/// common functions used by most Synopse projects // - this unit is a part of the freeware Synopse mORMot framework, // licensed under a MPL/GPL/LGPL tri-license; version 1.18 unit SynCommons; (* This file is part of Synopse framework. Synopse framework. Copyright (C) 2019 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** Version: MPL 1.1/GPL 2.0/LGPL 2.1 The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the specific language governing rights and limitations under the License. The Original Code is Synopse framework. The Initial Developer of the Original Code is Arnaud Bouchez. Portions created by the Initial Developer are Copyright (C) 2019 the Initial Developer. All Rights Reserved. Contributor(s): - Alan Chate - Aleksandr (sha) - Alfred Glaenzer (alf) - ASiwon - Chaa - BigStar - Eugene Ilyin - f-vicente - itSDS - Johan Bontes - kevinday - Maciej Izak (hnb) - Marius Maximus (mariuszekpl) - mazinsw - mingda - PBa - RalfS - Sanyin - Pavel (mpv) - Wloochacz - zed Alternatively, the contents of this file may be used under the terms of either the GNU General Public License Version 2 or later (the "GPL"), or the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), in which case the provisions of the GPL or the LGPL are applicable instead of those above. If you wish to allow use of your version of this file only under the terms of either the GPL or the LGPL, and not to allow others to use your version of this file under the terms of the MPL, indicate your decision by deleting the provisions above and replace them with the notice and other provisions required by the GPL or the LGPL. If you do not delete the provisions above, a recipient may use your version of this file under the terms of any one of the MPL, the GPL or the LGPL. ***** END LICENSE BLOCK ***** Version 1.18 - old version history has been cut down to maintain this huge unit under 65,000 lines, as required by Delphi 5 to avoid internal error PRO-3006 *) {$I Synopse.inc} // define HASINLINE USETYPEINFO CPU32 CPU64 OWNNORMTOUPPER interface uses {$ifdef WITH_FASTMM4STATS} FastMM4, {$endif} {$ifdef MSWINDOWS} Windows, Messages, {$ifndef LVCL} Registry, {$endif} {$else MSWINDOWS} {$ifdef KYLIX3} Types, LibC, SynKylix, {$endif KYLIX3} {$ifdef FPC} BaseUnix, {$endif FPC} {$endif MSWINDOWS} Classes, {$ifndef LVCL} SyncObjs, // for TEvent and TCriticalSection Contnrs, // for TObjectList {$ifdef HASINLINE} Types, {$endif HASINLINE} {$endif LVCL} {$ifndef NOVARIANTS} Variants, {$endif NOVARIANTS} SynLZ, // needed for TSynMapFile .mab format SysUtils; const /// the corresponding version of the freeware Synopse framework // - includes a commit increasing number (generated by SourceCodeRep tool) // - a similar constant shall be defined in SynCrtSock.pas SYNOPSE_FRAMEWORK_VERSION = {$I SynopseCommit.inc}; /// a text including the version and the main active conditional options // - usefull for low-level debugging purpose SYNOPSE_FRAMEWORK_FULLVERSION = SYNOPSE_FRAMEWORK_VERSION {$ifdef FPC} {$ifdef FPC_FASTMM4}+' FMM4'{$else} {$ifdef FPC_SYNTBB}+' TBB'{$else} {$ifdef FPC_SYNJEMALLOC}+' JM'{$else} {$ifdef FPC_SYNCMEM}+' GM'{$else} {$ifdef FPC_CMEM}+' CM'{$endif}{$endif}{$endif}{$endif}{$endif} {$else} {$ifdef LVCL}+' LVCL'{$else} {$ifdef ENHANCEDRTL}+' ERTL'{$endif}{$endif} {$ifdef DOPATCHTRTL}+' PRTL'{$endif} {$ifdef FullDebugMode}+' FDM'{$endif} {$endif FPC}; { ************ common types used for compatibility between compilers and CPU } const /// internal Code Page for UTF-16 Unicode encoding // - used e.g. for Delphi 2009+ UnicodeString=String type CP_UTF16 = 1200; /// fake code page used to recognize TSQLRawBlob // - as returned e.g. by TTypeInfo.AnsiStringCodePage from mORMot.pas CP_SQLRAWBLOB = 65534; /// internal Code Page for RawByteString undefined string CP_RAWBYTESTRING = 65535; /// US English Windows Code Page, i.e. WinAnsi standard character encoding CODEPAGE_US = 1252; /// Latin-1 ISO/IEC 8859-1 Code Page CODEPAGE_LATIN1 = 819; {$ifndef MSWINDOWS} /// internal Code Page for UTF-8 Unicode encoding CP_UTF8 = 65001; var /// contains the curent system code page (default WinAnsi) GetACP: integer = CODEPAGE_US; {$endif} {$ifdef FPC} { make cross-compiler and cross-CPU types available to Delphi } type PBoolean = ^Boolean; {$else FPC} type {$ifdef CPU64} // Delphi XE2 seems stable about those types (not Delphi 2009) PtrInt = NativeInt; PtrUInt = NativeUInt; {$else} /// a CPU-dependent signed integer type cast of a pointer / register // - used for 64-bit compatibility, native under Free Pascal Compiler PtrInt = integer; /// a CPU-dependent unsigned integer type cast of a pointer / register // - used for 64-bit compatibility, native under Free Pascal Compiler PtrUInt = cardinal; {$endif} /// a CPU-dependent unsigned integer type cast of a pointer of pointer // - used for 64-bit compatibility, native under Free Pascal Compiler PPtrUInt = ^PtrUInt; /// a CPU-dependent signed integer type cast of a pointer of pointer // - used for 64-bit compatibility, native under Free Pascal Compiler PPtrInt = ^PtrInt; /// unsigned Int64 doesn't exist under older Delphi, but is defined in FPC // - and UInt64 is buggy as hell under Delphi 2007 when inlining functions: // older compilers will fallback to signed Int64 values // - anyway, consider using SortDynArrayQWord() to compare QWord values // in a safe and efficient way, under a CPUX86 // - you may use UInt64 explicitly in your computation (like in SynEcc.pas), // if you are sure that Delphi 6-2007 compiler handles your code as expected, // but mORMot code will expect to use QWord for its internal process // (e.g. ORM/SOA serialization) {$ifdef UNICODE} QWord = UInt64; {$else} QWord = {$ifndef DELPHI5OROLDER}type{$endif} Int64; {$endif} /// points to an unsigned Int64 PQWord = ^QWord; {$ifndef ISDELPHIXE2} /// used to store the handle of a system Thread TThreadID = cardinal; {$endif} {$endif FPC} {$ifdef DELPHI6OROLDER} // some definitions not available prior to Delphi 7 type UInt64 = Int64; {$endif} {$ifdef DELPHI5OROLDER} // Delphi 5 doesn't have those basic types defined :( const varShortInt = $0010; varInt64 = $0014; { vt_i8 } soBeginning = soFromBeginning; soCurrent = soFromCurrent; reInvalidPtr = 2; PathDelim = '\'; sLineBreak = #13#10; type PPointer = ^Pointer; PPAnsiChar = ^PAnsiChar; PInteger = ^Integer; PCardinal = ^Cardinal; PWord = ^Word; PByte = ^Byte; PBoolean = ^Boolean; PDouble = ^Double; PComp = ^Comp; THandle = LongWord; PVarData = ^TVarData; TVarData = packed record // mostly used for varNull, varInt64, varDouble, varString and varAny VType: word; case Integer of 0: (Reserved1: Word; case Integer of 0: (Reserved2, Reserved3: Word; case Integer of varSmallInt: (VSmallInt: SmallInt); varInteger: (VInteger: Integer); varSingle: (VSingle: Single); varDouble: (VDouble: Double); // DOUBLE varCurrency: (VCurrency: Currency); varDate: (VDate: TDateTime); varOleStr: (VOleStr: PWideChar); varDispatch: (VDispatch: Pointer); varError: (VError: HRESULT); varBoolean: (VBoolean: WordBool); varUnknown: (VUnknown: Pointer); varByte: (VByte: Byte); varInt64: (VInt64: Int64); // INTEGER varString: (VString: Pointer); // TEXT varAny: (VAny: Pointer); varArray: (VArray: PVarArray); varByRef: (VPointer: Pointer); ); 1: (VLongs: array[0..2] of LongInt); ); end; {$endif} type /// RawUnicode is an Unicode String stored in an AnsiString // - faster than WideString, which are allocated in Global heap (for COM) // - an AnsiChar(#0) is added at the end, for having a true WideChar(#0) at ending // - length(RawUnicode) returns memory bytes count: use (length(RawUnicode) shr 1) // for WideChar count (that's why the definition of this type since Delphi 2009 // is AnsiString(1200) and not UnicodeString) // - pointer(RawUnicode) is compatible with Win32 'Wide' API call // - mimic Delphi 2009 UnicodeString, without the WideString or Ansi conversion overhead // - all conversion to/from AnsiString or RawUTF8 must be explicit: the // compiler is not able to make valid implicit conversion on CP_UTF16 {$ifdef HASCODEPAGE} RawUnicode = type AnsiString(CP_UTF16); // Codepage for an UnicodeString {$else} RawUnicode = type AnsiString; {$endif} /// RawUTF8 is an UTF-8 String stored in an AnsiString // - use this type instead of System.UTF8String, which behavior changed // between Delphi 2009 compiler and previous versions: our implementation // is consistent and compatible with all versions of Delphi compiler // - mimic Delphi 2009 UTF8String, without the charset conversion overhead // - all conversion to/from AnsiString or RawUnicode must be explicit {$ifdef HASCODEPAGE} RawUTF8 = type AnsiString(CP_UTF8); // Codepage for an UTF8 string {$else} RawUTF8 = type AnsiString; {$endif} /// WinAnsiString is a WinAnsi-encoded AnsiString (code page 1252) // - use this type instead of System.String, which behavior changed // between Delphi 2009 compiler and previous versions: our implementation // is consistent and compatible with all versions of Delphi compiler // - all conversion to/from RawUTF8 or RawUnicode must be explicit {$ifdef HASCODEPAGE} WinAnsiString = type AnsiString(CODEPAGE_US); // WinAnsi Codepage {$else} WinAnsiString = type AnsiString; {$endif} {$ifdef HASCODEPAGE} {$ifdef FPC} // missing declaration PRawByteString = ^RawByteString; {$endif} {$else} /// define RawByteString, as it does exist in Delphi 2009+ // - to be used for byte storage into an AnsiString // - use this type if you don't want the Delphi compiler not to do any // code page conversions when you assign a typed AnsiString to a RawByteString, // i.e. a RawUTF8 or a WinAnsiString RawByteString = type AnsiString; /// pointer to a RawByteString PRawByteString = ^RawByteString; {$endif} /// RawJSON will indicate that this variable content would stay in raw JSON // - i.e. won't be serialized into values // - could be any JSON content: number, string, object or array // - e.g. interface-based service will use it for efficient and AJAX-ready // transmission of TSQLTableJSON result RawJSON = type RawUTF8; /// SynUnicode is the fastest available Unicode native string type, depending // on the compiler used // - this type is native to the compiler, so you can use Length() Copy() and // such functions with it (this is not possible with RawUnicodeString type) // - before Delphi 2009+, it uses slow OLE compatible WideString // (with our Enhanced RTL, WideString allocation can be made faster by using // an internal caching mechanism of allocation buffers - WideString allocation // has been made much faster since Windows Vista/Seven) // - starting with Delphi 2009, it uses fastest UnicodeString type, which // allow Copy On Write, Reference Counting and fast heap memory allocation {$ifdef UNICODE} SynUnicode = UnicodeString; {$else} SynUnicode = WideString; {$endif} PRawUnicode = ^RawUnicode; PRawJSON = ^RawJSON; PRawUTF8 = ^RawUTF8; PWinAnsiString = ^WinAnsiString; PWinAnsiChar = type PAnsiChar; PSynUnicode = ^SynUnicode; /// a simple wrapper to UTF-8 encoded zero-terminated PAnsiChar // - PAnsiChar is used only for Win-Ansi encoded text // - the Synopse mORMot framework uses mostly this PUTF8Char type, // because all data is internaly stored and expected to be UTF-8 encoded PUTF8Char = type PAnsiChar; PPUTF8Char = ^PUTF8Char; /// a Row/Col array of PUTF8Char, for containing sqlite3_get_table() result TPUtf8CharArray = array[0..MaxInt div SizeOf(PUTF8Char)-1] of PUTF8Char; PPUtf8CharArray = ^TPUtf8CharArray; /// a dynamic array of PUTF8Char pointers TPUTF8CharDynArray = array of PUTF8Char; /// a dynamic array of UTF-8 encoded strings TRawUTF8DynArray = array of RawUTF8; PRawUTF8DynArray = ^TRawUTF8DynArray; TRawUTF8DynArrayDynArray = array of TRawUTF8DynArray; /// a dynamic array of TVarRec, i.e. could match an "array of const" parameter TTVarRecDynArray = array of TVarRec; {$ifndef NOVARIANTS} /// a TVarData values array // - is not called TVarDataArray to avoid confusion with the corresponding // type already defined in Variants.pas, and used for custom late-binding TVarDataStaticArray = array[0..MaxInt div SizeOf(TVarData)-1] of TVarData; PVarDataStaticArray = ^TVarDataStaticArray; TVariantArray = array[0..MaxInt div SizeOf(Variant)-1] of Variant; PVariantArray = ^TVariantArray; TVariantDynArray = array of variant; {$endif} PIntegerDynArray = ^TIntegerDynArray; TIntegerDynArray = array of integer; TIntegerDynArrayDynArray = array of TIntegerDynArray; PCardinalDynArray = ^TCardinalDynArray; TCardinalDynArray = array of cardinal; PSingleDynArray = ^TSingleDynArray; TSingleDynArray = array of Single; PInt64DynArray = ^TInt64DynArray; TInt64DynArray = array of Int64; PQwordDynArray = ^TQwordDynArray; TQwordDynArray = array of Qword; TPtrUIntDynArray = array of PtrUInt; PDoubleDynArray = ^TDoubleDynArray; TDoubleDynArray = array of double; PCurrencyDynArray = ^TCurrencyDynArray; TCurrencyDynArray = array of Currency; TWordDynArray = array of word; PWordDynArray = ^TWordDynArray; TByteDynArray = array of byte; PByteDynArray = ^TByteDynArray; TObjectDynArray = array of TObject; PObjectDynArray = ^TObjectDynArray; TPersistentDynArray = array of TPersistent; PPersistentDynArray = ^TPersistentDynArray; TPointerDynArray = array of pointer; PPointerDynArray = ^TPointerDynArray; TPPointerDynArray = array of PPointer; PPPointerDynArray = ^TPPointerDynArray; TMethodDynArray = array of TMethod; PMethodDynArray = ^TMethodDynArray; TObjectListDynArray = array of TObjectList; PObjectListDynArray = ^TObjectListDynArray; TFileNameDynArray = array of TFileName; PFileNameDynArray = ^TFileNameDynArray; TBooleanDynArray = array of boolean; PBooleanDynArray = ^TBooleanDynArray; TClassDynArray = array of TClass; TWinAnsiDynArray = array of WinAnsiString; PWinAnsiDynArray = ^TWinAnsiDynArray; TRawByteStringDynArray = array of RawByteString; TStringDynArray = array of string; PStringDynArray = ^TStringDynArray; PShortStringDynArray = array of PShortString; PPShortStringArray = ^PShortStringArray; TShortStringDynArray = array of ShortString; TDateTimeDynArray = array of TDateTime; PDateTimeDynArray = ^TDateTimeDynArray; TWideStringDynArray = array of WideString; PWideStringDynArray = ^TWideStringDynArray; TSynUnicodeDynArray = array of SynUnicode; PSynUnicodeDynArray = ^TSynUnicodeDynArray; TGUIDDynArray = array of TGUID; PObject = ^TObject; PClass = ^TClass; PByteArray = ^TByteArray; TByteArray = array[0..MaxInt-1] of Byte; // redefine here with {$R-} PBooleanArray = ^TBooleanArray; TBooleanArray = array[0..MaxInt-1] of Boolean; TWordArray = array[0..MaxInt div SizeOf(word)-1] of word; PWordArray = ^TWordArray; TIntegerArray = array[0..MaxInt div SizeOf(integer)-1] of integer; PIntegerArray = ^TIntegerArray; PIntegerArrayDynArray = array of PIntegerArray; TPIntegerArray = array[0..MaxInt div SizeOf(PIntegerArray)-1] of PInteger; PPIntegerArray = ^TPIntegerArray; TCardinalArray = array[0..MaxInt div SizeOf(cardinal)-1] of cardinal; PCardinalArray = ^TCardinalArray; TInt64Array = array[0..MaxInt div SizeOf(Int64)-1] of Int64; PInt64Array = ^TInt64Array; TQWordArray = array[0..MaxInt div SizeOf(QWord)-1] of QWord; PQWordArray = ^TQWordArray; TPtrUIntArray = array[0..MaxInt div SizeOf(PtrUInt)-1] of PtrUInt; PPtrUIntArray = ^TPtrUIntArray; TSmallIntArray = array[0..MaxInt div SizeOf(SmallInt)-1] of SmallInt; PSmallIntArray = ^TSmallIntArray; TSingleArray = array[0..MaxInt div SizeOf(Single)-1] of Single; PSingleArray = ^TSingleArray; TDoubleArray = array[0..MaxInt div SizeOf(Double)-1] of Double; PDoubleArray = ^TDoubleArray; TDateTimeArray = array[0..MaxInt div SizeOf(TDateTime)-1] of TDateTime; PDateTimeArray = ^TDateTimeArray; TPAnsiCharArray = array[0..MaxInt div SizeOf(PAnsiChar)-1] of PAnsiChar; PPAnsiCharArray = ^TPAnsiCharArray; TRawUTF8Array = array[0..MaxInt div SizeOf(RawUTF8)-1] of RawUTF8; PRawUTF8Array = ^TRawUTF8Array; TRawByteStringArray = array[0..MaxInt div SizeOf(RawByteString)-1] of RawByteString; PRawByteStringArray = ^TRawByteStringArray; PShortStringArray = array[0..MaxInt div SizeOf(pointer)-1] of PShortString; PointerArray = array [0..MaxInt div SizeOf(Pointer)-1] of Pointer; PPointerArray = ^PointerArray; TObjectArray = array [0..MaxInt div SizeOf(TObject)-1] of TObject; PObjectArray = ^TObjectArray; TPtrIntArray = array[0..MaxInt div SizeOf(PtrInt)-1] of PtrInt; PPtrIntArray = ^TPtrIntArray; PInt64Rec = ^Int64Rec; PPShortString = ^PShortString; {$ifndef DELPHI5OROLDER} PIInterface = ^IInterface; TInterfaceDynArray = array of IInterface; PInterfaceDynArray = ^TInterfaceDynArray; {$endif} {$ifndef LVCL} TCollectionClass = class of TCollection; TCollectionItemClass = class of TCollectionItem; {$endif} /// class-reference type (metaclass) of a TStream TStreamClass = class of TStream; /// class-reference type (metaclass) of a TInterfacedObject TInterfacedObjectClass = class of TInterfacedObject; { ************ fast UTF-8 / Unicode / Ansi types and conversion routines **** } type {$ifndef ISDELPHI2007ANDUP} TBytes = array of byte; {$endif} /// kind of adding in a TTextWriter TTextWriterKind = (twNone, twJSONEscape, twOnSameLine); /// an abstract class to handle Ansi to/from Unicode translation // - implementations of this class will handle efficiently all Code Pages // - this default implementation will use the Operating System APIs // - you should not create your own class instance by yourself, but should // better retrieve an instance using TSynAnsiConvert.Engine(), which will // initialize either a TSynAnsiFixedWidth or a TSynAnsiConvert instance on need TSynAnsiConvert = class protected fCodePage: cardinal; fAnsiCharShift: byte; {$ifdef KYLIX3} fIConvCodeName: RawUTF8; {$endif} procedure InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; DestTextWriter: TObject; Escape: TTextWriterKind); virtual; public /// initialize the internal conversion engine constructor Create(aCodePage: cardinal); reintroduce; virtual; /// returns the engine corresponding to a given code page // - a global list of TSynAnsiConvert instances is handled by the unit - // therefore, caller should not release the returned instance // - will return nil in case of unhandled code page // - is aCodePage is 0, will return CurrentAnsiConvert value class function Engine(aCodePage: cardinal): TSynAnsiConvert; /// direct conversion of a PAnsiChar buffer into an Unicode buffer // - Dest^ buffer must be reserved with at least SourceChars*2 bytes // - this default implementation will use the Operating System APIs // - will append a trailing #0 to the returned PWideChar, unless // NoTrailingZero is set function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; overload; virtual; /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded buffer // - Dest^ buffer must be reserved with at least SourceChars*3 bytes // - will append a trailing #0 to the returned PUTF8Char, unless // NoTrailingZero is set // - this default implementation will use the Operating System APIs function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; overload; virtual; /// convert any Ansi Text into an UTF-16 Unicode String // - returns a value using our RawUnicode kind of string function AnsiToRawUnicode(const AnsiText: RawByteString): RawUnicode; overload; /// convert any Ansi buffer into an Unicode String // - returns a value using our RawUnicode kind of string function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; overload; virtual; /// convert any Ansi buffer into an Unicode String // - returns a SynUnicode, i.e. Delphi 2009+ UnicodeString or a WideString function AnsiToUnicodeString(Source: PAnsiChar; SourceChars: Cardinal): SynUnicode; overload; /// convert any Ansi buffer into an Unicode String // - returns a SynUnicode, i.e. Delphi 2009+ UnicodeString or a WideString function AnsiToUnicodeString(const Source: RawByteString): SynUnicode; overload; /// convert any Ansi Text into an UTF-8 encoded String // - internaly calls AnsiBufferToUTF8 virtual method function AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; virtual; /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded string // - will call AnsiBufferToUnicode() overloaded virtual method function AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; overload; virtual; /// direct conversion of an Unicode buffer into a PAnsiChar buffer // - Dest^ buffer must be reserved with at least SourceChars*3 bytes // - this default implementation will rely on the Operating System for // all non ASCII-7 chars function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; overload; virtual; /// direct conversion of an Unicode buffer into an Ansi Text function UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString; overload; virtual; /// convert any Unicode-encoded String into Ansi Text // - internaly calls UnicodeBufferToAnsi virtual method function RawUnicodeToAnsi(const Source: RawUnicode): RawByteString; /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar buffer // - Dest^ buffer must be reserved with at least SourceChars bytes // - no trailing #0 is appended to the buffer function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; overload; virtual; /// convert any UTF-8 encoded buffer into Ansi Text // - internaly calls UTF8BufferToAnsi virtual method function UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal): RawByteString; overload; {$ifdef HASINLINE}inline;{$endif} /// convert any UTF-8 encoded buffer into Ansi Text // - internaly calls UTF8BufferToAnsi virtual method procedure UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal; var result: RawByteString); overload; virtual; /// convert any UTF-8 encoded String into Ansi Text // - internaly calls UTF8BufferToAnsi virtual method function UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; virtual; /// direct conversion of a UTF-8 encoded string into a WinAnsi buffer // - will truncate the destination string to DestSize bytes (including the // trailing #0), with a maximum handled size of 2048 bytes // - returns the number of bytes stored in Dest^ (i.e. the position of #0) function Utf8ToAnsiBuffer(const S: RawUTF8; Dest: PAnsiChar; DestSize: integer): integer; /// convert any Ansi Text (providing a From converted) into Ansi Text function AnsiToAnsi(From: TSynAnsiConvert; const Source: RawByteString): RawByteString; overload; /// convert any Ansi buffer (providing a From converted) into Ansi Text function AnsiToAnsi(From: TSynAnsiConvert; Source: PAnsiChar; SourceChars: cardinal): RawByteString; overload; /// corresponding code page property CodePage: Cardinal read fCodePage; end; /// a class to handle Ansi to/from Unicode translation of fixed width encoding // (i.e. non MBCS) // - this class will handle efficiently all Code Page availables without MBCS // encoding - like WinAnsi (1252) or Russian (1251) // - it will use internal fast look-up tables for such encodings // - this class could take some time to generate, and will consume more than // 64 KB of memory: you should not create your own class instance by yourself, // but should better retrieve an instance using TSynAnsiConvert.Engine(), which // will initialize either a TSynAnsiFixedWidth or a TSynAnsiConvert instance // on need // - this class has some additional methods (e.g. IsValid*) which take // advantage of the internal lookup tables to provide some fast process TSynAnsiFixedWidth = class(TSynAnsiConvert) protected fAnsiToWide: TWordDynArray; fWideToAnsi: TByteDynArray; procedure InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; DestTextWriter: TObject; Escape: TTextWriterKind); override; public /// initialize the internal conversion engine constructor Create(aCodePage: cardinal); override; /// direct conversion of a PAnsiChar buffer into an Unicode buffer // - Dest^ buffer must be reserved with at least SourceChars*2 bytes // - will append a trailing #0 to the returned PWideChar, unless // NoTrailingZero is set function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; override; /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded buffer // - Dest^ buffer must be reserved with at least SourceChars*3 bytes // - will append a trailing #0 to the returned PUTF8Char, unless // NoTrailingZero is set function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; override; /// convert any Ansi buffer into an Unicode String // - returns a value using our RawUnicode kind of string function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; override; /// direct conversion of an Unicode buffer into a PAnsiChar buffer // - Dest^ buffer must be reserved with at least SourceChars*3 bytes // - this overridden version will use internal lookup tables for fast process function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; override; /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar buffer // - Dest^ buffer must be reserved with at least SourceChars bytes // - no trailing #0 is appended to the buffer function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; override; /// conversion of a wide char into the corresponding Ansi character // - return -1 for an unknown WideChar in the current code page function WideCharToAnsiChar(wc: cardinal): integer; /// return TRUE if the supplied unicode buffer only contains characters of // the corresponding Ansi code page // - i.e. if the text can be displayed using this code page function IsValidAnsi(WideText: PWideChar; Length: integer): boolean; overload; /// return TRUE if the supplied unicode buffer only contains characters of // the corresponding Ansi code page // - i.e. if the text can be displayed using this code page function IsValidAnsi(WideText: PWideChar): boolean; overload; /// return TRUE if the supplied UTF-8 buffer only contains characters of // the corresponding Ansi code page // - i.e. if the text can be displayed using this code page function IsValidAnsiU(UTF8Text: PUTF8Char): boolean; /// return TRUE if the supplied UTF-8 buffer only contains 8 bits characters // of the corresponding Ansi code page // - i.e. if the text can be displayed with only 8 bit unicode characters // (e.g. no "tm" or such) within this code page function IsValidAnsiU8Bit(UTF8Text: PUTF8Char): boolean; /// direct access to the Ansi-To-Unicode lookup table // - use this array like AnsiToWide: array[byte] of word property AnsiToWide: TWordDynArray read fAnsiToWide; /// direct access to the Unicode-To-Ansi lookup table // - use this array like WideToAnsi: array[word] of byte // - any unhandled WideChar will return ord('?') property WideToAnsi: TByteDynArray read fWideToAnsi; end; /// a class to handle UTF-8 to/from Unicode translation // - match the TSynAnsiConvert signature, for code page CP_UTF8 // - this class is mostly a non-operation for conversion to/from UTF-8 TSynAnsiUTF8 = class(TSynAnsiConvert) private function UnicodeBufferToUTF8(Dest: PAnsiChar; DestChars: Cardinal; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; protected procedure InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; DestTextWriter: TObject; Escape: TTextWriterKind); override; public /// initialize the internal conversion engine constructor Create(aCodePage: cardinal); override; /// direct conversion of a PAnsiChar UTF-8 buffer into an Unicode buffer // - Dest^ buffer must be reserved with at least SourceChars*2 bytes // - will append a trailing #0 to the returned PWideChar, unless // NoTrailingZero is set function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; override; /// direct conversion of a PAnsiChar UTF-8 buffer into a UTF-8 encoded buffer // - Dest^ buffer must be reserved with at least SourceChars*3 bytes // - will append a trailing #0 to the returned PUTF8Char, unless // NoTrailingZero is set function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; override; /// convert any UTF-8 Ansi buffer into an Unicode String // - returns a value using our RawUnicode kind of string function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; override; /// direct conversion of an Unicode buffer into a PAnsiChar UTF-8 buffer // - Dest^ buffer must be reserved with at least SourceChars*3 bytes function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; override; /// direct conversion of an Unicode buffer into an Ansi Text function UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString; override; /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar UTF-8 buffer // - Dest^ buffer must be reserved with at least SourceChars bytes // - no trailing #0 is appended to the buffer function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; override; /// convert any UTF-8 encoded buffer into Ansi Text procedure UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal; var result: RawByteString); override; /// convert any UTF-8 encoded String into Ansi Text // - directly assign the input as result, since no conversion is needed function UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; override; /// convert any Ansi Text into an UTF-8 encoded String // - directly assign the input as result, since no conversion is needed function AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; override; /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded string function AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; override; end; /// a class to handle UTF-16 to/from Unicode translation // - match the TSynAnsiConvert signature, for code page CP_UTF16 // - even if UTF-16 is not an Ansi format, code page CP_UTF16 may have been // used to store UTF-16 encoded binary content // - this class is mostly a non-operation for conversion to/from Unicode TSynAnsiUTF16 = class(TSynAnsiConvert) public /// initialize the internal conversion engine constructor Create(aCodePage: cardinal); override; /// direct conversion of a PAnsiChar UTF-16 buffer into an Unicode buffer // - Dest^ buffer must be reserved with at least SourceChars*2 bytes // - will append a trailing #0 to the returned PWideChar, unless // NoTrailingZero is set function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; override; /// direct conversion of a PAnsiChar UTF-16 buffer into a UTF-8 encoded buffer // - Dest^ buffer must be reserved with at least SourceChars*3 bytes // - will append a trailing #0 to the returned PUTF8Char, unless // NoTrailingZero is set function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; override; /// convert any UTF-16 Ansi buffer into an Unicode String // - returns a value using our RawUnicode kind of string function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; override; /// direct conversion of an Unicode buffer into a PAnsiChar UTF-16 buffer // - Dest^ buffer must be reserved with at least SourceChars*3 bytes function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; override; /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar UTF-16 buffer // - Dest^ buffer must be reserved with at least SourceChars bytes // - no trailing #0 is appended to the buffer function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; override; end; /// implements a stack-based storage of some (UTF-8 or binary) text // - could be used e.g. to make a temporary copy when JSON is parsed in-place // - call one of the Init() overloaded methods, then Done to release its memory // - will avoid temporary memory allocation via the heap for up to 4KB of data // - all Init() methods will allocate 16 more bytes, for a trailing #0 and // to ensure our fast JSON parsing won't trigger any GPF (since it may read // up to 4 bytes ahead via its PInteger() trick) or any SSE4.2 function {$ifdef FPC_OR_UNICODE}TSynTempBuffer = record{$else}TSynTempBuffer = object{$endif} public /// the text/binary length, in bytes, excluding the trailing #0 len: integer; /// where the text/binary is available (and any Source has been copied) // - equals nil if len=0 buf: pointer; /// initialize a temporary copy of the content supplied as RawByteString // - will also allocate and copy the ending #0 (even for binary) procedure Init(const Source: RawByteString); overload; /// initialize a temporary copy of the supplied text buffer, ending with #0 function Init(Source: PUTF8Char): PUTF8Char; overload; /// initialize a temporary copy of the supplied text buffer procedure Init(Source: pointer; SourceLen: integer); overload; /// initialize a new temporary buffer of a given number of bytes function Init(SourceLen: integer): pointer; overload; {$ifdef HASINLINE}inline;{$endif} /// initialize the buffer returning the internal buffer size (4095 bytes) // - could be used e.g. for an API call, first trying with plain temp.Init // and using temp.buf and temp.len safely in the call, only calling // temp.Init(expectedsize) if the API returned an error about an insufficient // buffer space function Init: integer; overload; {$ifdef HASINLINE}inline;{$endif} /// initialize a new temporary buffer of a given number of random bytes // - will fill the buffer via FillRandom() calls function InitRandom(RandomLen: integer; forcegsl: boolean=true): pointer; /// initialize a new temporary buffer filled with integer increasing values function InitIncreasing(Count: integer; Start: integer=0): PIntegerArray; /// initialize a new temporary buffer of a given number of zero bytes function InitZero(ZeroLen: integer): pointer; /// finalize the temporary storage procedure Done; overload; {$ifdef HASINLINE}inline;{$endif} /// finalize the temporary storage, and create a RawUTF8 string from it procedure Done(EndBuf: pointer; var Dest: RawUTF8); overload; {$ifdef HASINLINE}inline;{$endif} private // default 4KB buffer allocated on stack tmp: array[0..4095] of AnsiChar; end; /// implements a stack-based writable storage of binary content // - memory allocation is performed via a TSynTempBuffer {$ifdef FPC_OR_UNICODE}TSynTempWriter = record private {$else}TSynTempWriter = object protected{$endif} tmp: TSynTempBuffer; public /// the current writable position in tmp.buf pos: PAnsiChar; /// initialize a new temporary buffer of a given number of bytes // - if maxsize is left to its 0 default value, the default stack-allocated // memory size is used, i.e. 4 KB procedure Init(maxsize: integer=0); /// finalize the temporary storage procedure Done; /// append some binary to the internal buffer // - will raise an ESynException in case of potential overflow procedure wr(const val; len: integer); /// append some shortstring as binary to the internal buffer procedure wrss(const str: shortstring); /// append some 8-bit value as binary to the internal buffer procedure wrb(b: byte); /// append some 16-bit value as binary to the internal buffer procedure wrw(w: word); /// append some 32-bit value as binary to the internal buffer procedure wrint(int: integer); /// append some 32-bit/64-bit pointer value as binary to the internal buffer procedure wrptr(ptr: pointer); /// append some 32-bit/64-bit integer as binary to the internal buffer procedure wrptrint(int: PtrInt); /// append some fixed-value bytes as binary to the internal buffer // - returns a pointer to the first byte of the added memory chunk function wrfillchar(count: integer; value: byte): PAnsiChar; /// returns the current offset position in the internal buffer function Position: integer; /// returns the buffer as a RawByteString instance function AsBinary: RawByteString; end; /// function prototype to be used for hashing of an element // - it must return a cardinal hash, with as less collision as possible // - TDynArrayHashed.Init will use crc32c() if no custom function is supplied, // which will run either as software or SSE4.2 hardware, with good colision // for most used kind of data THasher = function(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; var /// global TSynAnsiConvert instance to handle WinAnsi encoding (code page 1252) // - this instance is global and instantied during the whole program life time // - it will be created from hard-coded values, and not using the system API, // since it appeared that some systems (e.g. in Russia) did tweak the registry // so that 1252 code page maps 1251 code page WinAnsiConvert: TSynAnsiFixedWidth; /// global TSynAnsiConvert instance to handle current system encoding // - this is the encoding as used by the AnsiString Delphi, so will be used // before Delphi 2009 to speed-up VCL string handling (especially for UTF-8) // - this instance is global and instantied during the whole program life time CurrentAnsiConvert: TSynAnsiConvert; /// global TSynAnsiConvert instance to handle UTF-8 encoding (code page CP_UTF8) // - this instance is global and instantied during the whole program life time UTF8AnsiConvert: TSynAnsiUTF8; const /// HTTP header name for the content type, as defined in the corresponding RFC HEADER_CONTENT_TYPE = 'Content-Type: '; /// HTTP header name for the content type, in upper case // - as defined in the corresponding RFC // - could be used e.g. with IdemPChar() to retrieve the Content-Type value HEADER_CONTENT_TYPE_UPPER = 'CONTENT-TYPE: '; /// HTTP header name for the client IP, in upper case // - as defined in our HTTP server classes // - could be used e.g. with IdemPChar() to retrieve the remote IP address HEADER_REMOTEIP_UPPER = 'REMOTEIP: '; /// HTTP header name for the authorization token, in upper case // - could be used e.g. with IdemPChar() to retrieve a JWT value HEADER_BEARER_UPPER = 'AUTHORIZATION: BEARER '; /// MIME content type used for JSON communication (as used by the Microsoft // WCF framework and the YUI framework) JSON_CONTENT_TYPE = 'application/json; charset=UTF-8'; /// HTTP header for MIME content type used for plain JSON JSON_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+JSON_CONTENT_TYPE; /// MIME content type used for plain JSON, in upper case // - could be used e.g. with IdemPChar() to retrieve the Content-Type value JSON_CONTENT_TYPE_UPPER = 'APPLICATION/JSON'; /// HTTP header for MIME content type used for plain JSON, in upper case // - could be used e.g. with IdemPChar() to retrieve the Content-Type value JSON_CONTENT_TYPE_HEADER_UPPER = HEADER_CONTENT_TYPE_UPPER+JSON_CONTENT_TYPE_UPPER; /// MIME content type used for plain UTF-8 text TEXT_CONTENT_TYPE = 'text/plain; charset=UTF-8'; /// HTTP header for MIME content type used for plain UTF-8 text TEXT_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+TEXT_CONTENT_TYPE; /// MIME content type used for UTF-8 encoded HTML HTML_CONTENT_TYPE = 'text/html; charset=UTF-8'; /// HTTP header for MIME content type used for UTF-8 encoded HTML HTML_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+HTML_CONTENT_TYPE; /// MIME content type used for UTF-8 encoded XML XML_CONTENT_TYPE = 'text/xml; charset=UTF-8'; /// HTTP header for MIME content type used for UTF-8 encoded XML XML_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+XML_CONTENT_TYPE; /// MIME content type used for raw binary data BINARY_CONTENT_TYPE = 'application/octet-stream'; /// MIME content type used for raw binary data, in upper case BINARY_CONTENT_TYPE_UPPER = 'APPLICATION/OCTET-STREAM'; /// HTTP header for MIME content type used for raw binary data BINARY_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+BINARY_CONTENT_TYPE; /// MIME content type used for a JPEG picture JPEG_CONTENT_TYPE = 'image/jpeg'; var /// MIME content type used for JSON communication // - this global will be initialized with JSON_CONTENT_TYPE constant, to // avoid a memory allocation each time it is assigned to a variable JSON_CONTENT_TYPE_VAR: RawUTF8; /// HTTP header for MIME content type used for plain JSON // - this global will be initialized with JSON_CONTENT_TYPE_HEADER constant, // to avoid a memory allocation each time it is assigned to a variable JSON_CONTENT_TYPE_HEADER_VAR: RawUTF8; /// can be used to avoid a memory allocation for res := 'null' NULL_STR_VAR: RawUTF8; /// compute the new capacity when expanding an array of items // - handle small, medium and large sizes properly to reduce memory usage and // maximize performance function NextGrow(capacity: integer): integer; /// equivalence to SetString(s,nil,len) function // - faster especially under FPC procedure FastSetString(var s: RawUTF8; p: pointer; len: PtrInt); /// equivalence to SetString(s,nil,len) function with a specific code page // - faster especially under FPC procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt); /// initialize a RawByteString, ensuring returned "aligned" pointer is 16-bytes aligned // - to be used e.g. for proper SSE process procedure GetMemAligned(var s: RawByteString; p: pointer; len: PtrInt; out aligned: pointer); /// equivalence to @UTF8[1] expression to ensure a RawUTF8 variable is unique // - will ensure that the string refcount is 1, and return a pointer to the text // - under FPC, @UTF8[1] does not call UniqueString() as it does with Delphi // - if UTF8 is a constant (refcount=-1), will create a temporary copy in heap function UniqueRawUTF8(var UTF8: RawUTF8): pointer; {$ifdef HASINLINE}inline;{$endif} /// will fast replace all #0 chars as ~ // - could be used after UniqueRawUTF8() on a in-placed modified JSON buffer, // in which all values have been ended with #0 // - you can optionally specify a maximum size, in bytes (this won't reallocate // the string, but just add a #0 at some point in the UTF8 buffer) // - could allow logging of parsed input e.g. after an exception procedure UniqueRawUTF8ZeroToTilde(var UTF8: RawUTF8; MaxSize: integer=maxInt); /// conversion of a wide char into a WinAnsi (CodePage 1252) char // - return '?' for an unknown WideChar in code page 1252 function WideCharToWinAnsiChar(wc: cardinal): AnsiChar; {$ifdef HASINLINE}inline;{$endif} /// conversion of a wide char into a WinAnsi (CodePage 1252) char index // - return -1 for an unknown WideChar in code page 1252 function WideCharToWinAnsi(wc: cardinal): integer; {$ifdef HASINLINE}inline;{$endif} /// return TRUE if the supplied buffer only contains 7-bits Ansi characters function IsAnsiCompatible(PC: PAnsiChar): boolean; overload; /// return TRUE if the supplied buffer only contains 7-bits Ansi characters function IsAnsiCompatible(PC: PAnsiChar; Len: integer): boolean; overload; /// return TRUE if the supplied buffer only contains 7-bits Ansi characters function IsAnsiCompatible(PW: PWideChar): boolean; overload; /// return TRUE if the supplied text only contains 7-bits Ansi characters function IsAnsiCompatible(const Text: RawByteString): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// return TRUE if the supplied buffer only contains 7-bits Ansi characters function IsAnsiCompatible(PW: PWideChar; Len: integer): boolean; overload; /// return TRUE if the supplied unicode buffer only contains WinAnsi characters // - i.e. if the text can be displayed using ANSI_CHARSET function IsWinAnsi(WideText: PWideChar): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// return TRUE if the supplied unicode buffer only contains WinAnsi characters // - i.e. if the text can be displayed using ANSI_CHARSET function IsWinAnsi(WideText: PWideChar; Length: integer): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// return TRUE if the supplied UTF-8 buffer only contains WinAnsi characters // - i.e. if the text can be displayed using ANSI_CHARSET function IsWinAnsiU(UTF8Text: PUTF8Char): boolean; {$ifdef HASINLINE}inline;{$endif} /// return TRUE if the supplied UTF-8 buffer only contains WinAnsi 8 bit characters // - i.e. if the text can be displayed using ANSI_CHARSET with only 8 bit unicode // characters (e.g. no "tm" or such) function IsWinAnsiU8Bit(UTF8Text: PUTF8Char): boolean; {$ifdef HASINLINE}inline;{$endif} /// UTF-8 encode one UTF-16 character into Dest // - return the number of bytes written into Dest (i.e. 1,2 or 3) // - this method does NOT handle UTF-16 surrogate pairs function WideCharToUtf8(Dest: PUTF8Char; aWideChar: PtrUInt): integer; {$ifdef HASINLINE}inline;{$endif} /// UTF-8 encode one UTF-16 encoded UCS4 character into Dest // - return the number of bytes written into Dest (i.e. from 1 up to 6) // - Source will contain the next UTF-16 character // - this method DOES handle UTF-16 surrogate pairs function UTF16CharToUtf8(Dest: PUTF8Char; var Source: PWord): integer; /// UTF-8 encode one UCS4 character into Dest // - return the number of bytes written into Dest (i.e. from 1 up to 6) // - this method DOES handle UTF-16 surrogate pairs function UCS4ToUTF8(ucs4: cardinal; Dest: PUTF8Char): integer; /// direct conversion of an AnsiString with an unknown code page into an // UTF-8 encoded String // - will assume CurrentAnsiConvert.CodePage prior to Delphi 2009 // - newer UNICODE versions of Delphi will retrieve the code page from string procedure AnyAnsiToUTF8(const s: RawByteString; var result: RawUTF8); overload; /// direct conversion of an AnsiString with an unknown code page into an // UTF-8 encoded String // - will assume CurrentAnsiConvert.CodePage prior to Delphi 2009 // - newer UNICODE versions of Delphi will retrieve the code page from string function AnyAnsiToUTF8(const s: RawByteString): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// direct conversion of a WinAnsi (CodePage 1252) string into a UTF-8 encoded String // - faster than SysUtils: don't use Utf8Encode(WideString) -> no Windows.Global(), // and use a fixed pre-calculated array for individual chars conversion function WinAnsiToUtf8(const S: WinAnsiString): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// direct conversion of a WinAnsi (CodePage 1252) string into a UTF-8 encoded String // - faster than SysUtils: don't use Utf8Encode(WideString) -> no Windows.Global(), // and use a fixed pre-calculated array for individual chars conversion function WinAnsiToUtf8(WinAnsi: PAnsiChar; WinAnsiLen: integer): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// direct conversion of a WinAnsi PAnsiChar buffer into a UTF-8 encoded buffer // - Dest^ buffer must be reserved with at least SourceChars*3 // - call internally WinAnsiConvert fast conversion class function WinAnsiBufferToUtf8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal): PUTF8Char; {$ifdef HASINLINE}inline;{$endif} /// direct conversion of a WinAnsi shortstring into a UTF-8 text // - call internally WinAnsiConvert fast conversion class function ShortStringToUTF8(const source: ShortString): RawUTF8; {$ifdef HASINLINE}inline;{$endif} /// direct conversion of a WinAnsi (CodePage 1252) string into a Unicode encoded String // - very fast, by using a fixed pre-calculated array for individual chars conversion function WinAnsiToRawUnicode(const S: WinAnsiString): RawUnicode; /// direct conversion of a WinAnsi (CodePage 1252) string into a Unicode buffer // - very fast, by using a fixed pre-calculated array for individual chars conversion // - text will be truncated if necessary to avoid buffer overflow in Dest[] procedure WinAnsiToUnicodeBuffer(const S: WinAnsiString; Dest: PWordArray; DestLen: integer); {$ifdef HASINLINE}inline;{$endif} /// direct conversion of a UTF-8 encoded string into a WinAnsi String function Utf8ToWinAnsi(const S: RawUTF8): WinAnsiString; overload; {$ifdef HASINLINE}inline;{$endif} /// direct conversion of a UTF-8 encoded zero terminated buffer into a WinAnsi String function Utf8ToWinAnsi(P: PUTF8Char): WinAnsiString; overload; {$ifdef HASINLINE}inline;{$endif} /// direct conversion of a UTF-8 encoded zero terminated buffer into a RawUTF8 String procedure Utf8ToRawUTF8(P: PUTF8Char; var result: RawUTF8); {$ifdef HASINLINE}inline;{$endif} /// direct conversion of a UTF-8 encoded buffer into a WinAnsi PAnsiChar buffer function UTF8ToWinPChar(dest: PAnsiChar; source: PUTF8Char; count: integer): integer; {$ifdef HASINLINE}inline;{$endif} /// direct conversion of a UTF-8 encoded buffer into a WinAnsi shortstring buffer procedure UTF8ToShortString(var dest: shortstring; source: PUTF8Char); /// direct conversion of an ANSI-7 shortstring into an AnsiString // - can be used e.g. for names retrieved from RTTI to convert them into RawUTF8 function ShortStringToAnsi7String(const source: shortstring): RawByteString; overload; {$ifdef HASINLINE}inline;{$endif} /// direct conversion of an ANSI-7 shortstring into an AnsiString // - can be used e.g. for names retrieved from RTTI to convert them into RawUTF8 procedure ShortStringToAnsi7String(const source: shortstring; var result: RawUTF8); overload; {$ifdef HASINLINE}inline;{$endif} /// convert an UTF-8 encoded text into a WideChar (UTF-16) buffer // - faster than System.UTF8ToUnicode // - sourceBytes can by 0, therefore length is computed from zero terminated source // - enough place must be available in dest buffer (guess is sourceBytes*3+2) // - a WideChar(#0) is added at the end (if something is written) unless // NoTrailingZero is TRUE // - returns the BYTE count written in dest, excluding the ending WideChar(#0) function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; sourceBytes: PtrInt=0; NoTrailingZero: boolean=false): PtrInt; overload; /// convert an UTF-8 encoded text into a WideChar (UTF-16) buffer // - faster than System.UTF8ToUnicode // - this overloaded function expect a MaxDestChars parameter // - sourceBytes can not be 0 for this function // - enough place must be available in dest buffer (guess is sourceBytes*3+2) // - a WideChar(#0) is added at the end (if something is written) unless // NoTrailingZero is TRUE // - returns the BYTE COUNT (not WideChar count) written in dest, excluding the // ending WideChar(#0) function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; MaxDestChars, sourceBytes: PtrInt; NoTrailingZero: boolean=false): PtrInt; overload; /// calculate the UTF-16 Unicode characters count, UTF-8 encoded in source^ // - count may not match the UCS4 glyphs number, in case of UTF-16 surrogates // - faster than System.UTF8ToUnicode with dest=nil function Utf8ToUnicodeLength(source: PUTF8Char): PtrUInt; /// returns TRUE if the supplied buffer has valid UTF-8 encoding // - 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 function IsValidUTF8WithoutControlChars(source: PUTF8Char): Boolean; overload; /// returns TRUE if the supplied buffer has valid UTF-8 encoding with no #0..#31 // control characters // - supplied input is a RawUTF8 variable function IsValidUTF8WithoutControlChars(const source: RawUTF8): Boolean; overload; /// will truncate the supplied UTF-8 value if its length exceeds the specified // UTF-16 Unicode characters count // - count may not match the UCS4 glyphs number, in case of UTF-16 surrogates // - returns FALSE if text was not truncated, TRUE otherwise function Utf8TruncateToUnicodeLength(var text: RawUTF8; maxUtf16: integer): boolean; /// will truncate the supplied UTF-8 value if its length exceeds the specified // bytes count // - this function will ensure that the returned content will contain only valid // UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence // - returns FALSE if text was not truncated, TRUE otherwise function Utf8TruncateToLength(var text: RawUTF8; maxBytes: cardinal): boolean; /// compute the truncated length of the supplied UTF-8 value if it exceeds the // specified bytes count // - this function will ensure that the returned content will contain only valid // UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence // - returns maxUTF8 if text was not truncated, or the number of fitting bytes function Utf8TruncatedLength(const text: RawUTF8; maxBytes: cardinal): integer; overload; /// compute the truncated length of the supplied UTF-8 value if it exceeds the // specified bytes count // - this function will ensure that the returned content will contain only valid // UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence // - returns maxUTF8 if text was not truncated, or the number of fitting bytes function Utf8TruncatedLength(text: PAnsiChar; textlen,maxBytes: cardinal): integer; overload; /// calculate the UTF-16 Unicode characters count of the UTF-8 encoded first line // - count may not match the UCS4 glyphs number, in case of UTF-16 surrogates // - end the parsing at first #13 or #10 character function Utf8FirstLineToUnicodeLength(source: PUTF8Char): PtrInt; /// convert a UTF-8 encoded buffer into a RawUnicode string // - if L is 0, L is computed from zero terminated P buffer // - RawUnicode is ended by a WideChar(#0) // - faster than System.Utf8Decode() which uses slow widestrings function Utf8DecodeToRawUnicode(P: PUTF8Char; L: integer): RawUnicode; overload; /// convert a UTF-8 string into a RawUnicode string function Utf8DecodeToRawUnicode(const S: RawUTF8): RawUnicode; overload; {$ifdef HASINLINE}inline;{$endif} /// convert a UTF-8 string into a RawUnicode string // - this version doesn't resize the length of the result RawUnicode // and is therefore useful before a Win32 Unicode API call (with nCount=-1) // - if DestLen is not nil, the resulting length (in bytes) will be stored within function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; DestLen: PInteger=nil): RawUnicode; overload; /// convert a UTF-8 string into a RawUnicode string // - returns the resulting length (in bytes) will be stored within Dest function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; var Dest: RawUnicode): integer; overload; type /// option set for RawUnicodeToUtf8() conversion TCharConversionFlags = set of ( ccfNoTrailingZero, ccfReplacementCharacterForUnmatchedSurrogate); /// convert a RawUnicode PWideChar into a UTF-8 string procedure RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; var result: RawUTF8; Flags: TCharConversionFlags = [ccfNoTrailingZero]); overload; /// convert a RawUnicode PWideChar into a UTF-8 string function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; Flags: TCharConversionFlags = [ccfNoTrailingZero]): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// convert a RawUnicode UTF-16 PWideChar into a UTF-8 buffer // - replace system.UnicodeToUtf8 implementation, which is rather slow // since Delphi 2009+ // - append a trailing #0 to the ending PUTF8Char, unless ccfNoTrailingZero is set // - if ccfReplacementCharacterForUnmatchedSurrogate is set, this function will identify // unmatched surrogate pairs and replace them with EF BF BD / FFFD Unicode // Replacement character - see https://en.wikipedia.org/wiki/Specials_(Unicode_block) function RawUnicodeToUtf8(Dest: PUTF8Char; DestLen: PtrInt; Source: PWideChar; SourceLen: PtrInt; Flags: TCharConversionFlags): PtrInt; overload; /// convert a RawUnicode PWideChar into a UTF-8 string // - this version doesn't resize the resulting RawUTF8 string, but return // the new resulting RawUTF8 byte count into UTF8Length function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; out UTF8Length: integer): RawUTF8; overload; /// convert a RawUnicode string into a UTF-8 string function RawUnicodeToUtf8(const Unicode: RawUnicode): RawUTF8; overload; /// convert a SynUnicode string into a UTF-8 string function SynUnicodeToUtf8(const Unicode: SynUnicode): RawUTF8; /// convert a WideString into a UTF-8 string function WideStringToUTF8(const aText: WideString): RawUTF8; {$ifdef HASINLINE}inline;{$endif} /// direct conversion of a Unicode encoded buffer into a WinAnsi PAnsiChar buffer procedure RawUnicodeToWinPChar(dest: PAnsiChar; source: PWideChar; WideCharCount: integer); {$ifdef HASINLINE}inline;{$endif} /// convert a RawUnicode PWideChar into a WinAnsi (code page 1252) string function RawUnicodeToWinAnsi(WideChar: PWideChar; WideCharCount: integer): WinAnsiString; overload; {$ifdef HASINLINE}inline;{$endif} /// convert a RawUnicode string into a WinAnsi (code page 1252) string function RawUnicodeToWinAnsi(const Unicode: RawUnicode): WinAnsiString; overload; {$ifdef HASINLINE}inline;{$endif} /// convert a WideString into a WinAnsi (code page 1252) string function WideStringToWinAnsi(const Wide: WideString): WinAnsiString; {$ifdef HASINLINE}inline;{$endif} /// convert an AnsiChar buffer (of a given code page) into a UTF-8 string procedure AnsiCharToUTF8(P: PAnsiChar; L: Integer; var result: RawUTF8; ACP: integer); /// convert any Raw Unicode encoded String into a generic SynUnicode Text function RawUnicodeToSynUnicode(const Unicode: RawUnicode): SynUnicode; overload; {$ifdef HASINLINE}inline;{$endif} /// convert any Raw Unicode encoded String into a generic SynUnicode Text function RawUnicodeToSynUnicode(WideChar: PWideChar; WideCharCount: integer): SynUnicode; overload; {$ifdef HASINLINE}inline;{$endif} /// convert an Unicode buffer into a WinAnsi (code page 1252) string procedure UnicodeBufferToWinAnsi(source: PWideChar; out Dest: WinAnsiString); /// convert an Unicode buffer into a generic VCL string function UnicodeBufferToString(source: PWideChar): string; {$ifdef HASVARUSTRING} /// convert a Delphi 2009+ or FPC Unicode string into our UTF-8 string function UnicodeStringToUtf8(const S: UnicodeString): RawUTF8; inline; // this function is the same as direct RawUTF8=AnsiString(CP_UTF8) assignment // but is faster, since it uses no Win32 API call function UTF8DecodeToUnicodeString(const S: RawUTF8): UnicodeString; overload; inline; /// convert our UTF-8 encoded buffer into a Delphi 2009+ Unicode string // - this function is the same as direct assignment, since RawUTF8=AnsiString(CP_UTF8), // but is faster, since use no Win32 API call procedure UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer; var result: UnicodeString); overload; /// convert a Delphi 2009+ Unicode string into a WinAnsi (code page 1252) string function UnicodeStringToWinAnsi(const S: string): WinAnsiString; inline; /// convert our UTF-8 encoded buffer into a Delphi 2009+ Unicode string // - this function is the same as direct assignment, since RawUTF8=AnsiString(CP_UTF8), // but is faster, since use no Win32 API call function UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer): UnicodeString; overload; inline; /// convert a Win-Ansi encoded buffer into a Delphi 2009+ Unicode string // - this function is faster than default RTL, since use no Win32 API call function WinAnsiToUnicodeString(WinAnsi: PAnsiChar; WinAnsiLen: integer): UnicodeString; overload; /// convert a Win-Ansi string into a Delphi 2009+ Unicode string // - this function is faster than default RTL, since use no Win32 API call function WinAnsiToUnicodeString(const WinAnsi: WinAnsiString): UnicodeString; inline; overload; {$endif HASVARUSTRING} /// convert any generic VCL Text into an UTF-8 encoded String // - in the VCL context, it's prefered to use TLanguageFile.StringToUTF8() // method from mORMoti18n, which will handle full i18n of your application // - it will work as is with Delphi 2009+ (direct unicode conversion) // - under older version of Delphi (no unicode), it will use the // current RTL codepage, as with WideString conversion (but without slow // WideString usage) function StringToUTF8(const Text: string): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// convert any generic VCL Text buffer into an UTF-8 encoded String // - it will work as is with Delphi 2009+ (direct unicode conversion) // - under older version of Delphi (no unicode), it will use the // current RTL codepage, as with WideString conversion (but without slow // WideString usage) procedure StringToUTF8(Text: PChar; TextLen: integer; var result: RawUTF8); overload; {$ifdef HASINLINE}inline;{$endif} /// convert any generic VCL Text into an UTF-8 encoded String // - this overloaded function use a faster by-reference parameter for the result procedure StringToUTF8(const Text: string; var result: RawUTF8); overload; {$ifdef HASINLINE}inline;{$endif} /// convert any generic VCL Text into an UTF-8 encoded String function ToUTF8(const Text: string): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// convert any UTF-8 encoded shortstring Text into an UTF-8 encoded String // - expects the supplied content to be already ASCII-7 or UTF-8 encoded, e.g. // a RTTI type or property name: it won't work with Ansi-encoded strings function ToUTF8(const Ansi7Text: ShortString): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// convert a TGUID into UTF-8 encoded text // - will return e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without the {}) // - if you need the embracing { }, use GUIDToRawUTF8() function instead function ToUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; overload; {$ifndef NOVARIANTS} type /// function prototype used internally for variant comparaison // - used in mORMot.pas unit e.g. by TDocVariantData.SortByValue TVariantCompare = function(const V1,V2: variant): PtrInt; /// TVariantCompare-compatible case-sensitive comparison function // - just a wrapper around SortDynArrayVariantComp(caseInsensitive=false) function VariantCompare(const V1,V2: variant): PtrInt; {$ifdef HASINLINE}inline;{$endif} /// TVariantCompare-compatible case-insensitive comparison function // - just a wrapper around SortDynArrayVariantComp(caseInsensitive=true) function VariantCompareI(const V1,V2: variant): PtrInt; {$ifdef HASINLINE}inline;{$endif} /// convert any Variant into UTF-8 encoded String // - use VariantSaveJSON() instead if you need a conversion to JSON with // custom parameters function VariantToUTF8(const V: Variant): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// convert any Variant into UTF-8 encoded String // - use VariantSaveJSON() instead if you need a conversion to JSON with // custom parameters function ToUTF8(const V: Variant): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// convert any Variant into UTF-8 encoded String // - use VariantSaveJSON() instead if you need a conversion to JSON with // custom parameters // - wasString is set if the V value was a text // - empty and null variants will be stored as 'null' text - as expected by JSON // - custom variant types (e.g. TDocVariant) will be stored as JSON procedure VariantToUTF8(const V: Variant; var result: RawUTF8; var wasString: boolean); overload; /// convert any Variant into UTF-8 encoded String // - use VariantSaveJSON() instead if you need a conversion to JSON with // custom parameters // - returns TRUE if the V value was a text, FALSE if was not (e.g. a number) // - empty and null variants will be stored as 'null' text - as expected by JSON // - custom variant types (e.g. TDocVariant) will be stored as JSON function VariantToUTF8(const V: Variant; var Text: RawUTF8): boolean; overload; /// convert any date/time Variant into a TDateTime value // - would handle varDate kind of variant, or use a string conversion and // ISO-8601 parsing if possible function VariantToDateTime(const V: Variant; var Value: TDateTime): boolean; /// fast conversion from hexa chars, supplied as a variant string, into a binary buffer function VariantHexDisplayToBin(const Hex: variant; Bin: PByte; BinBytes: integer): boolean; /// fast conversion of a binary buffer into hexa chars, as a variant string function BinToHexDisplayLowerVariant(Bin: pointer; BinBytes: integer): variant; {$ifdef HASINLINE}inline;{$endif} /// fast comparison of a Variant and UTF-8 encoded String (or number) // - slightly faster than plain V=Str, which computes a temporary variant // - here Str='' equals unassigned, null or false // - if CaseSensitive is false, will use IdemPropNameU() for comparison function VariantEquals(const V: Variant; const Str: RawUTF8; CaseSensitive: boolean=true): boolean; overload; /// convert any Variant into a VCL string type // - expects any varString value to be stored as a RawUTF8 // - prior to Delphi 2009, use VariantToString(aVariant) instead of // string(aVariant) to safely retrieve a string=AnsiString value from a variant // generated by our framework units - otherwise, you may loose encoded characters // - for Unicode versions of Delphi, there won't be any potential data loss, // but this version may be slightly faster than a string(aVariant) function VariantToString(const V: Variant): string; /// convert any Variant into a value encoded as with :(..:) inlined parameters // in FormatUTF8(Format,Args,Params) procedure VariantToInlineValue(const V: Variant; var result: RawUTF8); /// convert any Variant into another Variant storing an RawUTF8 of the value // - e.g. VariantToVariantUTF8('toto')='toto' and VariantToVariantUTF8(12)='12' function VariantToVariantUTF8(const V: Variant): variant; /// faster alternative to Finalize(aVariantDynArray) // - this function will take account and optimize the release of a dynamic // array of custom variant types values // - for instance, an array of TDocVariant will be optimized for speed procedure VariantDynArrayClear(var Value: TVariantDynArray); /// crc32c-based hash of a variant value // - complex string types will make up to 255 uppercase characters conversion // if CaseInsensitive is true // - you can specify your own hashing function if crc32c is not what you expect function VariantHash(const value: variant; CaseInsensitive: boolean; Hasher: THasher=nil): cardinal; {$endif NOVARIANTS} { note: those VariantToInteger*() functions are expected to be there } /// convert any numerical Variant into a 32-bit integer // - it will expect true numerical Variant and won't convert any string nor // floating-pointer Variant, which will return FALSE and won't change the // Value variable content function VariantToInteger(const V: Variant; var Value: integer): boolean; /// convert any numerical Variant into a 64-bit integer // - it will expect true numerical Variant and won't convert any string nor // floating-pointer Variant, which will return FALSE and won't change the // Value variable content function VariantToInt64(const V: Variant; var Value: Int64): boolean; /// convert any numerical Variant into a 64-bit integer // - it will expect true numerical Variant and won't convert any string nor // floating-pointer Variant, which will return the supplied DefaultValue function VariantToInt64Def(const V: Variant; DefaultValue: Int64): Int64; /// convert any numerical Variant into a floating point value function VariantToDouble(const V: Variant; var Value: double): boolean; /// convert any numerical Variant into a floating point value function VariantToDoubleDef(const V: Variant; const default: double=0): double; /// convert any numerical Variant into a fixed decimals floating point value function VariantToCurrency(const V: Variant; var Value: currency): boolean; /// convert any numerical Variant into a boolean value function VariantToBoolean(const V: Variant; var Value: Boolean): boolean; /// convert any numerical Variant into an integer // - it will expect true numerical Variant and won't convert any string nor // floating-pointer Variant, which will return the supplied DefaultValue function VariantToIntegerDef(const V: Variant; DefaultValue: integer): integer; overload; /// convert any generic VCL Text buffer into an UTF-8 encoded buffer // - Dest must be able to receive at least SourceChars*3 bytes // - it will work as is with Delphi 2009+ (direct unicode conversion) // - under older version of Delphi (no unicode), it will use the // current RTL codepage, as with WideString conversion (but without slow // WideString usage) function StringBufferToUtf8(Dest: PUTF8Char; Source: PChar; SourceChars: PtrInt): PUTF8Char; overload; /// convert any generic VCL 0-terminated Text buffer into an UTF-8 string // - it will work as is with Delphi 2009+ (direct unicode conversion) // - under older version of Delphi (no unicode), it will use the // current RTL codepage, as with WideString conversion (but without slow // WideString usage) procedure StringBufferToUtf8(Source: PChar; out result: RawUTF8); overload; /// convert any generic VCL Text into a Raw Unicode encoded String // - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n, // which will handle full i18n of your application // - it will work as is with Delphi 2009+ (direct unicode conversion) // - under older version of Delphi (no unicode), it will use the // current RTL codepage, as with WideString conversion (but without slow // WideString usage) function StringToRawUnicode(const S: string): RawUnicode; overload; /// convert any generic VCL Text into a SynUnicode encoded String // - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n, // which will handle full i18n of your application // - it will work as is with Delphi 2009+ (direct unicode conversion) // - under older version of Delphi (no unicode), it will use the // current RTL codepage, as with WideString conversion (but without slow // WideString usage) function StringToSynUnicode(const S: string): SynUnicode; {$ifdef HASINLINE}inline;{$endif} /// convert any generic VCL Text into a Raw Unicode encoded String // - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n, // which will handle full i18n of your application // - it will work as is with Delphi 2009+ (direct unicode conversion) // - under older version of Delphi (no unicode), it will use the // current RTL codepage, as with WideString conversion (but without slow // WideString usage) function StringToRawUnicode(P: PChar; L: integer): RawUnicode; overload; /// convert any Raw Unicode encoded string into a generic VCL Text function RawUnicodeToString(const U: RawUnicode): string; overload; /// convert any Raw Unicode encoded buffer into a generic VCL Text function RawUnicodeToString(P: PWideChar; L: integer): string; overload; /// convert any Raw Unicode encoded buffer into a generic VCL Text procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); overload; /// convert any SynUnicode encoded string into a generic VCL Text function SynUnicodeToString(const U: SynUnicode): string; {$ifdef HASINLINE}inline;{$endif} /// convert any UTF-8 encoded String into a generic VCL Text // - it's prefered to use TLanguageFile.UTF8ToString() in mORMoti18n, // which will handle full i18n of your application // - it will work as is with Delphi 2009+ (direct unicode conversion) // - under older version of Delphi (no unicode), it will use the // current RTL codepage, as with WideString conversion (but without slow // WideString usage) function UTF8ToString(const Text: RawUTF8): string; {$ifdef HASINLINE}inline;{$endif} /// convert any UTF-8 encoded buffer into a generic VCL Text // - it's prefered to use TLanguageFile.UTF8ToString() in mORMoti18n, // which will handle full i18n of your application // - it will work as is with Delphi 2009+ (direct unicode conversion) // - under older version of Delphi (no unicode), it will use the // current RTL codepage, as with WideString conversion (but without slow // WideString usage) function UTF8DecodeToString(P: PUTF8Char; L: integer): string; overload; {$ifdef UNICODE}inline;{$endif} /// convert any UTF-8 encoded buffer into a generic VCL Text procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string); overload; /// convert any UTF-8 encoded String into a generic WideString Text function UTF8ToWideString(const Text: RawUTF8): WideString; overload; {$ifdef HASINLINE}inline;{$endif} /// convert any UTF-8 encoded String into a generic WideString Text procedure UTF8ToWideString(const Text: RawUTF8; var result: WideString); overload; {$ifdef HASINLINE}inline;{$endif} /// convert any UTF-8 encoded String into a generic WideString Text procedure UTF8ToWideString(Text: PUTF8Char; Len: integer; var result: WideString); overload; /// convert any UTF-8 encoded String into a generic SynUnicode Text function UTF8ToSynUnicode(const Text: RawUTF8): SynUnicode; overload; /// convert any UTF-8 encoded String into a generic SynUnicode Text procedure UTF8ToSynUnicode(const Text: RawUTF8; var result: SynUnicode); overload; /// convert any UTF-8 encoded buffer into a generic SynUnicode Text procedure UTF8ToSynUnicode(Text: PUTF8Char; Len: integer; var result: SynUnicode); overload; /// convert any Ansi 7 bit encoded String into a generic VCL Text // - the Text content must contain only 7 bit pure ASCII characters function Ansi7ToString(const Text: RawByteString): string; overload; {$ifndef UNICODE}{$ifdef HASINLINE}inline;{$endif}{$endif} /// convert any Ansi 7 bit encoded String into a generic VCL Text // - the Text content must contain only 7 bit pure ASCII characters function Ansi7ToString(Text: PWinAnsiChar; Len: integer): string; overload; {$ifdef HASINLINE}inline;{$endif} /// convert any Ansi 7 bit encoded String into a generic VCL Text // - the Text content must contain only 7 bit pure ASCII characters procedure Ansi7ToString(Text: PWinAnsiChar; Len: integer; var result: string); overload; /// convert any generic VCL Text into Ansi 7 bit encoded String // - the Text content must contain only 7 bit pure ASCII characters function StringToAnsi7(const Text: string): RawByteString; /// convert any generic VCL Text into WinAnsi (Win-1252) 8 bit encoded String function StringToWinAnsi(const Text: string): WinAnsiString; {$ifdef UNICODE}inline;{$endif} /// fast Format() function replacement, optimized for RawUTF8 // - only supported token is %, which will be written in the resulting string // according to each Args[] supplied items - so you will never get any exception // as with the SysUtils.Format() when a specifier is incorrect // - resulting string has no length limit and uses fast concatenation // - note that, due to a Delphi compiler limitation, cardinal values should be // type-casted to Int64() (otherwise the integer mapped value will be converted) // - any supplied TObject instance will be written as their class name function FormatUTF8(const Format: RawUTF8; const Args: array of const): RawUTF8; overload; {$ifdef FPC}inline;{$endif} /// fast Format() function replacement, optimized for RawUTF8 // - overloaded function, which avoid a temporary RawUTF8 instance on stack procedure FormatUTF8(const Format: RawUTF8; const Args: array of const; out result: RawUTF8); overload; /// fast Format() function replacement, for UTF-8 content stored in shortstring // - use the same single token % (and implementation) than FormatUTF8() // - shortstring allows fast stack allocation, so is perfect for small content // - truncate result if the text size exceeds 255 bytes procedure FormatShort(const Format: RawUTF8; const Args: array of const; var result: shortstring); /// fast Format() function replacement, for UTF-8 content stored in shortstring function FormatToShort(const Format: RawUTF8; const Args: array of const): shortstring; /// fast Format() function replacement, tuned for small content // - use the same single token % (and implementation) than FormatUTF8() procedure FormatString(const Format: RawUTF8; const Args: array of const; out result: string); overload; /// fast Format() function replacement, tuned for small content // - use the same single token % (and implementation) than FormatUTF8() function FormatString(const Format: RawUTF8; const Args: array of const): string; overload; {$ifdef FPC}inline;{$endif} type /// used e.g. by PointerToHexShort/CardinalToHexShort/Int64ToHexShort/FormatShort16 // - such result type would avoid a string allocation on heap, so are highly // recommended e.g. when logging small pieces of information TShort16 = string[16]; PShort16 = ^TShort16; /// fast Format() function replacement, for UTF-8 content stored in TShort16 // - truncate result if the text size exceeds 16 bytes procedure FormatShort16(const Format: RawUTF8; const Args: array of const; var result: TShort16); /// fast Format() function replacement, handling % and ? parameters // - will include Args[] for every % in Format // - will inline Params[] for every ? in Format, handling special "inlined" // parameters, as exected by mORMot.pas unit, i.e. :(1234): for numerical // values, and :('quoted '' string'): for textual values // - if optional JSONFormat parameter is TRUE, ? parameters will be written // as JSON quoted strings, without :(...): tokens, e.g. "quoted "" string" // - resulting string has no length limit and uses fast concatenation // - note that, due to a Delphi compiler limitation, cardinal values should be // type-casted to Int64() (otherwise the integer mapped value will be converted) // - any supplied TObject instance will be written as their class name function FormatUTF8(const Format: RawUTF8; const Args, Params: array of const; JSONFormat: boolean=false): RawUTF8; overload; /// read and store text into values[] according to fmt specifiers // - %d as PInteger, %D as PInt64, %u as PCardinal, %U as PQWord, %f as PDouble, // %F as PCurrency, %x as 8 hexa chars to PInteger, %X as 16 hexa chars to PInt64, // %s as PShortString (UTF-8 encoded), %S as PRawUTF8, %L as PRawUTF8 (getting // all text until the end of the line) // - optionally, specifiers and any whitespace separated identifiers may be // extracted and stored into the ident[] array, e.g. '%dFirstInt %s %DOneInt64' // will store ['dFirstInt','s','DOneInt64'] into ident function ScanUTF8(const text, fmt: RawUTF8; const values: array of pointer; ident: PRawUTF8DynArray=nil): integer; overload; {$ifdef FPC}inline;{$endif} /// read text from P/PLen and store it into values[] according to fmt specifiers function ScanUTF8(P: PUTF8Char; PLen: integer; const fmt: RawUTF8; const values: array of pointer; ident: PRawUTF8DynArray): integer; overload; /// convert an open array (const Args: array of const) argument to an UTF-8 // encoded text // - note that, due to a Delphi compiler limitation, cardinal values should be // type-casted to Int64() (otherwise the integer mapped value will be converted) // - any supplied TObject instance will be written as their class name procedure VarRecToUTF8(const V: TVarRec; var result: RawUTF8; wasString: PBoolean=nil); type /// a memory structure which avoids a temporary RawUTF8 allocation // - used by VarRecToTempUTF8() and FormatUTF8()/FormatShort() TTempUTF8 = record Len: PtrInt; Text: PUTF8Char; TempRawUTF8: pointer; Temp: array[0..23] of AnsiChar; end; PTempUTF8 = ^TTempUTF8; /// convert an open array (const Args: array of const) argument to an UTF-8 // encoded text, using a specified temporary buffer // - this function would allocate a RawUTF8 in TempRawUTF8 only if needed, // but use the supplied Res.Temp[] buffer for numbers to text conversion - // caller should ensure to make RawUTF8(TempRawUTF8) := '' on the entry // - it would return the number of UTF-8 bytes, i.e. Res.Len // - note that, due to a Delphi compiler limitation, cardinal values should be // type-casted to Int64() (otherwise the integer mapped value will be converted) // - any supplied TObject instance will be written as their class name function VarRecToTempUTF8(const V: TVarRec; var Res: TTempUTF8): integer; /// convert an open array (const Args: array of const) argument to an UTF-8 // encoded text, returning FALSE if the argument was not a string value function VarRecToUTF8IsString(const V: TVarRec; var value: RawUTF8): boolean; {$ifdef HASINLINE}inline;{$endif} /// convert an open array (const Args: array of const) argument to an Int64 // - returns TRUE and set Value if the supplied argument is a vtInteger, vtInt64 // or vtBoolean // - returns FALSE if the argument is not an integer // - note that, due to a Delphi compiler limitation, cardinal values should be // type-casted to Int64() (otherwise the integer mapped value will be converted) function VarRecToInt64(const V: TVarRec; out value: Int64): boolean; /// convert an open array (const Args: array of const) argument to a floating // point value // - returns TRUE and set Value if the supplied argument is a number (e.g. // vtInteger, vtInt64, vtCurrency or vtExtended) // - returns FALSE if the argument is not a number // - note that, due to a Delphi compiler limitation, cardinal values should be // type-casted to Int64() (otherwise the integer mapped value will be converted) function VarRecToDouble(const V: TVarRec; out value: double): boolean; /// convert an open array (const Args: array of const) argument to a value // encoded as with :(...): inlined parameters in FormatUTF8(Format,Args,Params) // - note that, due to a Delphi compiler limitation, cardinal values should be // type-casted to Int64() (otherwise the integer mapped value will be converted) // - any supplied TObject instance will be written as their class name procedure VarRecToInlineValue(const V: TVarRec; var result: RawUTF8); /// get an open array (const Args: array of const) character argument // - only handle varChar and varWideChar kind of arguments function VarRecAsChar(const V: TVarRec): integer; {$ifdef HASINLINE}inline;{$endif} type /// function prototype used internally for UTF-8 buffer comparaison // - used in mORMot.pas unit during TSQLTable rows sort and by TSQLQuery TUTF8Compare = function(P1,P2: PUTF8Char): PtrInt; /// convert the endianness of a given unsigned 32-bit integer into BigEndian function bswap32(a: cardinal): cardinal; {$ifdef FPC}inline;{$endif} /// convert the endianness of a given unsigned 64-bit integer into BigEndian function bswap64(const a: QWord): QWord; {$ifdef FPC}inline;{$endif} /// convert the endianness of an array of unsigned 64-bit integer into BigEndian // - n is required to be > 0 // - warning: on x86, a should be <> b procedure bswap64array(a,b: PQWordArray; n: PtrInt); /// fast concatenation of several AnsiStrings function RawByteStringArrayConcat(const Values: array of RawByteString): RawByteString; /// creates a TBytes from a RawByteString memory buffer procedure RawByteStringToBytes(const buf: RawByteString; out bytes: TBytes); /// creates a RawByteString memory buffer from a TBytes content procedure BytesToRawByteString(const bytes: TBytes; out buf: RawByteString); {$ifdef HASINLINE}inline;{$endif} /// creates a RawByteString memory buffer from an embedded resource // - returns '' if the resource is not found // - warning: resources size may be rounded up to alignment // - you can specify a library (dll) resource instance handle, if needed procedure ResourceToRawByteString(const ResName: string; ResType: PChar; out buf: RawByteString; Instance: THandle=0); /// creates a RawByteString memory buffer from an SynLZ-compressed embedded resource // - returns '' if the resource is not found // - this method would use SynLZDecompress() after ResourceToRawByteString(), // with a ResType=PChar(10) (i.e. RC_DATA) // - you can specify a library (dll) resource instance handle, if needed procedure ResourceSynLZToRawByteString(const ResName: string; out buf: RawByteString; Instance: THandle=0); {$ifndef ENHANCEDRTL} { is our Enhanced Runtime (or LVCL) library not installed? } /// fast dedicated RawUTF8 version of Trim() // - implemented using x86 asm, if possible // - this Trim() is seldom used, but this RawUTF8 specific version is needed // e.g. by Delphi 2009+, to avoid two unnecessary conversions into UnicodeString function Trim(const S: RawUTF8): RawUTF8; {$define OWNNORMTOUPPER} { NormToUpper[] exists only in our enhanced RTL } {$endif ENHANCEDRTL} /// our fast version of CompareMem() with optimized asm for x86 and tune pascal function CompareMem(P1, P2: Pointer; Length: PtrInt): Boolean; {$ifdef HASINLINE} function CompareMemFixed(P1, P2: Pointer; Length: PtrInt): Boolean; inline; {$else} /// a CompareMem()-like function designed for small and fixed-sized content // - here, Length is expected to be a constant value - typically from sizeof() - // so that inlining has better performance than calling the CompareMem() function var CompareMemFixed: function(P1, P2: Pointer; Length: PtrInt): Boolean = CompareMem; {$endif HASINLINE} /// a CompareMem()-like function designed for small (a few bytes) content function CompareMemSmall(P1, P2: Pointer; Length: PtrInt): Boolean; {$ifdef HASINLINE}inline;{$endif} /// convert an IPv4 'x.x.x.x' text into its 32-bit value // - returns TRUE if the text was a valid IPv4 text, unserialized as 32-bit aValue // - returns FALSE on parsing error, also setting aValue=0 // - '' or '127.0.0.1' will also return false function IPToCardinal(P: PUTF8Char; out aValue: cardinal): boolean; overload; /// convert an IPv4 'x.x.x.x' text into its 32-bit value // - returns TRUE if the text was a valid IPv4 text, unserialized as 32-bit aValue // - returns FALSE on parsing error, also setting aValue=0 // - '' or '127.0.0.1' will also return false function IPToCardinal(const aIP: RawUTF8; out aValue: cardinal): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// convert an IPv4 'x.x.x.x' text into its 32-bit value, 0 or localhost // - returns <> 0 value if the text was a valid IPv4 text, 0 on parsing error // - '' or '127.0.0.1' will also return 0 function IPToCardinal(const aIP: RawUTF8): cardinal; overload; {$ifdef HASINLINE}inline;{$endif} /// convert some ASCII-7 text into binary, using Emile Baudot code // - as used in telegraphs, covering #10 #13 #32 a-z 0-9 - ' , ! : ( + ) $ ? @ . / ; // charset, following a custom static-huffman-like encoding with 5-bit masks // - any upper case char will be converted into lowercase during encoding // - other characters (e.g. UTF-8 accents, or controls chars) will be ignored // - resulting binary will consume 5 (or 10) bits per character // - reverse of the BaudotToAscii() function // - the "baud" symbol rate measurement comes from Emile's name ;) function AsciiToBaudot(P: PAnsiChar; len: integer): RawByteString; overload; /// convert some ASCII-7 text into binary, using Emile Baudot code // - as used in telegraphs, covering #10 #13 #32 a-z 0-9 - ' , ! : ( + ) $ ? @ . / ; // charset, following a custom static-huffman-like encoding with 5-bit masks // - any upper case char will be converted into lowercase during encoding // - other characters (e.g. UTF-8 accents, or controls chars) will be ignored // - resulting binary will consume 5 (or 10) bits per character // - reverse of the BaudotToAscii() function // - the "baud" symbol rate measurement comes from Emile's name ;) function AsciiToBaudot(const Text: RawUTF8): RawByteString; overload; /// convert some Baudot code binary, into ASCII-7 text // - reverse of the AsciiToBaudot() function // - any uppercase character would be decoded as lowercase - and some characters // may have disapeared // - the "baud" symbol rate measurement comes from Emile's name ;) function BaudotToAscii(Baudot: PByteArray; len: integer): RawUTF8; overload; /// convert some Baudot code binary, into ASCII-7 text // - reverse of the AsciiToBaudot() function // - any uppercase character would be decoded as lowercase - and some characters // may have disapeared // - the "baud" symbol rate measurement comes from Emile's name ;) function BaudotToAscii(const Baudot: RawByteString): RawUTF8; overload; {$ifdef UNICODE} /// our fast RawUTF8 version of Pos(), for Unicode only compiler // - this Pos() is seldom used, but this RawUTF8 specific version is needed // by Delphi 2009+, to avoid two unnecessary conversions into UnicodeString // - just a wrapper around PosEx(substr,str,1) function Pos(const substr, str: RawUTF8): Integer; overload; inline; {$endif UNICODE} /// use our fast RawUTF8 version of IntToStr() // - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 // - only useful if our Enhanced Runtime (or LVCL) library is not installed function Int64ToUtf8(Value: Int64): RawUTF8; overload; {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} /// fast RawUTF8 version of IntToStr(), with proper QWord conversion procedure UInt64ToUtf8(Value: QWord; var result: RawUTF8); /// use our fast RawUTF8 version of IntToStr() // - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 // - only useful if our Enhanced Runtime (or LVCL) library is not installed function Int32ToUtf8(Value: PtrInt): RawUTF8; overload; {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} /// use our fast RawUTF8 version of IntToStr() // - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 // - result as var parameter saves a local assignment and a try..finally procedure Int32ToUTF8(Value: PtrInt; var result: RawUTF8); overload; {$ifdef HASINLINE}inline;{$endif} /// use our fast RawUTF8 version of IntToStr() // - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 // - result as var parameter saves a local assignment and a try..finally procedure Int64ToUtf8(Value: Int64; var result: RawUTF8); overload; {$ifdef HASINLINE}inline;{$endif} /// use our fast RawUTF8 version of IntToStr() function ToUTF8(Value: PtrInt): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} {$ifndef CPU64} /// use our fast RawUTF8 version of IntToStr() function ToUTF8(Value: Int64): RawUTF8; overload; {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} {$endif} /// optimized conversion of a cardinal into RawUTF8 function UInt32ToUtf8(Value: PtrUInt): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// optimized conversion of a cardinal into RawUTF8 procedure UInt32ToUtf8(Value: PtrUInt; var result: RawUTF8); overload; {$ifdef HASINLINE}inline;{$endif} /// faster version than default SysUtils.IntToStr implementation function IntToString(Value: integer): string; overload; /// faster version than default SysUtils.IntToStr implementation function IntToString(Value: cardinal): string; overload; /// faster version than default SysUtils.IntToStr implementation function IntToString(Value: Int64): string; overload; /// convert a floating-point value to its numerical text equivalency function DoubleToString(Value: Double): string; /// convert a currency value from its Int64 binary representation into // its numerical text equivalency // - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) function Curr64ToString(Value: Int64): string; type /// used to store a set of 8-bit encoded characters TSynAnsicharSet = set of AnsiChar; /// used to store a set of 8-bit unsigned integers TSynByteSet = set of Byte; /// used to store a set of 8-bit unsigned integers as 256 booleans TSynByteBoolean = array[byte] of boolean; /// returns the supplied text content, without any control char // - a control char has an ASCII code #0 .. #32, i.e. text[]<=' ' // - you can specify a custom char set to be excluded, if needed function TrimControlChars(const text: RawUTF8; const controls: TSynAnsicharSet=[#0..' ']): RawUTF8; var /// best possible precision when rendering a "single" kind of float // - can be used as parameter for ExtendedToString/ExtendedToStr // - is defined as a var, so that you may be able to override the default // settings, for the whole process SINGLE_PRECISION: integer = 8; /// best possible precision when rendering a "double" kind of float // - can be used as parameter for ExtendedToString/ExtendedToStr // - is defined as a var, so that you may be able to override the default // settings, for the whole process DOUBLE_PRECISION: integer = 15; /// best possible precision when rendering a "extended" kind of float // - can be used as parameter for ExtendedToString/ExtendedToStr // - is defined as a var, so that you may be able to override the default // settings, for the whole process EXTENDED_PRECISION: integer = 18; type {$ifdef CPUARM} // ARM does not support 80bit extended -> 64bit double is enough for us TSynExtended = double; {$else} {$ifdef CPU64} TSynExtended = double; {$else} /// the floating-point type to be used for best precision and speed // - will allow to fallback to double e.g. on x64 and ARM CPUs TSynExtended = extended; {$endif} {$endif} /// the non-number values potentially stored in an IEEE floating point TSynExtendedNan = (seNumber, seNan, seInf, seNegInf); const /// the JavaScript-like values of non-number IEEE constants // - as recognized by ExtendedToStringNan, and used by TTextWriter.Add() // when serializing such single/double/extended floating-point values JSON_NAN: array[TSynExtendedNan] of string[11] = ( '', '"NaN"', '"Infinity"', '"-Infinity"'); /// compare to floating point values, with IEEE 754 double precision // - use this function instead of raw = operator // - the precision is calculated from the A and B value range // - faster equivalent than SameValue() in Math unit // - if you know the precision range of A and B, it's faster to check abs(A-B)QWord(B) is wrong on older versions of Delphi, so you // should better use this function or SortDynArrayQWord() to properly compare // two QWord values over CPUX86 function CompareQWord(A, B: QWord): integer; {$ifdef HASINLINE}inline;{$endif} /// compute the sum of values, using a running compensation for lost low-order bits // - a naive "Sum := Sum + Data" will be restricted to 53 bits of resolution, // so will eventually result in an incorrect number // - Kahan algorithm keeps track of the accumulated error in integer operations, // to achieve a precision of more than 100 bits // - see https://en.wikipedia.org/wiki/Kahan_summation_algorithm procedure KahanSum(const Data: double; var Sum, Carry: double); {$ifdef HASINLINE}inline;{$endif} /// convert a floating-point value to its numerical text equivalency // - depending on the platform, it may either call ExtendedToStringNoExp or // use FloatToText() in ffGeneral mode (the shortest possible decimal string // using fixed or scientific format) // - returns the count of chars stored into S (S[0] is not set) function ExtendedToString(var S: ShortString; Value: TSynExtended; Precision: integer): integer; {$ifdef FPC}inline;{$endif} /// convert a floating-point value to its numerical text equivalency without // scientification notation // - returns the count of chars stored into S (S[0] is not set) // - call str(Value:0:Precision,S) to avoid any Exponent notation function ExtendedToStringNoExp(var S: ShortString; Value: TSynExtended; Precision: integer): integer; /// check if the supplied text is NAN/INF/+INF/-INF, i.e. not a number // - as returned by ExtendedToString() textual conversion // - such values do appear as IEEE floating points, but are not defined in JSON function ExtendedToStringNan(const s: shortstring): TSynExtendedNan; {$ifdef HASINLINE}inline;{$endif} /// check if the supplied text is NAN/INF/+INF/-INF, i.e. not a number // - as returned by ExtendedToString() textual conversion // - such values do appear as IEEE floating points, but are not defined in JSON function ExtendedToStrNan(const s: RawUTF8): TSynExtendedNan; {$ifdef HASINLINE}inline;{$endif} /// convert a floating-point value to its numerical text equivalency function ExtendedToStr(Value: TSynExtended; Precision: integer): RawUTF8; overload; /// convert a floating-point value to its numerical text equivalency procedure ExtendedToStr(Value: TSynExtended; Precision: integer; var result: RawUTF8); overload; /// convert a floating-point value to its numerical text equivalency function DoubleToStr(Value: Double): RawUTF8; {$ifdef HASINLINE}inline;{$endif} /// fast retrieve the position of a given character function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char; {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} /// fast retrieve the position of any value of a given set of characters function PosCharAny(Str: PUTF8Char; Characters: PAnsiChar): PUTF8Char; /// a non case-sensitive RawUTF8 version of Pos() // - uppersubstr is expected to be already in upper case // - this version handle only 7 bit ASCII (no accentuated characters) function PosI(uppersubstr: PUTF8Char; const str: RawUTF8): PtrInt; /// a non case-sensitive version of Pos() // - uppersubstr is expected to be already in upper case // - this version handle only 7 bit ASCII (no accentuated characters) function StrPosI(uppersubstr,str: PUTF8Char): PUTF8Char; /// a non case-sensitive RawUTF8 version of Pos() // - substr is expected to be already in upper case // - this version will decode the UTF-8 content before using NormToUpper[] function PosIU(substr: PUTF8Char; const str: RawUTF8): Integer; /// internal fast integer val to text conversion // - expect the last available temporary char position in P // - return the last written char position (write in reverse order in P^) // - typical use: // !function Int32ToUTF8(Value: PtrInt): RawUTF8; // !var tmp: array[0..23] of AnsiChar; // ! P: PAnsiChar; // !begin // ! P := StrInt32(@tmp[23],Value); // ! SetString(result,P,@tmp[23]-P); // !end; // - convert the input value as PtrInt, so as Int64 on 64-bit CPUs // - not to be called directly: use IntToStr() or Int32ToUTF8() instead function StrInt32(P: PAnsiChar; val: PtrInt): PAnsiChar; /// internal fast unsigned integer val to text conversion // - expect the last available temporary char position in P // - return the last written char position (write in reverse order in P^) // - convert the input value as PtrUInt, so as QWord on 64-bit CPUs function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar; /// internal fast Int64 val to text conversion // - same calling convention as with StrInt32() above function StrInt64(P: PAnsiChar; const val: Int64): PAnsiChar; {$ifdef HASINLINE}inline;{$endif} /// internal fast unsigned Int64 val to text conversion // - same calling convention as with StrInt32() above function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar; {$ifdef CPU64}inline;{$endif} /// fast add some characters to a RawUTF8 string // - faster than SetString(tmp,Buffer,BufferLen); Text := Text+tmp; procedure AppendBufferToRawUTF8(var Text: RawUTF8; Buffer: pointer; BufferLen: PtrInt); /// fast add one character to a RawUTF8 string // - faster than Text := Text + ch; procedure AppendCharToRawUTF8(var Text: RawUTF8; Ch: AnsiChar); /// fast add some characters to a RawUTF8 string // - faster than Text := Text+RawUTF8(Buffers[0])+RawUTF8(Buffers[0])+... procedure AppendBuffersToRawUTF8(var Text: RawUTF8; const Buffers: array of PUTF8Char); /// fast add some characters from a RawUTF8 string into a given buffer // - warning: the Buffer should contain enough space to store the Text, otherwise // you may encounter buffer overflows and random memory errors function AppendRawUTF8ToBuffer(Buffer: PUTF8Char; const Text: RawUTF8): PUTF8Char; /// fast add text conversion of a 32-bit signed integer value into a given buffer // - warning: the Buffer should contain enough space to store the text, otherwise // you may encounter buffer overflows and random memory errors function AppendUInt32ToBuffer(Buffer: PUTF8Char; Value: cardinal): PUTF8Char; /// buffer-safe version of StrComp(), to be used with PUTF8Char/PAnsiChar // - pure pascal StrComp() won't access the memory beyond the string, but this // function is defined for compatibility with SSE 4.2 expectations function StrCompFast(Str1, Str2: pointer): PtrInt; {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} /// fastest available version of StrComp(), to be used with PUTF8Char/PAnsiChar // - won't use SSE4.2 instructions on supported CPUs by default, which may read // some bytes beyond the s string, so should be avoided e.g. over memory mapped // files - call explicitely StrCompSSE42() if you are confident on your input var StrComp: function (Str1, Str2: pointer): PtrInt = StrCompFast; /// pure pascal version of strspn(), to be used with PUTF8Char/PAnsiChar // - please note that this optimized version may read up to 3 bytes beyond // accept but never after s end, so is safe e.g. over memory mapped files function strspnpas(s,accept: pointer): integer; {$ifdef HASINLINE}inline;{$endif} /// pure pascal version of strcspn(), to be used with PUTF8Char/PAnsiChar // - please note that this optimized version may read up to 3 bytes beyond // reject but never after s end, so is safe e.g. over memory mapped files function strcspnpas(s,reject: pointer): integer; {$ifdef HASINLINE}inline;{$endif} /// fastest available version of strspn(), to be used with PUTF8Char/PAnsiChar // - returns size of initial segment of s which appears in accept chars, e.g. // ! strspn('abcdef','debca')=5 // - won't use SSE4.2 instructions on supported CPUs by default, which may read // some bytes beyond the s string, so should be avoided e.g. over memory mapped // files - call explicitely strspnsse42() if you are confident on your input var strspn: function (s,accept: pointer): integer = strspnpas; /// fastest available version of strcspn(), to be used with PUTF8Char/PAnsiChar // - returns size of initial segment of s which doesn't appears in reject chars, e.g. // ! strcspn('1234,6789',',')=4 // - won't use SSE4.2 instructions on supported CPUs by default, which may read // some bytes beyond the s string, so should be avoided e.g. over memory mapped // files - call explicitely strcspnsse42() if you are confident on your input var strcspn: function (s,reject: pointer): integer = strcspnpas; {$ifndef ABSOLUTEPASCAL} {$ifdef CPUINTEL} {$ifdef HASAESNI} /// SSE 4.2 version of StrComp(), to be used with PUTF8Char/PAnsiChar // - please note that this optimized version may read up to 15 bytes // beyond the string; this is rarely a problem but it may generate protection // violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system // - could be used instead of StrComp() when you are confident about your // Str1/Str2 input buffers, checking if cfSSE42 in CpuFeatures function StrCompSSE42(Str1, Str2: pointer): PtrInt; // - please note that this optimized version may read up to 15 bytes // beyond the string; this is rarely a problem but it may generate protection // violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system // - could be used instead of StrLen() when you are confident about your // S input buffers, checking if cfSSE42 in CpuFeatures function StrLenSSE42(S: pointer): PtrInt; {$endif HASAESNI} /// SSE 4.2 version of strspn(), to be used with PUTF8Char/PAnsiChar // - please note that this optimized version may read up to 15 bytes // beyond the string; this is rarely a problem but it may generate protection // violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system // - could be used instead of strspn() when you are confident about your // s/accept input buffers, checking if cfSSE42 in CpuFeatures function strspnsse42(s,accept: pointer): integer; /// SSE 4.2 version of strcspn(), to be used with PUTF8Char/PAnsiChar // - please note that this optimized version may read up to 15 bytes // beyond the string; this is rarely a problem but it may generate protection // violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system // - could be used instead of strcspn() when you are confident about your // s/reject input buffers, checking if cfSSE42 in CpuFeatures function strcspnsse42(s,reject: pointer): integer; {$endif CPUINTEL} {$endif ABSOLUTEPASCAL} /// use our fast version of StrIComp(), to be used with PUTF8Char/PAnsiChar function StrIComp(Str1, Str2: pointer): PtrInt; {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} /// slower version of StrLen(), but which will never read beyond the string // - this version won't access the memory beyond the string, so may be // preferred to StrLen(), when using e.g. memory mapped files or any memory // protected buffer function StrLenPas(S: pointer): PtrInt; /// our fast version of StrLen(), to be used with PUTF8Char/PAnsiChar // - won't use SSE4.2 instructions on supported CPUs by default, which may read // some bytes beyond the s string, so should be avoided e.g. over memory mapped // files - call explicitely StrLenSSE42() if you are confident on your input var StrLen: function(S: pointer): PtrInt = StrLenPas; /// our fast version of FillChar() // - this version will use fast SSE2 instructions (if available), on both Win32 // and Win64 platforms, or an optimized X86 revision on older CPUs var FillcharFast: procedure(var Dest; count: PtrInt; Value: byte); /// our fast version of move() // - this version will use fast SSE2 instructions (if available), on both Win32 // and Win64 platforms, or an optimized X86 revision on older CPUs var MoveFast: procedure(const Source; var Dest; Count: PtrInt); /// our fast version of StrLen(), to be used with PWideChar function StrLenW(S: PWideChar): PtrInt; /// use our fast version of StrComp(), to be used with PWideChar function StrCompW(Str1, Str2: PWideChar): PtrInt; {$ifdef HASINLINE}inline;{$endif} /// use our fast version of StrCompL(), to be used with PUTF8Char function StrCompL(P1,P2: PUTF8Char; L, Default: Integer): PtrInt; {$ifdef HASINLINE}inline;{$endif} /// use our fast version of StrCompIL(), to be used with PUTF8Char function StrCompIL(P1,P2: PUTF8Char; L: Integer; Default: Integer=0): PtrInt; {$ifdef HASINLINE}inline;{$endif} {$ifdef USENORMTOUPPER} {$ifdef OWNNORMTOUPPER} type TNormTable = packed array[AnsiChar] of AnsiChar; PNormTable = ^TNormTable; TNormTableByte = packed array[byte] of byte; PNormTableByte = ^TNormTableByte; var /// the NormToUpper[] array is defined in our Enhanced RTL: define it now // if it was not installed // - handle 8 bit upper chars as in WinAnsi / code page 1252 (e.g. accents) NormToUpper: TNormTable; NormToUpperByte: TNormTableByte absolute NormToUpper; /// the NormToLower[] array is defined in our Enhanced RTL: define it now // if it was not installed // - handle 8 bit upper chars as in WinAnsi / code page 1252 (e.g. accents) NormToLower: TNormTable; NormToLowerByte: TNormTableByte absolute NormToLower; {$endif} {$else} {$undef OWNNORMTOUPPER} {$endif} var /// this table will convert 'a'..'z' into 'A'..'Z' // - so it will work with UTF-8 without decoding, whereas NormToUpper[] expects // WinAnsi encoding NormToUpperAnsi7: TNormTable; NormToUpperAnsi7Byte: TNormTableByte absolute NormToUpperAnsi7; /// case sensitive NormToUpper[]/NormToLower[]-like table // - i.e. NormToNorm[c] = c NormToNorm: TNormTable; NormToNormByte: TNormTableByte absolute NormToNorm; /// get the signed 32-bit integer value stored in P^ // - we use the PtrInt result type, even if expected to be 32-bit, to use // native CPU register size (don't want any 32-bit overflow here) // - will end parsing when P^ does not contain any number (e.g. it reaches any // ending #0 char) function GetInteger(P: PUTF8Char): PtrInt; overload; /// get the signed 32-bit integer value stored in P^..PEnd^ // - will end parsing when P^ does not contain any number (e.g. it reaches any // ending #0 char), or when P reached PEnd (avoiding any buffer overflow) function GetInteger(P,PEnd: PUTF8Char): PtrInt; overload; /// get the signed 32-bit integer value stored in P^ // - if P if nil or not start with a valid numerical value, returns Default function GetIntegerDef(P: PUTF8Char; Default: PtrInt): PtrInt; {$ifdef HASINLINE}inline;{$endif} /// get the signed 32-bit integer value stored in P^ // - this version return 0 in err if no error occured, and 1 if an invalid // character was found, not its exact index as for the val() function function GetInteger(P: PUTF8Char; var err: integer): PtrInt; overload; /// get the unsigned 32-bit integer value stored in P^ // - we use the PtrUInt result type, even if expected to be 32-bit, to use // native CPU register size (don't want any 32-bit overflow here) function GetCardinal(P: PUTF8Char): PtrUInt; /// get the unsigned 32-bit integer value stored in P^ // - if P if nil or not start with a valid numerical value, returns Default function GetCardinalDef(P: PUTF8Char; Default: PtrUInt): PtrUInt; /// get the unsigned 32-bit integer value stored as Unicode string in P^ function GetCardinalW(P: PWideChar): PtrUInt; /// get a boolean value stored as true/false text in P^ // - would also recognize any non 0 integer as true function GetBoolean(P: PUTF8Char): boolean; /// get the 64-bit integer value stored in P^ function GetInt64(P: PUTF8Char): Int64; overload; {$ifdef HASINLINE}inline;{$endif} /// get the 64-bit integer value stored in P^ // - if P if nil or not start with a valid numerical value, returns Default function GetInt64Def(P: PUTF8Char; const Default: Int64): Int64; /// get the 64-bit signed integer value stored in P^ procedure SetInt64(P: PUTF8Char; var result: Int64); {$ifdef CPU64}inline;{$endif} /// get the 64-bit unsigned integer value stored in P^ procedure SetQWord(P: PUTF8Char; var result: QWord); {$ifdef CPU64}inline;{$endif} /// get the 64-bit signed integer value stored in P^ // - set the err content to the index of any faulty character, 0 if conversion // was successful (same as the standard val function) function GetInt64(P: PUTF8Char; var err: integer): Int64; overload; {$ifdef CPU64}inline;{$endif} /// get the 64-bit unsigned integer value stored in P^ // - set the err content to the index of any faulty character, 0 if conversion // was successful (same as the standard val function) function GetQWord(P: PUTF8Char; var err: integer): QWord; /// get the extended floating point value stored in P^ // - set the err content to the index of any faulty character, 0 if conversion // was successful (same as the standard val function) function GetExtended(P: PUTF8Char; out err: integer): TSynExtended; overload; /// get the extended floating point value stored in P^ // - this overloaded version returns 0 as a result if the content of P is invalid function GetExtended(P: PUTF8Char): TSynExtended; overload; {$ifdef HASINLINE}inline;{$endif} /// get the WideChar stored in P^ (decode UTF-8 if necessary) // - any surrogate (UCS4>$ffff) will be returned as '?' function GetUTF8Char(P: PUTF8Char): cardinal; {$ifdef HASINLINE}inline;{$endif} /// get the UCS4 char stored in P^ (decode UTF-8 if necessary) function NextUTF8UCS4(var P: PUTF8Char): cardinal; {$ifdef HASINLINE}inline;{$endif} /// get the signed 32-bit integer value stored in a RawUTF8 string // - we use the PtrInt result type, even if expected to be 32-bit, to use // native CPU register size (don't want any 32-bit overflow here) function UTF8ToInteger(const value: RawUTF8; Default: PtrInt=0): PtrInt; overload; {$ifdef HASINLINE}inline;{$endif} /// get and check range of a signed 32-bit integer stored in a RawUTF8 string // - we use the PtrInt result type, even if expected to be 32-bit, to use // native CPU register size (don't want any 32-bit overflow here) function UTF8ToInteger(const value: RawUTF8; Min,max: PtrInt; Default: PtrInt=0): PtrInt; overload; {$ifdef HASINLINE}inline;{$endif} /// get the signed 32-bit integer value stored in a RawUTF8 string // - returns TRUE if the supplied text was successfully converted into an integer function ToInteger(const text: RawUTF8; out value: integer): boolean; {$ifdef HASINLINE}inline;{$endif} /// get the unsigned 32-bit cardinal value stored in a RawUTF8 string // - returns TRUE if the supplied text was successfully converted into a cardinal function ToCardinal(const text: RawUTF8; out value: cardinal; minimal: cardinal=0): boolean; {$ifdef HASINLINE}inline;{$endif} /// get the signed 64-bit integer value stored in a RawUTF8 string // - returns TRUE if the supplied text was successfully converted into an Int64 function ToInt64(const text: RawUTF8; out value: Int64): boolean; {$ifdef HASINLINE}inline;{$endif} /// get the signed 64-bit integer value stored in a RawUTF8 string // - returns the default value if the supplied text was not successfully // converted into an Int64 function UTF8ToInt64(const text: RawUTF8; const default: Int64=0): Int64; /// encode a string to be compatible with URI encoding function UrlEncode(const svar: RawUTF8): RawUTF8; overload; /// encode a string to be compatible with URI encoding function UrlEncode(Text: PUTF8Char): RawUTF8; overload; /// encode supplied parameters to be compatible with URI encoding // - parameters must be supplied two by two, as Name,Value pairs, e.g. // ! url := UrlEncode(['select','*','where','ID=12','offset',23,'object',aObject]); // - parameters names should be plain ASCII-7 RFC compatible identifiers // (0..9a..zA..Z_.~), otherwise their values are skipped // - parameters values can be either textual, integer or extended, or any TObject // - TObject serialization into UTF-8 will be processed by the ObjectToJSON() // function function UrlEncode(const NameValuePairs: array of const): RawUTF8; overload; /// encode a JSON object UTF-8 buffer into URI parameters // - you can specify property names to ignore during the object decoding function UrlEncodeJsonObject(const URIName: RawUTF8; ParametersJSON: PUTF8Char; const PropNamesToIgnore: array of RawUTF8): RawUTF8; /// decode a string compatible with URI encoding into its original value // - you can specify the decoding range (as in copy(s,i,len) function) function UrlDecode(const s: RawUTF8; i: PtrInt = 1; len: PtrInt = -1): RawUTF8; overload; /// decode a string compatible with URI encoding into its original value function UrlDecode(U: PUTF8Char): RawUTF8; overload; /// decode a specified parameter compatible with URI encoding into its original // textual value // - UrlDecodeValue('select=%2A&where=LastName%3D%27M%C3%B4net%27','SELECT=',V,@Next) // will return Next^='where=...' and V='*' // - if Upper is not found, Value is not modified, and result is FALSE // - if Upper is found, Value is modified with the supplied content, and result is TRUE function UrlDecodeValue(U: PUTF8Char; const Upper: RawUTF8; var Value: RawUTF8; Next: PPUTF8Char=nil): boolean; /// decode a specified parameter compatible with URI encoding into its original // integer numerical value // - UrlDecodeInteger('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) // will return Next^='where=...' and O=20 // - if Upper is not found, Value is not modified, and result is FALSE // - if Upper is found, Value is modified with the supplied content, and result is TRUE function UrlDecodeInteger(U: PUTF8Char; const Upper: RawUTF8; var Value: integer; Next: PPUTF8Char=nil): boolean; /// decode a specified parameter compatible with URI encoding into its original // cardinal numerical value // - UrlDecodeCardinal('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) // will return Next^='where=...' and O=20 // - if Upper is not found, Value is not modified, and result is FALSE // - if Upper is found, Value is modified with the supplied content, and result is TRUE function UrlDecodeCardinal(U: PUTF8Char; const Upper: RawUTF8; var Value: Cardinal; Next: PPUTF8Char=nil): boolean; /// decode a specified parameter compatible with URI encoding into its original // Int64 numerical value // - UrlDecodeInt64('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) // will return Next^='where=...' and O=20 // - if Upper is not found, Value is not modified, and result is FALSE // - if Upper is found, Value is modified with the supplied content, and result is TRUE function UrlDecodeInt64(U: PUTF8Char; const Upper: RawUTF8; var Value: Int64; Next: PPUTF8Char=nil): boolean; /// decode a specified parameter compatible with URI encoding into its original // floating-point value // - UrlDecodeExtended('price=20.45&where=LastName%3D%27M%C3%B4net%27','PRICE=',P,@Next) // will return Next^='where=...' and P=20.45 // - if Upper is not found, Value is not modified, and result is FALSE // - if Upper is found, Value is modified with the supplied content, and result is TRUE function UrlDecodeExtended(U: PUTF8Char; const Upper: RawUTF8; var Value: TSynExtended; Next: PPUTF8Char=nil): boolean; /// decode a specified parameter compatible with URI encoding into its original // floating-point value // - UrlDecodeDouble('price=20.45&where=LastName%3D%27M%C3%B4net%27','PRICE=',P,@Next) // will return Next^='where=...' and P=20.45 // - if Upper is not found, Value is not modified, and result is FALSE // - if Upper is found, Value is modified with the supplied content, and result is TRUE function UrlDecodeDouble(U: PUTF8Char; const Upper: RawUTF8; var Value: double; Next: PPUTF8Char=nil): boolean; /// returns TRUE if all supplied parameters do exist in the URI encoded text // - CSVNames parameter shall provide as a CSV list of names // - e.g. UrlDecodeNeedParameters('price=20.45&where=LastName%3D','price,where') // will return TRUE function UrlDecodeNeedParameters(U, CSVNames: PUTF8Char): boolean; /// decode the next Name=Value&.... pair from input URI // - Name is returned directly (should be plain ASCII 7 bit text) // - Value is returned after URI decoding (from %.. patterns) // - if a pair is decoded, return a PUTF8Char pointer to the next pair in // the input buffer, or points to #0 if all content has been processed // - if a pair is not decoded, return nil function UrlDecodeNextNameValue(U: PUTF8Char; var Name,Value: RawUTF8): PUTF8Char; /// decode a URI-encoded Value from an input buffer // - decoded value is set in Value out variable // - returns a pointer just after the decoded value (may points e.g. to // #0 or '&') - it is up to the caller to continue the process or not function UrlDecodeNextValue(U: PUTF8Char; out Value: RawUTF8): PUTF8Char; /// decode a URI-encoded Name from an input buffer // - decoded value is set in Name out variable // - returns a pointer just after the decoded name, after the '=' // - returns nil if there was no name=... pattern in U function UrlDecodeNextName(U: PUTF8Char; out Name: RawUTF8): PUTF8Char; /// checks if the supplied UTF-8 text don't need URI encoding // - returns TRUE if all its chars are non-void plain ASCII-7 RFC compatible // identifiers (0..9a..zA..Z-_.~) function IsUrlValid(P: PUTF8Char): boolean; /// checks if the supplied UTF-8 text values don't need URI encoding // - returns TRUE if all its chars of all strings are non-void plain ASCII-7 RFC // compatible identifiers (0..9a..zA..Z-_.~) function AreUrlValid(const Url: array of RawUTF8): boolean; /// ensure the supplied URI contains a trailing '/' charater function IncludeTrailingURIDelimiter(const URI: RawByteString): RawByteString; /// encode name/value pairs into CSV/INI raw format function CSVEncode(const NameValuePairs: array of const; const KeySeparator: RawUTF8='='; const ValueSeparator: RawUTF8=#13#10): RawUTF8; /// find a given name in name/value pairs, and returns the value as RawUTF8 function ArrayOfConstValueAsText(const NameValuePairs: array of const; const aName: RawUTF8): RawUTF8; /// returns TRUE if the given text buffer contains a..z,A..Z,0..9,_ characters // - should match most usual property names values or other identifier names // in the business logic source code // - i.e. can be tested via IdemPropName*() functions, and the MongoDB-like // extended JSON syntax as generated by dvoSerializeAsExtendedJson // - first char must be alphabetical or '_', following chars can be // alphanumerical or '_' function PropNameValid(P: PUTF8Char): boolean; {$ifdef HASINLINE}inline;{$endif} /// returns TRUE if the given text buffers contains A..Z,0..9,_ characters // - use it with property names values (i.e. only including A..Z,0..9,_ chars) // - this function won't check the first char the same way than PropNameValid() function PropNamesValid(const Values: array of RawUTF8): boolean; /// returns TRUE if the given text buffer contains simple characters as // recognized by JSON extended syntax // - follow GetJSONPropName and GotoNextJSONObjectOrArray expectations function JsonPropNameValid(P: PUTF8Char): boolean; {$ifdef HASINLINE}inline;{$endif} /// returns TRUE if the given text buffers would be escaped when written as JSON // - e.g. if contains " or \ characters, as defined by // http://www.ietf.org/rfc/rfc4627.txt function NeedsJsonEscape(const Text: RawUTF8): boolean; /// case insensitive comparison of ASCII identifiers // - use it with property names values (i.e. only including A..Z,0..9,_ chars) function IdemPropName(const P1,P2: shortstring): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// case insensitive comparison of ASCII identifiers // - use it with property names values (i.e. only including A..Z,0..9,_ chars) // - this version expects P2 to be a PAnsiChar with a specified length function IdemPropName(const P1: shortstring; P2: PUTF8Char; P2Len: PtrInt): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// case insensitive comparison of ASCII identifiers // - use it with property names values (i.e. only including A..Z,0..9,_ chars) // - this version expects P1 and P2 to be a PAnsiChar with specified lengths function IdemPropName(P1,P2: PUTF8Char; P1Len,P2Len: PtrInt): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// case insensitive comparison of ASCII identifiers // - use it with property names values (i.e. only including A..Z,0..9,_ chars) // - this version expects P2 to be a PAnsiChar with specified length function IdemPropNameU(const P1: RawUTF8; P2: PUTF8Char; P2Len: PtrInt): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// case insensitive comparison of ASCII identifiers of same length // - use it with property names values (i.e. only including A..Z,0..9,_ chars) // - this version expects P1 and P2 to be a PAnsiChar with an already checked // identical length, so may be used for a faster process, e.g. in a loop // - if P1 and P2 are RawUTF8, you should better call overloaded function // IdemPropNameU(const P1,P2: RawUTF8), which would be slightly faster by // using the length stored before the actual text buffer of each RawUTF8 function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: PtrInt): boolean; {$ifndef ANDROID}{$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}{$endif} /// case insensitive comparison of ASCII identifiers // - use it with property names values (i.e. only including A..Z,0..9,_ chars) function IdemPropNameU(const P1,P2: RawUTF8): boolean; overload; {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} /// returns true if the beginning of p^ is the same as up^ // - ignore case - up^ must be already Upper // - chars are compared as 7 bit Ansi only (no accentuated characters): but when // you only need to search for field names e.g. IdemPChar() is prefered, because // it'll be faster than IdemPCharU(), if UTF-8 decoding is not mandatory // - if p is nil, will return FALSE // - if up is nil, will return TRUE function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean; {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} /// returns true if the beginning of p^ is the same as up^, ignoring white spaces // - ignore case - up^ must be already Upper // - any white space in the input p^ buffer is just ignored // - chars are compared as 7 bit Ansi only (no accentuated characters): but when // you only need to search for field names e.g. IdemPChar() is prefered, because // it'll be faster than IdemPCharU(), if UTF-8 decoding is not mandatory // - if p is nil, will return FALSE // - if up is nil, will return TRUE function IdemPCharWithoutWhiteSpace(p: PUTF8Char; up: PAnsiChar): boolean; /// returns the index of a matching beginning of p^ in upArray[] // - returns -1 if no item matched // - ignore case - upArray^ must be already Upper // - chars are compared as 7 bit Ansi only (no accentuated characters) // - warning: this function expects upArray[] items to have AT LEAST TWO // CHARS (it will use a fast comparison of initial 2 bytes) function IdemPCharArray(p: PUTF8Char; const upArray: array of PAnsiChar): integer; overload; /// returns the index of a matching beginning of p^ in upArray two characters // - returns -1 if no item matched // - ignore case - upArray^ must be already Upper // - chars are compared as 7 bit Ansi only (no accentuated characters) function IdemPCharArray(p: PUTF8Char; const upArrayBy2Chars: RawUTF8): integer; overload; {$ifdef HASINLINE}inline;{$endif} /// returns true if the beginning of p^ is the same as up^ // - ignore case - up^ must be already Upper // - this version will decode the UTF-8 content before using NormToUpper[], so // it will be slower than the IdemPChar() function above, but will handle // WinAnsi accentuated characters (e.g. 'e' acute will be matched as 'E') function IdemPCharU(p, up: PUTF8Char): boolean; {$ifdef HASINLINE}inline;{$endif} /// returns true if the beginning of p^ is same as up^ // - ignore case - up^ must be already Upper // - this version expects p^ to point to an Unicode char array function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; /// check matching ending of p^ in upText // - returns true if the item matched // - ignore case - upText^ must be already Upper // - chars are compared as 7 bit Ansi only (no accentuated characters) function EndWith(const text, upText: RawUTF8): boolean; {$ifdef HASINLINE}inline;{$endif} /// returns the index of a matching ending of p^ in upArray[] // - returns -1 if no item matched // - ignore case - upArray^ must be already Upper // - chars are compared as 7 bit Ansi only (no accentuated characters) function EndWithArray(const text: RawUTF8; const upArray: array of RawUTF8): integer; /// returns true if the file name extension contained in p^ is the same same as extup^ // - ignore case - extup^ must be already Upper // - chars are compared as WinAnsi (codepage 1252), not as UTF-8 // - could be used e.g. like IdemFileExt(aFileName,'.JP'); function IdemFileExt(p: PUTF8Char; extup: PAnsiChar; sepChar: AnsiChar='.'): Boolean; /// internal function, used to retrieve a UCS4 char (>127) from UTF-8 // - not to be called directly, but from inlined higher-level functions // - here U^ shall be always >= #80 // - typical use is as such: // ! ch := ord(P^); // ! if ch and $80=0 then // ! inc(P) else // ! ch := GetHighUTF8UCS4(P); function GetHighUTF8UCS4(var U: PUTF8Char): PtrUInt; /// retrieve the next UCS4 value stored in U, then update the U pointer // - this function will decode the UTF-8 content before using NormToUpper[] // - will return '?' if the UCS4 value is higher than #255: so use this function // only if you need to deal with ASCII characters (e.g. it's used for Soundex // and for ContainsUTF8 function) function GetNextUTF8Upper(var U: PUTF8Char): PtrUInt; {$ifdef HASINLINE}inline;{$endif} /// points to the beginning of the next word stored in U // - returns nil if reached the end of U (i.e. #0 char) // - here a "word" is a Win-Ansi word, i.e. '0'..'9', 'A'..'Z' function FindNextUTF8WordBegin(U: PUTF8Char): PUTF8Char; /// return true if up^ is contained inside the UTF-8 buffer p^ // - search up^ at the beginning of every UTF-8 word (aka in Soundex) // - here a "word" is a Win-Ansi word, i.e. '0'..'9', 'A'..'Z' // - up^ must be already Upper function ContainsUTF8(p, up: PUTF8Char): boolean; /// returns TRUE if the supplied uppercased text is contained in the text buffer function GetLineContains(p,pEnd, up: PUTF8Char): boolean; {$ifdef HASINLINE}inline;{$endif} /// copy source into a 256 chars dest^ buffer with 7 bits upper case conversion // - used internally for short keys match or case-insensitive hash // - returns final dest pointer // - will copy up to 255 AnsiChar (expect the dest buffer to be defined e.g. as // array[byte] of AnsiChar on the caller stack) function UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; overload; {$ifdef HASINLINE}inline;{$endif} /// copy source^ into a 256 chars dest^ buffer with 7 bits upper case conversion // - used internally for short keys match or case-insensitive hash // - returns final dest pointer // - will copy up to 255 AnsiChar (expect the dest buffer to be defined e.g. as // array[byte] of AnsiChar on the caller stack) // - won't use SSE4.2 instructions on supported CPUs by default, which may read // some bytes beyond the s string, so should be avoided e.g. over memory mapped // files - call explicitely UpperCopy255BufSSE42() if you are confident on your input var UpperCopy255Buf: function(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; /// copy source^ into a 256 chars dest^ buffer with 7 bits upper case conversion // - used internally for short keys match or case-insensitive hash // - this version is written in optimized pascal // - you should not have to call this function, but rely on UpperCopy255Buf() // - returns final dest pointer // - will copy up to 255 AnsiChar (expect the dest buffer to be defined e.g. as // array[byte] of AnsiChar on the caller stack) function UpperCopy255BufPas(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; {$ifndef PUREPASCAL} {$ifndef DELPHI5OROLDER} /// SSE 4.2 version of UpperCopy255Buf() // - copy source^ into a 256 chars dest^ buffer with 7 bits upper case conversion // - please note that this optimized version may read up to 15 bytes // beyond the string; this is rarely a problem but it may generate protection // violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system // - could be used instead of UpperCopy255Buf() when you are confident about your // dest/source input buffers, checking if cfSSE42 in CpuFeatures function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; {$endif DELPHI5OROLDER} {$endif PUREPASCAL} /// copy source into dest^ with WinAnsi 8 bits upper case conversion // - used internally for short keys match or case-insensitive hash // - returns final dest pointer // - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of // AnsiChar) function UpperCopyWin255(dest: PWinAnsiChar; const source: RawUTF8): PWinAnsiChar; /// copy WideChar source into dest^ with upper case conversion // - used internally for short keys match or case-insensitive hash // - returns final dest pointer // - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of // AnsiChar) function UpperCopy255W(dest: PAnsiChar; const source: SynUnicode): PAnsiChar; overload; /// copy WideChar source into dest^ with upper case conversion // - used internally for short keys match or case-insensitive hash // - returns final dest pointer // - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of // AnsiChar) function UpperCopy255W(dest: PAnsiChar; source: PWideChar; L: integer): PAnsiChar; overload; /// copy source into dest^ with 7 bits upper case conversion // - returns final dest pointer // - will copy up to the source buffer end: so Dest^ should be big enough - // which will the case e.g. if Dest := pointer(source) function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; /// copy source into dest^ with 7 bits upper case conversion // - returns final dest pointer // - this special version expect source to be a shortstring function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar; {$ifdef USENORMTOUPPER} /// fast UTF-8 comparaison using the NormToUpper[] array for all 8 bits values // - this version expects u1 and u2 to be zero-terminated // - this version will decode each UTF-8 glyph before using NormToUpper[] // - current implementation handles UTF-16 surrogates function UTF8IComp(u1, u2: PUTF8Char): PtrInt; /// copy WideChar source into dest^ with upper case conversion, using the // NormToUpper[] array for all 8 bits values, encoding the result as UTF-8 // - returns final dest pointer // - current implementation handles UTF-16 surrogates function UTF8UpperCopy(Dest, Source: PUTF8Char; SourceChars: Cardinal): PUTF8Char; /// copy WideChar source into dest^ with upper case conversion, using the // NormToUpper[] array for all 8 bits values, encoding the result as UTF-8 // - returns final dest pointer // - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of // AnsiChar), with UTF-8 encoding function UTF8UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PUTF8Char; {$ifdef HASINLINE}inline;{$endif} /// fast UTF-8 comparaison using the NormToUpper[] array for all 8 bits values // - this version expects u1 and u2 not to be necessary zero-terminated, but // uses L1 and L2 as length for u1 and u2 respectively // - use this function for SQLite3 collation (TSQLCollateFunc) // - this version will decode the UTF-8 content before using NormToUpper[] // - current implementation handles UTF-16 surrogates function UTF8ILComp(u1, u2: PUTF8Char; L1,L2: cardinal): PtrInt; /// fast case-insensitive Unicode comparaison // - use the NormToUpperAnsi7Byte[] array, i.e. compare 'a'..'z' as 'A'..'Z' // - this version expects u1 and u2 to be zero-terminated function AnsiICompW(u1, u2: PWideChar): PtrInt; /// SameText() overloaded function with proper UTF-8 decoding // - fast version using NormToUpper[] array for all Win-Ansi characters // - this version will decode each UTF-8 glyph before using NormToUpper[] // - current implementation handles UTF-16 surrogates as UTF8IComp() function SameTextU(const S1, S2: RawUTF8): Boolean; {$ifdef HASINLINE}inline;{$endif} /// fast conversion of the supplied text into 8 bit uppercase // - this will not only convert 'a'..'z' into 'A'..'Z', but also accentuated // latin characters ('e' acute into 'E' e.g.), using NormToUpper[] array // - it will therefore decode the supplied UTF-8 content to handle more than // 7 bit of ascii characters (so this function is dedicated to WinAnsi code page // 1252 characters set) function UpperCaseU(const S: RawUTF8): RawUTF8; /// fast conversion of the supplied text into 8 bit lowercase // - this will not only convert 'A'..'Z' into 'a'..'z', but also accentuated // latin characters ('E' acute into 'e' e.g.), using NormToLower[] array // - it will therefore decode the supplied UTF-8 content to handle more than // 7 bit of ascii characters function LowerCaseU(const S: RawUTF8): RawUTF8; /// fast conversion of the supplied text into 8 bit case sensitivity // - convert the text in-place, returns the resulting length // - it will decode the supplied UTF-8 content to handle more than 7 bit // of ascii characters during the conversion (leaving not WinAnsi characters // untouched) // - will not set the last char to #0 (caller must do that if necessary) function ConvertCaseUTF8(P: PUTF8Char; const Table: TNormTableByte): PtrInt; {$endif USENORMTOUPPER} /// check if the supplied text has some case-insentitive 'a'..'z','A'..'Z' chars // - will therefore be correct with true UTF-8 content, but only for 7 bit function IsCaseSensitive(const S: RawUTF8): boolean; overload; /// check if the supplied text has some case-insentitive 'a'..'z','A'..'Z' chars // - will therefore be correct with true UTF-8 content, but only for 7 bit function IsCaseSensitive(P: PUTF8Char; PLen: integer): boolean; overload; /// fast conversion of the supplied text into uppercase // - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and // will therefore be correct with true UTF-8 content, but only for 7 bit function UpperCase(const S: RawUTF8): RawUTF8; /// fast conversion of the supplied text into uppercase // - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and // will therefore be correct with true UTF-8 content, but only for 7 bit procedure UpperCaseCopy(Text: PUTF8Char; Len: integer; var result: RawUTF8); overload; /// fast conversion of the supplied text into uppercase // - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and // will therefore be correct with true UTF-8 content, but only for 7 bit procedure UpperCaseCopy(const Source: RawUTF8; var Dest: RawUTF8); overload; /// fast in-place conversion of the supplied variable text into uppercase // - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and // will therefore be correct with true UTF-8 content, but only for 7 bit procedure UpperCaseSelf(var S: RawUTF8); /// fast conversion of the supplied text into lowercase // - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and // will therefore be correct with true UTF-8 content function LowerCase(const S: RawUTF8): RawUTF8; /// fast conversion of the supplied text into lowercase // - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and // will therefore be correct with true UTF-8 content procedure LowerCaseCopy(Text: PUTF8Char; Len: integer; var result: RawUTF8); /// fast in-place conversion of the supplied variable text into lowercase // - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and // will therefore be correct with true UTF-8 content, but only for 7 bit procedure LowerCaseSelf(var S: RawUTF8); /// accurate conversion of the supplied UTF-8 content into the corresponding // upper-case Unicode characters // - this version will use the Operating System API, and will therefore be // much slower than UpperCase/UpperCaseU versions, but will handle all // kind of unicode characters function UpperCaseUnicode(const S: RawUTF8): RawUTF8; /// accurate conversion of the supplied UTF-8 content into the corresponding // lower-case Unicode characters // - this version will use the Operating System API, and will therefore be // much slower than LowerCase/LowerCaseU versions, but will handle all // kind of unicode characters function LowerCaseUnicode(const S: RawUTF8): RawUTF8; /// trims leading whitespace characters from the string by removing // new line, space, and tab characters function TrimLeft(const S: RawUTF8): RawUTF8; /// trims trailing whitespace characters from the string by removing trailing // newline, space, and tab characters function TrimRight(const S: RawUTF8): RawUTF8; /// fast WinAnsi comparaison using the NormToUpper[] array for all 8 bits values function AnsiIComp(Str1, Str2: PWinAnsiChar): PtrInt; {$ifndef USENORMTOUPPER} {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} {$endif} /// extract a line from source array of chars // - next will contain the beginning of next line, or nil if source if ended function GetNextLine(source: PUTF8Char; out next: PUTF8Char): RawUTF8; {$ifdef UNICODE} /// extract a line from source array of chars // - next will contain the beginning of next line, or nil if source if ended // - this special version expect UnicodeString pointers, and return an UnicodeString function GetNextLineW(source: PWideChar; out next: PWideChar): string; /// find the Value of UpperName in P, till end of current section // - expect UpperName as 'NAME=' // - this special version expect UnicodeString pointer, and return a VCL string function FindIniNameValueW(P: PWideChar; UpperName: PUTF8Char): string; /// find a Name= Value in a [Section] of a INI Unicode Content // - this function scans the Content memory buffer, and is // therefore very fast (no temporary TMemIniFile is created) // - if Section equals '', find the Name= value before any [Section] function FindIniEntryW(const Content: string; const Section, Name: RawUTF8): string; {$endif UNICODE} {$ifdef PUREPASCAL} {$ifdef HASINLINE} function PosExPas(pSub, p: PUTF8Char; Offset: PtrUInt): PtrInt; function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt=1): PtrInt; inline; {$else} var PosEx: function(const SubStr, S: RawUTF8; Offset: PtrUInt=1): PtrInt; {$endif} {$else} /// faster RawUTF8 Equivalent of standard StrUtils.PosEx function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt=1): integer; {$endif PUREPASCAL} /// optimized version of PosEx() with search text as one AnsiChar function PosExChar(Chr: AnsiChar; const Str: RawUTF8): PtrInt; {$ifdef HASINLINE}inline;{$endif} /// split a RawUTF8 string into two strings, according to SepStr separator // - if SepStr is not found, LeftStr=Str and RightStr='' // - if ToUpperCase is TRUE, then LeftStr and RightStr will be made uppercase procedure Split(const Str, SepStr: RawUTF8; var LeftStr, RightStr: RawUTF8; ToUpperCase: boolean=false); overload; /// split a RawUTF8 string into two strings, according to SepStr separator // - this overloaded function returns the right string as function result // - if SepStr is not found, LeftStr=Str and result='' // - if ToUpperCase is TRUE, then LeftStr and result will be made uppercase function Split(const Str, SepStr: RawUTF8; var LeftStr: RawUTF8; ToUpperCase: boolean=false): RawUTF8; overload; /// returns the left part of a RawUTF8 string, according to SepStr separator // - if SepStr is found, returns Str first chars until (and excluding) SepStr // - if SepStr is not found, returns Str function Split(const Str, SepStr: RawUTF8; StartPos: integer=1): RawUTF8; overload; /// split a RawUTF8 string into several strings, according to SepStr separator // - this overloaded function will fill a DestPtr[] array of PRawUTF8 // - if any DestPtr[]=nil, the item will be skipped procedure Split(const Str: RawUTF8; const SepStr: array of RawUTF8; const DestPtr: array of PRawUTF8); overload; /// returns the last occurence of the given SepChar separated context // - e.g. SplitRight('01/2/34','/')='34' // - if SepChar doesn't appear, will return Str, e.g. SplitRight('123','/')='123' // - if LeftStr is supplied, the RawUTF8 it points to will be filled with // the left part just before SepChar ('' if SepChar doesn't appear) function SplitRight(const Str: RawUTF8; SepChar: AnsiChar; LeftStr: PRawUTF8=nil): RawUTF8; /// returns the last occurence of the given SepChar separated context // - e.g. SplitRight('path/one\two/file.ext','/\')='file.ext', i.e. // SepChars='/\' will be like ExtractFileName() over RawUTF8 string // - if SepChar doesn't appear, will return Str, e.g. SplitRight('123','/')='123' function SplitRights(const Str, SepChar: RawUTF8): RawUTF8; /// fast version of StringReplace(S, OldPattern, NewPattern,[rfReplaceAll]); function StringReplaceAll(const S, OldPattern, NewPattern: RawUTF8): RawUTF8; /// fast replace of a specified char by a given string function StringReplaceChars(const Source: RawUTF8; OldChar, NewChar: AnsiChar): RawUTF8; /// fast replace of all #9 chars by a given string function StringReplaceTabs(const Source,TabText: RawUTF8): RawUTF8; /// format a text content with SQL-like quotes // - UTF-8 version of the function available in SysUtils // - this function implements what is specified in the official SQLite3 // documentation: "A string constant is formed by enclosing the string in single // quotes ('). A single quote within the string can be encoded by putting two // single quotes in a row - as in Pascal." function QuotedStr(const S: RawUTF8; Quote: AnsiChar=''''): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// format a buffered text content with SQL-like quotes // - this function implements what is specified in the official SQLite3 // documentation: "A string constant is formed by enclosing the string in single // quotes ('). A single quote within the string can be encoded by putting two // single quotes in a row - as in Pascal." function QuotedStr(Text: PUTF8Char; Quote: AnsiChar): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// format a buffered text content with SQL-like quotes // - this function implements what is specified in the official SQLite3 // documentation: "A string constant is formed by enclosing the string in single // quotes ('). A single quote within the string can be encoded by putting two // single quotes in a row - as in Pascal." procedure QuotedStr(Text: PUTF8Char; Quote: AnsiChar; var result: RawUTF8); overload; /// convert a buffered text content into a JSON string // - with proper escaping of the content, and surounding " characters procedure QuotedStrJSON(const aText: RawUTF8; var result: RawUTF8; const aPrefix: RawUTF8=''; const aSuffix: RawUTF8=''); /// unquote a SQL-compatible string // - the first character in P^ must be either ', either " then double quotes // are transformed into single quotes // - 'text '' end' -> text ' end // - "text "" end" -> text " end // - returns nil if P doesn't contain a valid SQL string // - returns a pointer just after the quoted text otherwise function UnQuoteSQLStringVar(P: PUTF8Char; out Value: RawUTF8): PUTF8Char; /// unquote a SQL-compatible string function UnQuoteSQLString(const Value: RawUTF8): RawUTF8; /// unquote a SQL-compatible symbol name // - e.g. '[symbol]' -> 'symbol' or '"symbol"' -> 'symbol' function UnQuotedSQLSymbolName(const ExternalDBSymbol: RawUTF8): RawUTF8; /// get the next character after a quoted buffer // - the first character in P^ must be either ', either " // - it will return the latest quote position, ignoring double quotes within function GotoEndOfQuotedString(P: PUTF8Char): PUTF8Char; {$ifdef HASINLINE}inline;{$endif} /// get the next character after a quoted buffer // - the first character in P^ must be " // - it will return the latest " position, ignoring \" within function GotoEndOfJSONString(P: PUTF8Char): PUTF8Char; {$ifdef HASINLINE}inline;{$endif} /// get the next character not in [#1..' '] function GotoNextNotSpace(P: PUTF8Char): PUTF8Char; {$ifdef HASINLINE}inline;{$endif} /// get the next character in [#1..' '] function GotoNextSpace(P: PUTF8Char): PUTF8Char; {$ifdef HASINLINE}inline;{$endif} /// check if the next character not in [#1..' '] matchs a given value // - first ignore any non space character // - then returns TRUE if P^=ch, setting P to the character after ch // - or returns FALSE if P^<>ch, leaving P at the level of the unexpected char function NextNotSpaceCharIs(var P: PUTF8Char; ch: AnsiChar): boolean; {$ifdef HASINLINE}inline;{$endif} /// go to the beginning of the SQL statement, ignoring all blanks and comments // - used to check the SQL statement command (e.g. is it a SELECT?) function SQLBegin(P: PUTF8Char): PUTF8Char; /// add a condition to a SQL WHERE clause, with an ' and ' if where is not void procedure SQLAddWhereAnd(var where: RawUTF8; const condition: RawUTF8); /// return true if the parameter is void or begin with a 'SELECT' SQL statement // - used to avoid code injection and to check if the cache must be flushed // - VACUUM, PRAGMA, or EXPLAIN statements also return true, since they won't // change the data content // - WITH recursive statement expect no INSERT/UPDATE/DELETE pattern in the SQL // - if P^ is a SELECT and SelectClause is set to a variable, it would // contain the field names, from SELECT ...field names... FROM function isSelect(P: PUTF8Char; SelectClause: PRawUTF8=nil): boolean; /// return true if IdemPChar(source,searchUp), and go to the next line of source function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean; /// return true if IdemPChar(source,searchUp), and retrieve the value item // - typical use may be: // ! if IdemPCharAndGetNextItem(P, // ! 'CONTENT-DISPOSITION: FORM-DATA; NAME="',Name,'"') then ... function IdemPCharAndGetNextItem(var source: PUTF8Char; const searchUp: RawUTF8; var Item: RawUTF8; Sep: AnsiChar=#13): boolean; /// fast go to next text line, ended by #13 or #13#10 // - returns the beginning of next line, or nil if source^=#0 was reached function GotoNextLine(source: PUTF8Char): PUTF8Char; {$ifdef HASINLINE}inline;{$endif} /// compute the line length from a size-delimited source array of chars // - will use fast assembly on x86-64 CPU, and expects TextEnd to be not nil // - is likely to read some bytes after the TextEnd buffer, so GetLineSize() // may be preferred, e.g. on memory mapped files function BufferLineLength(Text, TextEnd: PUTF8Char): PtrInt; {$ifndef CPUX64}{$ifdef FPC}inline;{$endif}{$endif} /// compute the line length from source array of chars // - if PEnd = nil, end counting at either #0, #13 or #10 // - otherwise, end counting at either #13 or #10 function GetLineSize(P,PEnd: PUTF8Char): PtrUInt; /// returns true if the line length from source array of chars is not less than // the specified count function GetLineSizeSmallerThan(P,PEnd: PUTF8Char; aMinimalCount: integer): boolean; /// return next CSV string from P // - P=nil after call when end of text is reached function GetNextItem(var P: PUTF8Char; Sep: AnsiChar= ','): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// return next CSV string from P // - P=nil after call when end of text is reached procedure GetNextItem(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); overload; /// return next CSV string (unquoted if needed) from P // - P=nil after call when end of text is reached procedure GetNextItem(var P: PUTF8Char; Sep, Quote: AnsiChar; var result: RawUTF8); overload; /// return trimmed next CSV string from P // - P=nil after call when end of text is reached procedure GetNextItemTrimed(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); /// return next CRLF separated value string from P, ending #10 or #13#10 trimmed // - any kind of line feed (CRLF or LF) will be handled, on all operating systems // - as used e.g. by TSynNameValue.InitFromCSV and TDocVariantData.InitCSV // - P=nil after call when end of text is reached procedure GetNextItemTrimedCRLF(var P: PUTF8Char; var result: RawUTF8); /// return next CSV string from P, nil if no more // - this function returns the generic string type of the compiler, and // therefore can be used with ready to be displayed text (e.g. for the VCL) function GetNextItemString(var P: PChar; Sep: Char= ','): string; /// return next string delimited with #13#10 from P, nil if no more // - this function returns a RawUnicode string type function GetNextStringLineToRawUnicode(var P: PChar): RawUnicode; /// append some text lines with the supplied Values[] // - if any Values[] item is '', no line is added // - otherwise, appends 'Caption: Value', with Caption taken from CSV procedure AppendCSVValues(const CSV: string; const Values: array of string; var Result: string; const AppendBefore: string=#13#10); /// return a CSV list of the iterated same value // - e.g. CSVOfValue('?',3)='?,?,?' function CSVOfValue(const Value: RawUTF8; Count: cardinal; const Sep: RawUTF8=','): RawUTF8; /// retrieve the next CSV separated bit index // - each bit was stored as BitIndex+1, i.e. 0 to mark end of CSV chunk // - several bits set to one can be regrouped via 'first-last,' syntax procedure SetBitCSV(var Bits; BitsCount: integer; var P: PUTF8Char); /// convert a set of bit into a CSV content // - each bit is stored as BitIndex+1, and separated by a ',' // - several bits set to one can be regrouped via 'first-last,' syntax // - ',0' is always appended at the end of the CSV chunk to mark its end function GetBitCSV(const Bits; BitsCount: integer): RawUTF8; /// return next CSV string from P, nil if no more // - output text would be trimmed from any left or right space procedure GetNextItemShortString(var P: PUTF8Char; out Dest: ShortString; Sep: AnsiChar= ','); /// decode next CSV hexadecimal string from P, nil if no more or not matching BinBytes // - Bin is filled with 0 if the supplied CSV content is invalid // - if Sep is #0, it will read the hexadecimal chars until a whitespace is reached function GetNextItemHexDisplayToBin(var P: PUTF8Char; Bin: PByte; BinBytes: integer; Sep: AnsiChar= ','): boolean; type /// some stack-allocated zero-terminated character buffer // - as used by GetNextTChar64 TChar64 = array[0..63] of AnsiChar; /// return next CSV string from P as a #0-ended buffer, false if no more // - if Sep is #0, will copy all characters until next whitespace char // - returns the number of bytes stored into Buf[] function GetNextTChar64(var P: PUTF8Char; Sep: AnsiChar; out Buf: TChar64): PtrInt; /// return next CSV string as unsigned integer from P, 0 if no more // - if Sep is #0, it won't be searched for function GetNextItemCardinal(var P: PUTF8Char; Sep: AnsiChar=','): PtrUInt; /// return next CSV string as signed integer from P, 0 if no more // - if Sep is #0, it won't be searched for function GetNextItemInteger(var P: PUTF8Char; Sep: AnsiChar=','): PtrInt; /// return next CSV string as 64-bit signed integer from P, 0 if no more // - if Sep is #0, it won't be searched for function GetNextItemInt64(var P: PUTF8Char; Sep: AnsiChar=','): Int64; /// return next CSV string as 64-bit unsigned integer from P, 0 if no more // - if Sep is #0, it won't be searched for function GetNextItemQWord(var P: PUTF8Char; Sep: AnsiChar=','): QWord; /// return next CSV hexadecimal string as 64-bit unsigned integer from P // - returns 0 if no valid hexadecimal text is available in P // - if Sep is #0, it won't be searched for // - will first fill the 64-bit value with 0, then decode each two hexadecimal // characters available in P // - could be used to decode TTextWriter.AddBinToHexDisplayMinChars() output function GetNextItemHexa(var P: PUTF8Char; Sep: AnsiChar=','): QWord; /// return next CSV string as unsigned integer from P, 0 if no more // - P^ will point to the first non digit character (the item separator, e.g. // ',' for CSV) function GetNextItemCardinalStrict(var P: PUTF8Char): PtrUInt; /// return next CSV string as unsigned integer from P, 0 if no more // - this version expects P^ to point to an Unicode char array function GetNextItemCardinalW(var P: PWideChar; Sep: WideChar=','): PtrUInt; /// return next CSV string as double from P, 0.0 if no more // - if Sep is #0, will return all characters until next whitespace char function GetNextItemDouble(var P: PUTF8Char; Sep: AnsiChar=','): double; /// return next CSV string as currency from P, 0.0 if no more // - if Sep is #0, will return all characters until next whitespace char function GetNextItemCurrency(var P: PUTF8Char; Sep: AnsiChar=','): currency; overload; {$ifdef HASINLINE}inline;{$endif} /// return next CSV string as currency from P, 0.0 if no more // - if Sep is #0, will return all characters until next whitespace char procedure GetNextItemCurrency(var P: PUTF8Char; out result: currency; Sep: AnsiChar=','); overload; /// return n-th indexed CSV string in P, starting at Index=0 for first one function GetCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar=','): RawUTF8; overload; /// return n-th indexed CSV string (unquoted if needed) in P, starting at Index=0 for first one function GetUnQuoteCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar=','; Quote: AnsiChar=''''): RawUTF8; overload; /// return n-th indexed CSV string in P, starting at Index=0 for first one // - this function return the generic string type of the compiler, and // therefore can be used with ready to be displayed text (i.e. the VCL) function GetCSVItemString(P: PChar; Index: PtrUInt; Sep: Char=','): string; /// return last CSV string in the supplied UTF-8 content function GetLastCSVItem(const CSV: RawUTF8; Sep: AnsiChar=','): RawUTF8; /// return the index of a Value in a CSV string // - start at Index=0 for first one // - return -1 if specified Value was not found in CSV items function FindCSVIndex(CSV: PUTF8Char; const Value: RawUTF8; Sep: AnsiChar = ','; CaseSensitive: boolean=true; TrimValue: boolean=false): integer; /// add the strings in the specified CSV text into a dynamic array of UTF-8 strings procedure CSVToRawUTF8DynArray(CSV: PUTF8Char; var Result: TRawUTF8DynArray; Sep: AnsiChar=','; TrimItems: boolean=false; AddVoidItems: boolean=false); overload; /// add the strings in the specified CSV text into a dynamic array of UTF-8 strings procedure CSVToRawUTF8DynArray(const CSV,Sep,SepEnd: RawUTF8; var Result: TRawUTF8DynArray); overload; /// return the corresponding CSV text from a dynamic array of UTF-8 strings function RawUTF8ArrayToCSV(const Values: array of RawUTF8; const Sep: RawUTF8= ','): RawUTF8; /// return the corresponding CSV quoted text from a dynamic array of UTF-8 strings // - apply QuoteStr() function to each Values[] item function RawUTF8ArrayToQuotedCSV(const Values: array of RawUTF8; const Sep: RawUTF8=','; Quote: AnsiChar=''''): RawUTF8; /// append some prefix to all CSV values // ! AddPrefixToCSV('One,Two,Three','Pre')='PreOne,PreTwo,PreThree' function AddPrefixToCSV(CSV: PUTF8Char; const Prefix: RawUTF8; Sep: AnsiChar = ','): RawUTF8; /// append a Value to a CSV string procedure AddToCSV(const Value: RawUTF8; var CSV: RawUTF8; const Sep: RawUTF8 = ','); {$ifdef HASINLINE}inline;{$endif} /// change a Value within a CSV string function RenameInCSV(const OldValue, NewValue: RawUTF8; var CSV: RawUTF8; const Sep: RawUTF8 = ','): boolean; /// quick helper to initialize a dynamic array of RawUTF8 from some constants // - can be used e.g. as: // ! MyArray := TRawUTF8DynArrayFrom(['a','b','c']); function TRawUTF8DynArrayFrom(const Values: array of RawUTF8): TRawUTF8DynArray; /// append one or several values to a local "array of const" variable procedure AddArrayOfConst(var Dest: TTVarRecDynArray; const Values: array of const); /// return the index of Value in Values[], -1 if not found function FindRawUTF8(const Values: TRawUTF8DynArray; const Value: RawUTF8; CaseSensitive: boolean=true): integer; overload; /// return the index of Value in Values[], -1 if not found // - can optionally call IdemPropNameU() for property matching function FindRawUTF8(const Values: TRawUTF8DynArray; ValuesCount: integer; const Value: RawUTF8; SearchPropName: boolean): integer; overload; /// return the index of Value in Values[], -1 if not found function FindRawUTF8(const Values: array of RawUTF8; const Value: RawUTF8; CaseSensitive: boolean=true): integer; overload; /// return the index of Value in Values[], -1 if not found // - here name search would use fast IdemPropNameU() function function FindPropName(const Names: array of RawUTF8; const Name: RawUTF8): integer; /// true if Value was added successfully in Values[] function AddRawUTF8(var Values: TRawUTF8DynArray; const Value: RawUTF8; NoDuplicates: boolean=false; CaseSensitive: boolean=true): boolean; overload; /// add the Value to Values[], with an external count variable, for performance procedure AddRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; const Value: RawUTF8); overload; type /// simple stack-allocated type for handling a type names list {$ifdef FPC_OR_UNICODE}TPropNameList = record{$else}TPropNameList = object{$endif} public Values: TRawUTF8DynArray; Count: Integer; /// initialize the list // - set Count := 0 procedure Init; /// search for a Value within Values[0..Count-1] using IdemPropNameU() function FindPropName(const Value: RawUTF8): Integer; /// if Value is in Values[0..Count-1] using IdemPropNameU() returns FALSE // - otherwise, returns TRUE and add Value to Values[] function AddPropName(const Value: RawUTF8): Boolean; end; /// true if both TRawUTF8DynArray are the same // - comparison is case-sensitive function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray): boolean; overload; /// true if both TRawUTF8DynArray are the same for a given number of items // - A and B are expected to have at least Count items // - comparison is case-sensitive function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray; Count: integer): boolean; overload; /// convert the string dynamic array into a dynamic array of UTF-8 strings procedure StringDynArrayToRawUTF8DynArray(const Source: TStringDynArray; var Result: TRawUTF8DynArray); /// convert the string list into a dynamic array of UTF-8 strings procedure StringListToRawUTF8DynArray(Source: TStringList; var Result: TRawUTF8DynArray); /// find a Name= Value in a [Section] of a INI RawUTF8 Content // - this function scans the Content memory buffer, and is // therefore very fast (no temporary TMemIniFile is created) // - if Section equals '', find the Name= value before any [Section] function FindIniEntry(const Content, Section,Name: RawUTF8): RawUTF8; /// find a Name= Value in a [Section] of a INI WinAnsi Content // - same as FindIniEntry(), but the value is converted from WinAnsi into UTF-8 function FindWinAnsiIniEntry(const Content, Section,Name: RawUTF8): RawUTF8; /// find a Name= numeric Value in a [Section] of a INI RawUTF8 Content and // return it as an integer, or 0 if not found // - this function scans the Content memory buffer, and is // therefore very fast (no temporary TMemIniFile is created) // - if Section equals '', find the Name= value before any [Section] function FindIniEntryInteger(const Content, Section,Name: RawUTF8): integer; {$ifdef HASINLINE}inline;{$endif} /// find a Name= Value in a [Section] of a .INI file // - if Section equals '', find the Name= value before any [Section] // - use internaly fast FindIniEntry() function above function FindIniEntryFile(const FileName: TFileName; const Section,Name: RawUTF8): RawUTF8; /// update a Name= Value in a [Section] of a INI RawUTF8 Content // - this function scans and update the Content memory buffer, and is // therefore very fast (no temporary TMemIniFile is created) // - if Section equals '', update the Name= value before any [Section] procedure UpdateIniEntry(var Content: RawUTF8; const Section,Name,Value: RawUTF8); /// update a Name= Value in a [Section] of a .INI file // - if Section equals '', update the Name= value before any [Section] // - use internaly fast UpdateIniEntry() function above procedure UpdateIniEntryFile(const FileName: TFileName; const Section,Name,Value: RawUTF8); /// find the position of the [SEARCH] section in source // - return true if [SEARCH] was found, and store pointer to the line after it in source function FindSectionFirstLine(var source: PUTF8Char; search: PAnsiChar): boolean; /// find the position of the [SEARCH] section in source // - return true if [SEARCH] was found, and store pointer to the line after it in source // - this version expects source^ to point to an Unicode char array function FindSectionFirstLineW(var source: PWideChar; search: PUTF8Char): boolean; /// retrieve the whole content of a section as a string // - SectionFirstLine may have been obtained by FindSectionFirstLine() function above function GetSectionContent(SectionFirstLine: PUTF8Char): RawUTF8; overload; /// retrieve the whole content of a section as a string // - use SectionFirstLine() then previous GetSectionContent() function GetSectionContent(const Content, SectionName: RawUTF8): RawUTF8; overload; /// delete a whole [Section] // - if EraseSectionHeader is TRUE (default), then the [Section] line is also // deleted together with its content lines // - return TRUE if something was changed in Content // - return FALSE if [Section] doesn't exist or is already void function DeleteSection(var Content: RawUTF8; const SectionName: RawUTF8; EraseSectionHeader: boolean=true): boolean; overload; /// delete a whole [Section] // - if EraseSectionHeader is TRUE (default), then the [Section] line is also // deleted together with its content lines // - return TRUE if something was changed in Content // - return FALSE if [Section] doesn't exist or is already void // - SectionFirstLine may have been obtained by FindSectionFirstLine() function above function DeleteSection(SectionFirstLine: PUTF8Char; var Content: RawUTF8; EraseSectionHeader: boolean=true): boolean; overload; /// replace a whole [Section] content by a new content // - create a new [Section] if none was existing procedure ReplaceSection(var Content: RawUTF8; const SectionName, NewSectionContent: RawUTF8); overload; /// replace a whole [Section] content by a new content // - create a new [Section] if none was existing // - SectionFirstLine may have been obtained by FindSectionFirstLine() function above procedure ReplaceSection(SectionFirstLine: PUTF8Char; var Content: RawUTF8; const NewSectionContent: RawUTF8); overload; /// return TRUE if Value of UpperName does exist in P, till end of current section // - expect UpperName as 'NAME=' function ExistsIniName(P: PUTF8Char; UpperName: PAnsiChar): boolean; /// find the Value of UpperName in P, till end of current section // - expect UpperName as 'NAME=' function FindIniNameValue(P: PUTF8Char; UpperName: PAnsiChar): RawUTF8; /// return TRUE if one of the Value of UpperName exists in P, till end of // current section // - expect UpperName e.g. as 'CONTENT-TYPE: ' // - expect UpperValues to be any upper value with left side matching, e.g. as // used by IsHTMLContentTypeTextual() function: // ! result := ExistsIniNameValue(htmlHeaders,HEADER_CONTENT_TYPE_UPPER, // ! ['TEXT/','APPLICATION/JSON','APPLICATION/XML']); // - warning: this function calls IdemPCharArray(), so expects UpperValues[] /// items to have AT LEAST TWO CHARS (it will use fast initial 2 bytes compare) function ExistsIniNameValue(P: PUTF8Char; const UpperName: RawUTF8; const UpperValues: array of PAnsiChar): boolean; /// find the integer Value of UpperName in P, till end of current section // - expect UpperName as 'NAME=' // - return 0 if no NAME= entry was found function FindIniNameValueInteger(P: PUTF8Char; UpperName: PAnsiChar): PtrInt; {$ifdef HASINLINE}inline;{$endif} /// replace a value from a given set of name=value lines // - expect UpperName as 'UPPERNAME=', otherwise returns false // - if no UPPERNAME= entry was found, then Name+NewValue is added to Content // - a typical use may be: // ! UpdateIniNameValue(headers,HEADER_CONTENT_TYPE,HEADER_CONTENT_TYPE_UPPER,contenttype); function UpdateIniNameValue(var Content: RawUTF8; const Name, UpperName, NewValue: RawUTF8): boolean; /// read a File content into a String // - content can be binary or text // - returns '' if file was not found or any read error occured // - wil use GetFileSize() API by default, unless HasNoSize is defined, // and read will be done using a buffer (required e.g. for char files under Linux) // - uses RawByteString for byte storage, whatever the codepage is function StringFromFile(const FileName: TFileName; HasNoSize: boolean=false): RawByteString; /// create a File from a string content // - uses RawByteString for byte storage, whatever the codepage is function FileFromString(const Content: RawByteString; const FileName: TFileName; FlushOnDisk: boolean=false; FileDate: TDateTime=0): boolean; /// get text File contents (even Unicode or UTF8) and convert it into a // Charset-compatible AnsiString (for Delphi 7) or an UnicodeString (for Delphi // 2009 and up) according to any BOM marker at the beginning of the file // - before Delphi 2009, the current string code page is used (i.e. CurrentAnsiConvert) function AnyTextFileToString(const FileName: TFileName; ForceUTF8: boolean=false): string; /// get text file contents (even Unicode or UTF8) and convert it into an // Unicode string according to any BOM marker at the beginning of the file // - any file without any BOM marker will be interpreted as plain ASCII: in this // case, the current string code page is used (i.e. CurrentAnsiConvert class) function AnyTextFileToSynUnicode(const FileName: TFileName; ForceUTF8: boolean=false): SynUnicode; /// get text file contents (even Unicode or UTF8) and convert it into an // UTF-8 string according to any BOM marker at the beginning of the file // - if AssumeUTF8IfNoBOM is FALSE, the current string code page is used (i.e. // CurrentAnsiConvert class) for conversion from ANSI into UTF-8 // - if AssumeUTF8IfNoBOM is TRUE, any file without any BOM marker will be // interpreted as UTF-8 function AnyTextFileToRawUTF8(const FileName: TFileName; AssumeUTF8IfNoBOM: boolean=false): RawUTF8; /// read a TStream content into a String // - it will read binary or text content from the current position until the // end (using TStream.Size) // - uses RawByteString for byte storage, whatever the codepage is function StreamToRawByteString(aStream: TStream): RawByteString; /// create a TStream from a string content // - uses RawByteString for byte storage, whatever the codepage is // - in fact, the returned TStream is a TRawByteString instance, since this // function is just a wrapper around: // ! result := TRawByteStringStream.Create(aString); function RawByteStringToStream(const aString: RawByteString): TStream; {$ifdef HASINLINE}inline;{$endif} /// read an UTF-8 text from a TStream // - format is Length(Integer):Text, i.e. the one used by WriteStringToStream // - will return '' if there is no such text in the stream // - you can set a MaxAllowedSize value, if you know how long the size should be // - it will read from the current position in S: so if you just write into S, // it could be a good idea to rewind it before call, e.g.: // ! WriteStringToStream(Stream,aUTF8Text); // ! Stream.Seek(0,soBeginning); // ! str := ReadStringFromStream(Stream); function ReadStringFromStream(S: TStream; MaxAllowedSize: integer=255): RawUTF8; /// write an UTF-8 text into a TStream // - format is Length(Integer):Text, i.e. the one used by ReadStringFromStream function WriteStringToStream(S: TStream; const Text: RawUTF8): boolean; /// get a file date and time, from its name // - returns 0 if file doesn't exist // - under Windows, will use GetFileAttributesEx fast API function FileAgeToDateTime(const FileName: TFileName): TDateTime; /// get a file size, from its name // - returns 0 if file doesn't exist // - under Windows, will use GetFileAttributesEx fast API function FileSize(const FileName: TFileName): Int64; overload; /// get a file size, from its handle // - returns 0 if file doesn't exist function FileSize(F: THandle): Int64; overload; /// get low-level file information, in a cross-platform way // - returns true on success // - here file write/creation time are given as TUnixMSTime values, for better // cross-platform process - note that FileCreateDateTime may not be supported // by most Linux file systems, so the oldest timestamp available is returned // as failover on such systems (probably the latest file metadata writing) function FileInfoByHandle(aFileHandle: THandle; out FileId, FileSize, LastWriteAccess, FileCreateDateTime: Int64): Boolean; /// get a file date and time, from a FindFirst/FindNext search // - the returned timestamp is in local time, not UTC // - this method would use the F.Timestamp field available since Delphi XE2 function SearchRecToDateTime(const F: TSearchRec): TDateTime; {$ifdef HASINLINE}inline;{$endif} /// check if a FindFirst/FindNext found instance is actually a file function SearchRecValidFile(const F: TSearchRec): boolean; {$ifdef HASINLINE}inline;{$endif} const /// operating-system dependent wildchar to match all files in a folder FILES_ALL = {$ifdef MSWINDOWS}'*.*'{$else}'*'{$endif}; /// delete the content of a specified directory // - only one level of file is deleted within the folder: no recursive deletion // is processed by this function (for safety) // - if DeleteOnlyFilesNotDirectory is TRUE, it won't remove the folder itself, // but just the files found in it function DirectoryDelete(const Directory: TFileName; const Mask: TFileName=FILES_ALL; DeleteOnlyFilesNotDirectory: Boolean=false; DeletedCount: PInteger=nil): Boolean; /// delete the files older than a given age in a specified directory // - for instance, to delete all files older than one day: // ! DirectoryDeleteOlderFiles(FolderName, 1); // - only one level of file is deleted within the folder: no recursive deletion // is processed by this function, unless Recursive is TRUE // - if Recursive=true, caller should set TotalSize^=0 to have an accurate value function DirectoryDeleteOlderFiles(const Directory: TFileName; TimePeriod: TDateTime; const Mask: TFileName=FILES_ALL; Recursive: Boolean=false; TotalSize: PInt64=nil): Boolean; /// creates a directory if not already existing // - returns the full expanded directory name, including trailing backslash // - returns '' on error, unless RaiseExceptionOnCreationFailure=true function EnsureDirectoryExists(const Directory: TFileName; RaiseExceptionOnCreationFailure: boolean=false): TFileName; /// check if the directory is writable for the current user // - try to write a small file with a random name function IsDirectoryWritable(const Directory: TFileName): boolean; /// compute an unique temporary file name // - following 'exename_01234567.tmp' pattern, in the system temporary folder function TemporaryFileName: TFileName; type {$A-} /// file found result item, as returned by FindFiles() {$ifdef FPC_OR_UNICODE}TFindFiles = record{$else}TFindFiles = object{$endif} public /// the matching file name, including its folder name Name: TFileName; /// the matching file attributes Attr: Integer; /// the matching file size Size: Int64; /// the matching file date/time Timestamp: TDateTime; /// fill the item properties from a FindFirst/FindNext's TSearchRec procedure FromSearchRec(const Directory: TFileName; const F: TSearchRec); /// returns some ready-to-be-loggued text function ToText: shortstring; end; {$A+} /// result list, as returned by FindFiles() TFindFilesDynArray = array of TFindFiles; /// a pointer to a TFileName variable PFileName = ^TFileName; /// search for matching file names // - just a wrapper around FindFirst/FindNext // - you may specify several masks in Mask, e.g. as '*.jpg;*.jpeg' function FindFiles(const Directory,Mask: TFileName; const IgnoreFileName: TFileName=''; SortByName: boolean=false; IncludesDir: boolean=true; SubFolder: Boolean=false): TFindFilesDynArray; /// convert a result list, as returned by FindFiles(), into an array of Files[].Name function FindFilesDynArrayToFileNames(const Files: TFindFilesDynArray): TFileNameDynArray; {$ifdef DELPHI5OROLDER} /// DirectoryExists returns a boolean value that indicates whether the // specified directory exists (and is actually a directory) function DirectoryExists(const Directory: string): Boolean; /// case-insensitive comparison of filenames function SameFileName(const S1, S2: TFileName): Boolean; /// retrieve the corresponding environment variable value function GetEnvironmentVariable(const Name: string): string; /// retrieve the full path name of the given execution module (e.g. library) function GetModuleName(Module: HMODULE): TFileName; /// try to encode a time function TryEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean; /// alias to ExcludeTrailingBackslash() function function ExcludeTrailingPathDelimiter(const FileName: TFileName): TFileName; /// alias to IncludeTrailingBackslash() function function IncludeTrailingPathDelimiter(const FileName: TFileName): TFileName; type EOSError = class(Exception) public ErrorCode: DWORD; end; /// raise an EOSError exception corresponding to the last error reported by Windows procedure RaiseLastOSError; {$endif DELPHI5OROLDER} {$ifdef DELPHI6OROLDER} procedure VarCastError; {$endif} /// extract file name, without its extension // - may optionally return the associated extension, as '.ext' function GetFileNameWithoutExt(const FileName: TFileName; Extension: PFileName=nil): TFileName; /// extract a file extension from a file name, then compare with a comma // separated list of extensions // - e.g. GetFileNameExtIndex('test.log','exe,log,map')=1 // - will return -1 if no file extension match // - will return any matching extension, starting count at 0 // - extension match is case-insensitive function GetFileNameExtIndex(const FileName, CSVExt: TFileName): integer; /// copy one file to another, similar to the Windows API function CopyFile(const Source, Target: TFileName; FailIfExists: boolean): boolean; /// copy the date of one file to another function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean; /// retrieve a property value in a text-encoded class // - follows the Delphi serialized text object format, not standard .ini // - if the property is a string, the simple quotes ' are trimed function FindObjectEntry(const Content, Name: RawUTF8): RawUTF8; /// retrieve a filename property value in a text-encoded class // - follows the Delphi serialized text object format, not standard .ini // - if the property is a string, the simple quotes ' are trimed // - any file path and any extension are trimmed function FindObjectEntryWithoutExt(const Content, Name: RawUTF8): RawUTF8; type /// available pronunciations for our fast Soundex implementation TSynSoundExPronunciation = (sndxEnglish, sndxFrench, sndxSpanish, sndxNone); TSoundExValues = array[0..ord('Z')-ord('B')] of byte; PSoundExValues = ^TSoundExValues; PSynSoundEx = ^TSynSoundEx; /// fast search of a text value, using the Soundex approximation mechanism // - Soundex is a phonetic algorithm for indexing names by sound, // as pronounced in a given language. The goal is for homophones to be // encoded to the same representation so that they can be matched despite // minor differences in spelling // - this implementation is very fast and can be used e.g. to parse and search // in a huge text buffer // - this version also handles french and spanish pronunciations on request, // which differs from default Soundex, i.e. English {$ifdef FPC_OR_UNICODE}TSynSoundEx = record private {$else}TSynSoundEx = object protected{$endif} Search, FirstChar: cardinal; fValues: PSoundExValues; public /// prepare for a Soundex search // - you can specify another language pronunciation than default english function Prepare(UpperValue: PAnsiChar; Lang: TSynSoundExPronunciation=sndxEnglish): boolean; overload; /// prepare for a custom Soundex search // - you can specify any language pronunciation from raw TSoundExValues array function Prepare(UpperValue: PAnsiChar; Lang: PSoundExValues): boolean; overload; /// return true if prepared value is contained in a text buffer // (UTF-8 encoded), by using the SoundEx comparison algorithm // - search prepared value at every word beginning in U^ function UTF8(U: PUTF8Char): boolean; /// return true if prepared value is contained in a ANSI text buffer // by using the SoundEx comparison algorithm // - search prepared value at every word beginning in A^ function Ansi(A: PAnsiChar): boolean; end; /// Retrieve the Soundex value of a text word, from Ansi buffer // - Return the soundex value as an easy to use cardinal value, 0 if the // incoming string contains no valid word // - if next is defined, its value is set to the end of the encoded word // (so that you can call again this function to encode a full sentence) function SoundExAnsi(A: PAnsiChar; next: PPAnsiChar=nil; Lang: TSynSoundExPronunciation=sndxEnglish): cardinal; overload; /// Retrieve the Soundex value of a text word, from Ansi buffer // - Return the soundex value as an easy to use cardinal value, 0 if the // incoming string contains no valid word // - if next is defined, its value is set to the end of the encoded word // (so that you can call again this function to encode a full sentence) function SoundExAnsi(A: PAnsiChar; next: PPAnsiChar; Lang: PSoundExValues): cardinal; overload; /// Retrieve the Soundex value of a text word, from UTF-8 buffer // - Return the soundex value as an easy to use cardinal value, 0 if the // incoming string contains no valid word // - if next is defined, its value is set to the end of the encoded word // (so that you can call again this function to encode a full sentence) // - very fast: all UTF-8 decoding is handled on the fly function SoundExUTF8(U: PUTF8Char; next: PPUTF8Char=nil; Lang: TSynSoundExPronunciation=sndxEnglish): cardinal; const /// number of bits to use for each interresting soundex char // - default is to use 8 bits, i.e. 4 soundex chars, which is the // standard approach // - for a more detailled soundex, use 4 bits resolution, which will // compute up to 7 soundex chars in a cardinal (that's our choice) SOUNDEX_BITS = 4; /// return true if UpperValue (Ansi) is contained in A^ (Ansi) // - find UpperValue starting at word beginning, not inside words function FindAnsi(A, UpperValue: PAnsiChar): boolean; /// return true if UpperValue (Ansi) is contained in U^ (UTF-8 encoded) // - find UpperValue starting at word beginning, not inside words // - UTF-8 decoding is done on the fly (no temporary decoding buffer is used) function FindUTF8(U: PUTF8Char; UpperValue: PAnsiChar): boolean; /// return true if Upper (Unicode encoded) is contained in U^ (UTF-8 encoded) // - will use the slow but accurate Operating System API to perform the // comparison at Unicode-level function FindUnicode(PW: PWideChar; Upper: PWideChar; UpperLen: integer): boolean; /// trim first lowercase chars ('otDone' will return 'Done' e.g.) // - return a PUTF8Char to avoid any memory allocation function TrimLeftLowerCase(const V: RawUTF8): PUTF8Char; /// trim first lowercase chars ('otDone' will return 'Done' e.g.) // - return an RawUTF8 string: enumeration names are pure 7bit ANSI with Delphi 7 // to 2007, and UTF-8 encoded with Delphi 2009+ function TrimLeftLowerCaseShort(V: PShortString): RawUTF8; /// trim first lowercase chars ('otDone' will return 'Done' e.g.) // - return a shortstring: enumeration names are pure 7bit ANSI with Delphi 7 // to 2007, and UTF-8 encoded with Delphi 2009+ function TrimLeftLowerCaseToShort(V: PShortString): ShortString; overload; {$ifdef HASINLINE}inline;{$endif} /// trim first lowercase chars ('otDone' will return 'Done' e.g.) // - return a shortstring: enumeration names are pure 7bit ANSI with Delphi 7 // to 2007, and UTF-8 encoded with Delphi 2009+ procedure TrimLeftLowerCaseToShort(V: PShortString; out result: ShortString); overload; /// convert a CamelCase string into a space separated one // - 'OnLine' will return 'On line' e.g., and 'OnMyLINE' will return 'On my LINE' // - will handle capital words at the beginning, middle or end of the text, e.g. // 'KLMFlightNumber' will return 'KLM flight number' and 'GoodBBCProgram' will // return 'Good BBC program' // - will handle a number at the beginning, middle or end of the text, e.g. // 'Email12' will return 'Email 12' // - '_' char is transformed into ' - ' // - '__' chars are transformed into ': ' // - return an RawUTF8 string: enumeration names are pure 7bit ANSI with Delphi 7 // to 2007, and UTF-8 encoded with Delphi 2009+ function UnCamelCase(const S: RawUTF8): RawUTF8; overload; /// convert a CamelCase string into a space separated one // - 'OnLine' will return 'On line' e.g., and 'OnMyLINE' will return 'On my LINE' // - will handle capital words at the beginning, middle or end of the text, e.g. // 'KLMFlightNumber' will return 'KLM flight number' and 'GoodBBCProgram' will // return 'Good BBC program' // - will handle a number at the beginning, middle or end of the text, e.g. // 'Email12' will return 'Email 12' // - return the char count written into D^ // - D^ and P^ are expected to be UTF-8 encoded: enumeration and property names // are pure 7bit ANSI with Delphi 7 to 2007, and UTF-8 encoded with Delphi 2009+ // - '_' char is transformed into ' - ' // - '__' chars are transformed into ': ' function UnCamelCase(D, P: PUTF8Char): integer; overload; /// convert a string into an human-friendly CamelCase identifier // - replacing spaces or punctuations by an uppercase character // - as such, it is not the reverse function to UnCamelCase() procedure CamelCase(P: PAnsiChar; len: integer; var s: RawUTF8; const isWord: TSynByteSet=[ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')]); overload; /// convert a string into an human-friendly CamelCase identifier // - replacing spaces or punctuations by an uppercase character // - as such, it is not the reverse function to UnCamelCase() procedure CamelCase(const text: RawUTF8; var s: RawUTF8; const isWord: TSynByteSet=[ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')]); overload; {$ifdef HASINLINE}inline;{$endif} /// UnCamelCase and translate a char buffer // - P is expected to be #0 ended // - return "string" type, i.e. UnicodeString for Delphi 2009+ procedure GetCaptionFromPCharLen(P: PUTF8Char; out result: string); /// will get a class name as UTF-8 // - will trim 'T', 'TSyn', 'TSQL' or 'TSQLRecord' left side of the class name // - will encode the class name as UTF-8 (for Unicode Delphi versions) // - is used e.g. to extract the SQL table name for a TSQLRecord class function GetDisplayNameFromClass(C: TClass): RawUTF8; /// UnCamelCase and translate the class name, triming any left 'T', 'TSyn', // 'TSQL' or 'TSQLRecord' // - return generic VCL string type, i.e. UnicodeString for Delphi 2009+ function GetCaptionFromClass(C: TClass): string; /// just a wrapper around vmtClassName to avoid a string conversion function ClassNameShort(C: TClass): PShortString; overload; {$ifdef HASINLINE}inline;{$endif} /// just a wrapper around vmtClassName to avoid a string conversion function ClassNameShort(Instance: TObject): PShortString; overload; {$ifdef HASINLINE}inline;{$endif} /// just a wrapper around vmtClassName to avoid a string/RawUTF8 conversion function ToText(C: TClass): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// just a wrapper around vmtClassName to avoid a string/RawUTF8 conversion procedure ToText(C: TClass; var result: RawUTF8); overload; {$ifdef HASINLINE}inline;{$endif} type /// information about one method, as returned by GetPublishedMethods TPublishedMethodInfo = record /// the method name Name: RawUTF8; /// a callback to the method, for the given class instance Method: TMethod; end; /// information about all methods, as returned by GetPublishedMethods TPublishedMethodInfoDynArray = array of TPublishedMethodInfo; /// retrieve published methods information about any class instance // - will optionaly accept a Class, in this case Instance is ignored // - will work with FPC and Delphi RTTI function GetPublishedMethods(Instance: TObject; out Methods: TPublishedMethodInfoDynArray; aClass: TClass = nil): integer; {$ifdef LINUX} const ANSI_CHARSET = 0; DEFAULT_CHARSET = 1; SYMBOL_CHARSET = 2; SHIFTJIS_CHARSET = $80; HANGEUL_CHARSET = 129; GB2312_CHARSET = 134; CHINESEBIG5_CHARSET = 136; OEM_CHARSET = 255; JOHAB_CHARSET = 130; HEBREW_CHARSET = 177; ARABIC_CHARSET = 178; GREEK_CHARSET = 161; TURKISH_CHARSET = 162; VIETNAMESE_CHARSET = 163; THAI_CHARSET = 222; EASTEUROPE_CHARSET = 238; RUSSIAN_CHARSET = 204; BALTIC_CHARSET = 186; {$else} {$ifdef FPC} const VIETNAMESE_CHARSET = 163; {$endif} {$endif} /// convert a char set to a code page function CharSetToCodePage(CharSet: integer): cardinal; /// convert a code page to a char set function CodePageToCharSet(CodePage: Cardinal): Integer; /// retrieve the MIME content type from a supplied binary buffer // - return the MIME type, ready to be appended to a 'Content-Type: ' HTTP header // - returns DefaultContentType if the binary buffer has an unknown layout function GetMimeContentTypeFromBuffer(Content: Pointer; Len: integer; const DefaultContentType: RawUTF8): RawUTF8; /// retrieve the MIME content type from a supplied binary buffer or file name // - return the MIME type, ready to be appended to a 'Content-Type: ' HTTP header // - default is 'application/octet-stream' (BINARY_CONTENT_TYPE) or // 'application/extension' if FileName was specified // - see @http://en.wikipedia.org/wiki/Internet_media_type for most common values function GetMimeContentType(Content: Pointer; Len: integer; const FileName: TFileName=''): RawUTF8; /// retrieve the HTTP header for MIME content type from a supplied binary buffer // - just append HEADER_CONTENT_TYPE and GetMimeContentType() result // - can be used as such: // ! Call.OutHead := GetMimeContentTypeHeader(Call.OutBody,aFileName); function GetMimeContentTypeHeader(const Content: RawByteString; const FileName: TFileName=''): RawUTF8; /// retrieve if some content is compressed, from a supplied binary buffer // - returns TRUE, if the header in binary buffer "may" be compressed (this method // can trigger false positives), e.g. begin with most common already compressed // zip/gz/gif/png/jpeg/avi/mp3/mp4 markers (aka "magic numbers") function IsContentCompressed(Content: Pointer; Len: integer): boolean; /// returns TRUE if the supplied HTML Headers contains 'Content-Type: text/...', // 'Content-Type: application/json' or 'Content-Type: application/xml' function IsHTMLContentTypeTextual(Headers: PUTF8Char): Boolean; /// fast guess of the size, in pixels, of a JPEG memory buffer // - will only scan for basic JPEG structure, up to the StartOfFrame (SOF) chunk // - returns TRUE if the buffer is likely to be a JPEG picture, and set the // Height + Width variable with its dimensions - but there may be false positive // recognition, and no waranty that the memory buffer holds a valid JPEG picture // - returns FALSE if the buffer does not have any expected SOI/SOF markers function GetJpegSize(jpeg: PAnsiChar; len: integer; out Height, Width: integer): boolean; overload; /// fast guess of the size, in pixels, of a JPEG file // - will only scan for basic JPEG structure, up to the StartOfFrame (SOF) chunk // - returns TRUE if the buffer is likely to be a JPEG picture, and set the // Height + Width variable with its dimensions - but there may be false positive // recognition, and no waranty that the file is a valid JPEG picture // - returns FALSE if the file content does not have any expected SOI/SOF markers function GetJpegSize(const jpeg: TFileName; out Height, Width: integer): boolean; overload; type /// used by MultiPartFormDataDecode() to return one item of its data TMultiPart = record Name: RawUTF8; FileName: RawUTF8; ContentType: RawUTF8; Encoding: RawUTF8; Content: RawByteString; end; /// used by MultiPartFormDataDecode() to return all its data items TMultiPartDynArray = array of TMultiPart; /// decode multipart/form-data POST request content // - following RFC1867 function MultiPartFormDataDecode(const MimeType,Body: RawUTF8; var MultiPart: TMultiPartDynArray): boolean; /// encode multipart fields and files // - only one of them can be used because MultiPartFormDataDecode must implement // both decodings // - MultiPart: parts to build the multipart content from, which may be created // using MultiPartFormDataAddFile/MultiPartFormDataAddField // - MultiPartContentType: variable returning // $ Content-Type: multipart/form-data; boundary=xxx // where xxx is the first generated boundary // - MultiPartContent: generated multipart content function MultiPartFormDataEncode(const MultiPart: TMultiPartDynArray; var MultiPartContentType, MultiPartContent: RawUTF8): boolean; /// encode a file in a multipart array // - FileName: file to encode // - Multipart: where the part is added // - Name: name of the part, is empty the name 'File###' is generated function MultiPartFormDataAddFile(const FileName: TFileName; var MultiPart: TMultiPartDynArray; const Name: RawUTF8 = ''): boolean; /// encode a field in a multipart array // - FieldName: field name of the part // - FieldValue: value of the field // - Multipart: where the part is added function MultiPartFormDataAddField(const FieldName, FieldValue: RawUTF8; var MultiPart: TMultiPartDynArray): boolean; /// retrieve the index where to insert a PUTF8Char in a sorted PUTF8Char array // - R is the last index of available entries in P^ (i.e. Count-1) // - string comparison is case-sensitive StrComp (so will work with any PAnsiChar) // - returns -1 if the specified Value was found (i.e. adding will duplicate a value) // - will use fast O(log(n)) binary search algorithm function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; overload; {$ifdef HASINLINE}inline;{$endif} /// retrieve the index where to insert a PUTF8Char in a sorted PUTF8Char array // - this overloaded function accept a custom comparison function for sorting // - R is the last index of available entries in P^ (i.e. Count-1) // - string comparison is case-sensitive (so will work with any PAnsiChar) // - returns -1 if the specified Value was found (i.e. adding will duplicate a value) // - will use fast O(log(n)) binary search algorithm function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; Compare: TUTF8Compare): PtrInt; overload; /// retrieve the index where is located a PUTF8Char in a sorted PUTF8Char array // - R is the last index of available entries in P^ (i.e. Count-1) // - string comparison is case-sensitive StrComp (so will work with any PAnsiChar) // - returns -1 if the specified Value was not found // - will use fast O(log(n)) binary search algorithm function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; overload; {$ifdef HASINLINE}inline;{$endif} /// retrieve the index where is located a PUTF8Char in a sorted PUTF8Char array // - R is the last index of available entries in P^ (i.e. Count-1) // - string comparison will use the specified Compare function // - returns -1 if the specified Value was not found // - will use fast O(log(n)) binary search algorithm function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; Compare: TUTF8Compare): PtrInt; overload; /// retrieve the index of a PUTF8Char in a PUTF8Char array via a sort indexed // - will use fast O(log(n)) binary search algorithm function FastFindIndexedPUTF8Char(P: PPUTF8CharArray; R: PtrInt; var SortedIndexes: TCardinalDynArray; Value: PUTF8Char; ItemComp: TUTF8Compare): PtrInt; /// add a RawUTF8 value in an alphaticaly sorted dynamic array of RawUTF8 // - returns the index where the Value was added successfully in Values[] // - returns -1 if the specified Value was alredy present in Values[] // (we must avoid any duplicate for O(log(n)) binary search) // - if CoValues is set, its content will be moved to allow inserting a new // value at CoValues[result] position - a typical usage of CoValues is to store // the corresponding ID to each RawUTF8 item // - if FastLocatePUTF8CharSorted() has been already called, this index can // be set to optional ForceIndex parameter // - by default, exact (case-sensitive) match is used; you can specify a custom // compare function if needed in Compare optional parameter function AddSortedRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; const Value: RawUTF8; CoValues: PIntegerDynArray=nil; ForcedIndex: PtrInt=-1; Compare: TUTF8Compare=nil): PtrInt; /// delete a RawUTF8 item in a dynamic array of RawUTF8 // - if CoValues is set, the integer item at the same index is also deleted function DeleteRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; Index: integer; CoValues: PIntegerDynArray=nil): boolean; overload; /// delete a RawUTF8 item in a dynamic array of RawUTF8; function DeleteRawUTF8(var Values: TRawUTF8DynArray; Index: integer): boolean; overload; /// sort a dynamic array of RawUTF8 items // - if CoValues is set, the integer items are also synchronized // - by default, exact (case-sensitive) match is used; you can specify a custom // compare function if needed in Compare optional parameter procedure QuickSortRawUTF8(var Values: TRawUTF8DynArray; ValuesCount: integer; CoValues: PIntegerDynArray=nil; Compare: TUTF8Compare=nil); /// sort a dynamic array of PUTF8Char items, via an external array of indexes // - you can use FastFindIndexedPUTF8Char() for fast O(log(n)) binary search procedure QuickSortIndexedPUTF8Char(Values: PPUtf8CharArray; Count: Integer; var SortedIndexes: TCardinalDynArray; CaseSensitive: boolean=false); /// fast search of an unsigned integer position in an integer array // - Count is the number of cardinal entries in P^ // - returns P where P^=Value // - returns nil if Value was not found function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal; /// fast search of an unsigned integer position in an integer array // - Count is the number of integer entries in P^ // - return index of P^[index]=Value // - return -1 if Value was not found function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt; /// fast search of an integer position in a 64-bit integer array // - Count is the number of Int64 entries in P^ // - returns P where P^=Value // - returns nil if Value was not found function Int64Scan(P: PInt64Array; Count: PtrInt; const Value: Int64): PInt64; /// fast search of an integer position in a signed 64-bit integer array // - Count is the number of Int64 entries in P^ // - returns index of P^[index]=Value // - returns -1 if Value was not found function Int64ScanIndex(P: PInt64Array; Count: PtrInt; const Value: Int64): PtrInt; /// fast search of an integer position in an unsigned 64-bit integer array // - Count is the number of QWord entries in P^ // - returns index of P^[index]=Value // - returns -1 if Value was not found function QWordScanIndex(P: PQWordArray; Count: PtrInt; const Value: QWord): PtrInt; {$ifdef HASINLINE}inline;{$endif} /// fast search of an unsigned integer in an integer array // - returns true if P^=Value within Count entries // - returns false if Value was not found function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean; /// fast search of an integer value in a 64-bit integer array // - returns true if P^=Value within Count entries // - returns false if Value was not found function Int64ScanExists(P: PInt64Array; Count: PtrInt; const Value: Int64): boolean; /// fast search of a pointer-sized unsigned integer position // in an pointer-sized integer array // - Count is the number of pointer-sized integer entries in P^ // - return index of P^[index]=Value // - return -1 if Value was not found function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt; {$ifdef HASINLINE}inline;{$endif} /// fast search of a pointer-sized unsigned integer position // in an pointer-sized integer array // - Count is the number of pointer-sized integer entries in P^ // - returns true if P^=Value within Count entries // - returns false if Value was not found function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean; {$ifdef HASINLINE}inline;{$endif} /// fast search of an unsigned Byte value position in a Byte array // - Count is the number of Byte entries in P^ // - return index of P^[index]=Value // - return -1 if Value was not found function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: Byte): integer; {$ifdef HASINLINE}inline;{$endif} /// fast search of an unsigned Word value position in a Word array // - Count is the number of Word entries in P^ // - return index of P^[index]=Value // - return -1 if Value was not found function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): integer; {$ifdef HASINLINE}inline;{$endif} /// sort an Integer array, low values first procedure QuickSortInteger(ID: PIntegerArray; L, R: PtrInt); overload; /// sort an Integer array, low values first procedure QuickSortInteger(ID,CoValues: PIntegerArray; L, R: PtrInt); overload; /// sort an Integer array, low values first procedure QuickSortInteger(var ID: TIntegerDynArray); overload; /// sort a 16 bit unsigned Integer array, low values first procedure QuickSortWord(ID: PWordArray; L, R: PtrInt); /// sort a 64-bit signed Integer array, low values first procedure QuickSortInt64(ID: PInt64Array; L, R: PtrInt); overload; /// sort a 64-bit unsigned Integer array, low values first // - QWord comparison are implemented correctly under FPC or Delphi 2009+ - // older compilers will use fast and exact SortDynArrayQWord() procedure QuickSortQWord(ID: PQWordArray; L, R: PtrInt); overload; /// sort a 64-bit Integer array, low values first procedure QuickSortInt64(ID,CoValues: PInt64Array; L, R: PtrInt); overload; type /// event handler called by NotifySortedIntegerChanges() // - Sender is an opaque const value, maybe a TObject or any pointer TOnNotifySortedIntegerChange = procedure(const Sender; Value: integer) of object; /// compares two 32-bit signed sorted integer arrays, and call event handlers // to notify the corresponding modifications in an O(n) time // - items in both old[] and new[] arrays are required to be sorted procedure NotifySortedIntegerChanges(old, new: PIntegerArray; oldn, newn: PtrInt; const added, deleted: TOnNotifySortedIntegerChange; const sender); /// copy an integer array, then sort it, low values first procedure CopyAndSortInteger(Values: PIntegerArray; ValuesCount: integer; var Dest: TIntegerDynArray); /// copy an integer array, then sort it, low values first procedure CopyAndSortInt64(Values: PInt64Array; ValuesCount: integer; var Dest: TInt64DynArray); /// fast O(log(n)) binary search of an integer value in a sorted integer array // - R is the last index of available integer entries in P^ (i.e. Count-1) // - return index of P^[result]=Value // - return -1 if Value was not found function FastFindIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt; overload; /// fast O(log(n)) binary search of an integer value in a sorted integer array // - return index of Values[result]=Value // - return -1 if Value was not found function FastFindIntegerSorted(const Values: TIntegerDynArray; Value: integer): PtrInt; overload; {$ifdef HASINLINE}inline;{$endif} /// fast O(log(n)) binary search of a 16 bit unsigned integer value in a sorted array function FastFindWordSorted(P: PWordArray; R: PtrInt; Value: Word): PtrInt; /// fast O(log(n)) binary search of a 64-bit signed integer value in a sorted array // - R is the last index of available integer entries in P^ (i.e. Count-1) // - return index of P^[result]=Value // - return -1 if Value was not found function FastFindInt64Sorted(P: PInt64Array; R: PtrInt; const Value: Int64): PtrInt; overload; /// fast O(log(n)) binary search of a 64-bit unsigned integer value in a sorted array // - R is the last index of available integer entries in P^ (i.e. Count-1) // - return index of P^[result]=Value // - return -1 if Value was not found // - QWord comparison are implemented correctly under FPC or Delphi 2009+ - // older compilers will fast and exact SortDynArrayQWord() function FastFindQWordSorted(P: PQWordArray; R: PtrInt; const Value: QWord): PtrInt; overload; /// sort a PtrInt array, low values first procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt); {$ifdef HASINLINE}inline;{$endif} /// fast O(log(n)) binary search of a PtrInt value in a sorted array function FastFindPtrIntSorted(P: PPtrIntArray; R: PtrInt; Value: PtrInt): PtrInt; overload; {$ifdef HASINLINE}inline;{$endif} /// sort a pointer array, low values first procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt); {$ifdef HASINLINE}inline;{$endif} /// fast O(log(n)) binary search of a Pointer value in a sorted array function FastFindPointerSorted(P: PPointerArray; R: PtrInt; Value: Pointer): PtrInt; overload; {$ifdef HASINLINE}inline;{$endif} /// retrieve the index where to insert an integer value in a sorted integer array // - R is the last index of available integer entries in P^ (i.e. Count-1) // - returns -1 if the specified Value was found (i.e. adding will duplicate a value) function FastLocateIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt; /// retrieve the index where to insert a word value in a sorted word array // - R is the last index of available integer entries in P^ (i.e. Count-1) // - returns -1 if the specified Value was found (i.e. adding will duplicate a value) function FastLocateWordSorted(P: PWordArray; R: integer; Value: word): PtrInt; /// add an integer value in a sorted dynamic array of integers // - returns the index where the Value was added successfully in Values[] // - returns -1 if the specified Value was already present in Values[] // (we must avoid any duplicate for O(log(n)) binary search) // - if CoValues is set, its content will be moved to allow inserting a new // value at CoValues[result] position function AddSortedInteger(var Values: TIntegerDynArray; var ValuesCount: integer; Value: integer; CoValues: PIntegerDynArray=nil): PtrInt; overload; /// add an integer value in a sorted dynamic array of integers // - overloaded function which do not expect an external Count variable function AddSortedInteger(var Values: TIntegerDynArray; Value: integer; CoValues: PIntegerDynArray=nil): PtrInt; overload; /// insert an integer value at the specified index position of a dynamic array // of integers // - if Index is invalid, the Value is inserted at the end of the array function InsertInteger(var Values: TIntegerDynArray; var ValuesCount: integer; Value: Integer; Index: PtrInt; CoValues: PIntegerDynArray=nil): PtrInt; /// add an integer value at the end of a dynamic array of integers // - returns TRUE if Value was added successfully in Values[], in this case // length(Values) will be increased function AddInteger(var Values: TIntegerDynArray; Value: integer; NoDuplicates: boolean=false): boolean; overload; /// add an integer value at the end of a dynamic array of integers // - this overloaded function will use a separate Count variable (faster) // - it won't search for any existing duplicate procedure AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; Value: integer); overload; {$ifdef HASINLINE}inline;{$endif} /// add an integer array at the end of a dynamic array of integer function AddInteger(var Values: TIntegerDynArray; const Another: TIntegerDynArray): PtrInt; overload; /// add an integer value at the end of a dynamic array of integers // - this overloaded function will use a separate Count variable (faster), // and would allow to search for duplicates // - returns TRUE if Value was added successfully in Values[], in this case // ValuesCount will be increased, but length(Values) would stay fixed most // of the time (since it stores the Values[] array capacity) function AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; Value: integer; NoDuplicates: boolean): boolean; overload; /// add a 16-bit integer value at the end of a dynamic array of integers function AddWord(var Values: TWordDynArray; var ValuesCount: integer; Value: Word): PtrInt; /// add a 64-bit integer value at the end of a dynamic array of integers function AddInt64(var Values: TInt64DynArray; var ValuesCount: integer; Value: Int64): PtrInt; overload; {$ifdef HASINLINE}inline;{$endif} /// add a 64-bit integer value at the end of a dynamic array function AddInt64(var Values: TInt64DynArray; Value: Int64): PtrInt; overload; {$ifdef HASINLINE}inline;{$endif} /// add a 64-bit integer array at the end of a dynamic array function AddInt64(var Values: TInt64DynArray; const Another: TInt64DynArray): PtrInt; overload; /// if not already existing, add a 64-bit integer value to a dynamic array function AddInt64Once(var Values: TInt64DynArray; Value: Int64): PtrInt; /// if not already existing, add a 64-bit integer value to a sorted dynamic array procedure AddInt64Sorted(var Values: TInt64DynArray; Value: Int64); /// delete any 32-bit integer in Values[] procedure DeleteInteger(var Values: TIntegerDynArray; Index: PtrInt); overload; /// delete any 32-bit integer in Values[] procedure DeleteInteger(var Values: TIntegerDynArray; var ValuesCount: Integer; Index: PtrInt); overload; /// remove some 32-bit integer from Values[] // - Excluded is declared as var, since it will be sorted in-place during process // if it contains more than ExcludedSortSize items (i.e. if the sort is worth it) procedure ExcludeInteger(var Values, Excluded: TIntegerDynArray; ExcludedSortSize: Integer=32); /// ensure some 32-bit integer from Values[] will only contain Included[] // - Included is declared as var, since it will be sorted in-place during process // if it contains more than IncludedSortSize items (i.e. if the sort is worth it) procedure IncludeInteger(var Values, Included: TIntegerDynArray; IncludedSortSize: Integer=32); /// sort and remove any 32-bit duplicated integer from Values[] procedure DeduplicateInteger(var Values: TIntegerDynArray); overload; /// sort and remove any 32-bit duplicated integer from Values[] // - returns the new Values[] length function DeduplicateInteger(var Values: TIntegerDynArray; Count: integer): integer; overload; /// low-level function called by DeduplicateInteger() function DeduplicateIntegerSorted(val: PIntegerArray; last: PtrInt): PtrInt; /// create a new 32-bit integer dynamic array with the values from another one procedure CopyInteger(const Source: TIntegerDynArray; out Dest: TIntegerDynArray); /// delete any 16-bit integer in Values[] procedure DeleteWord(var Values: TWordDynArray; Index: PtrInt); /// delete any 64-bit integer in Values[] procedure DeleteInt64(var Values: TInt64DynArray; Index: PtrInt); overload; /// delete any 64-bit integer in Values[] procedure DeleteInt64(var Values: TInt64DynArray; var ValuesCount: Integer; Index: PtrInt); overload; /// remove some 64-bit integer from Values[] // - Excluded is declared as var, since it will be sorted in-place during process // if it contains more than ExcludedSortSize items (i.e. if the sort is worth it) procedure ExcludeInt64(var Values, Excluded: TInt64DynArray; ExcludedSortSize: Integer=32); /// ensure some 64-bit integer from Values[] will only contain Included[] // - Included is declared as var, since it will be sorted in-place during process // if it contains more than IncludedSortSize items (i.e. if the sort is worth it) procedure IncludeInt64(var Values, Included: TInt64DynArray; IncludedSortSize: Integer=32); /// sort and remove any 64-bit duplicated integer from Values[] procedure DeduplicateInt64(var Values: TInt64DynArray); overload; /// sort and remove any 64-bit duplicated integer from Values[] // - returns the new Values[] length function DeduplicateInt64(var Values: TInt64DynArray; Count: integer): integer; overload; /// low-level function called by DeduplicateInt64() // - warning: caller should ensure that last>0 function DeduplicateInt64Sorted(val: PInt64Array; last: PtrInt): PtrInt; /// create a new 64-bit integer dynamic array with the values from another one procedure CopyInt64(const Source: TInt64DynArray; out Dest: TInt64DynArray); /// find the maximum 32-bit integer in Values[] function MaxInteger(const Values: TIntegerDynArray; ValuesCount: integer; MaxStart: integer=-1): Integer; /// sum all 32-bit integers in Values[] function SumInteger(const Values: TIntegerDynArray; ValuesCount: integer): Integer; /// fill already allocated Reversed[] so that Reversed[Values[i]]=i procedure Reverse(const Values: TIntegerDynArray; ValuesCount: integer; Reversed: PIntegerArray); /// fill some values with i,i+1,i+2...i+Count-1 procedure FillIncreasing(Values: PIntegerArray; StartValue: integer; Count: PtrUInt); /// copy some Int64 values into an unsigned integer array procedure Int64ToUInt32(Values64: PInt64Array; Values32: PCardinalArray; Count: integer); /// add the strings in the specified CSV text into a dynamic array of integer procedure CSVToIntegerDynArray(CSV: PUTF8Char; var Result: TIntegerDynArray; Sep: AnsiChar= ','); /// add the strings in the specified CSV text into a dynamic array of integer procedure CSVToInt64DynArray(CSV: PUTF8Char; var Result: TInt64DynArray; Sep: AnsiChar= ','); overload; /// add the strings in the specified CSV text into a dynamic array of integer function CSVToInt64DynArray(CSV: PUTF8Char; Sep: AnsiChar= ','): TInt64DynArray; overload; /// return the corresponding CSV text from a dynamic array of 32-bit integer // - you can set some custom Prefix and Suffix text function IntegerDynArrayToCSV(Values: PIntegerArray; ValuesCount: integer; const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; /// return the corresponding CSV text from a dynamic array of 32-bit integer // - you can set some custom Prefix and Suffix text function IntegerDynArrayToCSV(const Values: TIntegerDynArray; const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// return the corresponding CSV text from a dynamic array of 64-bit integers // - you can set some custom Prefix and Suffix text function Int64DynArrayToCSV(Values: PInt64Array; ValuesCount: integer; const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; /// return the corresponding CSV text from a dynamic array of 64-bit integers // - you can set some custom Prefix and Suffix text function Int64DynArrayToCSV(const Values: TInt64DynArray; const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// quick helper to initialize a dynamic array of integer from some constants // - can be used e.g. as: // ! MyArray := TIntegerDynArrayFrom([1,2,3]); // - see also FromI32() function TIntegerDynArrayFrom(const Values: array of integer): TIntegerDynArray; /// quick helper to initialize a dynamic array of integer from 64-bit integers // - will raise a ESynException if any Value[] can not fit into 32-bit, unless // raiseExceptionOnOverflow is FALSE and the returned array slot is filled // with maxInt/minInt function TIntegerDynArrayFrom64(const Values: TInt64DynArray; raiseExceptionOnOverflow: boolean=true): TIntegerDynArray; /// quick helper to initialize a dynamic array of 64-bit integers from 32-bit values // - see also FromI64() for 64-bit signed integer values input function TInt64DynArrayFrom(const Values: TIntegerDynArray): TInt64DynArray; /// quick helper to initialize a dynamic array of 64-bit integers from 32-bit values // - see also FromU64() for 64-bit unsigned integer values input function TQWordDynArrayFrom(const Values: TCardinalDynArray): TQWordDynArray; /// initializes a dynamic array from a set of 32-bit integer signed values function FromI32(const Values: array of integer): TIntegerDynArray; {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} /// initializes a dynamic array from a set of 32-bit integer unsigned values function FromU32(const Values: array of cardinal): TCardinalDynArray; {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} /// initializes a dynamic array from a set of 64-bit integer signed values function FromI64(const Values: array of Int64): TInt64DynArray; {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} /// initializes a dynamic array from a set of 64-bit integer unsigned values function FromU64(const Values: array of QWord): TQWordDynArray; {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} type /// used to store and retrieve Words in a sorted array // - is defined either as an object either as a record, due to a bug // in Delphi 2009/2010 compiler (at least): this structure is not initialized // if defined as an object on the stack, but will be as a record :( {$ifdef FPC_OR_UNICODE}TSortedWordArray = record{$else}TSortedWordArray = object{$endif} public Values: TWordDynArray; Count: integer; /// add a value into the sorted array // - return the index of the new inserted value into the Values[] array // - return -(foundindex+1) if this value is already in the Values[] array function Add(aValue: Word): PtrInt; /// return the index if the supplied value in the Values[] array // - return -1 if not found function IndexOf(aValue: Word): PtrInt; {$ifdef HASINLINE}inline;{$endif} end; /// comparison function as expected by MedianQuickSelect() // - should return TRUE if Values[IndexA]>Values[IndexB] TOnValueGreater = function(IndexA,IndexB: PtrInt): boolean of object; /// compute the median of an integer serie of values, using "Quickselect" // - based on the algorithm described in "Numerical recipes in C", Second Edition, // translated from Nicolas Devillard's C code: http://ndevilla.free.fr/median/median // - warning: the supplied Integer array is modified in-place during the process, // and won't be fully sorted on output (this is no QuickSort alternative) function MedianQuickSelectInteger(Values: PIntegerArray; n: integer): integer; /// compute the median of a serie of values, using "Quickselect" // - based on the algorithm described in "Numerical recipes in C", Second Edition // - expect the values information to be available from a comparison callback // - this version will use a temporary index list to exchange items order // (supplied as a TSynTempBuffer), so won't change the supplied values themself // - returns the index of the median Value function MedianQuickSelect(const OnCompare: TOnValueGreater; n: integer; var TempBuffer: TSynTempBuffer): integer; /// compute GCD of two integers using substraction-based Euclidean algorithm function gcd(a, b: cardinal): cardinal; /// performs a QuickSort using a comparison callback procedure QuickSortCompare(const OnCompare: TOnValueGreater; Index: PIntegerArray; L,R: PtrInt); /// convert a cardinal into a 32-bit variable-length integer buffer function ToVarUInt32(Value: PtrUInt; Dest: PByte): PByte; /// return the number of bytes necessary to store a 32-bit variable-length integer // - i.e. the ToVarUInt32() buffer size function ToVarUInt32Length(Value: PtrUInt): PtrUInt; {$ifdef HASINLINE}inline;{$endif} /// return the number of bytes necessary to store some data with a its // 32-bit variable-length integer legnth function ToVarUInt32LengthWithData(Value: PtrUInt): PtrUInt; {$ifdef HASINLINE}inline;{$endif} /// convert an integer into a 32-bit variable-length integer buffer // - store negative values as cardinal two-complement, i.e. // 0=0,1=1,2=-1,3=2,4=-2... function ToVarInt32(Value: PtrInt; Dest: PByte): PByte; /// convert a 32-bit variable-length integer buffer into a cardinal // - fast inlined process for any number < 128 function FromVarUInt32(var Source: PByte): cardinal; {$ifdef HASINLINE}inline;{$endif} /// convert a 32-bit variable-length integer buffer into a cardinal // - this version could be called if number is likely to be > $7f, so it // inlining the first byte won't make any benefit function FromVarUInt32Big(var Source: PByte): cardinal; /// convert a 32-bit variable-length integer buffer into a cardinal // - this version must be called if Source^ has already been checked to be > $7f // ! result := Source^; // ! inc(Source); // ! if result>$7f then // ! result := (result and $7F) or FromVarUInt32Up128(Source); function FromVarUInt32Up128(var Source: PByte): cardinal; /// convert a 32-bit variable-length integer buffer into a cardinal // - this version must be called if Source^ has already been checked to be > $7f function FromVarUInt32High(var Source: PByte): cardinal; /// convert a 32-bit variable-length integer buffer into an integer // - decode negative values from cardinal two-complement, i.e. // 0=0,1=1,2=-1,3=2,4=-2... function FromVarInt32(var Source: PByte): integer; /// convert a UInt64 into a 64-bit variable-length integer buffer function ToVarUInt64(Value: QWord; Dest: PByte): PByte; /// convert a 64-bit variable-length integer buffer into a UInt64 function FromVarUInt64(var Source: PByte): QWord; /// convert a Int64 into a 64-bit variable-length integer buffer function ToVarInt64(Value: Int64; Dest: PByte): PByte; {$ifdef HASINLINE}inline;{$endif} /// convert a 64-bit variable-length integer buffer into a Int64 function FromVarInt64(var Source: PByte): Int64; /// convert a 64-bit variable-length integer buffer into a Int64 // - this version won't update the Source pointer function FromVarInt64Value(Source: PByte): Int64; /// jump a value in the 32-bit or 64-bit variable-length integer buffer function GotoNextVarInt(Source: PByte): pointer; {$ifdef HASINLINE}inline;{$endif} /// convert a RawUTF8 into an UTF-8 encoded variable-length buffer function ToVarString(const Value: RawUTF8; Dest: PByte): PByte; /// jump a value in variable-length text buffer function GotoNextVarString(Source: PByte): pointer; {$ifdef HASINLINE}inline;{$endif} /// retrieve a variable-length UTF-8 encoded text buffer in a newly allocation RawUTF8 function FromVarString(var Source: PByte): RawUTF8; overload; /// retrieve a variable-length text buffer // - this overloaded function will set the supplied code page to the AnsiString procedure FromVarString(var Source: PByte; var Value: RawByteString; CodePage: integer); overload; /// retrieve a variable-length UTF-8 encoded text buffer in a temporary buffer // - caller should call Value.Done after use of the Value.buf memory // - this overloaded function would include a trailing #0, so Value.buf could // be parsed as a valid PUTF8Char buffer (e.g. containing JSON) procedure FromVarString(var Source: PByte; var Value: TSynTempBuffer); overload; type /// kind of result returned by FromVarBlob() function TValueResult = record /// start of data value Ptr: PAnsiChar; /// value length (in bytes) Len: integer; end; /// retrieve pointer and length to a variable-length text/blob buffer function FromVarBlob(Data: PByte): TValueResult; {$ifdef HASINLINE}inline;{$endif} { ************ low-level RTTI types and conversion routines ***************** } type /// function prototype to be used for TDynArray Sort and Find method // - common functions exist for base types: see e.g. SortDynArrayBoolean, // SortDynArrayByte, SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal, // SortDynArrayInt64, SortDynArrayQWord, SordDynArraySingle, SortDynArrayDouble, // SortDynArrayAnsiString, SortDynArrayAnsiStringI, SortDynArrayUnicodeString, // SortDynArrayUnicodeStringI, SortDynArrayString, SortDynArrayStringI // - any custom type (even records) can be compared then sort by defining // such a custom function // - must return 0 if A=B, -1 if AB TDynArraySortCompare = function(const A,B): integer; /// event oriented version of TDynArraySortCompare TEventDynArraySortCompare = function(const A,B): integer of object; /// optional event called by TDynArray.LoadFrom method after each item load // - could be used e.g. for string interning or some custom initialization process // - won't be called if the dynamic array has ElemType=nil TDynArrayAfterLoadFrom = procedure(var A) of object; /// internal enumeration used to specify some standard Delphi arrays // - will be used e.g. to match JSON serialization or TDynArray search // (see TDynArray and TDynArrayHash InitSpecific method) // - djBoolean would generate an array of JSON boolean values // - djByte .. djTimeLog match numerical JSON values // - djDateTime .. djHash512 match textual JSON values // - djVariant will match standard variant JSON serialization (including // TDocVariant or other custom types, if any) // - djCustom will be used for registered JSON serializer (invalid for // InitSpecific methods call) // - see also djPointer and djObject constant aliases for a pointer or // TObject field hashing / comparison // - is used also by TDynArray.InitSpecific() to define the main field type TDynArrayKind = ( djNone, djBoolean, djByte, djWord, djInteger, djCardinal, djSingle, djInt64, djQWord, djDouble, djCurrency, djTimeLog, djDateTime, djDateTimeMS, djRawUTF8, djWinAnsi, djString, djRawByteString, djWideString, djSynUnicode, djHash128, djHash256, djHash512, djInterface, {$ifndef NOVARIANTS}djVariant,{$endif} djCustom); /// internal set to specify some standard Delphi arrays TDynArrayKinds = set of TDynArrayKind; {$ifdef FPC} /// map the Delphi/FPC dynamic array header (stored before each instance) // - define globally for proper inlining with FPC TDynArrayRec = packed record /// dynamic array reference count (basic garbage memory mechanism) refCnt: PtrInt; high: tdynarrayindex; function GetLength: sizeint; inline; procedure SetLength(len: sizeint); inline; property length: sizeint read GetLength write SetLength; end; PDynArrayRec = ^TDynArrayRec; {$endif FPC} function ToText(k: TDynArrayKind): PShortString; overload; const /// TDynArrayKind alias for a pointer field hashing / comparison djPointer = {$ifdef CPU64}djInt64{$else}djCardinal{$endif}; /// TDynArrayKind alias for a TObject field hashing / comparison djObject = djPointer; type /// the available JSON format, for TTextWriter.AddJSONReformat() and its // JSONBufferReformat() and JSONReformat() wrappers // - jsonCompact is the default machine-friendly single-line layout // - jsonHumanReadable will add line feeds and indentation, for a more // human-friendly result // - jsonUnquotedPropName will emit the jsonHumanReadable layout, but // with all property names being quoted only if necessary: this format // could be used e.g. for configuration files - this format, similar to the // one used in the MongoDB extended syntax, is not JSON compatible: do not // use it e.g. with AJAX clients, but is would be handled as expected by all // our units as valid JSON input, without previous correction // - jsonUnquotedPropNameCompact will emit single-line layout with unquoted // property names TTextWriterJSONFormat = ( jsonCompact, jsonHumanReadable, jsonUnquotedPropName, jsonUnquotedPropNameCompact); TDynArrayObjArray = (oaUnknown, oaFalse, oaTrue); /// a wrapper around a dynamic array with one dimension // - provide TList-like methods using fast RTTI information // - can be used to fast save/retrieve all memory content to a TStream // - note that the "const Elem" is not checked at compile time nor runtime: // you must ensure that Elem matchs the element type of the dynamic array // - can use external Count storage to make Add() and Delete() much faster // (avoid most reallocation of the memory buffer) // - Note that TDynArray is just a wrapper around an existing dynamic array: // methods can modify the content of the associated variable but the TDynArray // doesn't contain any data by itself. It is therefore aimed to initialize // a TDynArray wrapper on need, to access any existing dynamic array. // - is defined either as an object either as a record, due to a bug // in Delphi 2009/2010 compiler (at least): this structure is not initialized // if defined as an object on the stack, but will be as a record :( {$ifdef UNDIRECTDYNARRAY}TDynArray = record private {$else}TDynArray = object protected{$endif} fValue: PPointer; fTypeInfo: pointer; fElemType: pointer; fCountP: PInteger; fCompare: TDynArraySortCompare; fElemSize: cardinal; fKnownSize: integer; fParser: integer; // index to GlobalJSONCustomParsers.fParsers[] fSorted: boolean; fKnownType: TDynArrayKind; fIsObjArray: TDynArrayObjArray; function GetCount: integer; {$ifdef HASINLINE}inline;{$endif} procedure SetCount(aCount: integer); function GetCapacity: integer; procedure SetCapacity(aCapacity: integer); procedure SetCompare(const aCompare: TDynArraySortCompare); {$ifdef HASINLINE}inline;{$endif} function FindIndex(const Elem; aIndex: PIntegerDynArray; aCompare: TDynArraySortCompare): PtrInt; function GetArrayTypeName: RawUTF8; function GetArrayTypeShort: PShortString; function GetIsObjArray: boolean; {$ifdef HASINLINE}inline;{$endif} function ComputeIsObjArray: boolean; procedure SetIsObjArray(aValue: boolean); {$ifdef HASINLINE}inline;{$endif} /// will set fKnownType and fKnownOffset/fKnownSize fields function ToKnownType(exactType: boolean=false): TDynArrayKind; function LoadKnownType(Data,Source: PAnsiChar): boolean; /// faster than System.DynArraySetLength() function + handle T*ObjArray procedure InternalSetLength(NewLength: PtrUInt); public /// initialize the wrapper with a one-dimension dynamic array // - the dynamic array must have been defined with its own type // (e.g. TIntegerDynArray = array of Integer) // - if aCountPointer is set, it will be used instead of length() to store // the dynamic array items count - it will be much faster when adding // elements to the array, because the dynamic array won't need to be // resized each time - but in this case, you should use the Count property // instead of length(array) or high(array) when accessing the data: in fact // length(array) will store the memory size reserved, not the items count // - if aCountPointer is set, its content will be set to 0, whatever the // array length is, or the current aCountPointer^ value is // - a sample usage may be: // !var DA: TDynArray; // ! A: TIntegerDynArray; // !begin // ! DA.Init(TypeInfo(TIntegerDynArray),A); // ! (...) // - a sample usage may be (using a count variable): // !var DA: TDynArray; // ! A: TIntegerDynArray; // ! ACount: integer; // ! i: integer; // !begin // ! DA.Init(TypeInfo(TIntegerDynArray),A,@ACount); // ! for i := 1 to 100000 do // ! DA.Add(i); // MUCH faster using the ACount variable // ! (...) // now you should use DA.Count or Count instead of length(A) procedure Init(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil); /// initialize the wrapper with a one-dimension dynamic array // - this version accepts to specify how comparison should occur, using // TDynArrayKind kind of first field // - djNone and djCustom are too vague, and will raise an exception // - no RTTI check is made over the corresponding array layout: you shall // ensure that the aKind parameter matches the dynamic array element definition // - aCaseInsensitive will be used for djRawUTF8..djHash512 text comparison procedure InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind; aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false); /// define the reference to an external count integer variable // - Init and InitSpecific methods will reset the aCountPointer to 0: you // can use this method to set the external count variable without overriding // the current value procedure UseExternalCount(var aCountPointer: Integer); {$ifdef HASINLINE}inline;{$endif} /// check this dynamic array from the GlobalJSONCustomParsers list // - returns TRUE if this array has a custom JSON parser function HasCustomJSONParser: boolean; /// initialize the wrapper to point to no dynamic array procedure Void; /// check if the wrapper points to a dynamic array function IsVoid: boolean; /// add an element to the dynamic array // - warning: Elem must be of the same exact type than the dynamic array, // and must be a reference to a variable (you can't write Add(i+10) e.g.) // - returns the index of the added element in the dynamic array // - note that because of dynamic array internal memory managment, adding // may reallocate the list every time a record is added, unless an external // count variable has been specified in Init(...,@Count) method function Add(const Elem): PtrInt; /// add an element to the dynamic array // - this version add a void element to the array, and returns its index // - note: if you use this method to add a new item with a reference to the // dynamic array, using a local variable is needed under FPC: // ! i := DynArray.New; // ! with Values[i] do begin // otherwise Values is nil -> GPF // ! Field1 := 1; // ! ... function New: integer; /// add an element to the dynamic array at the position specified by Index // - warning: Elem must be of the same exact type than the dynamic array, // and must be a reference to a variable (you can't write Insert(10,i+10) e.g.) procedure Insert(Index: PtrInt; const Elem); /// get and remove the last element stored in the dynamic array // - Add + Pop/Peek will implement a LIFO (Last-In-First-Out) stack // - warning: Elem must be of the same exact type than the dynamic array // - returns true if the item was successfully copied and removed // - use Peek() if you don't want to remove the item function Pop(var Dest): boolean; /// get the last element stored in the dynamic array // - Add + Pop/Peek will implement a LIFO (Last-In-First-Out) stack // - warning: Elem must be of the same exact type than the dynamic array // - returns true if the item was successfully copied into Dest // - use Pop() if you also want to remove the item function Peek(var Dest): boolean; /// delete the whole dynamic array content // - this method will recognize T*ObjArray types and free all instances procedure Clear; {$ifdef HASINLINE}inline;{$endif} /// delete the whole dynamic array content, ignoring exceptions // - returns true if no exception occured when calling Clear, false otherwise // - you should better not call this method, which will catch and ignore // all exceptions - but it may somewhat make sense in a destructor // - this method will recognize T*ObjArray types and free all instances function ClearSafe: boolean; /// delete one item inside the dynamic array // - the deleted element is finalized if necessary // - this method will recognize T*ObjArray types and free all instances procedure Delete(aIndex: PtrInt); /// search for an element value inside the dynamic array // - return the index found (0..Count-1), or -1 if Elem was not found // - will search for all properties content of the eLement: TList.IndexOf() // searches by address, this method searches by content using the RTTI // element description (and not the Compare property function) // - use the Find() method if you want the search via the Compare property // function, or e.g. to search only with some part of the element content // - will work with simple types: binaries (byte, word, integer, Int64, // Currency, array[0..255] of byte, packed records with no reference-counted // type within...), string types (e.g. array of string), and packed records // with binary and string types within (like TFileVersion) // - won't work with not packed types (like a shorstring, or a record // with byte or word fields with {$A+}): in this case, the padding data // (i.e. the bytes between the aligned feeds can be filled as random, and // there is no way with standard RTTI do know which they are) // - warning: Elem must be of the same exact type than the dynamic array, // and must be a reference to a variable (you can't write IndexOf(i+10) e.g.) function IndexOf(const Elem): PtrInt; /// search for an element value inside the dynamic array // - this method will use the Compare property function for the search // - return the index found (0..Count-1), or -1 if Elem was not found // - if the array is sorted, it will use fast O(log(n)) binary search // - if the array is not sorted, it will use slower O(n) iterating search // - warning: Elem must be of the same exact type than the dynamic array, // and must be a reference to a variable (you can't write Find(i+10) e.g.) function Find(const Elem): PtrInt; overload; /// search for an element value inside the dynamic array, from an external // indexed lookup table // - return the index found (0..Count-1), or -1 if Elem was not found // - this method will use a custom comparison function, with an external // integer table, as created by the CreateOrderedIndex() method: it allows // multiple search orders in the same dynamic array content // - if an indexed lookup is supplied, it must already be sorted: // this function will then use fast O(log(n)) binary search // - if an indexed lookup is not supplied (i.e aIndex=nil), // this function will use slower but accurate O(n) iterating search // - warning; the lookup index should be synchronized if array content // is modified (in case of adding or deletion) function Find(const Elem; const aIndex: TIntegerDynArray; aCompare: TDynArraySortCompare): PtrInt; overload; /// search for an element value, then fill all properties if match // - this method will use the Compare property function for the search, // or the supplied indexed lookup table and its associated compare function // - if Elem content matches, all Elem fields will be filled with the record // - can be used e.g. as a simple dictionary: if Compare will match e.g. the // first string field (i.e. set to SortDynArrayString), you can fill the // first string field with the searched value (if returned index is >= 0) // - return the index found (0..Count-1), or -1 if Elem was not found // - if the array is sorted, it will use fast O(log(n)) binary search // - if the array is not sorted, it will use slower O(n) iterating search // - warning: Elem must be of the same exact type than the dynamic array, // and must be a reference to a variable (you can't write Find(i+10) e.g.) function FindAndFill(var Elem; aIndex: PIntegerDynArray=nil; aCompare: TDynArraySortCompare=nil): integer; /// search for an element value, then delete it if match // - this method will use the Compare property function for the search, // or the supplied indexed lookup table and its associated compare function // - if Elem content matches, this item will be deleted from the array // - can be used e.g. as a simple dictionary: if Compare will match e.g. the // first string field (i.e. set to SortDynArrayString), you can fill the // first string field with the searched value (if returned index is >= 0) // - return the index deleted (0..Count-1), or -1 if Elem was not found // - if the array is sorted, it will use fast O(log(n)) binary search // - if the array is not sorted, it will use slower O(n) iterating search // - warning: Elem must be of the same exact type than the dynamic array, // and must be a reference to a variable (you can't write Find(i+10) e.g.) function FindAndDelete(const Elem; aIndex: PIntegerDynArray=nil; aCompare: TDynArraySortCompare=nil): integer; /// search for an element value, then update the item if match // - this method will use the Compare property function for the search, // or the supplied indexed lookup table and its associated compare function // - if Elem content matches, this item will be updated with the supplied value // - can be used e.g. as a simple dictionary: if Compare will match e.g. the // first string field (i.e. set to SortDynArrayString), you can fill the // first string field with the searched value (if returned index is >= 0) // - return the index found (0..Count-1), or -1 if Elem was not found // - if the array is sorted, it will use fast O(log(n)) binary search // - if the array is not sorted, it will use slower O(n) iterating search // - warning: Elem must be of the same exact type than the dynamic array, // and must be a reference to a variable (you can't write Find(i+10) e.g.) function FindAndUpdate(const Elem; aIndex: PIntegerDynArray=nil; aCompare: TDynArraySortCompare=nil): integer; /// search for an element value, then add it if none matched // - this method will use the Compare property function for the search, // or the supplied indexed lookup table and its associated compare function // - if no Elem content matches, the item will added to the array // - can be used e.g. as a simple dictionary: if Compare will match e.g. the // first string field (i.e. set to SortDynArrayString), you can fill the // first string field with the searched value (if returned index is >= 0) // - return the index found (0..Count-1), or -1 if Elem was not found and // the supplied element has been succesfully added // - if the array is sorted, it will use fast O(log(n)) binary search // - if the array is not sorted, it will use slower O(n) iterating search // - warning: Elem must be of the same exact type than the dynamic array, // and must be a reference to a variable (you can't write Find(i+10) e.g.) function FindAndAddIfNotExisting(const Elem; aIndex: PIntegerDynArray=nil; aCompare: TDynArraySortCompare=nil): integer; /// sort the dynamic array elements, using the Compare property function // - it will change the dynamic array content, and exchange all elements // in order to be sorted in increasing order according to Compare function procedure Sort(aCompare: TDynArraySortCompare=nil); overload; /// sort some dynamic array elements, using the Compare property function // - this method allows to sort only some part of the items // - it will change the dynamic array content, and exchange all elements // in order to be sorted in increasing order according to Compare function procedure SortRange(aStart, aStop: integer; aCompare: TDynArraySortCompare=nil); /// sort the dynamic array elements, using a Compare method (not function) // - it will change the dynamic array content, and exchange all elements // in order to be sorted in increasing order according to Compare function, // unless aReverse is true // - it won't mark the array as Sorted, since the comparer is local procedure Sort(const aCompare: TEventDynArraySortCompare; aReverse: boolean=false); overload; /// search the elements range which match a given value in a sorted dynamic array // - this method will use the Compare property function for the search // - returns TRUE and the matching indexes, or FALSE if none found // - if the array is not sorted, returns FALSE function FindAllSorted(const Elem; out FirstIndex,LastIndex: Integer): boolean; /// search for an element value inside a sorted dynamic array // - this method will use the Compare property function for the search // - will be faster than a manual FindAndAddIfNotExisting+Sort process // - returns TRUE and the index of existing Elem, or FALSE and the index // where the Elem is to be inserted so that the array remains sorted // - you should then call FastAddSorted() later with the returned Index // - if the array is not sorted, returns FALSE and Index=-1 // - warning: Elem must be of the same exact type than the dynamic array, // and must be a reference to a variable (no FastLocateSorted(i+10) e.g.) function FastLocateSorted(const Elem; out Index: Integer): boolean; /// insert a sorted element value at the proper place // - the index should have been computed by FastLocateSorted(): false // - you may consider using FastLocateOrAddSorted() instead procedure FastAddSorted(Index: Integer; const Elem); /// search and add an element value inside a sorted dynamic array // - this method will use the Compare property function for the search // - will be faster than a manual FindAndAddIfNotExisting+Sort process // - returns the index of the existing Elem and wasAdded^=false // - returns the sorted index of the inserted Elem and wasAdded^=true // - if the array is not sorted, returns -1 and wasAdded^=false // - is just a wrapper around FastLocateSorted+FastAddSorted function FastLocateOrAddSorted(const Elem; wasAdded: PBoolean=nil): integer; /// delete a sorted element value at the proper place // - plain Delete(Index) would reset the fSorted flag to FALSE, so use // this method with a FastLocateSorted/FastAddSorted array procedure FastDeleteSorted(Index: Integer); /// will reverse all array elements, in place procedure Reverse; /// sort the dynamic array elements using a lookup array of indexes // - in comparison to the Sort method, this CreateOrderedIndex won't change // the dynamic array content, but only create (or update) the supplied // integer lookup array, using the specified comparison function // - if aCompare is not supplied, the method will use fCompare (if defined) // - you should provide either a void either a valid lookup table, that is // a table with one to one lookup (e.g. created with FillIncreasing) // - if the lookup table has less elements than the main dynamic array, // its content will be recreated procedure CreateOrderedIndex(var aIndex: TIntegerDynArray; aCompare: TDynArraySortCompare); overload; /// sort the dynamic array elements using a lookup array of indexes // - this overloaded method will use the supplied TSynTempBuffer for // index storage, so use PIntegerArray(aIndex.buf) to access the values // - caller should always make aIndex.Done once done procedure CreateOrderedIndex(out aIndex: TSynTempBuffer; aCompare: TDynArraySortCompare); overload; /// sort using a lookup array of indexes, after a Add() // - will resize aIndex if necessary, and set aIndex[Count-1] := Count-1 procedure CreateOrderedIndexAfterAdd(var aIndex: TIntegerDynArray; aCompare: TDynArraySortCompare); /// save the dynamic array content into a (memory) stream // - will handle array of binaries values (byte, word, integer...), array of // strings or array of packed records, with binaries and string properties // - will use a proprietary binary format, with some variable-length encoding // of the string length - note that if you change the type definition, any // previously-serialized content will fail, maybe triggering unexpected GPF: // use SaveToTypeInfoHash if you share this binary data accross executables // - Stream position will be set just after the added data // - is optimized for memory streams, but will work with any kind of TStream procedure SaveToStream(Stream: TStream); /// load the dynamic array content from a (memory) stream // - stream content must have been created using SaveToStream method // - will handle array of binaries values (byte, word, integer...), array of // strings or array of packed records, with binaries and string properties // - will use a proprietary binary format, with some variable-length encoding // of the string length - note that if you change the type definition, any // previously-serialized content will fail, maybe triggering unexpected GPF: // use SaveToTypeInfoHash if you share this binary data accross executables procedure LoadFromStream(Stream: TCustomMemoryStream); /// save the dynamic array content into an allocated memory buffer // - Dest buffer must have been allocated to contain at least the number // of bytes returned by the SaveToLength method // - return a pointer at the end of the data written in Dest, nil in case // of an invalid input buffer // - will use a proprietary binary format, with some variable-length encoding // of the string length - note that if you change the type definition, any // previously-serialized content will fail, maybe triggering unexpected GPF: // use SaveToTypeInfoHash if you share this binary data accross executables // - this method will raise an ESynException for T*ObjArray types // - use TDynArray.LoadFrom or TDynArrayLoadFrom to decode the saved buffer function SaveTo(Dest: PAnsiChar): PAnsiChar; overload; /// compute the number of bytes needed by SaveTo() to persist a dynamic array // - will use a proprietary binary format, with some variable-length encoding // of the string length - note that if you change the type definition, any // previously-serialized content will fail, maybe triggering unexpected GPF: // use SaveToTypeInfoHash if you share this binary data accross executables // - this method will raise an ESynException for T*ObjArray types function SaveToLength: integer; /// save the dynamic array content into a RawByteString // - will use a proprietary binary format, with some variable-length encoding // of the string length - note that if you change the type definition, any // previously-serialized content will fail, maybe triggering unexpected GPF: // use SaveToTypeInfoHash if you share this binary data accross executables // - this method will raise an ESynException for T*ObjArray types // - use TDynArray.LoadFrom or TDynArrayLoadFrom to decode the saved buffer function SaveTo: RawByteString; overload; /// compute a crc32c-based hash of the RTTI for this dynamic array // - can be used to ensure that the TDynArray.SaveTo binary layout // is compatible accross executables // - won't include the RTTI type kind, as TypeInfoToHash(), but only // ElemSize or ElemType information, or any previously registered // TTextWriter.RegisterCustomJSONSerializerFromText definition function SaveToTypeInfoHash(crc: cardinal=0): cardinal; /// load the dynamic array content from a memory buffer // - return nil if the Source buffer is incorrect (invalid type or internal // checksum e.g.), or return the memory buffer pointer just after the // content, as written by TDynArray.SaveTo // - this method will raise an ESynException for T*ObjArray types // - you can optionally call AfterEach callback for each row loaded // - if you don't want to allocate all items on memory, but just want to // iterate over all items stored in a TDynArray.SaveTo memory buffer, // consider using TDynArrayLoadFrom object function LoadFrom(Source: PAnsiChar; AfterEach: TDynArrayAfterLoadFrom=nil; NoCheckHash: boolean=false): PAnsiChar; /// serialize the dynamic array content as JSON // - is just a wrapper around TTextWriter.AddDynArrayJSON() // - this method will therefore recognize T*ObjArray types function SaveToJSON(EnumSetsAsText: boolean=false; reformat: TTextWriterJSONFormat=jsonCompact): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// serialize the dynamic array content as JSON // - is just a wrapper around TTextWriter.AddDynArrayJSON() // - this method will therefore recognize T*ObjArray types procedure SaveToJSON(out Result: RawUTF8; EnumSetsAsText: boolean=false; reformat: TTextWriterJSONFormat=jsonCompact); overload; /// load the dynamic array content from an UTF-8 encoded JSON buffer // - expect the format as saved by TTextWriter.AddDynArrayJSON method, i.e. // handling TBooleanDynArray, TIntegerDynArray, TInt64DynArray, TCardinalDynArray, // TDoubleDynArray, TCurrencyDynArray, TWordDynArray, TByteDynArray, // TRawUTF8DynArray, TWinAnsiDynArray, TRawByteStringDynArray, // TStringDynArray, TWideStringDynArray, TSynUnicodeDynArray, // TTimeLogDynArray and TDateTimeDynArray as JSON array - or any customized // valid JSON serialization as set by TTextWriter.RegisterCustomJSONSerializer // - or any other kind of array as Base64 encoded binary stream precessed // via JSON_BASE64_MAGIC (UTF-8 encoded \uFFF0 special code) // - typical handled content could be // ! '[1,2,3,4]' or '["\uFFF0base64encodedbinary"]' // - return a pointer at the end of the data read from P, nil in case // of an invalid input buffer // - this method will recognize T*ObjArray types, and will first free // any existing instance before unserializing, to avoid memory leak // - warning: the content of P^ will be modified during parsing: please // make a local copy if it will be needed later (using e.g. TSynTempBufer) function LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil): PUTF8Char; {$ifndef NOVARIANTS} /// load the dynamic array content from a TDocVariant instance // - will convert the TDocVariant into JSON, the call LoadFromJSON function LoadFromVariant(const DocVariant: variant): boolean; {$endif NOVARIANTS} /// select a sub-section (slice) of a dynamic array content procedure Slice(var Dest; aCount: Cardinal; aFirstIndex: cardinal=0); /// add elements from a given dynamic array variable // - the supplied source DynArray MUST be of the same exact type as the // current used for this TDynArray - warning: pass here a reference to // a "array of ..." variable, not another TDynArray instance; if you // want to add another TDynArray, use AddDynArray() method // - you can specify the start index and the number of items to take from // the source dynamic array (leave as -1 to add till the end) // - returns the number of items added to the array function AddArray(const DynArrayVar; aStartIndex: integer=0; aCount: integer=-1): integer; {$ifndef DELPHI5OROLDER} /// fast initialize a wrapper for an existing dynamic array of the same type // - is slightly faster than // ! Init(aAnother.ArrayType,aValue,nil); procedure InitFrom(const aAnother: TDynArray; var aValue); {$ifdef HASINLINE}inline;{$endif} /// add elements from a given TDynArray // - the supplied source TDynArray MUST be of the same exact type as the // current used for this TDynArray, otherwise it won't do anything // - you can specify the start index and the number of items to take from // the source dynamic array (leave as -1 to add till the end) procedure AddDynArray(const aSource: TDynArray; aStartIndex: integer=0; aCount: integer=-1); /// compare the content of the two arrays, returning TRUE if both match // - this method compares using any supplied Compare property (unless // ignorecompare=true), or by content using the RTTI element description // of the whole array items // - will call SaveToJSON to compare T*ObjArray kind of arrays function Equals(const B: TDynArray; ignorecompare: boolean=false): boolean; /// set all content of one dynamic array to the current array // - both must be of the same exact type // - T*ObjArray will be reallocated and copied by content (using a temporary // JSON serialization), unless ObjArrayByRef is true and pointers are copied procedure Copy(const Source: TDynArray; ObjArrayByRef: boolean=false); /// set all content of one dynamic array to the current array // - both must be of the same exact type // - T*ObjArray will be reallocated and copied by content (using a temporary // JSON serialization), unless ObjArrayByRef is true and pointers are copied procedure CopyFrom(const Source; MaxElem: integer; ObjArrayByRef: boolean=false); /// set all content of the current dynamic array to another array variable // - both must be of the same exact type // - resulting length(Dest) will match the exact items count, even if an // external Count integer variable is used by this instance // - T*ObjArray will be reallocated and copied by content (using a temporary // JSON serialization), unless ObjArrayByRef is true and pointers are copied procedure CopyTo(out Dest; ObjArrayByRef: boolean=false); {$endif DELPHI5OROLDER} /// returns a pointer to an element of the array // - returns nil if aIndex is out of range // - since TDynArray is just a wrapper around an existing array, you should // better use direct access to its wrapped variable, and not using this // slower and more error prone method (such pointer access lacks of strong // typing abilities), which was designed for TDynArray internal use function ElemPtr(index: PtrInt): pointer; {$ifdef HASINLINE}inline;{$endif} /// will copy one element content from its index into another variable // - do nothing if index is out of range procedure ElemCopyAt(index: PtrInt; var Dest); {$ifdef FPC}inline;{$endif} /// will move one element content from its index into another variable // - will erase the internal item after copy // - do nothing if index is out of range procedure ElemMoveTo(index: PtrInt; var Dest); /// will copy one variable content into an indexed element // - do nothing if index is out of range // - ClearBeforeCopy will call ElemClear() before the copy, which may be safer // if the source item is a copy of Values[index] with some dynamic arrays procedure ElemCopyFrom(const Source; index: PtrInt; ClearBeforeCopy: boolean=false); {$ifdef FPC}inline;{$endif} /// compare the content of two elements, returning TRUE if both values equal // - this method compares first using any supplied Compare property, // then by content using the RTTI element description of the whole record function ElemEquals(const A,B): boolean; /// will reset the element content procedure ElemClear(var Elem); /// will copy one element content procedure ElemCopy(const A; var B); {$ifdef FPC}inline;{$endif} /// will copy the first field value of an array element // - will use the array KnownType to guess the copy routine to use // - returns false if the type information is not enough for a safe copy function ElemCopyFirstField(Source,Dest: Pointer): boolean; /// save an array element into a serialized binary content // - use the same layout as TDynArray.SaveTo, but for a single item // - you can use ElemLoad method later to retrieve its content // - warning: Elem must be of the same exact type than the dynamic array, // and must be a reference to a variable (you can't write ElemSave(i+10) e.g.) function ElemSave(const Elem): RawByteString; /// load an array element as saved by the ElemSave method into Elem variable // - warning: Elem must be of the same exact type than the dynamic array, // and must be a reference to a variable (you can't write ElemLoad(P,i+10) e.g.) procedure ElemLoad(Source: PAnsiChar; var Elem); overload; /// load an array element as saved by the ElemSave method // - this overloaded method will retrieve the element as a memory buffer, // which should be cleared by ElemLoadClear() before release function ElemLoad(Source: PAnsiChar): RawByteString; overload; /// search for an array element as saved by the ElemSave method // - same as ElemLoad() + Find()/IndexOf() + ElemLoadClear() // - will call Find() method if Compare property is set // - will call generic IndexOf() method if no Compare property is set function ElemLoadFind(Source: PAnsiChar): integer; /// finalize a temporary buffer used to store an element via ElemLoad() // - will release any managed type referenced inside the RawByteString, // then void the variable // - is just a wrapper around ElemClear(pointer(ElemTemp)) + ElemTemp := '' procedure ElemLoadClear(var ElemTemp: RawByteString); /// retrieve or set the number of elements of the dynamic array // - same as length(DynArray) or SetLength(DynArray) // - this property will recognize T*ObjArray types, so will free any stored // instance if the array is sized down property Count: integer read GetCount write SetCount; /// the internal buffer capacity // - if no external Count pointer was set with Init, is the same as Count // - if an external Count pointer is set, you can set a value to this // property before a massive use of the Add() method e.g. // - if no external Count pointer is set, set a value to this property // will affect the Count value, i.e. Add() will append after this count // - this property will recognize T*ObjArray types, so will free any stored // instance if the array is sized down property Capacity: integer read GetCapacity write SetCapacity; /// the compare function to be used for Sort and Find methods // - by default, no comparison function is set // - common functions exist for base types: e.g. SortDynArrayByte, SortDynArrayBoolean, // SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle, // SortDynArrayInt64, SortDynArrayDouble, SortDynArrayAnsiString, // SortDynArrayAnsiStringI, SortDynArrayString, SortDynArrayStringI, // SortDynArrayUnicodeString, SortDynArrayUnicodeStringI property Compare: TDynArraySortCompare read fCompare write SetCompare; /// must be TRUE if the array is currently in sorted order according to // the compare function // - Add/Delete/Insert/Load* methods will reset this property to false // - Sort method will set this property to true // - you MUST set this property to false if you modify the dynamic array // content in your code, so that Find() won't try to wrongly use binary // search in an unsorted array, and miss its purpose property Sorted: boolean read fSorted write fSorted; /// low-level direct access to the storage variable property Value: PPointer read fValue; /// the known type, possibly retrieved from dynamic array RTTI property KnownType: TDynArrayKind read fKnownType; /// the known RTTI information of the whole array property ArrayType: pointer read fTypeInfo; /// the known type name of the whole array, as RawUTF8 property ArrayTypeName: RawUTF8 read GetArrayTypeName; /// the known type name of the whole array, as PShortString property ArrayTypeShort: PShortString read GetArrayTypeShort; /// the internal in-memory size of one element, as retrieved from RTTI property ElemSize: cardinal read fElemSize; /// the internal type information of one element, as retrieved from RTTI property ElemType: pointer read fElemType; /// if this dynamic aray is a T*ObjArray property IsObjArray: boolean read GetIsObjArray write SetIsObjArray; end; /// a pointer to a TDynArray wrapper instance PDynArray = ^TDynArray; /// allows to iterate over a TDynArray.SaveTo binary buffer // - may be used as alternative to TDynArray.LoadFrom, if you don't want // to allocate all items at once, but retrieve items one by one {$ifdef FPC_OR_UNICODE}TDynArrayLoadFrom = record private {$else}TDynArrayLoadFrom = object protected{$endif} DynArray: TDynArray; // used to access RTTI Hash: PCardinalArray; public /// how many items were saved in the TDynArray.SaveTo binary buffer Count: integer; /// the zero-based index of the current item pointed by next Step() call // - is in range 0..Count-1 until Step() returns false Current: integer; /// current position in the TDynArray.SaveTo binary buffer // - after Step() returned false, points just after the binary buffer, // like a regular TDynArray.LoadFrom Position: PAnsiChar; /// initialize iteration over a TDynArray.SaveTo binary buffer // - returns true on success, with Count and Position being set // - returns false if the supplied binary buffer is not correct function Init(ArrayTypeInfo: pointer; Source: PAnsiChar): boolean; /// iterate over the current stored item // - Elem should point to a variable of the exact item type stored in this // dynamic array // - returns true if Elem was filled with one value, or false if all // items were read, and Position contains the end of the binary buffer function Step(out Elem): boolean; /// extract the first field value of the current stored item // - returns true if Field was filled with one value, or false if all // items were read, and Position contains the end of the binary buffer // - could be called before Step(), to pre-allocate a new item instance, // or update an existing instance function FirstField(out Field): boolean; /// after all items are read by Step(), validate the stored hash // - returns true if items hash is correct, false otherwise function CheckHash: boolean; end; /// function prototype to be used for hashing of a dynamic array element // - this function must use the supplied hasher on the Elem data TDynArrayHashOne = function(const Elem; Hasher: THasher): cardinal; /// event handler to be used for hashing of a dynamic array element // - can be set as an alternative to TDynArrayHashOne TEventDynArrayHashOne = function(const Elem): cardinal of object; /// internal structure used to store one item hash // - used e.g. by TDynArrayHashed or TObjectHash via TSynHashDynArray TSynHash = record /// unsigned integer hash of the item Hash: cardinal; /// index of the item in the main storage array Index: cardinal; end; /// internal structure used to store hashs of items // - used e.g. by TDynArrayHashed or TObjectHash TSynHashDynArray = array of TSynHash; {.$define DYNARRAYHASHCOLLISIONCOUNT} /// used to access any dynamic arrray elements using fast hash // - by default, binary sort could be used for searching items for TDynArray: // using a hash is faster on huge arrays for implementing a dictionary // - in this current implementation, modification (update or delete) of an // element is not handled yet: you should rehash all content - only // TDynArrayHashed.FindHashedForAdding / FindHashedAndUpdate / // FindHashedAndDelete will refresh the internal hash // - this object extends the TDynArray type, since presence of Hashs[] dynamic // array will increase code size if using TDynArrayHashed instead of TDynArray // - in order to have the better performance, you should use an external Count // variable, AND set the Capacity property to the expected maximum count (this // will avoid most ReHash calls for FindHashedForAdding+FindHashedAndUpdate) {$ifdef UNDIRECTDYNARRAY} TDynArrayHashed = record // pseudo inheritance for most used methods private function GetCount: Integer; inline; procedure SetCount(aCount: integer); inline; procedure SetCapacity(aCapacity: Integer); inline; function GetCapacity: Integer; inline; public InternalDynArray: TDynArray; function Value: PPointer; inline; function ElemSize: PtrUInt; inline; function ElemType: Pointer; inline; function KnownType: TDynArrayKind; inline; procedure Clear; inline; procedure ElemCopy(const A; var B); inline; function ElemPtr(index: PtrInt): pointer; inline; procedure ElemCopyAt(index: PtrInt; var Dest); inline; // warning: you shall call ReHash() after manual Add/Delete function Add(const Elem): integer; inline; procedure Delete(aIndex: PtrInt); inline; function SaveTo: RawByteString; overload; inline; function SaveTo(Dest: PAnsiChar): PAnsiChar; overload; inline; function SaveToJSON(EnumSetsAsText: boolean=false; reformat: TTextWriterJSONFormat=jsonCompact): RawUTF8; inline; procedure Sort(aCompare: TDynArraySortCompare=nil); inline; function LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil): PUTF8Char; inline; function SaveToLength: integer; inline; function LoadFrom(Source: PAnsiChar): PAnsiChar; inline; property Count: integer read GetCount write SetCount; property Capacity: integer read GetCapacity write SetCapacity; private {$else UNDIRECTDYNARRAY} TDynArrayHashed = object(TDynArray) protected {$endif UNDIRECTDYNARRAY} fHashElement: TDynArrayHashOne; fHasher: THasher; fHashs: TSynHashDynArray; fHashsCount: integer; fEventCompare: TEventDynArraySortCompare; fEventHash: TEventDynArrayHashOne; fHashCountTrigger: integer; fHashFindCount: integer; {$ifdef DYNARRAYHASHCOLLISIONCOUNT} fHashFindCollisions: cardinal; {$endif} procedure HashAdd(const Elem; aHashCode: Cardinal; var result: integer); /// low-level search of an element from its pre-computed hash // - if not found and aForAdd=true, returns -(indexofvoidfHashs[]+1) // - this overloaded method will return the first matching item: use the // HashFindAndCompare(...; const Elem) method to avoid any collision issue // - you should NOT use this method, but rather high-level FindHashed*() function HashFind(aHashCode: cardinal; aForAdd: boolean): integer; /// low-level search of an element from its pre-computed hash // - search for the hash, then use fEventCompare/fCompare/ElemEquals // - if not found, returns -(indexofvoidfHashs[]+1) // - you should NOT use this method, but rather high-level FindHashed*() function HashFindAndCompare(aHashCode: cardinal; const Elem): integer; function GetHashFromIndex(aIndex: PtrInt): Cardinal; procedure HashInvalidate; procedure RaiseFatalCollision(const caller: RawUTF8; aHashCode: cardinal); public /// initialize the wrapper with a one-dimension dynamic array // - this version accepts some hash-dedicated parameters: aHashElement to // set how to hash each element, aCompare to handle hash collision // - if no aHashElement is supplied, it will hash according to the RTTI, i.e. // strings or binary types, and the first field for records (strings included) // - if no aCompare is supplied, it will use default Equals() method // - if no THasher function is supplied, it will use the one supplied in // DefaultHasher global variable, set to crc32c() by default - using // SSE4.2 instruction if available // - if CaseInsensitive is set to TRUE, it will ignore difference in 7 bit // alphabetic characters (e.g. compare 'a' and 'A' as equal) procedure Init(aTypeInfo: pointer; var aValue; aHashElement: TDynArrayHashOne=nil; aCompare: TDynArraySortCompare=nil; aHasher: THasher=nil; aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false); /// initialize the wrapper with a one-dimension dynamic array // - this version accepts to specify how both hashing and comparison should // occur, setting the TDynArrayKind kind of first/hashed field // - djNone and djCustom are too vague, and will raise an exception // - no RTTI check is made over the corresponding array layout: you shall // ensure that aKind matches the dynamic array element definition // - aCaseInsensitive will be used for djRawUTF8..djHash512 text comparison procedure InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind; aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false); /// will compute all hash from the current elements of the dynamic array // - is called within the TDynArrayHashed.Init method to initialize the // internal hash array // - can be called on purpose, when modifications have been performed on // the dynamic array content (e.g. in case of element deletion or update, // or after calling LoadFrom/Clear method) - this is not necessary after // FindHashedForAdding / FindHashedAndUpdate / FindHashedAndDelete methods function ReHash(forAdd: boolean=false): boolean; /// low-level function which would inspect the internal fHashs[] array for // any collision // - is a brute force search within fHashs[].Hash values, which may be handy // to validate the current HashElement() function // - returns -1 if no collision was found, or the index of the first collision function IsHashElementWithoutCollision: integer; /// search for an element value inside the dynamic array using hashing // - ELem should be of the same exact type than the dynamic array, or at // least matchs the fields used by both the hash function and Equals method: // e.g. if the searched/hashed field in a record is a string as first field, // you may use a string variable as Elem: other fields will be ignored // - returns -1 if not found, or the index in the dynamic array if found // - optional aHashCode parameter can be supplied with an already hashed // value of the item, to be used e.g. after a call to HashFind() - default // 0 will use fHashElement(Elem,fHasher) function FindHashed(const Elem; aHashCode: cardinal=0): integer; /// search for an element value inside the dynamic array using hashing, and // fill Elem with the found content // - return the index found (0..Count-1), or -1 if Elem was not found // - warning: Elem must be of the same exact type than the dynamic array, // and must be a reference to a variable (you can't write Find(i+10) e.g.) function FindHashedAndFill(var ElemToFill): integer; /// search for an element value inside the dynamic array using hashing, and // add a void entry to the array if was not found // - this method will use hashing for fast retrieval // - Elem should be of the same exact type than the dynamic array, or at // least matchs the fields used by both the hash function and Equals method: // e.g. if the searched/hashed field in a record is a string as first field, // you may use a string variable as Elem: other fields will be ignored // - returns either the index in the dynamic array if found (and set wasAdded // to false), either the newly created index in the dynamic array (and set // wasAdded to true) // - for faster process (avoid ReHash), please set the Capacity property // - warning: in contrast to the Add() method, if an entry is added to the // array (wasAdded=true), the entry is left VOID: you must set the field // content to expecting value - in short, Elem is used only for searching, // not copied to the newly created entry in the array // - optional aHashCode parameter can be supplied with an already hashed // value of the item, to be used e.g. after a call to HashFind() - default // 0 will use fHashElement(Elem,fHasher) function FindHashedForAdding(const Elem; out wasAdded: boolean; aHashCode: cardinal=0): integer; /// ensure a given element name is unique, then add it to the array // - expected element layout is to have a RawUTF8 field at first position // - the aName is searched (using hashing) to be unique, and if not the case, // an ESynException.CreateUTF8() is raised with the supplied arguments // - use internaly FindHashedForAdding method // - this version will set the field content with the unique value // - returns a pointer to the newly added element (to set other fields) function AddUniqueName(const aName: RawUTF8; const ExceptionMsg: RawUTF8; const ExceptionArgs: array of const): pointer; /// search for a given element name, make it unique, and add it to the array // - expected element layout is to have a RawUTF8 field at first position // - the aName is searched (using hashing) to be unique, and if not the case, // some suffix is added to make it unique // - use internaly FindHashedForAdding method // - this version will set the field content with the unique value // - returns a pointer to the newly added element (to set other fields) function AddAndMakeUniqueName(aName: RawUTF8): pointer; /// search for an element value inside the dynamic array using hashing, then // update any matching item, or add the item if none matched // - if AddIfNotExisting is FALSE, returns the index found (0..Count-1), // or -1 if Elem was not found - update will force slow rehash all content // - if AddIfNotExisting is TRUE, returns the index found (0..Count-1), // or the index newly created/added is the Elem value was not matching - // add won't rehash all content - for even faster process (avoid ReHash), // please set the Capacity property // - warning: Elem must be of the same exact type than the dynamic array, and // must refer to a variable (you can't write FindHashedAndUpdate(i+10) e.g.) function FindHashedAndUpdate(const Elem; AddIfNotExisting: boolean): integer; /// search for an element value inside the dynamic array using hashing, and // delete it if matchs // - return the index deleted (0..Count-1), or -1 if Elem was not found // - this will rehash all content: this method could be slow in the current // implementation // - warning: Elem must be of the same exact type than the dynamic array, and // must refer to a variable (you can't write FindHashedAndDelete(i+10) e.g.) function FindHashedAndDelete(const Elem): integer; /// will search for an element value inside the dynamic array without hashing // - is used internally when Count < HashCountTrigger // - is preferred to Find(), since EventCompare would be used if defined // - Elem should be of the same exact type than the dynamic array, or at // least matchs the fields used by both the hash function and Equals method: // e.g. if the searched/hashed field in a record is a string as first field, // you may use a string variable as Elem: other fields will be ignored // - returns -1 if not found, or the index in the dynamic array if found function Scan(const Elem): integer; /// retrieve the hash value of a given item, from its index property Hash[aIndex: PtrInt]: Cardinal read GetHashFromIndex; /// alternative event-oriented Compare function to be used for Sort and Find // - will be used instead of Compare, to allow object-oriented callbacks property EventCompare: TEventDynArraySortCompare read fEventCompare write fEventCompare; /// custom hash function to be used for hashing of a dynamic array element property HashElement: TDynArrayHashOne read fHashElement; /// alternative event-oriented Hash function for ReHash // - this object-oriented callback will be used instead of HashElement // on each dynamic array entries - HashElement will still be used on // const Elem values, since they may be just a sub part of the stored entry property EventHash: TEventDynArrayHashOne read fEventHash write fEventHash; /// after how many items the hashing take place // - for smallest arrays, O(n) seach if faster than O(1) hashing, since // maintaining the fHashs[] lookup has some CPU and memory costs // - equals 32 by default property HashCountTrigger: integer read fHashCountTrigger write fHashCountTrigger; {$ifdef DYNARRAYHASHCOLLISIONCOUNT} /// access to the internal collision of HashFind() // - it won't depend only on the HashElement(), but also on the internal // hash bucket size (which is much lower than 2^32 items) property HashFindCollisions: cardinal read fHashFindCollisions write fHashFindCollisions; {$endif} end; /// defines a wrapper interface around a dynamic array of TObject // - implemented by TObjectDynArrayWrapper for instance // - i.e. most common methods are available to work with a dynamic array // - warning: the IObjectDynArray MUST be defined in the stack, class or // record BEFORE the dynamic array it is wrapping, otherwise you may leak // memory - see for instance TSQLRestServer class: // ! fSessionAuthentications: IObjectDynArray; // defined before the array // ! fSessionAuthentication: TSQLRestServerAuthenticationDynArray; // note that allocation time as variable on the local stack may depend on the // compiler, and its optimization IObjectDynArray = interface ['{A0D50BD0-0D20-4552-B365-1D63393511FC}'] /// search one element within the TObject instances function Find(Instance: TObject): integer; /// add one element to the dynamic array of TObject instances // - once added, the Instance will be owned by this TObjectDynArray instance function Add(Instance: TObject): integer; /// delete one element from the TObject dynamic array // - deleted TObject instance will be freed as expected procedure Delete(Index: integer); /// sort the dynamic array content according to a specified comparer procedure Sort(Compare: TDynArraySortCompare); /// delete all TObject instances, and release the memory // - is not to be called for most use, thanks to reference-counting memory // handling, but can be handy for quick release procedure Clear; /// ensure the internal list capacity is set to the current Count // - may be used to publish the associated dynamic array with the expected // final size, once IObjectDynArray is out of scope procedure Slice; /// returns the number of TObject instances available // - note that the length of the associated dynamic array is used to store // the capacity of the list, so won't probably never match with this value function Count: integer; /// returns the internal array capacity of TObject instances available // - which is in fact the length() of the associated dynamic array function Capacity: integer; end; /// a wrapper to own a dynamic array of TObject // - this version behave list a TObjectList (i.e. owning the class instances) // - but the dynamic array is NOT owned by the instance // - will define an internal Count property, using the dynamic array length // as capacity: adding and deleting will be much faster // - implements IObjectDynArray, so that most common methods are available // to work with the dynamic array // - does not need any sub-classing of generic overhead to work, and will be // reference counted // - warning: the IObjectDynArray MUST be defined in the stack, class or // record BEFORE the dynamic array it is wrapping, otherwise you may leak // memory, and TObjectDynArrayWrapper.Destroy will raise an ESynException // - a sample usage may be: // !var DA: IObjectDynArray; // defined BEFORE the dynamic array itself // ! A: array of TMyObject; // ! i: integer; // !begin // ! DA := TObjectDynArrayWrapper.Create(A); // ! DA.Add(TMyObject.Create('one')); // ! DA.Add(TMyObject.Create('two')); // ! DA.Delete(0); // ! assert(DA.Count=1); // ! assert(A[0].Name='two'); // ! DA.Clear; // ! assert(DA.Count=0); // ! DA.Add(TMyObject.Create('new')); // ! assert(DA.Count=1); // !end; // will auto-release DA (no need of try..finally DA.Free) TObjectDynArrayWrapper = class(TInterfacedObject, IObjectDynArray) protected fValue: PPointer; fCount: integer; fOwnObjects: boolean; public /// initialize the wrapper with a one-dimension dynamic array of TObject // - by default, objects will be owned by this class, but you may set // aOwnObjects=false if you expect the dynamic array to remain available constructor Create(var aValue; aOwnObjects: boolean=true); /// will release all associated TObject instances destructor Destroy; override; /// search one element within the TObject instances function Find(Instance: TObject): integer; /// add one element to the dynamic array of TObject instances // - once added, the Instance will be owned by this TObjectDynArray instance // (unless aOwnObjects was false in Create) function Add(Instance: TObject): integer; /// delete one element from the TObject dynamic array // - deleted TObject instance will be freed as expected (unless aOwnObjects // was defined as false in Create) procedure Delete(Index: integer); /// sort the dynamic array content according to a specified comparer procedure Sort(Compare: TDynArraySortCompare); /// delete all TObject instances, and release the memory // - is not to be called for most use, thanks to reference-counting memory // handling, but can be handy for quick release // - warning: won't release the instances if aOwnObjects was false in Create procedure Clear; /// ensure the internal list capacity is set to the current Count // - may be used to publish the associated dynamic array with the expected // final size, once IObjectDynArray is out of scope procedure Slice; /// returns the number of TObject instances available // - note that the length() of the associated dynamic array is used to store // the capacity of the list, so won't probably never match with this value function Count: integer; /// returns the internal array capacity of TObject instances available // - which is in fact the length() of the associated dynamic array function Capacity: integer; end; /// abstract class able to use hashing to find an object in O(1) speed // - all protected abstract methods shall be overridden and implemented // - use this class instead of a plain TDynArrayHashed, since it would // feature its own dedicated hashing, and any abstract mean of value storage TObjectHash = class protected fHashs: TSynHashDynArray; procedure HashInit(aCountToHash: integer); function HashFind(aHashCode: cardinal; Item: TObject): integer; /// abstract method to hash an item // - note that the overridden method shall not return 0 (mark void fHashs[]) function Hash(Item: TObject): cardinal; virtual; abstract; /// abstract method to compare two items function Compare(Item1,Item2: TObject): boolean; virtual; abstract; /// abstract method to get an item // - shall return nil if Index is out of range (e.g. >= Count) // - will be called e.g. by Find() with Compare() to avoid collision function Get(Index: integer): TObject; virtual; abstract; /// used to retrieve the number of items function Count: integer; virtual; abstract; public /// search one item in the internal hash array function Find(Item: TObject): integer; /// search one item using slow list browsing // - this version expects the internal list count to be supplied, if some // last items are to be ignored (used e.g. in EnsureJustAddedNotDuplicated) function Scan(Item: TObject; ListCount: integer): integer; virtual; /// to be called when an item is modified // - for Delete/Update will force a full rehash on next Find() call procedure Invalidate; /// to be called when an item has just been added // - the index of the latest added item should be Count-1 // - this method will update the internal hash table, and check if // the newly added value is not duplicated // - return FALSE if this item is already existing (i.e. insert error) // - return TRUE if has been added to the internal hash table function EnsureJustAddedNotDuplicated: boolean; end; /// abstract parent class with a virtual constructor, ready to be overridden // to initialize the instance // - you can specify such a class if you need an object including published // properties (like TPersistent) with a virtual constructor (e.g. to // initialize some nested class properties) TPersistentWithCustomCreate = class(TPersistent) public /// this virtual constructor will be called at instance creation // - this constructor does nothing, but is declared as virtual so that // inherited classes may safely override this default void implementation constructor Create; virtual; end; {$M+} /// abstract parent class with threadsafe implementation of IInterface and // a virtual constructor // - you can specify e.g. such a class to TSQLRestServer.ServiceRegister() if // you need an interfaced object with a virtual constructor, ready to be // overridden to initialize the instance TInterfacedObjectWithCustomCreate = class(TInterfacedObject) public /// this virtual constructor will be called at instance creation // - this constructor does nothing, but is declared as virtual so that // inherited classes may safely override this default void implementation constructor Create; virtual; /// used to mimic TInterfacedObject reference counting // - Release=true will call TInterfacedObject._Release // - Release=false will call TInterfacedObject._AddRef // - could be used to emulate proper reference counting of the instance // via interfaces variables, but still storing plain class instances // (e.g. in a global list of instances) procedure RefCountUpdate(Release: boolean); virtual; end; /// our own empowered TPersistent-like parent class // - TPersistent has an unexpected speed overhead due a giant lock introduced // to manage property name fixup resolution (which we won't use outside the VCL) // - this class has a virtual constructor, so is a preferred alternative // to both TPersistent and TPersistentWithCustomCreate classes // - for best performance, any type inheriting from this class will bypass // some regular steps: do not implement interfaces or use TMonitor with them! TSynPersistent = class(TObject) protected // this default implementation will call AssignError() procedure AssignTo(Dest: TSynPersistent); virtual; procedure AssignError(Source: TSynPersistent); public /// this virtual constructor will be called at instance creation // - this constructor does nothing, but is declared as virtual so that // inherited classes may safely override this default void implementation constructor Create; virtual; /// allows to implement a TPersistent-like assignement mechanism // - inherited class should override AssignTo() protected method // to implement the proper assignment procedure Assign(Source: TSynPersistent); virtual; /// optimized x86 asm initialization code // - warning: this optimized version won't initialize the vmtIntfTable // for this class hierarchy: as a result, you would NOT be able to // implement an interface with a TSynPersistent descendent (but you should // not need to, but inherit from TInterfacedObject) // - warning: under FPC, it won't initialize fields management operators class function NewInstance: TObject; override; {$ifndef FPC_OR_PUREPASCAL} /// optimized x86 asm finalization code // - warning: this version won't release either any allocated TMonitor // (as available since Delphi 2009) - do not use TMonitor with // TSynPersistent, but rather the faster TSynPersistentLock class procedure FreeInstance; override; {$endif} end; {$M-} /// allow to add cross-platform locking methods to any class instance // - typical use is to define a Safe: TSynLocker property, call Safe.Init // and Safe.Done in constructor/destructor methods, and use Safe.Lock/UnLock // methods in a try ... finally section // - in respect to the TCriticalSection class, fix a potential CPU cache line // conflict which may degrade the multi-threading performance, as reported by // @http://www.delphitools.info/2011/11/30/fixing-tcriticalsection // - internal padding is used to safely store up to 7 values protected // from concurrent access with a mutex // - for object-level locking, see TSynPersistentLock which owns one such // instance, or call low-level NewSynLocker function then DoneAndFreemem {$ifdef FPC_OR_UNICODE}TSynLocker = record private {$else}TSynLocker = object protected{$endif} fSection: TRTLCriticalSection; fSectionPadding: PtrInt; // paranoid to avoid FUTEX_WAKE_PRIVATE=EAGAIN fLocked, fInitialized: boolean; {$ifndef NOVARIANTS} function GetVariant(Index: integer): Variant; procedure SetVariant(Index: integer; const Value: Variant); function GetInt64(Index: integer): Int64; procedure SetInt64(Index: integer; const Value: Int64); function GetBool(Index: integer): boolean; procedure SetBool(Index: integer; const Value: boolean); function GetUnlockedInt64(Index: integer): Int64; procedure SetUnlockedInt64(Index: integer; const Value: Int64); function GetPointer(Index: integer): Pointer; procedure SetPointer(Index: integer; const Value: Pointer); function GetUTF8(Index: integer): RawUTF8; procedure SetUTF8(Index: integer; const Value: RawUTF8); {$endif} public /// internal padding data, also used to store up to 7 variant values // - this memory buffer will ensure no CPU cache line mixup occurs // - you should not use this field directly, but rather the Locked[], // LockedInt64[], LockedUTF8[] or LockedPointer[] methods // - if you want to access those array values, ensure you protect them // using a Safe.Lock; try ... Padding[n] ... finally Safe.Unlock structure, // and maintain the PaddingMaxUsedIndex field accurately Padding: array[0..6] of TVarData; /// maximum index of the last value stored in the internal Padding[] array // - equals -1 if no value is actually stored, or a 0..6 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 PaddingMaxUsedIndex: integer; /// initialize the mutex // - calling this method is mandatory (e.g. in the class constructor owning // the TSynLocker instance), otherwise you may encounter unexpected // behavior, like access violations or memory leaks procedure Init; /// finalize the mutex // - calling this method is mandatory (e.g. in the class destructor owning // the TSynLocker instance), otherwise you may encounter unexpected // behavior, like access violations or memory leaks procedure Done; /// finalize the mutex, and call FreeMem() on the pointer of this instance // - should have been initiazed with a NewSynLocker call procedure DoneAndFreeMem; /// lock the instance for exclusive access // - use as such to avoid race condition (from a Safe: TSynLocker property): // ! Safe.Lock; // ! try // ! ... // ! finally // ! Safe.Unlock; // ! end; procedure Lock; {$ifdef HASINLINE}inline;{$endif} /// will try to acquire the mutex // - use as such to avoid race condition (from a Safe: TSynLocker property): // ! if Safe.TryLock then // ! try // ! ... // ! finally // ! Safe.Unlock; // ! end; function TryLock: boolean; {$ifdef HASINLINE}inline;{$endif} /// will try to acquire the mutex for a given time // - use as such to avoid race condition (from a Safe: TSynLocker property): // ! if Safe.TryLockMS(100) then // ! try // ! ... // ! finally // ! Safe.Unlock; // ! end; function TryLockMS(retryms: integer): boolean; /// release the instance for exclusive access procedure UnLock; {$ifdef HASINLINE}inline;{$endif} /// will enter the mutex until the IUnknown reference is released // - could be used as such under Delphi: // !begin // ! ... // unsafe code // ! Safe.ProtectMethod; // ! ... // thread-safe code // !end; // local hidden IUnknown will release the lock for the method // - warning: under FPC, you should assign its result to a local variable - // see bug http://bugs.freepascal.org/view.php?id=26602 // !var LockFPC: IUnknown; // !begin // ! ... // unsafe code // ! LockFPC := Safe.ProtectMethod; // ! ... // thread-safe code // !end; // LockFPC will release the lock for the method // or // !begin // ! ... // unsafe code // ! with Safe.ProtectMethod do begin // ! ... // thread-safe code // ! end; // local hidden IUnknown will release the lock for the method // !end; function ProtectMethod: IUnknown; /// returns true if the mutex is currently locked by another thread property IsLocked: boolean read fLocked; /// 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, but may not be accurate when allocated on stack property IsInitialized: boolean read fInitialized; {$ifndef NOVARIANTS} /// safe locked access to a Variant value // - you may store up to 7 variables, using an 0..6 index, shared with // LockedBool, LockedInt64, LockedPointer and LockedUTF8 array properties // - returns null if the Index is out of range property Locked[Index: integer]: Variant read GetVariant write SetVariant; /// safe locked access to a Int64 value // - you may store up to 7 variables, using an 0..6 index, shared with // Locked and LockedUTF8 array properties // - Int64s will be stored internally as a varInt64 variant // - returns nil if the Index is out of range, or does not store a Int64 property LockedInt64[Index: integer]: Int64 read GetInt64 write SetInt64; /// safe locked access to a boolean value // - you may store up to 7 variables, using an 0..6 index, shared with // Locked, LockedInt64, LockedPointer and LockedUTF8 array properties // - value will be stored internally as a varBoolean variant // - returns nil if the Index is out of range, or does not store a boolean property LockedBool[Index: integer]: boolean read GetBool write SetBool; /// safe locked access to a pointer/TObject value // - you may store up to 7 variables, using an 0..6 index, shared with // Locked, LockedBool, LockedInt64 and LockedUTF8 array properties // - pointers will be stored internally as a varUnknown variant // - returns nil if the Index is out of range, or does not store a pointer property LockedPointer[Index: integer]: Pointer read GetPointer write SetPointer; /// safe locked access to an UTF-8 string value // - you may store up to 7 variables, using an 0..6 index, shared with // Locked and LockedPointer array properties // - UTF-8 string will be stored internally as a varString variant // - returns '' if the Index is out of range, or does not store a string property LockedUTF8[Index: integer]: RawUTF8 read GetUTF8 write SetUTF8; /// safe locked in-place increment to an Int64 value // - you may store up to 7 variables, using an 0..6 index, shared with // Locked and LockedUTF8 array properties // - Int64s will be stored internally as a varInt64 variant // - returns the newly stored value // - if the internal value is not defined yet, would use 0 as default value function LockedInt64Increment(Index: integer; const Increment: Int64): Int64; /// safe locked in-place exchange of a Variant value // - you may store up to 7 variables, using an 0..6 index, shared with // Locked and LockedUTF8 array properties // - returns the previous stored value, or null if the Index is out of range function LockedExchange(Index: integer; const Value: variant): variant; /// safe locked in-place exchange of a pointer/TObject value // - you may store up to 7 variables, using an 0..6 index, shared with // Locked and LockedUTF8 array properties // - pointers will be stored internally as a varUnknown variant // - returns the previous stored value, nil if the Index is out of range, // or does not store a pointer function LockedPointerExchange(Index: integer; Value: pointer): pointer; /// unsafe access to a Int64 value // - you may store up to 7 variables, using an 0..6 index, shared with // Locked and LockedUTF8 array properties // - Int64s will be stored internally as a varInt64 variant // - returns nil if the Index is out of range, or does not store a Int64 // - you should rather call LockedInt64[] property, or use this property // with a Lock; try ... finally UnLock block property UnlockedInt64[Index: integer]: Int64 read GetUnlockedInt64 write SetUnlockedInt64; {$endif NOVARIANTS} end; PSynLocker = ^TSynLocker; /// adding locking methods to a TSynPersistent with virtual constructor // - you may use this class instead of the RTL TCriticalSection, since it // would use a TSynLocker which does not suffer from CPU cache line conflit TSynPersistentLock = class(TSynPersistent) protected fSafe: PSynLocker; // TSynLocker would increase inherited fields offset public /// initialize the instance, and its associated lock constructor Create; override; /// finalize the instance, and its associated lock destructor Destroy; override; /// access to the associated instance critical section // - call Safe.Lock/UnLock to protect multi-thread access on this storage property Safe: PSynLocker read fSafe; end; /// used for backward compatibility only with existing code TSynPersistentLocked = class(TSynPersistentLock); /// adding locking methods to a TInterfacedObject with virtual constructor TInterfacedObjectLocked = class(TInterfacedObjectWithCustomCreate) protected fSafe: PSynLocker; // TSynLocker would increase inherited fields offset public /// initialize the object instance, and its associated lock constructor Create; override; /// release the instance (including the locking resource) destructor Destroy; override; /// access to the locking methods of this instance // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block property Safe: PSynLocker read fSafe; end; /// used to determine the exact class type of a TInterfacedObjectWithCustomCreate // - could be used to create instances using its virtual constructor TInterfacedObjectWithCustomCreateClass = class of TInterfacedObjectWithCustomCreate; /// used to determine the exact class type of a TPersistentWithCustomCreateClass // - could be used to create instances using its virtual constructor TPersistentWithCustomCreateClass = class of TPersistentWithCustomCreate; /// used to determine the exact class type of a TSynPersistent // - could be used to create instances using its virtual constructor TSynPersistentClass = class of TSynPersistent; /// used to store one list of hashed RawUTF8 in TRawUTF8Interning pool {$ifdef FPC_OR_UNICODE}TRawUTF8InterningSlot = record{$else}TRawUTF8InterningSlot = object{$endif} public /// actual RawUTF8 storage Value: TRawUTF8DynArray; /// hashed access to the Value[] list Values: TDynArrayHashed; /// associated mutex for thread-safe process Safe: TSynLocker; /// initialize the RawUTF8 slot (and its Safe mutex) procedure Init; /// finalize the RawUTF8 slot procedure Done; /// returns the interned RawUTF8 value procedure Unique(var aResult: RawUTF8; const aText: RawUTF8; aTextHash: cardinal); /// ensure the supplied RawUTF8 value is interned procedure UniqueText(var aText: RawUTF8; aTextHash: cardinal); /// delete all stored RawUTF8 values procedure Clear; /// reclaim any unique RawUTF8 values function Clean(aMaxRefCount: integer): integer; /// how many items are currently stored in Value[] function Count: integer; end; /// allow to store only one copy of distinct RawUTF8 values // - thanks to the Copy-On-Write feature of string variables, this may // reduce a lot the memory overhead of duplicated text content // - this class is thread-safe and optimized for performance TRawUTF8Interning = class(TSynPersistent) protected fPool: array of TRawUTF8InterningSlot; fPoolLast: integer; public /// initialize the storage and its internal hash pools // - aHashTables is the pool size, and should be a power of two <= 512 constructor Create(aHashTables: integer=4); reintroduce; /// finalize the storage destructor Destroy; override; /// return a RawUTF8 variable stored within this class // - if aText occurs for the first time, add it to the internal string pool // - if aText does exist in the internal string pool, return the shared // instance (with its reference counter increased), to reduce memory usage function Unique(const aText: RawUTF8): RawUTF8; overload; /// return a RawUTF8 variable stored within this class from a text buffer // - if aText occurs for the first time, add it to the internal string pool // - if aText does exist in the internal string pool, return the shared // instance (with its reference counter increased), to reduce memory usage function Unique(aText: PUTF8Char; aTextLen: integer): RawUTF8; overload; /// return a RawUTF8 variable stored within this class // - if aText occurs for the first time, add it to the internal string pool // - if aText does exist in the internal string pool, return the shared // instance (with its reference counter increased), to reduce memory usage procedure Unique(var aResult: RawUTF8; const aText: RawUTF8); overload; /// return a RawUTF8 variable stored within this class from a text buffer // - if aText occurs for the first time, add it to the internal string pool // - if aText does exist in the internal string pool, return the shared // instance (with its reference counter increased), to reduce memory usage procedure Unique(var aResult: RawUTF8; aText: PUTF8Char; aTextLen: integer); overload; {$ifdef HASINLINE}inline;{$endif} /// ensure a RawUTF8 variable is stored within this class // - if aText occurs for the first time, add it to the internal string pool // - if aText does exist in the internal string pool, set the shared // instance (with its reference counter increased), to reduce memory usage procedure UniqueText(var aText: RawUTF8); {$ifndef NOVARIANTS} /// return a variant containing a RawUTF8 stored within this class // - similar to RawUTF8ToVariant(), but with string interning procedure UniqueVariant(var aResult: variant; const aText: RawUTF8); overload; {$ifdef HASINLINE}inline;{$endif} /// return a variant containing a RawUTF8 stored within this class // - similar to RawUTF8ToVariant(StringToUTF8()), but with string interning // - this method expects the text to be supplied as a VCL string, which will // be converted into a variant containing a RawUTF8 varString instance procedure UniqueVariantString(var aResult: variant; const aText: string); /// return a variant, may be containing a RawUTF8 stored within this class // - similar to TextToVariant(), but with string interning // - first try with GetNumericVariantFromJSON(), then fallback to // RawUTF8ToVariant() with string variable interning procedure UniqueVariant(var aResult: variant; aText: PUTF8Char; aTextLen: integer; aAllowVarDouble: boolean=false); overload; /// ensure a variant contains only RawUTF8 stored within this class // - supplied variant should be a varString containing a RawUTF8 value procedure UniqueVariant(var aResult: variant); overload; {$ifdef HASINLINE}inline;{$endif} {$endif NOVARIANTS} /// delete any previous storage pool procedure Clear; /// reclaim any unique RawUTF8 values // - i.e. run a garbage collection process of all values with RefCount=1 // by default, i.e. all string which are not used any more; you may set // aMaxRefCount to a higher value, depending on your expecations, i.e. 2 to // delete all string which are referenced only once outside of the pool // - returns the number of unique RawUTF8 cleaned from the internal pool // - to be executed on a regular basis - but not too often, since the // process can be time consumming, and void the benefit of interning function Clean(aMaxRefCount: integer=1): integer; /// how many items are currently stored in this instance function Count: integer; end; /// store one Name/Value pair, as used by TSynNameValue class TSynNameValueItem = record /// the name of the Name/Value pair // - this property is hashed by TSynNameValue for fast retrieval Name: RawUTF8; /// the value of the Name/Value pair Value: RawUTF8; /// any associated Pointer or numerical value Tag: PtrInt; end; /// Name/Value pairs storage, as used by TSynNameValue class TSynNameValueItemDynArray = array of TSynNameValueItem; /// event handler used to convert on the fly some UTF-8 text content TConvertRawUTF8 = function(const text: RawUTF8): RawUTF8 of object; /// callback event used by TSynNameValue TSynNameValueNotify = procedure(const Item: TSynNameValueItem; Index: PtrInt) of object; /// pseudo-class used to store Name/Value RawUTF8 pairs // - use internaly a TDynArrayHashed instance for fast retrieval // - is therefore faster than TRawUTF8List // - is defined as an object, not as a class: you can use this in any // class, without the need to destroy the content // - is defined either as an object either as a record, due to a bug // in Delphi 2009/2010 compiler (at least): this structure is not initialized // if defined as an object on the stack, but will be as a record :( {$ifdef FPC_OR_UNICODE}TSynNameValue = record private {$else}TSynNameValue = object protected{$endif} fDynArray: TDynArrayHashed; fOnAdd: TSynNameValueNotify; function GetBlobData: RawByteString; procedure SetBlobData(const aValue: RawByteString); function GetStr(const aName: RawUTF8): RawUTF8; {$ifdef HASINLINE}inline;{$endif} function GetInt(const aName: RawUTF8): Int64; {$ifdef HASINLINE}inline;{$endif} function GetBool(const aName: RawUTF8): Boolean; {$ifdef HASINLINE}inline;{$endif} public /// the internal Name/Value storage List: TSynNameValueItemDynArray; /// the number of Name/Value pairs Count: integer; /// initialize the storage // - will also reset the internal List[] and the internal hash array procedure Init(aCaseSensitive: boolean); /// add an element to the array // - if aName already exists, its associated Value will be updated procedure Add(const aName, aValue: RawUTF8; aTag: PtrInt=0); /// reset content, then add all name=value pairs from a supplied .ini file // section content // - will first call Init(false) to initialize the internal array // - Section can be retrieved e.g. via FindSectionFirstLine() procedure InitFromIniSection(Section: PUTF8Char; OnTheFlyConvert: TConvertRawUTF8=nil; OnAdd: TSynNameValueNotify=nil); /// reset content, then add all name=value; CSV pairs // - will first call Init(false) to initialize the internal array // - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled procedure InitFromCSV(CSV: PUTF8Char; NameValueSep: AnsiChar='='; ItemSep: AnsiChar=#10); /// reset content, then add all fields from an JSON object // - will first call Init() to initialize the internal array // - then parse the incoming JSON object, storing all its field values // as RawUTF8, and returning TRUE if the supplied content is correct // - warning: the supplied JSON buffer will be decoded and modified in-place function InitFromJSON(JSON: PUTF8Char; aCaseSensitive: boolean=false): boolean; /// reset content, then add all name, value pairs // - will first call Init(false) to initialize the internal array procedure InitFromNamesValues(const Names, Values: array of RawUTF8); /// search for a Name, return the index in List // - using fast O(1) hash algoritm function Find(const aName: RawUTF8): integer; /// search for the first chars of a Name, return the index in List // - using O(n) calls of IdemPChar() function // - here aUpperName should be already uppercase, as expected by IdemPChar() function FindStart(const aUpperName: RawUTF8): integer; /// search for a Value, return the index in List // - using O(n) brute force algoritm with case-sensitive aValue search function FindByValue(const aValue: RawUTF8): integer; /// search for a Name, and delete its entry in the List if it exists function Delete(const aName: RawUTF8): boolean; /// search for a Value, and delete its entry in the List if it exists // - returns the number of deleted entries // - you may search for more than one match, by setting a >1 Limit value function DeleteByValue(const aValue: RawUTF8; Limit: integer=1): integer; /// search for a Name, return the associated Value as a UTF-8 string function Value(const aName: RawUTF8; const aDefaultValue: RawUTF8=''): RawUTF8; /// search for a Name, return the associated Value as integer function ValueInt(const aName: RawUTF8; const aDefaultValue: Int64=0): Int64; /// search for a Name, return the associated Value as boolean // - returns true only if the value is exactly '1' function ValueBool(const aName: RawUTF8): Boolean; /// search for a Name, return the associated Value as an enumerate // - returns true and set aEnum if aName was found, and associated value // matched an aEnumTypeInfo item // - returns false if no match was found function ValueEnum(const aName: RawUTF8; aEnumTypeInfo: pointer; out aEnum; aEnumDefault: byte=0): boolean; overload; /// returns all values, as CSV or INI content function AsCSV(const KeySeparator: RawUTF8='='; const ValueSeparator: RawUTF8=#13#10; const IgnoreKey: RawUTF8=''): RawUTF8; /// returns all values as a JSON object of string fields function AsJSON: RawUTF8; /// fill the supplied two arrays of RawUTF8 with the stored values procedure AsNameValues(out Names,Values: TRawUTF8DynArray); {$ifndef NOVARIANTS} /// search for a Name, return the associated Value as variant // - returns null if the name was not found function ValueVariantOrNull(const aName: RawUTF8): variant; /// compute a TDocVariant document from the stored values // - output variant will be reset and filled as a TDocVariant instance, // ready to be serialized as a JSON object // - if there is no value stored (i.e. Count=0), set null procedure AsDocVariant(out DocVariant: variant; ExtendedJson: boolean=false; ValueAsString: boolean=true; AllowVarDouble: boolean=false); overload; /// compute a TDocVariant document from the stored values function AsDocVariant(ExtendedJson: boolean=false; ValueAsString: boolean=true): variant; overload; {$ifdef HASINLINE}inline;{$endif} /// merge the stored values into a TDocVariant document // - existing properties would be updated, then new values will be added to // the supplied TDocVariant instance, ready to be serialized as a JSON object // - if ValueAsString is TRUE, values would be stored as string // - if ValueAsString is FALSE, numerical values would be identified by // IsString() and stored as such in the resulting TDocVariant // - if you let ChangedProps point to a TDocVariantData, it would contain // an object with the stored values, just like AsDocVariant // - returns the number of updated values in the TDocVariant, 0 if // no value was changed function MergeDocVariant(var DocVariant: variant; ValueAsString: boolean; ChangedProps: PVariant=nil; ExtendedJson: boolean=false; AllowVarDouble: boolean=false): integer; {$endif} /// returns true if the Init() method has been called function Initialized: boolean; /// can be used to set all data from one BLOB memory buffer procedure SetBlobDataPtr(aValue: pointer); /// can be used to set or retrieve all stored data as one BLOB content property BlobData: RawByteString read GetBlobData write SetBlobData; /// event triggerred after an item has just been added to the list property OnAfterAdd: TSynNameValueNotify read fOnAdd write fOnAdd; /// search for a Name, return the associated Value as a UTF-8 string // - returns '' if aName is not found in the stored keys property Str[const aName: RawUTF8]: RawUTF8 read GetStr; default; /// search for a Name, return the associated Value as integer // - returns 0 if aName is not found, or not a valid Int64 in the stored keys property Int[const aName: RawUTF8]: Int64 read GetInt; /// search for a Name, return the associated Value as boolean // - returns true if aName stores '1' as associated value property Bool[const aName: RawUTF8]: Boolean read GetBool; end; /// a reference pointer to a Name/Value RawUTF8 pairs storage PSynNameValue = ^TSynNameValue; /// allocate and initialize a TSynLocker instance // - caller should call result^.DoneAndFreemem when not used any more function NewSynLocker: PSynLocker; {$ifdef HASINLINE}inline;{$endif} /// wrapper to add an item to a array of pointer dynamic array storage function PtrArrayAdd(var aPtrArray; aItem: pointer): integer; {$ifdef HASINLINE}inline;{$endif} /// wrapper to add once an item to a array of pointer dynamic array storage function PtrArrayAddOnce(var aPtrArray; aItem: pointer): integer; /// wrapper to delete an item from a array of pointer dynamic array storage function PtrArrayDelete(var aPtrArray; aItem: pointer): integer; overload; /// wrapper to find an item to a array of pointer dynamic array storage function PtrArrayFind(var aPtrArray; aItem: pointer): integer; {$ifdef HASINLINE}inline;{$endif} /// wrapper to add an item to a T*ObjArray dynamic array storage // - as expected by TJSONSerializer.RegisterObjArrayForJSON() // - could be used as such (note the T*ObjArray type naming convention): // ! TUserObjArray = array of TUser; // ! ... // ! var arr: TUserObjArray; // ! user: TUser; // ! .. // ! try // ! user := TUser.Create; // ! user.Name := 'Name'; // ! index := ObjArrayAdd(arr,user); // ! ... // ! finally // ! ObjArrayClear(arr); // release all items // ! end; // - return the index of the item in the dynamic array function ObjArrayAdd(var aObjArray; aItem: TObject): PtrInt; {$ifdef HASINLINE}inline;{$endif} /// wrapper to add items to a T*ObjArray dynamic array storage // - aSourceObjArray[] items will be owned by aDestObjArray[], therefore // aSourceObjArray is set to nil // - return the new number of the items in aDestObjArray function ObjArrayAppend(var aDestObjArray, aSourceObjArray): PtrInt; /// wrapper to add an item to a T*ObjArray dynamic array storage // - this overloaded function will use a separated variable to store the items // count, so will be slightly faster: but you should call SetLength() when done, // to have an array as expected by TJSONSerializer.RegisterObjArrayForJSON() // - return the index of the item in the dynamic array function ObjArrayAddCount(var aObjArray; aItem: TObject; var aObjArrayCount: integer): PtrInt; /// wrapper to add once an item to a T*ObjArray dynamic array storage // - as expected by TJSONSerializer.RegisterObjArrayForJSON() // - if the object is already in the array (searching by address/reference, // not by content), return its current index in the dynamic array // - if the object does not appear in the array, add it at the end procedure ObjArrayAddOnce(var aObjArray; aItem: TObject); /// wrapper to set the length of a T*ObjArray dynamic array storage // - could be used as an alternative to SetLength() when you do not // know the exact T*ObjArray type procedure ObjArraySetLength(var aObjArray; aLength: integer); {$ifdef HASINLINE}inline;{$endif} /// wrapper to search an item in a T*ObjArray dynamic array storage // - as expected by TJSONSerializer.RegisterObjArrayForJSON() // - search is performed by address/reference, not by content // - returns -1 if the item is not found in the dynamic array function ObjArrayFind(const aObjArray; aItem: TObject): PtrInt; {$ifdef HASINLINE}inline;{$endif} /// wrapper to count all not nil items in a T*ObjArray dynamic array storage // - as expected by TJSONSerializer.RegisterObjArrayForJSON() function ObjArrayCount(const aObjArray): integer; /// wrapper to delete an item in a T*ObjArray dynamic array storage // - as expected by TJSONSerializer.RegisterObjArrayForJSON() // - do nothing if the index is out of range in the dynamic array procedure ObjArrayDelete(var aObjArray; aItemIndex: PtrInt; aContinueOnException: boolean=false); overload; /// wrapper to delete an item in a T*ObjArray dynamic array storage // - as expected by TJSONSerializer.RegisterObjArrayForJSON() // - search is performed by address/reference, not by content // - do nothing if the item is not found in the dynamic array function ObjArrayDelete(var aObjArray; aItem: TObject): PtrInt; overload; /// wrapper to sort the items stored in a T*ObjArray dynamic array // - as expected by TJSONSerializer.RegisterObjArrayForJSON() procedure ObjArraySort(var aObjArray; Compare: TDynArraySortCompare); /// wrapper to release all items stored in a T*ObjArray dynamic array // - as expected by TJSONSerializer.RegisterObjArrayForJSON() // - you should always use ObjArrayClear() before the array storage is released, // e.g. in the owner class destructor // - will also set the dynamic array length to 0, so could be used to re-use // an existing T*ObjArray procedure ObjArrayClear(var aObjArray); overload; /// wrapper to release all items stored in a T*ObjArray dynamic array // - this overloaded function will use the supplied array length as parameter // - you should always use ObjArrayClear() before the array storage is released, // e.g. in the owner class destructor // - will also set the dynamic array length to 0, so could be used to re-use // an existing T*ObjArray procedure ObjArrayClear(var aObjArray; aCount: integer); overload; /// wrapper to release all items stored in a T*ObjArray dynamic array // - as expected by TJSONSerializer.RegisterObjArrayForJSON() // - you should always use ObjArrayClear() before the array storage is released, // e.g. in the owner class destructor // - will also set the dynamic array length to 0, so could be used to re-use // an existing T*ObjArray procedure ObjArrayClear(var aObjArray; aContinueOnException: boolean); overload; /// wrapper to release all items stored in an array of T*ObjArray dynamic array // - e.g. aObjArray may be defined as "array of array of TSynFilter" procedure ObjArrayObjArrayClear(var aObjArray); /// wrapper to release all items stored in several T*ObjArray dynamic arrays // - as expected by TJSONSerializer.RegisterObjArrayForJSON() procedure ObjArraysClear(const aObjArray: array of pointer); {$ifndef DELPHI5OROLDER} /// wrapper to add an item to a T*InterfaceArray dynamic array storage function InterfaceArrayAdd(var aInterfaceArray; const aItem: IUnknown): PtrInt; /// wrapper to add once an item to a T*InterfaceArray dynamic array storage procedure InterfaceArrayAddOnce(var aInterfaceArray; const aItem: IUnknown); /// wrapper to search an item in a T*InterfaceArray dynamic array storage // - search is performed by address/reference, not by content // - return -1 if the item is not found in the dynamic array, or the index of // the matching entry otherwise function InterfaceArrayFind(const aInterfaceArray; const aItem: IUnknown): PtrInt; {$ifdef HASINLINE}inline;{$endif} /// wrapper to delete an item in a T*InterfaceArray dynamic array storage // - search is performed by address/reference, not by content // - do nothing if the item is not found in the dynamic array function InterfaceArrayDelete(var aInterfaceArray; const aItem: IUnknown): PtrInt; overload; /// wrapper to delete an item in a T*InterfaceArray dynamic array storage // - do nothing if the item is not found in the dynamic array procedure InterfaceArrayDelete(var aInterfaceArray; aItemIndex: PtrInt); overload; {$endif DELPHI5OROLDER} /// helper to retrieve the text of an enumerate item // - see also RTTI related classes of mORMot.pas unit, e.g. TEnumType function GetEnumName(aTypeInfo: pointer; aIndex: integer): PShortString; /// helper to retrieve all texts of an enumerate // - may be used as cache for overloaded ToText() content procedure GetEnumNames(aTypeInfo: pointer; aDest: PPShortString); /// helper to retrieve all trimmed texts of an enumerate // - may be used as cache to retrieve UTF-8 text without lowercase 'a'..'z' chars procedure GetEnumTrimmedNames(aTypeInfo: pointer; aDest: PRawUTF8); overload; /// helper to retrieve all trimmed texts of an enumerate as UTF-8 strings function GetEnumTrimmedNames(aTypeInfo: pointer): TRawUTF8DynArray; overload; /// helper to retrieve all (translated) caption texts of an enumerate // - may be used as cache for overloaded ToCaption() content procedure GetEnumCaptions(aTypeInfo: pointer; aDest: PString); /// UnCamelCase and translate the enumeration item function GetCaptionFromEnum(aTypeInfo: pointer; aIndex: integer): string; /// low-level helper to retrieve a (translated) caption from a PShortString // - as used e.g. by GetEnumCaptions or GetCaptionFromEnum procedure GetCaptionFromTrimmed(PS: PShortString; var result: string); /// helper to retrieve the index of an enumerate item from its text // - returns -1 if aValue was not found // - will search for the exact text and also trim the lowercase 'a'..'z' chars on // left side of the text if no exact match is found and AlsoTrimLowerCase is TRUE // - see also RTTI related classes of mORMot.pas unit, e.g. TEnumType function GetEnumNameValue(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: integer; AlsoTrimLowerCase: boolean=false): Integer; overload; /// retrieve the index of an enumerate item from its left-trimmed text // - will trim the lowercase 'a'..'z' chars on left side of the supplied aValue text // - returns -1 if aValue was not found function GetEnumNameValueTrimmed(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: integer): integer; /// helper to retrieve the index of an enumerate item from its text function GetEnumNameValue(aTypeInfo: pointer; const aValue: RawUTF8; AlsoTrimLowerCase: boolean=false): Integer; overload; /// helper to retrieve the bit mapped integer value of a set from its JSON text // - if supplied P^ is a JSON integer number, will read it directly // - if P^ maps some ["item1","item2"] content, would fill all matching bits // - if P^ contains ['*'], would fill all bits // - returns P=nil if reached prematurly the end of content, or returns // the value separator (e.g. , or }) in EndOfObject (like GetJsonField) function GetSetNameValue(aTypeInfo: pointer; var P: PUTF8Char; out EndOfObject: AnsiChar): cardinal; /// helper to retrieve the CSV text of all enumerate items defined in a set // - you'd better use RTTI related classes of mORMot.pas unit, e.g. TEnumType function GetSetName(aTypeInfo: pointer; const value): RawUTF8; /// helper to retrieve the CSV text of all enumerate items defined in a set // - you'd better use RTTI related classes of mORMot.pas unit, e.g. TEnumType procedure GetSetNameShort(aTypeInfo: pointer; const value; out result: ShortString; trimlowercase: boolean=false); /// fast append some UTF-8 text into a shortstring procedure AppendShortComma(text: PAnsiChar; len: integer; var result: shortstring; trimlowercase: boolean); /// fast search of an exact case-insensitive match of a RTTI's PShortString array function FindShortStringListExact(List: PShortString; MaxValue: integer; aValue: PUTF8Char; aValueLen: PtrInt): integer; /// fast search of an left-trimmed lowercase match of a RTTI's PShortString array function FindShortStringListTrimLowerCase(List: PShortString; MaxValue: integer; aValue: PUTF8Char; aValueLen: PtrInt): integer; /// retrieve the type name from its low-level RTTI function TypeInfoToName(aTypeInfo: pointer): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// retrieve the type name from its low-level RTTI procedure TypeInfoToName(aTypeInfo: pointer; var result: RawUTF8; const default: RawUTF8=''); overload; /// retrieve the unit name and type name from its low-level RTTI procedure TypeInfoToQualifiedName(aTypeInfo: pointer; var result: RawUTF8; const default: RawUTF8=''); /// compute a crc32c-based hash of the RTTI for a managed given type // - can be used to ensure that the RecordSave/TDynArray.SaveTo binary layout // is compatible accross executables, even between FPC and Delphi // - will ignore the type names, but will check the RTTI type kind and any // nested fields (for records or arrays) - for a record/object type, will use // TTextWriter.RegisterCustomJSONSerializerFromText definition, if available function TypeInfoToHash(aTypeInfo: pointer): cardinal; /// retrieve the record size from its low-level RTTI function RecordTypeInfoSize(aRecordTypeInfo: pointer): integer; /// retrieve the item type information of a dynamic array low-level RTTI function DynArrayTypeInfoToRecordInfo(aDynArrayTypeInfo: pointer; aDataSize: PInteger=nil): pointer; /// sort any dynamic array, via an external array of indexes // - this function will use the supplied TSynTempBuffer for index storage, // so use PIntegerArray(Indexes.buf) to access the values // - caller should always make Indexes.Done once done procedure DynArraySortIndexed(Values: pointer; ElemSize, Count: Integer; out Indexes: TSynTempBuffer; Compare: TDynArraySortCompare); /// compare two TGUID values // - this version is faster than the one supplied by SysUtils function IsEqualGUID({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid1, guid2: TGUID): Boolean; {$ifdef HASINLINE}inline;{$endif} /// returns the index of a matching TGUID in an array // - returns -1 if no item matched function IsEqualGUIDArray({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID; const guids: array of TGUID): integer; /// check if a TGUID value contains only 0 bytes // - this version is faster than the one supplied by SysUtils function IsNullGUID({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): Boolean; {$ifdef HASINLINE}inline;{$endif} /// append one TGUID item to a TGUID dynamic array // - returning the newly inserted index in guids[], or an existing index in // guids[] if NoDuplicates is TRUE and TGUID already exists function AddGUID(var guids: TGUIDDynArray; const guid: TGUID; NoDuplicates: boolean=false): integer; /// append a TGUID binary content as text // - will store e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without any {}) // - this will be the format used for JSON encoding, e.g. // $ { "UID": "C9A646D3-9C61-4CB7-BFCD-EE2522C8F633" } function GUIDToText(P: PUTF8Char; guid: PByteArray): PUTF8Char; /// convert a TGUID into UTF-8 encoded text // - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) // - if you do not need the embracing { }, use ToUTF8() overloaded function function GUIDToRawUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; /// convert a TGUID into text // - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) // - this version is faster than the one supplied by SysUtils function GUIDToString({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): string; type /// low-level object implementing a 32-bit Pierre L'Ecuyer software generator // - as used by RandomGsl function, and Random32 if no RDRAND hardware is available // - is not thread-safe, but cross-compiler and cross-platform, still very // fast with a much better distribution than Delphi system's Random() function {$ifdef FPC_OR_UNICODE}TLecuyer = record{$else}TLecuyer = object{$endif} public rs1, rs2, rs3, seedcount: cardinal; /// force an immediate seed of the generator from current system state // - should be called before any call to the Next method procedure Seed(entropy: PByteArray; entropylen: PtrInt); /// compute the next 32-bit generated value // - will automatically reseed after around 65,000 generated values function Next: cardinal; overload; /// compute the next 32-bit generated value, in range [0..max-1] // - will automatically reseed after around 65,000 generated values function Next(max: cardinal): cardinal; overload; end; /// fast compute of some 32-bit random value // - will use (slow but) hardware-derivated RDRAND Intel x86/x64 opcode if // available, or fast gsl_rng_taus2 generator by Pierre L'Ecuyer (which period // is 2^88, i.e. about 10^26) if the CPU doesn't support it // - use rather TAESPRNG.Main.FillRandom() for cryptographic-level randomness // - thread-safe function: each thread will maintain its own gsl_rng_taus2 table function Random32: cardinal; overload; /// fast compute of some 32-bit random value, with a maximum (excluded) upper value // - i.e. returns a value in range [0..max-1] // - will use (slow but) hardware-derivated RDRAND Intel x86/x64 opcode if // available, or fast gsl_rng_taus2 generator by Pierre L'Ecuyer (which period // is 2^88, i.e. about 10^26) if the CPU doesn't support it // - use rather TAESPRNG.Main.FillRandom() for cryptographic-level randomness // - thread-safe function: each thread will maintain its own gsl_rng_taus2 table function Random32(max: cardinal): cardinal; overload; /// fast compute of some 32-bit random value, using the gsl_rng_taus2 generator // - plain Random32 may call RDRAND opcode on Intel CPUs, wherease this function // will use well documented (and proven) Pierre L'Ecuyer software generator // - may be used if you don't want/trust RDRAND, if you expect a well defined // cross-platform generator, or have higher performance expectations // - use rather TAESPRNG.Main.FillRandom() for cryptographic-level randomness // - thread-safe function: each thread will maintain its own gsl_rng_taus2 table function Random32gsl: cardinal; overload; /// fast compute of bounded 32-bit random value, using the gsl_rng_taus2 generator function Random32gsl(max: cardinal): cardinal; overload; /// seed the gsl_rng_taus2 Random32/Random32gsl generator // - this seeding won't affect RDRAND Intel x86/x64 opcode generation // - by default, gsl_rng_taus2 generator is re-seeded every 256KB, much more // often than the Pierre L'Ecuyer's algorithm period of 2^88 // - you can specify some additional entropy buffer; note that calling this // function with the same entropy again WON'T seed the generator with the same // sequence (as with RTL's RandomSeed function), but initiate a new one // - thread-specific function: each thread will maintain its own seed table procedure Random32Seed(entropy: pointer=nil; entropylen: integer=0); /// fill some memory buffer with random values // - the destination buffer is expected to be allocated as 32-bit items // - use internally crc32c() with some rough entropy source, and Random32 // gsl_rng_taus2 generator or hardware RDRAND Intel x86/x64 opcode if available // (and ForceGsl is kept to its default false value) // - consider using instead the cryptographic secure TAESPRNG.Main.FillRandom() // method from the SynCrypto unit - in particular, RDRAND could be slow // as reported by https://en.wikipedia.org/wiki/RdRand#Performance procedure FillRandom(Dest: PCardinalArray; CardinalCount: integer; ForceGsl: boolean=false); /// compute a random GUID value procedure RandomGUID(out result: TGUID); overload; {$ifdef HASINLINE}inline;{$endif} /// compute a random GUID value function RandomGUID: TGUID; overload; {$ifdef HASINLINE}inline;{$endif} /// fill a GUID with 0 procedure FillZero(var result: TGUID); overload; {$ifdef HASINLINE}inline;{$endif} type /// stack-allocated ASCII string, used by GUIDToShort() function TGUIDShortString = string[38]; const /// a TGUID containing '{00000000-0000-0000-0000-00000000000}' GUID_NULL: TGUID = (); /// convert a TGUID into text // - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) // - using a shortstring will allow fast allocation on the stack, so is // preferred e.g. when providing a GUID to a ESynException.CreateUTF8() function GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): TGUIDShortString; overload; {$ifdef HASINLINE}inline;{$endif} /// convert a TGUID into text // - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) // - using a shortstring will allow fast allocation on the stack, so is // preferred e.g. when providing a GUID to a ESynException.CreateUTF8() procedure GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID; out dest: TGUIDShortString); overload; /// convert some text into its TGUID binary value // - expect e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without any {}) // - return if the supplied text buffer is not a valid TGUID // - this will be the format used for JSON encoding, e.g. // $ { "UID": "C9A646D3-9C61-4CB7-BFCD-EE2522C8F633" } function TextToGUID(P: PUTF8Char; guid: PByteArray): PUTF8Char; /// convert some text into a TGUID // - expect e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) // - return {00000000-0000-0000-0000-000000000000} if the supplied text buffer // is not a valid TGUID function StringToGUID(const text: string): TGUID; /// convert some UTF-8 encoded text into a TGUID // - expect e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) // - return {00000000-0000-0000-0000-000000000000} if the supplied text buffer // is not a valid TGUID function RawUTF8ToGUID(const text: RawByteString): TGUID; /// check equality of two records by content // - will handle packed records, with binaries (byte, word, integer...) and // string types properties // - will use binary-level comparison: it could fail to match two floating-point // values because of rounding issues (Currency won't have this problem) function RecordEquals(const RecA, RecB; TypeInfo: pointer; PRecSize: PInteger=nil): boolean; /// save a record content into a RawByteString // - will handle packed records, with binaries (byte, word, integer...) and // string types properties (but not with internal raw pointers, of course) // - will use a proprietary binary format, with some variable-length encoding // of the string length - note that if you change the type definition, any // previously-serialized content will fail, maybe triggering unexpected GPF: you // may use TypeInfoToHash() if you share this binary data accross executables // - warning: will encode generic string fields as AnsiString (one byte per char) // prior to Delphi 2009, and as UnicodeString (two bytes per char) since Delphi // 2009: if you want to use this function between UNICODE and NOT UNICODE // versions of Delphi, you should use some explicit types like RawUTF8, // WinAnsiString, SynUnicode or even RawUnicode/WideString function RecordSave(const Rec; TypeInfo: pointer): RawByteString; overload; /// save a record content into a TBytes dynamic array // - could be used as an alternative to RawByteString's RecordSave() function RecordSaveBytes(const Rec; TypeInfo: pointer): TBytes; /// save a record content into a destination memory buffer // - Dest must be at least RecordSaveLength() bytes long // - will return the Rec size, in bytes, into Len reference variable // - will handle packed records, with binaries (byte, word, integer...) and // string types properties (but not with internal raw pointers, of course) // - will use a proprietary binary format, with some variable-length encoding // of the string length - note that if you change the type definition, any // previously-serialized content will fail, maybe triggering unexpected GPF: you // may use TypeInfoToHash() if you share this binary data accross executables // - warning: will encode generic string fields as AnsiString (one byte per char) // prior to Delphi 2009, and as UnicodeString (two bytes per char) since Delphi // 2009: if you want to use this function between UNICODE and NOT UNICODE // versions of Delphi, you should use some explicit types like RawUTF8, // WinAnsiString, SynUnicode or even RawUnicode/WideString function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer; out Len: integer): PAnsiChar; overload; /// save a record content into a destination memory buffer // - Dest must be at least RecordSaveLength() bytes long // - will handle packed records, with binaries (byte, word, integer...) and // string types properties (but not with internal raw pointers, of course) // - will use a proprietary binary format, with some variable-length encoding // of the string length - note that if you change the type definition, any // previously-serialized content will fail, maybe triggering unexpected GPF: you // may use TypeInfoToHash() if you share this binary data accross executables // - warning: will encode generic string fields as AnsiString (one byte per char) // prior to Delphi 2009, and as UnicodeString (two bytes per char) since Delphi // 2009: if you want to use this function between UNICODE and NOT UNICODE // versions of Delphi, you should use some explicit types like RawUTF8, // WinAnsiString, SynUnicode or even RawUnicode/WideString function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer): PAnsiChar; overload; {$ifdef HASINLINE}inline;{$endif} /// save a record content into a destination memory buffer // - caller should make Dest.Done once finished with Dest.buf/Dest.len buffer procedure RecordSave(const Rec; var Dest: TSynTempBuffer; TypeInfo: pointer); overload; /// save a record content into a Base-64 encoded UTF-8 text content // - will use RecordSave() format, with a left-sided binary CRC function RecordSaveBase64(const Rec; TypeInfo: pointer; UriCompatible: boolean=false): RawUTF8; /// compute the number of bytes needed to save a record content // using the RecordSave() function // - will return 0 in case of an invalid (not handled) record type (e.g. if // it contains an unknown variant) // - optional Len parameter will contain the Rec memory buffer length, in bytes function RecordSaveLength(const Rec; TypeInfo: pointer; Len: PInteger=nil): integer; /// save record into its JSON serialization as saved by TTextWriter.AddRecordJSON // - will use default Base64 encoding over RecordSave() binary - or custom true // JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via // enhanced RTTI), if available (following EnumSetsAsText optional parameter // for nested enumerates and sets) function RecordSaveJSON(const Rec; TypeInfo: pointer; EnumSetsAsText: boolean=false): RawUTF8; {$ifdef HASINLINE}inline;{$endif} /// fill a record content from a memory buffer as saved by RecordSave() // - return nil if the Source buffer is incorrect // - in case of success, return the memory buffer pointer just after the // read content, and set the Rec size, in bytes, into Len reference variable // - will use a proprietary binary format, with some variable-length encoding // of the string length - note that if you change the type definition, any // previously-serialized content will fail, maybe triggering unexpected GPF: you // may use TypeInfoToHash() if you share this binary data accross executables function RecordLoad(var Rec; Source: PAnsiChar; TypeInfo: pointer; Len: PInteger=nil): PAnsiChar; overload; /// fill a record content from a memory buffer as saved by RecordSave() // - returns false if the Source buffer was incorrect, true on success function RecordLoad(var Res; const Source: RawByteString; TypeInfo: pointer): boolean; overload; /// read a record content from a Base-64 encoded content // - expects RecordSaveBase64() format, with a left-sided binary CRC function RecordLoadBase64(Source: PAnsiChar; Len: integer; var Rec; TypeInfo: pointer; UriCompatible: boolean=false): boolean; /// fill a record content from a JSON serialization as saved by // TTextWriter.AddRecordJSON / RecordSaveJSON // - will use default Base64 encoding over RecordSave() binary - or custom true // JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via // enhanced RTTI), if available // - returns nil on error, or the end of buffer on success // - warning: the JSON buffer will be modified in-place during process - use // a temporary copy if you need to access it later, or the overloaded RecordLoadJSON() function RecordLoadJSON(var Rec; JSON: PUTF8Char; TypeInfo: pointer; EndOfObject: PUTF8Char=nil): PUTF8Char; overload; /// fill a record content from a JSON serialization as saved by // TTextWriter.AddRecordJSON / RecordSaveJSON // - will use default Base64 encoding over RecordSave() binary - or custom true // JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via // enhanced RTTI), if available function RecordLoadJSON(var Rec; const JSON: RawUTF8; TypeInfo: pointer): boolean; overload; /// copy a record content from source to Dest // - this unit includes a fast optimized asm version for x86 on Delphi procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); {$ifdef FPC}inline;{$endif} /// clear a record content // - this unit includes a fast optimized asm version for x86 on Delphi procedure RecordClear(var Dest; TypeInfo: pointer); {$ifdef FPC}inline;{$endif} {$ifndef DELPHI5OROLDER} /// copy a dynamic array content from source to Dest // - uses internally the TDynArray.CopyFrom() method and two temporary // TDynArray wrappers procedure DynArrayCopy(var Dest; const Source; SourceMaxElem: integer; TypeInfo: pointer); {$endif DELPHI5OROLDER} /// fill a dynamic array content from a binary serialization as saved by // DynArraySave() / TDynArray.Save() // - Value shall be set to the target dynamic array field // - just a function helper around TDynArray.Init + TDynArray.LoadFrom function DynArrayLoad(var Value; Source: PAnsiChar; TypeInfo: pointer): PAnsiChar; /// serialize a dynamic array content as binary, ready to be loaded by // DynArrayLoad() / TDynArray.Load() // - Value shall be set to the source dynamic arry field // - just a function helper around TDynArray.Init + TDynArray.SaveTo function DynArraySave(var Value; TypeInfo: pointer): RawByteString; /// fill a dynamic array content from a JSON serialization as saved by // TTextWriter.AddDynArrayJSON // - Value shall be set to the target dynamic array field // - is just a wrapper around TDynArray.LoadFromJSON(), creating a temporary // TDynArray wrapper on the stack // - return a pointer at the end of the data read from JSON, nil in case // of an invalid input buffer // - to be used e.g. for custom record JSON unserialization, within a // TDynArrayJSONCustomReader callback // - warning: the JSON buffer will be modified in-place during process - use // a temporary copy if you need to access it later function DynArrayLoadJSON(var Value; JSON: PUTF8Char; TypeInfo: pointer; EndOfObject: PUTF8Char=nil): PUTF8Char; /// serialize a dynamic array content as JSON // - Value shall be set to the source dynamic array field // - is just a wrapper around TTextWriter.AddDynArrayJSON(), creating // a temporary TDynArray wrapper on the stack // - to be used e.g. for custom record JSON serialization, within a // TDynArrayJSONCustomWriter callback or RegisterCustomJSONSerializerFromText() // (following EnumSetsAsText optional parameter for nested enumerates and sets) function DynArraySaveJSON(const Value; TypeInfo: pointer; EnumSetsAsText: boolean=false): RawUTF8; {$ifdef HASINLINE}inline;{$endif} {$ifndef DELPHI5OROLDER} /// compare two dynamic arrays by calling TDynArray.Equals function DynArrayEquals(TypeInfo: pointer; var Array1, Array2; Array1Count: PInteger=nil; Array2Count: PInteger=nil): boolean; {$endif DELPHI5OROLDER} /// serialize a dynamic array content, supplied as raw binary buffer, as JSON // - Value shall be set to the source dynamic array field // - is just a wrapper around TTextWriter.AddDynArrayJSON(), creating // a temporary TDynArray wrapper on the stack // - to be used e.g. for custom record JSON serialization, within a // TDynArrayJSONCustomWriter callback or RegisterCustomJSONSerializerFromText() function DynArrayBlobSaveJSON(TypeInfo, BlobValue: pointer): RawUTF8; /// compute a dynamic array element information // - will raise an exception if the supplied RTTI is not a dynamic array // - will return the element type name and set ElemTypeInfo otherwise // - if there is no element type information, an approximative element type name // will be returned (e.g. 'byte' for an array of 1 byte items), and ElemTypeInfo // will be set to nil // - this low-level function is used e.g. by mORMotWrappers unit function DynArrayElementTypeName(TypeInfo: pointer; ElemTypeInfo: PPointer=nil; ExactType: boolean=false): RawUTF8; /// trim ending 'DynArray' or 's' chars from a dynamic array type name // - used internally to guess the associated item type name function DynArrayItemTypeLen(const aDynArrayTypeName: RawUTF8): integer; /// compare two "array of boolean" elements function SortDynArrayBoolean(const A,B): integer; /// compare two "array of shortint" elements function SortDynArrayShortint(const A,B): integer; /// compare two "array of byte" elements function SortDynArrayByte(const A,B): integer; /// compare two "array of smallint" elements function SortDynArraySmallint(const A,B): integer; /// compare two "array of word" elements function SortDynArrayWord(const A,B): integer; /// compare two "array of integer" elements function SortDynArrayInteger(const A,B): integer; /// compare two "array of cardinal" elements function SortDynArrayCardinal(const A,B): integer; /// compare two "array of Int64" or "array of Currency" elements function SortDynArrayInt64(const A,B): integer; /// compare two "array of QWord" elements // - note that QWord(A)>QWord(B) is wrong on older versions of Delphi, so you // should better use this function or CompareQWord() to properly compare two // QWord values over CPUX86 function SortDynArrayQWord(const A,B): integer; /// compare two "array of THash128" elements function SortDynArray128(const A,B): integer; /// compare two "array of THash256" elements function SortDynArray256(const A,B): integer; /// compare two "array of THash512" elements function SortDynArray512(const A,B): integer; /// compare two "array of TObject/pointer" elements function SortDynArrayPointer(const A,B): integer; /// compare two "array of single" elements function SortDynArraySingle(const A,B): integer; /// compare two "array of double" elements function SortDynArrayDouble(const A,B): integer; /// compare two "array of AnsiString" elements, with case sensitivity function SortDynArrayAnsiString(const A,B): integer; /// compare two "array of RawByteString" elements, with case sensitivity // - can't use StrComp() or similar functions since RawByteString may contain #0 function SortDynArrayRawByteString(const A,B): integer; /// compare two "array of AnsiString" elements, with no case sensitivity function SortDynArrayAnsiStringI(const A,B): integer; /// compare two "array of PUTF8Char/PAnsiChar" elements, with case sensitivity function SortDynArrayPUTF8Char(const A,B): integer; /// compare two "array of PUTF8Char/PAnsiChar" elements, with no case sensitivity function SortDynArrayPUTF8CharI(const A,B): integer; /// compare two "array of WideString/UnicodeString" elements, with case sensitivity function SortDynArrayUnicodeString(const A,B): integer; /// compare two "array of WideString/UnicodeString" elements, with no case sensitivity function SortDynArrayUnicodeStringI(const A,B): integer; /// compare two "array of generic string" elements, with case sensitivity // - the expected string type is the generic VCL string function SortDynArrayString(const A,B): integer; /// compare two "array of generic string" elements, with no case sensitivity // - the expected string type is the generic VCL string function SortDynArrayStringI(const A,B): integer; /// compare two "array of TFileName" elements, as file names // - i.e. with no case sensitivity, and grouped by file extension // - the expected string type is the generic RTL string, i.e. TFileName // - calls internally GetFileNameWithoutExt() and AnsiCompareFileName() function SortDynArrayFileName(const A,B): integer; {$ifndef NOVARIANTS} /// compare two "array of variant" elements, with case sensitivity function SortDynArrayVariant(const A,B): integer; /// compare two "array of variant" elements, with no case sensitivity function SortDynArrayVariantI(const A,B): integer; /// compare two "array of variant" elements, with or without case sensitivity function SortDynArrayVariantComp(const A,B: TVarData; caseInsensitive: boolean): integer; {$endif NOVARIANTS} /// hash one AnsiString content with the suppplied Hasher() function function HashAnsiString(const Elem; Hasher: THasher): cardinal; /// case-insensitive hash one AnsiString content with the suppplied Hasher() function function HashAnsiStringI(const Elem; Hasher: THasher): cardinal; /// hash one SynUnicode content with the suppplied Hasher() function // - work with WideString for all Delphi versions, or UnicodeString in Delphi 2009+ function HashSynUnicode(const Elem; Hasher: THasher): cardinal; /// case-insensitive hash one SynUnicode content with the suppplied Hasher() function // - work with WideString for all Delphi versions, or UnicodeString in Delphi 2009+ function HashSynUnicodeI(const Elem; Hasher: THasher): cardinal; /// hash one WideString content with the suppplied Hasher() function // - work with WideString for all Delphi versions function HashWideString(const Elem; Hasher: THasher): cardinal; /// case-insensitive hash one WideString content with the suppplied Hasher() function // - work with WideString for all Delphi versions function HashWideStringI(const Elem; Hasher: THasher): cardinal; {$ifdef UNICODE} /// hash one UnicodeString content with the suppplied Hasher() function // - work with UnicodeString in Delphi 2009+ function HashUnicodeString(const Elem; Hasher: THasher): cardinal; /// case-insensitive hash one UnicodeString content with the suppplied Hasher() function // - work with UnicodeString in Delphi 2009+ function HashUnicodeStringI(const Elem; Hasher: THasher): cardinal; {$endif UNICODE} {$ifndef NOVARIANTS} /// case-sensitive hash one variant content with the suppplied Hasher() function function HashVariant(const Elem; Hasher: THasher): cardinal; /// case-insensitive hash one variant content with the suppplied Hasher() function function HashVariantI(const Elem; Hasher: THasher): cardinal; {$endif NOVARIANTS} /// hash one PtrUInt (=NativeUInt) value with the suppplied Hasher() function function HashPtrUInt(const Elem; Hasher: THasher): cardinal; /// hash one Byte value - simply return the value ignore Hasher() parameter function HashByte(const Elem; Hasher: THasher): cardinal; /// hash one Word value - simply return the value ignore Hasher() parameter function HashWord(const Elem; Hasher: THasher): cardinal; /// hash one Integer/cardinal value - simply return the value ignore Hasher() parameter function HashInteger(const Elem; Hasher: THasher): cardinal; /// hash one Int64/Qword value with the suppplied Hasher() function function HashInt64(const Elem; Hasher: THasher): cardinal; /// hash one THash128 value with the suppplied Hasher() function function Hash128(const Elem; Hasher: THasher): cardinal; /// hash one THash256 value with the suppplied Hasher() function function Hash256(const Elem; Hasher: THasher): cardinal; /// hash one THash512 value with the suppplied Hasher() function function Hash512(const Elem; Hasher: THasher): cardinal; /// hash one pointer value with the suppplied Hasher() function // - this version is not the same as HashPtrUInt, since it will always // use the hasher function function HashPointer(const Elem; Hasher: THasher): cardinal; var /// helper array to get the comparison function corresponding to a given // standard array type // - not to be used as such, but e.g. when inlining TDynArray methods DYNARRAY_SORTFIRSTFIELD: array[boolean,TDynArrayKind] of TDynArraySortCompare = ( (nil, SortDynArrayBoolean, SortDynArrayByte, SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle, SortDynArrayInt64, SortDynArrayQWord, SortDynArrayDouble, SortDynArrayInt64, SortDynArrayInt64, SortDynArrayDouble, SortDynArrayDouble, SortDynArrayAnsiString, SortDynArrayAnsiString, SortDynArrayString, SortDynArrayRawByteString, SortDynArrayUnicodeString, SortDynArrayUnicodeString, SortDynArray128, SortDynArray256, SortDynArray512, SortDynArrayPointer, {$ifndef NOVARIANTS}SortDynArrayVariant,{$endif} nil), (nil, SortDynArrayBoolean, SortDynArrayByte, SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle, SortDynArrayInt64, SortDynArrayQWord, SortDynArrayDouble, SortDynArrayInt64, SortDynArrayInt64, SortDynArrayDouble, SortDynArrayDouble, SortDynArrayAnsiStringI, SortDynArrayAnsiStringI, SortDynArrayStringI, SortDynArrayRawByteString, SortDynArrayUnicodeStringI, SortDynArrayUnicodeStringI, SortDynArray128, SortDynArray256, SortDynArray512, SortDynArrayPointer, {$ifndef NOVARIANTS}SortDynArrayVariantI,{$endif} nil)); /// helper array to get the hashing function corresponding to a given // standard array type // - not to be used as such, but e.g. when inlining TDynArray methods DYNARRAY_HASHFIRSTFIELD: array[boolean,TDynArrayKind] of TDynArrayHashOne = ( (nil, HashByte, HashByte, HashWord, HashInteger, HashInteger, HashInteger, HashInt64, HashInt64, HashInt64, HashInt64, HashInt64, HashInt64, HashInt64, HashAnsiString, HashAnsiString, {$ifdef UNICODE}HashUnicodeString{$else}HashAnsiString{$endif}, HashAnsiString, HashWideString, HashSynUnicode, Hash128, Hash256, Hash512, HashPointer, {$ifndef NOVARIANTS}HashVariant,{$endif} nil), (nil, HashByte, HashByte, HashWord, HashInteger, HashInteger, HashInteger, HashInt64, HashInt64, HashInt64, HashInt64, HashInt64, HashInt64, HashInt64, HashAnsiStringI, HashAnsiStringI, {$ifdef UNICODE}HashUnicodeStringI{$else}HashAnsiStringI{$endif}, HashAnsiStringI, HashWideStringI, HashSynUnicodeI, Hash128, Hash256, Hash512, HashPointer, {$ifndef NOVARIANTS}HashVariantI,{$endif} nil)); /// initialize the structure with a one-dimension dynamic array // - the dynamic array must have been defined with its own type // (e.g. TIntegerDynArray = array of Integer) // - if aCountPointer is set, it will be used instead of length() to store // the dynamic array items count - it will be much faster when adding // elements to the array, because the dynamic array won't need to be // resized each time - but in this case, you should use the Count property // instead of length(array) or high(array) when accessing the data: in fact // length(array) will store the memory size reserved, not the items count // - if aCountPointer is set, its content will be set to 0, whatever the // array length is, or the current aCountPointer^ value is // - a typical usage could be: // !var IntArray: TIntegerDynArray; // !begin // ! with DynArray(TypeInfo(TIntegerDynArray),IntArray) do // ! begin // ! (...) // ! end; // ! (...) // ! DynArray(TypeInfo(TIntegerDynArray),IntArrayA).SaveTo function DynArray(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil): TDynArray; {$ifdef HASINLINE}inline;{$endif} /// wrap a simple dynamic array BLOB content as stored by TDynArray.SaveTo // - a "simple" dynamic array contains data with no reference count, e.g. byte, // word, integer, cardinal, Int64, double or Currency // - same as TDynArray.LoadFrom() with no memory allocation nor memory copy: so // is much faster than creating a temporary dynamic array to load the data // - will return nil if no or invalid data, or a pointer to the data // array otherwise, with the items number stored in Count and the individual // element size in ElemSize (e.g. 2 for a TWordDynArray) function SimpleDynArrayLoadFrom(Source: PAnsiChar; aTypeInfo: pointer; var Count, ElemSize: integer; NoHash32Check: boolean=false): pointer; /// wrap an Integer dynamic array BLOB content as stored by TDynArray.SaveTo // - same as TDynArray.LoadFrom() with no memory allocation nor memory copy: so // is much faster than creating a temporary dynamic array to load the data // - will return nil if no or invalid data, or a pointer to the integer // array otherwise, with the items number stored in Count // - sligtly faster than SimpleDynArrayLoadFrom(Source,TypeInfo(TIntegerDynArray),Count) function IntegerDynArrayLoadFrom(Source: PAnsiChar; var Count: integer; NoHash32Check: boolean=false): PIntegerArray; /// search in a RawUTF8 dynamic array BLOB content as stored by TDynArray.SaveTo // - same as search within TDynArray.LoadFrom() with no memory allocation nor // memory copy: so is much faster // - will return -1 if no match or invalid data, or the matched entry index function RawUTF8DynArrayLoadFromContains(Source: PAnsiChar; Value: PUTF8Char; ValueLen: integer; CaseSensitive: boolean): integer; { ****************** text buffer and JSON functions and classes ************ } const /// maximum number of fields in a database Table // - is included in SynCommons so that all DB-related work will be able to // share the same low-level types and functions (e.g. TSQLFieldBits, // TJSONWriter, TSynTableStatement, TSynTable, TSQLRecordProperties) // - default is 64, but can be set to any value (64, 128, 192 and 256 optimized) // changing the source below or using MAX_SQLFIELDS_128, MAX_SQLFIELDS_192 or // MAX_SQLFIELDS_256 conditional directives for your project // - this constant is used internaly to optimize memory usage in the // generated asm code, and statically allocate some arrays for better speed // - note that due to compiler restriction, 256 is the maximum value // (this is the maximum number of items in a Delphi/FPC set) {$ifdef MAX_SQLFIELDS_128} MAX_SQLFIELDS = 128; {$else} {$ifdef MAX_SQLFIELDS_192} MAX_SQLFIELDS = 192; {$else} {$ifdef MAX_SQLFIELDS_256} MAX_SQLFIELDS = 256; {$else} MAX_SQLFIELDS = 64; {$endif} {$endif} {$endif} /// sometimes, the ID field is included in a bits set MAX_SQLFIELDS_INCLUDINGID = MAX_SQLFIELDS+1; /// UTF-8 encoded \uFFF0 special code to mark Base64 binary content in JSON // - Unicode special char U+FFF0 is UTF-8 encoded as EF BF B0 bytes // - as generated by BinToBase64WithMagic() functions, and expected by // SQLParamContent() and ExtractInlineParameters() functions // - used e.g. when transmitting TDynArray.SaveTo() content JSON_BASE64_MAGIC = $b0bfef; /// '"' + UTF-8 encoded \uFFF0 special code to mark Base64 binary in JSON JSON_BASE64_MAGIC_QUOTE = ord('"')+cardinal(JSON_BASE64_MAGIC) shl 8; /// '"' + UTF-8 encoded \uFFF0 special code to mark Base64 binary in JSON // - defined as a cardinal variable to be used as: // ! AddNoJSONEscape(@JSON_BASE64_MAGIC_QUOTE_VAR,4); JSON_BASE64_MAGIC_QUOTE_VAR: cardinal = JSON_BASE64_MAGIC_QUOTE; /// UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON // - e.g. '"\uFFF12012-05-04"' pattern // - Unicode special char U+FFF1 is UTF-8 encoded as EF BF B1 bytes // - as generated by DateToSQL/DateTimeToSQL/TimeLogToSQL functions, and // expected by SQLParamContent() and ExtractInlineParameters() functions JSON_SQLDATE_MAGIC = $b1bfef; /// '"' + UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON JSON_SQLDATE_MAGIC_QUOTE = ord('"')+cardinal(JSON_SQLDATE_MAGIC) shl 8; ///'"' + UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON // - defined as a cardinal variable to be used as: // ! AddNoJSONEscape(@JSON_SQLDATE_MAGIC_QUOTE_VAR,4); JSON_SQLDATE_MAGIC_QUOTE_VAR: cardinal = JSON_SQLDATE_MAGIC_QUOTE; type TTextWriter = class; /// method prototype for custom serialization of a dynamic array item // - each element of the dynamic array will be called as aValue parameter // of this callback // - can be used also at record level, if the record has a type information // (i.e. shall contain a managed type within its fields) // - to be used with TTextWriter.RegisterCustomJSONSerializer() method // - note that the generated JSON content will be appended after a '[' and // before a ']' as a normal JSON arrray, but each item can be any JSON // structure (i.e. a number, a string, but also an object or an array) // - implementation code could call aWriter.Add/AddJSONEscapeString... // - implementation code shall follow the same exact format for the // associated TDynArrayJSONCustomReader callback TDynArrayJSONCustomWriter = procedure(const aWriter: TTextWriter; const aValue) of object; /// method prototype for custom unserialization of a dynamic array item // - each element of the dynamic array will be called as aValue parameter // of this callback // - can be used also at record level, if the record has a type information // (i.e. shall contain a managed type within its fields) // - to be used with TTextWriter.RegisterCustomJSONSerializer() method // - implementation code could call e.g. GetJSONField() low-level function, and // returns a pointer to the last handled element of the JSON input buffer, // as such (aka EndOfBuffer variable as expected by GetJSONField): // ! var V: TFV absolute aValue; // ! begin // ! (...) // ! V.Detailed := UTF8ToString(GetJSONField(P,P)); // ! if P=nil then // ! exit; // ! aValid := true; // ! result := P; // ',' or ']' for last item of array // ! end; // - implementation code shall follow the same exact format for the // associated TDynArrayJSONCustomWriter callback TDynArrayJSONCustomReader = function(P: PUTF8Char; var aValue; out aValid: Boolean): PUTF8Char of object; /// the kind of variables handled by TJSONCustomParser // - the last item should be ptCustom, for non simple types TJSONCustomParserRTTIType = ( ptArray, ptBoolean, ptByte, ptCardinal, ptCurrency, ptDouble, ptExtended, ptInt64, ptInteger, ptQWord, ptRawByteString, ptRawJSON, ptRawUTF8, ptRecord, ptSingle, ptString, ptSynUnicode, ptDateTime, ptDateTimeMS, ptGUID, ptID, ptTimeLog, {$ifndef NOVARIANTS} ptVariant, {$endif} ptWideString, ptWord, ptCustom); /// how TJSONCustomParser would serialize/unserialize JSON content TJSONCustomParserSerializationOption = ( soReadIgnoreUnknownFields, soWriteHumanReadable, soCustomVariantCopiedByReference, soWriteIgnoreDefault); /// how TJSONCustomParser would serialize/unserialize JSON content // - by default, during reading any unexpected field will stop and fail the // process - if soReadIgnoreUnknownFields is defined, such properties will // be ignored (can be very handy when parsing JSON from a remote service) // - by default, JSON content will be written in its compact standard form, // ready to be parsed by any client - you can specify soWriteHumanReadable // so that some line feeds and indentation will make the content more readable // - by default, internal TDocVariant variants will be copied by-value from // one instance to another, to ensure proper safety - but it may be too slow: // if you set soCustomVariantCopiedByReference, any internal // TDocVariantData.VValue/VName instances will be copied by-reference, // to avoid memory allocations, BUT it may break internal process if you change // some values in place (since VValue/VName and VCount won't match) - as such, // if you set this option, ensure that you use the content as read-only // - by default, all fields are persistented, unless soWriteIgnoreDefault is // defined and void values (e.g. "" or 0) won't be written // - you may use TTextWriter.RegisterCustomJSONSerializerSetOptions() class // method to customize the serialization for a given type TJSONCustomParserSerializationOptions = set of TJSONCustomParserSerializationOption; TJSONCustomParserRTTI = class; /// an array of RTTI properties information // - we use dynamic arrays, since all the information is static and we // do not need to remove any RTTI information TJSONCustomParserRTTIs = array of TJSONCustomParserRTTI; /// used to store additional RTTI in TJSONCustomParser internal structures TJSONCustomParserRTTI = class protected fPropertyName: RawUTF8; fFullPropertyName: RawUTF8; fPropertyType: TJSONCustomParserRTTIType; fCustomTypeName: RawUTF8; fNestedProperty: TJSONCustomParserRTTIs; fDataSize: integer; fNestedDataSize: integer; procedure ComputeDataSizeAfterAdd; virtual; procedure ComputeNestedDataSize; procedure ComputeFullPropertyName; procedure FinalizeNestedRecord(var Data: PByte); procedure FinalizeNestedArray(var Data: PtrUInt); procedure AllocateNestedArray(var Data: PtrUInt; NewLength: integer); procedure ReAllocateNestedArray(var Data: PtrUInt; NewLength: integer); function IfDefaultSkipped(var Value: PByte): boolean; procedure WriteOneSimpleValue(aWriter: TTextWriter; var Value: PByte; Options: TJSONCustomParserSerializationOptions); public /// initialize the instance constructor Create(const aPropertyName: RawUTF8; aPropertyType: TJSONCustomParserRTTIType); /// initialize an instance from the RTTI type information // - will return an instance of this class of any inherited class class function CreateFromRTTI(const PropertyName: RawUTF8; Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; /// create an instance from a specified type name // - will return an instance of this class of any inherited class class function CreateFromTypeName(const aPropertyName, aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; /// recognize a simple type from a supplied type name // - will return ptCustom for any unknown type class function TypeNameToSimpleRTTIType( const TypeName: RawUTF8): TJSONCustomParserRTTIType; overload; /// recognize a simple type from a supplied type name // - will return ptCustom for any unknown type class function TypeNameToSimpleRTTIType( TypeName: PShortString): TJSONCustomParserRTTIType; overload; /// recognize a simple type from a supplied type name // - will return ptCustom for any unknown type class function TypeNameToSimpleRTTIType(TypeName: PUTF8Char; TypeNameLen: Integer; var ItemTypeName: RawUTF8): TJSONCustomParserRTTIType; overload; /// recognize a simple type from a supplied type information // - to be called if TypeNameToSimpleRTTIType() did fail, i.e. return ptCustom // - will return ptCustom for any unknown type class function TypeInfoToSimpleRTTIType(Info: pointer; ItemSize: integer): TJSONCustomParserRTTIType; /// recognize a ktBinary simple type from a supplied type name // - as registered by TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType class function TypeNameToSimpleBinary(const aTypeName: RawUTF8; out aDataSize, aFieldSize: integer): boolean; /// unserialize some JSON content into its binary internal representation // - on error, returns false and P should point to the faulty text input function ReadOneLevel(var P: PUTF8Char; var Data: PByte; Options: TJSONCustomParserSerializationOptions): boolean; virtual; /// serialize a binary internal representation into JSON content // - this method won't append a trailing ',' character procedure WriteOneLevel(aWriter: TTextWriter; var P: PByte; Options: TJSONCustomParserSerializationOptions); virtual; /// the associated type name, e.g. for a record property CustomTypeName: RawUTF8 read fCustomTypeName; /// the property name // - may be void for the Root element // - e.g. 'SubProp' property PropertyName: RawUTF8 read fPropertyName; /// the property name, including all parent elements // - may be void for the Root element // - e.g. 'MainProp.SubProp' property FullPropertyName: RawUTF8 read fFullPropertyName; /// the property type // - support only a limited set of simple types, or ptRecord for a nested // record, or ptArray for a nested array property PropertyType: TJSONCustomParserRTTIType read fPropertyType; /// the nested array of properties (if any) // - assigned only if PropertyType is [ptRecord,ptArray] // - is either the record type of each ptArray item: // ! SubProp: array of record ... // - or one NestedProperty[0] entry with PropertyName='' and PropertyType // not in [ptRecord,ptArray]: // ! SubPropNumber: array of integer; // ! SubPropText: array of RawUTF8; property NestedProperty: TJSONCustomParserRTTIs read fNestedProperty; end; /// used to store additional RTTI as a ptCustom kind of property TJSONCustomParserCustom = class(TJSONCustomParserRTTI) protected fCustomTypeInfo: pointer; public /// initialize the instance constructor Create(const aPropertyName, aCustomTypeName: RawUTF8); virtual; /// abstract method to write the instance as JSON procedure CustomWriter(const aWriter: TTextWriter; const aValue); virtual; abstract; /// abstract method to read the instance from JSON // - should return nil on parsing error function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar): PUTF8Char; virtual; abstract; /// release any memory used by the instance procedure FinalizeItem(Data: Pointer); virtual; /// the associated RTTI structure property CustomTypeInfo: pointer read fCustomTypeInfo; end; /// which kind of property does TJSONCustomParserCustomSimple refer to TJSONCustomParserCustomSimpleKnownType = ( ktNone, ktEnumeration, ktSet, ktGUID, ktFixedArray, ktStaticArray, ktDynamicArray, ktBinary); /// used to store additional RTTI for simple type as a ptCustom kind // - this class handle currently enumerate, TGUID or static/dynamic arrays TJSONCustomParserCustomSimple = class(TJSONCustomParserCustom) protected fKnownType: TJSONCustomParserCustomSimpleKnownType; fTypeData: pointer; fFixedSize: integer; fNestedArray: TJSONCustomParserRTTI; public /// initialize the instance from the given RTTI structure constructor Create(const aPropertyName, aCustomTypeName: RawUTF8; aCustomType: pointer); reintroduce; /// initialize the instance for a static array constructor CreateFixedArray(const aPropertyName: RawUTF8; aFixedSize: cardinal); /// initialize the instance for a binary blob constructor CreateBinary(const aPropertyName: RawUTF8; aDataSize, aFixedSize: cardinal); /// released used memory destructor Destroy; override; /// method to write the instance as JSON procedure CustomWriter(const aWriter: TTextWriter; const aValue); override; /// method to read the instance from JSON function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar): PUTF8Char; override; /// which kind of simple property this instance does refer to property KnownType: TJSONCustomParserCustomSimpleKnownType read fKnownType; /// the element type for ktStaticArray and ktDynamicArray property NestedArray: TJSONCustomParserRTTI read fNestedArray; end; /// implement a reference to a registered record type // - i.e. ptCustom kind of property, handled by the // TTextWriter.RegisterCustomJSONSerializer*() internal list TJSONCustomParserCustomRecord = class(TJSONCustomParserCustom) protected fCustomTypeIndex: integer; function GetJSONCustomParserRegistration: pointer; public /// initialize the instance from the given record custom serialization index constructor Create(const aPropertyName: RawUTF8; aCustomTypeIndex: integer); reintroduce; overload; /// method to write the instance as JSON procedure CustomWriter(const aWriter: TTextWriter; const aValue); override; /// method to read the instance from JSON function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar): PUTF8Char; override; /// release any memory used by the instance procedure FinalizeItem(Data: Pointer); override; end; /// how an RTTI expression is expected to finish TJSONCustomParserRTTIExpectedEnd = (eeNothing, eeSquare, eeCurly, eeEndKeyWord); TJSONRecordAbstract = class; /// used to handle additional RTTI for JSON record serialization // - this class is used to define how a record is defined, and will work // with any version of Delphi // - this Abstract class is not to be used as-this, but contains all // needed information to provide CustomWriter/CustomReader methods // - you can use e.g. TJSONRecordTextDefinition for text-based RTTI // manual definition, or (not yet provided) a version based on Delphi 2010+ // new RTTI information TJSONRecordAbstract = class protected /// internal storage of TJSONCustomParserRTTI instances fItems: TObjectList; fRoot: TJSONCustomParserRTTI; fOptions: TJSONCustomParserSerializationOptions; function AddItem(const aPropertyName: RawUTF8; aPropertyType: TJSONCustomParserRTTIType; const aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; public /// initialize the class instance constructor Create; /// callback for custom JSON serialization // - will follow the RTTI textual information as supplied to the constructor procedure CustomWriter(const aWriter: TTextWriter; const aValue); /// callback for custom JSON unserialization // - will follow the RTTI textual information as supplied to the constructor function CustomReader(P: PUTF8Char; var aValue; out aValid: Boolean): PUTF8Char; /// release used memory // - when created via Compute() call, instances of this class are managed // via a GarbageCollector() global list, so you do not need to free them destructor Destroy; override; /// store the RTTI information of properties at root level // - is one instance with PropertyType=ptRecord and PropertyName='' property Root: TJSONCustomParserRTTI read fRoot; /// how this class would serialize/unserialize JSON content // - by default, no option is defined // - you can customize the expected options with the instance returned by // TTextWriter.RegisterCustomJSONSerializerFromText() method, or via the // TTextWriter.RegisterCustomJSONSerializerSetOptions() overloaded methods property Options: TJSONCustomParserSerializationOptions read fOptions write fOptions; end; /// used to handle JSON record serialization using RTTI // - is able to handle any kind of record since Delphi 2010, thanks to // enhanced RTTI TJSONRecordRTTI = class(TJSONRecordAbstract) protected fRecordTypeInfo: pointer; function AddItemFromRTTI(const PropertyName: RawUTF8; Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; {$ifdef ISDELPHI2010} procedure FromEnhancedRTTI(Props: TJSONCustomParserRTTI; Info: pointer); {$endif} public /// initialize the instance // - you should NOT use this constructor directly, but let e.g. // TJSONCustomParsers.TryToGetFromRTTI() create it for you constructor Create(aRecordTypeInfo: pointer; aRoot: TJSONCustomParserRTTI); reintroduce; /// the low-level address of the enhanced RTTI property RecordTypeInfo: pointer read fRecordTypeInfo; end; /// used to handle text-defined additional RTTI for JSON record serialization // - is used by TTextWriter.RegisterCustomJSONSerializerFromText() method TJSONRecordTextDefinition = class(TJSONRecordAbstract) protected fDefinition: RawUTF8; procedure Parse(Props: TJSONCustomParserRTTI; var P: PUTF8Char; PEnd: TJSONCustomParserRTTIExpectedEnd); public /// initialize a custom JSON serializer/unserializer from pseudo RTTI // - you should NOT use this constructor directly, but call the FromCache() // class function, which will use an internal definition cache constructor Create(aRecordTypeInfo: pointer; const aDefinition: RawUTF8); reintroduce; /// retrieve a custom cached JSON serializer/unserializer from pseudo RTTI // - returned class instance will be cached for any further use // - the record where the data will be stored should be defined as PACKED: // ! type TMyRecord = packed record // ! A,B,C: integer; // ! D: RawUTF8; // ! E: record; // or array of record/integer/string/... // ! E1,E2: double; // ! end; // ! end; // - only known sub types are integer, cardinal, Int64, single, double, // currency, TDateTime, TTimeLog, RawUTF8, String, WideString, SynUnicode, // or a nested record or dynamic array // - RTTI textual information shall be supplied as text, with the // same format as with a pascal record, or with some shorter variations: // ! FromCache('A,B,C: integer; D: RawUTF8; E: record E1,E2: double; end;'); // ! FromCache('A,B,C: integer; D: RawUTF8; E: array of record E1,E2: double; end;'); // ! 'A,B,C: integer; D: RawUTF8; E: array of SynUnicode; F: array of integer' // or a shorter alternative syntax for records and arrays: // ! FromCache('A,B,C: integer; D: RawUTF8; E: {E1,E2: double}'); // ! FromCache('A,B,C: integer; D: RawUTF8; E: [E1,E2: double]'); // in fact ; could be ignored: // ! FromCache('A,B,C:integer D:RawUTF8 E:{E1,E2:double}'); // ! FromCache('A,B,C:integer D:RawUTF8 E:[E1,E2:double]'); // or even : could be ignored: // ! FromCache('A,B,C integer D RawUTF8 E{E1,E2 double}'); // ! FromCache('A,B,C integer D RawUTF8 E[E1,E2 double]'); class function FromCache(aTypeInfo: pointer; const aDefinition: RawUTF8): TJSONRecordTextDefinition; /// the textual definition of this RTTI information property Definition: RawUTF8 read fDefinition; end; /// the available logging events, as handled by TSynLog // - defined in SynCommons so that it may be used with TTextWriter.AddEndOfLine // - sllInfo will log general information events // - sllDebug will log detailed debugging information // - sllTrace will log low-level step by step debugging information // - sllWarning will log unexpected values (not an error) // - sllError will log errors // - sllEnter will log every method start // - sllLeave will log every method exit // - sllLastError will log the GetLastError OS message // - sllException will log all exception raised - available since Windows XP // - sllExceptionOS will log all OS low-level exceptions (EDivByZero, // ERangeError, EAccessViolation...) // - sllMemory will log memory statistics // - sllStackTrace will log caller's stack trace (it's by default part of // TSynLogFamily.LevelStackTrace like sllError, sllException, sllExceptionOS, // sllLastError and sllFail) // - sllFail was defined for TSynTestsLogged.Failed method, and can be used // to log some customer-side assertions (may be notifications, not errors) // - sllSQL is dedicated to trace the SQL statements // - sllCache should be used to trace the internal caching mechanism // - sllResult could trace the SQL results, JSON encoded // - sllDB is dedicated to trace low-level database engine features // - sllHTTP could be used to trace HTTP process // - sllClient/sllServer could be used to trace some Client or Server process // - sllServiceCall/sllServiceReturn to trace some remote service or library // - sllUserAuth to trace user authentication (e.g. for individual requests) // - sllCustom* items can be used for any purpose // - sllNewRun will be written when a process opens a rotated log // - sllDDDError will log any DDD-related low-level error information // - sllDDDInfo will log any DDD-related low-level debugging information // - sllMonitoring will log the statistics information (if available), // or may be used for real-time chat among connected people to ToolsAdmin TSynLogInfo = ( sllNone, sllInfo, sllDebug, sllTrace, sllWarning, sllError, sllEnter, sllLeave, sllLastError, sllException, sllExceptionOS, sllMemory, sllStackTrace, sllFail, sllSQL, sllCache, sllResult, sllDB, sllHTTP, sllClient, sllServer, sllServiceCall, sllServiceReturn, sllUserAuth, sllCustom1, sllCustom2, sllCustom3, sllCustom4, sllNewRun, sllDDDError, sllDDDInfo, sllMonitoring); /// used to define a set of logging level abilities // - i.e. a combination of none or several logging event // - e.g. use LOG_VERBOSE constant to log all events, or LOG_STACKTRACE // to log all errors and exceptions TSynLogInfos = set of TSynLogInfo; /// a dynamic array of logging event levels TSynLogInfoDynArray = array of TSynLogInfo; /// available options for TTextWriter.WriteObject() method // - woHumanReadable will add some line feeds and indentation to the content, // to make it more friendly to the human eye // - woDontStoreDefault (which is set by default for WriteObject method) will // avoid serializing properties including a default value (JSONToObject function // will set the default values, so it may help saving some bandwidth or storage) // - woFullExpand will generate a debugger-friendly layout, including instance // class name, sets/enumerates as text, and reference pointer - as used by // TSynLog and ObjectToJSONFull() // - woStoreClassName will add a "ClassName":"TMyClass" field // - woStorePointer will add a "Address":"0431298A" field, and .map/.mab // source code line number corresponding to ESynException.RaisedAt // - woStoreStoredFalse will write the 'stored false' properties, even // if they are marked as such (used e.g. to persist all settings on file, // but disallow the sensitive - password - fields be logged) // - woHumanReadableFullSetsAsStar will store an human-readable set with // all its enumerates items set to be stored as ["*"] // - woHumanReadableEnumSetAsComment will add a comment at the end of the // line, containing all available values of the enumaration or set, e.g: // $ "Enum": "Destroying", // Idle,Started,Finished,Destroying // - woEnumSetsAsText will store sets and enumerables as text (is also // included in woFullExpand or woHumanReadable) // - woDateTimeWithMagic will append the JSON_SQLDATE_MAGIC (i.e. U+FFF1) // before the ISO-8601 encoded TDateTime value // - woDateTimeWithZSuffix will append the Z suffix to the ISO-8601 encoded // TDateTime value, to identify the content as strict UTC value // - TTimeLog would be serialized as Int64, unless woTimeLogAsText is defined // - since TSQLRecord.ID could be huge Int64 numbers, they may be truncated // on client side, e.g. to 53-bit range in JavaScript: you could define // woIDAsIDstr to append an additional "ID_str":"##########" field // - by default, TSQLRawBlob properties are serialized as null, unless // woSQLRawBlobAsBase64 is defined // - if woHideSynPersistentPassword is set, TSynPersistentWithPassword.Password // field will be serialized as "***" to prevent security issues (e.g. in log) // - by default, TObjectList will set the woStoreClassName for its nested // objects, unless woObjectListWontStoreClassName is defined // - void strings would be serialized as "", unless woDontStoreEmptyString // is defined so that such properties would not be written // - all inherited properties would be serialized, unless woDontStoreInherited // is defined, and only the topmost class level properties would be serialized // - woInt64AsHex will force Int64/QWord to be written as hexadecimal string - // see j2oAllowInt64Hex reverse option fot Json2Object // - woDontStore0 will avoid serializating number properties equal to 0 TTextWriterWriteObjectOption = ( woHumanReadable, woDontStoreDefault, woFullExpand, woStoreClassName, woStorePointer, woStoreStoredFalse, woHumanReadableFullSetsAsStar, woHumanReadableEnumSetAsComment, woEnumSetsAsText, woDateTimeWithMagic, woDateTimeWithZSuffix, woTimeLogAsText, woIDAsIDstr, woSQLRawBlobAsBase64, woHideSynPersistentPassword, woObjectListWontStoreClassName, woDontStoreEmptyString, woDontStoreInherited, woInt64AsHex, woDontStore0); /// options set for TTextWriter.WriteObject() method TTextWriterWriteObjectOptions = set of TTextWriterWriteObjectOption; /// callback used to echo each line of TTextWriter class // - should return TRUE on sucess, FALSE if the log was not echoed: but // TSynLog will continue logging, even if this event returned FALSE TOnTextWriterEcho = function(Sender: TTextWriter; Level: TSynLogInfo; const Text: RawUTF8): boolean of object; /// callback used by TTextWriter.WriteObject to customize class instance // serialization // - should return TRUE if the supplied property has been written (including // the property name and the ending ',' character), and doesn't need to be // processed with the default RTTI-based serializer TOnTextWriterObjectProp = function(Sender: TTextWriter; Value: TObject; PropInfo: pointer; Options: TTextWriterWriteObjectOptions): boolean of object; /// class of our simple writer to a Stream, specialized for the TEXT format TTextWriterClass = class of TTextWriter; /// the potential places were TTextWriter.HtmlEscape should process // proper HTML string escaping // $ < > & " -> < > & "e; // by default (hfAnyWhere) // $ < > & -> < > & // outside HTML attributes (hfOutsideAttributes) // $ & " -> & "e; // within HTML attributes (hfWithinAttributes) TTextWriterHTMLFormat = ( hfAnyWhere, hfOutsideAttributes, hfWithinAttributes); /// available global options for a TTextWriter instance // - TTextWriter.WriteObject() method behavior would be set via their own // TTextWriterWriteObjectOptions, and work in conjunction with those settings // - twoStreamIsOwned would be set if the associated TStream is owned by // the TTextWriter instance // - twoFlushToStreamNoAutoResize would forbid FlushToStream to resize the // internal memory buffer when it appears undersized - FlushFinal will set it // before calling a last FlushToStream // - by default, custom serializers defined via RegisterCustomJSONSerializer() // would let AddRecordJSON() and AddDynArrayJSON() write enumerates and sets // as integer numbers, unless twoEnumSetsAsTextInRecord or // twoEnumSetsAsBooleanInRecord (exclusively) are set - for Mustache data // context, twoEnumSetsAsBooleanInRecord will return a JSON object with // "setname":true/false fields // - variants and nested objects would be serialized with their default // JSON serialization options, unless twoForceJSONExtended or // twoForceJSONStandard is defined // - when enumerates and sets are serialized as text into JSON, you may force // the identifiers to be left-trimed for all their lowercase characters // (e.g. sllError -> 'Error') by setting twoTrimLeftEnumSets: this option // would default to the global TTextWriter.SetDefaultEnumTrim setting // - twoEndOfLineCRLF would reflect the TTextWriter.EndOfLineCRLF property // - twoBufferIsExternal would be set if the temporary buffer is not handled // by the instance, but specified at constructor, maybe from the stack // - twoIgnoreDefaultInRecord will force custom record serialization to avoid // writing the fields with default values, i.e. enable soWriteIgnoreDefault // when TJSONCustomParserRTTI.WriteOneLevel is called TTextWriterOption = ( twoStreamIsOwned, twoFlushToStreamNoAutoResize, twoEnumSetsAsTextInRecord, twoEnumSetsAsBooleanInRecord, twoFullSetsAsStar, twoTrimLeftEnumSets, twoForceJSONExtended, twoForceJSONStandard, twoEndOfLineCRLF, twoBufferIsExternal, twoIgnoreDefaultInRecord); /// options set for a TTextWriter instance // - allows to override e.g. AddRecordJSON() and AddDynArrayJSON() behavior; // or set global process customization for a TTextWriter TTextWriterOptions = set of TTextWriterOption; /// may be used to allocate on stack a 8KB work buffer for a TTextWriter // - via the TTextWriter.CreateOwnedStream overloaded constructor TTextWriterStackBuffer = array[0..8191] of AnsiChar; /// simple writer to a Stream, specialized for the TEXT format // - use an internal buffer, faster than string+string // - some dedicated methods is able to encode any data with JSON escape TTextWriter = class protected B, BEnd: PUTF8Char; fStream: TStream; fInitialStreamPosition: PtrUInt; fTotalFileSize: PtrUInt; fCustomOptions: TTextWriterOptions; // internal temporary buffer fTempBufSize: Integer; fTempBuf: PUTF8Char; fOnWriteObject: TOnTextWriterObjectProp; /// used by WriteObjectAsString/AddDynArrayJSONAsString methods fInternalJSONWriter: TTextWriter; fHumanReadableLevel: integer; fEchoStart: PtrInt; fEchoBuf: RawUTF8; fEchos: array of TOnTextWriterEcho; function GetTextLength: PtrUInt; procedure SetStream(aStream: TStream); procedure SetBuffer(aBuf: pointer; aBufSize: integer); function EchoFlush: PtrInt; procedure InternalAddFixedAnsi(Source: PAnsiChar; SourceChars: Cardinal; const AnsiToWide: TWordDynArray; Escape: TTextWriterKind); function GetEndOfLineCRLF: boolean; {$ifdef HASINLINE}inline;{$endif} procedure SetEndOfLineCRLF(aEndOfLineCRLF: boolean); public /// the data will be written to the specified Stream // - aStream may be nil: in this case, it MUST be set before using any // Add*() method // - default internal buffer size if 8192 constructor Create(aStream: TStream; aBufSize: integer=8192); overload; /// the data will be written to the specified Stream // - aStream may be nil: in this case, it MUST be set before using any // Add*() method // - will use an external buffer (which may be allocated on stack) constructor Create(aStream: TStream; aBuf: pointer; aBufSize: integer); overload; /// the data will be written to an internal TRawByteStringStream // - TRawByteStringStream.DataString method will be used by TTextWriter.Text // to retrieve directly the content without any data move nor allocation // - default internal buffer size if 4096 (enough for most JSON objects) // - consider using a stack-allocated buffer and the overloaded method constructor CreateOwnedStream(aBufSize: integer=4096); overload; /// the data will be written to an internal TRawByteStringStream // - will use an external buffer (which may be allocated on stack) // - TRawByteStringStream.DataString method will be used by TTextWriter.Text // to retrieve directly the content without any data move nor allocation constructor CreateOwnedStream(aBuf: pointer; aBufSize: integer); overload; /// the data will be written to an internal TRawByteStringStream // - will use the stack-allocated TTextWriterStackBuffer if possible // - TRawByteStringStream.DataString method will be used by TTextWriter.Text // to retrieve directly the content without any data move nor allocation constructor CreateOwnedStream(var aStackBuf: TTextWriterStackBuffer; aBufSize: integer=SizeOf(TTextWriterStackBuffer)); overload; /// the data will be written to an external file // - you should call explicitly FlushFinal or FlushToStream to write // any pending data to the file constructor CreateOwnedFileStream(const aFileName: TFileName; aBufSize: integer=8192); /// release all internal structures // - e.g. free fStream if the instance was owned by this class destructor Destroy; override; /// you can use this method to override the default JSON serialization class // - if only SynCommons.pas is used, it will be TTextWriter // - but mORMot.pas initialization will call it to use the TJSONSerializer // instead, which is able to serialize any class as JSON class procedure SetDefaultJSONClass(aClass: TTextWriterClass); /// you can use this method to retireve the default JSON serialization class // - if only SynCommons.pas is used, it will be TTextWriter // - but mORMot.pas initialization will call SetDefaultJSONClass to define // TJSONSerializer instead, which is able to serialize any class as JSON class function GetDefaultJSONClass: TTextWriterClass; /// allow to override the default JSON serialization of enumerations and // sets as text, which would write the whole identifier (e.g. 'sllError') // - calling SetDefaultEnumTrim(true) would force the enumerations to // be trimmed for any lower case char, e.g. sllError -> 'Error' // - this is global to the current process, and should be use mainly for // compatibility purposes for the whole process // - you may change the default behavior by setting twoTrimLeftEnumSets // in the TTextWriter.CustomOptions property of a given serializer // - note that unserialization process would recognize both formats class procedure SetDefaultEnumTrim(aShouldTrimEnumsAsText: boolean); /// retrieve the data as a string function Text: RawUTF8; {$ifdef HASINLINE}inline;{$endif} /// retrieve the data as a string // - will avoid creation of a temporary RawUTF8 variable as for Text function procedure SetText(var result: RawUTF8; reformat: TTextWriterJSONFormat=jsonCompact); /// set the internal stream content with the supplied UTF-8 text procedure ForceContent(const text: RawUTF8); /// write pending data to the Stream, with automatic buffer resizal // - you should not have to call FlushToStream in most cases, but FlushFinal // at the end of the process, just before using the resulting Stream // - FlushToStream may be used to force immediate writing of the internal // memory buffer to the destination Stream // - you can set FlushToStreamNoAutoResize=true or call FlushFinal if you // do not want the automatic memory buffer resizal to take place procedure FlushToStream; virtual; /// write pending data to the Stream, without automatic buffer resizal // - will append the internal memory buffer to the Stream // - in short, FlushToStream may be called during the adding process, and // FlushFinal at the end of the process, just before using the resulting Stream // - if you don't call FlushToStream or FlushFinal, some pending characters // may not be copied to the Stream: you should call it before using the Stream procedure FlushFinal; /// gives access to an internal temporary TTextWriter // - may be used to escape some JSON espaced value (i.e. escape it twice), // in conjunction with AddJSONEscape(Source: TTextWriter) function InternalJSONWriter: TTextWriter; /// add a callback to echo each line written by this class // - this class expects AddEndOfLine to mark the end of each line procedure EchoAdd(const aEcho: TOnTextWriterEcho); /// remove a callback to echo each line written by this class // - event should have been previously registered by a EchoAdd() call procedure EchoRemove(const aEcho: TOnTextWriterEcho); /// reset the internal buffer used for echoing content procedure EchoReset; /// append one ASCII char to the buffer procedure Add(c: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif} /// append two chars to the buffer procedure Add(c1,c2: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif} {$ifndef CPU64} // already implemented by Add(Value: PtrInt) method /// append a 64-bit signed Integer Value as text procedure Add(Value: Int64); overload; {$endif} /// append a 32-bit signed Integer Value as text procedure Add(Value: PtrInt); overload; /// append a boolean Value as text // - write either 'true' or 'false' procedure Add(Value: boolean); overload; {$ifdef HASINLINE}inline;{$endif} /// append a Currency from its Int64 in-memory representation procedure AddCurr64(const Value: Int64); overload; /// append a Currency from its Int64 in-memory representation procedure AddCurr64(const Value: currency); overload; {$ifdef HASINLINE}inline;{$endif} /// append a TTimeLog value, expanded as Iso-8601 encoded text procedure AddTimeLog(Value: PInt64); /// append a TUnixTime value, expanded as Iso-8601 encoded text procedure AddUnixTime(Value: PInt64); /// append a TUnixMSTime value, expanded as Iso-8601 encoded text procedure AddUnixMSTime(Value: PInt64; WithMS: boolean=false); /// append a TDateTime value, expanded as Iso-8601 encoded text // - use 'YYYY-MM-DDThh:mm:ss' format (with FirstChar='T') // - if 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 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 // - i.e. 'YYYY-MM-DDThh:mm:ss.sssZ' format // - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') procedure AddDateTimeMS(const Value: TDateTime; Expanded: boolean=true; FirstTimeChar: AnsiChar = 'T'; const TZD: RawUTF8='Z'); /// append an Unsigned 32-bit Integer Value as a String procedure AddU(Value: cardinal); /// append an Unsigned 64-bit Integer Value as a String procedure AddQ(Value: QWord); /// append an Unsigned 64-bit Integer Value as a quoted hexadecimal String procedure AddQHex(Value: Qword); {$ifdef HASINLINE}inline;{$endif} /// append a GUID value, encoded as text without any {} // - will store e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' procedure Add({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID); overload; /// append a floating-point Value as a String // - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values // - noexp=true will call ExtendedToStringNoExp() to avoid any scientific // notation in the resulting text procedure AddDouble(Value: double; noexp: boolean=false); {$ifdef HASINLINE}inline;{$endif} /// append a floating-point Value as a String // - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values // - noexp=true will call ExtendedToStringNoExp() to avoid any scientific // notation in the resulting text procedure AddSingle(Value: single; noexp: boolean=false); {$ifdef HASINLINE}inline;{$endif} /// append a floating-point Value as a String // - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values // - noexp=true will call ExtendedToStringNoExp() to avoid any scientific // notation in the resulting text procedure Add(Value: Extended; precision: integer; noexp: boolean=false); overload; /// append a floating-point text buffer // - will correct on the fly '.5' -> '0.5' and '-.5' -> '-0.5' // - is used when the input comes from a third-party source with no regular // output, e.g. a database driver procedure AddFloatStr(P: PUTF8Char); /// append strings or integers with a specified format // - % = #37 marks a string, integer, floating-point, or class parameter // to be appended as text (e.g. class name) // - if StringEscape is false (by default), the text won't be escaped before // adding; but if set to true text will be JSON escaped at writing // - note that due to a limitation of the "array of const" format, cardinal // values should be type-casted to Int64() - otherwise the integer mapped // value will be transmitted, therefore wrongly {$ifdef OLDTEXTWRITERFORMAT} // - $ dollar = #36 indicates an integer to be written with 2 digits and a comma // - | vertical = #124 will write the next char e.g. Add('%|$',[10]) will write '10$' // - pound = #163 indicates an integer to be written with 4 digits and a comma // - micro = #181 indicates an integer to be written with 3 digits without any comma // - currency = #164 indicates CR+LF chars // - section = #167 indicates to trim last comma // - since some of this characters above are > #127, they are not UTF-8 // ready, so we expect the input format to be WinAnsi, i.e. mostly English // text (with chars < #128) with some values to be inserted inside {$endif} procedure Add(const Format: RawUTF8; const Values: array of const; Escape: TTextWriterKind=twNone; WriteObjectOptions: TTextWriterWriteObjectOptions=[woFullExpand]); overload; /// append some values at once // - text values (e.g. RawUTF8) will be escaped as JSON procedure Add(const Values: array of const); overload; /// append CR+LF (#13#10) chars // - this method won't call EchoAdd() registered events - use AddEndOfLine() // method instead // - AddEndOfLine() will append either CR+LF (#13#10) or LF (#10) depending // on a flag procedure AddCR; /// mark an end of line, ready to be "echoed" to registered listeners // - append a LF (#10) char or CR+LF (#13#10) chars to the buffer, depending // on the EndOfLineCRLF property value (default is LF, to minimize storage) // - any callback registered via EchoAdd() will monitor this line // - used e.g. by TSynLog for console output, as stated by Level parameter procedure AddEndOfLine(aLevel: TSynLogInfo=sllNone); /// append CR+LF (#13#10) chars and #9 indentation // - indentation depth is defined by fHumanReadableLevel protected field procedure AddCRAndIndent; /// write the same character multiple times procedure AddChars(aChar: AnsiChar; aCount: integer); /// append an Integer Value as a 2 digits String with comma procedure Add2(Value: integer); /// append the current UTC date and time, in a log-friendly format // - e.g. append '20110325 19241502' // - you may set LocalTime=TRUE to write the local date and time instead // - this method is very fast, and avoid most calculation or API calls procedure AddCurrentLogTime(LocalTime: boolean); /// append a time period, specified in micro seconds procedure AddMicroSec(MS: cardinal); /// append an Integer Value as a 4 digits String with comma procedure Add4(Value: integer); /// append an Integer Value as a 3 digits String without any added comma procedure Add3(Value: integer); /// append a line of text with CR+LF at the end procedure AddLine(const Text: shortstring); /// append an UTF-8 String, with no JSON escaping procedure AddString(const Text: RawUTF8); /// append several UTF-8 strings procedure AddStrings(const Text: array of RawUTF8); overload; /// append an UTF-8 string several times procedure AddStrings(const Text: RawUTF8; count: integer); overload; /// append a ShortString procedure AddShort(const Text: ShortString); /// append a sub-part of an UTF-8 String // - emulates AddString(copy(Text,start,len)) procedure AddStringCopy(const Text: RawUTF8; start,len: integer); /// append after trim first lowercase chars ('otDone' will add 'Done' e.g.) procedure AddTrimLeftLowerCase(Text: PShortString); /// append a ShortString property name, as '"PropName":' // - PropName content should not need to be JSON escaped (e.g. no " within, // and only ASCII 7-bit characters) // - if twoForceJSONExtended is defined in CustomOptions, it would append // 'PropName:' without the double quotes procedure AddPropName(const PropName: ShortString); /// append a JSON field name, followed by an escaped UTF-8 JSON String and // a comma (',') procedure AddPropJSONString(const PropName: shortstring; const Text: RawUTF8); /// append a JSON field name, followed by a number value and a comma (',') procedure AddPropJSONInt64(const PropName: shortstring; Value: Int64); /// append a RawUTF8 property name, as '"FieldName":' // - FieldName content should not need to be JSON escaped (e.g. no " within) procedure AddFieldName(const FieldName: RawUTF8); overload; {$ifdef HASINLINE}inline;{$endif} /// append a UTF8-encoded property name, as '"FieldName":' // - FieldName content should not need to be JSON escaped (e.g. no " within) procedure AddFieldName(FieldName: PUTF8Char; FieldNameLen: integer); overload; /// append the class name of an Object instance as text // - aClass must be not nil procedure AddClassName(aClass: TClass); /// append an Instance name and pointer, as '"TObjectList(00425E68)"'+SepChar // - Instance must be not nil procedure AddInstanceName(Instance: TObject; SepChar: AnsiChar); /// append an Instance name and pointer, as 'TObjectList(00425E68)'+SepChar // - Instance must be not nil // - overriden version in TJSONSerializer would implement IncludeUnitName procedure AddInstancePointer(Instance: TObject; SepChar: AnsiChar; IncludeUnitName, IncludePointer: boolean); virtual; /// append a quoted string as JSON, with in-place decoding // - if QuotedString does not start with ' or ", it will written directly // (i.e. expects to be a number, or null/true/false constants) // - as used e.g. by TJSONObjectDecoder.EncodeAsJSON method and // JSONEncodeNameSQLValue() function procedure AddQuotedStringAsJSON(const QuotedString: RawUTF8); /// append an array of integers as CSV procedure AddCSVInteger(const Integers: array of Integer); overload; /// append an array of doubles as CSV procedure AddCSVDouble(const Doubles: array of double); overload; /// append an array of RawUTF8 as CSV procedure AddCSVUTF8(const Values: array of RawUTF8); overload; /// append an array of const as CSV procedure AddCSVConst(const Values: array of const); /// write some data Base64 encoded // - if withMagic is TRUE, will write as '"\uFFF0base64encodedbinary"' procedure WrBase64(P: PAnsiChar; Len: cardinal; withMagic: boolean); /// write some record content as binary, Base64 encoded with our magic prefix procedure WrRecord(const Rec; TypeInfo: pointer); /// write some #0 ended UTF-8 text, according to the specified format // - if Escape is a constant, consider calling directly AddNoJSONEscape, // AddJSONEscape or AddOnSameLine methods procedure Add(P: PUTF8Char; Escape: TTextWriterKind); overload; /// write some #0 ended UTF-8 text, according to the specified format // - if Escape is a constant, consider calling directly AddNoJSONEscape, // AddJSONEscape or AddOnSameLine methods procedure Add(P: PUTF8Char; Len: PtrInt; Escape: TTextWriterKind); overload; /// write some #0 ended Unicode text as UTF-8, according to the specified format // - if Escape is a constant, consider calling directly AddNoJSONEscapeW, // AddJSONEscapeW or AddOnSameLineW methods procedure AddW(P: PWord; Len: PtrInt; Escape: TTextWriterKind); /// append some UTF-8 encoded chars to the buffer, from the main AnsiString type // - use the current system code page for AnsiString parameter procedure AddAnsiString(const s: AnsiString; Escape: TTextWriterKind); overload; /// append some UTF-8 encoded chars to the buffer, from any AnsiString value // - if CodePage is left to its default value of -1, it will assume // CurrentAnsiConvert.CodePage prior to Delphi 2009, but newer UNICODE // versions of Delphi will retrieve the code page from string // - if CodePage is defined to a >= 0 value, the encoding will take place procedure AddAnyAnsiString(const s: RawByteString; Escape: TTextWriterKind; CodePage: Integer=-1); /// append some UTF-8 encoded chars to the buffer, from any Ansi buffer // - the codepage should be specified, e.g. CP_UTF8, CP_RAWBYTESTRING, // CODEPAGE_US, or any version supported by the Operating System // - if codepage is 0, the current CurrentAnsiConvert.CodePage would be used // - will use TSynAnsiConvert to perform the conversion to UTF-8 procedure AddAnyAnsiBuffer(P: PAnsiChar; Len: integer; Escape: TTextWriterKind; CodePage: Integer); /// append some UTF-8 chars to the buffer // - input length is calculated from zero-ended char // - don't escapes chars according to the JSON RFC procedure AddNoJSONEscape(P: Pointer); overload; /// append some UTF-8 chars to the buffer // - don't escapes chars according to the JSON RFC procedure AddNoJSONEscape(P: Pointer; Len: PtrInt); overload; /// append some UTF-8 chars to the buffer // - don't escapes chars according to the JSON RFC procedure AddNoJSONEscapeUTF8(const text: RawByteString); {$ifdef HASINLINE}inline;{$endif} /// flush a supplied TTextWriter, and write pending data as JSON escaped text // - may be used with InternalJSONWriter, as a faster alternative to // ! AddNoJSONEscapeUTF8(Source.Text); procedure AddNoJSONEscape(Source: TTextWriter); overload; /// append some UTF-8 chars to the buffer // - if supplied json is '', will write 'null' procedure AddRawJSON(const json: RawJSON); /// append some chars, quoting all " chars // - same algorithm than AddString(QuotedStr()) - without memory allocation, // and with an optional maximum text length (truncated with ending '...') // - this function implements what is specified in the official SQLite3 // documentation: "A string constant is formed by enclosing the string in single // quotes ('). A single quote within the string can be encoded by putting two // single quotes in a row - as in Pascal." procedure AddQuotedStr(Text: PUTF8Char; Quote: AnsiChar; TextMaxLen: integer=0); /// append some chars, escaping all HTML special chars as expected procedure AddHtmlEscape(Text: PUTF8Char; Fmt: TTextWriterHTMLFormat=hfAnyWhere); overload; /// append some chars, escaping all HTML special chars as expected procedure AddHtmlEscape(Text: PUTF8Char; TextLen: integer; Fmt: TTextWriterHTMLFormat=hfAnyWhere); overload; /// append some chars, escaping all HTML special chars as expected procedure AddHtmlEscapeString(const Text: string; Fmt: TTextWriterHTMLFormat=hfAnyWhere); /// append some chars, escaping all HTML special chars as expected procedure AddHtmlEscapeUTF8(const Text: RawUTF8; Fmt: TTextWriterHTMLFormat=hfAnyWhere); /// convert some wiki-like text into proper HTML // - convert all #13#10 into

...

, *..* into .. and +..+ into // .., then escape http:// as and any HTML special chars procedure AddHtmlEscapeWiki(P: PUTF8Char); /// append some chars, escaping all XML special chars as expected // - i.e. < > & " ' as < > & "e; ' // - and all control chars (i.e. #1..#31) as &#..; // - see @http://www.w3.org/TR/xml/#syntax procedure AddXmlEscape(Text: PUTF8Char); /// append some chars, replacing a given character with another procedure AddReplace(Text: PUTF8Char; Orig,Replaced: AnsiChar); /// append some binary data as hexadecimal text conversion procedure AddBinToHex(Bin: Pointer; BinBytes: integer); /// fast conversion from binary data into hexa chars, ready to be displayed // - using this function with Bin^ as an integer value will serialize it // in big-endian order (most-significant byte first), as used by humans // - up to the internal buffer bytes may be converted procedure AddBinToHexDisplay(Bin: pointer; BinBytes: integer); /// fast conversion from binary data into MSB hexa chars // - up to the internal buffer bytes may be converted procedure AddBinToHexDisplayLower(Bin: pointer; BinBytes: integer); /// fast conversion from binary data into quoted MSB lowercase hexa chars // - up to the internal buffer bytes may be converted procedure AddBinToHexDisplayQuoted(Bin: pointer; BinBytes: integer); /// append a Value as significant hexadecimal text // - append its minimal size, i.e. excluding highest bytes containing 0 // - use GetNextItemHexa() to decode such a text value procedure AddBinToHexDisplayMinChars(Bin: pointer; BinBytes: PtrInt); /// add the pointer into significant hexa chars, ready to be displayed procedure AddPointer(P: PtrUInt); {$ifdef HASINLINE}inline;{$endif} /// write a byte as hexa chars procedure AddByteToHex(Value: byte); /// write a Int18 value (0..262143) as 3 chars // - this encoding is faster than Base64, and has spaces on the left side // - use function Chars3ToInt18() to decode the textual content procedure AddInt18ToChars3(Value: cardinal); /// append some unicode chars to the buffer // - WideCharCount is the unicode chars count, not the byte size // - don't escapes chars according to the JSON RFC // - will convert the Unicode chars into UTF-8 procedure AddNoJSONEscapeW(WideChar: PWord; WideCharCount: integer); /// append some UTF-8 encoded chars to the buffer // - if Len is 0, Len is calculated from zero-ended char // - escapes chars according to the JSON RFC procedure AddJSONEscape(P: Pointer; Len: PtrInt=0); overload; /// append some UTF-8 encoded chars to the buffer, from a generic string type // - faster than AddJSONEscape(pointer(StringToUTF8(string)) // - escapes chars according to the JSON RFC procedure AddJSONEscapeString(const s: string); {$ifdef HASINLINE}inline;{$endif} /// append some UTF-8 encoded chars to the buffer, from the main AnsiString type // - escapes chars according to the JSON RFC procedure AddJSONEscapeAnsiString(const s: AnsiString); /// append some UTF-8 encoded chars to the buffer, from a generic string type // - faster than AddNoJSONEscape(pointer(StringToUTF8(string)) // - don't escapes chars according to the JSON RFC // - will convert the Unicode chars into UTF-8 procedure AddNoJSONEscapeString(const s: string); {$ifdef UNICODE}inline;{$endif} /// append some Unicode encoded chars to the buffer // - if Len is 0, Len is calculated from zero-ended widechar // - escapes chars according to the JSON RFC procedure AddJSONEscapeW(P: PWord; Len: PtrInt=0); /// append an open array constant value to the buffer // - "" will be added if necessary // - escapes chars according to the JSON RFC // - very fast (avoid most temporary storage) procedure AddJSONEscape(const V: TVarRec); overload; /// flush a supplied TTextWriter, and write pending data as JSON escaped text // - may be used with InternalJSONWriter, as a faster alternative to // ! AddJSONEscape(Pointer(fInternalJSONWriter.Text),0); procedure AddJSONEscape(Source: TTextWriter); overload; /// append a UTF-8 JSON String, between double quotes and with JSON escaping procedure AddJSONString(const Text: RawUTF8); /// append an open array constant value to the buffer // - "" won't be added for string values // - string values may be escaped, depending on the supplied parameter // - very fast (avoid most temporary storage) procedure Add(const V: TVarRec; Escape: TTextWriterKind=twNone; WriteObjectOptions: TTextWriterWriteObjectOptions=[woFullExpand]); overload; /// encode the supplied data as an UTF-8 valid JSON object content // - data must be supplied two by two, as Name,Value pairs, e.g. // ! aWriter.AddJSONEscape(['name','John','year',1972]); // will append to the buffer: // ! '{"name":"John","year":1972}' // - or you can specify nested arrays or objects with '['..']' or '{'..'}': // ! aWriter.AddJSONEscape(['doc','{','name','John','ab','[','a','b']','}','id',123]); // will append to the buffer: // ! '{"doc":{"name":"John","abc":["a","b"]},"id":123}' // - note that, due to a Delphi compiler limitation, cardinal values should be // type-casted to Int64() (otherwise the integer mapped value will be converted) // - you can pass nil as parameter for a null JSON value procedure AddJSONEscape(const NameValuePairs: array of const); overload; {$ifndef NOVARIANTS} /// encode the supplied (extended) JSON content, with parameters, // as an UTF-8 valid JSON object content // - in addition to the JSON RFC specification strict mode, this method will // handle some BSON-like extensions, e.g. unquoted field names: // ! aWriter.AddJSON('{id:?,%:{name:?,birthyear:?}}',['doc'],[10,'John',1982]); // - you can use nested _Obj() / _Arr() instances // ! aWriter.AddJSON('{%:{$in:[?,?]}}',['type'],['food','snack']); // ! aWriter.AddJSON('{type:{$in:?}}',[],[_Arr(['food','snack'])]); // ! // which are the same as: // ! aWriter.AddShort('{"type":{"$in":["food","snack"]}}'); // - if the SynMongoDB unit is used in the application, the MongoDB Shell // syntax will also be recognized to create TBSONVariant, like // ! new Date() ObjectId() MinKey MaxKey // // see @http://docs.mongodb.org/manual/reference/mongodb-extended-json // ! aWriter.AddJSON('{name:?,field:/%/i}',['acme.*corp'],['John'])) // ! // will write // ! '{"name":"John","field":{"$regex":"acme.*corp","$options":"i"}}' // - will call internally _JSONFastFmt() to create a temporary TDocVariant // with all its features - so is slightly slower than other AddJSON* methods procedure AddJSON(const Format: RawUTF8; const Args,Params: array of const); {$endif} /// append two JSON arrays of keys and values as one JSON object // - i.e. makes the following transformation: // $ [key1,key2...] + [value1,value2...] -> {key1:value1,key2,value2...} // - this method won't allocate any memory during its process, nor // modify the keys and values input buffers // - is the reverse of the JSONObjectAsJSONArrays() function procedure AddJSONArraysAsJSONObject(keys,values: PUTF8Char); /// append a dynamic array content as UTF-8 encoded JSON array // - expect a dynamic array TDynArray wrapper as incoming parameter // - TIntegerDynArray, TInt64DynArray, TCardinalDynArray, TDoubleDynArray, // TCurrencyDynArray, TWordDynArray and TByteDynArray will be written as // numerical JSON values // - TRawUTF8DynArray, TWinAnsiDynArray, TRawByteStringDynArray, // TStringDynArray, TWideStringDynArray, TSynUnicodeDynArray, TTimeLogDynArray, // and TDateTimeDynArray will be written as escaped UTF-8 JSON strings // (and Iso-8601 textual encoding if necessary) // - you can add some custom serializers via RegisterCustomJSONSerializer() // class method, to serialize any dynamic array as valid JSON // - any other non-standard or non-registered kind of dynamic array (including // array of records) will be written as Base64 encoded binary stream, with a // JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) - this will // include TBytes (i.e. array of bytes) content, which is a good candidate // for BLOB stream // - typical content could be // ! '[1,2,3,4]' or '["\uFFF0base64encodedbinary"]' // - by default, custom serializers defined via RegisterCustomJSONSerializer() // would write enumerates and sets as integer numbers, unless // twoEnumSetsAsTextInRecord is set in the instance Options procedure AddDynArrayJSON(var aDynArray: TDynArray); overload; /// append a dynamic array content as UTF-8 encoded JSON array // - expect a dynamic array TDynArrayHashed wrapper as incoming parameter procedure AddDynArrayJSON(var aDynArray: TDynArrayHashed); overload; {$ifdef HASINLINE}inline;{$endif} /// append a dynamic array content as UTF-8 encoded JSON array // - just a wrapper around the other overloaded method, creating a // temporary TDynArray wrapper on the stack // - to be used e.g. for custom record JSON serialization, within a // TDynArrayJSONCustomWriter callback procedure AddDynArrayJSON(aTypeInfo: pointer; const aValue); overload; /// same as AddDynArrayJSON(), but will double all internal " and bound with " // - this implementation will avoid most memory allocations procedure AddDynArrayJSONAsString(aTypeInfo: pointer; var aValue); /// append a T*ObjArray dynamic array as a JSON array // - as expected by TJSONSerializer.RegisterObjArrayForJSON() procedure AddObjArrayJSON(const aObjArray; aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]); /// append a record content as UTF-8 encoded JSON or custom serialization // - default serialization will use Base64 encoded binary stream, or // a custom serialization, in case of a previous registration via // RegisterCustomJSONSerializer() class method - from a dynamic array // handling this kind of records, or directly from TypeInfo() of the record // - by default, custom serializers defined via RegisterCustomJSONSerializer() // would write enumerates and sets as integer numbers, unless // twoEnumSetsAsTextInRecord or twoEnumSetsAsBooleanInRecord is set in // the instance CustomOptions procedure AddRecordJSON(const Rec; TypeInfo: pointer); {$ifndef NOVARIANTS} /// append a variant content as number or string // - default Escape=twJSONEscape will create valid JSON content, which // can be converted back to a variant value using VariantLoadJSON() // - default JSON serialization options would apply, unless // twoForceJSONExtended or twoForceJSONStandard is defined // - note that before Delphi 2009, any varString value is expected to be // a RawUTF8 instance - which does make sense in the mORMot context procedure AddVariant(const Value: variant; Escape: TTextWriterKind=twJSONEscape); {$endif} /// append a void record content as UTF-8 encoded JSON or custom serialization // - this method will first create a void record (i.e. filled with #0 bytes) // then save its content with default or custom serialization procedure AddVoidRecordJSON(TypeInfo: pointer); /// append a JSON value from its RTTI type // - handle tkClass,tkEnumeration,tkSet,tkRecord,tkDynArray,tkVariant types // - write null for other types procedure AddTypedJSON(aTypeInfo: pointer; const aValue); /// serialize as JSON the given object // - this default implementation will write null, or only write the // class name and pointer if FullExpand is true - use TJSONSerializer. // WriteObject method for full RTTI handling // - default implementation will write TList/TCollection/TStrings/TRawUTF8List // as appropriate array of class name/pointer (if woFullExpand is set) procedure WriteObject(Value: TObject; Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]); virtual; /// same as WriteObject(), but will double all internal " and bound with " // - this implementation will avoid most memory allocations procedure WriteObjectAsString(Value: TObject; Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]); /// append a JSON value, array or document as simple XML content // - you can use JSONBufferToXML() and JSONToXML() functions as wrappers // - this method is called recursively to handle all kind of JSON values // - WARNING: the JSON buffer is decoded in-place, so will be changed // - returns the end of the current JSON converted level, or nil if the // supplied content was not correct JSON function AddJSONToXML(JSON: PUTF8Char; ArrayName: PUTF8Char=nil; EndOfObject: PUTF8Char=nil): PUTF8Char; /// append a JSON value, array or document, in a specified format // - will parse the JSON buffer and write its content with proper line // feeds and indentation, according to the supplied TTextWriterJSONFormat // - see also JSONReformat() and JSONBufferReformat() wrappers // - this method is called recursively to handle all kind of JSON values // - WARNING: the JSON buffer is decoded in-place, so will be changed // - returns the end of the current JSON converted level, or nil if the // supplied content was not valid JSON function AddJSONReformat(JSON: PUTF8Char; Format: TTextWriterJSONFormat; EndOfObject: PUTF8Char): PUTF8Char; /// define a custom serialization for a given dynamic array or record // - expects TypeInfo() from a dynamic array or a record (will raise an // exception otherwise) // - for a dynamic array, the associated item record RTTI will be registered // - for a record, any matching dynamic array will also be registered // - by default, TIntegerDynArray and such known classes are processed as // true JSON arrays: but you can specify here some callbacks to perform // the serialization process for any kind of dynamic array // - any previous registration is overridden // - setting both aReader=aWriter=nil will return back to the default // binary + Base64 encoding serialization (i.e. undefine custom serializer) class procedure RegisterCustomJSONSerializer(aTypeInfo: pointer; aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); {$ifndef NOVARIANTS} /// define a custom serialization for a given variant custom type // - used e.g. to serialize TBCD values class procedure RegisterCustomJSONSerializerForVariant(aClass: TCustomVariantType; aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); /// define a custom serialization for a given variant custom type // - used e.g. to serialize TBCD values class procedure RegisterCustomJSONSerializerForVariantByType(aVarType: TVarType; aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); {$endif NOVARIANTS} /// define a custom serialization for a given dynamic array or record // - the RTTI information will here be defined as plain text // - since Delphi 2010, you can call directly // RegisterCustomJSONSerializerFromTextSimpleType() // - aTypeInfo may be valid TypeInfo(), or any fixed pointer value if the // record does not have any RTTI (e.g. a record without any nested reference- // counted types) // - the record where the data will be stored should be defined as PACKED: // ! type TMyRecord = packed record // ! A,B,C: integer; // ! D: RawUTF8; // ! E: record; // or array of record/integer/string/... // ! E1,E2: double; // ! end; // ! end; // - call this method with aRTTIDefinition='' to return back to the default // binary + Base64 encoding serialization (i.e. undefine custom serializer) // - only known sub types are byte, word, integer, cardinal, Int64, single, // double, currency, TDateTime, TTimeLog, RawUTF8, String, WideString, // SynUnicode, TGUID (encoded via GUIDToText) or a nested record or dynamic // array of the same simple types or record // - RTTI textual information shall be supplied as text, with the // same format as with a pascal record: // ! 'A,B,C: integer; D: RawUTF8; E: record E1,E2: double;' // ! 'A,B,C: integer; D: RawUTF8; E: array of record E1,E2: double;' // ! 'A,B,C: integer; D: RawUTF8; E: array of SynUnicode; F: array of TGUID' // or a shorter alternative syntax for records and arrays: // ! 'A,B,C: integer; D: RawUTF8; E: {E1,E2: double}' // ! 'A,B,C: integer; D: RawUTF8; E: [E1,E2: double]' // in fact ; could be ignored: // ! 'A,B,C:integer D:RawUTF8 E:{E1,E2:double}' // ! 'A,B,C:integer D:RawUTF8 E:[E1,E2:double]' // or even : could be ignored: // ! 'A,B,C integer D RawUTF8 E{E1,E2 double}' // ! 'A,B,C integer D RawUTF8 E[E1,E2 double]' // - it will return the cached TJSONRecordTextDefinition // instance corresponding to the supplied RTTI text definition class function RegisterCustomJSONSerializerFromText(aTypeInfo: pointer; const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; overload; /// define a custom serialization for several dynamic arrays or records // - the TypeInfo() and textual RTTI information will here be defined as // ([TypeInfo(TType1),_TType1,TypeInfo(TType2),_TType2]) pairs // - a wrapper around the overloaded RegisterCustomJSONSerializerFromText() class procedure RegisterCustomJSONSerializerFromText( const aTypeInfoTextDefinitionPairs: array of const); overload; /// change options for custom serialization of dynamic array or record // - will return TRUE if the options have been changed, FALSE if the // supplied type info was not previously registered // - if AddIfNotExisting is TRUE, and enhanced RTTI is available (since // Delphi 2010), you would be able to customize the options of this type class function RegisterCustomJSONSerializerSetOptions(aTypeInfo: pointer; aOptions: TJSONCustomParserSerializationOptions; aAddIfNotExisting: boolean=false): boolean; overload; /// change options for custom serialization of dynamic arrays or records // - will return TRUE if the options have been changed, FALSE if the // supplied type info was not previously registered for at least one type // - if AddIfNotExisting is TRUE, and enhanced RTTI is available (since // Delphi 2010), you would be able to customize the options of this type class function RegisterCustomJSONSerializerSetOptions( const aTypeInfo: array of pointer; aOptions: TJSONCustomParserSerializationOptions; aAddIfNotExisting: boolean=false): boolean; overload; /// retrieve a previously registered custom parser instance from its type // - will return nil if the type info was not available, or defined just // with some callbacks // - if AddIfNotExisting is TRUE, and enhanced RTTI is available (since // Delphi 2010), you would be able to retrieve this type's parser even // if the record type has not been previously used class function RegisterCustomJSONSerializerFindParser( aTypeInfo: pointer; aAddIfNotExisting: boolean=false): TJSONRecordAbstract; /// define a custom serialization for a given simple type // - you should be able to use this type in the RTTI text definition // of any further RegisterCustomJSONSerializerFromText() call // - the RTTI information should be enough to serialize the type from // its name (e.g. an enumeration for older Delphi revision, but all records // since Delphi 2010) // - you can supply a custom type name, which will be registered in addition // to the "official" name defined at RTTI level // - on older Delphi versions (up to Delphi 2009), it will handle only // enumerations, which will be transmitted as JSON string instead of numbers // - since Delphi 2010, any record type can be supplied - which is more // convenient than calling RegisterCustomJSONSerializerFromText() class procedure RegisterCustomJSONSerializerFromTextSimpleType(aTypeInfo: pointer; const aTypeName: RawUTF8=''); overload; /// define a custom binary serialization for a given simple type // - you should be able to use this type in the RTTI text definition // of any further RegisterCustomJSONSerializerFromText() call // - data will be serialized as BinToHexDisplayLower() JSON hexadecimal string // - you can truncate the original data size (e.g. if all bits of an integer // are not used) by specifying the aFieldSize optional parameter class procedure RegisterCustomJSONSerializerFromTextBinaryType(aTypeInfo: pointer; aDataSize: integer; aFieldSize: integer=0); overload; /// define custom binary serialization for several simple types // - data will be serialized as BinToHexDisplayLower() JSON hexadecimal string // - the TypeInfo() and associated size information will here be defined as triplets: // ([TypeInfo(TType1),SizeOf(TType1),TYPE1_BYTES,TypeInfo(TType2),SizeOf(TType2),TYPE2_BYTES]) // - a wrapper around the overloaded RegisterCustomJSONSerializerFromTextBinaryType() class procedure RegisterCustomJSONSerializerFromTextBinaryType( const aTypeInfoDataFieldSize: array of const); overload; /// define a custom serialization for several simple types // - will call the overloaded RegisterCustomJSONSerializerFromTextSimpleType // method for each supplied type information class procedure RegisterCustomJSONSerializerFromTextSimpleType( const aTypeInfos: array of pointer); overload; /// undefine a custom serialization for a given dynamic array or record // - it will un-register any callback or text-based custom serialization // i.e. any previous RegisterCustomJSONSerializer() or // RegisterCustomJSONSerializerFromText() call // - expects TypeInfo() from a dynamic array or a record (will raise an // exception otherwise) // - it will set back to the default binary + Base64 encoding serialization class procedure UnRegisterCustomJSONSerializer(aTypeInfo: pointer); /// append some chars to the buffer in one line // - P should be ended with a #0 // - will write #1..#31 chars as spaces (so content will stay on the same line) procedure AddOnSameLine(P: PUTF8Char); overload; /// append some chars to the buffer in one line // - will write #0..#31 chars as spaces (so content will stay on the same line) procedure AddOnSameLine(P: PUTF8Char; Len: PtrInt); overload; /// append some wide chars to the buffer in one line // - will write #0..#31 chars as spaces (so content will stay on the same line) procedure AddOnSameLineW(P: PWord; Len: PtrInt); /// return the last char appended function LastChar: AnsiChar; /// how many bytes are currently in the internal buffer and not on disk // - see TextLength for the total number of bytes, on both disk and memory function PendingBytes: PtrUInt; {$ifdef HASINLINE}inline;{$endif} /// how many bytes were currently written on disk // - excluding the bytes in the internal buffer // - see TextLength for the total number of bytes, on both disk and memory property WrittenBytes: PtrUInt read fTotalFileSize; /// the last char appended is canceled procedure CancelLastChar; overload; {$ifdef HASINLINE}inline;{$endif} /// the last char appended is canceled, if match the supplied one procedure CancelLastChar(aCharToCancel: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif} /// the last char appended is canceled if it was a ',' procedure CancelLastComma; {$ifdef HASINLINE}inline;{$endif} /// rewind the Stream to the position when Create() was called // - note that this does not clear the Stream content itself, just // move back its writing position to its initial place procedure CancelAll; /// count of added bytes to the stream // - see PendingBytes for the number of bytes currently in the memory buffer // or WrittenBytes for the number of bytes already written to disk property TextLength: PtrUInt read GetTextLength; /// define how AddEndOfLine method stores its line feed characters // - by default (FALSE), it will append a LF (#10) char to the buffer // - you can set this property to TRUE, so that CR+LF (#13#10) chars will // be appended instead // - is just a wrapper around twoEndOfLineCRLF item in CustomOptions property EndOfLineCRLF: boolean read GetEndOfLineCRLF write SetEndOfLineCRLF; /// allows to override default WriteObject property JSON serialization property OnWriteObject: TOnTextWriterObjectProp read fOnWriteObject write fOnWriteObject; /// the internal TStream used for storage // - you should call the FlushFinal (or FlushToStream) methods before using // this TStream content, to flush all pending characters // - if the TStream instance has not been specified when calling the // TTextWriter constructor, it can be forced via this property, before // any writting property Stream: TStream read fStream write SetStream; /// global options to customize this TTextWriter instance process // - allows to override e.g. AddRecordJSON() and AddDynArrayJSON() behavior property CustomOptions: TTextWriterOptions read fCustomOptions write fCustomOptions; end; /// serialize most kind of content as JSON, using its RTTI // - is just a wrapper around TTextWriter.AddTypedJSON() // - so would handle tkClass, tkEnumeration, tkSet, tkRecord, tkDynArray, // tkVariant kind of content - other kinds would return 'null' // - you can override serialization options if needed procedure SaveJSON(const Value; TypeInfo: pointer; Options: TTextWriterOptions; var result: RawUTF8); overload; /// serialize most kind of content as JSON, using its RTTI // - is just a wrapper around TTextWriter.AddTypedJSON() // - so would handle tkClass, tkEnumeration, tkSet, tkRecord, tkDynArray, // tkVariant kind of content - other kinds would return 'null' function SaveJSON(const Value; TypeInfo: pointer; EnumSetsAsText: boolean=false): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// will serialize any TObject into its UTF-8 JSON representation /// - serialize as JSON the published integer, Int64, floating point values, // TDateTime (stored as ISO 8601 text), string, variant and enumerate // (e.g. boolean) properties of the object (and its parents) // - would set twoForceJSONStandard to force standard (non-extended) JSON // - the enumerates properties are stored with their integer index value // - will write also the properties published in the parent classes // - nested properties are serialized as nested JSON objects // - any TCollection property will also be serialized as JSON arrays // - you can add some custom serializers for ANY Delphi class, via mORMot.pas' // TJSONSerializer.RegisterCustomSerializer() class method // - call internaly TJSONSerializer.WriteObject() method (or fallback to // TJSONWriter if mORMot.pas is not linked to the executable) function ObjectToJSON(Value: TObject; Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8; /// will serialize set of TObject into its UTF-8 JSON representation // - follows ObjectToJSON()/TTextWriter.WriterObject() functions output // - if Names is not supplied, the corresponding class names would be used function ObjectsToJSON(const Names: array of RawUTF8; const Values: array of TObject; Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8; type /// implement a cache of some key/value pairs, e.g. to improve reading speed // - used e.g. by TSQLDataBase for caching the SELECT statements results in an // internal JSON format (which is faster than a query to the SQLite3 engine) // - internally make use of an efficient hashing algorithm for fast response // (i.e. TSynNameValue will use the TDynArrayHashed wrapper mechanism) // - this class is thread-safe if you use properly the associated Safe lock TSynCache = class(TSynPersistentLock) protected /// last index in fNameValue.List[] if was added by Find() // - contains -1 if no previous immediate call to Find() fFindLastAddedIndex: integer; fFindLastKey: RawUTF8; fNameValue: TSynNameValue; fRamUsed: cardinal; fMaxRamUsed: cardinal; fTimeoutSeconds: cardinal; fTimeoutTix: cardinal; procedure ResetIfNeeded; public /// initialize the internal storage // - aMaxCacheRamUsed can set the maximum RAM to be used for values, in bytes // (default is 16 MB), after which the cache is flushed // - by default, key search is done case-insensitively, but you can specify // another option here // - by default, there is no timeout period, but you may specify a number of // seconds of inactivity (i.e. no Add call) after which the cache is flushed constructor Create(aMaxCacheRamUsed: cardinal=16 shl 20; aCaseSensitive: boolean=false; aTimeoutSeconds: cardinal=0); reintroduce; /// find a Key in the cache entries // - return '' if nothing found: you may call Add() just after to insert // the expected value in the cache // - return the associated Value otherwise, and the associated integer tag // if aResultTag address is supplied // - this method is not thread-safe, unless you call Safe.Lock before // calling Find(), and Safe.Unlock after calling Add() function Find(const aKey: RawUTF8; aResultTag: PPtrInt=nil): RawUTF8; /// add a Key and its associated value (and tag) to the cache entries // - you MUST always call Find() with the associated Key first // - this method is not thread-safe, unless you call Safe.Lock before // calling Find(), and Safe.Unlock after calling Add() procedure Add(const aValue: RawUTF8; aTag: PtrInt); /// add a Key/Value pair in the cache entries // - returns true if aKey was not existing yet, and aValue has been stored // - returns false if aKey did already exist in the internal cache, and // its entry has been updated with the supplied aValue/aTag // - this method is thread-safe, using the Safe locker of this instance function AddOrUpdate(const aKey, aValue: RawUTF8; aTag: PtrInt): boolean; /// called after a write access to the database to flush the cache // - set Count to 0 // - release all cache memory // - returns TRUE if was flushed, i.e. if there was something in cache // - this method is thread-safe, using the Safe locker of this instance function Reset: boolean; /// number of entries in the cache function Count: integer; /// access to the internal locker, for thread-safe process // - Find/Add methods calls should be protected as such: // ! cache.Safe.Lock; // ! try // ! ... cache.Find/cache.Add ... // ! finally // ! cache.Safe.Unlock; // ! end; property Safe: PSynLocker read fSafe; /// the current global size of Values in RAM cache, in bytes property RamUsed: cardinal read fRamUsed; /// the maximum RAM to be used for values, in bytes // - the cache is flushed when ValueSize reaches this limit // - default is 16 MB (16 shl 20) property MaxRamUsed: cardinal read fMaxRamUsed; /// after how many seconds betwen Add() calls the cache should be flushed // - equals 0 by default, meaning no time out property TimeoutSeconds: cardinal read fTimeoutSeconds; end; /// abstract ancestor to manage a dynamic array of TObject // - do not use this abstract class directly, but rather the inherited // TObjectListHashed and TObjectListPropertyHashed TObjectListHashedAbstract = class protected fList: TObjectDynArray; fCount: integer; fHash: TDynArrayHashed; fFreeItems: boolean; public /// initialize the class instance // - if aFreeItems is TRUE (default), will behave like a TObjectList // - if aFreeItems is FALSE, will behave like a TList constructor Create(aFreeItems: boolean=true); reintroduce; /// release used memory destructor Destroy; override; /// search and add an object reference to the list // - returns the found/added index function Add(aObject: TObject; out wasAdded: boolean): integer; virtual; abstract; /// retrieve an object index within the list, using a fast hash table // - returns -1 if not found function IndexOf(aObject: TObject): integer; virtual; abstract; /// delete an object from the list procedure Delete(aIndex: integer); overload; /// delete an object from the list procedure Delete(aObject: TObject); overload; /// direct access to the items list array property List: TObjectDynArray read fList; /// returns the count of stored objects property Count: integer read fCount; /// direct access to the underlying hashing engine property Hash: TDynArrayHashed read fHash; end; /// this class behaves like TList/TObjectList, but will use hashing // for (much) faster IndexOf() method TObjectListHashed = class(TObjectListHashedAbstract) public /// search and add an object reference to the list // - returns the found/added index // - if added, hash is stored and Items[] := aObject function Add(aObject: TObject; out wasAdded: boolean): integer; override; /// retrieve an object index within the list, using a fast hash table // - returns -1 if not found function IndexOf(aObject: TObject): integer; override; end; /// function prototype used to retrieve a pointer to the hashed property // value of a TObjectListPropertyHashed list TObjectListPropertyHashedAccessProp = function(aObject: TObject): pointer; /// this class will hash and search for a sub property of the stored objects TObjectListPropertyHashed = class(TObjectListHashedAbstract) protected fSubPropAccess: TObjectListPropertyHashedAccessProp; function IntHash(const Elem): cardinal; function IntComp(const A,B): integer; public /// initialize the class instance with the corresponding callback in order // to handle sub-property hashing and search // - see TSetWeakZeroClass in mORMot.pas unit as example: // ! function WeakZeroClassSubProp(aObject: TObject): TObject; // ! begin // ! result := TSetWeakZeroInstance(aObject).fInstance; // ! end; // - by default, aHashElement/aCompare will hash/search for pointers: // you can specify the hash/search methods according to your sub property // (e.g. HashAnsiStringI/SortDynArrayAnsiStringI for a RawUTF8) // - if aFreeItems is TRUE (default), will behave like a TObjectList; // if aFreeItems is FALSE, will behave like a TList constructor Create(aSubPropAccess: TObjectListPropertyHashedAccessProp; aHashElement: TDynArrayHashOne=nil; aCompare: TDynArraySortCompare=nil; aFreeItems: boolean=true); reintroduce; /// search and add an object reference to the list // - returns the found/added index // - if added, only the hash is stored: caller has to set List[i] function Add(aObject: TObject; out wasAdded: boolean): integer; override; /// retrieve an object index within the list, using a fast hash table // - returns -1 if not found function IndexOf(aObject: TObject): integer; override; end; /// abstract class stored by a TPointerClassHash list TPointerClassHashed = class protected fInfo: pointer; public /// initialize the instance constructor Create(aInfo: pointer); /// the associated information of this instance // - may be e.g. a PTypeInfo value, when caching RTTI information property Info: pointer read fInfo write fInfo; end; /// a reference to a TPointerClassHashed instance PPointerClassHashed = ^TPointerClassHashed; /// handle a O(1) hashed-based storage of TPointerClassHashed, from a pointer // - used e.g. to store RTTI information from its PTypeInfo value // - if not thread safe, but could be used to store RTTI, since all type // information should have been initialized before actual process TPointerClassHash = class(TObjectListPropertyHashed) public /// initialize the storage list constructor Create; /// try to add an entry to the storage // - returns nil if the supplied information is already in the list // - returns a pointer to where a newly created TPointerClassHashed // instance should be stored // - this method is not thread-safe function TryAdd(aInfo: pointer): PPointerClassHashed; /// search for a stored instance, from its supplied pointer reference // - returns nil if aInfo was not previously added by FindOrAdd() // - this method is not thread-safe function Find(aInfo: pointer): TPointerClassHashed; end; /// handle a O(1) hashed-based storage of TPointerClassHashed, from a pointer // - this inherited class add a mutex to be thread-safe TPointerClassHashLocked = class(TPointerClassHash) protected fSafe: TSynLocker; public /// initialize the storage list constructor Create; /// finalize the storage list destructor Destroy; override; /// try to add an entry to the storage // - returns false if the supplied information is already in the list // - returns true, and a pointer to where a newly created TPointerClassHashed // instance should be stored: in this case, you should call UnLock once set // - could be used as such: // !var entry: PPointerClassHashed; // !... // ! if HashList.TryAddLocked(aTypeInfo,entry) then // ! try // ! entry^ := TMyCustomPointerClassHashed.Create(aTypeInfo,...); // ! finally // ! HashList.Unlock; // ! end; // !... function TryAddLocked(aInfo: pointer; out aNewEntry: PPointerClassHashed): boolean; /// release the lock after a previous TryAddLocked()=true call procedure Unlock; /// search for a stored instance, from its supplied pointer reference // - returns nil if aInfo was not previously added by FindOrAdd() // - this overriden method is thread-safe function FindLocked(aInfo: pointer): TPointerClassHashed; end; /// add locking methods to a standard TObjectList // - this class overrides the regular TObjectList, and do not share any code // with the TObjectListHashedAbstract/TObjectListHashed classes // - caller has to call the Safe.Lock/Unlock methods by hand to protect the // execution of regular TObjectList methods (like Add/Remove/Count...), // or use the SafeAdd/SafeRemove/SafeExists/SafeCount wrapper methods TObjectListLocked = class(TObjectList) protected fSafe: TSynLocker; public /// initialize the list instance // - the stored TObject instances will be owned by this TObjectListLocked, // unless AOwnsObjects is set to false constructor Create(AOwnsObjects: Boolean=true); reintroduce; /// release the list instance (including the locking resource) destructor Destroy; override; /// Add an TObject instance using the global critical section function SafeAdd(AObject: TObject): integer; /// find and delete a TObject instance using the global critical section function SafeRemove(AObject: TObject): integer; /// find a TObject instance using the global critical section function SafeExists(AObject: TObject): boolean; /// returns the number of instances stored using the global critical section function SafeCount: integer; /// delete all items of the list using global critical section procedure SafeClear; /// the critical section associated to this list instance // - could be used to protect shared resources within the internal process // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block property Safe: TSynLocker read fSafe; end; /// TStringList-class optimized to work with our native UTF-8 string type // - cross-compiler, from Delphi 6 and up, i.e is Unicode Ready for all TRawUTF8List = class protected fCount: PtrInt; fList: TRawUTF8DynArray; fObjects: TObjectDynArray; fObjectsOwned: boolean; fNameValueSep: AnsiChar; fCaseSensitive: boolean; fOnChange, fOnChangeHidden: TNotifyEvent; fOnChangeTrigerred: boolean; fOnChangeLevel: PtrInt; procedure Changed; virtual; procedure OnChangeHidden(Sender: TObject); procedure SetCapacity(const Value: PtrInt); function GetCapacity: PtrInt; procedure Put(Index: PtrInt; const Value: RawUTF8); function GetCount: PtrInt; {$ifdef HASINLINE}inline;{$endif} procedure PutObject(Index: PtrInt; const Value: TObject); function GetName(Index: PtrInt): RawUTF8; function GetValue(const Name: RawUTF8): RawUTF8; procedure SetValue(const Name, Value: RawUTF8); function GetTextCRLF: RawUTF8; procedure SetTextCRLF(const Value: RawUTF8); procedure SetTextPtr(P,PEnd: PUTF8Char; const Delimiter: RawUTF8); function GetListPtr: PPUtf8CharArray; function GetObjectPtr: PPointerArray; {$ifdef HASINLINE}inline;{$endif} procedure SetCaseSensitive(Value: boolean); virtual; public /// initialize the class instance // - by default, any associated Objects[] are just weak references // - also define CaseSensitive=true // - you may supply aOwnObjects=true to force object instance management constructor Create(aOwnObjects: boolean=false); /// finalize the internal objects stored // - if instance was created with aOwnObjects=true destructor Destroy; override; /// get a stored RawUTF8 item // - returns '' and raise no exception in case of out of range supplied index function Get(Index: PtrInt): RawUTF8; {$ifdef HASINLINE}inline;{$endif} /// get a stored Object item by index // - returns nil and raise no exception in case of out of range supplied index function GetObject(Index: PtrInt): TObject; {$ifdef HASINLINE}inline;{$endif} /// get a stored Object item by name // - returns nil and raise no exception in case of out of range supplied index function GetObjectByName(const Name: RawUTF8): TObject; /// store a new RawUTF8 item // - returns -1 and raise no exception in case of self=nil function Add(const aText: RawUTF8): PtrInt; {$ifdef HASINLINE}inline;{$endif} /// store a new RawUTF8 item if not already in the list // - returns -1 and raise no exception in case of self=nil function AddIfNotExisting(const aText: RawUTF8; wasAdded: PBoolean=nil): PtrInt; virtual; /// store a new RawUTF8 item, and its associated TObject // - returns -1 and raise no exception in case of self=nil function AddObject(const aText: RawUTF8; aObject: TObject): PtrInt; /// store a new RawUTF8 item if not already in the list, and its associated TObject // - returns -1 and raise no exception in case of self=nil function AddObjectIfNotExisting(const aText: RawUTF8; aObject: TObject; wasAdded: PBoolean=nil): PtrInt; virtual; /// append a specified list to the current content procedure AddRawUTF8List(List: TRawUTF8List); /// delete a stored RawUTF8 item, and its associated TObject // - raise no exception in case of out of range supplied index procedure Delete(Index: PtrInt); overload; virtual; /// delete a stored RawUTF8 item, and its associated TObject // - will search for the value using IndexOf(aText), and returns its index // - returns -1 if no entry was found and deleted function Delete(const aText: RawUTF8): PtrInt; overload; virtual; /// delete a stored RawUTF8 item, and its associated TObject, from // a given Name when stored as 'Name=Value' pairs // - raise no exception in case of out of range supplied index function DeleteFromName(const Name: RawUTF8): PtrInt; virtual; /// update Value from an existing Name=Value, then optinally delete the entry procedure UpdateValue(const Name: RawUTF8; var Value: RawUTF8; ThenDelete: boolean); /// retrieve and delete the first RawUTF8 item in the list // - could be used as a FIFO function PopFirst(out aText: RawUTF8; aObject: PObject=nil): boolean; virtual; /// retrieve and delete the last RawUTF8 item in the list // - could be used as a FILO function PopLast(out aText: RawUTF8; aObject: PObject=nil): boolean; virtual; /// erase all stored RawUTF8 items // - and corresponding objects (if aOwnObjects was true at constructor) procedure Clear; virtual; /// find a RawUTF8 item in the stored Strings[] list // - this search is case sensitive if CaseSensitive property is TRUE (which // is the default) function IndexOf(const aText: RawUTF8): PtrInt; virtual; /// find the index of a given Name when stored as 'Name=Value' pairs // - search on Name is case-insensitive with 'Name=Value' pairs function IndexOfName(const Name: RawUTF8): PtrInt; /// find a TObject item index in the stored Objects[] list function IndexOfObject(aObject: TObject): PtrInt; /// access to the Value of a given 'Name=Value' pair function GetValueAt(Index: PtrInt): RawUTF8; /// retrieve the all lines, separated by the supplied delimiter function GetText(const Delimiter: RawUTF8=#13#10): RawUTF8; /// the OnChange event will be raised only when EndUpdate will be called procedure BeginUpdate; /// call the OnChange event if changes occured procedure EndUpdate; /// set all lines, separated by the supplied delimiter procedure SetText(const aText: RawUTF8; const Delimiter: RawUTF8=#13#10); /// set all lines from an UTF-8 text file // - expect the file is explicitly an UTF-8 file // - will ignore any trailing UTF-8 BOM in the file content, but will not // expect one either procedure LoadFromFile(const FileName: TFileName); /// write all lines into the supplied stream procedure SaveToStream(Dest: TStream; const Delimiter: RawUTF8=#13#10); /// write all lines into a new file procedure SaveToFile(const FileName: TFileName; const Delimiter: RawUTF8=#13#10); /// return the count of stored RawUTF8 property Count: PtrInt read GetCount; /// set or retrive the current memory capacity of the RawUTF8 list property Capacity: PtrInt read GetCapacity write SetCapacity; /// get or set a RawUTF8 item // - returns '' and raise no exception in case of out of range supplied index // - if you want to use it with the VCL, use UTF8ToString() function property Strings[Index: PtrInt]: RawUTF8 read Get write Put; default; /// get or set a Object item // - returns nil and raise no exception in case of out of range supplied index property Objects[Index: PtrInt]: TObject read GetObject write PutObject; /// set if IndexOf() shall be case sensitive or not // - default is TRUE property CaseSensitive: boolean read fCaseSensitive write SetCaseSensitive; /// retrieve the corresponding Name when stored as 'Name=Value' pairs property names[Index: PtrInt]: RawUTF8 read GetName; /// access to the corresponding 'Name=Value' pairs // - search on Name is case-insensitive with 'Name=Value' pairs property Values[const Name: RawUTF8]: RawUTF8 read GetValue write SetValue; /// the char separator between 'Name=Value' pairs // - equals '=' by default property NameValueSep: AnsiChar read fNameValueSep write fNameValueSep; /// set or retrieve all items as text lines // - lines are separated by #13#10 (CRLF) by default; use GetText and // SetText methods if you want to use another line delimiter (even a comma) property Text: RawUTF8 read GetTextCRLF write SetTextCRLF; /// Event triggered when an entry is modified property OnChange: TNotifyEvent read fOnChange write fOnChange; /// direct access to the memory of the RawUTF8 array property ListPtr: PPUtf8CharArray read GetListPtr; /// direct access to the memory of the Objects array property ObjectPtr: PPointerArray read GetObjectPtr; end; /// a TRawUTF8List with an associated lock for thread-safety TRawUTF8ListLocked = class(TRawUTF8List) protected fSafe: TSynLocker; public /// initialize the class instance constructor Create(aOwnObjects: boolean=false); /// finalize the instance // - and all internal objects stored, if was created with Create(true) destructor Destroy; override; /// thread-safe adding of an item to the list // - will just call Add() within Safe.Lock/Unlock // - you may use SafePop to handle a thread-safe FIFO procedure SafePush(const aValue: RawUTF8); /// thread-safe retrieving of an item to the list // - returns TRUE and set aValue from the oldest SafePush() content // - returns FALSE if there is no pending item in the list // - you may have used SafePush before to handle a thread-safe FIFO function SafePop(out aValue: RawUTF8): boolean; /// thread-safe delete all items from the list procedure SafeClear; /// access to the locking methods of this instance // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block property Safe: TSynLocker read fSafe; end; /// a TRawUTF8List which will use an internal hash table for faster IndexOf() // - purpose of this class is to allow faster access of a static list of RawUTF8 // values (e.g. service method names) which are somewhat fixed during run // - uses a rather rough implementation: all values are re-hashed after change, // just before IndexOf() call, or explicitly via the ReHash method TRawUTF8ListHashed = class(TRawUTF8List) protected fHash: TDynArrayHashed; fChanged: boolean; procedure SetCaseSensitive(Value: boolean); override; /// will set fChanged=true to force re-hash of all items procedure Changed; override; public /// initialize the class instance constructor Create(aOwnObjects: boolean=false); /// find a RawUTF8 item in the stored Strings[] list // - this overridden method will update the internal hash table (if needed), // then use it to retrieve the corresponding matching index // - if your purpose is to test if an item is existing, then add it on need, // use rather the AddObjectIfNotExisting() method which would preserve // the internal hash array, so would perform better function IndexOf(const aText: RawUTF8): PtrInt; override; /// store a new RawUTF8 item if not already in the list // - returns -1 and raise no exception in case of self=nil // - this overridden method will update and use the internal hash table, // so is preferred to plain Add if you want faster insertion // into the TRawUTF8ListHashed function AddIfNotExisting(const aText: RawUTF8; wasAdded: PBoolean=nil): PtrInt; override; /// store a new RawUTF8 item if not already in the list, and its associated TObject // - returns -1 and raise no exception in case of self=nil // - this overridden method will update and use the internal hash table, // so is preferred to plain Add if you want faster insertion // into the TRawUTF8ListHashed function AddObjectIfNotExisting(const aText: RawUTF8; aObject: TObject; wasAdded: PBoolean=nil): PtrInt; override; /// search in the low-level internal hashing table function HashFind(aHashCode: cardinal): integer; {$ifdef HASINLINE}inline;{$endif} /// ensure all items are hashed if necessay // - could be executed after several Add/AddObject calls to ensure the hash // table is computed and this instance ready for the next IndexOf() call // - will hash all items only if fChanged or aForceRehash is true // - returns true if stored information has been re-hashed function ReHash(aForceRehash: boolean=false): boolean; virtual; /// access to the low-level internal hashing table // - could be used e.g. to retrieve Hash.IsHashElementWithoutCollision state property Hash: TDynArrayHashed read fHash; end; /// a TRawUTF8List with an internal hash, with thread-safe locking methods // - by default, inherited methods are not protected by the mutex: you have // to explicitely call Safe.Lock/UnLock to enter or leave the critical section, // or use the methods overriden at this class level TRawUTF8ListHashedLocked = class(TRawUTF8ListHashed) protected fSafe: TSynLocker; public /// initialize the class instance constructor Create(aOwnObjects: boolean=false); /// finalize the instance // - and all internal objects stored, if was created with Create(true) destructor Destroy; override; /// access to the locking methods of this instance // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block property Safe: TSynLocker read fSafe; /// add a RawUTF8 item in the stored Strings[] list // - just a wrapper over Add() using Safe.Lock/Unlock // - warning: this method WON'T update the internal hash array: use // AddIfNotExisting/AddObjectIfNotExisting() methods instead function LockedAdd(const aText: RawUTF8): PtrInt; virtual; /// find a RawUTF8 item in the stored Strings[] list // - just a wrapper over IndexOf() using Safe.Lock/Unlock function IndexOf(const aText: RawUTF8): PtrInt; override; /// find a RawUTF8 item in the stored Strings[] list // - just a wrapper over GetObjectByName() using Safe.Lock/Unlock // - warning: the object instance should remain in the list, so the caller // should not make any Delete/LockedDeleteFromName otherwise a GPF may occur function LockedGetObjectByName(const aText: RawUTF8): TObject; virtual; /// add a RawUTF8 item in the internal storage // - just a wrapper over AddIfNotExisting() using Safe.Lock/Unlock function AddIfNotExisting(const aText: RawUTF8; wasAdded: PBoolean=nil): PtrInt; override; /// add a RawUTF8 item in the internal storage, with an optional object // - just a wrapper over AddObjectIfNotExisting() using Safe.Lock/Unlock function AddObjectIfNotExisting(const aText: RawUTF8; aObject: TObject; wasAdded: PBoolean=nil): PtrInt; override; /// find and delete an RawUTF8 item in the stored Strings[] list // - just a wrapper over inherited Delete(aText) using Safe.Lock/Unlock function Delete(const aText: RawUTF8): PtrInt; override; /// find and delete an RawUTF8 item from its Name=... in the stored Strings[] list // - just a wrapper over inherited DeleteFromName() using Safe.Lock/Unlock function DeleteFromName(const Name: RawUTF8): PtrInt; override; /// retrieve and delete the first RawUTF8 item in the list // - could be used as a FIFO // - just a wrapper over inherited PopFirst() using Safe.Lock/Unlock function PopFirst(out aText: RawUTF8; aObject: PObject=nil): boolean; override; /// retrieve and delete the last RawUTF8 item in the list // - could be used as a FILO // - just a wrapper over inherited PopLast() using Safe.Lock/Unlock function PopLast(out aText: RawUTF8; aObject: PObject=nil): boolean; override; /// delete all RawUTF8 items in the list // - just a wrapper over inherited Clear using Safe.Lock/Unlock procedure Clear; override; /// ensure all items are hashed if necessay // - just a wrapper over inherited Rehash using Safe.Lock/Unlock function ReHash(aForceRehash: boolean=false): boolean; override; end; /// this class stores TMethod callbacks with an associated UTF-8 string // - event names will be hashed for O(1) fast access TRawUTF8MethodList = class(TRawUTF8ListHashed) protected fEvents: TMethodDynArray; public /// delete a stored RawUTF8 item, and its associated event // - raise no exception in case of out of range supplied index procedure Delete(Index: PtrInt); override; /// erase all stored RawUTF8 items and events procedure Clear; override; /// register a callback with its name function AddEvent(const aName: RawUTF8; const aEvent: TMethod): PtrInt; /// retrieve a callback from its index // - return FALSE if not previously set via AddEvent() // - return TRUE if found, and set aEvent to the corresponding callback function GetEvent(aIndex: PtrInt; out aEvent: TMethod): boolean; /// retrieve a callback from its hashed name // - return FALSE if not found // - return TRUE if found, and set aEvent to the corresponding callback function GetEventByName(const aText: RawUTF8; out aEvent: TMethod): boolean; end; /// define the implemetation used by TAlgoCompress.Decompress() TAlgoCompressLoad = (aclNormal, aclSafeSlow, aclNoCrcFast); /// abstract low-level parent class for generic compression/decompression algorithms // - will encapsulate the compression algorithm with crc32c hashing // - all Algo* abtract methods should be overriden by inherited classes TAlgoCompress = class(TSynPersistent) public /// should return a genuine byte identifier // - 0 is reserved for stored, 1 for TAlgoSynLz, 2/3 for TAlgoDeflate/Fast // (in mORMot.pas), 4/5/6 for TAlgoLizard/Fast/Huffman (in SynLizard.pas) function AlgoID: byte; virtual; abstract; /// computes by default the crc32c() digital signature of the buffer function AlgoHash(Previous: cardinal; Data: pointer; DataLen: integer): cardinal; virtual; /// get maximum possible (worse) compressed size for the supplied length function AlgoCompressDestLen(PlainLen: integer): integer; virtual; abstract; /// this method will compress the supplied data function AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; virtual; abstract; /// this method will return the size of the decompressed data function AlgoDecompressDestLen(Comp: pointer): integer; virtual; abstract; /// this method will decompress the supplied data function AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; virtual; abstract; /// this method will partially and safely decompress the supplied data // - expects PartialLen <= result < PartialLenMax, depending on the algorithm function AlgoDecompressPartial(Comp: pointer; CompLen: integer; Partial: pointer; PartialLen, PartialLenMax: integer): integer; virtual; abstract; public /// will register AlgoID in the global list, for Algo() class methods // - no need to free this instance, since it will be owned by the global list // - raise a ESynException if the class or its AlgoID are already registered // - you should never have to call this constructor, but define a global // variable holding a reference to a shared instance constructor Create; override; /// get maximum possible (worse) compressed size for the supplied length // - including the crc32c + algo 9 bytes header function CompressDestLen(PlainLen: integer): integer; {$ifdef HASINLINE}inline;{$endif} /// compress a memory buffer with crc32c hashing to a RawByteString function Compress(const Plain: RawByteString; CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false; BufferOffset: integer=0): RawByteString; overload; {$ifdef HASINLINE}inline;{$endif} /// compress a memory buffer with crc32c hashing to a RawByteString function Compress(Plain: PAnsiChar; PlainLen: integer; CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false; BufferOffset: integer=0): RawByteString; overload; /// compress a memory buffer with crc32c hashing // - supplied Comp buffer should contain at least CompressDestLen(PlainLen) bytes function Compress(Plain, Comp: PAnsiChar; PlainLen, CompLen: integer; CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false): integer; overload; /// compress a memory buffer with crc32c hashing to a TByteDynArray function CompressToBytes(const Plain: RawByteString; CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false): TByteDynArray; overload; {$ifdef HASINLINE}inline;{$endif} /// compress a memory buffer with crc32c hashing to a TByteDynArray function CompressToBytes(Plain: PAnsiChar; PlainLen: integer; CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false): TByteDynArray; overload; /// uncompress a RawByteString memory buffer with crc32c hashing function Decompress(const Comp: RawByteString; Load: TAlgoCompressLoad=aclNormal; BufferOffset: integer=0): RawByteString; overload; {$ifdef HASINLINE}inline;{$endif} /// uncompress a RawByteString memory buffer with crc32c hashing // - returns TRUE on success function TryDecompress(const Comp: RawByteString; out Dest: RawByteString; Load: TAlgoCompressLoad=aclNormal): boolean; /// uncompress a memory buffer with crc32c hashing procedure Decompress(Comp: PAnsiChar; CompLen: integer; out Result: RawByteString; Load: TAlgoCompressLoad=aclNormal; BufferOffset: integer=0); overload; /// uncompress a RawByteString memory buffer with crc32c hashing function Decompress(const Comp: TByteDynArray): RawByteString; overload; {$ifdef HASINLINE}inline;{$endif} /// uncompress a RawByteString memory buffer with crc32c hashing // - returns nil if crc32 hash failed, i.e. if the supplied Comp is not correct // - returns a pointer to the uncompressed data and fill PlainLen variable, // after crc32c hash // - avoid any memory allocation in case of a stored content - otherwise, would // uncompress to the tmp variable, and return pointer(tmp) and length(tmp) function Decompress(const Comp: RawByteString; out PlainLen: integer; var tmp: RawByteString; Load: TAlgoCompressLoad=aclNormal): pointer; overload; {$ifdef HASINLINE}inline;{$endif} /// uncompress a RawByteString memory buffer with crc32c hashing // - returns nil if crc32 hash failed, i.e. if the supplied Data is not correct // - returns a pointer to an uncompressed data buffer of PlainLen bytes // - avoid any memory allocation in case of a stored content - otherwise, would // uncompress to the tmp variable, and return pointer(tmp) and length(tmp) function Decompress(Comp: PAnsiChar; CompLen: integer; out PlainLen: integer; var tmp: RawByteString; Load: TAlgoCompressLoad=aclNormal): pointer; overload; /// decode the header of a memory buffer compressed via the Compress() method // - validates the crc32c of the compressed data (unless Load=aclNoCrcFast), // then return the uncompressed size in bytes, or 0 if the crc32c does not match // - should call DecompressBody() later on to actually retrieve the content function DecompressHeader(Comp: PAnsiChar; CompLen: integer; Load: TAlgoCompressLoad=aclNormal): integer; /// decode the content of a memory buffer compressed via the Compress() method // - PlainLen has been returned by a previous call to DecompressHeader() function DecompressBody(Comp,Plain: PAnsiChar; CompLen,PlainLen: integer; Load: TAlgoCompressLoad=aclNormal): boolean; /// partial decoding of a memory buffer compressed via the Compress() method // - returns 0 on error, or how many bytes have been written to Partial // - will call virtual AlgoDecompressPartial() which is slower, but expected // to avoid any buffer overflow on the Partial destination buffer // - some algorithms (e.g. Lizard) may need some additional bytes in the // decode buffer, so PartialLenMax bytes should be allocated in Partial^, // with PartialLenMax > expected PartialLen, and returned bytes may be > // PartialLen, but always <= PartialLenMax function DecompressPartial(Comp,Partial: PAnsiChar; CompLen,PartialLen,PartialLenMax: integer): integer; /// get the TAlgoCompress instance corresponding to the AlgoID stored // in the supplied compressed buffer // - returns nil if no algorithm was identified class function Algo(Comp: PAnsiChar; CompLen: integer): TAlgoCompress; overload; {$ifdef HASINLINE}inline;{$endif} /// get the TAlgoCompress instance corresponding to the AlgoID stored // in the supplied compressed buffer // - returns nil if no algorithm was identified // - also identifies "stored" content in IsStored variable class function Algo(Comp: PAnsiChar; CompLen: integer; out IsStored: boolean): TAlgoCompress; overload; /// get the TAlgoCompress instance corresponding to the AlgoID stored // in the supplied compressed buffer // - returns nil if no algorithm was identified class function Algo(const Comp: RawByteString): TAlgoCompress; overload; {$ifdef HASINLINE}inline;{$endif} /// get the TAlgoCompress instance corresponding to the AlgoID stored // in the supplied compressed buffer // - returns nil if no algorithm was identified class function Algo(const Comp: TByteDynArray): TAlgoCompress; overload; {$ifdef HASINLINE}inline;{$endif} /// get the TAlgoCompress instance corresponding to the supplied AlgoID // - returns nil if no algorithm was identified // - stored content is identified as TAlgoSynLZ class function Algo(AlgoID: byte): TAlgoCompress; overload; /// quickly validate a compressed buffer content, without uncompression // - extract the TAlgoCompress, and call DecompressHeader() to check the // hash of the compressed data, and return then uncompressed size // - returns 0 on error (e.g. unknown algorithm or incorrect hash) class function UncompressedSize(const Comp: RawByteString): integer; /// returns the algorithm name, from its classname // - e.g. TAlgoSynLZ->'synlz' TAlgoLizard->'lizard' nil->'none' function AlgoName: TShort16; end; /// implement our fast SynLZ compression as a TAlgoCompress class // - please use the AlgoSynLZ global variable methods instead of the deprecated // SynLZCompress/SynLZDecompress wrapper functions TAlgoSynLZ = class(TAlgoCompress) public /// returns 1 as genuine byte identifier for SynLZ function AlgoID: byte; override; /// get maximum possible (worse) SynLZ compressed size for the supplied length function AlgoCompressDestLen(PlainLen: integer): integer; override; /// compress the supplied data using SynLZ function AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; override; /// return the size of the SynLZ decompressed data function AlgoDecompressDestLen(Comp: pointer): integer; override; /// decompress the supplied data using SynLZ function AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; override; /// partial (and safe) decompression of the supplied data using SynLZ function AlgoDecompressPartial(Comp: pointer; CompLen: integer; Partial: pointer; PartialLen, PartialLenMax: integer): integer; override; end; TAlgoCompressWithNoDestLenProcess = (doCompress, doUnCompress, doUncompressPartial); /// abstract class storing the plain length before calling compression API // - some libraries (e.g. Deflate or Lizard) don't provide the uncompressed // length from its output buffer - inherit from this class to store this value // as ToVarUInt32, and override the RawProcess abstract protected method TAlgoCompressWithNoDestLen = class(TAlgoCompress) protected /// inherited classes should implement this single method for the actual process // - dstMax is oinly used for doUncompressPartial function RawProcess(src,dst: pointer; srcLen,dstLen,dstMax: integer; process: TAlgoCompressWithNoDestLenProcess): integer; virtual; abstract; public /// performs the compression, storing PlainLen and calling protected RawProcess function AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; override; /// return the size of the decompressed data (using FromVarUInt32) function AlgoDecompressDestLen(Comp: pointer): integer; override; /// performs the decompression, retrieving PlainLen and calling protected RawProcess function AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; override; /// performs the decompression, retrieving PlainLen and calling protected RawProcess function AlgoDecompressPartial(Comp: pointer; CompLen: integer; Partial: pointer; PartialLen, PartialLenMax: integer): integer; override; end; TSynDictionaryInArray = ( iaFind, iaFindAndDelete, iaFindAndUpdate, iaFindAndAddIfNotExisting, iaAdd); /// event called by TSynDictionary.ForEach methods to iterate over stored items // - if the implementation method returns TRUE, will continue the loop // - if the implementation method returns FALSE, will stop values browsing // - aOpaque is a custom value specified at ForEach() method call TSynDictionaryEvent = function(const aKey; var aValue; aIndex,aCount: integer; aOpaque: pointer): boolean of object; /// event called by TSynDictionary.DeleteDeprecated // - called just before deletion: return false to by-pass this item TSynDictionaryCanDeleteEvent = function(const aKey, aValue; aIndex: integer): boolean of object; /// thread-safe dictionary to store some values from associated keys // - will maintain a dynamic array of values, associated with a hashed dynamic // array for the keys, so that setting or retrieving values would be O(1) // - all process is protected by a TSynLocker, so will be thread-safe // - TDynArray is a wrapper which do not store anything, whereas this class // is able to store both keys and values, and provide convenient methods to // access the stored data, including JSON serialization and binary storage TSynDictionary = class(TSynPersistentLock) protected fKeys: TDynArrayHashed; fValues: TDynArray; fTimeOut: TCardinalDynArray; fTimeOuts: TDynArray; fCompressAlgo: TAlgoCompress; fOnCanDelete: TSynDictionaryCanDeleteEvent; function InArray(const aKey,aArrayValue; aAction: TSynDictionaryInArray): boolean; procedure SetTimeouts; function ComputeNextTimeOut: cardinal; function KeyFullHash(const Elem): cardinal; function KeyFullCompare(const A,B): integer; function GetCapacity: integer; procedure SetCapacity(const Value: integer); function GetTimeOutSeconds: cardinal; public /// initialize the dictionary storage, specifyng dynamic array keys/values // - aKeyTypeInfo should be a dynamic array TypeInfo() RTTI pointer, which // would store the keys within this TSynDictionary instance // - aValueTypeInfo should be a dynamic array TypeInfo() RTTI pointer, which // would store the values within this TSynDictionary instance // - by default, string keys would be searched following exact case, unless // aKeyCaseInsensitive is TRUE // - you can set an optional timeout period, in seconds - you should call // DeleteDeprecated periodically to search for deprecated items constructor Create(aKeyTypeInfo,aValueTypeInfo: pointer; aKeyCaseInsensitive: boolean=false; aTimeoutSeconds: cardinal=0; aCompressAlgo: TAlgoCompress=nil); reintroduce; virtual; /// finalize the storage // - would release all internal stored values destructor Destroy; override; /// try to add a value associated with a primary key // - returns the index of the inserted item, -1 if aKey is already existing // - this method is thread-safe, since it will lock the instance function Add(const aKey, aValue): integer; /// store a value associated with a primary key // - returns the index of the matching item // - if aKey does not exist, a new entry is added // - if aKey does exist, the existing entry is overriden with aValue // - this method is thread-safe, since it will lock the instance function AddOrUpdate(const aKey, aValue): integer; /// clear the value associated via aKey // - does not delete the entry, but reset its value // - returns the index of the matching item, -1 if aKey was not found // - this method is thread-safe, since it will lock the instance function Clear(const aKey): integer; /// delete all key/value stored in the current instance procedure DeleteAll; /// delete a key/value association from its supplied aKey // - this would delete the entry, i.e. matching key and value pair // - returns the index of the deleted item, -1 if aKey was not found // - this method is thread-safe, since it will lock the instance function Delete(const aKey): integer; /// delete a key/value association from its internal index // - this method is not thread-safe: you should use fSafe.Lock/Unlock // e.g. then Find/FindValue to retrieve the index value function DeleteAt(aIndex: integer): boolean; /// search and delete all deprecated items according to TimeoutSeconds // - returns how many items have been deleted // - you can call this method very often: it will ensure that the // search process will take place at most once every second // - this method is thread-safe, but blocking during the process function DeleteDeprecated: integer; /// search of a primary key within the internal hashed dictionary // - returns the index of the matching item, -1 if aKey was not found // - if you want to access the value, you should use fSafe.Lock/Unlock: // consider using Exists or FindAndCopy thread-safe methods instead // - aUpdateTimeOut will update the associated timeout value of the entry function Find(const aKey; aUpdateTimeOut: boolean=false): integer; /// search of a primary key within the internal hashed dictionary // - returns a pointer to the matching item, nil if aKey was not found // - if you want to access the value, you should use fSafe.Lock/Unlock: // consider using Exists or FindAndCopy thread-safe methods instead // - aUpdateTimeOut will update the associated timeout value of the entry function FindValue(const aKey; aUpdateTimeOut: boolean=false; aIndex: PInteger=nil): pointer; /// search of a primary key within the internal hashed dictionary // - returns a pointer to the matching or already existing item // - if you want to access the value, you should use fSafe.Lock/Unlock: // consider using Exists or FindAndCopy thread-safe methods instead // - will update the associated timeout value of the entry, if applying function FindValueOrAdd(const aKey; var added: boolean; aIndex: PInteger=nil): pointer; /// search of a stored value by its primary key, and return a local copy // - so this method is thread-safe // - returns TRUE if aKey was found, FALSE if no match exists // - will update the associated timeout value of the entry, unless // aUpdateTimeOut is set to false function FindAndCopy(const aKey; out aValue; aUpdateTimeOut: boolean=true): boolean; /// search of a stored value by its primary key, then delete and return it // - returns TRUE if aKey was found, fill aValue with its content, // and delete the entry in the internal storage // - so this method is thread-safe // - returns FALSE if no match exists function FindAndExtract(const aKey; out aValue): boolean; /// search for a primary key presence // - returns TRUE if aKey was found, FALSE if no match exists // - this method is thread-safe function Exists(const aKey): boolean; /// apply a specified event over all items stored in this dictionnary // - would browse the list in the adding order // - returns the number of times OnEach has been called // - this method is thread-safe, since it will lock the instance function ForEach(const OnEach: TSynDictionaryEvent; Opaque: pointer=nil): integer; overload; /// apply a specified event over matching items stored in this dictionnary // - would browse the list in the adding order, comparing each key and/or // value item with the supplied comparison functions and aKey/aValue content // - returns the number of times OnMatch has been called, i.e. how many times // KeyCompare(aKey,Keys[#])=0 or ValueCompare(aValue,Values[#])=0 // - this method is thread-safe, since it will lock the instance function ForEach(const OnMatch: TSynDictionaryEvent; KeyCompare,ValueCompare: TDynArraySortCompare; const aKey,aValue; Opaque: pointer=nil): integer; overload; /// touch the entry timeout field so that it won't be deprecated sooner // - this method is not thread-safe, and is expected to be execute e.g. // from a ForEach() TSynDictionaryEvent callback procedure SetTimeoutAtIndex(aIndex: integer); /// search aArrayValue item in a dynamic-array value associated via aKey // - expect the stored value to be a dynamic array itself // - would search for aKey as primary key, then use TDynArray.Find // to delete any aArrayValue match in the associated dynamic array // - returns FALSE if Values is not a tkDynArray, or if aKey or aArrayValue // were not found // - this method is thread-safe, since it will lock the instance function FindInArray(const aKey, aArrayValue): boolean; /// search of a stored key by its associated key, and return a key local copy // - won't use any hashed index but TDynArray.IndexOf over fValues, // so is much slower than FindAndCopy() // - will update the associated timeout value of the entry, unless // aUpdateTimeOut is set to false // - so this method is thread-safe // - returns TRUE if aValue was found, FALSE if no match exists function FindKeyFromValue(const aValue; out aKey; aUpdateTimeOut: boolean=true): boolean; /// add aArrayValue item within a dynamic-array value associated via aKey // - expect the stored value to be a dynamic array itself // - would search for aKey as primary key, then use TDynArray.Add // to add aArrayValue to the associated dynamic array // - returns FALSE if Values is not a tkDynArray, or if aKey was not found // - this method is thread-safe, since it will lock the instance function AddInArray(const aKey, aArrayValue): boolean; /// add once aArrayValue within a dynamic-array value associated via aKey // - expect the stored value to be a dynamic array itself // - would search for aKey as primary key, then use // TDynArray.FindAndAddIfNotExisting to add once aArrayValue to the // associated dynamic array // - returns FALSE if Values is not a tkDynArray, or if aKey was not found // - this method is thread-safe, since it will lock the instance function AddOnceInArray(const aKey, aArrayValue): boolean; /// clear aArrayValue item of a dynamic-array value associated via aKey // - expect the stored value to be a dynamic array itself // - would search for aKey as primary key, then use TDynArray.FindAndDelete // to delete any aArrayValue match in the associated dynamic array // - returns FALSE if Values is not a tkDynArray, or if aKey or aArrayValue were // not found // - this method is thread-safe, since it will lock the instance function DeleteInArray(const aKey, aArrayValue): boolean; /// replace aArrayValue item of a dynamic-array value associated via aKey // - expect the stored value to be a dynamic array itself // - would search for aKey as primary key, then use TDynArray.FindAndUpdate // to delete any aArrayValue match in the associated dynamic array // - returns FALSE if Values is not a tkDynArray, or if aKey or aArrayValue were // not found // - this method is thread-safe, since it will lock the instance function UpdateInArray(const aKey, aArrayValue): boolean; {$ifndef DELPHI5OROLDER} /// make a copy of the stored values // - this method is thread-safe, since it will lock the instance during copy // - resulting length(Dest) will match the exact values count // - T*ObjArray will be reallocated and copied by content (using a temporary // JSON serialization), unless ObjArrayByRef is true and pointers are copied procedure CopyValues(out Dest; ObjArrayByRef: boolean=false); {$endif DELPHI5OROLDER} /// serialize the content as a "key":value JSON object procedure SaveToJSON(W: TTextWriter; EnumSetsAsText: boolean=false); overload; /// serialize the content as a "key":value JSON object function SaveToJSON(EnumSetsAsText: boolean=false): RawUTF8; overload; /// serialize the Values[] as a JSON array function SaveValuesToJSON(EnumSetsAsText: boolean=false): RawUTF8; /// unserialize the content from "key":value JSON object // - if the JSON input may not be correct (i.e. if not coming from SaveToJSON), // you may set EnsureNoKeyCollision=TRUE for a slow but safe keys validation function LoadFromJSON(const JSON: RawUTF8; EnsureNoKeyCollision: boolean=false): boolean; overload; /// unserialize the content from "key":value JSON object // - note that input JSON buffer is not modified in place: no need to create // a temporary copy if the buffer is about to be re-used // - if the JSON input may not be correct (i.e. if not coming from SaveToJSON), // you may set EnsureNoKeyCollision=TRUE for a slow but safe keys validation function LoadFromJSON(JSON: PUTF8Char; EnsureNoKeyCollision: boolean=false): boolean; overload; /// save the content as SynLZ-compressed raw binary data // - warning: this format is tied to the values low-level RTTI, so if you // change the value/key type definitions, LoadFromBinary() would fail function SaveToBinary(NoCompression: boolean=false): RawByteString; /// load the content from SynLZ-compressed raw binary data // - as previously saved by SaveToBinary method function LoadFromBinary(const binary: RawByteString): boolean; /// can be assigned to OnCanDeleteDeprecated to check TSynPersistentLock(aValue).Safe.IsLocked class function OnCanDeleteSynPersistentLock(const aKey, aValue; aIndex: integer): boolean; /// can be assigned to OnCanDeleteDeprecated to check TSynPersistentLock(aValue).Safe.IsLocked class function OnCanDeleteSynPersistentLocked(const aKey, aValue; aIndex: integer): boolean; /// returns how many items are currently stored in this dictionary // - this method is thread-safe function Count: integer; /// fast returns how many items are currently stored in this dictionary // - this method is NOT thread-safe so should be protected by fSafe.Lock/UnLock function RawCount: integer; {$ifdef HASINLINE}inline;{$endif} /// direct access to the primary key identifiers // - if you want to access the keys, you should use fSafe.Lock/Unlock property Keys: TDynArrayHashed read fKeys; /// direct access to the associated stored values // - if you want to access the values, you should use fSafe.Lock/Unlock property Values: TDynArray read fValues; /// defines how many items are currently stored in Keys/Values internal arrays property Capacity: integer read GetCapacity write SetCapacity; /// direct low-level access to the internal access tick (GetTickCount64 shr 10) // - may be nil if TimeOutSeconds=0 property TimeOut: TCardinalDynArray read fTimeOut; /// returns the aTimeOutSeconds parameter value, as specified to Create() property TimeOutSeconds: cardinal read GetTimeOutSeconds; /// the compression algorithm used for binary serialization property CompressAlgo: TAlgoCompress read fCompressAlgo write fCompressAlgo; /// callback to by-pass DeleteDeprecated deletion by returning false // - can be assigned e.g. to OnCanDeleteSynPersistentLock if Value is a // TSynPersistentLock instance, to avoid any potential access violation property OnCanDeleteDeprecated: TSynDictionaryCanDeleteEvent read fOnCanDelete write fOnCanDelete; end; /// thread-safe FIFO (First-In-First-Out) in-order queue of records // - uses internally a dynamic array storage, with a sliding algorithm // (more efficient than the FPC or Delphi TQueue) TSynQueue = class(TSynPersistentLock) protected fValues: TDynArray; fValueVar: pointer; fCount, fFirst, fLast: integer; fWaitPopFlags: set of (wpfDestroying); fWaitPopCounter: integer; procedure InternalGrow; function InternalDestroying(incPopCounter: integer): boolean; function InternalWaitDone(endtix: Int64; const idle: TThreadMethod): boolean; public /// initialize the queue storage // - aTypeInfo should be a dynamic array TypeInfo() RTTI pointer, which // would store the values within this TSynQueue instance constructor Create(aTypeInfo: pointer); reintroduce; virtual; /// finalize the storage // - would release all internal stored values, and call WaitPopFinalize destructor Destroy; override; /// store one item into the queue // - this method is thread-safe, since it will lock the instance procedure Push(const aValue); /// extract one item from the queue, as FIFO (First-In-First-Out) // - returns true if aValue has been filled with a pending item, which // is removed from the queue (use Peek if you don't want to remove it) // - returns false if the queue is empty // - this method is thread-safe, since it will lock the instance function Pop(out aValue): boolean; /// lookup one item from the queue, as FIFO (First-In-First-Out) // - returns true if aValue has been filled with a pending item, without // removing it from the queue (as Pop method does) // - returns false if the queue is empty // - this method is thread-safe, since it will lock the instance function Peek(out aValue): boolean; /// waiting extract of one item from the queue, as FIFO (First-In-First-Out) // - returns true if aValue has been filled with a pending item within the // specified aTimeoutMS time // - returns false if nothing was pushed into the queue in time, or if // WaitPopFinalize has been called // - aWhenIdle could be assigned e.g. to VCL/LCL Application.ProcessMessages // - this method is thread-safe, but will lock the instance only if needed function WaitPop(aTimeoutMS: integer; const aWhenIdle: TThreadMethod; out aValue): boolean; /// waiting lookup of one item from the queue, as FIFO (First-In-First-Out) // - returns a pointer to a pending item within the specified aTimeoutMS // time - the Safe.Lock is still there, so that caller could check its content, // then call Pop() if it is the expected one, and eventually always call Safe.Unlock // - returns nil if nothing was pushed into the queue in time // - this method is thread-safe, but will lock the instance only if needed function WaitPeekLocked(aTimeoutMS: integer; const aWhenIdle: TThreadMethod): pointer; /// ensure any pending or future WaitPop() returns immediately as false // - is always called by Destroy destructor // - could be also called e.g. from an UI OnClose event to avoid any lock // - this method is thread-safe, but will lock the instance only if needed procedure WaitPopFinalize; /// delete all items currently stored in this queue, and void its capacity // - this method is thread-safe, since it will lock the instance procedure Clear; /// initialize a dynamic array with the stored queue items // - aDynArrayValues should be a variable defined as aTypeInfo from Create // - you can retrieve an optional TDynArray wrapper, e.g. for binary or JSON // persistence // - this method is thread-safe, and will make a copy of the queue data procedure Save(out aDynArrayValues; aDynArray: PDynArray=nil); /// returns how many items are currently stored in this queue // - this method is thread-safe function Count: Integer; /// returns how much slots is currently reserved in memory // - the queue has an optimized auto-sizing algorithm, you can use this // method to return its current capacity // - this method is thread-safe function Capacity: integer; /// returns true if there are some items currently pending in the queue // - slightly faster than checking Count=0, and much faster than Pop or Peek function Pending: boolean; end; /// event signature to locate a service for a given string key // - used e.g. by TRawUTF8ObjectCacheList.OnKeyResolve property TOnKeyResolve = function(const aInterface: TGUID; const Key: RawUTF8; out Obj): boolean of object; /// event signature to notify a given string key TOnKeyNotify = procedure(Sender: TObject; const Key: RawUTF8) of object; var /// mORMot.pas will registry here its T*ObjArray serialization process // - will be used by TDynArray.GetIsObjArray DynArrayIsObjArray: function(aDynArrayTypeInfo: Pointer): TPointerClassHashed; type /// handle memory mapping of a file content {$ifdef FPC_OR_UNICODE}TMemoryMap = record private {$else}TMemoryMap = object protected{$endif} fBuf: PAnsiChar; fBufSize: PtrUInt; fFile: THandle; {$ifdef MSWINDOWS} fMap: THandle; {$endif} fFileSize: Int64; fFileLocal: boolean; public /// map the corresponding file handle // - if aCustomSize and aCustomOffset are specified, the corresponding // map view if created (by default, will map whole file) function Map(aFile: THandle; aCustomSize: PtrUInt=0; aCustomOffset: Int64=0): boolean; overload; /// map the file specified by its name // - file will be closed when UnMap will be called function Map(const aFileName: TFileName): boolean; overload; /// set a fixed buffer for the content // - emulated a memory-mapping from an existing buffer procedure Map(aBuffer: pointer; aBufferSize: PtrUInt); overload; /// unmap the file procedure UnMap; /// retrieve the memory buffer mapped to the file content property Buffer: PAnsiChar read fBuf; /// retrieve the buffer size property Size: PtrUInt read fBufSize; end; {$M+} /// able to read a UTF-8 text file using memory map // - much faster than TStringList.LoadFromFile() // - will ignore any trailing UTF-8 BOM in the file content, but will not // expect one either TMemoryMapText = class protected fLines: PPointerArray; fLinesMax: integer; fCount: integer; fMapEnd: PUTF8Char; fMap: TMemoryMap; fFileName: TFileName; fAppendedLines: TRawUTF8DynArray; fAppendedLinesCount: integer; function GetLine(aIndex: integer): RawUTF8; {$ifdef HASINLINE}inline;{$endif} function GetString(aIndex: integer): string; {$ifdef HASINLINE}inline;{$endif} /// call once by Create constructors when fMap has been initialized procedure LoadFromMap(AverageLineLength: integer=32); virtual; /// call once per line, from LoadFromMap method // - default implementation will set fLines[fCount] := LineBeg; // - override this method to add some per-line process at loading: it will // avoid reading the entire file more than once procedure ProcessOneLine(LineBeg, LineEnd: PUTF8Char); virtual; public /// initialize the memory mapped text file // - this default implementation just do nothing but is called by overloaded // constructors so may be overriden to initialize an inherited class constructor Create; overload; virtual; /// read an UTF-8 encoded text file // - every line beginning is stored into LinePointers[] constructor Create(const aFileName: TFileName); overload; /// read an UTF-8 encoded text file content // - every line beginning is stored into LinePointers[] // - this overloaded constructor accept an existing memory buffer (some // uncompressed data e.g.) constructor Create(aFileContent: PUTF8Char; aFileSize: integer); overload; /// release the memory map and internal LinePointers[] destructor Destroy; override; /// save the whole content into a specified stream // - including any runtime appended values via AddInMemoryLine() procedure SaveToStream(Dest: TStream; const Header: RawUTF8); /// save the whole content into a specified file // - including any runtime appended values via AddInMemoryLine() // - an optional header text can be added to the beginning of the file procedure SaveToFile(FileName: TFileName; const Header: RawUTF8=''); /// add a new line to the already parsed content // - this line won't be stored in the memory mapped file, but stay in memory // and appended to the existing lines, until this instance is released procedure AddInMemoryLine(const aNewLine: RawUTF8); virtual; /// clear all in-memory appended rows procedure AddInMemoryLinesClear; virtual; /// retrieve the number of UTF-8 chars of the given line // - warning: no range check is performed about supplied index function LineSize(aIndex: integer): integer; {$ifdef HASINLINE}inline;{$endif} /// check if there is at least a given number of UTF-8 chars in the given line // - this is faster than LineSize(aIndex)=0, either available at // the current position, as saved by TFileBufferWriter.WriteStream method // - if this content fit in the current 1GB memory map buffer, a // TSynMemoryStream instance is returned, with no data copy (faster) // - if this content is not already mapped in memory, a separate memory map // will be created (the returned instance is a TSynMemoryStreamMapped) function ReadStream(DataLen: PtrInt=-1): TCustomMemoryStream; /// retrieve the current in-memory pointer // - if file was not memory-mapped, returns nil // - if DataLen>0, will increment the current in-memory position function CurrentMemory(DataLen: PtrUInt=0): pointer; /// retrieve the current in-memory position // - if file was not memory-mapped, returns -1 function CurrentPosition: integer; /// raise an exception in case of invalid content procedure ErrorInvalidContent; /// read-only access to the global file size property FileSize: Int64 read fMap.fFileSize; /// read-only access to the global mapped buffer binary property MappedBuffer: PAnsiChar read fMap.fBuf; end; /// FileSeek() overloaded function, working with huge files // - Delphi FileSeek() is buggy -> use this function to safe access files > 2 GB // (thanks to sanyin for the report) function FileSeek64(Handle: THandle; const Offset: Int64; Origin: cardinal): Int64; /// wrapper to serialize a T*ObjArray dynamic array as JSON // - as expected by TJSONSerializer.RegisterObjArrayForJSON() function ObjArrayToJSON(const aObjArray; aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8; /// encode the supplied data as an UTF-8 valid JSON object content // - data must be supplied two by two, as Name,Value pairs, e.g. // ! JSONEncode(['name','John','year',1972]) = '{"name":"John","year":1972}' // - or you can specify nested arrays or objects with '['..']' or '{'..'}': // ! J := JSONEncode(['doc','{','name','John','abc','[','a','b','c',']','}','id',123]); // ! assert(J='{"doc":{"name":"John","abc":["a","b","c"]},"id":123}'); // - note that, due to a Delphi compiler limitation, cardinal values should be // type-casted to Int64() (otherwise the integer mapped value will be converted) // - you can pass nil as parameter for a null JSON value function JSONEncode(const NameValuePairs: array of const): RawUTF8; overload; {$ifndef NOVARIANTS} /// encode the supplied (extended) JSON content, with parameters, // as an UTF-8 valid JSON object content // - in addition to the JSON RFC specification strict mode, this method will // handle some BSON-like extensions, e.g. unquoted field names: // ! aJSON := JSONEncode('{id:?,%:{name:?,birthyear:?}}',['doc'],[10,'John',1982]); // - you can use nested _Obj() / _Arr() instances // ! aJSON := JSONEncode('{%:{$in:[?,?]}}',['type'],['food','snack']); // ! aJSON := JSONEncode('{type:{$in:?}}',[],[_Arr(['food','snack'])]); // ! // will both return // ! '{"type":{"$in":["food","snack"]}}') // - if the SynMongoDB unit is used in the application, the MongoDB Shell // syntax will also be recognized to create TBSONVariant, like // ! new Date() ObjectId() MinKey MaxKey // // see @http://docs.mongodb.org/manual/reference/mongodb-extended-json // ! aJSON := JSONEncode('{name:?,field:/%/i}',['acme.*corp'],['John'])) // ! // will return // ! '{"name":"John","field":{"$regex":"acme.*corp","$options":"i"}}' // - will call internally _JSONFastFmt() to create a temporary TDocVariant with // all its features - so is slightly slower than other JSONEncode* functions function JSONEncode(const Format: RawUTF8; const Args,Params: array of const): RawUTF8; overload; {$endif} /// encode the supplied RawUTF8 array data as an UTF-8 valid JSON array content function JSONEncodeArrayUTF8(const Values: array of RawUTF8): RawUTF8; overload; /// encode the supplied integer array data as a valid JSON array function JSONEncodeArrayInteger(const Values: array of integer): RawUTF8; overload; /// encode the supplied floating-point array data as a valid JSON array function JSONEncodeArrayDouble(const Values: array of double): RawUTF8; overload; /// encode the supplied array data as a valid JSON array content // - if WithoutBraces is TRUE, no [ ] will be generated // - note that, due to a Delphi compiler limitation, cardinal values should be // type-casted to Int64() (otherwise the integer mapped value will be converted) function JSONEncodeArrayOfConst(const Values: array of const; WithoutBraces: boolean=false): RawUTF8; overload; /// encode the supplied array data as a valid JSON array content // - if WithoutBraces is TRUE, no [ ] will be generated // - note that, due to a Delphi compiler limitation, cardinal values should be // type-casted to Int64() (otherwise the integer mapped value will be converted) procedure JSONEncodeArrayOfConst(const Values: array of const; WithoutBraces: boolean; var result: RawUTF8); overload; /// encode as JSON {"name":value} object, from a potential SQL quoted value // - will unquote the SQLValue using TTextWriter.AddQuotedStringAsJSON() procedure JSONEncodeNameSQLValue(const Name,SQLValue: RawUTF8; var result: RawUTF8); type /// points to one value of raw UTF-8 content, decoded from a JSON buffer // - used e.g. by JSONDecode() overloaded function to returns names/values {$ifdef FPC_OR_UNICODE}TValuePUTF8Char = record{$else}TValuePUTF8Char = object{$endif} public /// a pointer to the actual UTF-8 text Value: PUTF8Char; /// how many UTF-8 bytes are stored in Value ValueLen: PtrInt; /// convert the value into a UTF-8 string procedure ToUTF8(var Text: RawUTF8); overload; {$ifdef HASINLINE}inline;{$endif} /// convert the value into a UTF-8 string function ToUTF8: RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// convert the value into a VCL/generic string function ToString: string; /// convert the value into a signed integer function ToInteger: PtrInt; {$ifdef HASINLINE}inline;{$endif} /// convert the value into an unsigned integer function ToCardinal: PtrUInt; {$ifdef HASINLINE}inline;{$endif} /// will call IdemPropNameU() over the stored text Value function Idem(const Text: RawUTF8): boolean; {$ifdef HASINLINE}inline;{$endif} end; /// used e.g. by JSONDecode() overloaded function to returns values TValuePUTF8CharArray = array[0..maxInt div SizeOf(TValuePUTF8Char)-1] of TValuePUTF8Char; PValuePUTF8CharArray = ^TValuePUTF8CharArray; /// store one name/value pair of raw UTF-8 content, from a JSON buffer // - used e.g. by JSONDecode() overloaded function to returns names/values TNameValuePUTF8Char = record /// a pointer to the actual UTF-8 name text Name: PUTF8Char; /// a pointer to the actual UTF-8 value text Value: PUTF8Char; /// how many UTF-8 bytes are stored in Name NameLen: integer; /// how many UTF-8 bytes are stored in Value ValueLen: integer; end; /// used e.g. by JSONDecode() overloaded function to returns name/value pairs TNameValuePUTF8CharDynArray = array of TNameValuePUTF8Char; /// decode the supplied UTF-8 JSON content for the supplied names // - data will be set in Values, according to the Names supplied e.g. // ! JSONDecode(JSON,['name','year'],@Values) -> Values[0].Value='John'; Values[1].Value='1972'; // - if any supplied name wasn't found its corresponding Values[] will be nil // - this procedure will decode the JSON content in-memory, i.e. the PUtf8Char // array is created inside JSON, which is therefore modified: make a private // copy first if you want to reuse the JSON content // - if HandleValuesAsObjectOrArray is TRUE, then this procedure will handle // JSON arrays or objects // - support enhanced JSON syntax, e.g. '{name:'"John",year:1972}' is decoded // just like '{"name":'"John","year":1972}' procedure JSONDecode(var JSON: RawUTF8; const Names: array of RawUTF8; Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean=false); overload; /// decode the supplied UTF-8 JSON content for the supplied names // - an overloaded function when the JSON is supplied as a RawJSON variable procedure JSONDecode(var JSON: RawJSON; const Names: array of RawUTF8; Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean=false); overload; /// decode the supplied UTF-8 JSON content for the supplied names // - data will be set in Values, according to the Names supplied e.g. // ! JSONDecode(P,['name','year'],Values) -> Values[0]^='John'; Values[1]^='1972'; // - if any supplied name wasn't found its corresponding Values[] will be nil // - this procedure will decode the JSON content in-memory, i.e. the PUtf8Char // array is created inside P, which is therefore modified: make a private // copy first if you want to reuse the JSON content // - if HandleValuesAsObjectOrArray is TRUE, then this procedure will handle // JSON arrays or objects // - if ValuesLen is set, ValuesLen[] will contain the length of each Values[] // - returns a pointer to the next content item in the JSON buffer function JSONDecode(P: PUTF8Char; const Names: array of RawUTF8; Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean=false): PUTF8Char; overload; /// decode the supplied UTF-8 JSON content into an array of name/value pairs // - this procedure will decode the JSON content in-memory, i.e. the PUtf8Char // array is created inside JSON, which is therefore modified: make a private // copy first if you want to reuse the JSON content // - the supplied JSON buffer should stay available until Name/Value pointers // from returned Values[] are accessed // - if HandleValuesAsObjectOrArray is TRUE, then this procedure will handle // JSON arrays or objects // - support enhanced JSON syntax, e.g. '{name:'"John",year:1972}' is decoded // just like '{"name":'"John","year":1972}' function JSONDecode(P: PUTF8Char; out Values: TNameValuePUTF8CharDynArray; HandleValuesAsObjectOrArray: Boolean=false): PUTF8Char; overload; /// decode the supplied UTF-8 JSON content for the one supplied name // - this function will decode the JSON content in-memory, so will unescape it // in-place: it must be called only once with the same JSON data function JSONDecode(var JSON: RawUTF8; const aName: RawUTF8='result'; wasString: PBoolean=nil; HandleValuesAsObjectOrArray: Boolean=false): RawUTF8; overload; /// retrieve a pointer to JSON string field content // - returns either ':' for name field, either '}',',' for value field // - returns nil on JSON content error // - this function won't touch the JSON buffer, so you can call it before // using in-place escape process via JSONDecode() or GetJSONField() function JSONRetrieveStringField(P: PUTF8Char; out Field: PUTF8Char; out FieldLen: integer; ExpectNameField: boolean): PUTF8Char; {$ifdef HASINLINE}inline;{$endif} /// decode a JSON field in an UTF-8 encoded buffer (used in TSQLTableJSON.Create) // - 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 // - 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" // - '"strings"' are decoded as 'strings', with wasString=true, properly JSON // unescaped (e.g. any \u0123 pattern would be converted into UTF-8 content) // - null is decoded as nil, with wasString=false // - true/false boolean values are returned as 'true'/'false', with wasString=false // - any number value is returned as its ascii representation, with wasString=false // - works for both field names or values (e.g. '"FieldName":' or 'Value,') function GetJSONField(P: PUTF8Char; out PDest: PUTF8Char; wasString: PBoolean=nil; EndOfObject: PUTF8Char=nil; Len: PInteger=nil): PUTF8Char; /// decode a JSON field name in an UTF-8 encoded buffer // - this function decodes in the P^ buffer memory itself (no memory allocation // or copy), for faster process - so take care that P^ is not shared // - it will return the property name (with an ending #0) or nil on error // - this function will handle strict JSON property name (i.e. a "string"), but // also MongoDB extended syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}} // see @http://docs.mongodb.org/manual/reference/mongodb-extended-json function GetJSONPropName(var P: PUTF8Char; Len: PInteger=nil): PUTF8Char; overload; /// decode a JSON field name in an UTF-8 encoded shortstring variable // - this function would left the P^ buffer memory untouched, so may be safer // than the overloaded GetJSONPropName() function in some cases // - it will return the property name as a local UTF-8 encoded shortstring, // or PropName='' on error // - this function won't unescape the property name, as strict JSON (i.e. a "st\"ring") // - but it will handle MongoDB syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}} // see @http://docs.mongodb.org/manual/reference/mongodb-extended-json procedure GetJSONPropName(var P: PUTF8Char; out PropName: shortstring); overload; /// decode a JSON content in an UTF-8 encoded buffer // - GetJSONField() will only handle JSON "strings" or numbers - if // HandleValuesAsObjectOrArray is TRUE, this function will process JSON { // objects } or [ arrays ] and add a #0 at the end of it // - this function decodes in the P^ buffer memory itself (no memory allocation // or copy), for faster process - so take care that it is an unique string // - returns a pointer to the value start, and moved P to the next field to // be decoded, or P=nil in case of any unexpected input // - wasString is set to true if the JSON value was a "string" // - EndOfObject (if not nil) is set to the JSON value end char (',' ':' or '}') // - if Len is set, it will contain the length of the returned pointer value function GetJSONFieldOrObjectOrArray(var P: PUTF8Char; wasString: PBoolean=nil; EndOfObject: PUTF8Char=nil; HandleValuesAsObjectOrArray: Boolean=false; NormalizeBoolean: Boolean=true; Len: PInteger=nil): PUTF8Char; /// retrieve the next JSON item as a RawJSON variable // - buffer can be either any JSON item, i.e. a string, a number or even a // JSON array (ending with ]) or a JSON object (ending with }) // - EndOfObject (if not nil) is set to the JSON value end char (',' ':' or '}') procedure GetJSONItemAsRawJSON(var P: PUTF8Char; var result: RawJSON; EndOfObject: PAnsiChar=nil); /// retrieve the next JSON item as a RawUTF8 decoded buffer // - buffer can be either any JSON item, i.e. a string, a number or even a // JSON array (ending with ]) or a JSON object (ending with }) // - EndOfObject (if not nil) is set to the JSON value end char (',' ':' or '}') // - just call GetJSONField(), and create a new RawUTF8 from the returned value, // after proper unescape if wasString^=true function GetJSONItemAsRawUTF8(var P: PUTF8Char; var output: RawUTF8; wasString: PBoolean=nil; EndOfObject: PUTF8Char=nil): boolean; /// test if the supplied buffer is a "string" value or a numerical value // (floating point or integer), according to the characters within // - this version will recognize null/false/true as strings // - e.g. IsString('0')=false, IsString('abc')=true, IsString('null')=true function IsString(P: PUTF8Char): boolean; /// test if the supplied buffer is a "string" value or a numerical value // (floating or integer), according to the JSON encoding schema // - this version will NOT recognize JSON null/false/true as strings // - e.g. IsStringJSON('0')=false, IsStringJSON('abc')=true, // but IsStringJSON('null')=false // - will follow the JSON definition of number, i.e. '0123' is a string (i.e. // '0' is excluded at the begining of a number) and '123' is not a string function IsStringJSON(P: PUTF8Char): boolean; /// reach positon just after the current JSON item in the supplied UTF-8 buffer // - buffer can be either any JSON item, i.e. a string, a number or even a // JSON array (ending with ]) or a JSON object (ending with }) // - returns nil if the specified buffer is not valid JSON content // - returns the position in buffer just after the item excluding the separator // character - i.e. result^ may be ',','}',']' function GotoEndJSONItem(P: PUTF8Char): PUTF8Char; /// reach the positon of the next JSON item in the supplied UTF-8 buffer // - buffer can be either any JSON item, i.e. a string, a number or even a // JSON array (ending with ]) or a JSON object (ending with }) // - returns nil if the specified number of items is not available in buffer // - returns the position in buffer after the item including the separator // character (optionally in EndOfObject) - i.e. result will be at the start of // the next object, and EndOfObject may be ',','}',']' function GotoNextJSONItem(P: PUTF8Char; NumberOfItemsToJump: cardinal=1; EndOfObject: PAnsiChar=nil): PUTF8Char; /// read the position of the JSON value just after a property identifier // - this function will handle strict JSON property name (i.e. a "string"), but // also MongoDB extended syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}} // see @http://docs.mongodb.org/manual/reference/mongodb-extended-json function GotoNextJSONPropName(P: PUTF8Char): PUTF8Char; /// reach the position of the next JSON object of JSON array // - first char is expected to be either '[' or '{' // - will return nil in case of parsing error or unexpected end (#0) // - will return the next character after ending ] or } - i.e. may be , } ] function GotoNextJSONObjectOrArray(P: PUTF8Char): PUTF8Char; overload; {$ifdef FPC}inline;{$endif} /// reach the position of the next JSON object of JSON array // - first char is expected to be just after the initial '[' or '{' // - specify ']' or '}' as the expected EndChar // - will return nil in case of parsing error or unexpected end (#0) // - will return the next character after ending ] or } - i.e. may be , } ] function GotoNextJSONObjectOrArray(P: PUTF8Char; EndChar: AnsiChar): PUTF8Char; overload; {$ifdef FPC}inline;{$endif} /// reach the position of the next JSON object of JSON array // - first char is expected to be either '[' or '{' // - this version expects a maximum position in PMax: it may be handy to break // the parsing for HUGE content - used e.g. by JSONArrayCount(P,PMax) // - will return nil in case of parsing error or if P reached PMax limit // - will return the next character after ending ] or { - i.e. may be , } ] function GotoNextJSONObjectOrArrayMax(P,PMax: PUTF8Char): PUTF8Char; /// compute the number of elements of a JSON array // - this will handle any kind of arrays, including those with nested // JSON objects or arrays // - incoming P^ should point to the first char AFTER the initial '[' (which // may be a closing ']') // - returns -1 if the supplied input is invalid, or the number of identified // items in the JSON array buffer function JSONArrayCount(P: PUTF8Char): integer; overload; /// compute the number of elements of a JSON array // - this will handle any kind of arrays, including those with nested // JSON objects or arrays // - incoming P^ should point to the first char after the initial '[' (which // may be a closing ']') // - this overloaded method will abort if P reaches a certain position: for // really HUGE arrays, it is faster to allocate the content within the loop, // not ahead of time function JSONArrayCount(P,PMax: PUTF8Char): integer; overload; /// go to the #nth item of a JSON array // - implemented via a fast SAX-like approach: the input buffer is not changed, // nor no memory buffer allocated neither content copied // - returns nil if the supplied index is out of range // - returns a pointer to the index-nth item in the JSON array (first index=0) // - this will handle any kind of arrays, including those with nested // JSON objects or arrays // - incoming P^ should point to the first initial '[' char function JSONArrayItem(P: PUTF8Char; Index: integer): PUTF8Char; /// retrieve all elements of a JSON array // - this will handle any kind of arrays, including those with nested // JSON objects or arrays // - incoming P^ should point to the first char AFTER the initial '[' (which // may be a closing ']') // - returns false if the supplied input is invalid // - returns true on success, with Values[] pointing to each unescaped value, // may be a JSON string, object, array of constant function JSONArrayDecode(P: PUTF8Char; out Values: TPUTF8CharDynArray): boolean; /// compute the number of fields in a JSON object // - this will handle any kind of objects, including those with nested // JSON objects or arrays // - incoming P^ should point to the first char after the initial '{' (which // may be a closing '}') function JSONObjectPropCount(P: PUTF8Char): integer; /// go to a named property of a JSON object // - implemented via a fast SAX-like approach: the input buffer is not changed, // nor no memory buffer allocated neither content copied // - returns nil if the supplied property name does not exist // - returns a pointer to the matching item in the JSON object // - this will handle any kind of objects, including those with nested // JSON objects or arrays // - incoming P^ should point to the first initial '{' char function JsonObjectItem(P: PUTF8Char; const PropName: RawUTF8; PropNameFound: PRawUTF8=nil): PUTF8Char; /// go to a property of a JSON object, by its full path, e.g. 'parent.child' // - implemented via a fast SAX-like approach: the input buffer is not changed, // nor no memory buffer allocated neither content copied // - returns nil if the supplied property path does not exist // - returns a pointer to the matching item in the JSON object // - this will handle any kind of objects, including those with nested // JSON objects or arrays // - incoming P^ should point to the first initial '{' char function JsonObjectByPath(JsonObject,PropPath: PUTF8Char): PUTF8Char; /// return all matching properties of a JSON object // - here the PropPath could be a comma-separated list of full paths, // e.g. 'Prop1,Prop2' or 'Obj1.Obj2.Prop1,Obj1.Prop2' // - returns '' if no property did match // - returns a JSON object of all matching properties // - this will handle any kind of objects, including those with nested // JSON objects or arrays // - incoming P^ should point to the first initial '{' char function JsonObjectsByPath(JsonObject,PropPath: PUTF8Char): RawUTF8; /// convert one JSON object into two JSON arrays of keys and values // - i.e. makes the following transformation: // $ {key1:value1,key2,value2...} -> [key1,key2...] + [value1,value2...] // - this function won't allocate any memory during its process, nor // modify the JSON input buffer // - is the reverse of the TTextWriter.AddJSONArraysAsJSONObject() method function JSONObjectAsJSONArrays(JSON: PUTF8Char; out keys,values: RawUTF8): boolean; /// remove comments 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 // - may be used to prepare configuration files before loading; // for example we store server configuration in file config.json and // put some comments in this file then code for loading is: // !var cfg: RawUTF8; // ! cfg := StringFromFile(ExtractFilePath(paramstr(0))+'Config.json'); // ! RemoveCommentsFromJSON(@cfg[1]); // ! pLastChar := JSONToObject(sc,pointer(cfg),configValid); procedure RemoveCommentsFromJSON(P: PUTF8Char); const /// standard header for an UTF-8 encoded XML file XMLUTF8_HEADER = ''#13#10; /// standard namespace for a generic XML File XMLUTF8_NAMESPACE = ''; /// convert a JSON array or document into a simple XML content // - just a wrapper around TTextWriter.AddJSONToXML, with an optional // header before the XML converted data (e.g. XMLUTF8_HEADER), and an optional // name space content node which will nest the generated XML data (e.g. // '') - the // corresponding ending token will be appended after (e.g. '') // - WARNING: the JSON buffer is decoded in-place, so P^ WILL BE modified procedure JSONBufferToXML(P: PUTF8Char; const Header,NameSpace: RawUTF8; out result: RawUTF8); /// convert a JSON array or document into a simple XML content // - just a wrapper around TTextWriter.AddJSONToXML, making a private copy // of the supplied JSON buffer using TSynTempBuffer (so that JSON content // would stay untouched) // - the optional header is added at the beginning of the resulting string // - an optional name space content node could be added around the generated XML, // e.g. '' function JSONToXML(const JSON: RawUTF8; const Header: RawUTF8=XMLUTF8_HEADER; const NameSpace: RawUTF8=''): RawUTF8; /// formats and indents a JSON array or document to the specified layout // - just a wrapper around TTextWriter.AddJSONReformat() method // - WARNING: the JSON buffer is decoded in-place, so P^ WILL BE modified procedure JSONBufferReformat(P: PUTF8Char; out result: RawUTF8; Format: TTextWriterJSONFormat=jsonHumanReadable); /// formats and indents a JSON array or document to the specified layout // - just a wrapper around TTextWriter.AddJSONReformat, making a private // of the supplied JSON buffer (so that JSON content would stay untouched) function JSONReformat(const JSON: RawUTF8; Format: TTextWriterJSONFormat=jsonHumanReadable): RawUTF8; /// formats and indents a JSON array or document as a file // - just a wrapper around TTextWriter.AddJSONReformat() method // - WARNING: the JSON buffer is decoded in-place, so P^ WILL BE modified function JSONBufferReformatToFile(P: PUTF8Char; const Dest: TFileName; Format: TTextWriterJSONFormat=jsonHumanReadable): boolean; /// formats and indents a JSON array or document as a file // - just a wrapper around TTextWriter.AddJSONReformat, making a private // of the supplied JSON buffer (so that JSON content would stay untouched) function JSONReformatToFile(const JSON: RawUTF8; const Dest: TFileName; Format: TTextWriterJSONFormat=jsonHumanReadable): boolean; const /// map a PtrInt type to the TJSONCustomParserRTTIType set ptPtrInt = {$ifdef CPU64}ptInt64{$else}ptInteger{$endif}; /// map a PtrUInt type to the TJSONCustomParserRTTIType set ptPtrUInt = {$ifdef CPU64}ptQWord{$else}ptCardinal{$endif}; /// which TJSONCustomParserRTTIType types are not simple types // - ptTimeLog is complex, since could be also TCreateTime or TModTime PT_COMPLEXTYPES = [ptArray, ptRecord, ptCustom, ptTimeLog]; /// could be used to compute the index in a pointer list from its position POINTERSHR = {$ifdef CPU64}3{$else}2{$endif}; /// could be used to compute the bitmask of a pointer integer POINTERAND = {$ifdef CPU64}7{$else}3{$endif}; { ************ some other common types and conversion routines ************** } type /// timestamp stored as second-based Unix Time // - i.e. the number of seconds since 1970-01-01 00:00:00 UTC // - is stored as 64-bit value, so that it won't be affected by the // "Year 2038" overflow issue // - see TUnixMSTime for a millisecond resolution Unix Timestamp // - use UnixTimeToDateTime/DateTimeToUnixTime functions to convert it to/from // a regular TDateTime // - use UnixTimeUTC to return the current timestamp, using fast OS API call // - also one of the encodings supported by SQLite3 date/time functions TUnixTime = type Int64; /// timestamp stored as millisecond-based Unix Time // - i.e. the number of milliseconds since 1970-01-01 00:00:00 UTC // - see TUnixTime for a second resolution Unix Timestamp // - use UnixMSTimeToDateTime/DateTimeToUnixMSTime functions to convert it // to/from a regular TDateTime // - also one of the JavaScript date encodings TUnixMSTime = type Int64; /// pointer to a timestamp stored as second-based Unix Time PUnixTime = ^TUnixTime; /// pointer to a timestamp stored as millisecond-based Unix Time PUnixMSTime = ^TUnixMSTime; /// dynamic array of timestamps stored as second-based Unix Time TUnixTimeDynArray = array of TUnixTime; /// dynamic array of timestamps stored as millisecond-based Unix Time TUnixMSTimeDynArray = array of TUnixMSTime; type /// calling context of TSynLogExceptionToStr callbacks TSynLogExceptionContext = record /// the raised exception class EClass: ExceptClass; /// the Delphi Exception instance // - may be nil for external/OS exceptions EInstance: Exception; /// the OS-level exception code // - could be $0EEDFAE0 of $0EEDFADE for Delphi-generated exceptions ECode: DWord; /// the address where the exception occured EAddr: PtrUInt; /// the optional stack trace EStack: PPtrUInt; /// = FPC's RaiseProc() FrameCount if EStack is Frame: PCodePointer EStackCount: integer; /// the timestamp of this exception, as number of seconds since UNIX Epoch // - UnixTimeUTC is faster than NowUTC or GetSystemTime // - use UnixTimeToDateTime() to convert it into a regular TDateTime ETimestamp: TUnixTime; /// the logging level corresponding to this exception // - may be either sllException or sllExceptionOS ELevel: TSynLogInfo; end; /// global hook callback to customize exceptions logged by TSynLog // - should return TRUE if all needed information has been logged by the // event handler // - should return FALSE if Context.EAddr and Stack trace is to be appended TSynLogExceptionToStr = function(WR: TTextWriter; const Context: TSynLogExceptionContext): boolean; {$M+} /// generic parent class of all custom Exception types of this unit // - all our classes inheriting from ESynException are serializable, // so you could use ObjectToJSONDebug(anyESynException) to retrieve some // extended information ESynException = class(Exception) protected fRaisedAt: pointer; public /// constructor which will use FormatUTF8() instead of Format() // - expect % as delimiter, so is less error prone than %s %d %g // - will handle vtPointer/vtClass/vtObject/vtVariant kind of arguments, // appending class name for any class or object, the hexa value for a // pointer, or the JSON representation of any supplied TDocVariant constructor CreateUTF8(const Format: RawUTF8; const Args: array of const); /// constructor appending some FormatUTF8() content to the GetLastError // - message will contain GetLastError value followed by the formatted text // - expect % as delimiter, so is less error prone than %s %d %g // - will handle vtPointer/vtClass/vtObject/vtVariant kind of arguments, // appending class name for any class or object, the hexa value for a // pointer, or the JSON representation of any supplied TDocVariant constructor CreateLastOSError(const Format: RawUTF8; const Args: array of const); {$ifndef NOEXCEPTIONINTERCEPT} /// can be used to customize how the exception is logged // - this default implementation will call the DefaultSynLogExceptionToStr() // function or the TSynLogExceptionToStrCustom global callback, if defined // - override this method to provide a custom logging content // - should return TRUE if Context.EAddr and Stack trace is not to be // written (i.e. as for any TSynLogExceptionToStr callback) function CustomLog(WR: TTextWriter; const Context: TSynLogExceptionContext): boolean; virtual; {$endif} /// the code location when this exception was triggered // - populated by SynLog unit, during interception - so may be nil // - you can use TSynMapFile.FindLocation(ESynException) class function to // guess the corresponding source code line // - will be serialized as "Address": hexadecimal and source code location // (using TSynMapFile .map/.mab information) in TJSONSerializer.WriteObject // when woStorePointer option is defined - e.g. with ObjectToJSONDebug() property RaisedAt: pointer read fRaisedAt write fRaisedAt; published property Message; end; {$M-} ESynExceptionClass = class of ESynException; /// exception class associated to TDocVariant JSON/BSON document EDocVariant = class(ESynException); /// exception raised during TFastReader decoding EFastReader = class(ESynException); var /// allow to customize the ESynException logging message TSynLogExceptionToStrCustom: TSynLogExceptionToStr = nil; {$ifndef NOEXCEPTIONINTERCEPT} /// default exception logging callback - will be set by the SynLog unit // - will add the default Exception details, including any Exception.Message // - if the exception inherits from ESynException // - returns TRUE: caller will then append ' at EAddr' and the stack trace DefaultSynLogExceptionToStr: TSynLogExceptionToStr = nil; {$endif} /// convert a string into its INTEGER Curr64 (value*10000) representation // - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ // - fast conversion, using only integer operations // - if NoDecimal is defined, will be set to TRUE if there is no decimal, AND // the returned value will be an Int64 (not a PInt64(@Curr)^) function StrToCurr64(P: PUTF8Char; NoDecimal: PBoolean=nil): Int64; /// convert a string into its currency representation // - will call StrToCurr64() function StrToCurrency(P: PUTF8Char): currency; /// convert a currency value into a string // - fast conversion, using only integer operations // - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) function CurrencyToStr(Value: currency): RawUTF8; /// convert an INTEGER Curr64 (value*10000) into a string // - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ // - fast conversion, using only integer operations // - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) function Curr64ToStr(const Value: Int64): RawUTF8; overload; /// convert an INTEGER Curr64 (value*10000) into a string // - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ // - fast conversion, using only integer operations // - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) procedure Curr64ToStr(const Value: Int64; var result: RawUTF8); overload; /// convert an INTEGER Curr64 (value*10000) into a string // - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ // - fast conversion, using only integer operations // - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) // - return the number of chars written to Dest^ function Curr64ToPChar(const Value: Int64; Dest: PUTF8Char): PtrInt; /// internal fast INTEGER Curr64 (value*10000) value to text conversion // - expect the last available temporary char position in P // - return the last written char position (write in reverse order in P^) // - will return 0 for Value=0, or a string representation with always 4 decimals // (e.g. 1->'0.0001' 500->'0.0500' 25000->'2.5000' 30000->'3.0000') // - is called by Curr64ToPChar() and Curr64ToStr() functions function StrCurr64(P: PAnsiChar; const Value: Int64): PAnsiChar; /// truncate a Currency value to only 2 digits // - implementation will use fast Int64 math to avoid any precision loss due to // temporary floating-point conversion function TruncTo2Digits(Value: Currency): Currency; /// truncate a Currency value, stored as Int64, to only 2 digits // - implementation will use fast Int64 math to avoid any precision loss due to // temporary floating-point conversion procedure TruncTo2DigitsCurr64(var Value: Int64); {$ifdef HASINLINE}inline;{$endif} /// simple, no banker rounding of a Currency value to only 2 digits // - #.##51 will round to #.##+0.01 and #.##50 will be truncated to #.## // - implementation will use fast Int64 math to avoid any precision loss due to // temporary floating-point conversion function SimpleRoundTo2Digits(Value: Currency): Currency; /// simple, no banker rounding of a Currency value, stored as Int64, to only 2 digits // - #.##51 will round to #.##+0.01 and #.##50 will be truncated to #.## // - implementation will use fast Int64 math to avoid any precision loss due to // temporary floating-point conversion procedure SimpleRoundTo2DigitsCurr64(var Value: Int64); var /// a conversion table from hexa chars into binary data // - returns 255 for any character out of 0..9,A..Z,a..z range // - used e.g. by HexToBin() function // - is defined globally, since may be used from an inlined function ConvertHexToBin: array[byte] of byte; /// naive but efficient cache to avoid string memory allocation for // 0..999 small numbers by Int32ToUTF8/UInt32ToUTF8 // - use around 16KB of heap (since each item consumes 16 bytes), but increase // overall performance and reduce memory allocation (and fragmentation), // especially during multi-threaded execution // - noticeable when strings are used as array indexes (e.g. in SynMongoDB BSON) // - is defined globally, since may be used from an inlined function SmallUInt32UTF8: array[0..999] of RawUTF8; /// fast conversion from hexa chars into binary data // - BinBytes contain the bytes count to be converted: Hex^ must contain // at least BinBytes*2 chars to be converted, and Bin^ enough space // - if Bin=nil, no output data is written, but the Hex^ format is checked // - return false if any invalid (non hexa) char is found in Hex^ // - using this function with Bin^ as an integer value will decode in big-endian // order (most-signignifican byte first) function HexToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer): boolean; overload; /// fast conversion from one hexa char pair into a 8 bit AnsiChar // - return false if any invalid (non hexa) char is found in Hex^ // - similar to HexToBin(Hex,nil,1) function HexToCharValid(Hex: PAnsiChar): boolean; {$ifdef HASINLINE}inline;{$endif} /// fast check if the supplied Hex buffer is an hexadecimal representation // of a binary buffer of a given number of bytes function IsHex(const Hex: RawByteString; BinBytes: integer): boolean; /// fast conversion from one hexa char pair into a 8 bit AnsiChar // - return false if any invalid (non hexa) char is found in Hex^ // - similar to HexToBin(Hex,Bin,1) but with Bin<>nil // - use HexToCharValid if you want to check a hexadecimal char content function HexToChar(Hex: PAnsiChar; Bin: PUTF8Char): boolean; {$ifdef HASINLINE}inline;{$endif} /// fast conversion from two hexa bytes into a 16 bit UTF-16 WideChar // - similar to HexToBin(Hex,@wordvar,2) + bswap(wordvar) function HexToWideChar(Hex: PAnsiChar): cardinal; {$ifdef HASINLINE}inline;{$endif} /// fast conversion from binary data into hexa chars // - BinBytes contain the bytes count to be converted: Hex^ must contain // enough space for at least BinBytes*2 chars // - using this function with BinBytes^ as an integer value will encode it // in low-endian order (less-signignifican byte first): don't use it for display procedure BinToHex(Bin, Hex: PAnsiChar; BinBytes: integer); overload; /// fast conversion from hexa chars into binary data function HexToBin(const Hex: RawUTF8): RawByteString; overload; /// fast conversion from binary data into hexa chars function BinToHex(const Bin: RawByteString): RawUTF8; overload; /// fast conversion from binary data into hexa chars function BinToHex(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; /// fast conversion from binary data into hexa chars, ready to be displayed // - BinBytes contain the bytes count to be converted: Hex^ must contain // enough space for at least BinBytes*2 chars // - using this function with Bin^ as an integer value will encode it // in big-endian order (most-signignifican byte first): use it for display procedure BinToHexDisplay(Bin, Hex: PAnsiChar; BinBytes: integer); overload; /// fast conversion from binary data into hexa chars, ready to be displayed function BinToHexDisplay(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; /// fast conversion from binary data into lowercase hexa chars // - BinBytes contain the bytes count to be converted: Hex^ must contain // enough space for at least BinBytes*2 chars // - using this function with BinBytes^ as an integer value will encode it // in low-endian order (less-signignifican byte first): don't use it for display procedure BinToHexLower(Bin, Hex: PAnsiChar; BinBytes: integer); overload; /// fast conversion from binary data into lowercase hexa chars function BinToHexLower(const Bin: RawByteString): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// fast conversion from binary data into lowercase hexa chars function BinToHexLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} /// fast conversion from binary data into lowercase hexa chars procedure BinToHexLower(Bin: PAnsiChar; BinBytes: integer; var result: RawUTF8); overload; /// fast conversion from binary data into lowercase hexa chars // - BinBytes contain the bytes count to be converted: Hex^ must contain // enough space for at least BinBytes*2 chars // - using this function with Bin^ as an integer value will encode it // in big-endian order (most-signignifican byte first): use it for display procedure BinToHexDisplayLower(Bin, Hex: PAnsiChar; BinBytes: PtrInt); overload; /// fast conversion from binary data into lowercase hexa chars function BinToHexDisplayLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; /// fast conversion from up to 127 bytes of binary data into lowercase hexa chars function BinToHexDisplayLowerShort(Bin: PAnsiChar; BinBytes: integer): shortstring; /// fast conversion from up to 64-bit of binary data into lowercase hexa chars function BinToHexDisplayLowerShort16(Bin: Int64; BinBytes: integer): TShort16; /// fast conversion from binary data into hexa lowercase chars, ready to be // used as a convenient TFileName prefix function BinToHexDisplayFile(Bin: PAnsiChar; BinBytes: integer): TFileName; /// append one byte as hexadecimal char pairs, into a text buffer function ByteToHex(P: PAnsiChar; Value: byte): PAnsiChar; /// fast conversion from binary data to escaped text // - non printable characters will be written as $xx hexadecimal codes // - will be #0 terminated, with '...' characters trailing on overflow // - ensure the destination buffer contains at least max*3+3 bytes, which is // always the case when using LogEscape() and its local TLogEscape variable function EscapeBuffer(s,d: PAnsiChar; len,max: integer): PAnsiChar; const /// maximum size, in bytes, of a TLogEscape / LogEscape() buffer LOGESCAPELEN = 200; type /// buffer to be allocated on stack when using LogEscape() TLogEscape = array[0..LOGESCAPELEN*3+5] of AnsiChar; /// fill TLogEscape stack buffer with the (hexadecimal) chars of the input binary // - up to LOGESCAPELEN (i.e. 200) bytes will be escaped and appended to a // Local temp: TLogEscape variable, using the EscapeBuffer() low-level function // - you can then log the resulting escaped text by passing the returned // PAnsiChar as % parameter to a TSynLog.Log() method // - the "enabled" parameter can be assigned from a process option, avoiding to // process the escape if verbose logs are disabled // - used e.g. to implement logBinaryFrameContent option for WebSockets function LogEscape(source: PAnsiChar; sourcelen: integer; var temp: TLogEscape; enabled: boolean=true): PAnsiChar; {$ifdef HASINLINE}inline;{$endif} /// returns a text buffer with the (hexadecimal) chars of the input binary // - is much slower than LogEscape/EscapeToShort, but has no size limitation function LogEscapeFull(source: PAnsiChar; sourcelen: integer): RawUTF8; overload; /// returns a text buffer with the (hexadecimal) chars of the input binary // - is much slower than LogEscape/EscapeToShort, but has no size limitation function LogEscapeFull(const source: RawByteString): RawUTF8; overload; /// fill a shortstring with the (hexadecimal) chars of the input text/binary function EscapeToShort(source: PAnsiChar; sourcelen: integer): shortstring; overload; /// fill a shortstring with the (hexadecimal) chars of the input text/binary function EscapeToShort(const source: RawByteString): shortstring; overload; /// fast conversion from a pointer data into hexa chars, ready to be displayed // - use internally BinToHexDisplay() function PointerToHex(aPointer: Pointer): RawUTF8; overload; /// fast conversion from a pointer data into hexa chars, ready to be displayed // - use internally BinToHexDisplay() procedure PointerToHex(aPointer: Pointer; var result: RawUTF8); overload; /// fast conversion from a pointer data into hexa chars, ready to be displayed // - use internally BinToHexDisplay() // - such result type would avoid a string allocation on heap function PointerToHexShort(aPointer: Pointer): TShort16; overload; /// fast conversion from a Cardinal value into hexa chars, ready to be displayed // - use internally BinToHexDisplay() // - reverse function of HexDisplayToCardinal() function CardinalToHex(aCardinal: Cardinal): RawUTF8; /// fast conversion from a Cardinal value into hexa chars, ready to be displayed // - use internally BinToHexDisplayLower() // - reverse function of HexDisplayToCardinal() function CardinalToHexLower(aCardinal: Cardinal): RawUTF8; /// fast conversion from a Cardinal value into hexa chars, ready to be displayed // - use internally BinToHexDisplay() // - such result type would avoid a string allocation on heap function CardinalToHexShort(aCardinal: Cardinal): TShort16; /// fast conversion from a Int64 value into hexa chars, ready to be displayed // - use internally BinToHexDisplay() // - reverse function of HexDisplayToInt64() function Int64ToHex(aInt64: Int64): RawUTF8; overload; /// fast conversion from a Int64 value into hexa chars, ready to be displayed // - use internally BinToHexDisplay() // - reverse function of HexDisplayToInt64() procedure Int64ToHex(aInt64: Int64; var result: RawUTF8); overload; /// fast conversion from a Int64 value into hexa chars, ready to be displayed // - use internally BinToHexDisplay() // - such result type would avoid a string allocation on heap procedure Int64ToHexShort(aInt64: Int64; out result: TShort16); overload; /// fast conversion from a Int64 value into hexa chars, ready to be displayed // - use internally BinToHexDisplay() // - such result type would avoid a string allocation on heap function Int64ToHexShort(aInt64: Int64): TShort16; overload; /// fast conversion from a Int64 value into hexa chars, ready to be displayed // - use internally BinToHexDisplay() // - reverse function of HexDisplayToInt64() function Int64ToHexString(aInt64: Int64): string; /// fast conversion from hexa chars into a binary buffer function HexDisplayToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: integer): boolean; /// fast conversion from hexa chars into a cardinal // - reverse function of CardinalToHex() // - returns false and set aValue=0 if Hex is not a valid hexadecimal 32-bit // unsigned integer // - returns true and set aValue with the decoded number, on success function HexDisplayToCardinal(Hex: PAnsiChar; out aValue: cardinal): boolean; {$ifndef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} // inline gives an error under release conditions with FPC /// fast conversion from hexa chars into a cardinal // - reverse function of Int64ToHex() // - returns false and set aValue=0 if Hex is not a valid hexadecimal 64-bit // signed integer // - returns true and set aValue with the decoded number, on success function HexDisplayToInt64(Hex: PAnsiChar; out aValue: Int64): boolean; overload; {$ifndef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} { inline gives an error under release conditions with FPC } /// fast conversion from hexa chars into a cardinal // - reverse function of Int64ToHex() // - returns 0 if the supplied text buffer is not a valid hexadecimal 64-bit // signed integer function HexDisplayToInt64(const Hex: RawByteString): Int64; overload; {$ifdef HASINLINE}inline;{$endif} /// fast conversion from binary data into Base64 encoded UTF-8 text function BinToBase64(const s: RawByteString): RawUTF8; overload; /// fast conversion from binary data into Base64 encoded UTF-8 text function BinToBase64(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; /// fast conversion from binary data into prefixed/suffixed Base64 encoded UTF-8 text // - with optional JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) function BinToBase64(const data, Prefix, Suffix: RawByteString; WithMagic: boolean): RawUTF8; overload; /// fast conversion from binary data into Base64 encoded UTF-8 text // with JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) function BinToBase64WithMagic(const data: RawByteString): RawUTF8; overload; /// fast conversion from binary data into Base64 encoded UTF-8 text // with JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) function BinToBase64WithMagic(Data: pointer; DataLen: integer): RawUTF8; overload; /// fast conversion from Base64 encoded text into binary data // - is now just an alias to Base64ToBinSafe() overloaded function // - returns '' if s was not a valid Base64-encoded input function Base64ToBin(const s: RawByteString): RawByteString; overload; {$ifdef HASINLINE}inline;{$endif} /// fast conversion from Base64 encoded text into binary data // - is now just an alias to Base64ToBinSafe() overloaded function // - returns '' if sp/len buffer was not a valid Base64-encoded input function Base64ToBin(sp: PAnsiChar; len: PtrInt): RawByteString; overload; {$ifdef HASINLINE}inline;{$endif} /// fast conversion from Base64 encoded text into binary data // - is now just an alias to Base64ToBinSafe() overloaded function // - returns false and data='' if sp/len buffer was invalid function Base64ToBin(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// fast conversion from Base64 encoded text into binary data // - returns TRUE on success, FALSE if sp/len buffer was invvalid function Base64ToBin(sp: PAnsiChar; len: PtrInt; var Blob: TSynTempBuffer): boolean; overload; /// fast conversion from Base64 encoded text into binary data // - returns TRUE on success, FALSE if base64 does not match binlen // - nofullcheck is deprecated and not used any more, since nofullcheck=false // is now processed with no performance cost function Base64ToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt; nofullcheck: boolean=true): boolean; overload; /// fast conversion from Base64 encoded text into binary data // - returns TRUE on success, FALSE if base64 does not match binlen // - nofullcheck is deprecated and not used any more, since nofullcheck=false // is now processed with no performance cost function Base64ToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt; nofullcheck: boolean=true): boolean; overload; /// fast conversion from Base64 encoded text into binary data // - will check supplied text is a valid Base64 encoded stream function Base64ToBinSafe(const s: RawByteString): RawByteString; overload; {$ifdef HASINLINE}inline;{$endif} /// fast conversion from Base64 encoded text into binary data // - will check supplied text is a valid Base64 encoded stream function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt): RawByteString; overload; {$ifdef HASINLINE}inline;{$endif} /// fast conversion from Base64 encoded text into binary data // - will check supplied text is a valid Base64 encoded stream function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; overload; /// just a wrapper around Base64ToBin() for in-place decode of JSON_BASE64_MAGIC // '\uFFF0base64encodedbinary' content into binary // - input ParamValue shall have been checked to match the expected pattern procedure Base64MagicDecode(var ParamValue: RawUTF8); /// check and decode '\uFFF0base64encodedbinary' content into binary // - this method will check the supplied value to match the expected // JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: RawByteString): boolean; overload; /// check and decode '\uFFF0base64encodedbinary' content into binary // - this method will check the supplied value to match the expected // JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE function Base64MagicCheckAndDecode(Value: PUTF8Char; ValueLen: Integer; var Blob: RawByteString): boolean; overload; /// check and decode '\uFFF0base64encodedbinary' content into binary // - this method will check the supplied value to match the expected // JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: TSynTempBuffer): boolean; overload; /// check if the supplied text is a valid Base64 encoded stream function IsBase64(const s: RawByteString): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// check if the supplied text is a valid Base64 encoded stream function IsBase64(sp: PAnsiChar; len: PtrInt): boolean; overload; /// retrieve the expected encoded length after Base64 process function BinToBase64Length(len: PtrUInt): PtrUInt; {$ifdef HASINLINE}inline;{$endif} /// retrieve the expected undecoded length of a Base64 encoded buffer // - here len is the number of bytes in sp function Base64ToBinLength(sp: PAnsiChar; len: PtrInt): PtrInt; /// retrieve the expected undecoded length of a Base64 encoded buffer // - here len is the number of bytes in sp // - will check supplied text is a valid Base64 encoded stream function Base64ToBinLengthSafe(sp: PAnsiChar; len: PtrInt): PtrInt; /// direct low-level decoding of a Base64 encoded buffer // - here len is the number of 4 chars chunks in sp input // - deprecated low-level function: use Base64ToBin/Base64ToBinSafe instead function Base64Decode(sp,rp: PAnsiChar; len: PtrInt): boolean; /// fast conversion from binary data into Base64-like URI-compatible encoded text // - in comparison to Base64 standard encoding, will trim any right-sided '=' // unsignificant characters, and replace '+' or '/' by '_' or '-' function BinToBase64uri(const s: RawByteString): RawUTF8; overload; /// fast conversion from a binary buffer into Base64-like URI-compatible encoded text // - in comparison to Base64 standard encoding, will trim any right-sided '=' // unsignificant characters, and replace '+' or '/' by '_' or '-' function BinToBase64uri(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; /// fast conversion from a binary buffer into Base64-like URI-compatible encoded shortstring // - in comparison to Base64 standard encoding, will trim any right-sided '=' // unsignificant characters, and replace '+' or '/' by '_' or '-' // - returns '' if BinBytes void or too big for the resulting shortstring function BinToBase64uriShort(Bin: PAnsiChar; BinBytes: integer): shortstring; /// conversion from any Base64 encoded value into URI-compatible encoded text // - warning: will modify the supplied base64 string in-place // - in comparison to Base64 standard encoding, will trim any right-sided '=' // unsignificant characters, and replace '+' or '/' by '_' or '-' procedure Base64ToURI(var base64: RawUTF8); /// low-level conversion from a binary buffer into Base64-like URI-compatible encoded text // - you should rather use the overloaded BinToBase64uri() functions procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal); /// retrieve the expected encoded length after Base64-URI process // - in comparison to Base64 standard encoding, will trim any right-sided '=' // unsignificant characters, and replace '+' or '/' by '_' or '-' function BinToBase64uriLength(len: PtrUInt): PtrUInt; {$ifdef HASINLINE}inline;{$endif} /// retrieve the expected undecoded length of a Base64-URI encoded buffer // - here len is the number of bytes in sp // - in comparison to Base64 standard encoding, will trim any right-sided '=' // unsignificant characters, and replace '+' or '/' by '_' or '-' function Base64uriToBinLength(len: PtrInt): PtrInt; /// fast conversion from Base64-URI encoded text into binary data // - in comparison to Base64 standard encoding, will trim any right-sided '=' // unsignificant characters, and replace '+' or '/' by '_' or '-' function Base64uriToBin(sp: PAnsiChar; len: PtrInt): RawByteString; overload; {$ifdef HASINLINE}inline;{$endif} /// fast conversion from Base64-URI encoded text into binary data // - in comparison to Base64 standard encoding, will trim any right-sided '=' // unsignificant characters, and replace '+' or '/' by '_' or '-' procedure Base64uriToBin(sp: PAnsiChar; len: PtrInt; var result: RawByteString); overload; /// fast conversion from Base64-URI encoded text into binary data // - caller should always execute temp.Done when finished with the data // - in comparison to Base64 standard encoding, will trim any right-sided '=' // unsignificant characters, and replace '+' or '/' by '_' or '-' function Base64uriToBin(sp: PAnsiChar; len: PtrInt; var temp: TSynTempBuffer): boolean; overload; /// fast conversion from Base64-URI encoded text into binary data // - in comparison to Base64 standard encoding, will trim any right-sided '=' // unsignificant characters, and replace '+' or '/' by '_' or '-' function Base64uriToBin(const s: RawByteString): RawByteString; overload; {$ifdef HASINLINE}inline;{$endif} /// fast conversion from Base64-URI encoded text into binary data // - in comparison to Base64 standard encoding, will trim any right-sided '=' // unsignificant characters, and replace '+' or '/' by '_' or '-' // - will check supplied text is a valid Base64-URI encoded stream function Base64uriToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt): boolean; overload; /// fast conversion from Base64-URI encoded text into binary data // - in comparison to Base64 standard encoding, will trim any right-sided '=' // unsignificant characters, and replace '+' or '/' by '_' or '-' // - will check supplied text is a valid Base64-URI encoded stream function Base64uriToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// direct low-level decoding of a Base64-URI encoded buffer // - the buffer is expected to be at least Base64uriToBinLength() bytes long // - returns true if the supplied sp[] buffer has been successfully decoded // into rp[] - will break at any invalid character, so is always safe to use // - in comparison to Base64 standard encoding, will trim any right-sided '=' // unsignificant characters, and replace '+' or '/' by '_' or '-' // - you should better not use this, but Base64uriToBin() overloaded functions function Base64uriDecode(sp,rp: PAnsiChar; len: PtrInt): boolean; /// generate some pascal source code holding some data binary as constant // - can store sensitive information (e.g. certificates) within the executable // - generates a source code snippet of the following format: // ! const // ! // Comment // ! ConstName: array[0..2] of byte = ( // ! $01,$02,$03); procedure BinToSource(Dest: TTextWriter; const ConstName, Comment: RawUTF8; Data: pointer; Len: integer; PerLine: integer=16); overload; /// generate some pascal source code holding some data binary as constant // - can store sensitive information (e.g. certificates) within the executable // - generates a source code snippet of the following format: // ! const // ! // Comment // ! ConstName: array[0..2] of byte = ( // ! $01,$02,$03); function BinToSource(const ConstName, Comment: RawUTF8; Data: pointer; Len: integer; PerLine: integer=16; const Suffix: RawUTF8=''): RawUTF8; overload; /// revert the value as encoded by TTextWriter.AddInt18ToChars3() or Int18ToChars3() // - no range check is performed: you should ensure that the incoming text // follows the expected 3-chars layout function Chars3ToInt18(P: pointer): cardinal; {$ifdef HASINLINE}inline;{$endif} /// compute the value as encoded by TTextWriter.AddInt18ToChars3() method function Int18ToChars3(Value: cardinal): RawUTF8; overload; /// compute the value as encoded by TTextWriter.AddInt18ToChars3() method procedure Int18ToChars3(Value: cardinal; var result: RawUTF8); overload; /// add the 4 digits of integer Y to P^ as '0000'..'9999' procedure YearToPChar(Y: PtrUInt; P: PUTF8Char); {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} /// creates a 3 digits string from a 0..999 value as '000'..'999' // - consider using UInt3DigitsToShort() to avoid temporary memory allocation, // e.g. when used as FormatUTF8() parameter function UInt3DigitsToUTF8(Value: Cardinal): RawUTF8; {$ifdef HASINLINE}inline;{$endif} /// creates a 4 digits string from a 0..9999 value as '0000'..'9999' // - consider using UInt4DigitsToShort() to avoid temporary memory allocation, // e.g. when used as FormatUTF8() parameter function UInt4DigitsToUTF8(Value: Cardinal): RawUTF8; {$ifdef HASINLINE}inline;{$endif} type /// used e.g. by UInt4DigitsToShort/UInt3DigitsToShort/UInt2DigitsToShort // - such result type would avoid a string allocation on heap TShort4 = string[4]; /// creates a 4 digits short string from a 0..9999 value // - using TShort4 as returned string would avoid a string allocation on heap // - could be used e.g. as parameter to FormatUTF8() function UInt4DigitsToShort(Value: Cardinal): TShort4; {$ifdef HASINLINE}inline;{$endif} /// creates a 3 digits short string from a 0..999 value // - using TShort4 as returned string would avoid a string allocation on heap // - could be used e.g. as parameter to FormatUTF8() function UInt3DigitsToShort(Value: Cardinal): TShort4; {$ifdef HASINLINE}inline;{$endif} /// creates a 2 digits short string from a 0..99 value // - using TShort4 as returned string would avoid a string allocation on heap // - could be used e.g. as parameter to FormatUTF8() function UInt2DigitsToShort(Value: byte): TShort4; {$ifdef HASINLINE}inline;{$endif} /// creates a 2 digits short string from a 0..99 value // - won't test Value>99 as UInt2DigitsToShort() function UInt2DigitsToShortFast(Value: byte): TShort4; {$ifdef HASINLINE}inline;{$endif} /// compute CRC16-CCITT checkum on the supplied buffer // - i.e. 16-bit CRC-CCITT, with polynomial x^16 + x^12 + x^5 + 1 ($1021) // and $ffff as initial value // - this version is not optimized for speed, but for correctness function crc16(Data: PAnsiChar; Len: integer): cardinal; // our custom hash/checksum function, specialized for Text comparaison // - it is a checksum algorithm, not a hash function: has less colision than // Adler32 for short strings, but more than xxhash32 or crc32/crc32c // - written in simple plain pascal, with no L1 CPU cache pollution // - overloaded version for direct binary content hashing // - crc32c() has less collision - but is faster only on a SSE4.2 x86_64 CPU; // some numbers on FPC/Linux64, with a SSE4.2 enabled CPU: // $ -- 8 bytes buffers // $ crc32c 8B in 12us i.e. 41,666,666/s, aver. 0us, 317.8 MB/s // $ xxhash32 8B in 10us i.e. 50,000,000/s, aver. 0us, 381.4 MB/s // $ hash32 8B in 9us i.e. 55,555,555/s, aver. 0us, 423.8 MB/s // $ -- 50 bytes buffers // $ crc32c 50B in 11us i.e. 45,454,545/s, aver. 0us, 2.1 GB/s // $ xxhash32 50B in 14us i.e. 35,714,285/s, aver. 0us, 1.6 GB/s // $ hash32 50B in 10us i.e. 50,000,000/s, aver. 0us, 2.3 GB/s // $ -- 100 bytes buffers // $ crc32c 100B in 12us i.e. 41,666,666/s, aver. 0us, 3.8 GB/s // $ xxhash32 100B in 19us i.e. 26,315,789/s, aver. 0us, 2.4 GB/s // $ hash32 100B in 13us i.e. 38,461,538/s, aver. 0us, 3.5 GB/s // $ -- 1000 bytes buffers // $ crc32c 0.9KB in 37us i.e. 13,513,513/s, aver. 0us, 12.5 GB/s // $ xxhash32 0.9KB in 96us i.e. 5,208,333/s, aver. 0us, 4.8 GB/s // $ hash32 0.9KB in 62us i.e. 8,064,516/s, aver. 0us, 7.5 GB/s // $ -- 10000 bytes buffers // $ crc32c 9.7KB in 282us i.e. 1,773,049/s, aver. 0us, 16.5 GB/s // $ xxhash32 9.7KB in 927us i.e. 539,374/s, aver. 1us, 5 GB/s // $ hash32 9.7KB in 487us i.e. 1,026,694/s, aver. 0us, 9.5 GB/s function Hash32(Data: PCardinalArray; Len: integer): cardinal; overload; // our custom hash/checsum function, specialized for Text comparaison // - it is a checksum algorithm, not a hash function: has less colision than // Adler32 for short strings, but more than xxhash32 or crc32/crc32c // - is faster than CRC32 or Adler32, since uses DQWord (128-bit) aligned read // - overloaded function using RawByteString for binary content hashing, // whatever the codepage is function Hash32(const Text: RawByteString): cardinal; overload; {$ifdef HASINLINE}inline;{$endif} /// standard Kernighan & Ritchie hash from "The C programming Language", 3rd edition // - simple and efficient code, but too much collisions for THasher // - kr32() is 898.8 MB/s - crc32cfast() 1.7 GB/s, crc32csse42() 4.3 GB/s function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; /// simple FNV-1a hashing function // - when run over our regression suite, is similar to crc32c() about collisions, // and 4 times better than kr32(), but also slower than the others // - fnv32() is 715.5 MB/s - kr32() 898.8 MB/s // - this hash function should not be usefull, unless you need several hashing // algorithms at once (e.g. if crc32c with diverse seeds is not enough) function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; /// perform very fast xxHash hashing in 32-bit mode // - will use optimized asm for x86/x64, or a pascal version on other CPUs function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; type TCrc32tab = array[0..{$ifdef PUREPASCAL}3{$else}7{$endif},byte] of cardinal; PCrc32tab = ^TCrc32tab; var /// tables used by crc32cfast() function // - created with a polynom diverse from zlib's crc32() algorithm, but // compatible with SSE 4.2 crc32 instruction // - tables content is created from code in initialization section below // - will also be used internally by SymmetricEncrypt, FillRandom and // TSynUniqueIdentifierGenerator as 1KB master/reference key tables crc32ctab: TCrc32tab; /// compute CRC32C checksum on the supplied buffer using x86/x64 code // - result is compatible with SSE 4.2 based hardware accelerated instruction // - result is not compatible with zlib's crc32() - not the same polynom // - crc32cfast() is 1.7 GB/s, crc32csse42() is 4.3 GB/s // - you should use crc32c() function instead of crc32cfast() or crc32csse42() function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; /// compute CRC32C checksum on the supplied buffer using inlined code // - if the compiler supports inlining, will compute a slow but safe crc32c // checksum of the binary buffer, without calling the main crc32c() function // - may be used e.g. to identify patched executable at runtime, for a licensing // protection system function crc32cinlined(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; {$ifdef HASINLINE}inline;{$endif} /// compute CRC64C checksum on the supplied buffer, cascading two crc32c // - will use SSE 4.2 hardware accelerated instruction, if available // - will combine two crc32c() calls into a single Int64 result // - by design, such combined hashes cannot be cascaded function crc64c(buf: PAnsiChar; len: cardinal): Int64; /// compute CRC63C checksum on the supplied buffer, cascading two crc32c // - similar to crc64c, but with 63-bit, so no negative value: may be used // safely e.g. as mORMot's TID source // - will use SSE 4.2 hardware accelerated instruction, if available // - will combine two crc32c() calls into a single Int64 result // - by design, such combined hashes cannot be cascaded function crc63c(buf: PAnsiChar; len: cardinal): Int64; type /// binary access to an unsigned 32-bit value (4 bytes in memory) TDWordRec = record case integer of 0: (V: DWord); 1: (L,H: word); 2: (B: array[0..3] of byte); end; /// points to the binary of an unsigned 32-bit value PDWordRec = ^TDWordRec; /// binary access to an unsigned 64-bit value (8 bytes in memory) TQWordRec = record case integer of 0: (V: Qword); 1: (L,H: cardinal); 2: (W: array[0..3] of word); 3: (B: array[0..7] of byte); end; /// points to the binary of an unsigned 64-bit value PQWordRec = ^TQWordRec; /// store a 128-bit hash value // - e.g. a MD5 digest, or array[0..3] of cardinal (TBlock128) // - consumes 16 bytes of memory THash128 = array[0..15] of byte; /// pointer to a 128-bit hash value PHash128 = ^THash128; /// store a 160-bit hash value // - e.g. a SHA-1 digest // - consumes 20 bytes of memory THash160 = array[0..19] of byte; /// pointer to a 160-bit hash value PHash160 = ^THash160; /// store a 192-bit hash value // - consumes 24 bytes of memory THash192 = array[0..23] of byte; /// pointer to a 192-bit hash value PHash192 = ^THash192; /// store a 256-bit hash value // - e.g. a SHA-256 digest, a TECCSignature result, or array[0..7] of cardinal // - consumes 32 bytes of memory THash256 = array[0..31] of byte; /// pointer to a 256-bit hash value PHash256 = ^THash256; /// store a 384-bit hash value // - e.g. a SHA-384 digest // - consumes 48 bytes of memory THash384 = array[0..47] of byte; /// pointer to a 384-bit hash value PHash384 = ^THash384; /// store a 512-bit hash value // - e.g. a SHA-512 digest, a TECCSignature result, or array[0..15] of cardinal // - consumes 64 bytes of memory THash512 = array[0..63] of byte; /// pointer to a 512-bit hash value PHash512 = ^THash512; /// store a 128-bit buffer // - e.g. an AES block // - consumes 16 bytes of memory TBlock128 = array[0..3] of cardinal; /// pointer to a 128-bit buffer PBlock128 = ^TBlock128; /// map an infinite array of 128-bit hash values // - each item consumes 16 bytes of memory THash128Array = array[0..(maxInt div SizeOf(THash128))-1] of THash128; /// pointer to an infinite array of 128-bit hash values PHash128Array = ^THash128Array; /// store several 128-bit hash values // - e.g. MD5 digests // - consumes 16 bytes of memory per item THash128DynArray = array of THash128; /// map a 128-bit hash as an array of lower bit size values // - consumes 16 bytes of memory THash128Rec = packed record case integer of 0: (Lo,Hi: Int64); 1: (L,H: QWord); 2: (i0,i1,i2,i3: integer); 3: (c0,c1,c2,c3: cardinal); 4: (c: TBlock128); 5: (b: THash128); 6: (w: array[0..7] of word); end; /// pointer to 128-bit hash map variable record PHash128Rec = ^THash128Rec; /// map an infinite array of 256-bit hash values // - each item consumes 32 bytes of memory THash256Array = array[0..(maxInt div SizeOf(THash256))-1] of THash256; /// pointer to an infinite array of 256-bit hash values PHash256Array = ^THash256Array; /// store several 256-bit hash values // - e.g. SHA-256 digests, TECCSignature results, or array[0..7] of cardinal // - consumes 32 bytes of memory per item THash256DynArray = array of THash256; /// map a 256-bit hash as an array of lower bit size values // - consumes 32 bytes of memory THash256Rec = packed record case integer of 0: (Lo,Hi: THash128); 1: (d0,d1,d2,d3: Int64); 2: (i0,i1,i2,i3,i4,i5,i6,i7: integer); 3: (c0,c1: TBlock128); 4: (b: THash256); 5: (q: array[0..3] of QWord); 6: (c: array[0..7] of cardinal); 7: (w: array[0..15] of word); end; /// pointer to 256-bit hash map variable record PHash256Rec = ^THash256Rec; /// map an infinite array of 512-bit hash values // - each item consumes 64 bytes of memory THash512Array = array[0..(maxInt div SizeOf(THash512))-1] of THash512; /// pointer to an infinite array of 512-bit hash values PHash512Array = ^THash512Array; /// store several 512-bit hash values // - e.g. SHA-512 digests, or array[0..15] of cardinal // - consumes 64 bytes of memory per item THash512DynArray = array of THash512; /// map a 512-bit hash as an array of lower bit size values // - consumes 64 bytes of memory THash512Rec = packed record case integer of 0: (Lo,Hi: THash256); 1: (h0,h1,h2,h3: THash128); 2: (d0,d1,d2,d3,d4,d5,d6,d7: Int64); 3: (i0,i1,i2,i3,i4,i5,i6,i7,i8,i9,i10,i11,i12,i13,i14,i15: integer); 4: (c0,c1,c2,c3: TBlock128); 5: (b: THash512); 6: (b160: THash160); 7: (b384: THash384); 8: (w: array[0..31] of word); 9: (c: array[0..15] of cardinal); end; /// pointer to 512-bit hash map variable record PHash512Rec = ^THash512Rec; /// compute a 128-bit checksum on the supplied buffer, cascading two crc32c // - will use SSE 4.2 hardware accelerated instruction, if available // - will combine two crc32c() calls into a single TAESBlock result // - by design, such combined hashes cannot be cascaded procedure crc128c(buf: PAnsiChar; len: cardinal; out crc: THash128); /// compute a proprietary 128-bit CRC of 128-bit binary buffers // - apply four crc32c() calls on the 128-bit input chunks, into a 128-bit crc // - its output won't match crc128c() value, which works on 8-bit input // - will use SSE 4.2 hardware accelerated instruction, if available // - is used e.g. by SynEcc's TECDHEProtocol.ComputeMAC for macCrc128c procedure crcblocks(crc128, data128: PBlock128; count: integer); /// computation of our 128-bit CRC of a 128-bit binary buffer without SSE4.2 // - to be used for regression tests only: crcblock will use the fastest // implementation available on the current CPU procedure crcblockNoSSE42(crc128, data128: PBlock128); /// compute a proprietary 128-bit CRC of a 128-bit binary buffer // - apply four crc32c() calls on the 128-bit input chunk, into a 128-bit crc // - its output won't match crc128c() value, which works on 8-bit input // - will use SSE 4.2 hardware accelerated instruction, if available // - is used e.g. by SynCrypto's TAESCFBCRC to check for data integrity var crcblock: procedure(crc128, data128: PBlock128) = crcblockNoSSE42; /// returns TRUE if all 16 bytes of this 128-bit buffer equal zero // - e.g. a MD5 digest, or an AES block function IsZero(const dig: THash128): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// returns TRUE if all 16 bytes of both 128-bit buffers do match // - e.g. a MD5 digest, or an AES block // - this function is not sensitive to any timing attack, so is designed // for cryptographic purpose function IsEqual(const A,B: THash128): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// fill all 16 bytes of this 128-bit buffer with zero // - may be used to cleanup stack-allocated content // ! ... finally FillZero(digest); end; procedure FillZero(out dig: THash128); overload; /// fast O(n) search of a 128-bit item in an array of such values function HashFound(P: PHash128Rec; Count: integer; const h: THash128Rec): boolean; /// convert a 32-bit integer (storing a IP4 address) into its full notation // - returns e.g. '1.2.3.4' for any valid address, or '' if ip4=0 function IP4Text(ip4: cardinal): shortstring; overload; /// convert a 128-bit buffer (storing an IP6 address) into its full notation // - returns e.g. '2001:0db8:0a0b:12f0:0000:0000:0000:0001' function IP6Text(ip6: PHash128): shortstring; overload; {$ifdef HASINLINE}inline;{$endif} /// convert a 128-bit buffer (storing an IP6 address) into its full notation // - returns e.g. '2001:0db8:0a0b:12f0:0000:0000:0000:0001' procedure IP6Text(ip6: PHash128; result: PShortString); overload; /// compute a 256-bit checksum on the supplied buffer using crc32c // - will use SSE 4.2 hardware accelerated instruction, if available // - will combine two crc32c() calls into a single THash256 result // - by design, such combined hashes cannot be cascaded procedure crc256c(buf: PAnsiChar; len: cardinal; out crc: THash256); /// returns TRUE if all 20 bytes of this 160-bit buffer equal zero // - e.g. a SHA-1 digest function IsZero(const dig: THash160): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// returns TRUE if all 20 bytes of both 160-bit buffers do match // - e.g. a SHA-1 digest // - this function is not sensitive to any timing attack, so is designed // for cryptographic purpose function IsEqual(const A,B: THash160): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// fill all 20 bytes of this 160-bit buffer with zero // - may be used to cleanup stack-allocated content // ! ... finally FillZero(digest); end; procedure FillZero(out dig: THash160); overload; /// returns TRUE if all 32 bytes of this 256-bit buffer equal zero // - e.g. a SHA-256 digest, or a TECCSignature result function IsZero(const dig: THash256): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// returns TRUE if all 32 bytes of both 256-bit buffers do match // - e.g. a SHA-256 digest, or a TECCSignature result // - this function is not sensitive to any timing attack, so is designed // for cryptographic purpose function IsEqual(const A,B: THash256): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// fill all 32 bytes of this 256-bit buffer with zero // - may be used to cleanup stack-allocated content // ! ... finally FillZero(digest); end; procedure FillZero(out dig: THash256); overload; /// returns TRUE if all 48 bytes of this 384-bit buffer equal zero // - e.g. a SHA-384 digest function IsZero(const dig: THash384): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// returns TRUE if all 48 bytes of both 384-bit buffers do match // - e.g. a SHA-384 digest // - this function is not sensitive to any timing attack, so is designed // for cryptographic purpose function IsEqual(const A,B: THash384): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// fill all 32 bytes of this 384-bit buffer with zero // - may be used to cleanup stack-allocated content // ! ... finally FillZero(digest); end; procedure FillZero(out dig: THash384); overload; /// returns TRUE if all 64 bytes of this 512-bit buffer equal zero // - e.g. a SHA-512 digest function IsZero(const dig: THash512): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// returns TRUE if all 64 bytes of both 512-bit buffers do match // - e.g. two SHA-512 digests // - this function is not sensitive to any timing attack, so is designed // for cryptographic purpose function IsEqual(const A,B: THash512): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// fill all 64 bytes of this 512-bit buffer with zero // - may be used to cleanup stack-allocated content // ! ... finally FillZero(digest); end; procedure FillZero(out dig: THash512); overload; /// compute a 512-bit checksum on the supplied buffer using crc32c // - will use SSE 4.2 hardware accelerated instruction, if available // - will combine two crc32c() calls into a single THash512 result // - by design, such combined hashes cannot be cascaded procedure crc512c(buf: PAnsiChar; len: cardinal; out crc: THash512); /// fill all bytes of this memory buffer with zeros, i.e. 'toto' -> #0#0#0#0 // - will write the memory buffer directly, so if this string instance is shared // (i.e. has refcount>1), all other variables will contains zeros // - may be used to cleanup stack-allocated content // ! ... finally FillZero(secret); end; procedure FillZero(var secret: RawByteString); overload; {$ifdef FPC}inline;{$endif} /// fill all bytes of this UTF-8 string with zeros, i.e. 'toto' -> #0#0#0#0 // - will write the memory buffer directly, so if this string instance is shared // (i.e. has refcount>1), all other variables will contains zeros // - may be used to cleanup stack-allocated content // ! ... finally FillZero(secret); end; procedure FillZero(var secret: RawUTF8); overload; {$ifdef FPC}inline;{$endif} /// fill all bytes of a memory buffer with zero // - 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)); procedure FillZero(var dest; count: PtrInt); overload; {$ifdef HASINLINE}inline;{$endif} /// fast computation of two 64-bit unsigned integers into a 128-bit value procedure mul64x64(const left, right: QWord; out product: THash128Rec); {$ifdef FPC}{$ifndef CPUX64}inline;{$endif CPUX64}{$endif FPC} type /// the potential features, retrieved from an Intel CPU // - see https://en.wikipedia.org/wiki/CPUID#EAX.3D1:_Processor_Info_and_Feature_Bits 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, 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, 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); /// all features, as retrieved from an Intel CPU TIntelCpuFeatures = set of TIntelCpuFeature; /// convert Intel CPU features as plain CSV text function ToText(const aIntelCPUFeatures: TIntelCpuFeatures; const Sep: RawUTF8=','): RawUTF8; overload; {$ifdef CPUINTEL} var /// the available CPU features, as recognized at program startup CpuFeatures: TIntelCpuFeatures; /// compute CRC32C checksum on the supplied buffer using SSE 4.2 // - use Intel Streaming SIMD Extensions 4.2 hardware accelerated instruction // - SSE 4.2 shall be available on the processor (i.e. cfSSE42 in CpuFeatures) // - result is not compatible with zlib's crc32() - not the same polynom // - crc32cfast() is 1.7 GB/s, crc32csse42() is 4.3 GB/s // - you should use crc32c() function instead of crc32cfast() or crc32csse42() function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; {$endif CPUINTEL} /// naive symmetric encryption scheme using a 32-bit key // - fast, but not very secure, since uses crc32ctab[] content as master cypher // key: consider using SynCrypto proven AES-based algorithms instead procedure SymmetricEncrypt(key: cardinal; var data: RawByteString); type TCrc32cBy4 = function(crc, value: cardinal): cardinal; var /// compute CRC32C checksum on the supplied buffer // - result is not compatible with zlib's crc32() - Intel/SCSI CRC32C is not // the same polynom - but will use the fastest mean available, e.g. SSE 4.2, // to achieve up to 16GB/s with the optimized implementation from SynCrypto.pas // - you should use this function instead of crc32cfast() or crc32csse42() crc32c: THasher; /// compute CRC32C checksum on one 32-bit unsigned integer // - can be used instead of crc32c() for inlined process during data acquisition // - doesn't make "crc := not crc" before and after the computation: caller has // to start with "crc := cardinal(not 0)" and make "crc := not crc" at the end, // to compute the very same hash value than regular crc32c() // - this variable will use the fastest mean available, e.g. SSE 4.2 crc32cBy4: TCrc32cBy4; /// compute the hexadecimal representation of the crc32 checkum of a given text // - wrapper around CardinalToHex(crc32c(...)) function crc32cUTF8ToHex(const str: RawUTF8): RawUTF8; var /// the default hasher used by TDynArrayHashed // - set to crc32csse42() if SSE4.2 instructions are available on this CPU, // or fallback to xxHash32() which performs better than crc32cfast() DefaultHasher: THasher; /// the hash function used by TRawUTF8Interning // - set to crc32csse42() if SSE4.2 instructions are available on this CPU, // or fallback to xxHash32() which performs better than crc32cfast() InterningHasher: THasher; /// retrieve a particular bit status from a bit array // - this function can't be inlined, whereas GetBitPtr() function can function GetBit(const Bits; aIndex: PtrInt): boolean; /// set a particular bit into a bit array // - this function can't be inlined, whereas SetBitPtr() function can procedure SetBit(var Bits; aIndex: PtrInt); /// unset/clear a particular bit into a bit array // - this function can't be inlined, whereas UnSetBitPtr() function can procedure UnSetBit(var Bits; aIndex: PtrInt); /// retrieve a particular bit status from a bit array // - GetBit() can't be inlined, whereas this pointer-oriented function can function GetBitPtr(Bits: pointer; aIndex: PtrInt): boolean; {$ifdef HASINLINE}inline;{$endif} /// set a particular bit into a bit array // - SetBit() can't be inlined, whereas this pointer-oriented function can procedure SetBitPtr(Bits: pointer; aIndex: PtrInt); {$ifdef HASINLINE}inline;{$endif} /// unset/clear a particular bit into a bit array // - UnSetBit() can't be inlined, whereas this pointer-oriented function can procedure UnSetBitPtr(Bits: pointer; aIndex: PtrInt); {$ifdef HASINLINE}inline;{$endif} /// compute the number of bits set in a bit array // - Count is the bit count, not byte size function GetBitsCount(const Bits; Count: PtrInt): integer; const /// constant array used by GetAllBits() function (when inlined) ALLBITS_CARDINAL: array[1..32] of Cardinal = ( 1 shl 1-1, 1 shl 2-1, 1 shl 3-1, 1 shl 4-1, 1 shl 5-1, 1 shl 6-1, 1 shl 7-1, 1 shl 8-1, 1 shl 9-1, 1 shl 10-1, 1 shl 11-1, 1 shl 12-1, 1 shl 13-1, 1 shl 14-1, 1 shl 15-1, 1 shl 16-1, 1 shl 17-1, 1 shl 18-1, 1 shl 19-1, 1 shl 20-1, 1 shl 21-1, 1 shl 22-1, 1 shl 23-1, 1 shl 24-1, 1 shl 25-1, 1 shl 26-1, 1 shl 27-1, 1 shl 28-1, 1 shl 29-1, 1 shl 30-1, $7fffffff, $ffffffff); /// returns TRUE if all BitCount bits are set in the input 32-bit cardinal function GetAllBits(Bits, BitCount: cardinal): boolean; {$ifdef HASINLINE}inline;{$endif} type /// fast access to 8-bit integer bits // - the compiler will generate bt/btr/bts opcodes TBits8 = set of 0..7; PBits8 = ^TBits8; TBits8Array = array[0..maxInt-1] of TBits8; /// fast access to 32-bit integer bits // - the compiler will generate bt/btr/bts opcodes TBits32 = set of 0..31; PBits32 = ^TBits32; /// fast access to 64-bit integer bits // - the compiler will generate bt/btr/bts opcodes // - as used by GetBit64/SetBit64/UnSetBit64 TBits64 = set of 0..63; PBits64 = ^TBits64; /// retrieve a particular bit status from a 64-bit integer bits (max aIndex is 63) function GetBit64(const Bits: Int64; aIndex: PtrInt): boolean; {$ifdef HASINLINE}inline;{$endif} /// set a particular bit into a 64-bit integer bits (max aIndex is 63) procedure SetBit64(var Bits: Int64; aIndex: PtrInt); {$ifdef HASINLINE}inline;{$endif} /// unset/clear a particular bit into a 64-bit integer bits (max aIndex is 63) procedure UnSetBit64(var Bits: Int64; aIndex: PtrInt); {$ifdef HASINLINE}inline;{$endif} /// logical OR of two memory buffers // - will perform on all buffer bytes: // ! Dest[i] := Dest[i] or Source[i]; procedure OrMemory(Dest,Source: PByteArray; size: PtrInt); {$ifdef HASINLINE}inline;{$endif} /// logical XOR of two memory buffers // - will perform on all buffer bytes: // ! Dest[i] := Dest[i] xor Source[i]; procedure XorMemory(Dest,Source: PByteArray; size: PtrInt); overload; {$ifdef HASINLINE}inline;{$endif} /// logical XOR of two memory buffers into a third // - will perform on all buffer bytes: // ! Dest[i] := Source1[i] xor Source2[i]; procedure XorMemory(Dest,Source1,Source2: PByteArray; size: PtrInt); overload; {$ifdef HASINLINE}inline;{$endif} /// logical AND of two memory buffers // - will perform on all buffer bytes: // ! Dest[i] := Dest[i] and Source[i]; procedure AndMemory(Dest,Source: PByteArray; size: PtrInt); {$ifdef HASINLINE}inline;{$endif} /// returns TRUE if all bytes equal zero function IsZero(P: pointer; Length: integer): boolean; overload; /// returns TRUE if Value is nil or all supplied Values[] equal '' function IsZero(const Values: TRawUTF8DynArray): boolean; overload; /// returns TRUE if Value is nil or all supplied Values[] equal 0 function IsZero(const Values: TIntegerDynArray): boolean; overload; /// returns TRUE if Value is nil or all supplied Values[] equal 0 function IsZero(const Values: TInt64DynArray): boolean; overload; /// fill all entries of a supplied array of RawUTF8 with '' procedure FillZero(var Values: TRawUTF8DynArray); overload; /// fill all entries of a supplied array of 32-bit integers with 0 procedure FillZero(var Values: TIntegerDynArray); overload; /// fill all entries of a supplied array of 64-bit integers with 0 procedure FillZero(var Values: TInt64DynArray); overload; /// name the current thread so that it would be easily identified in the IDE debugger procedure SetCurrentThreadName(const Format: RawUTF8; const Args: array of const); /// name a thread so that it would be easily identified in the IDE debugger // - you can force this function to do nothing by setting the NOSETTHREADNAME // conditional, if you have issues with this feature when debugging your app procedure SetThreadName(ThreadID: TThreadID; const Format: RawUTF8; const Args: array of const); /// could be used to override SetThreadNameInternal() // - under Linux/FPC, calls pthread_setname_np API which truncates to 16 chars procedure SetThreadNameDefault(ThreadID: TThreadID; const Name: RawUTF8); var /// is overriden e.g. by mORMot.pas to log the thread name SetThreadNameInternal: procedure(ThreadID: TThreadID; const Name: RawUTF8) = SetThreadNameDefault; /// low-level wrapper to add a callback to a dynamic list of events // - by default, you can assign only one callback to an Event: but by storing // it as a dynamic array of events, you can use this wrapper to add one callback // to this list of events // - if the event was already registered, do nothing (i.e. won't call it twice) // - since this function uses an unsafe typeless EventList parameter, you should // not use it in high-level code, but only as wrapper within dedicated methods // - will add Event to EventList[] unless Event is already registered // - is used e.g. by TTextWriter as such: // ! ... // ! fEchos: array of TOnTextWriterEcho; // ! ... // ! procedure EchoAdd(const aEcho: TOnTextWriterEcho); // ! ... // ! procedure TTextWriter.EchoAdd(const aEcho: TOnTextWriterEcho); // ! begin // ! MultiEventAdd(fEchos,TMethod(aEcho)); // ! end; // then callbacks are then executed as such: // ! if fEchos<>nil then // ! for i := 0 to length(fEchos)-1 do // ! fEchos[i](self,fEchoBuf); // - use MultiEventRemove() to un-register a callback from the list function MultiEventAdd(var EventList; const Event: TMethod): boolean; /// low-level wrapper to remove a callback from a dynamic list of events // - by default, you can assign only one callback to an Event: but by storing // it as a dynamic array of events, you can use this wrapper to remove one // callback already registered by MultiEventAdd() to this list of events // - since this function uses an unsafe typeless EventList parameter, you should // not use it in high-level code, but only as wrapper within dedicated methods // - is used e.g. by TTextWriter as such: // ! ... // ! fEchos: array of TOnTextWriterEcho; // ! ... // ! procedure EchoRemove(const aEcho: TOnTextWriterEcho); // ! ... // ! procedure TTextWriter.EchoRemove(const aEcho: TOnTextWriterEcho); // ! begin // ! MultiEventRemove(fEchos,TMethod(aEcho)); // ! end; procedure MultiEventRemove(var EventList; const Event: TMethod); overload; /// low-level wrapper to remove a callback from a dynamic list of events // - same as the same overloaded procedure, but accepting an EventList[] index // to identify the Event to be suppressed procedure MultiEventRemove(var EventList; Index: Integer); overload; /// low-level wrapper to check if a callback is in a dynamic list of events // - by default, you can assign only one callback to an Event: but by storing // it as a dynamic array of events, you can use this wrapper to check if // a callback has already been registered to this list of events // - used internally by MultiEventAdd() and MultiEventRemove() functions function MultiEventFind(const EventList; const Event: TMethod): integer; /// low-level wrapper to add one or several callbacks from another list of events // - all events of the ToBeAddedList would be added to DestList // - the list is not checked for duplicates procedure MultiEventMerge(var DestList; const ToBeAddedList); /// compare two TMethod instances function EventEquals(const eventA,eventB): boolean; {$ifdef HASINLINE}inline;{$endif} { ************ fast ISO-8601 types and conversion routines ***************** } type /// a type alias, which will be serialized as ISO-8601 with milliseconds // - i.e. 'YYYY-MM-DD hh:mm:ss.sss' or 'YYYYMMDD hhmmss.sss' format TDateTimeMS = type TDateTime; /// a dynamic array of TDateTimeMS values TDateTimeMSDynArray = array of TDateTimeMS; PDateTimeMSDynArray = ^TDateTimeMSDynArray; /// a cross-platform and cross-compiler TSystemTime structure // - FPC's TSystemTime in datih.inc does NOT match Windows TSystemTime fields! // - also used to store a Date/Time in TSynTimeZone internal structures, or // for fast conversion from TDateTime to its ready-to-display members {$ifdef FPC_OR_UNICODE}TSynSystemTime = record{$else}TSynSystemTime = object{$endif} public Year, Month, DayOfWeek, Day, Hour, Minute, Second, MilliSecond: word; /// set all fields to 0 procedure Clear; {$ifdef HASINLINE}inline;{$endif} /// returns true if all fields are zero function IsZero: boolean; {$ifdef HASINLINE}inline;{$endif} /// returns true if all fields do match function IsEqual(const another{$ifndef DELPHI5OROLDER}: TSynSystemTime{$endif}): boolean; /// used by TSynTimeZone function EncodeForTimeChange(const aYear: word): TDateTime; /// fill fields with the current UTC time, using a 8-16ms thread-safe cache procedure FromNowUTC; /// fill fields with the current Local time, using a 8-16ms thread-safe cache procedure FromNowLocal; /// fill fields from the given value - but not DayOfWeek procedure FromDateTime(const dt: TDateTime); /// fill Year/Month/Day fields from the given value - but not DayOfWeek // - faster than the RTL DecodeDate() function procedure FromDate(const dt: TDateTime); /// fill Hour/Minute/Second/Millisecond fields from the given value // - faster than the RTL DecodeTime() function procedure FromTime(const dt: TDateTime); /// encode the stored date/time as text function ToText(Expanded: boolean=true; FirstTimeChar: AnsiChar='T'; const TZD: RawUTF8=''): RawUTF8; /// append the stored date and time, in a log-friendly format // - e.g. append '20110325 19241502' - with no trailing space nor tab // - as called by TTextWriter.AddCurrentLogTime() procedure AddLogTime(WR: TTextWriter); /// append the stored data and time, in apache-like format, to a TTextWriter // - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space procedure AddNCSAText(WR: TTextWriter); /// append the stored data and time, in apache-like format, to a memory buffer // - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space // - returns the number of chars added to P, i.e. always 21 function ToNCSAText(P: PUTF8Char): PtrInt; /// convert the stored time into a TDateTime function ToDateTime: TDateTime; /// add some 1..999 milliseconds to the stored time // - not to be used for computation, but e.g. for fast AddLogTime generation procedure IncrementMS(ms: integer); end; PSynSystemTime = ^TSynSystemTime; /// fast bit-encoded date and time value // - faster than Iso-8601 text and TDateTime, e.g. can be used as published // property field in mORMot's TSQLRecord (see also TModTime and TCreateTime) // - use internally for computation an abstract "year" of 16 months of 32 days // of 32 hours of 64 minutes of 64 seconds - same as Iso8601ToTimeLog() // - use TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow functions, or // type-cast any TTimeLog value with the TTimeLogBits memory structure for // direct access to its bit-oriented content (or via PTimeLogBits pointer) // - since TTimeLog type is bit-oriented, you can't just add or substract two // TTimeLog values when doing date/time computation: use a TDateTime temporary // conversion in such case: // ! aTimestamp := TimeLogFromDateTime(IncDay(TimeLogToDateTime(aTimestamp))); TTimeLog = type Int64; /// dynamic array of TTimeLog // - used by TDynArray JSON serialization to handle textual serialization TTimeLogDynArray = array of TTimeLog; /// pointer to a memory structure for direct access to a TTimeLog type value PTimeLogBits = ^TTimeLogBits; /// internal memory structure for direct access to a TTimeLog type value // - most of the time, you should not use this object, but higher level // TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow/Iso8601ToTimeLog functions // - since TTimeLogBits.Value is bit-oriented, you can't just add or substract // two TTimeLog values when doing date/time computation: use a TDateTime // temporary conversion in such case // - TTimeLogBits.Value has a 38-bit precision, so features exact representation // as JavaScript numbers (stored in a 52-bit mantissa) {$ifdef FPC_OR_UNICODE}TTimeLogBits = record{$else}TTimeLogBits = object{$endif} public /// the bit-encoded value itself, which follows an abstract "year" of 16 // months of 32 days of 32 hours of 64 minutes of 64 seconds // - bits 0..5 = Seconds (0..59) // - bits 6..11 = Minutes (0..59) // - bits 12..16 = Hours (0..23) // - bits 17..21 = Day-1 (0..31) // - bits 22..25 = Month-1 (0..11) // - bits 26..38 = Year (0..4095) Value: Int64; /// extract the date and time content in Value into individual values procedure Expand(out Date: TSynSystemTime); /// convert to Iso-8601 encoded text function Text(Expanded: boolean; FirstTimeChar: AnsiChar = 'T'): RawUTF8; overload; /// convert to Iso-8601 encoded text function Text(Dest: PUTF8Char; Expanded: boolean; FirstTimeChar: AnsiChar = 'T'): integer; overload; /// convert to ready-to-be displayed text // - using i18nDateText global event, if set (e.g. by mORMoti18n.pas) function i18nText: string; /// convert to a Delphi Time function ToTime: TDateTime; /// convert to a Delphi Date // - will return 0 if the stored value is not a valid date function ToDate: TDateTime; /// convert to a Delphi Date and Time // - will return 0 if the stored value is not a valid date function ToDateTime: TDateTime; /// convert to a second-based c-encoded time (from Unix epoch 1/1/1970) function ToUnixTime: TUnixTime; /// convert to a millisecond-based c-encoded time (from Unix epoch 1/1/1970) // - of course, milliseconds will be 0 due to TTimeLog second resolution function ToUnixMSTime: TUnixMSTime; /// fill Value from specified Date and Time procedure From(Y,M,D, HH,MM,SS: cardinal); overload; /// fill Value from specified TDateTime procedure From(DateTime: TDateTime; DateOnly: Boolean=false); overload; /// fill Value from specified File Date procedure From(FileDate: integer); overload; /// fill Value from Iso-8601 encoded text procedure From(P: PUTF8Char; L: integer); overload; /// fill Value from Iso-8601 encoded text procedure From(const S: RawUTF8); overload; /// fill Value from specified Date/Time individual fields procedure From(Time: PSynSystemTime); overload; /// fill Value from second-based c-encoded time (from Unix epoch 1/1/1970) procedure FromUnixTime(const UnixTime: TUnixTime); /// fill Value from millisecond-based c-encoded time (from Unix epoch 1/1/1970) // - of course, millisecond resolution will be lost during conversion procedure FromUnixMSTime(const UnixMSTime: TUnixMSTime); /// fill Value from current local system Date and Time procedure FromNow; /// fill Value from current UTC system Date and Time // - FromNow uses local time: this function retrieves the system time // expressed in Coordinated Universal Time (UTC) procedure FromUTCTime; /// get the year (e.g. 2015) of the TTimeLog value function Year: Integer; {$ifdef HASINLINE}inline;{$endif} /// get the month (1..12) of the TTimeLog value function Month: Integer; {$ifdef HASINLINE}inline;{$endif} /// get the day (1..31) of the TTimeLog value function Day: Integer; {$ifdef HASINLINE}inline;{$endif} /// get the hour (0..23) of the TTimeLog value function Hour: integer; {$ifdef HASINLINE}inline;{$endif} /// get the minute (0..59) of the TTimeLog value function Minute: integer; {$ifdef HASINLINE}inline;{$endif} /// get the second (0..59) of the TTimeLog value function Second: integer; {$ifdef HASINLINE}inline;{$endif} end; /// get TTimeLog value from current local system date and time // - handle TTimeLog bit-encoded Int64 format function TimeLogNow: TTimeLog; {$ifdef HASINLINE}inline;{$endif} /// get TTimeLog value from current UTC system Date and Time // - handle TTimeLog bit-encoded Int64 format function TimeLogNowUTC: TTimeLog; {$ifdef HASINLINE}inline;{$endif} /// get TTimeLog value from a file date and time // - handle TTimeLog bit-encoded Int64 format function TimeLogFromFile(const FileName: TFileName): TTimeLog; /// get TTimeLog value from a given Delphi date and time // - handle TTimeLog bit-encoded Int64 format // - just a wrapper around PTimeLogBits(@aTime)^.From() // - we defined such a function since TTimeLogBits(aTimeLog).From() won't change // the aTimeLog variable content function TimeLogFromDateTime(const DateTime: TDateTime): TTimeLog; {$ifdef HASINLINE}inline;{$endif} /// get TTimeLog value from a given Unix seconds since epoch timestamp // - handle TTimeLog bit-encoded Int64 format // - just a wrapper around PTimeLogBits(@aTime)^.FromUnixTime() function TimeLogFromUnixTime(const UnixTime: TUnixTime): TTimeLog; {$ifdef HASINLINE}inline;{$endif} /// Date/Time conversion from a TTimeLog value // - handle TTimeLog bit-encoded Int64 format // - just a wrapper around PTimeLogBits(@Timestamp)^.ToDateTime // - we defined such a function since TTimeLogBits(aTimeLog).ToDateTime gives an // internall compiler error on some Delphi IDE versions (e.g. Delphi 6) function TimeLogToDateTime(const Timestamp: TTimeLog): TDateTime; {$ifdef HASINLINE}inline;{$endif} /// Unix seconds since epoch timestamp conversion from a TTimeLog value // - handle TTimeLog bit-encoded Int64 format // - just a wrapper around PTimeLogBits(@Timestamp)^.ToUnixTime function TimeLogToUnixTime(const Timestamp: TTimeLog): TUnixTime; {$ifdef HASINLINE}inline;{$endif} /// convert a Iso8601 encoded string into a TTimeLog value // - handle TTimeLog bit-encoded Int64 format // - use this function only for fast comparaison between two Iso8601 date/time // - conversion is faster than Iso8601ToDateTime: use only binary integer math // - ContainsNoTime optional pointer can be set to a boolean, which will be // set according to the layout in P (e.g. TRUE for '2012-05-26') // - returns 0 in case of invalid input string function Iso8601ToTimeLogPUTF8Char(P: PUTF8Char; L: integer; ContainsNoTime: PBoolean=nil): TTimeLog; /// convert a Iso8601 encoded string into a TTimeLog value // - handle TTimeLog bit-encoded Int64 format // - use this function only for fast comparaison between two Iso8601 date/time // - conversion is faster than Iso8601ToDateTime: use only binary integer math function Iso8601ToTimeLog(const S: RawByteString): TTimeLog; {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} /// test if P^ contains a valid ISO-8601 text encoded value // - calls internally Iso8601ToTimeLogPUTF8Char() and returns true if contains // at least a valid year (YYYY) function IsIso8601(P: PUTF8Char; L: integer): boolean; {$ifdef HASINLINE}inline;{$endif} /// Date/Time conversion from ISO-8601 // - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format // - will also recognize '.sss' milliseconds suffix, if any function Iso8601ToDateTime(const S: RawByteString): TDateTime; overload; {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} /// Date/Time conversion from ISO-8601 // - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format // - will also recognize '.sss' milliseconds suffix, if any // - if L is left to default 0, it will be computed from StrLen(P) function Iso8601ToDateTimePUTF8Char(P: PUTF8Char; L: integer=0): TDateTime; {$ifdef HASINLINE}inline;{$endif} /// Date/Time conversion from ISO-8601 // - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format, with potentially // shorten versions has handled by the ISO-8601 standard (e.g. 'YYYY') // - will also recognize '.sss' milliseconds suffix, if any // - if L is left to default 0, it will be computed from StrLen(P) procedure Iso8601ToDateTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); /// Date/Time conversion from strict ISO-8601 content // - recognize 'YYYY-MM-DDThh:mm:ss[.sss]' or 'YYYY-MM-DD' or 'Thh:mm:ss[.sss]' // patterns, as e.g. generated by TTextWriter.AddDateTime() or RecordSaveJSON() // - will also recognize '.sss' milliseconds suffix, if any function Iso8601CheckAndDecode(P: PUTF8Char; L: integer; var Value: TDateTime): boolean; /// Time conversion from ISO-8601 (with no Date part) // - handle 'hhmmss' and 'hh:mm:ss' format // - will also recognize '.sss' milliseconds suffix, if any // - if L is left to default 0, it will be computed from StrLen(P) function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer=0): TDateTime; overload; {$ifdef HASINLINE}inline;{$endif} /// Time conversion from ISO-8601 (with no Date part) // - handle 'hhmmss' and 'hh:mm:ss' format // - will also recognize '.sss' milliseconds suffix, if any // - if L is left to default 0, it will be computed from StrLen(P) procedure Iso8601ToTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); /// Time conversion from ISO-8601 (with no Date part) // - regnozie 'hhmmss' and 'hh:mm:ss' format into H,M,S variables // - will also recognize '.sss' milliseconds suffix, if any, into MS // - if L is left to default 0, it will be computed from StrLen(P) function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer; var H,M,S,MS: cardinal): boolean; overload; /// Interval date/time conversion from simple text // - expected format does not match ISO-8601 Time intervals format, but Oracle // interval litteral representation, i.e. '+/-D HH:MM:SS' // - e.g. IntervalTextToDateTime('+0 06:03:20') will return 0.25231481481 and // IntervalTextToDateTime('-20 06:03:20') -20.252314815 // - as a consequence, negative intervals will be written as TDateTime values: // !DateTimeToIso8601Text(IntervalTextToDateTime('+0 06:03:20'))='T06:03:20' // !DateTimeToIso8601Text(IntervalTextToDateTime('+1 06:03:20'))='1899-12-31T06:03:20' // !DateTimeToIso8601Text(IntervalTextToDateTime('-2 06:03:20'))='1899-12-28T06:03:20' function IntervalTextToDateTime(Text: PUTF8Char): TDateTime; {$ifdef HASINLINE}inline;{$endif} /// Interval date/time conversion from simple text // - expected format does not match ISO-8601 Time intervals format, but Oracle // interval litteral representation, i.e. '+/-D HH:MM:SS' // - e.g. '+1 06:03:20' will return 1.25231481481 procedure IntervalTextToDateTimeVar(Text: PUTF8Char; var result: TDateTime); /// basic Date/Time conversion into ISO-8601 // - use 'YYYYMMDDThhmmss' format if not Expanded // - use 'YYYY-MM-DDThh:mm:ss' format if Expanded // - if WithMS is TRUE, will append '.sss' for milliseconds resolution // - 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; /// basic Date conversion into ISO-8601 // - use 'YYYYMMDD' format if not Expanded // - use 'YYYY-MM-DD' format if Expanded function DateToIso8601(Date: TDateTime; Expanded: boolean): RawUTF8; overload; /// basic Date conversion into ISO-8601 // - use 'YYYYMMDD' format if not Expanded // - use 'YYYY-MM-DD' format if Expanded function DateToIso8601(Y,M,D: cardinal; Expanded: boolean): RawUTF8; overload; /// basic Date period conversion into ISO-8601 // - will convert an elapsed number of days as ISO-8601 text // - use 'YYYYMMDD' format if not Expanded // - use 'YYYY-MM-DD' format if Expanded function DaysToIso8601(Days: cardinal; Expanded: boolean): RawUTF8; /// basic Time conversion into ISO-8601 // - use 'Thhmmss' format if not Expanded // - use 'Thh:mm:ss' format if Expanded // - if WithMS is TRUE, will append '.sss' for milliseconds resolution function TimeToIso8601(Time: TDateTime; Expanded: boolean; FirstChar: AnsiChar='T'; WithMS: boolean=false): RawUTF8; /// Write a Date to P^ Ansi buffer // - if Expanded is false, 'YYYYMMDD' date format is used // - if Expanded is true, 'YYYY-MM-DD' date format is used procedure DateToIso8601PChar(P: PUTF8Char; Expanded: boolean; Y,M,D: PtrUInt); 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; /// Write a TDateTime value, expanded as Iso-8601 encoded text into P^ Ansi buffer // - if DT=0, returns '' // - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' // - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' // - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' // - if WithMS is TRUE, will append '.sss' for milliseconds resolution procedure DateTimeToIso8601ExpandedPChar(const Value: TDateTime; Dest: PUTF8Char; FirstChar: AnsiChar='T'; WithMS: boolean=false); /// write a TDateTime into strict ISO-8601 date and/or time text // - if DT=0, returns '' // - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' // - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' // - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' // - if WithMS is TRUE, will append '.sss' for milliseconds resolution // - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods function DateTimeToIso8601Text(DT: TDateTime; FirstChar: AnsiChar='T'; WithMS: boolean=false): RawUTF8; {$ifdef HASINLINE}inline;{$endif} /// write a TDateTime into strict ISO-8601 date and/or time text // - if DT=0, returns '' // - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' // - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' // - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' // - if WithMS is TRUE, will append '.sss' for milliseconds resolution // - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods procedure DateTimeToIso8601TextVar(DT: TDateTime; FirstChar: AnsiChar; var result: RawUTF8; WithMS: boolean=false); /// write a TDateTime into strict ISO-8601 date and/or time text // - if DT=0, returns '' // - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' // - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' // - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' // - if WithMS is TRUE, will append '.sss' for milliseconds resolution // - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods procedure DateTimeToIso8601StringVar(DT: TDateTime; FirstChar: AnsiChar; var result: string; WithMS: boolean=false); /// Write a Time to P^ Ansi buffer // - if Expanded is false, 'Thhmmss' time format is used // - if Expanded is true, 'Thh:mm:ss' time format is used // - you can custom the first char in from of the resulting text time // - if WithMS is TRUE, will append MS as '.sss' for milliseconds resolution procedure TimeToIso8601PChar(P: PUTF8Char; Expanded: boolean; H,M,S,MS: PtrUInt; FirstChar: AnsiChar = 'T'; WithMS: boolean=false); 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; var /// custom TTimeLog date to ready to be displayed text function // - you can override this pointer in order to display the text according // to your expected i18n settings // - this callback will therefore be set by the mORMoti18n.pas unit // - used e.g. by TTimeLogBits.i18nText and by TSQLTable.ExpandAsString() // methods, i.e. TSQLTableToGrid.DrawCell() i18nDateText: function(const Iso: TTimeLog): string = nil; /// custom date to ready to be displayed text function // - you can override this pointer in order to display the text according // to your expected i18n settings // - this callback will therefore be set by the mORMoti18n.pas unit // - used e.g. by TSQLTable.ExpandAsString() method, // i.e. TSQLTableToGrid.DrawCell() i18nDateTimeText: function(const DateTime: TDateTime): string = nil; /// wrapper calling global i18nDateTimeText() callback if set, // or returning ISO-8601 standard layout on default function DateTimeToi18n(const DateTime: TDateTime): string; /// fast conversion of 2 digit characters into a 0..99 value // - returns FALSE on success, TRUE if P^ is not correct function Char2ToByte(P: PUTF8Char; out Value: Cardinal): Boolean; /// fast conversion of 3 digit characters into a 0..9999 value // - returns FALSE on success, TRUE if P^ is not correct function Char3ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; /// fast conversion of 4 digit characters into a 0..9999 value // - returns FALSE on success, TRUE if P^ is not correct function Char4ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; /// our own fast version of the corresponding low-level function function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean; /// retrieve the current Date, in the ISO 8601 layout, but expanded and // ready to be displayed function NowToString(Expanded: boolean=true; FirstTimeChar: AnsiChar = ' '): RawUTF8; /// retrieve the current UTC Date, in the ISO 8601 layout, but expanded and // ready to be displayed function NowUTCToString(Expanded: boolean=true; FirstTimeChar: AnsiChar = ' '): RawUTF8; /// convert some date/time to the ISO 8601 text layout, including milliseconds // - i.e. 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format // - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') // - see also TTextWriter.AddDateTimeMS method function DateTimeMSToString(DateTime: TDateTime; Expanded: boolean=true; FirstTimeChar: AnsiChar=' '; const TZD: RawUTF8='Z'): RawUTF8; overload; /// convert some date/time to the ISO 8601 text layout, including milliseconds // - i.e. 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format // - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') // - see also TTextWriter.AddDateTimeMS method function DateTimeMSToString(HH,MM,SS,MS,Y,M,D: cardinal; Expanded: boolean; FirstTimeChar: AnsiChar=' '; const TZD: RawUTF8='Z'): RawUTF8; overload; /// convert some date/time to the "HTTP-date" format as defined by RFC 7231 // - i.e. "Tue, 15 Nov 1994 12:45:26 GMT" to be used as a value of // "Date", "Expires" or "Last-Modified" HTTP header // - if you care about timezones Value must be converted to UTC first // using TSynTimeZone.LocalToUtc function DateTimeToHTTPDate(UTCDateTime: TDateTime): RawUTF8; /// convert some TDateTime to a small text layout, perfect e.g. for naming a local file // - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting // a date > 1999 (a current date would be fine) function DateTimeToFileShort(const DateTime: TDateTime): TShort16; overload; {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell /// convert some TDateTime to a small text layout, perfect e.g. for naming a local file // - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting // a date > 1999 (a current date would be fine) procedure DateTimeToFileShort(const DateTime: TDateTime; out result: TShort16); overload; /// retrieve the current Time (whithout Date), in the ISO 8601 layout // - useful for direct on screen logging e.g. function TimeToString: RawUTF8; const /// a contemporary, but elapsed, TUnixTime second-based value // - corresponds to Thu, 08 Dec 2016 08:50:20 GMT // - may be used to check for a valid just-generated Unix timestamp value UNIXTIME_MINIMAL = 1481187020; /// convert a second-based c-encoded time as TDateTime // - i.e. number of seconds elapsed since Unix epoch 1/1/1970 into TDateTime function UnixTimeToDateTime(const UnixTime: TUnixTime): TDateTime; {$ifdef HASINLINE}inline;{$endif} /// convert a TDateTime into a second-based c-encoded time // - i.e. TDateTime into number of seconds elapsed since Unix epoch 1/1/1970 function DateTimeToUnixTime(const AValue: TDateTime): TUnixTime; {$ifdef HASINLINE}inline;{$endif} /// returns the current UTC date/time as a second-based c-encoded time // - i.e. current number of seconds elapsed since Unix epoch 1/1/1970 // - faster than NowUTC or GetTickCount64, on Windows or Unix platforms // (will use e.g. fast clock_gettime(CLOCK_REALTIME_COARSE) under Linux, // or GetSystemTimeAsFileTime under Windows) // - returns a 64-bit unsigned value, so is "Year2038bug" free function UnixTimeUTC: TUnixTime; {$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif} /// convert some second-based c-encoded time (from Unix epoch 1/1/1970) to // the ISO 8601 text layout // - use 'YYYYMMDDThhmmss' format if not Expanded // - use 'YYYY-MM-DDThh:mm:ss' format if Expanded function UnixTimeToString(const UnixTime: TUnixTime; Expanded: boolean=true; FirstTimeChar: AnsiChar='T'): RawUTF8; /// convert some second-based c-encoded time (from Unix epoch 1/1/1970) to // a small text layout, perfect e.g. for naming a local file // - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting // a date > 1999 (a current date would be fine) procedure UnixTimeToFileShort(const UnixTime: TUnixTime; out result: TShort16); overload; /// convert some second-based c-encoded time (from Unix epoch 1/1/1970) to // a small text layout, perfect e.g. for naming a local file // - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting // a date > 1999 (a current date would be fine) function UnixTimeToFileShort(const UnixTime: TUnixTime): TShort16; overload; {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell /// convert some second-based c-encoded time to the ISO 8601 text layout, either // as time or date elapsed period // - this function won't add the Unix epoch 1/1/1970 offset to the timestamp // - returns 'Thh:mm:ss' or 'YYYY-MM-DD' format, depending on the supplied value function UnixTimePeriodToString(const UnixTime: TUnixTime; FirstTimeChar: AnsiChar='T'): RawUTF8; /// returns the current UTC date/time as a millisecond-based c-encoded time // - i.e. current number of milliseconds elapsed since Unix epoch 1/1/1970 // - faster than NowUTC or GetTickCount64, on Windows or Unix platforms // (will use e.g. fast clock_gettime(CLOCK_REALTIME_COARSE) under Linux, // or GetSystemTimeAsFileTime under Windows) function UnixMSTimeUTC: TUnixMSTime; {$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif} /// convert a millisecond-based c-encoded time (from Unix epoch 1/1/1970) as TDateTime function UnixMSTimeToDateTime(const UnixMSTime: TUnixMSTime): TDateTime; {$ifdef HASINLINE}inline;{$endif} /// convert a TDateTime into a millisecond-based c-encoded time (from Unix epoch 1/1/1970) // - if AValue is 0, will return 0 (since is likely to be an error constant) function DateTimeToUnixMSTime(const AValue: TDateTime): TUnixMSTime; {$ifdef HASINLINE}inline;{$endif} /// convert some millisecond-based c-encoded time (from Unix epoch 1/1/1970) to // the ISO 8601 text layout, including milliseconds // - i.e. 'YYYY-MM-DDThh:mm:ss.sssZ' or 'YYYYMMDDThhmmss.sssZ' format // - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') function UnixMSTimeToString(const UnixMSTime: TUnixMSTime; Expanded: boolean=true; FirstTimeChar: AnsiChar='T'; const TZD: RawUTF8=''): RawUTF8; /// convert some milllisecond-based c-encoded time (from Unix epoch 1/1/1970) to // a small text layout, trimming to the second resolution, perfect e.g. for // naming a local file // - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting // a date > 1999 (a current date would be fine) function UnixMSTimeToFileShort(const UnixMSTime: TUnixMSTime): TShort16; {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell /// convert some millisecond-based c-encoded time to the ISO 8601 text layout, // as time or date elapsed period // - this function won't add the Unix epoch 1/1/1970 offset to the timestamp // - returns 'Thh:mm:ss' or 'YYYY-MM-DD' format, depending on the supplied value function UnixMSTimePeriodToString(const UnixMSTime: TUnixMSTime; FirstTimeChar: AnsiChar='T'): RawUTF8; /// returns the current UTC system date and time // - SysUtils.Now returns local time: this function returns the system time // expressed in Coordinated Universal Time (UTC) function NowUTC: TDateTime; type {$A-} /// used to store Time Zone bias in TSynTimeZone // - map how low-level information is stored in the Windows Registry TTimeZoneInfo = record Bias: integer; bias_std: integer; bias_dlt: integer; change_time_std: TSynSystemTime; change_time_dlt: TSynSystemTime; end; PTimeZoneInfo = ^TTimeZoneInfo; /// text identifier of a Time Zone, following Microsoft Windows naming TTimeZoneID = type RawUTF8; /// used to store Time Zone information for a single area in TSynTimeZone {$ifdef FPC_OR_UNICODE}TTimeZoneData = record{$else}TTimeZoneData = object{$endif} public id: TTimeZoneID; display: RawUTF8; tzi: TTimeZoneInfo; dyn: array of packed record year: integer; tzi: TTimeZoneInfo; end; function GetTziFor(year: integer): PTimeZoneInfo; end; /// used to store the Time Zone information of a TSynTimeZone class TTimeZoneDataDynArray = array of TTimeZoneData; {$A+} /// handle cross-platform time conversions, following Microsoft time zones // - is able to retrieve accurate information from the Windows registry, // or from a binary compressed file on other platforms (which should have been // saved from a Windows system first) // - each time zone will be idendified by its TzId string, as defined by // Microsoft for its Windows Operating system TSynTimeZone = class protected fZone: TTimeZoneDataDynArray; fZones: TDynArrayHashed; fLastZone: TTimeZoneID; fLastIndex: integer; fIds: TStringList; fDisplays: TStringList; public /// will retrieve the default shared TSynTimeZone instance // - locally created via the CreateDefault constructor // - this is the usual entry point for time zone process, calling e.g. // $ aLocalTime := TSynTimeZone.Default.NowToLocal(aTimeZoneID); class function Default: TSynTimeZone; /// initialize the internal storage // - but no data is available, until Load* methods are called constructor Create; /// retrieve the time zones from Windows registry, or from a local file // - under Linux, the file should be located with the executable, renamed // with a .tz extension - may have been created via SaveToFile(''), or // from a 'TSynTimeZone' bound resource // "dummy" parameter exists only to disambiguate constructors for C++ constructor CreateDefault(dummy: integer=0); /// finalize the instance destructor Destroy; override; {$ifdef MSWINDOWS} {$ifndef LVCL} /// read time zone information from the Windows registry procedure LoadFromRegistry; {$endif} {$endif MSWINDOWS} /// read time zone information from a compressed file // - if no file name is supplied, a ExecutableName.tz file would be used procedure LoadFromFile(const FileName: TFileName=''); /// read time zone information from a compressed memory buffer procedure LoadFromBuffer(const Buffer: RawByteString); /// read time zone information from a 'TSynTimeZone' resource // - the resource should contain the SaveToBuffer compressed binary content // - is no resource matching the TSynTimeZone class name and ResType=10 // do exist, nothing would be loaded // - the resource could be created as such, from a Windows system: // ! TSynTimeZone.Default.SaveToFile('TSynTimeZone.data'); // then compile the resource as expected, with a brcc32 .rc entry: // ! TSynTimeZone 10 "TSynTimeZone.data" // - you can specify a library (dll) resource instance handle, if needed procedure LoadFromResource(Instance: THandle=0); /// write then time zone information into a compressed file // - if no file name is supplied, a ExecutableName.tz file would be created procedure SaveToFile(const FileName: TFileName); /// write then time zone information into a compressed memory buffer 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; /// retrieve the display text corresponding to a TzId // - returns '' if the supplied TzId is not recognized function GetDisplay(const TzId: TTimeZoneID): RawUTF8; /// compute the UTC date/time corrected for a given TzId function UtcToLocal(const UtcDateTime: TDateTime; const TzId: TTimeZoneID): TDateTime; /// compute the current date/time corrected for a given TzId function NowToLocal(const TzId: TTimeZoneID): TDateTime; /// compute the UTC date/time for a given local TzId value // - by definition, a local time may correspond to two UTC times, during the // time biais period, so the returned value is informative only, and any // stored value should be following UTC function LocalToUtc(const LocalDateTime: TDateTime; const TzID: TTimeZoneID): TDateTime; /// direct access to the low-level time zone information property Zone: TTimeZoneDataDynArray read fZone; /// direct access to the wrapper over the time zone information array property Zones: TDynArrayHashed read fZones; /// returns a TStringList of all TzID values // - could be used to fill any VCL component to select the time zone // - order in Ids[] array follows the Zone[].id information function Ids: TStrings; /// returns a TStringList of all Display text values // - could be used to fill any VCL component to select the time zone // - order in Displays[] array follows the Zone[].display information function Displays: TStrings; end; {$ifndef ENHANCEDRTL} {$ifndef LVCL} { don't define these twice } var /// these procedure type must be defined if a default system.pas is used // - mORMoti18n.pas unit will hack default LoadResString() procedure // - already defined in our Extended system.pas unit // - needed with FPC, Delphi 2009 and up, i.e. when ENHANCEDRTL is not defined // - expect generic "string" type, i.e. UnicodeString for Delphi 2009+ // - not needed with the LVCL framework (we should be on server side) LoadResStringTranslate: procedure(var Text: string) = nil; /// current LoadResString() cached entries count // - i.e. resourcestring caching for faster use // - used only if a default system.pas is used, not our Extended version // - defined here, but resourcestring caching itself is implemented in the // mORMoti18n.pas unit, if the ENHANCEDRTL conditional is not defined CacheResCount: integer = -1; {$endif} {$endif} type /// a generic callback, which can be used to translate some text on the fly // - maps procedure TLanguageFile.Translate(var English: string) signature // as defined in mORMoti18n.pas // - can be used e.g. for TSynMustache's {{"English text}} callback TOnStringTranslate = procedure (var English: string) of object; const /// Rotate local log file if reached this size (1MB by default) // - .log file will be save as .log.bak file // - a new .log file is created // - used by AppendToTextFile() and LogToTextFile() functions (not TSynLog) MAXLOGSIZE = 1024*1024; /// log a message to a local text file // - the text file is located in the executable directory, and its name is // simply the executable file name with the '.log' extension instead of '.exe' // - format contains the current date and time, then the Msg on one line // - date and time format used is 'YYYYMMDD hh:mm:ss (i.e. ISO-8601)' procedure LogToTextFile(Msg: RawUTF8); /// log a message to a local text file // - this version expects the filename to be specified // - format contains the current date and time, then the Msg on one line // - date and time format used is 'YYYYMMDD hh:mm:ss' procedure AppendToTextFile(aLine: RawUTF8; const aFileName: TFileName; aMaxSize: Int64=MAXLOGSIZE; aUTCTimeStamp: boolean=false); { ************ fast low-level lookup types used by internal conversion routines } {$ifndef ENHANCEDRTL} {$ifndef LVCL} { don't define these const twice } const /// fast lookup table for converting any decimal number from // 0 to 99 into their ASCII equivalence // - our enhanced SysUtils.pas (normal and LVCL) contains the same array TwoDigitLookup: packed array[0..99] of array[1..2] of AnsiChar = ('00','01','02','03','04','05','06','07','08','09', '10','11','12','13','14','15','16','17','18','19', '20','21','22','23','24','25','26','27','28','29', '30','31','32','33','34','35','36','37','38','39', '40','41','42','43','44','45','46','47','48','49', '50','51','52','53','54','55','56','57','58','59', '60','61','62','63','64','65','66','67','68','69', '70','71','72','73','74','75','76','77','78','79', '80','81','82','83','84','85','86','87','88','89', '90','91','92','93','94','95','96','97','98','99'); {$endif} {$endif} var /// fast lookup table for converting any decimal number from // 0 to 99 into their ASCII equivalence TwoDigitLookupW: packed array[0..99] of word absolute TwoDigitLookup; const {$ifdef OPT4AMD} // circumvent Delphi 5 and Delphi 6 compilation issues :( ANSICHARNOT01310: TSynAnsicharSet = [#1..#9,#11,#12,#14..#255]; IsWord: TSynByteSet = [ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')]; IsIdentifier: TSynByteSet = [ord('_'),ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')]; IsJsonIdentifierFirstChar: TSynByteSet = [ord('_'),ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z'),ord('$')]; IsJsonIdentifier: TSynByteSet = [ord('_'),ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z'), ord('.'),ord('['),ord(']')]; IsURIUnreserved: TSynByteSet = [ord('a')..ord('z'),ord('A')..ord('Z'),ord('0')..ord('9'), ord('-'),ord('.'),ord('_'),ord('~')]; {$else} /// used e.g. by inlined function GetLineContains() ANSICHARNOT01310 = [#1..#9,#11,#12,#14..#255]; /// used internaly for fast word recognition (32 bytes const) IsWord = [ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')]; /// used internaly for fast identifier recognition (32 bytes const) // - can be used e.g. for field or table name // - this char set matches the classical pascal definition of identifiers // - see also PropNameValid() and PropNamesValid() IsIdentifier = [ord('_'),ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')]; /// used internaly for fast extended JSON property name recognition (32 bytes const) // - can be used e.g. for extended JSON object field // - follow JsonPropNameValid, GetJSONPropName and GotoNextJSONObjectOrArray IsJsonIdentifierFirstChar = [ord('_'),ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z'),ord('$')]; /// used internaly for fast extended JSON property name recognition (32 bytes const) // - can be used e.g. for extended JSON object field // - follow JsonPropNameValid, GetJSONPropName and GotoNextJSONObjectOrArray IsJsonIdentifier = [ord('_'),ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z'), ord('.'),ord('['),ord(']')]; /// used internaly for fast URI "unreserved" characters identifier // - defined as unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~" // in @http://tools.ietf.org/html/rfc3986#section-2.3 IsURIUnreserved = [ord('a')..ord('z'),ord('A')..ord('Z'),ord('0')..ord('9'), ord('-'),ord('.'),ord('_'),ord('~')]; {$endif OPT4AMD} {$M+} // to have existing RTTI for published properties type /// used to retrieve version information from any EXE // - under Linux, all version numbers are set to 0 by default // - you should not have to use this class directly, but via the // ExeVersion global variable TFileVersion = class protected fDetailed: string; fFileName: TFileName; fBuildDateTime: TDateTime; /// change the version (not to be used in most cases) procedure SetVersion(aMajor,aMinor,aRelease,aBuild: integer); public /// executable major version number Major: Integer; /// executable minor version number Minor: Integer; /// executable release version number Release: Integer; /// executable release build number Build: Integer; /// build year of this exe file BuildYear: word; /// version info of the exe file as '3.1' // - return "string" type, i.e. UnicodeString for Delphi 2009+ Main: string; /// associated CompanyName string version resource // - only available on Windows - contains '' under Linux CompanyName: RawUTF8; /// associated FileDescription string version resource // - only available on Windows - contains '' under Linux FileDescription: RawUTF8; /// associated FileVersion string version resource // - only available on Windows - contains '' under Linux FileVersion: RawUTF8; /// associated InternalName string version resource // - only available on Windows - contains '' under Linux InternalName: RawUTF8; /// associated LegalCopyright string version resource // - only available on Windows - contains '' under Linux LegalCopyright: RawUTF8; /// associated OriginalFileName string version resource // - only available on Windows - contains '' under Linux OriginalFilename: RawUTF8; /// associated ProductName string version resource // - only available on Windows - contains '' under Linux ProductName: RawUTF8; /// associated ProductVersion string version resource // - only available on Windows - contains '' under Linux ProductVersion: RawUTF8; /// associated Comments string version resource // - only available on Windows - contains '' under Linux Comments: RawUTF8; /// retrieve application version from exe file name // - DefaultVersion32 is used if no information Version was included into // the executable resources (on compilation time) // - you should not have to use this constructor, but rather access the // ExeVersion global variable constructor Create(const aFileName: TFileName; aMajor: integer=0; aMinor: integer=0; aRelease: integer=0; aBuild: integer=0); /// retrieve the version as a 32-bit integer with Major.Minor.Release // - following Major shl 16+Minor shl 8+Release bit pattern function Version32: integer; /// build date and time of this exe file, as plain text function BuildDateTimeString: string; /// version info of the exe file as '3.1.0.123' or '' // - this method returns '' if Detailed is '0.0.0.0' function DetailedOrVoid: string; /// returns the version information of this exe file as text // - includes FileName (without path), Detailed and BuildDateTime properties // - e.g. 'myprogram.exe 3.1.0.123 2016-06-14 19:07:55' function VersionInfo: RawUTF8; /// returns a ready-to-use User-Agent header with exe name, version and OS // - e.g. 'myprogram/3.1.0.123W32' // - here OS_INITIAL[] character is used to identify the OS, with '32' // appended on 32-bit Windows function UserAgent: RawUTF8; /// returns the version information of a specified exe file as text // - includes FileName (without path), Detailed and BuildDateTime properties // - e.g. 'myprogram.exe 3.1.0.123 2016-06-14 19:07:55' class function GetVersionInfo(const aFileName: TFileName): RawUTF8; published /// version info of the exe file as '3.1.0.123' // - return "string" type, i.e. UnicodeString for Delphi 2009+ // - under Linux, always return '0.0.0.0' if no custom version number // has been defined // - consider using DetailedOrVoid method if '0.0.0.0' is not expected property Detailed: string read fDetailed write fDetailed; /// build date and time of this exe file property BuildDateTime: TDateTime read fBuildDateTime write fBuildDateTime; end; {$M-} {$ifdef DELPHI6OROLDER} // define some common constants not available prior to Delphi 7 const HoursPerDay = 24; MinsPerHour = 60; SecsPerMin = 60; MSecsPerSec = 1000; MinsPerDay = HoursPerDay * MinsPerHour; SecsPerDay = MinsPerDay * SecsPerMin; MSecsPerDay = SecsPerDay * MSecsPerSec; DateDelta = 693594; UnixDateDelta = 25569; /// GetFileVersion returns the most significant 32-bit of a file's binary // version number // - typically, this includes the major and minor version placed // together in one 32-bit integer // - generally does not include the release or build numbers // - returns Cardinal(-1) in case of failure function GetFileVersion(const FileName: TFileName): cardinal; {$endif DELPHI6OROLDER} type /// the recognized operating systems // - it will also recognize some Linux distributions TOperatingSystem = (osUnknown, osWindows, osLinux, osOSX, osBSD, osPOSIX, osArch, osAurox, osDebian, osFedora, osGentoo, osKnoppix, osMint, osMandrake, osMandriva, osNovell, osUbuntu, osSlackware, osSolaris, osSuse, osSynology, osTrustix, osClear, osUnited, osRedHat, osLFS, osOracle, osMageia, osCentOS, osCloud, osXen, osAmazon, osCoreOS, osAlpine); /// the recognized Windows versions // - defined even outside MSWINDOWS to allow process e.g. from monitoring tools TWindowsVersion = ( wUnknown, w2000, wXP, wXP_64, wServer2003, wServer2003_R2, wVista, wVista_64, wServer2008, wServer2008_64, wSeven, wSeven_64, wServer2008_R2, wServer2008_R2_64, wEight, wEight_64, wServer2012, wServer2012_64, wEightOne, wEightOne_64, wServer2012R2, wServer2012R2_64, wTen, wTen_64, wServer2016, wServer2016_64, wServer2019_64); /// the running Operating System, encoded as a 32-bit integer TOperatingSystemVersion = packed record case os: TOperatingSystem of osUnknown: (b: array[0..2] of byte); osWindows: (win: TWindowsVersion); osLinux: (utsrelease: array[0..2] of byte); end; const /// the recognized Windows versions, as plain text // - defined even outside MSWINDOWS to allow process e.g. from monitoring tools WINDOWS_NAME: array[TWindowsVersion] of RawUTF8 = ( '', '2000', 'XP', 'XP 64bit', 'Server 2003', 'Server 2003 R2', 'Vista', 'Vista 64bit', 'Server 2008', 'Server 2008 64bit', '7', '7 64bit', 'Server 2008 R2', 'Server 2008 R2 64bit', '8', '8 64bit', 'Server 2012', 'Server 2012 64bit', '8.1', '8.1 64bit', 'Server 2012 R2', 'Server 2012 R2 64bit', '10', '10 64bit', 'Server 2016', 'Server 2016 64bit', '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]; /// translate one operating system (and distribution) into a single character // - may be used internally e.g. for a HTTP User-Agent header OS_INITIAL: array[TOperatingSystem] of AnsiChar = ('?', 'W', 'L', 'X', 'B', 'P', 'A', 'a', 'D', 'F', 'G', 'K', 'M', 'm', 'n', 'N', 'U', 'S', 's', 'u', 'Y', 'T', 'C', 't', 'R', 'l', 'O', 'G', 'c', 'd', 'x', 'Z', 'r', 'p'); /// the operating systems items which actually are Linux distributions OS_LINUX = [osLinux, osArch .. osAlpine]; /// the compiler family used COMP_TEXT = {$ifdef FPC}'Fpc'{$else}'Delphi'{$endif}; /// the target Operating System used for compilation, as text OS_TEXT = {$ifdef MSWINDOWS}'Win'{$else}{$ifdef DARWIN}'OSX'{$else} {$ifdef BSD}'BSD'{$else}{$ifdef LINUX}'Linux'{$else}'Posix' {$endif}{$endif}{$endif}{$endif}; /// the CPU architecture used for compilation CPU_ARCH_TEXT = {$ifdef CPUX86}'x86'{$else}{$ifdef CPUX64}'x64'{$else} {$ifdef CPUARM}'arm'+{$else} {$ifdef CPUPOWERPC}'ppc'+{$else} {$ifdef CPUSPARC}'sparc'+{$endif}{$endif}{$endif} {$ifdef CPU32}'32'{$else}'64'{$endif}{$endif}{$endif}; function ToText(os: TOperatingSystem): PShortString; overload; function ToText(const osv: TOperatingSystemVersion): ShortString; overload; function ToTextOS(osint32: integer): RawUTF8; var /// the target Operating System used for compilation, as TOperatingSystem OS_KIND: TOperatingSystem = {$ifdef MSWINDOWS}osWindows{$else}{$ifdef DARWIN}osOSX{$else} {$ifdef BSD}osBSD{$else}{$ifdef LINUX}osLinux{$else}osPOSIX {$endif}{$endif}{$endif}{$endif}; /// the current Operating System version, as retrieved for the current process // - contains e.g. 'Windows Seven 64 SP1 (6.1.7601)' or // 'Ubuntu 16.04.5 LTS - Linux 3.13.0 110 generic#157 Ubuntu SMP Mon Feb 20 11:55:25 UTC 2017' OSVersionText: RawUTF8; /// some textual information about the current CPU CpuInfoText: RawUTF8; /// some textual information about the current computer hardware, from BIOS BiosInfoText: RawUTF8; /// the running Operating System OSVersion32: TOperatingSystemVersion; OSVersionInt32: integer absolute OSVersion32; {$ifdef MSWINDOWS} {$ifndef UNICODE} type /// low-level API structure, not defined in older Delphi versions TOSVersionInfoEx = record dwOSVersionInfoSize: DWORD; dwMajorVersion: DWORD; dwMinorVersion: DWORD; dwBuildNumber: DWORD; dwPlatformId: DWORD; szCSDVersion: array[0..127] of char; wServicePackMajor: WORD; wServicePackMinor: WORD; wSuiteMask: WORD; wProductType: BYTE; wReserved: BYTE; end; {$endif UNICODE} var /// is set to TRUE if the current process is a 32-bit image running under WOW64 // - WOW64 is the x86 emulator that allows 32-bit Windows-based applications // to run seamlessly on 64-bit Windows // - equals always FALSE if the current executable is a 64-bit image IsWow64: boolean; /// the current System information, as retrieved for the current process // - under a WOW64 process, it will use the GetNativeSystemInfo() new API // to retrieve the real top-most system information // - note that the lpMinimumApplicationAddress field is replaced by a // more optimistic/realistic value ($100000 instead of default $10000) // - under BSD/Linux, only contain dwPageSize and dwNumberOfProcessors fields SystemInfo: TSystemInfo; /// the current Operating System information, as retrieved for the current process OSVersionInfo: TOSVersionInfoEx; /// the current Operating System version, as retrieved for the current process OSVersion: TWindowsVersion; /// this function can be used to create a GDI compatible window, able to // receive Windows Messages for fast local communication // - will return 0 on failure (window name already existing e.g.), or // the created HWND handle on success // - it will call the supplied message handler defined for a given Windows Message: // for instance, define such a method in any object definition: // ! procedure WMCopyData(var Msg : TWMCopyData); message WM_COPYDATA; function CreateInternalWindow(const aWindowName: string; aObject: TObject): HWND; /// delete the window resources used to receive Windows Messages // - must be called for each CreateInternalWindow() function // - both parameter values are then reset to ''/0 function ReleaseInternalWindow(var aWindowName: string; var aWindow: HWND): boolean; /// under Windows 7 and later, will set an unique application-defined // Application User Model ID (AppUserModelID) that identifies the current // process to the taskbar // - this identifier allows an application to group its associated processes // and windows under a single taskbar button // - value can have no more than 128 characters, cannot contain spaces, and // each section should be camel-cased, as such: // $ CompanyName.ProductName.SubProduct.VersionInformation // CompanyName and ProductName should always be used, while the SubProduct and // VersionInformation portions are optional and depend on the application's requirements // - if the supplied text does not contain an '.', 'ID.ID' will be used function SetAppUserModelID(const AppUserModelID: string): boolean; var /// the number of milliseconds that have elapsed since the system was started // - compatibility function, to be implemented according to the running OS // - will use the corresponding native API function under Vista+, or // will emulate it for older Windows versions (XP) // - warning: FPC's SysUtils.GetTickCount64 or TThread.GetTickCount64 don't // handle properly 49 days wrapping under XP -> always use this safe version GetTickCount64: function: Int64; stdcall; /// similar to Windows sleep() API call, to be truly cross-platform // - it should have a millisecond resolution, and handle ms=0 as a switch to // another pending thread, i.e. under Windows will call SwitchToThread API procedure SleepHiRes(ms: cardinal); /// low-level wrapper to get the 64-bit value from a TFileTime // - as recommended by MSDN to avoid dword alignment issue procedure FileTimeToInt64(const FT: TFileTime; out I64: Int64); {$ifdef HASINLINE}inline;{$endif} /// low-level conversion of a Windows 64-bit TFileTime into a Unix time seconds stamp function FileTimeToUnixTime(const FT: TFileTime): TUnixTime; /// low-level conversion of a Windows 64-bit TFileTime into a Unix time ms stamp function FileTimeToUnixMSTime(const FT: TFileTime): TUnixMSTime; {$else MSWINDOWS} var /// emulate only some used fields of Windows' TSystemInfo SystemInfo: record // retrieved from libc's getpagesize() dwPageSize: cardinal; // retrieved from HW_NCPU (BSD) or /proc/cpuinfo (Linux) dwNumberOfProcessors: cardinal; // as returned by fpuname() uts: UtsName; // as from /etc/*-release release: RawUTF8; end; {$ifdef KYLIX3} /// compatibility function for Linux function GetCurrentThreadID: TThreadID; cdecl; external 'libpthread.so.0' name 'pthread_self'; /// overloaded function using open64() to allow 64-bit positions function FileOpen(const FileName: string; Mode: LongWord): Integer; {$endif} /// compatibility function, to be implemented according to the running OS // - expect more or less the same result as the homonymous Win32 API function, // but usually with a better resolution (Windows has only around 10-16 ms) // - will call the corresponding function in SynKylix.pas or SynFPCLinux.pas, // using the very fast CLOCK_MONOTONIC_COARSE if available on the kernel function GetTickCount64: Int64; {$endif MSWINDOWS} /// overloaded function optimized for one pass file reading // - will use e.g. the FILE_FLAG_SEQUENTIAL_SCAN flag under Windows, as stated // by http://blogs.msdn.com/b/oldnewthing/archive/2012/01/20/10258690.aspx // - is used e.g. by StringFromFile() and TSynMemoryStreamMapped.Create() function FileOpenSequentialRead(const FileName: string): Integer; {$ifdef HASINLINE}inline;{$endif} /// returns a TFileStream optimized for one pass file reading // - will use FileOpenSequentialRead(), i.e. FILE_FLAG_SEQUENTIAL_SCAN function FileStreamSequentialRead(const FileName: string): TFileStream; /// check if the current timestamp, in ms, matched a given period // - will compare the current GetTickCount64 to the supplied PreviousTix // - returns TRUE if the Internal ms period was not elapsed // - returns TRUE, and set PreviousTix, if the Interval ms period was elapsed // - possible use case may be: // !var Last: Int64; // !... // ! Last := GetTickCount64; // ! repeat // ! ... // ! if Elapsed(Last,1000) then begin // ! ... // do something every second // ! end; // ! until Terminated; // !... function Elapsed(var PreviousTix: Int64; Interval: Integer): Boolean; /// thread-safe move of a 32-bit value using a simple Read-Copy-Update pattern procedure RCU32(var src,dst); /// thread-safe move of a 64-bit value using a simple Read-Copy-Update pattern procedure RCU64(var src,dst); /// thread-safe move of a 128-bit value using a simple Read-Copy-Update pattern procedure RCU128(var src,dst); /// thread-safe move of a pointer value using a simple Read-Copy-Update pattern procedure RCUPtr(var src,dst); /// thread-safe move of a memory buffer using a simple Read-Copy-Update pattern procedure RCU(var src,dst; len: integer); {$ifndef FPC} { FPC defines those functions as built-in } /// compatibility function, to be implemented according to the running CPU // - expect the same result as the homonymous Win32 API function function InterlockedIncrement(var I: Integer): Integer; {$ifdef PUREPASCAL}{$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif}{$endif} /// compatibility function, to be implemented according to the running CPU // - expect the same result as the homonymous Win32 API function function InterlockedDecrement(var I: Integer): Integer; {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} {$endif FPC} type /// stores some global information about the current executable and computer TExeVersion = record /// the main executable name, without any path nor extension // - e.g. 'Test' for 'c:\pathto\Test.exe' ProgramName: RawUTF8; /// the main executable details, as used e.g. by TSynLog // - e.g. 'C:\Dev\lib\SQLite3\exe\TestSQL3.exe 0.0.0.0 (2011-03-29 11:09:06)' ProgramFullSpec: RawUTF8; /// the main executable file name (including full path) // - same as paramstr(0) ProgramFileName: TFileName; /// the main executable full path (excluding .exe file name) // - same as ExtractFilePath(paramstr(0)) ProgramFilePath: TFileName; /// the full path of the running executable or library // - for an executable, same as paramstr(0) // - for a library, will contain the whole .dll file name InstanceFileName: TFileName; /// the current executable version Version: TFileVersion; /// the current computer host name Host: RawUTF8; /// the current computer user name User: RawUTF8; /// some hash representation of this information // - the very same executable on the very same computer run by the very // same user will always have the same Hash value // - is computed from the crc32c of this TExeVersion fields: c0 from // Version32, CpuFeatures and Host, c1 from User, c2 from ProgramFullSpec // and c3 from InstanceFileName // - may be used as an entropy seed, or to identify a process execution Hash: THash128Rec; end; var /// global information about the current executable and computer // - this structure is initialized in this unit's initialization block below // - you can call SetExecutableVersion() with a custom version, if needed ExeVersion: TExeVersion; /// initialize ExeVersion global variable, supplying a custom version number // - by default, the version numbers will be retrieved at startup from the // executable itself (if it was included at build time) // - but you can use this function to set any custom version numbers procedure SetExecutableVersion(aMajor,aMinor,aRelease,aBuild: integer); overload; /// initialize ExeVersion global variable, supplying the version as text // - e.g. SetExecutableVersion('7.1.2.512'); procedure SetExecutableVersion(const aVersionText: RawUTF8); overload; type /// identify an operating system folder TSystemPath = ( spCommonData, spUserData, spCommonDocuments, spUserDocuments, spTempFolder, spLog); /// returns an operating system folder // - will return the full path of a given kind of private or shared folder, // depending on the underlying operating system // - will use SHGetFolderPath and the corresponding CSIDL constant under Windows // - under POSIX, will return $TMP/$TMPDIR folder for spTempFolder, ~/.cache/appname // for spUserData, /var/log for spLog, or the $HOME folder // - returned folder name contains the trailing path delimiter (\ or /) function GetSystemPath(kind: TSystemPath): TFileName; /// self-modifying code - change some memory buffer in the code segment // - if Backup is not nil, it should point to a Size array of bytes, ready // to contain the overridden code buffer, for further hook disabling procedure PatchCode(Old,New: pointer; Size: integer; Backup: pointer=nil; LeaveUnprotected: boolean=false); /// self-modifying code - change one PtrUInt in the code segment procedure PatchCodePtrUInt(Code: PPtrUInt; Value: PtrUInt; LeaveUnprotected: boolean=false); {$ifdef CPUINTEL} type /// small memory buffer used to backup a RedirectCode() redirection hook TPatchCode = array[0..4] of byte; /// pointer to a small memory buffer used to backup a RedirectCode() hook PPatchCode = ^TPatchCode; /// self-modifying code - add an asm JUMP to a redirected function // - if Backup is not nil, it should point to a TPatchCode buffer, ready // to contain the overridden code buffer, for further hook disabling procedure RedirectCode(Func, RedirectFunc: Pointer; Backup: PPatchCode=nil); /// self-modifying code - restore a code from its RedirectCode() backup procedure RedirectCodeRestore(Func: pointer; const Backup: TPatchCode); {$endif CPUINTEL} type /// to be used instead of TMemoryStream, for speed // - allocates memory from Delphi heap (i.e. FastMM4/SynScaleMM) // and not GlobalAlloc(), as was the case for oldest versions of Delphi // - uses bigger growing size of the capacity // - consider using TRawByteStringStream, as we do in our units {$ifdef LVCL} // LVCL already use Delphi heap instead of GlobalAlloc() THeapMemoryStream = TMemoryStream; {$else} {$ifdef FPC} // FPC already use heap instead of GlobalAlloc() THeapMemoryStream = TMemoryStream; {$else} {$ifdef MSWINDOWS} THeapMemoryStream = class(TMemoryStream) protected function Realloc(var NewCapacity: longint): Pointer; override; end; {$else} THeapMemoryStream = TMemoryStream; {$endif} {$endif} {$endif} var /// a global "Garbage collector", for some classes instances which must // live during whole main executable process // - used to avoid any memory leak with e.g. 'class var RecordProps', i.e. // some singleton or static objects // - to be used, e.g. as: // ! Version := TFileVersion.Create(InstanceFileName,DefaultVersion32); // ! GarbageCollector.Add(Version); // - see also GarbageCollectorFreeAndNil() as an alternative GarbageCollector: TObjectList; /// set to TRUE when the global "Garbage collector" are beeing freed GarbageCollectorFreeing: boolean; /// a global "Garbage collector" for some TObject global variables which must // live during whole main executable process // - this list expects a pointer to the TObject instance variable to be // specified, and will be set to nil (like a FreeAndNil) // - this may be useful when used when targetting Delphi IDE packages, // to circumvent the bug of duplicated finalization of units, in the scope // of global variables // - to be used, e.g. as: // ! if SynAnsiConvertList=nil then // ! GarbageCollectorFreeAndNil(SynAnsiConvertList,TObjectList.Create); procedure GarbageCollectorFreeAndNil(var InstanceVariable; Instance: TObject); /// force the global "Garbage collector" list to be released immediately // - this function is called in the finalization section of this unit // - you should NEVER have to call this function, unless some specific cases // (e.g. when using Delphi packages, just before releasing the package) procedure GarbageCollectorFree; /// enter a giant lock for thread-safe shared process // - shall be protected as such: // ! GlobalLock; // ! try // ! .... do something thread-safe but as short as possible // ! finally // ! GlobalUnLock; // ! end; // - you should better not use such a giant-lock, but an instance-dedicated // critical section - these functions are just here to be convenient, for // non time critical process procedure GlobalLock; /// release the giant lock for thread-safe shared process // - you should better not use such a giant-lock, but an instance-dedicated // critical section - these functions are just here to be convenient, for // non time critical process procedure GlobalUnLock; /// JSON compatible representation of a boolean value // - returns either 'true' or 'false' procedure JSONBoolean(value: boolean; var result: RawUTF8); {$ifdef HASINLINE}inline;{$endif} overload; const /// can be used e.g. in logs BOOL_STR: array[boolean] of string[7] = ('false','true'); /// can be used to append to most English nouns to form a plural // - see also the Plural function PLURAL_FORM: array[boolean] of RawUTF8 = ('','s'); /// write count number and append 's' (if needed) to form a plural English noun // - for instance, Plural('row',100) returns '100 rows' with no heap allocation function Plural(const itemname: shortstring; itemcount: cardinal): shortstring; /// returns TRUE if the specified field name is either 'ID', either 'ROWID' function IsRowID(FieldName: PUTF8Char): boolean; {$ifdef HASINLINE}inline;{$endif} overload; /// returns TRUE if the specified field name is either 'ID', either 'ROWID' function IsRowID(FieldName: PUTF8Char; FieldLen: integer): boolean; {$ifdef HASINLINE}inline;{$endif} overload; /// returns TRUE if the specified field name is either 'ID', either 'ROWID' function IsRowIDShort(const FieldName: shortstring): boolean; {$ifdef HASINLINE}inline;{$endif} overload; /// retrieve the next identifier within the UTF-8 buffer // - returns true if something was set to Prop function GetNextFieldProp(var P: PUTF8Char; var Prop: RawUTF8): boolean; { ************ variant-based process, including JSON/BSON document content } const /// unsigned 64bit integer variant type // - currently called varUInt64 in Delphi (not defined in older versions), // and varQWord in FPC varWord64 = 21; /// this variant type will map the current SynUnicode type // - depending on the compiler version varSynUnicode = {$ifdef HASVARUSTRING}varUString{$else}varOleStr{$endif}; /// this variant type will map the current string type // - depending on the compiler version varNativeString = {$ifdef UNICODE}varUString{$else}varString{$endif}; /// those TVarData.VType values are un-managed and do not need to be cleared // - used mainly in low-level code similar to the folllowing: // ! if TVarData(aVariant).VType and VTYPE_STATIC<>0 then // ! VarClear(aVariant); // - equals private constant varDeepData in Delphi's Variants.pas and // varComplexType in FPC's variants.pp - seldom used on FPC // - make some false positive to varBoolean and varError VTYPE_STATIC = $BFE8; /// same as Dest := TVarData(Source) for simple values // - will return TRUE for all simple values after varByRef unreference, and // copying the unreferenced Source value into Dest raw storage // - will return FALSE for not varByRef values, or complex values (e.g. string) function SetVariantUnRefSimpleValue(const Source: variant; var Dest: TVarData): boolean; {$ifdef HASINLINE}inline;{$endif} {$ifndef LVCL} /// convert a raw binary buffer into a variant RawByteString varString // - you can then use VariantToRawByteString() to retrieve the binary content procedure RawByteStringToVariant(Data: PByte; DataLen: Integer; var Value: variant); overload; /// convert a RawByteString content into a variant varString // - you can then use VariantToRawByteString() to retrieve the binary content procedure RawByteStringToVariant(const Data: RawByteString; var Value: variant); overload; /// convert back a RawByteString from a variant // - the supplied variant should have been created via a RawByteStringToVariant() // function call procedure VariantToRawByteString(const Value: variant; var Dest: RawByteString); /// same as Value := Null, but slightly faster procedure SetVariantNull(var Value: variant); {$ifdef HASINLINE}inline;{$endif} const NullVarData: TVarData = (VType: varNull); var /// a slightly faster alternative to Variants.Null function Null: variant absolute NullVarData; {$endif} /// same as VarIsEmpty(V) or VarIsEmpty(V), but faster // - we also discovered some issues with FPC's Variants unit, so this function // may be used even in end-user cross-compiler code function VarIsEmptyOrNull(const V: Variant): Boolean; {$ifdef HASINLINE}inline;{$endif} /// same as VarIsEmpty(PVariant(V)^) or VarIsEmpty(PVariant(V)^), but faster // - we also discovered some issues with FPC's Variants unit, so this function // may be used even in end-user cross-compiler code function VarDataIsEmptyOrNull(VarData: pointer): Boolean; {$ifdef HASINLINE}inline;{$endif} /// fastcheck if a variant hold a value // - varEmpty, varNull or a '' string would be considered as void // - varBoolean=false or varDate=0 would be considered as void // - a TDocVariantData with Count=0 would be considered as void // - any other value (e.g. integer) would be considered as not void function VarIsVoid(const V: Variant): boolean; type TVarDataTypes = set of 0..255; /// allow to check for a specific set of TVarData.VType function VarIs(const V: Variant; const VTypes: TVarDataTypes): Boolean; {$ifdef HASINLINE}inline;{$endif} {$ifndef NOVARIANTS} type /// an abstract ancestor for faster access of properties // - default GetProperty/SetProperty methods are called via some protected // virtual IntGet/IntSet methods, with less overhead // - these kind of custom variants will be faster than the default // TInvokeableVariantType for properties getter/setter, but you should // manually register each type by calling SynRegisterCustomVariantType() // - also feature custom JSON parsing, via TryJSONToVariant() protected method TSynInvokeableVariantType = class(TInvokeableVariantType) protected {$ifndef FPC} {$ifndef DELPHI6OROLDER} /// our custom call backs do not want the function names to be uppercased function FixupIdent(const AText: string): string; override; {$endif} {$endif} /// override those two abstract methods for fast getter/setter implementation procedure IntGet(var Dest: TVarData; const V: TVarData; Name: PAnsiChar); virtual; abstract; procedure IntSet(const V, Value: TVarData; Name: PAnsiChar); virtual; abstract; public /// customization of JSON parsing into variants // - will be called by e.g. by VariantLoadJSON() or GetVariantFromJSON() // with Options: PDocVariantOptions parameter not nil // - this default implementation will always returns FALSE, // meaning that the supplied JSON is not to be handled by this custom // (abstract) variant type // - this method could be overridden to identify any custom JSON content // and convert it into a dedicated variant instance, then return TRUE // - warning: should NOT modify JSON buffer in-place, unless it returns true function TryJSONToVariant(var JSON: PUTF8Char; var Value: variant; EndOfObject: PUTF8Char): boolean; virtual; /// customization of variant into JSON serialization procedure ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind); overload; virtual; /// retrieve the field/column value // - this method will call protected IntGet abstract method function GetProperty(var Dest: TVarData; const V: TVarData; const Name: String): Boolean; override; /// set the field/column value // - this method will call protected IntSet abstract method {$ifdef FPC_VARIANTSETVAR} // see http://mantis.freepascal.org/view.php?id=26773 function SetProperty(var V: TVarData; const Name: string; const Value: TVarData): Boolean; override; {$else} function SetProperty(const V: TVarData; const Name: string; const Value: TVarData): Boolean; override; {$endif} /// clear the content // - this default implementation will set VType := varEmpty // - override it if your custom type needs to manage its internal memory procedure Clear(var V: TVarData); override; /// copy two variant content // - this default implementation will copy the TVarData memory // - override it if your custom type needs to manage its internal structure procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override; /// copy two variant content by value // - this default implementation will call the Copy() method // - override it if your custom types may use a by reference copy pattern procedure CopyByValue(var Dest: TVarData; const Source: TVarData); virtual; /// this method will allow to look for dotted name spaces, e.g. 'parent.child' // - should return Unassigned if the FullName does not match any value // - this default implementation will handle TDocVariant storage, or using // generic TSynInvokeableVariantType.IntGet() until nested value match // - you can override it with a more optimized version procedure Lookup(var Dest: TVarData; const V: TVarData; FullName: PUTF8Char); virtual; /// will check if the value is an array, and return the number of items // - if the document is an array, will return the items count (0 meaning // void array) // - this default implementation will return -1 (meaning this is not an array) // - overridden method could implement it, e.g. for TDocVariant of kind dvArray function IterateCount(const V: TVarData): integer; virtual; /// allow to loop over an array value // - Index should be in 0..IterateCount-1 range // - this default implementation will do nothing procedure Iterate(var Dest: TVarData; const V: TVarData; Index: integer); virtual; /// returns TRUE if the supplied variant is of the exact custom type function IsOfType(const V: variant): boolean; end; /// class-reference type (metaclass) of custom variant type definition // - used by SynRegisterCustomVariantType() function TSynInvokeableVariantTypeClass = class of TSynInvokeableVariantType; /// register a custom variant type to handle properties // - this will implement an internal mechanism used to bypass the default // _DispInvoke() implementation in Variant.pas, to use a faster version // - is called in case of TSynTableVariant, TDocVariant, TBSONVariant or // TSQLDBRowVariant function SynRegisterCustomVariantType(aClass: TSynInvokeableVariantTypeClass): TSynInvokeableVariantType; type /// possible options for a TDocVariant JSON/BSON document storage // - dvoIsArray and dvoIsObject will store the "Kind: TDocVariantKind" state - // you should never have to define these two options directly // - dvoNameCaseSensitive will be used for every name lookup - here // case-insensitivity is restricted to a-z A-Z 0-9 and _ characters // - dvoCheckForDuplicatedNames will be used for method // TDocVariantData.AddValue(), but not when setting properties at // variant level: for consistency, "aVariant.AB := aValue" will replace // any previous value for the name "AB" // - dvoReturnNullForUnknownProperty will be used when retrieving any value // from its name (for dvObject kind of instance), or index (for dvArray or // dvObject kind of instance) // - by default, internal values will be copied by-value from one variant // instance to another, to ensure proper safety - but it may be too slow: // if you set dvoValueCopiedByReference, the internal // TDocVariantData.VValue/VName instances will be copied by-reference, // to avoid memory allocations, BUT it may break internal process if you change // some values in place (since VValue/VName and VCount won't match) - as such, // if you set this option, ensure that you use the content as read-only // - any registered custom types may have an extended JSON syntax (e.g. // TBSONVariant does for MongoDB types), and will be searched during JSON // parsing, unless dvoJSONParseDoNotTryCustomVariants is set (slightly faster) // - by default, it will only handle direct JSON [array] of {object}: but if // you define dvoJSONObjectParseWithinString, it will also try to un-escape // a JSON string first, i.e. handle "[array]" or "{object}" content (may be // used e.g. when JSON has been retrieved from a database TEXT column) - is // used for instance by VariantLoadJSON() // - JSON serialization will follow the standard layout, unless // dvoSerializeAsExtendedJson is set so that the property names would not // be escaped with double quotes, writing '{name:"John",age:123}' instead of // '{"name":"John","age":123}': this extended json layout is compatible with // http://docs.mongodb.org/manual/reference/mongodb-extended-json and with // TDocVariant JSON unserialization, also our SynCrossPlatformJSON unit, but // NOT recognized by most JSON clients, like AJAX/JavaScript or C#/Java // - by default, only integer/Int64/currency number values are allowed, unless // dvoAllowDoubleValue is set and 32-bit floating-point conversion is tried, // with potential loss of precision during the conversion // - dvoInternNames and dvoInternValues will use shared TRawUTF8Interning // instances to maintain a list of RawUTF8 names/values for all TDocVariant, // so that redundant text content will be allocated only once on heap TDocVariantOption = (dvoIsArray, dvoIsObject, dvoNameCaseSensitive, dvoCheckForDuplicatedNames, dvoReturnNullForUnknownProperty, dvoValueCopiedByReference, dvoJSONParseDoNotTryCustomVariants, dvoJSONObjectParseWithinString, dvoSerializeAsExtendedJson, dvoAllowDoubleValue, dvoInternNames, dvoInternValues); /// set of options for a TDocVariant storage // - you can use JSON_OPTIONS[true] if you want to create a fast by-reference // local document as with _ObjFast/_ArrFast/_JsonFast - i.e. // [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference] // - when specifying the options, you should not include dvoIsArray nor // dvoIsObject directly in the set, but explicitly define TDocVariantDataKind TDocVariantOptions = set of TDocVariantOption; /// pointer to a set of options for a TDocVariant storage // - you may use e.g. @JSON_OPTIONS[true], @JSON_OPTIONS[false], // @JSON_OPTIONS_FAST_STRICTJSON or @JSON_OPTIONS_FAST_EXTENDED PDocVariantOptions = ^TDocVariantOptions; const /// some convenient TDocVariant options, as JSON_OPTIONS[CopiedByReference] // - JSON_OPTIONS[false] is e.g. _Json() and _JsonFmt() functions default // - JSON_OPTIONS[true] are used e.g. by _JsonFast() and _JsonFastFmt() functions JSON_OPTIONS: array[Boolean] of TDocVariantOptions = ( [dvoReturnNullForUnknownProperty], [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]); /// same as JSON_OPTIONS[true], but can not be used as PDocVariantOptions JSON_OPTIONS_FAST = [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]; /// TDocVariant options which may be used for plain JSON parsing // - this won't recognize any extended syntax JSON_OPTIONS_FAST_STRICTJSON: TDocVariantOptions = [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, dvoJSONParseDoNotTryCustomVariants]; /// TDocVariant options to be used for case-sensitive TSynNameValue-like // storage, with optional extended JSON syntax serialization // - consider using JSON_OPTIONS_FAST_EXTENDED for case-insensitive objects JSON_OPTIONS_NAMEVALUE: array[boolean] of TDocVariantOptions = ( [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, dvoNameCaseSensitive], [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, dvoNameCaseSensitive,dvoSerializeAsExtendedJson]); /// TDocVariant options to be used for case-sensitive TSynNameValue-like // storage, RawUTF8 interning and optional extended JSON syntax serialization // - consider using JSON_OPTIONS_FAST_EXTENDED for case-insensitive objects, // or JSON_OPTIONS_NAMEVALUE[] if you don't expect names and values interning JSON_OPTIONS_NAMEVALUEINTERN: array[boolean] of TDocVariantOptions = ( [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, dvoNameCaseSensitive,dvoInternNames,dvoInternValues], [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, dvoNameCaseSensitive,dvoInternNames,dvoInternValues, dvoSerializeAsExtendedJson]); /// TDocVariant options to be used so that JSON serialization would // use the unquoted JSON syntax for field names // - you could use it e.g. on a TSQLRecord variant published field to // reduce the JSON escape process during storage in the database, by // customizing your TSQLModel instance: // ! (aModel.Props[TSQLMyRecord]['VariantProp'] as TSQLPropInfoRTTIVariant). // ! DocVariantOptions := JSON_OPTIONS_FAST_EXTENDED; // or - in a cleaner way - by overriding TSQLRecord.InternalDefineModel(): // ! class procedure TSQLMyRecord.InternalDefineModel(Props: TSQLRecordProperties); // ! begin // ! (Props.Fields.ByName('VariantProp') as TSQLPropInfoRTTIVariant). // ! DocVariantOptions := JSON_OPTIONS_FAST_EXTENDED; // ! end; // or to set all variant fields at once: // ! class procedure TSQLMyRecord.InternalDefineModel(Props: TSQLRecordProperties); // ! begin // ! Props.SetVariantFieldsDocVariantOptions(JSON_OPTIONS_FAST_EXTENDED); // ! end; // - consider using JSON_OPTIONS_NAMEVALUE[true] for case-sensitive // TSynNameValue-like storage, or JSON_OPTIONS_FAST_EXTENDEDINTERN if you // expect RawUTF8 names and values interning JSON_OPTIONS_FAST_EXTENDED: TDocVariantOptions = [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, dvoSerializeAsExtendedJson]; /// TDocVariant options for JSON serialization with efficient storage // - i.e. unquoted JSON syntax for field names and RawUTF8 interning // - may be used e.g. for efficient persistence of similar data // - consider using JSON_OPTIONS_FAST_EXTENDED if you don't expect // RawUTF8 names and values interning, or need BSON variants parsing JSON_OPTIONS_FAST_EXTENDEDINTERN: TDocVariantOptions = [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, dvoSerializeAsExtendedJson,dvoJSONParseDoNotTryCustomVariants, dvoInternNames,dvoInternValues]; /// same as Dest := Source, but copying by reference // - i.e. VType is defined as varVariant or varByRef // - for instance, it will be used for late binding of TDocVariant properties, // to let following statements work as expected: // ! V := _Json('{arr:[1,2]}'); // ! V.arr.Add(3); // will work, since V.arr will be returned by reference // ! writeln(V); // will write '{"arr":[1,2,3]}' procedure SetVariantByRef(const Source: Variant; var Dest: Variant); /// same as Dest := Source, but copying by value // - will unreference any varByRef content // - will convert any string value into RawUTF8 (varString) for consistency procedure SetVariantByValue(const Source: Variant; var Dest: Variant); /// same as FillChar(Value^,SizeOf(TVarData),0) // - so can be used for TVarData or Variant // - it will set V.VType := varEmpty, so Value will be Unassigned // - it won't call VarClear(variant(Value)): it should have been cleaned before procedure ZeroFill(Value: PVarData); {$ifdef HASINLINE}inline;{$endif} /// fill all bytes of the value's memory buffer with zeros, i.e. 'toto' -> #0#0#0#0 // - may be used to cleanup stack-allocated content procedure FillZero(var value: variant); overload; /// retrieve a variant value from variable-length buffer // - matches TFileBufferWriter.Write() // - how custom type variants are created can be defined via CustomVariantOptions // - is just a wrapper around VariantLoad() procedure FromVarVariant(var Source: PByte; var Value: variant; CustomVariantOptions: PDocVariantOptions=nil); {$ifdef HASINLINE}inline;{$endif} /// compute the number of bytes needed to save a Variant content // using the VariantSave() function // - will return 0 in case of an invalid (not handled) Variant type function VariantSaveLength(const Value: variant): integer; /// save a Variant content into a destination memory buffer // - Dest must be at least VariantSaveLength() bytes long // - will handle standard Variant types and custom types (serialized as JSON) // - will return nil in case of an invalid (not handled) Variant type // - will use a proprietary binary format, with some variable-length encoding // of the string length // - warning: will encode generic string fields as within the variant type // itself: using this function between UNICODE and NOT UNICODE // versions of Delphi, will propably fail - you have been warned! function VariantSave(const Value: variant; Dest: PAnsiChar): PAnsiChar; overload; /// save a Variant content into a binary buffer // - will handle standard Variant types and custom types (serialized as JSON) // - will return '' in case of an invalid (not handled) Variant type // - just a wrapper around VariantSaveLength()+VariantSave() // - warning: will encode generic string fields as within the variant type // itself: using this function between UNICODE and NOT UNICODE // versions of Delphi, will propably fail - you have been warned! function VariantSave(const Value: variant): RawByteString; overload; /// retrieve a variant value from our optimized binary serialization format // - follow the data layout as used by RecordLoad() or VariantSave() function // - return nil if the Source buffer is incorrect // - in case of success, return the memory buffer pointer just after the // read content // - how custom type variants are created can be defined via CustomVariantOptions function VariantLoad(var Value: variant; Source: PAnsiChar; CustomVariantOptions: PDocVariantOptions): PAnsiChar; overload; /// retrieve a variant value from our optimized binary serialization format // - follow the data layout as used by RecordLoad() or VariantSave() function // - return varEmpty if the Source buffer is incorrect // - just a wrapper around VariantLoad() // - how custom type variants are created can be defined via CustomVariantOptions function VariantLoad(const Bin: RawByteString; CustomVariantOptions: PDocVariantOptions): variant; overload; /// retrieve a variant value from a JSON number or string // - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) // - will instantiate either an Integer, Int64, currency, double or string value // (as RawUTF8), guessing the best numeric type according to the textual content, // and string in all other cases, except TryCustomVariants points to some options // (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or // array, either encoded as strict-JSON (i.e. {..} or [..]), or with some // extended (e.g. BSON) syntax // - warning: the JSON buffer will be modified in-place during process - use // a temporary copy or the overloaded functions with RawUTF8 parameter // if you need to access it later function VariantLoadJSON(var Value: variant; JSON: PUTF8Char; EndOfObject: PUTF8Char=nil; TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false): PUTF8Char; overload; /// retrieve a variant value from a JSON number or string // - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) // - will instantiate either an Integer, Int64, currency, double or string value // (as RawUTF8), guessing the best numeric type according to the textual content, // and string in all other cases, except TryCustomVariants points to some options // (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or // array, either encoded as strict-JSON (i.e. {..} or [..]), or with some // extended (e.g. BSON) syntax // - this overloaded procedure will make a temporary copy before JSON parsing // and return the variant as result procedure VariantLoadJSON(var Value: Variant; const JSON: RawUTF8; TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false); overload; /// retrieve a variant value from a JSON number or string // - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) // - will instantiate either an Integer, Int64, currency, double or string value // (as RawUTF8), guessing the best numeric type according to the textual content, // and string in all other cases, except TryCustomVariants points to some options // (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or // array, either encoded as strict-JSON (i.e. {..} or [..]), or with some // extended (e.g. BSON) syntax // - this overloaded procedure will make a temporary copy before JSON parsing // and return the variant as result function VariantLoadJSON(const JSON: RawUTF8; TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false): variant; overload; /// save a variant value into a JSON content // - follows the TTextWriter.AddVariant() and VariantLoadJSON() format // - is able to handle simple and custom variant types, for instance: // ! VariantSaveJSON(1.5)='1.5' // ! VariantSaveJSON('test')='"test"' // ! o := _Json('{ BSON: [ "test", 5.05, 1986 ] }'); // ! VariantSaveJSON(o)='{"BSON":["test",5.05,1986]}' // ! o := _Obj(['name','John','doc',_Obj(['one',1,'two',_Arr(['one',2])])]); // ! VariantSaveJSON(o)='{"name":"John","doc":{"one":1,"two":["one",2]}}' // - note that before Delphi 2009, any varString value is expected to be // a RawUTF8 instance - which does make sense in the mORMot area function VariantSaveJSON(const Value: variant; Escape: TTextWriterKind=twJSONEscape): RawUTF8; overload; /// save a variant value into a JSON content // - follows the TTextWriter.AddVariant() and VariantLoadJSON() format // - is able to handle simple and custom variant types, for instance: // ! VariantSaveJSON(1.5)='1.5' // ! VariantSaveJSON('test')='"test"' // ! o := _Json('{BSON: ["test", 5.05, 1986]}'); // ! VariantSaveJSON(o)='{"BSON":["test",5.05,1986]}' // ! o := _Obj(['name','John','doc',_Obj(['one',1,'two',_Arr(['one',2])])]); // ! VariantSaveJSON(o)='{"name":"John","doc":{"one":1,"two":["one",2]}}' // - note that before Delphi 2009, any varString value is expected to be // a RawUTF8 instance - which does make sense in the mORMot area procedure VariantSaveJSON(const Value: variant; Escape: TTextWriterKind; var result: RawUTF8); overload; /// compute the number of chars needed to save a variant value into a JSON content // - follows the TTextWriter.AddVariant() and VariantLoadJSON() format // - this will be much faster than length(VariantSaveJSON()) for huge content // - note that before Delphi 2009, any varString value is expected to be // a RawUTF8 instance - which does make sense in the mORMot area function VariantSaveJSONLength(const Value: variant; Escape: TTextWriterKind=twJSONEscape): integer; /// low-level function to set a variant from an unescaped JSON number or string // - expect the JSON input buffer to be already unescaped, e.g. by GetJSONField() // - is called e.g. by function VariantLoadJSON() // - will instantiate either a null, boolean, Integer, Int64, currency, double // (if AllowDouble is true or dvoAllowDoubleValue is in TryCustomVariants^) or // string value (as RawUTF8), guessing the best numeric type according to the textual content, // and string in all other cases, except if TryCustomVariants points to some // options (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known // object or array, either encoded as strict-JSON (i.e. {..} or [..]), // or with some extended (e.g. BSON) syntax procedure GetVariantFromJSON(JSON: PUTF8Char; wasString: Boolean; var Value: variant; TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false); /// low-level function to set a variant from an unescaped JSON non string // - expect the JSON input buffer to be already unescaped, e.g. by GetJSONField(), // and having returned wasString=TRUE (i.e. not surrounded by double quotes) // - is called e.g. by function GetVariantFromJSON() // - will recognize null, boolean, Integer, Int64, currency, double // (if AllowDouble is true) input, then set Value and return TRUE // - returns FALSE if the supplied input has no expected JSON format function GetVariantFromNotStringJSON(JSON: PUTF8Char; var Value: TVarData; AllowDouble: boolean): boolean; /// identify either varInt64, varDouble, varCurrency types following JSON format // - any non valid number is returned as varString // - is used e.g. by GetVariantFromJSON() to guess the destination variant type // - warning: supplied JSON is expected to be not nil function TextToVariantNumberType(JSON: PUTF8Char): word; /// identify either varInt64 or varCurrency types following JSON format // - this version won't return varDouble, i.e. won't handle more than 4 exact // decimals (as varCurrency), nor scientific notation with exponent (1.314e10) // - this will ensure that any incoming JSON will converted back with its exact // textual representation, without digit truncation due to limited precision // - any non valid number is returned as varString // - is used e.g. by GetVariantFromJSON() to guess the destination variant type // - warning: supplied JSON is expected to be not nil function TextToVariantNumberTypeNoDouble(JSON: PUTF8Char): word; /// low-level function to set a numerical variant from an unescaped JSON number // - returns TRUE if TextToVariantNumberType/TextToVariantNumberTypeNoDouble(JSON) // identified it as a number and set Value to the corresponding content // - returns FALSE if JSON is a string, or null/true/false function GetNumericVariantFromJSON(JSON: PUTF8Char; var Value: TVarData; AllowVarDouble: boolean): boolean; /// convert the next CSV item from an UTF-8 encoded text buffer // into a variant number or RawUTF8 varString // - first try with GetNumericVariantFromJSON(), then fallback to RawUTF8ToVariant // - is a wrapper around GetNextItem() + TextToVariant() function GetNextItemToVariant(var P: PUTF8Char; out Value: Variant; Sep: AnsiChar= ','; AllowDouble: boolean=true): boolean; /// convert an UTF-8 encoded text buffer into a variant number or RawUTF8 varString // - first try with GetNumericVariantFromJSON(), then fallback to RawUTF8ToVariant procedure TextToVariant(const aValue: RawUTF8; AllowVarDouble: boolean; out aDest: variant); /// convert an UTF-8 encoded text buffer into a variant RawUTF8 varString procedure RawUTF8ToVariant(Txt: PUTF8Char; TxtLen: integer; var Value: variant); overload; /// convert an UTF-8 encoded string into a variant RawUTF8 varString procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: variant); overload; /// convert a FormatUTF8() UTF-8 encoded string into a variant RawUTF8 varString procedure FormatUTF8ToVariant(const Fmt: RawUTF8; const Args: array of const; var Value: variant); /// convert an UTF-8 encoded string into a variant RawUTF8 varString function RawUTF8ToVariant(const Txt: RawUTF8): variant; overload; {$ifdef HASINLINE}inline;{$endif} /// convert an UTF-8 encoded text buffer into a variant RawUTF8 varString // - this overloaded version expects a destination variant type (e.g. varString // varOleStr / varUString) - if the type is not handled, will raise an // EVariantTypeCastError procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: TVarData; ExpectedValueType: word); overload; /// convert an open array (const Args: array of const) argument to a variant // - note that, due to a Delphi compiler limitation, cardinal values should be // type-casted to Int64() (otherwise the integer mapped value will be converted) procedure VarRecToVariant(const V: TVarRec; var result: variant); overload; /// convert an open array (const Args: array of const) argument to a variant // - note that, due to a Delphi compiler limitation, cardinal values should be // type-casted to Int64() (otherwise the integer mapped value will be converted) function VarRecToVariant(const V: TVarRec): variant; overload; {$ifdef HASINLINE}inline;{$endif} /// convert a variant to an open array (const Args: array of const) argument // - will always map to a vtVariant kind of argument procedure VariantToVarRec(const V: variant; var result: TVarRec); {$ifdef HASINLINE}inline;{$endif} /// convert a dynamic array of variants into its JSON serialization // - will use a TDocVariantData temporary storage function VariantDynArrayToJSON(const V: TVariantDynArray): RawUTF8; /// convert a JSON array into a dynamic array of variants // - will use a TDocVariantData temporary storage function JSONToVariantDynArray(const JSON: RawUTF8): TVariantDynArray; /// convert an open array list into a dynamic array of variants // - will use a TDocVariantData temporary storage function ValuesToVariantDynArray(const items: array of const): TVariantDynArray; type /// pointer to a TDocVariant storage // - since variants may be stored by reference (i.e. as varByRef), it may // be a good idea to use such a pointer via DocVariantData(aVariant)^ or // _Safe(aVariant)^ instead of TDocVariantData(aVariant), // if you are not sure how aVariant was allocated (may be not _Obj/_Json) PDocVariantData = ^TDocVariantData; /// a custom variant type used to store any JSON/BSON document-based content // - i.e. name/value pairs for objects, or an array of values (including // nested documents), stored in a TDocVariantData memory structure // - you can use _Obj()/_ObjFast() _Arr()/_ArrFast() _Json()/_JsonFast() or // _JsonFmt()/_JsonFastFmt() functions to create instances of such variants // - property access may be done via late-binding - with some restrictions // for older versions of FPC, e.g. allowing to write: // ! TDocVariant.NewFast(aVariant); // ! aVariant.Name := 'John'; // ! aVariant.Age := 35; // ! writeln(aVariant.Name,' is ',aVariant.Age,' years old'); // - it also supports a small set of pseudo-properties or pseudo-methods: // ! aVariant._Count = DocVariantData(aVariant).Count // ! aVariant._Kind = ord(DocVariantData(aVariant).Kind) // ! aVariant._JSON = DocVariantData(aVariant).JSON // ! aVariant._(i) = DocVariantData(aVariant).Value[i] // ! aVariant.Value(i) = DocVariantData(aVariant).Value[i] // ! aVariant.Value(aName) = DocVariantData(aVariant).Value[aName] // ! aVariant.Name(i) = DocVariantData(aVariant).Name[i] // ! aVariant.Add(aItem) = DocVariantData(aVariant).AddItem(aItem) // ! aVariant._ := aItem = DocVariantData(aVariant).AddItem(aItem) // ! aVariant.Add(aName,aValue) = DocVariantData(aVariant).AddValue(aName,aValue) // ! aVariant.Exists(aName) = DocVariantData(aVariant).GetValueIndex(aName)>=0 // ! aVariant.Delete(i) = DocVariantData(aVariant).Delete(i) // ! aVariant.Delete(aName) = DocVariantData(aVariant).Delete(aName) // ! aVariant.NameIndex(aName) = DocVariantData(aVariant).GetValueIndex(aName) // - it features direct JSON serialization/unserialization, e.g.: // ! assert(_Json('["one",2,3]')._JSON='["one",2,3]'); // - it features direct trans-typing into a string encoded as JSON, e.g.: // ! assert(_Json('["one",2,3]')='["one",2,3]'); TDocVariant = class(TSynInvokeableVariantType) protected fInternNames: TRawUTF8Interning; fInternValues: TRawUTF8Interning; /// fast getter/setter implementation procedure IntGet(var Dest: TVarData; const V: TVarData; Name: PAnsiChar); override; procedure IntSet(const V, Value: TVarData; Name: PAnsiChar); override; public /// initialize a variant instance to store some document-based content // - by default, every internal value will be copied, so access of nested // properties can be slow - if you expect the data to be read-only or not // propagated into another place, set aOptions=[dvoValueCopiedByReference] // will increase the process speed a lot class procedure New(out aValue: variant; aOptions: TDocVariantOptions=[]); overload; {$ifdef HASINLINE}inline;{$endif} /// initialize a variant instance to store per-reference document-based content // - same as New(aValue,JSON_OPTIONS[true]); // - to be used e.g. as // !var v: variant; // !begin // ! TDocVariant.NewFast(v); // ! ... class procedure NewFast(out aValue: variant); overload; {$ifdef HASINLINE}inline;{$endif} /// ensure a variant is a TDocVariant instance // - if aValue is not a TDocVariant, will create a new JSON_OPTIONS[true] class procedure IsOfTypeOrNewFast(var aValue: variant); /// initialize several variant instances to store document-based content // - replace several calls to TDocVariantData.InitFast // - to be used e.g. as // !var v1,v2,v3: TDocVariantData; // !begin // ! TDocVariant.NewFast([@v1,@v2,@v3]); // ! ... class procedure NewFast(const aValues: array of PDocVariantData); overload; /// initialize a variant instance to store some document-based content // - you can use this function to create a variant, which can be nested into // another document, e.g.: // ! aVariant := TDocVariant.New; // ! aVariant.id := 10; // - by default, every internal value will be copied, so access of nested // properties can be slow - if you expect the data to be read-only or not // propagated into another place, set Options=[dvoValueCopiedByReference] // will increase the process speed a lot // - in practice, you should better use _Obj()/_ObjFast() _Arr()/_ArrFast() // functions or TDocVariant.NewFast() class function New(Options: TDocVariantOptions=[]): variant; overload; {$ifdef HASINLINE}inline;{$endif} /// initialize a variant instance to store some document-based object content // - object will be initialized with data supplied two by two, as Name,Value // pairs, e.g. // ! aVariant := TDocVariant.NewObject(['name','John','year',1972]); // which is the same as: // ! TDocVariant.New(aVariant); // ! TDocVariantData(aVariant).AddValue('name','John'); // ! TDocVariantData(aVariant).AddValue('year',1972); // - by default, every internal value will be copied, so access of nested // properties can be slow - if you expect the data to be read-only or not // propagated into another place, set Options=[dvoValueCopiedByReference] // will increase the process speed a lot // - in practice, you should better use the function _Obj() which is a // wrapper around this class method class function NewObject(const NameValuePairs: array of const; Options: TDocVariantOptions=[]): variant; /// initialize a variant instance to store some document-based array content // - array will be initialized with data supplied as parameters, e.g. // ! aVariant := TDocVariant.NewArray(['one',2,3.0]); // which is the same as: // ! TDocVariant.New(aVariant); // ! TDocVariantData(aVariant).AddItem('one'); // ! TDocVariantData(aVariant).AddItem(2); // ! TDocVariantData(aVariant).AddItem(3.0); // - by default, every internal value will be copied, so access of nested // properties can be slow - if you expect the data to be read-only or not // propagated into another place, set aOptions=[dvoValueCopiedByReference] // will increase the process speed a lot // - in practice, you should better use the function _Arr() which is a // wrapper around this class method class function NewArray(const Items: array of const; Options: TDocVariantOptions=[]): variant; overload; /// initialize a variant instance to store some document-based array content // - array will be initialized with data supplied dynamic array of variants class function NewArray(const Items: TVariantDynArray; Options: TDocVariantOptions=[]): variant; overload; /// initialize a variant instance to store some document-based object content // from a supplied (extended) JSON content // - in addition to the JSON RFC specification strict mode, this method will // handle some BSON-like extensions, e.g. unquoted field names // - a private copy of the incoming JSON buffer will be used, then // it will call the TDocVariantData.InitJSONInPlace() method // - to be used e.g. as: // ! var V: variant; // ! begin // ! V := TDocVariant.NewJSON('{"id":10,"doc":{"name":"John","birthyear":1972}}'); // ! assert(V.id=10); // ! assert(V.doc.name='John'); // ! assert(V.doc.birthYear=1972); // ! // and also some pseudo-properties: // ! assert(V._count=2); // ! assert(V.doc._kind=ord(dvObject)); // - or with a JSON array: // ! V := TDocVariant.NewJSON('["one",2,3]'); // ! assert(V._kind=ord(dvArray)); // ! for i := 0 to V._count-1 do // ! writeln(V._(i)); // - by default, every internal value will be copied, so access of nested // properties can be slow - if you expect the data to be read-only or not // propagated into another place, add dvoValueCopiedByReference in Options // will increase the process speed a lot // - in practice, you should better use the function _Json()/_JsonFast() // which are handy wrappers around this class method class function NewJSON(const JSON: RawUTF8; Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; {$ifdef HASINLINE}inline;{$endif} /// initialize a variant instance to store some document-based object content // from a supplied existing TDocVariant instance // - use it on a value returned as varByRef (e.g. by _() pseudo-method), // to ensure the returned variant will behave as a stand-alone value // - for instance, the following: // ! oSeasons := TDocVariant.NewUnique(o.Seasons); // is the same as: // ! oSeasons := o.Seasons; // ! _Unique(oSeasons); // or even: // ! oSeasons := _Copy(o.Seasons); class function NewUnique(const SourceDocVariant: variant; Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; {$ifdef HASINLINE}inline;{$endif} /// will return the unique element of a TDocVariant array or a default // - if the value is a dvArray with one single item, it will this value // - if the value is not a TDocVariant nor a dvArray with one single item, // it wil return the default value class procedure GetSingleOrDefault(const docVariantArray, default: variant; var result: variant); /// finalize the stored information destructor Destroy; override; /// used by dvoInternNames for string interning of all Names[] values function InternNames: TRawUTF8Interning; {$ifdef HASINLINE}inline;{$endif} /// used by dvoInternValues for string interning of all RawUTF8 Values[] function InternValues: TRawUTF8Interning; {$ifdef HASINLINE}inline;{$endif} // this implementation will write the content as JSON object or array procedure ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind); override; /// will check if the value is an array, and return the number of items // - if the document is an array, will return the items count (0 meaning // void array) // - this overridden method will implement it for dvArray instance kind function IterateCount(const V: TVarData): integer; override; /// allow to loop over an array value // - Index should be in 0..IterateCount-1 range // - this default implementation will do handle dvArray instance kind procedure Iterate(var Dest: TVarData; const V: TVarData; Index: integer); override; /// low-level callback to access internal pseudo-methods // - mainly the _(Index: integer): variant method to retrieve an item // if the document is an array function DoFunction(var Dest: TVarData; const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean; override; /// low-level callback to clear the content procedure Clear(var V: TVarData); override; /// low-level callback to copy two variant content // - such copy will by default be done by-value, for safety // - if you are sure you will use the variants as read-only, you can set // the dvoValueCopiedByReference Option to use faster by-reference copy procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override; /// copy two variant content by value // - overridden method since instance may use a by-reference copy pattern procedure CopyByValue(var Dest: TVarData; const Source: TVarData); override; /// handle type conversion // - only types processed by now are string/OleStr/UnicodeString/date procedure Cast(var Dest: TVarData; const Source: TVarData); override; /// handle type conversion // - only types processed by now are string/OleStr/UnicodeString/date procedure CastTo(var Dest: TVarData; const Source: TVarData; const AVarType: TVarType); override; /// compare two variant values // - it uses case-sensitive text comparison of the JSON representation // of each variant (including TDocVariant instances) procedure Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult); override; end; /// define the TDocVariant storage layout // - if it has one or more named properties, it is a dvObject // - if it has no name property, it is a dvArray TDocVariantKind = (dvUndefined, dvObject, dvArray); /// method used by TDocVariantData.ReduceAsArray to filter each object // - should return TRUE if the item match the expectations TOnReducePerItem = function(Item: PDocVariantData): boolean of object; /// method used by TDocVariantData.ReduceAsArray to filter each object // - should return TRUE if the item match the expectations TOnReducePerValue = function(const Value: variant): boolean of object; {$A-} { packet object not allowed since Delphi 2009 :( } /// memory structure used for TDocVariant storage of any JSON/BSON // document-based content as variant // - i.e. name/value pairs for objects, or an array of values (including // nested documents) // - you can use _Obj()/_ObjFast() _Arr()/_ArrFast() _Json()/_JsonFast() or // _JsonFmt()/_JsonFastFmt() functions to create instances of such variants // - you can transtype such an allocated variant into TDocVariantData // to access directly its internals (like Count or Values[]/Names[]): // ! aVariantObject := TDocVariant.NewObject(['name','John','year',1972]); // ! aVariantObject := _ObjFast(['name','John','year',1972]); // ! with TDocVariantData(aVariantObject) do // ! for i := 0 to Count-1 do // ! writeln(Names[i],'=',Values[i]); // for an object // ! aVariantArray := TDocVariant.NewArray(['one',2,3.0]); // ! aVariantArray := _JsonFast('["one",2,3.0]'); // ! with TDocVariantData(aVariantArray) do // ! for i := 0 to Count-1 do // ! writeln(Values[i]); // for an array // here, using "with TDocVariantData(...) do" syntax can be very convenient // - since variants may be stored by reference (i.e. as varByRef), it may // be a good idea to use DocVariantData(aVariant)^ or _Safe(aVariant)^ instead // of TDocVariantData(aVariant), if you are not sure how aVariant was allocated // (may be not _Obj/_Json, but retrieved as varByRef e.g. from late binding) {$ifdef FPC_OR_UNICODE}TDocVariantData = record private {$else}TDocVariantData = object protected{$endif} VType: TVarType; VOptions: TDocVariantOptions; (* this structure uses all TVarData available space: no filler needed! {$HINTS OFF} // does not complain if Filler is declared but never used Filler: array[1..SizeOf(TVarData)-SizeOf(TVarType)-SizeOf(TDocVariantOptions)- SizeOf(TDocVariantKind)-SizeOf(TRawUTF8DynArray)-SizeOf(TVariantDynArray)- SizeOf(integer)] of byte; {$HINTS ON} *) VName: TRawUTF8DynArray; VValue: TVariantDynArray; VCount: integer; // retrieve the value as varByRef function GetValueOrItem(const aNameOrIndex: variant): variant; procedure SetValueOrItem(const aNameOrIndex, aValue: variant); function GetKind: TDocVariantKind; {$ifdef HASINLINE}inline;{$endif} procedure SetOptions(const opt: TDocVariantOptions); // keep dvoIsObject/Array {$ifdef HASINLINE}inline;{$endif} procedure SetCapacity(aValue: integer); function GetCapacity: integer; {$ifdef HASINLINE}inline;{$endif} // implement U[] I[] B[] D[] O[] O_[] A[] A_[] _[] properties function GetOrAddIndexByName(const aName: RawUTF8): integer; {$ifdef HASINLINE}inline;{$endif} function GetOrAddPVariantByName(const aName: RawUTF8): PVariant; {$ifdef HASINLINE}inline;{$endif} function GetPVariantByName(const aName: RawUTF8): PVariant; function GetRawUTF8ByName(const aName: RawUTF8): RawUTF8; procedure SetRawUTF8ByName(const aName, aValue: RawUTF8); function GetStringByName(const aName: RawUTF8): string; procedure SetStringByName(const aName: RawUTF8; const aValue: string); function GetInt64ByName(const aName: RawUTF8): Int64; procedure SetInt64ByName(const aName: RawUTF8; const aValue: Int64); function GetBooleanByName(const aName: RawUTF8): Boolean; procedure SetBooleanByName(const aName: RawUTF8; aValue: Boolean); function GetDoubleByName(const aName: RawUTF8): Double; procedure SetDoubleByName(const aName: RawUTF8; const aValue: Double); function GetDocVariantExistingByName(const aName: RawUTF8; aNotMatchingKind: TDocVariantKind): PDocVariantData; function GetObjectExistingByName(const aName: RawUTF8): PDocVariantData; function GetDocVariantOrAddByName(const aName: RawUTF8; aKind: TDocVariantKind): PDocVariantData; function GetObjectOrAddByName(const aName: RawUTF8): PDocVariantData; function GetArrayExistingByName(const aName: RawUTF8): PDocVariantData; function GetArrayOrAddByName(const aName: RawUTF8): PDocVariantData; function GetAsDocVariantByIndex(aIndex: integer): PDocVariantData; public /// initialize a TDocVariantData to store some document-based content // - can be used with a stack-allocated TDocVariantData variable: // !var Doc: TDocVariantData; // stack-allocated variable // !begin // ! Doc.Init; // ! Doc.AddValue('name','John'); // ! assert(Doc.Value['name']='John'); // ! assert(variant(Doc).name='John'); // !end; // - if you call Init*() methods in a row, ensure you call Clear in-between procedure Init(aOptions: TDocVariantOptions=[]; aKind: TDocVariantKind=dvUndefined); /// initialize a TDocVariantData to store per-reference document-based content // - same as Doc.Init(JSON_OPTIONS[true]); // - can be used with a stack-allocated TDocVariantData variable: // !var Doc: TDocVariantData; // stack-allocated variable // !begin // ! Doc.InitFast; // ! Doc.AddValue('name','John'); // ! assert(Doc.Value['name']='John'); // ! assert(variant(Doc).name='John'); // !end; // - see also TDocVariant.NewFast() if you want to initialize several // TDocVariantData variable instances at once // - if you call Init*() methods in a row, ensure you call Clear in-between procedure InitFast; overload; /// initialize a TDocVariantData to store per-reference document-based content // - this overloaded method allows to specify an estimation of how many // properties or items this aKind document would contain procedure InitFast(InitialCapacity: integer; aKind: TDocVariantKind); overload; /// initialize a TDocVariantData to store document-based object content // - object will be initialized with data supplied two by two, as Name,Value // pairs, e.g. // !var Doc: TDocVariantData; // stack-allocated variable // !begin // ! Doc.InitObject(['name','John','year',1972]); // which is the same as: // ! var Doc: TDocVariantData; // !begin // ! Doc.Init; // ! Doc.AddValue('name','John'); // ! Doc.AddValue('year',1972); // - this method is called e.g. by _Obj() and _ObjFast() global functions // - if you call Init*() methods in a row, ensure you call Clear in-between procedure InitObject(const NameValuePairs: array of const; aOptions: TDocVariantOptions=[]); /// initialize a variant instance to store some document-based array content // - array will be initialized with data supplied as parameters, e.g. // !var Doc: TDocVariantData; // stack-allocated variable // !begin // ! Doc.InitArray(['one',2,3.0]); // ! assert(Doc.Count=3); // !end; // which is the same as: // ! var Doc: TDocVariantData; // ! i: integer; // !begin // ! Doc.Init; // ! Doc.AddItem('one'); // ! Doc.AddItem(2); // ! Doc.AddItem(3.0); // ! assert(Doc.Count=3); // ! for i := 0 to Doc.Count-1 do // ! writeln(Doc.Value[i]); // !end; // - this method is called e.g. by _Arr() and _ArrFast() global functions // - if you call Init*() methods in a row, ensure you call Clear in-between procedure InitArray(const Items: array of const; aOptions: TDocVariantOptions=[]); /// initialize a variant instance to store some document-based array content // - array will be initialized with data supplied as variant dynamic array // - if Items is [], the variant will be set as null // - will be almost immediate, since TVariantDynArray is reference-counted, // unless ItemsCopiedByReference is set to FALSE // - if you call Init*() methods in a row, ensure you call Clear in-between procedure InitArrayFromVariants(const Items: TVariantDynArray; aOptions: TDocVariantOptions=[]; ItemsCopiedByReference: boolean=true); /// initialize a variant instance to store some RawUTF8 array content procedure InitArrayFrom(const Items: TRawUTF8DynArray; aOptions: TDocVariantOptions); overload; /// initialize a variant instance to store some 32-bit integer array content procedure InitArrayFrom(const Items: TIntegerDynArray; aOptions: TDocVariantOptions); overload; /// initialize a variant instance to store some 64-bit integer array content procedure InitArrayFrom(const Items: TInt64DynArray; aOptions: TDocVariantOptions); overload; /// initialize a variant instance to store a T*ObjArray content // - will call internally ObjectToVariant() to make the conversion procedure InitArrayFromObjArray(const ObjArray; aOptions: TDocVariantOptions; aWriterOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]); /// initialize a variant instance to store document-based array content // - array will be initialized from the supplied variable (which would be // e.g. a T*ObjArray or a dynamic array), using RTTI // - will use a temporary JSON serialization via SaveJSON() procedure InitFromTypeInfo(const aValue; aTypeInfo: pointer; aEnumSetsAsText: boolean; aOptions: TDocVariantOptions); /// initialize a variant instance to store some document-based object content // - object will be initialized with names and values supplied as dynamic arrays // - if aNames and aValues are [] or do have matching sizes, the variant // will be set as null // - will be almost immediate, since Names and Values are reference-counted // - if you call Init*() methods in a row, ensure you call Clear in-between procedure InitObjectFromVariants(const aNames: TRawUTF8DynArray; const aValues: TVariantDynArray; aOptions: TDocVariantOptions=[]); /// initialize a variant instance to store a document-based object with a // single property // - the supplied path could be 'Main.Second.Third', to create nested // objects, e.g. {"Main":{"Second":{"Third":value}}} // - if you call Init*() methods in a row, ensure you call Clear in-between procedure InitObjectFromPath(const aPath: RawUTF8; const aValue: variant; aOptions: TDocVariantOptions=[]); /// initialize a variant instance to store some document-based object content // from a supplied JSON array or JSON object content // - warning: the incoming JSON buffer will be modified in-place: so you should // make a private copy before running this method, e.g. using TSynTempBuffer // - this method is called e.g. by _JsonFmt() _JsonFastFmt() global functions // with a temporary JSON buffer content created from a set of parameters // - if you call Init*() methods in a row, ensure you call Clear in-between function InitJSONInPlace(JSON: PUTF8Char; aOptions: TDocVariantOptions=[]; aEndOfObject: PUTF8Char=nil): PUTF8Char; /// initialize a variant instance to store some document-based object content // from a supplied JSON array of JSON object content // - a private copy of the incoming JSON buffer will be used, then // it will call the other overloaded InitJSONInPlace() method // - this method is called e.g. by _Json() and _JsonFast() global functions // - if you call Init*() methods in a row, ensure you call Clear in-between function InitJSON(const JSON: RawUTF8; aOptions: TDocVariantOptions=[]): boolean; /// initialize a variant instance to store some document-based object content // from a JSON array of JSON object content, stored in a file // - any kind of file encoding will be handled, via AnyTextFileToRawUTF8() // - you can optionally remove any comment from the file content // - if you call Init*() methods in a row, ensure you call Clear in-between function InitJSONFromFile(const JsonFile: TFileName; aOptions: TDocVariantOptions=[]; RemoveComments: boolean=false): boolean; /// ensure a document-based variant instance will have one unique options set // - this will create a copy of the supplied TDocVariant instance, forcing // all nested events to have the same set of Options // - you can use this function to ensure that all internal properties of this // variant will be copied e.g. per-reference (if you set JSON_OPTIONS[false]) // or per-value (if you set JSON_OPTIONS[false]) whatever options the nested // objects or arrays were created with // - will raise an EDocVariant if the supplied variant is not a TDocVariant // - you may rather use _Unique() or _UniqueFast() wrappers if you want to // ensure that a TDocVariant instance is unique // - if you call Init*() methods in a row, ensure you call Clear in-between procedure InitCopy(const SourceDocVariant: variant; aOptions: TDocVariantOptions); /// initialize a variant instance to store some document-based object content // from a supplied CSV UTF-8 encoded text // - the supplied content may have been generated by ToTextPairs() method // - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled // - if you call Init*() methods in a row, ensure you call Clear in-between procedure InitCSV(CSV: PUTF8Char; aOptions: TDocVariantOptions; NameValueSep: AnsiChar='='; ItemSep: AnsiChar=#10; DoTrim: boolean=true); overload; /// initialize a variant instance to store some document-based object content // from a supplied CSV UTF-8 encoded text // - the supplied content may have been generated by ToTextPairs() method // - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled // - if you call Init*() methods in a row, ensure you call Clear in-between procedure InitCSV(const CSV: RawUTF8; aOptions: TDocVariantOptions; NameValueSep: AnsiChar='='; ItemSep: AnsiChar=#10; DoTrim: boolean=true); overload; {$ifdef HASINLINE}inline;{$endif} /// to be called before any Init*() method call, when a previous Init*() // has already be performed on the same instance, to avoid memory leaks // - for instance: // !var Doc: TDocVariantData; // stack-allocated variable // !begin // ! Doc.InitArray(['one',2,3.0]); // no need of any Doc.Clear here // ! assert(Doc.Count=3); // ! Doc.Clear; // to release memory before following InitObject() // ! Doc.InitObject(['name','John','year',1972]); // !end; // - implemented as just a wrapper around DocVariantType.Clear() procedure Clear; /// delete all internal stored values // - like Clear + Init() with the same options // - will reset Kind to dvUndefined procedure Reset; /// fill all Values[] with #0, then delete all values // - could be used to specifically remove sensitive information from memory procedure FillZero; /// low-level method to force a number of items // - could be used to fast add items to the internal Values[]/Names[] arrays // - just set protected VCount field, do not resize the arrays: caller // should ensure that Capacity is big enough procedure SetCount(aCount: integer); {$ifdef HASINLINE}inline;{$endif} /// low-level method called internally to reserve place for new values // - returns the index of the newly created item in Values[]/Names[] arrays // - you should not have to use it, unless you want to add some items // directly within the Values[]/Names[] arrays, using e.g. // InitFast(InitialCapacity) to initialize the document // - if aName='', append a dvArray item, otherwise append a dvObject field function InternalAdd(const aName: RawUTF8): integer; /// save a document as UTF-8 encoded JSON // - will write either a JSON object or array, depending of the internal // layout of this instance (i.e. Kind property value) // - will write 'null' if Kind is dvUndefined // - implemented as just a wrapper around VariantSaveJSON() function ToJSON(const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; Format: TTextWriterJSONFormat=jsonCompact): RawUTF8; /// save an array of objects as UTF-8 encoded non expanded layout JSON // - returned content would be a JSON object in mORMot's TSQLTable non // expanded format, with reduced JSON size, i.e. // $ {"fieldCount":3,"values":["ID","FirstName","LastName",...']} // - will write '' if Kind is dvUndefined or dvObject // - will raise an exception if the array document is not an array of // objects with identical field names function ToNonExpandedJSON: RawUTF8; /// save a document as an array of UTF-8 encoded JSON // - will expect the document to be a dvArray - otherwise, will raise a // EDocVariant exception // - will use VariantToUTF8() to populate the result array: as a consequence, // any nested custom variant types (e.g. TDocVariant) will be stored as JSON procedure ToRawUTF8DynArray(out Result: TRawUTF8DynArray); overload; /// save a document as an array of UTF-8 encoded JSON // - will expect the document to be a dvArray - otherwise, will raise a // EDocVariant exception // - will use VariantToUTF8() to populate the result array: as a consequence, // any nested custom variant types (e.g. TDocVariant) will be stored as JSON function ToRawUTF8DynArray: TRawUTF8DynArray; overload; {$ifdef HASINLINE}inline;{$endif} /// save a document as an CSV of UTF-8 encoded JSON // - will expect the document to be a dvArray - otherwise, will raise a // EDocVariant exception // - will use VariantToUTF8() to populate the result array: as a consequence, // any nested custom variant types (e.g. TDocVariant) will be stored as JSON function ToCSV(const Separator: RawUTF8=','): RawUTF8; /// save a document as UTF-8 encoded Name=Value pairs // - will follow by default the .INI format, but you can specify your // own expected layout procedure ToTextPairsVar(out result: RawUTF8; const NameValueSep: RawUTF8='='; const ItemSep: RawUTF8=#13#10; Escape: TTextWriterKind=twJSONEscape); /// save a document as UTF-8 encoded Name=Value pairs // - will follow by default the .INI format, but you can specify your // own expected layout function ToTextPairs(const NameValueSep: RawUTF8='='; const ItemSep: RawUTF8=#13#10; Escape: TTextWriterKind=twJSONEscape): RawUTF8; {$ifdef HASINLINE}inline;{$endif} /// save an array document as an array of TVarRec, i.e. an array of const // - will expect the document to be a dvArray - otherwise, will raise a // EDocVariant exception // - would allow to write code as such: // ! Doc.InitArray(['one',2,3]); // ! Doc.ToArrayOfConst(vr); // ! s := FormatUTF8('[%,%,%]',vr,[],true); // ! // here s='[one,2,3]') since % would be replaced by Args[] parameters // ! s := FormatUTF8('[?,?,?]',[],vr,true); // ! // here s='["one",2,3]') since ? would be escaped by Params[] parameters procedure ToArrayOfConst(out Result: TTVarRecDynArray); overload; /// save an array document as an array of TVarRec, i.e. an array of const // - will expect the document to be a dvArray - otherwise, will raise a // EDocVariant exception // - would allow to write code as such: // ! Doc.InitArray(['one',2,3]); // ! s := FormatUTF8('[%,%,%]',Doc.ToArrayOfConst,[],true); // ! // here s='[one,2,3]') since % would be replaced by Args[] parameters // ! s := FormatUTF8('[?,?,?]',[],Doc.ToArrayOfConst,true); // ! // here s='["one",2,3]') since ? would be escaped by Params[] parameters function ToArrayOfConst: TTVarRecDynArray; overload; {$ifdef HASINLINE}inline;{$endif} /// save an object document as an URI-encoded list of parameters // - object field names should be plain ASCII-7 RFC compatible identifiers // (0..9a..zA..Z_.~), otherwise their values are skipped function ToUrlEncode(const UriRoot: RawUTF8): RawUTF8; /// find an item index in this document from its name // - search will follow dvoNameCaseSensitive option of this document // - returns -1 if not found function GetValueIndex(const aName: RawUTF8): integer; overload; {$ifdef HASINLINE}inline;{$endif} /// find an item index in this document from its name // - returns -1 if not found function GetValueIndex(aName: PUTF8Char; aNameLen: PtrInt; aCaseSensitive: boolean): integer; overload; /// find an item in this document, and returns its value // - raise an EDocVariant if not found and dvoReturnNullForUnknownProperty // is not set in Options (in this case, it will return Null) function GetValueOrRaiseException(const aName: RawUTF8): variant; /// find an item in this document, and returns its value // - return the supplied default if aName is not found, or if the instance // is not a TDocVariant function GetValueOrDefault(const aName: RawUTF8; const aDefault: variant): variant; /// find an item in this document, and returns its value // - return null if aName is not found, or if the instance is not a TDocVariant function GetValueOrNull(const aName: RawUTF8): variant; /// find an item in this document, and returns its value // - return a cleared variant if aName is not found, or if the instance is // not a TDocVariant function GetValueOrEmpty(const aName: RawUTF8): variant; /// find an item in this document, and returns its value as enumerate // - return false if aName is not found, if the instance is not a TDocVariant, // or if the value is not a string corresponding to the supplied enumerate // - return true if the name has been found, and aValue stores the value // - will call Delete() on the found entry, if aDeleteFoundEntry is true function GetValueEnumerate(const aName: RawUTF8; aTypeInfo: pointer; out aValue; aDeleteFoundEntry: boolean=false): Boolean; /// returns a TDocVariant object containing all properties matching the // first characters of the supplied property name // - returns null if the document is not a dvObject // - will use IdemPChar(), so search would be case-insensitive function GetValuesByStartName(const aStartName: RawUTF8; TrimLeftStartName: boolean=false): variant; /// returns a JSON object containing all properties matching the // first characters of the supplied property name // - returns null if the document is not a dvObject // - will use IdemPChar(), so search would be case-insensitive function GetJsonByStartName(const aStartName: RawUTF8): RawUTF8; /// find an item in this document, and returns its value as TVarData // - return false if aName is not found, or if the instance is not a TDocVariant // - return true if the name has been found, and aValue stores the value // - will use simple loop lookup to identify the name, unless aSortedCompare is // set, and would let use a faster O(log(n)) binary search after a SortByName() function GetVarData(const aName: RawUTF8; var aValue: TVarData; aSortedCompare: TUTF8Compare=nil): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// find an item in this document, and returns its value as TVarData pointer // - return nil if aName is not found, or if the instance is not a TDocVariant // - return a pointer to the value if the name has been found // - after a SortByName(aSortedCompare), would use faster binary search function GetVarData(const aName: RawUTF8; aSortedCompare: TUTF8Compare=nil): PVarData; overload; /// find an item in this document, and returns its value as boolean // - return false if aName is not found, or if the instance is not a TDocVariant // - return true if the name has been found, and aValue stores the value // - after a SortByName(aSortedCompare), would use faster binary search // - consider using B[] property if you want simple read/write typed access function GetAsBoolean(const aName: RawUTF8; out aValue: boolean; aSortedCompare: TUTF8Compare=nil): Boolean; /// find an item in this document, and returns its value as integer // - return false if aName is not found, or if the instance is not a TDocVariant // - return true if the name has been found, and aValue stores the value // - after a SortByName(aSortedCompare), would use faster binary search // - consider using I[] property if you want simple read/write typed access function GetAsInteger(const aName: RawUTF8; out aValue: integer; aSortedCompare: TUTF8Compare=nil): Boolean; /// find an item in this document, and returns its value as integer // - return false if aName is not found, or if the instance is not a TDocVariant // - return true if the name has been found, and aValue stores the value // - after a SortByName(aSortedCompare), would use faster binary search // - consider using I[] property if you want simple read/write typed access function GetAsInt64(const aName: RawUTF8; out aValue: Int64; aSortedCompare: TUTF8Compare=nil): Boolean; /// find an item in this document, and returns its value as floating point // - return false if aName is not found, or if the instance is not a TDocVariant // - return true if the name has been found, and aValue stores the value // - after a SortByName(aSortedCompare), would use faster binary search // - consider using D[] property if you want simple read/write typed access function GetAsDouble(const aName: RawUTF8; out aValue: double; aSortedCompare: TUTF8Compare=nil): Boolean; /// find an item in this document, and returns its value as RawUTF8 // - return false if aName is not found, or if the instance is not a TDocVariant // - return true if the name has been found, and aValue stores the value // - after a SortByName(aSortedCompare), would use faster binary search // - consider using U[] property if you want simple read/write typed access function GetAsRawUTF8(const aName: RawUTF8; out aValue: RawUTF8; aSortedCompare: TUTF8Compare=nil): Boolean; /// find an item in this document, and returns its value as a TDocVariantData // - return false if aName is not found, or if the instance is not a TDocVariant // - return true if the name has been found and points to a TDocVariant: // then aValue stores a pointer to the value // - after a SortByName(aSortedCompare), would use faster binary search function GetAsDocVariant(const aName: RawUTF8; out aValue: PDocVariantData; aSortedCompare: TUTF8Compare=nil): boolean; overload; /// find an item in this document, and returns its value as a TDocVariantData // - returns a void TDocVariant if aName is not a document // - after a SortByName(aSortedCompare), would use faster binary search // - consider using O[] or A[] properties if you want simple read-only // access, or O_[] or A_[] properties if you want the ability to add // a missing object or array in the document function GetAsDocVariantSafe(const aName: RawUTF8; aSortedCompare: TUTF8Compare=nil): PDocVariantData; /// find an item in this document, and returns pointer to its value // - return false if aName is not found // - return true if the name has been found: then aValue stores a pointer // to the value // - after a SortByName(aSortedCompare), would use faster binary search function GetAsPVariant(const aName: RawUTF8; out aValue: PVariant; aSortedCompare: TUTF8Compare=nil): boolean; /// retrieve a value, given its path // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' // - it will return Unassigned if the path does match the supplied aPath function GetValueByPath(const aPath: RawUTF8): variant; overload; /// retrieve a value, given its path // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' // - it will return FALSE if the path does not match the supplied aPath // - returns TRUE and set the found value in aValue function GetValueByPath(const aPath: RawUTF8; out aValue: variant): boolean; overload; /// retrieve a value, given its path // - path is defined as a list of names, e.g. ['doc','glossary','title'] // - it will return Unassigned if the path does not match the data // - this method will only handle nested TDocVariant values: use the // slightly slower GetValueByPath() overloaded method, if any nested object // may be of another type (e.g. a TBSONVariant) function GetValueByPath(const aDocVariantPath: array of RawUTF8): variant; overload; /// retrieve a reference to a value, given its path // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' // - if the supplied aPath does not match any object, it will return nil // - if aPath is found, returns a pointer to the corresponding value function GetPVariantByPath(const aPath: RawUTF8): PVariant; /// retrieve a reference to a TDocVariant, given its path // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' // - if the supplied aPath does not match any object, it will return false // - if aPath stores a valid TDocVariant, returns true and a pointer to it function GetDocVariantByPath(const aPath: RawUTF8; out aValue: PDocVariantData): boolean; /// retrieve a dvObject in the dvArray, from a property value // - {aPropName:aPropValue} will be searched within the stored array, // and the corresponding item will be copied into Dest, on match // - returns FALSE if no match is found, TRUE if found and copied // - create a copy of the variant by default, unless DestByRef is TRUE // - will call VariantEquals() for value comparison function GetItemByProp(const aPropName,aPropValue: RawUTF8; aPropValueCaseSensitive: boolean; var Dest: variant; DestByRef: boolean=false): boolean; /// retrieve a reference to a dvObject in the dvArray, from a property value // - {aPropName:aPropValue} will be searched within the stored array, // and the corresponding item will be copied into Dest, on match // - returns FALSE if no match is found, TRUE if found and copied by reference function GetDocVariantByProp(const aPropName,aPropValue: RawUTF8; aPropValueCaseSensitive: boolean; out Dest: PDocVariantData): boolean; /// find an item in this document, and returns its value // - raise an EDocVariant if not found and dvoReturnNullForUnknownProperty // is not set in Options (in this case, it will return Null) // - create a copy of the variant by default, unless DestByRef is TRUE procedure RetrieveValueOrRaiseException(aName: PUTF8Char; aNameLen: integer; aCaseSensitive: boolean; var Dest: variant; DestByRef: boolean); overload; /// retrieve an item in this document from its index, and returns its value // - raise an EDocVariant if the supplied Index is not in the 0..Count-1 // range and dvoReturnNullForUnknownProperty is set in Options // - create a copy of the variant by default, unless DestByRef is TRUE procedure RetrieveValueOrRaiseException(Index: integer; var Dest: variant; DestByRef: boolean); overload; /// retrieve an item in this document from its index, and returns its Name // - raise an EDocVariant if the supplied Index is not in the 0..Count-1 // range and dvoReturnNullForUnknownProperty is set in Options procedure RetrieveNameOrRaiseException(Index: integer; var Dest: RawUTF8); /// set an item in this document from its index // - raise an EDocVariant if the supplied Index is not in 0..Count-1 range procedure SetValueOrRaiseException(Index: integer; const NewValue: variant); /// add a value in this document // - if aName is set, if dvoCheckForDuplicatedNames option is set, any // existing duplicated aName will raise an EDocVariant; if instance's // kind is dvArray and aName is defined, it will raise an EDocVariant // - aName may be '' e.g. if you want to store an array: in this case, // dvoCheckForDuplicatedNames option should not be set; if instance's Kind // is dvObject, it will raise an EDocVariant exception // - you can therefore write e.g.: // ! TDocVariant.New(aVariant); // ! Assert(TDocVariantData(aVariant).Kind=dvUndefined); // ! TDocVariantData(aVariant).AddValue('name','John'); // ! Assert(TDocVariantData(aVariant).Kind=dvObject); // - returns the index of the corresponding newly added value function AddValue(const aName: RawUTF8; const aValue: variant): integer; overload; /// add a value in this document // - overloaded function accepting a UTF-8 encoded buffer for the name function AddValue(aName: PUTF8Char; aNameLen: integer; const aValue: variant): integer; overload; /// add a value in this document, or update an existing entry // - if instance's Kind is dvArray, it will raise an EDocVariant exception // - any existing Name would be updated with the new Value, unless // OnlyAddMissing is set to TRUE, in which case existing values would remain // - returns the index of the corresponding value, which may be just added function AddOrUpdateValue(const aName: RawUTF8; const aValue: variant; wasAdded: PBoolean=nil; OnlyAddMissing: boolean=false): integer; /// add a value in this document, from its text representation // - this function expects a UTF-8 text for the value, which would be // converted to a variant number, if possible (as varInt/varInt64/varCurrency // and/or as varDouble is AllowVarDouble is set) // - if Update=TRUE, will set the property, even if it is existing function AddValueFromText(const aName,aValue: RawUTF8; Update: boolean=false; AllowVarDouble: boolean=false): integer; /// add some properties to a TDocVariantData dvObject // - data is supplied two by two, as Name,Value pairs // - caller should ensure that Kind=dvObject, otherwise it won't do anything // - any existing Name would be duplicated procedure AddNameValuesToObject(const NameValuePairs: array of const); /// merge some properties to a TDocVariantData dvObject // - data is supplied two by two, as Name,Value pairs // - caller should ensure that Kind=dvObject, otherwise it won't do anything // - any existing Name would be updated with the new Value procedure AddOrUpdateNameValuesToObject(const NameValuePairs: array of const); /// merge some TDocVariantData dvObject properties to a TDocVariantData dvObject // - data is supplied two by two, as Name,Value pairs // - caller should ensure that both variants have Kind=dvObject, otherwise // it won't do anything // - any existing Name would be updated with the new Value, unless // OnlyAddMissing is set to TRUE, in which case existing values would remain procedure AddOrUpdateObject(const NewValues: variant; OnlyAddMissing: boolean=false; RecursiveUpdate: boolean=false); /// add a value to this document, handled as array // - if instance's Kind is dvObject, it will raise an EDocVariant exception // - you can therefore write e.g.: // ! TDocVariant.New(aVariant); // ! Assert(TDocVariantData(aVariant).Kind=dvUndefined); // ! TDocVariantData(aVariant).AddItem('one'); // ! Assert(TDocVariantData(aVariant).Kind=dvArray); // - returns the index of the corresponding newly added item function AddItem(const aValue: variant): integer; /// add a value to this document, handled as array, from its text representation // - this function expects a UTF-8 text for the value, which would be // converted to a variant number, if possible (as varInt/varInt64/varCurrency // unless AllowVarDouble is set) // - if instance's Kind is dvObject, it will raise an EDocVariant exception // - returns the index of the corresponding newly added item function AddItemFromText(const aValue: RawUTF8; AllowVarDouble: boolean=false): integer; /// add a RawUTF8 value to this document, handled as array // - if instance's Kind is dvObject, it will raise an EDocVariant exception // - returns the index of the corresponding newly added item function AddItemText(const aValue: RawUTF8): integer; /// add one or several values to this document, handled as array // - if instance's Kind is dvObject, it will raise an EDocVariant exception procedure AddItems(const aValue: array of const); /// add one or several values from another document // - supplied document should be of the same kind than the current one, // otherwise nothing is added procedure AddFrom(const aDocVariant: Variant); /// add or update or on several valeus from another object // - current document should be an object procedure AddOrUpdateFrom(const aDocVariant: Variant; aOnlyAddMissing: boolean=false); /// add one or several properties, specified by path, from another object // - path are defined as a dotted name-space, e.g. 'doc.glossary.title' // - matching values would be added as root values, with the path as name // - instance and supplied aSource should be a dvObject procedure AddByPath(const aSource: TDocVariantData; const aPaths: array of RawUTF8); /// delete a value/item in this document, from its index // - return TRUE on success, FALSE if the supplied index is not correct function Delete(Index: integer): boolean; overload; /// delete a value/item in this document, from its name // - return TRUE on success, FALSE if the supplied name does not exist function Delete(const aName: RawUTF8): boolean; overload; /// delete a value in this document, by property name match // - {aPropName:aPropValue} will be searched within the stored array or // object, and the corresponding item will be deleted, on match // - returns FALSE if no match is found, TRUE if found and deleted // - will call VariantEquals() for value comparison function DeleteByProp(const aPropName,aPropValue: RawUTF8; aPropValueCaseSensitive: boolean): boolean; /// delete one or several value/item in this document, from its value // - returns the number of deleted items // - returns 0 if the document is not a dvObject, or if no match was found // - if the value exists several times, all occurences would be removed // - is optimized for DeleteByValue(null) call function DeleteByValue(const aValue: Variant; CaseInsensitive: boolean=false): integer; /// delete all values matching the first characters of a property name // - returns the number of deleted items // - returns 0 if the document is not a dvObject, or if no match was found // - will use IdemPChar(), so search would be case-insensitive function DeleteByStartName(aStartName: PUTF8Char; aStartNameLen: integer): integer; /// search a property match in this document, handled as array or object // - {aPropName:aPropValue} will be searched within the stored array or // object, and the corresponding item index will be returned, on match // - returns -1 if no match is found // - will call VariantEquals() for value comparison function SearchItemByProp(const aPropName,aPropValue: RawUTF8; aPropValueCaseSensitive: boolean): integer; overload; /// search a property match in this document, handled as array or object // - {aPropName:aPropValue} will be searched within the stored array or // object, and the corresponding item index will be returned, on match // - returns -1 if no match is found // - will call VariantEquals() for value comparison function SearchItemByProp(const aPropNameFmt: RawUTF8; const aPropNameArgs: array of const; const aPropValue: RawUTF8; aPropValueCaseSensitive: boolean): integer; overload; /// search a value in this document, handled as array // - aValue will be searched within the stored array // and the corresponding item index will be returned, on match // - returns -1 if no match is found // - you could make several searches, using the StartIndex optional parameter function SearchItemByValue(const aValue: Variant; CaseInsensitive: boolean=false; StartIndex: integer=0): integer; /// sort the document object values by name // - do nothing if the document is not a dvObject // - will follow case-insensitive order (@StrIComp) by default, but you // can specify @StrComp as comparer function for case-sensitive ordering // - once sorted, you can use GetVarData(..,Compare) or GetAs*(..,Compare) // methods for much faster O(log(n)) binary search procedure SortByName(Compare: TUTF8Compare=nil); /// sort the document object values by value // - work for both dvObject and dvArray documents // - will sort by UTF-8 text (VariantCompare) if no custom aCompare is supplied procedure SortByValue(Compare: TVariantCompare = nil); /// sort the document array values by a field of some stored objet values // - do nothing if the document is not a dvArray, or if the items are no dvObject // - will sort by UTF-8 text (VariantCompare) if no custom aValueCompare is supplied procedure SortArrayByField(const aItemPropName: RawUTF8; aValueCompare: TVariantCompare=nil; aValueCompareReverse: boolean=false; aNameSortedCompare: TUTF8Compare=nil); /// reverse the order of the document object or array items procedure Reverse; /// create a TDocVariant object, from a selection of properties of this // document, by property name // - if the document is a dvObject, to reduction will be applied to all // its properties // - if the document is a dvArray, the reduction will be applied to each // stored item, if it is a document procedure Reduce(const aPropNames: array of RawUTF8; aCaseSensitive: boolean; out result: TDocVariantData; aDoNotAddVoidProp: boolean=false); overload; /// create a TDocVariant object, from a selection of properties of this // document, by property name // - always returns a TDocVariantData, even if no property name did match // (in this case, it is dvUndefined) function Reduce(const aPropNames: array of RawUTF8; aCaseSensitive: boolean; aDoNotAddVoidProp: boolean=false): variant; overload; /// create a TDocVariant array, from the values of a single properties of // this document, specified by name // - you can optionally apply an additional filter to each reduced item procedure ReduceAsArray(const aPropName: RawUTF8; out result: TDocVariantData; OnReduce: TOnReducePerItem=nil); overload; /// create a TDocVariant array, from the values of a single properties of // this document, specified by name // - always returns a TDocVariantData, even if no property name did match // (in this case, it is dvUndefined) // - you can optionally apply an additional filter to each reduced item function ReduceAsArray(const aPropName: RawUTF8; OnReduce: TOnReducePerItem=nil): variant; overload; /// create a TDocVariant array, from the values of a single properties of // this document, specified by name // - this overloaded method accepts an additional filter to each reduced item procedure ReduceAsArray(const aPropName: RawUTF8; out result: TDocVariantData; OnReduce: TOnReducePerValue); overload; /// create a TDocVariant array, from the values of a single properties of // this document, specified by name // - always returns a TDocVariantData, even if no property name did match // (in this case, it is dvUndefined) // - this overloaded method accepts an additional filter to each reduced item function ReduceAsArray(const aPropName: RawUTF8; OnReduce: TOnReducePerValue): variant; overload; /// rename some properties of a TDocVariant object // - returns the number of property names modified function Rename(const aFromPropName, aToPropName: TRawUTF8DynArray): integer; /// map {"obj.prop1"..,"obj.prop2":..} into {"obj":{"prop1":..,"prop2":...}} // - the supplied aObjectPropName should match the incoming dotted value // of all properties (e.g. 'obj' for "obj.prop1") // - if any of the incoming property is not of "obj.prop#" form, the // whole process would be ignored // - return FALSE if the TDocVariant did not change // - return TRUE if the TDocVariant has been flattened function FlattenAsNestedObject(const aObjectPropName: RawUTF8): boolean; /// how this document will behave // - those options are set when creating the instance // - dvoArray and dvoObject are not options, but define the document Kind, // so those items are ignored when assigned to this property property Options: TDocVariantOptions read VOptions write SetOptions; /// returns the document internal layout // - just after initialization, it will return dvUndefined // - most of the time, you will add named values with AddValue() or by // setting the variant properties: it will return dvObject // - but is you use AddItem(), values will have no associated names: the // document will be a dvArray // - value computed from the dvoArray and dvoObject presence in Options property Kind: TDocVariantKind read GetKind; /// return the custom variant type identifier, i.e. DocVariantType.VarType property VarType: word read VType; /// number of items stored in this document // - is 0 if Kind=dvUndefined // - is the number of name/value pairs for Kind=dvObject // - is the number of items for Kind=dvArray property Count: integer read VCount; /// the current capacity of this document // - allow direct access to VValue[] length property Capacity: integer read GetCapacity write SetCapacity; /// direct acces to the low-level internal array of values // - transtyping a variant and direct access to TDocVariantData is the // fastest way of accessing all properties of a given dvObject: // ! with TDocVariantData(aVariantObject) do // ! for i := 0 to Count-1 do // ! writeln(Names[i],'=',Values[i]); // - or to access a dvArray items (e.g. a MongoDB collection): // ! with TDocVariantData(aVariantArray) do // ! for i := 0 to Count-1 do // ! writeln(Values[i]); property Values: TVariantDynArray read VValue; /// direct acces to the low-level internal array of names // - is void (nil) if Kind is not dvObject // - transtyping a variant and direct access to TDocVariantData is the // fastest way of accessing all properties of a given dvObject: // ! with TDocVariantData(aVariantObject) do // ! for i := 0 to Count-1 do // ! writeln(Names[i],'=',Values[i]); property Names: TRawUTF8DynArray read VName; /// find an item in this document, and returns its value // - raise an EDocVariant if aNameOrIndex is neither an integer nor a string // - raise an EDocVariant if Kind is dvArray and aNameOrIndex is a string // or if Kind is dvObject and aNameOrIndex is an integer // - raise an EDocVariant if Kind is dvObject and if aNameOrIndex is a // string, which is not found within the object property names and // dvoReturnNullForUnknownProperty is set in Options // - raise an EDocVariant if Kind is dvArray and if aNameOrIndex is a // integer, which is not within 0..Count-1 and dvoReturnNullForUnknownProperty // is set in Options // - so you can use directly: // ! // for an array document: // ! aVariant := TDocVariant.NewArray(['one',2,3.0]); // ! for i := 0 to TDocVariantData(aVariant).Count-1 do // ! aValue := TDocVariantData(aVariant).Value[i]; // ! // for an object document: // ! aVariant := TDocVariant.NewObject(['name','John','year',1972]); // ! assert(aVariant.Name=TDocVariantData(aVariant)['name']); // ! assert(aVariant.year=TDocVariantData(aVariant)['year']); // - due to the internal implementation of variant execution (somewhat // slow _DispInvoke() function), it is a bit faster to execute: // ! aValue := TDocVariantData(aVariant).Value['name']; // instead of // ! aValue := aVariant.name; // but of course, if want to want to access the content by index (typically // for a dvArray), using Values[] - and Names[] - properties is much faster // than this variant-indexed pseudo-property: // ! with TDocVariantData(aVariant) do // ! for i := 0 to Count-1 do // ! Writeln(Values[i]); // is faster than: // ! with TDocVariantData(aVariant) do // ! for i := 0 to Count-1 do // ! Writeln(Value[i]); // which is faster than: // ! for i := 0 to aVariant.Count-1 do // ! Writeln(aVariant._(i)); // - this property will return the value as varByRef (just like with // variant late binding of any TDocVariant instance), so you can write: // !var Doc: TDocVariantData; // stack-allocated variable // !begin // ! Doc.InitJSON('{arr:[1,2]}'); // ! assert(Doc.Count=2); // ! Doc.Value['arr'].Add(3); // works since Doc.Value['arr'] is varByRef // ! writeln(Doc.ToJSON); // will write '{"arr":[1,2,3]}' // !end; // - if you want to access a property as a copy, i.e. to assign it to a // variant variable which will stay alive after this TDocVariant instance // is release, you should not use Value[] but rather // GetValueOrRaiseException or GetValueOrNull/GetValueOrEmpty // - see U[] I[] B[] D[] O[] O_[] A[] A_[] _[] properties for direct access // of strong typed values property Value[const aNameOrIndex: Variant]: Variant read GetValueOrItem write SetValueOrItem; default; /// direct access to a dvObject UTF-8 stored property value from its name // - slightly faster than the variant-based Value[] default property // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options // - use GetAsRawUTF8() if you want to check the availability of the field // - U['prop'] := 'value' would add a new property, or overwrite an existing property U[const aName: RawUTF8]: RawUTF8 read GetRawUTF8ByName write SetRawUTF8ByName; /// direct string access to a dvObject UTF-8 stored property value from its name // - just a wrapper around U[] property, to avoid a compilation warning when // using plain string variables (internaly, RawUTF8 will be used for storage) // - slightly faster than the variant-based Value[] default property // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options // - use GetAsRawUTF8() if you want to check the availability of the field // - S['prop'] := 'value' would add a new property, or overwrite an existing property S[const aName: RawUTF8]: string read GetStringByName write SetStringByName; /// direct access to a dvObject Integer stored property value from its name // - slightly faster than the variant-based Value[] default property // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options // - use GetAsInt/GetAsInt64 if you want to check the availability of the field // - I['prop'] := 123 would add a new property, or overwrite an existing property I[const aName: RawUTF8]: Int64 read GetInt64ByName write SetInt64ByName; /// direct access to a dvObject Boolean stored property value from its name // - slightly faster than the variant-based Value[] default property // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options // - use GetAsBoolean if you want to check the availability of the field // - B['prop'] := true would add a new property, or overwrite an existing property B[const aName: RawUTF8]: Boolean read GetBooleanByName write SetBooleanByName; /// direct access to a dvObject floating-point stored property value from its name // - slightly faster than the variant-based Value[] default property // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options // - use GetAsDouble if you want to check the availability of the field // - D['prop'] := 1.23 would add a new property, or overwrite an existing property D[const aName: RawUTF8]: Double read GetDoubleByName write SetDoubleByName; /// direct access to a dvObject existing dvObject property from its name // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options // - O['prop'] would return a fake void TDocVariant if the property is not // existing or not a dvObject, just like GetAsDocVariantSafe() // - use O_['prop'] to force adding any missing property property O[const aName: RawUTF8]: PDocVariantData read GetObjectExistingByName; /// direct access or add a dvObject's dvObject property from its name // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options // - O_['prop'] would add a new property if there is none existing, or // overwrite an existing property which is not a dvObject property O_[const aName: RawUTF8]: PDocVariantData read GetObjectOrAddByName; /// direct access to a dvObject existing dvArray property from its name // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options // - A['prop'] would return a fake void TDocVariant if the property is not // existing or not a dvArray, just like GetAsDocVariantSafe() // - use A_['prop'] to force adding any missing property property A[const aName: RawUTF8]: PDocVariantData read GetArrayExistingByName; /// direct access or add a dvObject's dvArray property from its name // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options // - A_['prop'] would add a new property if there is none existing, or // overwrite an existing property which is not a dvArray property A_[const aName: RawUTF8]: PDocVariantData read GetArrayOrAddByName; /// direct access to a dvArray's TDocVariant property from its index // - simple values may directly use Values[] dynamic array, but to access // a TDocVariantData members, this property is safer // - follows dvoReturnNullForUnknownProperty option to raise an exception // - _[ndx] would return a fake void TDocVariant if aIndex is out of range, // if the property is not existing or not a TDocVariantData (just like // GetAsDocVariantSafe) property _[aIndex: integer]: PDocVariantData read GetAsDocVariantByIndex; end; {$A+} { packet object not allowed since Delphi 2009 :( } var /// the internal custom variant type used to register TDocVariant DocVariantType: TDocVariant = nil; /// copy of DocVariantType.VarType // - as used by inlined functions of TDocVariantData DocVariantVType: integer = -1; /// retrieve the text representation of a TDocVairnatKind function ToText(kind: TDocVariantKind): PShortString; overload; /// direct access to a TDocVariantData from a given variant instance // - return a pointer to the TDocVariantData corresponding to the variant // instance, which may be of kind varByRef (e.g. when retrieved by late binding) // - raise an EDocVariant exception if the instance is not a TDocVariant // - the following direct trans-typing may fail, e.g. for varByRef value: // ! TDocVariantData(aVarDoc.ArrayProp).Add('new item'); // - so you can write the following: // ! DocVariantData(aVarDoc.ArrayProp).AddItem('new item'); function DocVariantData(const DocVariant: variant): PDocVariantData; const /// constant used e.g. by _Safe() overloaded functions // - will be in code section of the exe, so will be read-only by design // - would have Kind=dvUndefined and Count=0, so _Safe() would return // a valid, but void document // - its VType is varNull, so would be viewed as a null variant // - dvoReturnNullForUnknownProperty is defined, so that U[]/I[]... methods // won't raise any exception about unexpected field name DocVariantDataFake: TDocVariantData = ( VType:1; VOptions:[dvoReturnNullForUnknownProperty]); /// direct access to a TDocVariantData from a given variant instance // - return a pointer to the TDocVariantData corresponding to the variant // instance, which may be of kind varByRef (e.g. when retrieved by late binding) // - will return a read-only fake TDocVariantData with Kind=dvUndefined if the // supplied variant is not a TDocVariant instance, so could be safely used // in a with block (use "with" moderation, of course): // ! with _Safe(aDocVariant)^ do // ! for ndx := 0 to Count-1 do // here Count=0 for the "fake" result // ! writeln(Names[ndx]); function _Safe(const DocVariant: variant): PDocVariantData; overload; {$ifdef FPC}inline;{$endif} // Delphi has problems inlining this :( /// direct access to a TDocVariantData from a given variant instance // - return a pointer to the TDocVariantData corresponding to the variant // instance, which may be of kind varByRef (e.g. when retrieved by late binding) // - will check the supplied document kind, i.e. either dvObject or dvArray and // raise a EDocVariant exception if it does not match function _Safe(const DocVariant: variant; ExpectedKind: TDocVariantKind): PDocVariantData; overload; /// initialize a variant instance to store some document-based object content // - object will be initialized with data supplied two by two, as Name,Value // pairs, e.g. // ! aVariant := _Obj(['name','John','year',1972]); // or even with nested objects: // ! aVariant := _Obj(['name','John','doc',_Obj(['one',1,'two',2.0])]); // - this global function is an alias to TDocVariant.NewObject() // - by default, every internal value will be copied, so access of nested // properties can be slow - if you expect the data to be read-only or not // propagated into another place, set Options=[dvoValueCopiedByReference] // or using _ObjFast() will increase the process speed a lot function _Obj(const NameValuePairs: array of const; Options: TDocVariantOptions=[]): variant; /// add some property values to a document-based object content // - if Obj is a TDocVariant object, will add the Name/Value pairs // - if Obj is not a TDocVariant, will create a new fast document, // initialized with supplied the Name/Value pairs // - this function will also ensure that ensure Obj is not stored by reference, // but as a true TDocVariantData procedure _ObjAddProps(const NameValuePairs: array of const; var Obj: variant); overload; /// add the property values of a document to a document-based object content // - if Document is not a TDocVariant object, will do nothing // - if Obj is a TDocVariant object, will add Document fields to its content // - if Obj is not a TDocVariant object, Document will be copied to Obj procedure _ObjAddProps(const Document: variant; var Obj: variant); overload; /// initialize a variant instance to store some document-based array content // - array will be initialized with data supplied as parameters, e.g. // ! aVariant := _Arr(['one',2,3.0]); // - this global function is an alias to TDocVariant.NewArray() // - by default, every internal value will be copied, so access of nested // properties can be slow - if you expect the data to be read-only or not // propagated into another place, set Options=[dvoValueCopiedByReference] // or using _ArrFast() will increase the process speed a lot function _Arr(const Items: array of const; Options: TDocVariantOptions=[]): variant; /// initialize a variant instance to store some document-based content // from a supplied (extended) JSON content // - this global function is an alias to TDocVariant.NewJSON(), and // will return an Unassigned variant if JSON content was not correctly converted // - object or array will be initialized from the supplied JSON content, e.g. // ! aVariant := _Json('{"id":10,"doc":{"name":"John","birthyear":1972}}'); // ! // now you can access to the properties via late binding // ! assert(aVariant.id=10); // ! assert(aVariant.doc.name='John'); // ! assert(aVariant.doc.birthYear=1972); // ! // and also some pseudo-properties: // ! assert(aVariant._count=2); // ! assert(aVariant.doc._kind=ord(dvObject)); // ! // or with a JSON array: // ! aVariant := _Json('["one",2,3]'); // ! assert(aVariant._kind=ord(dvArray)); // ! for i := 0 to aVariant._count-1 do // ! writeln(aVariant._(i)); // - in addition to the JSON RFC specification strict mode, this method will // handle some BSON-like extensions, e.g. unquoted field names: // ! aVariant := _Json('{id:10,doc:{name:"John",birthyear:1972}}'); // - if the SynMongoDB unit is used in the application, the MongoDB Shell // syntax will also be recognized to create TBSONVariant, like // ! new Date() ObjectId() MinKey MaxKey // // see @http://docs.mongodb.org/manual/reference/mongodb-extended-json // - by default, every internal value will be copied, so access of nested // properties can be slow - if you expect the data to be read-only or not // propagated into another place, add dvoValueCopiedByReference in Options // will increase the process speed a lot, or use _JsonFast() function _Json(const JSON: RawUTF8; Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; overload; {$ifdef HASINLINE}inline;{$endif} /// initialize a variant instance to store some document-based content // from a supplied (extended) JSON content, with parameters formating // - wrapper around the _Json(FormatUTF8(...,JSONFormat=true)) function, // i.e. every Args[] will be inserted for each % and Params[] for each ?, // with proper JSON escaping of string values, and writing nested _Obj() / // _Arr() instances as expected JSON objects / arrays // - typical use (in the context of SynMongoDB unit) could be: // ! aVariant := _JSONFmt('{%:{$in:[?,?]}}',['type'],['food','snack']); // ! aVariant := _JSONFmt('{type:{$in:?}}',[],[_Arr(['food','snack'])]); // ! // which are the same as: // ! aVariant := _JSONFmt('{type:{$in:["food","snack"]}}'); // ! // in this context: // ! u := VariantSaveJSON(aVariant); // ! assert(u='{"type":{"$in":["food","snack"]}}'); // ! u := VariantSaveMongoJSON(aVariant,modMongoShell); // ! assert(u='{type:{$in:["food","snack"]}}'); // - by default, every internal value will be copied, so access of nested // properties can be slow - if you expect the data to be read-only or not // propagated into another place, add dvoValueCopiedByReference in Options // will increase the process speed a lot, or use _JsonFast() function _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; overload; /// initialize a variant instance to store some document-based content // from a supplied (extended) JSON content, with parameters formating // - this overload function will set directly a local variant variable, // and would be used by inlined _JsonFmt/_JsonFastFmt functions procedure _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; Options: TDocVariantOptions; out result: variant); overload; /// initialize a variant instance to store some document-based content // from a supplied (extended) JSON content // - this global function is an alias to TDocVariant.NewJSON(), and // will return TRUE if JSON content was correctly converted into a variant // - in addition to the JSON RFC specification strict mode, this method will // handle some BSON-like extensions, e.g. unquoted field names or ObjectID() // - by default, every internal value will be copied, so access of nested // properties can be slow - if you expect the data to be read-only or not // propagated into another place, add dvoValueCopiedByReference in Options // will increase the process speed a lot, or use _JsonFast() function _Json(const JSON: RawUTF8; var Value: variant; Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): boolean; overload; {$ifdef HASINLINE}inline;{$endif} /// initialize a variant instance to store some document-based object content // - this global function is an handy alias to: // ! Obj(NameValuePairs,JSON_OPTIONS[true]); // - so all created objects and arrays will be handled by reference, for best // speed - but you should better write on the resulting variant tree with caution function _ObjFast(const NameValuePairs: array of const): variant; overload; /// initialize a variant instance to store any object as a TDocVariant // - is a wrapper around _JsonFast(ObjectToJson(aObject,aOptions)) function _ObjFast(aObject: TObject; aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]): variant; overload; /// initialize a variant instance to store some document-based array content // - this global function is an handy alias to: // ! _Array(Items,JSON_OPTIONS[true]); // - so all created objects and arrays will be handled by reference, for best // speed - but you should better write on the resulting variant tree with caution function _ArrFast(const Items: array of const): variant; overload; /// initialize a variant instance to store some document-based content // from a supplied (extended) JSON content // - this global function is an handy alias to: // ! _Json(JSON,JSON_OPTIONS[true]); // so it will return an Unassigned variant if JSON content was not correct // - so all created objects and arrays will be handled by reference, for best // speed - but you should better write on the resulting variant tree with caution // - in addition to the JSON RFC specification strict mode, this method will // handle some BSON-like extensions, e.g. unquoted field names or ObjectID() function _JsonFast(const JSON: RawUTF8): variant; {$ifdef HASINLINE}inline;{$endif} /// initialize a variant instance to store some extended document-based content // - this global function is an handy alias to: // ! _Json(JSON,JSON_OPTIONS_FAST_EXTENDED); function _JsonFastExt(const JSON: RawUTF8): variant; {$ifdef HASINLINE}inline;{$endif} /// initialize a variant instance to store some document-based content // from a supplied (extended) JSON content, with parameters formating // - this global function is an handy alias e.g. to: // ! aVariant := _JSONFmt('{%:{$in:[?,?]}}',['type'],['food','snack'],JSON_OPTIONS[true]); // - so all created objects and arrays will be handled by reference, for best // speed - but you should better write on the resulting variant tree with caution // - in addition to the JSON RFC specification strict mode, this method will // handle some BSON-like extensions, e.g. unquoted field names or ObjectID(): function _JsonFastFmt(const Format: RawUTF8; const Args,Params: array of const): variant; /// ensure a document-based variant instance will have only per-value nested // objects or array documents // - is just a wrapper around: // ! TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[false]) // - you can use this function to ensure that all internal properties of this // variant will be copied per-value whatever options the nested objects or // arrays were created with // - for huge document with a big depth of nested objects or arrays, a full // per-value copy may be time and resource consuming, but will be also safe // - will raise an EDocVariant if the supplied variant is not a TDocVariant or // a varByRef pointing to a TDocVariant procedure _Unique(var DocVariant: variant); /// ensure a document-based variant instance will have only per-value nested // objects or array documents // - is just a wrapper around: // ! TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[true]) // - you can use this function to ensure that all internal properties of this // variant will be copied per-reference whatever options the nested objects or // arrays were created with // - for huge document with a big depth of nested objects or arrays, it will // first create a whole copy of the document nodes, but further assignments // of the resulting value will be per-reference, so will be almost instant // - will raise an EDocVariant if the supplied variant is not a TDocVariant or // a varByRef pointing to a TDocVariant procedure _UniqueFast(var DocVariant: variant); /// return a full nested copy of a document-based variant instance // - is just a wrapper around: // ! TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[false]) // - you can use this function to ensure that all internal properties of this // variant will be copied per-value whatever options the nested objects or // arrays were created with: to be used on a value returned as varByRef // (e.g. by _() pseudo-method) // - for huge document with a big depth of nested objects or arrays, a full // per-value copy may be time and resource consuming, but will be also safe - // consider using _ByRef() instead if a fast copy-by-reference is enough // - will raise an EDocVariant if the supplied variant is not a TDocVariant or // a varByRef pointing to a TDocVariant function _Copy(const DocVariant: variant): variant; {$ifdef HASINLINE}inline;{$endif} /// return a full nested copy of a document-based variant instance // - is just a wrapper around: // ! TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[true]) // - you can use this function to ensure that all internal properties of this // variant will be copied per-value whatever options the nested objects or // arrays were created with: to be used on a value returned as varByRef // (e.g. by _() pseudo-method) // - for huge document with a big depth of nested objects or arrays, a full // per-value copy may be time and resource consuming, but will be also safe - // consider using _ByRef() instead if a fast copy-by-reference is enough // - will raise an EDocVariant if the supplied variant is not a TDocVariant or // a varByRef pointing to a TDocVariant function _CopyFast(const DocVariant: variant): variant; {$ifdef HASINLINE}inline;{$endif} /// copy a TDocVariant to another variable, changing the options on the fly // - note that the content (items or properties) is copied by reference, // so consider using _Copy() instead if you expect to safely modify its content // - will return null if the supplied variant is not a TDocVariant function _ByRef(const DocVariant: variant; Options: TDocVariantOptions): variant; overload; /// copy a TDocVariant to another variable, changing the options on the fly // - note that the content (items or properties) is copied by reference, // so consider using _Copy() instead if you expect to safely modify its content // - will return null if the supplied variant is not a TDocVariant procedure _ByRef(const DocVariant: variant; out Dest: variant; Options: TDocVariantOptions); overload; /// convert a TDocVariantData array or a string value into a CSV // - will call either TDocVariantData.ToCSV, or return the string // - returns '' if the supplied value is neither a TDocVariant or a string // - could be used e.g. to store either a JSON CSV string or a JSON array of // strings in a settings property function _CSV(const DocVariantOrString: variant): RawUTF8; /// will convert any TObject into a TDocVariant document instance // - a slightly faster alternative to Dest := _JsonFast(ObjectToJSON(Value)) // - this would convert the TObject by representation, using only serializable // published properties: do not use this function to store temporary a class // instance, but e.g. to store an object values in a NoSQL database // - if you expect lazy-loading of a TObject, see TObjectVariant.New() procedure ObjectToVariant(Value: TObject; out Dest: variant); overload; {$ifdef HASINLINE}inline;{$endif} /// will convert any TObject into a TDocVariant document instance // - a faster alternative to _JsonFast(ObjectToJSON(Value)) // - if you expect lazy-loading of a TObject, see TObjectVariant.New() function ObjectToVariant(Value: TObject; EnumSetsAsText: boolean=false): variant; overload; /// will convert any TObject into a TDocVariant document instance // - a faster alternative to _Json(ObjectToJSON(Value),Options) // - note that the result variable should already be cleared: no VarClear() // is done by this function // - would be used e.g. by VarRecToVariant() function // - if you expect lazy-loading of a TObject, see TObjectVariant.New() procedure ObjectToVariant(Value: TObject; var result: variant; Options: TTextWriterWriteObjectOptions); overload; {$endif NOVARIANTS} { ************ some console functions ************************************** } type /// available console colors (under Windows at least) TConsoleColor = ( ccBlack, ccBlue, ccGreen, ccCyan, ccRed, ccMagenta, ccBrown, ccLightGray, ccDarkGray, ccLightBlue, ccLightGreen, ccLightCyan, ccLightRed, ccLightMagenta, ccYellow, ccWhite); {$ifdef FPC}{$ifdef Linux} var stdoutIsTTY: boolean; {$endif}{$endif} /// change the Windows console text writing color // - you should call this procedure to initialize StdOut global variable, if // you manually initialized the Windows console, e.g. via the following code: // ! AllocConsole; // ! TextColor(ccLightGray); // initialize internal console context procedure TextColor(Color: TConsoleColor); /// change the Windows console text background color procedure TextBackground(Color: TConsoleColor); /// will wait for the ENTER key to be pressed, processing the internal // Windows Message loop and any Synchronize() pending notification // - to be used e.g. for proper work of console applications with interface-based // service implemented as optExecInMainThread procedure ConsoleWaitForEnterKey; {$ifdef MSWINDOWS} /// low-level access to the keyboard state of a given key function ConsoleKeyPressed(ExpectedKey: Word): Boolean; {$endif} /// direct conversion of a UTF-8 encoded string into a console OEM-encoded String // - under Windows, will use the CP_OEMCP encoding // - under Linux, will expect the console to be defined with UTF-8 encoding function Utf8ToConsole(const S: RawUTF8): RawByteString; {$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif} /// direct conversion of a VCL string into a console OEM-encoded String // - under Windows, will use the CP_OEMCP encoding // - under Linux, will expect the console to be defined with UTF-8 encoding function StringToConsole(const S: string): RawByteString; {$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif} /// could be used in the main program block of a console application to // handle unexpected fatal exceptions // - typical use may be: // !begin // ! try // ! ... // main console process // ! except // ! on E: Exception do // ! ConsoleShowFatalException(E); // ! end; // !end. procedure ConsoleShowFatalException(E: Exception; WaitForEnterKey: boolean=true); var /// low-level handle used for console writing // - may be overriden when console is redirected // - is initialized when TextColor() is called StdOut: THandle; {$ifndef NOVARIANTS} type /// an interface to process the command line switches over a console // - as implemented e.g. by TCommandLine class // - can implement any process, optionally with console interactivity ICommandLine = interface ['{77AB427C-1025-488B-8E04-3E62C8100E62}'] /// returns a command line switch value as UTF-8 text // - you can specify a prompt text, when asking for any missing switch function AsUTF8(const Switch, Default: RawUTF8; const Prompt: string): RawUTF8; /// returns a command line switch value as VCL string text // - you can specify a prompt text, when asking for any missing switch function AsString(const Switch: RawUTF8; const Default, Prompt: string): string; /// returns a command line switch value as integer // - you can specify a prompt text, when asking for any missing switch function AsInt(const Switch: RawUTF8; Default: Int64; const Prompt: string): Int64; /// returns a command line switch ISO-8601 value as date value // - here dates are expected to be encoded with ISO-8601, i.e. YYYY-MM-DD // - you can specify a prompt text, when asking for any missing switch function AsDate(const Switch: RawUTF8; Default: TDateTime; const Prompt: string): TDateTime; /// returns a command line switch value as enumeration ordinal // - RTTI will be used to check for the enumeration text, or plain integer // value will be returned as ordinal value // - you can specify a prompt text, when asking for any missing switch function AsEnum(const Switch, Default: RawUTF8; TypeInfo: pointer; const Prompt: string): integer; /// returns all command line values as an array of UTF-8 text // - i.e. won't interpret the various switches in the input parameters // - as created e.g. by TCommandLine.CreateAsArray constructor function AsArray: TRawUTF8DynArray; /// serialize all recognized switches as UTF-8 JSON text function AsJSON(Format: TTextWriterJSONFormat): RawUTF8; /// equals TRUE if the -noprompt switch has been supplied // - may be used to force pure execution without console interaction, // e.g. when run from another process function NoPrompt: boolean; /// change the console text color // - do nothing if NoPrompt is TRUE procedure TextColor(Color: TConsoleColor); /// write some console text, with an optional color // - will output the text even if NoPrompt is TRUE procedure Text(const Fmt: RawUTF8; const Args: array of const; Color: TConsoleColor=ccLightGray); end; /// a class to process the command line switches, with console interactivity // - is able to redirect all Text() output to an internal UTF-8 storage, // in addition or instead of the console (to be used e.g. from a GUI) // - implements ICommandLine interface TCommandLine = class(TInterfacedObjectWithCustomCreate, ICommandLine) private fValues: TDocVariantData; fNoPrompt: boolean; fNoConsole: boolean; fLines: TRawUTF8DynArray; procedure SetNoConsole(value: boolean); public /// initialize the internal storage from the command line // - will parse "-switch1 value1 -switch2 value2" layout // - stand-alone "-switch1 -switch2 value2" will a create switch1=true value constructor Create; overload; override; /// initialize the internal storage from the command line // - will set paramstr(firstParam)..paramstr(paramcount) in fValues as array // - may be used e.g. for "val1 val2 val3" command line layout constructor CreateAsArray(firstParam: integer); /// initialize the internal storage with some ready-to-use switches // - will also set the NoPrompt option, and set the supplied NoConsole value // - may be used e.g. from a graphical interface instead of console mode constructor Create(const switches: variant; aNoConsole: boolean=true); reintroduce; overload; /// initialize the internal storage with some ready-to-use name/value pairs // - will also set the NoPrompt option, and set the supplied NoConsole value // - may be used e.g. from a graphical interface instead of console mode constructor Create(const NameValuePairs: array of const; aNoConsole: boolean=true); reintroduce; overload; /// returns a command line switch value as UTF-8 text // - you can specify a prompt text, when asking for any missing switch function AsUTF8(const Switch, Default: RawUTF8; const Prompt: string): RawUTF8; /// returns a command line switch value as VCL string text // - you can specify a prompt text, when asking for any missing switch function AsString(const Switch: RawUTF8; const Default, Prompt: string): string; /// returns a command line switch value as integer // - you can specify a prompt text, when asking for any missing switch function AsInt(const Switch: RawUTF8; Default: Int64; const Prompt: string): Int64; /// returns a command line switch ISO-8601 value as date value // - here dates are expected to be encoded with ISO-8601, i.e. YYYY-MM-DD // - you can specify a prompt text, when asking for any missing switch function AsDate(const Switch: RawUTF8; Default: TDateTime; const Prompt: string): TDateTime; /// returns a command line switch value as enumeration ordinal // - RTTI will be used to check for the enumeration text, or plain integer // value will be returned as ordinal value // - you can specify a prompt text, when asking for any missing switch function AsEnum(const Switch, Default: RawUTF8; TypeInfo: pointer; const Prompt: string): integer; /// returns all command line values as an array of UTF-8 text // - i.e. won't interpret the various switches in the input parameters // - as created e.g. by TCommandLine.CreateAsArray constructor function AsArray: TRawUTF8DynArray; /// serialize all recognized switches as UTF-8 JSON text function AsJSON(Format: TTextWriterJSONFormat): RawUTF8; /// equals TRUE if the -noprompt switch has been supplied // - may be used to force pure execution without console interaction, // e.g. when run from another process function NoPrompt: boolean; /// change the console text color // - do nothing if NoPrompt is TRUE procedure TextColor(Color: TConsoleColor); /// write some console text, with an optional color // - will output the text even if NoPrompt=TRUE, but not if NoConsole=TRUE // - will append the text to the internal storage, available from ConsoleText procedure Text(const Fmt: RawUTF8; const Args: array of const; Color: TConsoleColor=ccLightGray); /// low-level access to the internal switches storage property Values: TDocVariantData read fValues; /// if Text() should be redirected to ConsoleText internal storage // - and don't write anything to the console // - should be associated with NoProperty = TRUE property property NoConsole: boolean read fNoConsole write SetNoConsole; /// low-level access to the internal UTF-8 console lines storage property ConsoleLines: TRawUTF8DynArray read fLines; /// returns the UTF-8 text as inserted by Text() calls // - line feeds will be included to the ConsoleLines[] values function ConsoleText(const LineFeed: RawUTF8=sLineBreak): RawUTF8; end; {$endif NOVARIANTS} { ******************* process monitoring / statistics ********************** } type /// the kind of value stored in a TSynMonitor / TSynMonitorUsage property // - i.e. match TSynMonitorTotalMicroSec, TSynMonitorOneMicroSec, // TSynMonitorOneCount, TSynMonitorOneBytes, TSynMonitorBytesPerSec, // TSynMonitorTotalBytes, TSynMonitorCount and TSynMonitorCount64 types as // used to store statistic information // - "cumulative" values would sum each process values, e.g. total elapsed // time for SOA execution, task count or total I/O bytes // - "immediate" (e.g. svOneBytes or smvBytesPerSec) values would be an evolving // single value, e.g. an average value or current disk free size // - use SYNMONITORVALUE_CUMULATIVE = [smvMicroSec,smvBytes,smvCount,smvCount64] // constant to identify the kind of value // - TSynMonitorUsage.Track() would use MonitorPropUsageValue() to guess // the tracked properties type from class RTTI TSynMonitorType = ( smvUndefined, smvOneMicroSec, smvOneBytes, smvOneCount, smvBytesPerSec, smvMicroSec, smvBytes, smvCount, smvCount64); /// value types as stored in TSynMonitor / TSynMonitorUsage TSynMonitorTypes = set of TSynMonitorType; /// would identify a cumulative time process information in micro seconds, during monitoring // - "cumulative" time would add each process timing, e.g. for statistics about // SOA computation of a given service // - any property defined with this type would be identified by TSynMonitorUsage TSynMonitorTotalMicroSec = type QWord; /// would identify an immediate time count information, during monitoring // - "immediate" counts won't accumulate, e.g. may store the current number // of thread used by a process // - any property defined with this type would be identified by TSynMonitorUsage TSynMonitorOneCount = type cardinal; /// would identify an immediate time process information in micro seconds, during monitoring // - "immediate" time won't accumulate, i.e. may store the duration of the // latest execution of a SOA computation // - any property defined with this type would be identified by TSynMonitorUsage TSynMonitorOneMicroSec = type QWord; /// would identify a process information as cumulative bytes count, during monitoring // - "cumulative" size would add some byte for each process, e.g. input/output // - any property defined with this type would be identified by TSynMonitorUsage TSynMonitorTotalBytes = type QWord; /// would identify an immediate process information as bytes count, during monitoring // - "immediate" size won't accumulate, i.e. may be e.g. computer free memory // at a given time // - any property defined with this type would be identified by TSynMonitorUsage TSynMonitorOneBytes = type QWord; /// would identify the process throughput, during monitoring // - it indicates e.g. "immediate" bandwith usage // - any property defined with this type would be identified by TSynMonitorUsage TSynMonitorBytesPerSec = type QWord; /// would identify a cumulative number of processes, during monitoring // - any property defined with this type would be identified by TSynMonitorUsage TSynMonitorCount = type cardinal; /// would identify a cumulative number of processes, during monitoring // - any property defined with this type would be identified by TSynMonitorUsage TSynMonitorCount64 = type QWord; /// pointer to a high resolution timer object/record PPrecisionTimer = ^TPrecisionTimer; /// indirect reference to a pointer to a high resolution timer object/record PPPrecisionTimer = ^PPrecisionTimer; /// high resolution timer (for accurate speed statistics) // - WARNING: under Windows, this record MUST be aligned to 32-bit, otherwise // iFreq=0 - so you can use TLocalPrecisionTimer/ILocalPrecisionTimer if you // want to alllocate a local timer instance on the stack {$ifdef FPC_OR_UNICODE}TPrecisionTimer = record private {$else}TPrecisionTimer = object protected{$endif} fStart,fStop,fResume,fLast: Int64; {$ifndef LINUX} // use QueryPerformanceMicroSeconds() fast API fWinFreq: Int64; {$endif} /// contains the time elapsed in micro seconds between Start and Stop fTime: TSynMonitorTotalMicroSec; /// contains the time elapsed in micro seconds between Resume and Pause fLastTime: TSynMonitorOneMicroSec; fPauseCount: TSynMonitorCount; public /// initialize the timer // - not necessary if created on the heap (e.g. as class member) // - will set all fields to 0 procedure Init; /// initialize and start the high resolution timer procedure Start; /// returns TRUE if fStart is not 0 function Started: boolean; {$ifdef HASINLINE}inline;{$endif} /// stop the timer, setting the Time elapsed since last Start procedure ComputeTime; {$ifdef LINUX}{$ifdef HASINLINE}inline;{$endif}{$endif} /// stop the timer, returning the time elapsed as text with time resolution // (us,ms,s) // - is just a wrapper around ComputeTime + Time function Stop: TShort16; /// stop the timer, ready to continue its time measurement via Resume procedure Pause; /// resume a paused timer // - if the previous method called was Pause, it will ignore all the // time elapsed since then // - if the previous method called was Start, it will start as if it was // in pause mode procedure Resume; /// resume a paused timer until the method ends // - will internaly create a TInterfaceObject class to let the compiler // generate a try..finally block as expected to call Pause at method ending // - is therefore very convenient to have consistent Resume/Pause calls // - for proper use, expect TPrecisionTimer to be initialized to 0 before // execution (e.g. define it as a protected member of a class) // - typical use is to declare a fTimeElapsed: TPrecisionTimer protected // member, then call fTimeElapsed.ProfileCurrentMethod at the beginning of // all process expecting some timing, then log/save fTimeElapsed.Stop content // - FPC TIP: result should be assigned to a local variable of IUnknown type function ProfileCurrentMethod: IUnknown; /// low-level method to force values settings to allow thread safe timing // - by default, this timer is not thread safe: you can use this method to // set the timing values from manually computed performance counters // - the caller should also use a mutex to prevent from race conditions: // see e.g. TSynMonitor.FromExternalQueryPerformanceCounters implementation // - returns the time elapsed, in micro seconds (i.e. LastTime value) // - warning: Start, Stop, Pause and Resume methods are then disallowed function FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; /// low-level method to force values settings to allow thread safe timing // - by default, this timer is not thread safe: you can use this method to // set the timing values from manually computed performance counters // - the caller should also use a mutex to prevent from race conditions: // see e.g. TSynMonitor.FromExternalMicroSeconds implementation // - warning: Start, Stop, Pause and Resume methods are then disallowed procedure FromExternalMicroSeconds(const MicroSeconds: QWord); {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell /// compute the per second count function PerSec(const Count: QWord): QWord; /// compute the time elapsed by count, with appened time resolution (us,ms,s) function ByCount(Count: QWord): TShort16; /// returns e.g. '16.9 MB in 102.20ms i.e. 165.5 MB/s' function SizePerSec(Size: QWord): shortstring; /// textual representation of time after counter stopped // - with appened time resolution (us,ms,s) // - not to be used in normal code, but e.g. for custom performance analysis function Time: TShort16; /// time elapsed in micro seconds after counter stopped // - not to be used in normal code, but e.g. for custom performance analysis property TimeInMicroSec: TSynMonitorTotalMicroSec read fTime write fTime; /// textual representation of last process timing after counter stopped // - with appened time resolution (us,ms,s) // - not to be used in normal code, but e.g. for custom performance analysis function LastTime: TShort16; /// timing in micro seconds of the last process // - not to be used in normal code, but e.g. for custom performance analysis property LastTimeInMicroSec: TSynMonitorOneMicroSec read fLastTime write fLastTime; /// how many times the Pause method was called, i.e. the number of tasks // processeed property PauseCount: TSynMonitorCount read fPauseCount; end; /// interface to a reference counted high resolution timer instance // - implemented by TLocalPrecisionTimer ILocalPrecisionTimer = interface /// start the high resolution timer procedure Start; /// stop the timer, returning the time elapsed, with appened time resolution (us,ms,s) function Stop: TShort16; /// stop the timer, ready to continue its time measure procedure Pause; /// resume a paused timer procedure Resume; /// compute the per second count function PerSec(Count: cardinal): cardinal; /// compute the time elapsed by count, with appened time resolution (us,ms,s) function ByCount(Count: cardinal): RawUTF8; end; /// reference counted high resolution timer (for accurate speed statistics) // - since TPrecisionTimer shall be 32-bit aligned, you can use this class // to initialize a local auto-freeing ILocalPrecisionTimer variable on stack // - to be used as such: // ! var Timer: ILocalPrecisionTimer; // ! (...) // ! Timer := TLocalPrecisionTimer.Create; // ! Timer.Start; // ! (...) TLocalPrecisionTimer = class(TInterfacedObject,ILocalPrecisionTimer) protected fTimer: TPrecisionTimer; public /// initialize the instance, and start the high resolution timer constructor CreateAndStart; /// start the high resolution timer procedure Start; /// stop the timer, returning the time elapsed, with appened time resolution (us,ms,s) function Stop: TShort16; /// stop the timer, ready to continue its time measure procedure Pause; /// resume a paused timer procedure Resume; /// compute the per second count function PerSec(Count: cardinal): cardinal; /// compute the time elapsed by count, with appened time resolution (us,ms,s) function ByCount(Count: cardinal): RawUTF8; end; /// able to serialize any cumulative timing as raw micro-seconds number or text // - "cumulative" time would add each process value, e.g. SOA methods execution TSynMonitorTime = class(TSynPersistent) protected fMicroSeconds: TSynMonitorTotalMicroSec; function GetAsText: TShort16; public /// compute a number per second, of the current value function PerSecond(const Count: QWord): QWord; {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell published /// micro seconds time elapsed, as raw number property MicroSec: TSynMonitorTotalMicroSec read fMicroSeconds write fMicroSeconds; /// micro seconds time elapsed, as '... us-ns-ms-s' text property Text: TShort16 read GetAsText; end; /// able to serialize any immediate timing as raw micro-seconds number or text // - "immediate" size won't accumulate, i.e. may be e.g. last process time TSynMonitorOneTime = class(TSynPersistent) protected fMicroSeconds: TSynMonitorOneMicroSec; function GetAsText: TShort16; public /// compute a number per second, of the current value function PerSecond(const Count: QWord): QWord; {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell published /// micro seconds time elapsed, as raw number property MicroSec: TSynMonitorOneMicroSec read fMicroSeconds write fMicroSeconds; /// micro seconds time elapsed, as '... us-ns-ms-s' text property Text: TShort16 read GetAsText; end; TSynMonitorSizeParent = class(TSynPersistent) protected fTextNoSpace: boolean; public /// initialize the instance constructor Create(aTextNoSpace: boolean); reintroduce; end; /// able to serialize any cumulative size as bytes number // - "cumulative" time would add each process value, e.g. global IO consumption TSynMonitorSize = class(TSynMonitorSizeParent) protected fBytes: TSynMonitorTotalBytes; function GetAsText: TShort16; published /// number of bytes, as raw number property Bytes: TSynMonitorTotalBytes read fBytes write fBytes; /// number of bytes, as '... B-KB-MB-GB' text property Text: TShort16 read GetAsText; end; /// able to serialize any immediate size as bytes number // - "immediate" size won't accumulate, i.e. may be e.g. computer free memory // at a given time TSynMonitorOneSize = class(TSynMonitorSizeParent) protected fBytes: TSynMonitorOneBytes; function GetAsText: TShort16; published /// number of bytes, as raw number property Bytes: TSynMonitorOneBytes read fBytes write fBytes; /// number of bytes, as '... B-KB-MB-GB' text property Text: TShort16 read GetAsText; end; /// able to serialize any bandwith as bytes count per second // - is usually associated with TSynMonitorOneSize properties, // e.g. to monitor IO activity TSynMonitorThroughput = class(TSynMonitorSizeParent) protected fBytesPerSec: QWord; function GetAsText: TShort16; published /// number of bytes per second, as raw number property BytesPerSec: QWord read fBytesPerSec write fBytesPerSec; /// number of bytes per second, as '... B-KB-MB-GB/s' text property Text: TShort16 read GetAsText; end; /// a generic value object able to handle any task / process statistic // - base class shared e.g. for ORM, SOA or DDD, when a repeatable data // process is to be monitored // - this class is thread-safe for its methods, but you should call explicitly // Lock/UnLock to access its individual properties TSynMonitor = class(TSynPersistentLock) protected fName: RawUTF8; fTaskCount: TSynMonitorCount64; fTotalTime: TSynMonitorTime; fLastTime: TSynMonitorOneTime; fMinimalTime: TSynMonitorOneTime; fAverageTime: TSynMonitorOneTime; fMaximalTime: TSynMonitorOneTime; fPerSec: QWord; fInternalErrors: TSynMonitorCount; fProcessing: boolean; fTaskStatus: (taskNotStarted,taskStarted); fLastInternalError: variant; procedure LockedPerSecProperties; virtual; procedure LockedFromProcessTimer; virtual; procedure LockedSum(another: TSynMonitor); virtual; procedure WriteDetailsTo(W: TTextWriter); virtual; procedure Changed; virtual; public /// low-level high-precision timer instance InternalTimer: TPrecisionTimer; /// initialize the instance nested class properties // - you can specify identifier associated to this monitored resource // which would be used for TSynMonitorUsage persistence constructor Create(const aName: RawUTF8); reintroduce; overload; virtual; /// initialize the instance nested class properties constructor Create; overload; override; /// finalize the instance destructor Destroy; override; /// lock the instance for exclusive access // - needed only if you access directly the instance properties procedure Lock; {$ifdef HASINLINE}inline;{$endif} /// release the instance for exclusive access // - needed only if you access directly the instance properties procedure UnLock; {$ifdef HASINLINE}inline;{$endif} /// create Count instances of this actual class in the supplied ObjArr[] class procedure InitializeObjArray(var ObjArr; Count: integer); virtual; /// should be called when the process starts, to resume the internal timer // - thread-safe method procedure ProcessStart; virtual; /// should be called each time a pending task is processed // - will increase the TaskCount property // - thread-safe method procedure ProcessDoTask; virtual; /// should be called when the process starts, and a task is processed // - similar to ProcessStart + ProcessDoTask // - thread-safe method procedure ProcessStartTask; virtual; /// should be called when an error occurred // - typical use is with ObjectToVariantDebug(E,...) kind of information // - thread-safe method procedure ProcessError(const info: variant); virtual; /// should be called when an error occurred // - typical use is with a HTTP status, e.g. as ProcessError(Call.OutStatus) // - just a wraper around overloaded ProcessError(), so a thread-safe method procedure ProcessErrorNumber(info: integer); /// should be called when an error occurred // - just a wraper around overloaded ProcessError(), so a thread-safe method procedure ProcessErrorFmt(const Fmt: RawUTF8; const Args: array of const); /// should be called when an Exception occurred // - just a wraper around overloaded ProcessError(), so a thread-safe method procedure ProcessErrorRaised(E: Exception); /// should be called when the process stops, to pause the internal timer // - thread-safe method procedure ProcessEnd; virtual; /// could be used to manage information average or sums // - thread-safe method calling LockedSum protected virtual method procedure Sum(another: TSynMonitor); /// returns a JSON content with all published properties information // - thread-safe method function ComputeDetailsJSON: RawUTF8; /// appends a JSON content with all published properties information // - thread-safe method procedure ComputeDetailsTo(W: TTextWriter); virtual; {$ifndef NOVARIANTS} /// returns a TDocVariant with all published properties information // - thread-safe method function ComputeDetails: variant; {$endif NOVARIANTS} /// used to allow thread safe timing // - by default, the internal TPrecisionTimer is not thread safe: you can // use this method to update the timing from many threads // - if you use this method, ProcessStart, ProcessDoTask and ProcessEnd // methods are disallowed, and the global fTimer won't be used any more // - will return the processing time, converted into micro seconds, ready // to be logged if needed // - thread-safe method function FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; /// used to allow thread safe timing // - by default, the internal TPrecisionTimer is not thread safe: you can // use this method to update the timing from many threads // - if you use this method, ProcessStart, ProcessDoTask and ProcessEnd // methods are disallowed, and the global fTimer won't be used any more // - thread-safe method procedure FromExternalMicroSeconds(const MicroSecondsElapsed: QWord); /// an identifier associated to this monitored resource // - is used e.g. for TSynMonitorUsage persistence/tracking property Name: RawUTF8 read fName write fName; published /// indicates if this thread is currently working on some process property Processing: boolean read fProcessing write fProcessing; /// how many times the task was performed property TaskCount: TSynMonitorCount64 read fTaskCount write fTaskCount; /// the whole time spend during all working process property TotalTime: TSynMonitorTime read fTotalTime; /// the time spend during the last task processing property LastTime: TSynMonitorOneTime read fLastTime; /// the lowest time spent during any working process property MinimalTime: TSynMonitorOneTime read fMinimalTime; /// the time spent in average during any working process property AverageTime: TSynMonitorOneTime read fAverageTime; /// the highest time spent during any working process property MaximalTime: TSynMonitorOneTime read fMaximalTime; /// average of how many tasks did occur per second property PerSec: QWord read fPerSec; /// how many errors did occur during the processing property Errors: TSynMonitorCount read fInternalErrors; /// information about the last error which occured during the processing property LastError: variant read fLastInternalError; end; /// references a TSynMonitor instance PSynMonitor = ^TSynMonitor; /// handle generic process statistic with a processing data size and bandwitdh TSynMonitorWithSize = class(TSynMonitor) protected fSize: TSynMonitorSize; fThroughput: TSynMonitorThroughput; procedure LockedPerSecProperties; override; procedure LockedSum(another: TSynMonitor); override; public /// initialize the instance nested class properties constructor Create; override; /// finalize the instance destructor Destroy; override; /// increase the internal size counter // - thread-safe method procedure AddSize(const Bytes: QWord); published /// how many total data has been hanlded during all working process property Size: TSynMonitorSize read fSize; /// data processing bandwith, returned as B/KB/MB per second property Throughput: TSynMonitorThroughput read fThroughput; end; /// handle generic process statistic with a incoming and outgoing processing // data size and bandwitdh TSynMonitorInputOutput = class(TSynMonitor) protected fInput: TSynMonitorSize; fOutput: TSynMonitorSize; fInputThroughput: TSynMonitorThroughput; fOutputThroughput: TSynMonitorThroughput; procedure LockedPerSecProperties; override; procedure LockedSum(another: TSynMonitor); override; public /// initialize the instance nested class properties constructor Create; override; /// finalize the instance destructor Destroy; override; /// increase the internal size counters // - thread-safe method procedure AddSize(const Incoming, Outgoing: QWord); published /// how many data has been received property Input: TSynMonitorSize read fInput; /// how many data has been sent back property Output: TSynMonitorSize read fOutput; /// incoming data processing bandwith, returned as B/KB/MB per second property InputThroughput: TSynMonitorThroughput read fInputThroughput; /// outgoing data processing bandwith, returned as B/KB/MB per second property OutputThroughput: TSynMonitorThroughput read fOutputThroughput; end; /// could monitor a standard Server // - including Input/Output statistics and connected Clients count TSynMonitorServer = class(TSynMonitorInputOutput) protected fCurrentRequestCount: integer; fClientsCurrent: TSynMonitorOneCount; fClientsMax: TSynMonitorOneCount; public /// update ClientsCurrent and ClientsMax // - thread-safe method procedure ClientConnect; /// update ClientsCurrent and ClientsMax // - thread-safe method procedure ClientDisconnect; /// update ClientsCurrent to 0 // - thread-safe method procedure ClientDisconnectAll; /// retrieve the number of connected clients // - thread-safe method function GetClientsCurrent: TSynMonitorOneCount; /// how many concurrent requests are currently processed // - returns the updated number of requests // - thread-safe method function AddCurrentRequestCount(diff: integer): integer; published /// current count of connected clients property ClientsCurrent: TSynMonitorOneCount read fClientsCurrent; /// max count of connected clients property ClientsMax: TSynMonitorOneCount read fClientsMax; /// how many concurrent requests are currently processed // - modified via AddCurrentRequestCount() in TSQLRestServer.URI() property CurrentRequestCount: integer read fCurrentRequestCount; end; /// a list of simple process statistics TSynMonitorObjArray = array of TSynMonitor; /// a list of data process statistics TSynMonitorWithSizeObjArray = array of TSynMonitorWithSize; /// a list of incoming/outgoing data process statistics TSynMonitorInputOutputObjArray = array of TSynMonitorInputOutput; /// class-reference type (metaclass) of a process statistic information TSynMonitorClass = class of TSynMonitor; { ******************* cross-cutting classes and functions ***************** } type /// an abstract ancestor, for implementing a custom TInterfacedObject like class // - by default, will do nothing: no instance would be retrieved by // QueryInterface unless the VirtualQueryInterface protected method is // overriden, and _AddRef/_Release methods would call VirtualAddRef and // VirtualRelease pure abstract methods // - using this class will leverage the signature difference between Delphi // and FPC, among all supported platforms // - the class includes a RefCount integer field TSynInterfacedObject = class(TObject,IUnknown) protected fRefCount: integer; // returns E_NOINTERFACE function VirtualQueryInterface(const IID: TGUID; out Obj): HResult; virtual; // always return 1 for a "non allocated" instance (0 triggers release) function VirtualAddRef: Integer; virtual; abstract; function VirtualRelease: Integer; virtual; abstract; {$ifdef FPC} function QueryInterface( {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; function _AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; function _Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; {$else} function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; {$endif} public /// the associated reference count property RefCount: integer read fRefCount write fRefCount; end; {$ifdef CPUINTEL} {$ifndef DELPHI5OROLDER} /// a simple class which will set FPU exception flags for a code block // - using an IUnknown interface to let the compiler auto-generate a // try..finally block statement to reset the FPU exception register // - to be used e.g. as such: // !begin // ! TSynFPUException.ForLibrayCode; // ! ... now FPU exceptions will be ignored // ! ... so here it is safe to call external libray code // !end; // now FPU exception will be reset as with standard Delphi // - it will avoid any unexpected invalid floating point operation in Delphi // code, whereas it was in fact triggerred in some external library code TSynFPUException = class(TSynInterfacedObject) protected {$ifndef CPU64} fExpected8087, fSaved8087: word; {$else} fExpectedMXCSR, fSavedMXCSR: word; {$endif} function VirtualAddRef: Integer; override; function VirtualRelease: Integer; override; public /// internal constructor // - do not call this constructor directly, but rather use // ForLibraryCode/ForDelphiCode class methods // - for cpu32 flags are $1372 for Delphi, or $137F for library (mask all exceptions) // - for cpu64 flags are $1920 for Delphi, or $1FA0 for library (mask all exceptions) {$ifndef CPU64} constructor Create(Expected8087Flag: word); reintroduce; {$else} constructor Create(ExpectedMXCSR: word); reintroduce; {$endif} /// after this method call, all FPU exceptions will be ignored // - until the method finishes (a try..finally block is generated by // the compiler), then FPU exceptions will be reset into "Delphi" mode // - you have to put this e.g. before calling an external libray // - this method is thread-safe and re-entrant (by reference-counting) class function ForLibraryCode: IUnknown; /// after this method call, all FPU exceptions will be enabled // - this is the Delphi normal behavior // - until the method finishes (a try..finally block is generated by // the compiler), then FPU execptions will be disabled again // - you have to put this e.g. before running an Delphi code from // a callback executed in an external libray // - this method is thread-safe and re-entrant (by reference-counting) class function ForDelphiCode: IUnknown; end; {$endif DELPHI5OROLDER} {$endif CPUINTEL} /// interface for TAutoFree to register another TObject instance // to an existing IAutoFree local variable IAutoFree = interface procedure Another(var objVar; obj: TObject); end; /// simple reference-counted storage for local objects // - be aware that it won't implement a full ARC memory model, but may be // just used to avoid writing some try ... finally blocks on local variables // - use with caution, only on well defined local scope TAutoFree = class(TInterfacedObject,IAutoFree) protected fObject: TObject; fObjectList: array of TObject; public /// initialize the TAutoFree class for one local variable // - do not call this constructor, but class function One() instead constructor Create(var localVariable; obj: TObject); reintroduce; overload; /// initialize the TAutoFree class for several local variables // - do not call this constructor, but class function Several() instead constructor Create(const varObjPairs: array of pointer); reintroduce; overload; /// protect one local TObject variable instance life time // - for instance, instead of writing: // !var myVar: TMyClass; // !begin // ! myVar := TMyClass.Create; // ! try // ! ... use myVar // ! finally // ! myVar.Free; // ! end; // !end; // - you may write: // !var myVar: TMyClass; // !begin // ! TAutoFree.One(myVar,TMyClass.Create); // ! ... use myVar // !end; // here myVar will be released // - warning: under FPC, you should assign the result of this method to a local // IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602 class function One(var localVariable; obj: TObject): IAutoFree; /// protect several local TObject variable instances life time // - specified as localVariable/objectInstance pairs // - you may write: // !var var1,var2: TMyClass; // !begin // ! TAutoFree.Several([ // ! @var1,TMyClass.Create, // ! @var2,TMyClass.Create]); // ! ... use var1 and var2 // !end; // here var1 and var2 will be released // - warning: under FPC, you should assign the result of this method to a local // IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602 class function Several(const varObjPairs: array of pointer): IAutoFree; /// protect another TObject variable to an existing IAutoFree instance life time // - you may write: // !var var1,var2: TMyClass; // ! auto: IAutoFree; // !begin // ! auto := TAutoFree.One(var1,TMyClass.Create);, // ! .... do something // ! auto.Another(var2,TMyClass.Create); // ! ... use var1 and var2 // !end; // here var1 and var2 will be released procedure Another(var localVariable; obj: TObject); /// will finalize the associated TObject instances // - note that releasing the TObject instances won't be protected, so // any exception here may induce a memory leak: use only with "safe" // simple objects, e.g. mORMot's TSQLRecord destructor Destroy; override; end; {$ifdef DELPHI5OROLDER} // IAutoLocker -> internal error C3517 under Delphi 5 :( TAutoLocker = class protected fSafe: TSynLocker; public constructor Create; destructor Destroy; override; procedure Enter; virtual; procedure Leave; virtual; function ProtectMethod: IUnknown; /// gives an access to the internal low-level TSynLocker instance used function Safe: PSynLocker; property Locker: TSynLocker read fSafe; end; IAutoLocker = TAutoLocker; {$else DELPHI5OROLDER} /// an interface used by TAutoLocker to protect multi-thread execution IAutoLocker = interface ['{97559643-6474-4AD3-AF72-B9BB84B4955D}'] /// enter the mutex // - any call to Enter should be ended with a call to Leave, and // protected by a try..finally block, as such: // !begin // ! ... // unsafe code // ! fSharedAutoLocker.Enter; // ! try // ! ... // thread-safe code // ! finally // ! fSharedAutoLocker.Leave; // ! end; // !end; procedure Enter; /// leave the mutex // - any call to Leave should be preceded with a call to Enter procedure Leave; /// will enter the mutex until the IUnknown reference is released // - using an IUnknown interface to let the compiler auto-generate a // try..finally block statement to release the lock for the code block // - could be used as such under Delphi: // !begin // ! ... // unsafe code // ! fSharedAutoLocker.ProtectMethod; // ! ... // thread-safe code // !end; // local hidden IUnknown will release the lock for the method // - warning: under FPC, you should assign its result to a local variable - // see bug http://bugs.freepascal.org/view.php?id=26602 // !var LockFPC: IUnknown; // !begin // ! ... // unsafe code // ! LockFPC := fSharedAutoLocker.ProtectMethod; // ! ... // thread-safe code // !end; // LockFPC will release the lock for the method // or // !begin // ! ... // unsafe code // ! with fSharedAutoLocker.ProtectMethod do begin // ! ... // thread-safe code // ! end; // local hidden IUnknown will release the lock for the method // !end; function ProtectMethod: IUnknown; /// gives an access to the internal low-level TSynLocker instance used function Safe: PSynLocker; end; /// reference-counted block code critical section // - you can use one instance of this to protect multi-threaded execution // - the main class may initialize a IAutoLocker property in Create, then call // IAutoLocker.ProtectMethod in any method to make its execution thread safe // - this class inherits from TInterfacedObjectWithCustomCreate so you // could define one published property of a mORMot.pas' TInjectableObject // as IAutoLocker so that this class may be automatically injected // - you may use the inherited TAutoLockerDebug class, as defined in SynLog.pas, // to debug unexpected race conditions due to such critical sections // - consider inherit from high-level TSynPersistentLock or call low-level // fSafe := NewSynLocker / fSafe^.DoneAndFreemem instead TAutoLocker = class(TInterfacedObjectWithCustomCreate,IAutoLocker) protected fSafe: TSynLocker; public /// initialize the mutex constructor Create; override; /// finalize the mutex destructor Destroy; override; /// will enter the mutex until the IUnknown reference is released // - as expected by IAutoLocker interface // - could be used as such under Delphi: // !begin // ! ... // unsafe code // ! fSharedAutoLocker.ProtectMethod; // ! ... // thread-safe code // !end; // local hidden IUnknown will release the lock for the method // - warning: under FPC, you should assign its result to a local variable - // see bug http://bugs.freepascal.org/view.php?id=26602 // !var LockFPC: IUnknown; // !begin // ! ... // unsafe code // ! LockFPC := fSharedAutoLocker.ProtectMethod; // ! ... // thread-safe code // !end; // LockFPC will release the lock for the method // or // !begin // ! ... // unsafe code // ! with fSharedAutoLocker.ProtectMethod do begin // ! ... // thread-safe code // ! end; // local hidden IUnknown will release the lock for the method // !end; function ProtectMethod: IUnknown; /// enter the mutex // - as expected by IAutoLocker interface // - any call to Enter should be ended with a call to Leave, and // protected by a try..finally block, as such: // !begin // ! ... // unsafe code // ! fSharedAutoLocker.Enter; // ! try // ! ... // thread-safe code // ! finally // ! fSharedAutoLocker.Leave; // ! end; // !end; procedure Enter; virtual; /// leave the mutex // - as expected by IAutoLocker interface procedure Leave; virtual; /// access to the locking methods of this instance // - as expected by IAutoLocker interface function Safe: PSynLocker; /// direct access to the locking methods of this instance // - faster than IAutoLocker.Safe function property Locker: TSynLocker read fSafe; end; {$endif DELPHI5OROLDER} {$ifndef DELPHI5OROLDER} // internal error C3517 under Delphi 5 :( {$ifndef NOVARIANTS} /// ref-counted interface for thread-safe access to a TDocVariant document // - is implemented e.g. by TLockedDocVariant, for IoC/DI resolution // - fast and safe storage of any JSON-like object, as property/value pairs, // or a JSON-like array, as values ILockedDocVariant = interface ['{CADC2C20-3F5D-4539-9D23-275E833A86F3}'] function GetValue(const Name: RawUTF8): Variant; procedure SetValue(const Name: RawUTF8; const Value: Variant); /// check and return a given property by name // - returns TRUE and fill Value with the value associated with the supplied // Name, using an internal lock for thread-safety // - returns FALSE if the Name was not found, releasing the internal lock: // use ExistsOrLock() if you want to add the missing value function Exists(const Name: RawUTF8; out Value: Variant): boolean; /// check and return a given property by name // - returns TRUE and fill Value with the value associated with the supplied // Name, using an internal lock for thread-safety // - returns FALSE and set the internal lock if Name does not exist: // caller should then release the lock via ReplaceAndUnlock() function ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean; /// set a value by property name, and set a local copy // - could be used as such, for implementing a thread-safe cache: // ! if not cache.ExistsOrLock('prop',local) then // ! cache.ReplaceAndUnlock('prop',newValue,local); // - call of this method should have been precedeed by ExistsOrLock() // returning false, i.e. be executed on a locked instance procedure ReplaceAndUnlock(const Name: RawUTF8; const Value: Variant; out LocalValue: Variant); /// add an existing property value to the given TDocVariant document object // - returns TRUE and add the Name/Value pair to Obj if Name is existing, // using an internal lock for thread-safety // - returns FALSE if Name is not existing in the stored document, and // lock the internal storage: caller should eventually release the lock // via AddNewPropAndUnlock() // - could be used as such, for implementing a thread-safe cache: // ! if not cache.AddExistingPropOrLock('Articles',Scope) then // ! cache.AddNewPropAndUnlock('Articles',GetArticlesFromDB,Scope); // here GetArticlesFromDB would occur inside the main lock function AddExistingPropOrLock(const Name: RawUTF8; var Obj: variant): boolean; /// add a property value to the given TDocVariant document object and // to the internal stored document, then release a previous lock // - call of this method should have been precedeed by AddExistingPropOrLock() // returning false, i.e. be executed on a locked instance procedure AddNewPropAndUnlock(const Name: RawUTF8; const Value: variant; var Obj: variant); /// add an existing property value to the given TDocVariant document object // - returns TRUE and add the Name/Value pair to Obj if Name is existing // - returns FALSE if Name is not existing in the stored document // - this method would use a lock during the Name lookup, but would always // release the lock, even if returning FALSE (see AddExistingPropOrLock) function AddExistingProp(const Name: RawUTF8; var Obj: variant): boolean; /// add a property value to the given TDocVariant document object // - this method would not expect the resource to be locked when called, // as with AddNewPropAndUnlock // - will use the internal lock for thread-safety // - if the Name is already existing, would update/change the existing value // - could be used as such, for implementing a thread-safe cache: // ! if not cache.AddExistingProp('Articles',Scope) then // ! cache.AddNewProp('Articles',GetArticlesFromDB,Scope); // here GetArticlesFromDB would occur outside the main lock procedure AddNewProp(const Name: RawUTF8; const Value: variant; var Obj: variant); /// append a value to the internal TDocVariant document array // - you should not use this method in conjunction with other document-based // alternatives, like Exists/AddExistingPropOrLock or AddExistingProp procedure AddItem(const Value: variant); /// makes a thread-safe copy of the internal TDocVariant document object or array function Copy: variant; /// delete all stored properties procedure Clear; /// save the stored values as UTF-8 encoded JSON Object function ToJSON(HumanReadable: boolean=false): RawUTF8; /// the document fields would be safely accessed via this property // - this is the main entry point of this storage // - will raise an EDocVariant exception if Name does not exist at reading // - implementation class would make a thread-safe copy of the variant value property Value[const Name: RawUTF8]: Variant read GetValue write SetValue; default; end; /// allows thread-safe access to a TDocVariant document // - this class inherits from TInterfacedObjectWithCustomCreate so you // could define one published property of a mORMot.pas' TInjectableObject // as ILockedDocVariant so that this class may be automatically injected TLockedDocVariant = class(TInterfacedObjectWithCustomCreate,ILockedDocVariant) protected fValue: TDocVariantData; fLock: TAutoLocker; function GetValue(const Name: RawUTF8): Variant; procedure SetValue(const Name: RawUTF8; const Value: Variant); public /// initialize the thread-safe document with a fast TDocVariant // - i.e. call Create(true) aka Create(JSON_OPTIONS[true]) // - will be the TInterfacedObjectWithCustomCreate default constructor, // called e.g. during IoC/DI resolution constructor Create; overload; override; /// initialize the thread-safe document storage constructor Create(FastStorage: boolean); reintroduce; overload; /// initialize the thread-safe document storage with the corresponding options constructor Create(options: TDocVariantOptions); reintroduce; overload; /// finalize the storage destructor Destroy; override; /// check and return a given property by name function Exists(const Name: RawUTF8; out Value: Variant): boolean; /// check and return a given property by name // - this version function ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean; /// set a value by property name, and set a local copy procedure ReplaceAndUnlock(const Name: RawUTF8; const Value: Variant; out LocalValue: Variant); /// add an existing property value to the given TDocVariant document object // - returns TRUE and add the Name/Value pair to Obj if Name is existing // - returns FALSE if Name is not existing in the stored document function AddExistingPropOrLock(const Name: RawUTF8; var Obj: variant): boolean; /// add a property value to the given TDocVariant document object and // to the internal stored document procedure AddNewPropAndUnlock(const Name: RawUTF8; const Value: variant; var Obj: variant); /// add an existing property value to the given TDocVariant document object // - returns TRUE and add the Name/Value pair to Obj if Name is existing // - returns FALSE if Name is not existing in the stored document // - this method would use a lock during the Name lookup, but would always // release the lock, even if returning FALSE (see AddExistingPropOrLock) function AddExistingProp(const Name: RawUTF8; var Obj: variant): boolean; /// add a property value to the given TDocVariant document object // - this method would not expect the resource to be locked when called, // as with AddNewPropAndUnlock // - will use the internal lock for thread-safety // - if the Name is already existing, would update/change the existing value procedure AddNewProp(const Name: RawUTF8; const Value: variant; var Obj: variant); /// append a value to the internal TDocVariant document array procedure AddItem(const Value: variant); /// makes a thread-safe copy of the internal TDocVariant document object or array function Copy: variant; /// delete all stored properties procedure Clear; /// save the stored value as UTF-8 encoded JSON Object // - implemented as just a wrapper around VariantSaveJSON() function ToJSON(HumanReadable: boolean=false): RawUTF8; /// the document fields would be safely accessed via this property // - will raise an EDocVariant exception if Name does not exist // - result variant is returned as a copy, not as varByRef, since a copy // will definitively be more thread safe property Value[const Name: RawUTF8]: Variant read GetValue write SetValue; default; end; {$endif} {$endif} type /// class-reference type (metaclass) of an TSynPersistentLock class TSynPersistentLockClass = class of TSynPersistentLock; /// abstract dynamic array of TSynPersistentLock instance // - note defined as T*ObjArray, since it won't TSynPersistentLockDynArray = array of TSynPersistentLock; /// maintain a thread-safe sorted list of TSynPersistentLock objects // - will use fast O(log(n)) binary search for efficient search - it is // a lighter alternative to TObjectListHashedAbstract/TObjectListPropertyHashed // if hashing has a performance cost (e.g. if there are a few items, or // deletion occurs regularly) // - in practice, insertion becomes slower after around 100,000 items stored // - expect to store only TSynPersistentLock inherited items, so that // the process is explicitly thread-safe // - inherited classes should override the Compare and NewItem abstract methods TObjectListSorted = class(TSynPersistentLock) protected fCount: integer; fObjArray: TSynPersistentLockDynArray; function FastLocate(const Value; out Index: Integer): boolean; procedure InsertNew(Item: TSynPersistentLock; Index: integer); // override those methods for actual implementation function Compare(Item: TSynPersistentLock; const Value): integer; virtual; abstract; function NewItem(const Value): TSynPersistentLock; virtual; abstract; public /// finalize the list destructor Destroy; override; /// search a given TSynPersistentLock instance from a value // - if returns not nil, caller should make result.Safe.UnLock once finished // - will use the TObjectListSortedCompare function for the search function FindLocked(const Value): pointer; /// search or add a given TSynPersistentLock instance from a value // - if returns not nil, caller should make result.Safe.UnLock once finished // - added is TRUE if a new void item has just been created // - will use the TObjectListSortedCompare function for the search function FindOrAddLocked(const Value; out added: boolean): pointer; /// remove a given TSynPersistentLock instance from a value function Delete(const Value): boolean; /// how many items are actually stored property Count: Integer read fCount; /// low-level access to the stored items // - warning: use should be protected by Lock.Enter/Lock.Leave property ObjArray: TSynPersistentLockDynArray read fObjArray; end; /// convert a size to a human readable value power-of-two metric value // - append EB, PB, TB, GB, MB, KB or B symbol with or without preceding space // - for EB, PB, TB, GB, MB and KB, add one fractional digit procedure KB(bytes: Int64; out result: TShort16; nospace: boolean); overload; /// convert a size to a human readable value // - append EB, PB, TB, GB, MB, KB or B symbol with preceding space // - for EB, PB, TB, GB, MB and KB, add one fractional digit function KB(bytes: Int64): TShort16; overload; {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell /// convert a size to a human readable value // - append EB, PB, TB, GB, MB, KB or B symbol without preceding space // - for EB, PB, TB, GB, MB and KB, add one fractional digit function KBNoSpace(bytes: Int64): TShort16; {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell /// convert a size to a human readable value // - append EB, PB, TB, GB, MB, KB or B symbol with or without preceding space // - for EB, PB, TB, GB, MB and KB, add one fractional digit function KB(bytes: Int64; nospace: boolean): TShort16; overload; {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell /// convert a string size to a human readable value // - append EB, PB, TB, GB, MB, KB or B symbol // - for EB, PB, TB, GB, MB and KB, add one fractional digit function KB(const buffer: RawByteString): TShort16; overload; {$ifdef FPC_OR_UNICODE}inline;{$endif} /// convert a size to a human readable value // - append EB, PB, TB, GB, MB, KB or B symbol // - for EB, PB, TB, GB, MB and KB, add one fractional digit procedure KBU(bytes: Int64; var result: RawUTF8); /// convert a micro seconds elapsed time into a human readable value // - append 'us', 'ms', 's', 'm', 'h' and 'd' symbol for the given value range, // with two fractional digits function MicroSecToString(Micro: QWord): TShort16; overload; {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell /// convert a micro seconds elapsed time into a human readable value // - append 'us', 'ms', 's', 'm', 'h' and 'd' symbol for the given value range, // with two fractional digits procedure MicroSecToString(Micro: QWord; out result: TShort16); overload; /// convert an integer value into its textual representation with thousands marked // - ThousandSep is the character used to separate thousands in numbers with // more than three digits to the left of the decimal separator function IntToThousandString(Value: integer; const ThousandSep: TShort4=','): shortstring; /// return the Delphi/FPC Compiler Version // - returns 'Delphi 2007', 'Delphi 2010' or 'Free Pascal 3.3.1' e.g. function GetDelphiCompilerVersion: RawUTF8; /// returns TRUE if the supplied mutex has been initialized // - will check if the supplied mutex is void (i.e. all filled with 0 bytes) function IsInitializedCriticalSection(const CS: TRTLCriticalSection): Boolean; {$ifdef HASINLINE}inline;{$endif} /// on need initialization of a mutex, then enter the lock // - if the supplied mutex has been initialized, do nothing // - if the supplied mutex is void (i.e. all filled with 0), initialize it procedure InitializeCriticalSectionIfNeededAndEnter(var CS: TRTLCriticalSection); {$ifdef HASINLINE}inline;{$endif} /// on need finalization of a mutex // - if the supplied mutex has been initialized, delete it // - if the supplied mutex is void (i.e. all filled with 0), do nothing procedure DeleteCriticalSectionIfNeeded(var CS: TRTLCriticalSection); /// compress a data content using the SynLZ algorithm // - as expected by THttpSocket.RegisterCompress // - will return 'synlz' as ACCEPT-ENCODING: header parameter // - will store a hash of both compressed and uncompressed stream: if the // data is corrupted during transmission, will instantly return '' function CompressSynLZ(var DataRawByteString; Compress: boolean): AnsiString; /// compress a data content using the SynLZ algorithm from one stream into another // - returns the number of bytes written to Dest // - you should specify a Magic number to be used to identify the block function StreamSynLZ(Source: TCustomMemoryStream; Dest: TStream; Magic: cardinal): integer; overload; /// compress a data content using the SynLZ algorithm from one stream into a file // - returns the number of bytes written to the destination file // - you should specify a Magic number to be used to identify the block function StreamSynLZ(Source: TCustomMemoryStream; const DestFile: TFileName; Magic: cardinal): integer; overload; /// uncompress using the SynLZ algorithm from one stream into another // - returns a newly create memory stream containing the uncompressed data // - returns nil if source data is invalid // - you should specify a Magic number to be used to identify the block // - this function will also recognize the block at the end of the source stream // (if was appended to an existing data - e.g. a .mab at the end of a .exe) // - on success, Source will point after all read data (so that you can e.g. // append several data blocks to the same stream) function StreamUnSynLZ(Source: TStream; Magic: cardinal): TMemoryStream; overload; /// compute the real length of a given StreamSynLZ-compressed buffer // - allows to replace an existing appended content, for instance function StreamSynLZComputeLen(P: PAnsiChar; Len, aMagic: cardinal): integer; /// uncompress using the SynLZ algorithm from one file into another // - returns a newly create memory stream containing the uncompressed data // - returns nil if source file is invalid (e.g. invalid name or invalid content) // - you should specify a Magic number to be used to identify the block // - this function will also recognize the block at the end of the source file // (if was appended to an existing data - e.g. a .mab at the end of a .exe) function StreamUnSynLZ(const Source: TFileName; Magic: cardinal): TMemoryStream; overload; /// compress a file content using the SynLZ algorithm a file content // - source file is split into 128 MB blocks for fast in-memory compression of // any file size // - you should specify a Magic number to be used to identify the compressed // file format function FileSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; /// compress a file content using the SynLZ algorithm a file content // - you should specify a Magic number to be used to identify the compressed // file format function FileUnSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; /// returns TRUE if the supplied file name is a SynLZ compressed file, // matching the Magic number as supplied to FileSynLZ() function function FileIsSynLZ(const Name: TFileName; Magic: Cardinal): boolean; var /// acccess to our fast SynLZ compression as a TAlgoCompress class // - please use this global variable methods instead of the deprecated // SynLZCompress/SynLZDecompress wrapper functions AlgoSynLZ: TAlgoCompress; const /// CompressionSizeTrigger parameter SYNLZTRIG[true] will disable then // SynLZCompress() compression SYNLZTRIG: array[boolean] of integer = (100, maxInt); /// used e.g. as when ALGO_SAFE[SafeDecompression] for TAlgoCompress.Decompress ALGO_SAFE: array[boolean] of TAlgoCompressLoad = (aclNormal, aclSafeSlow); /// deprecated function - please call AlgoSynLZ.Compress() method function SynLZCompress(const Data: RawByteString; CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false): RawByteString; overload; /// deprecated function - please call AlgoSynLZ.Compress() method procedure SynLZCompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false); overload; /// deprecated function - please call AlgoSynLZ.Compress() method function SynLZCompress(P, Dest: PAnsiChar; PLen, DestLen: integer; CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false): integer; overload; /// deprecated function - please call AlgoSynLZ.Decompress() method function SynLZDecompress(const Data: RawByteString): RawByteString; overload; /// deprecated function - please call AlgoSynLZ.Decompress() method procedure SynLZDecompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; SafeDecompression: boolean=false); overload; /// deprecated function - please call AlgoSynLZ.DecompressToBytes() method function SynLZCompressToBytes(const Data: RawByteString; CompressionSizeTrigger: integer=100): TByteDynArray; overload; /// deprecated function - please call AlgoSynLZ.CompressToBytes() method function SynLZCompressToBytes(P: PAnsiChar; PLen: integer; CompressionSizeTrigger: integer=100): TByteDynArray; overload; /// deprecated function - please call AlgoSynLZ.Decompress() method function SynLZDecompress(const Data: TByteDynArray): RawByteString; overload; /// deprecated function - please call AlgoSynLZ.Decompress() method function SynLZDecompress(const Data: RawByteString; out Len: integer; var tmp: RawByteString): pointer; overload; /// deprecated function - please call AlgoSynLZ.Decompress() method function SynLZDecompress(P: PAnsiChar; PLen: integer; out Len: integer; var tmp: RawByteString): pointer; overload; /// deprecated function - please call AlgoSynLZ.DecompressHeader() method function SynLZDecompressHeader(P: PAnsiChar; PLen: integer): integer; /// deprecated function - please call AlgoSynLZ.DecompressBody() method function SynLZDecompressBody(P,Body: PAnsiChar; PLen,BodyLen: integer; SafeDecompression: boolean=false): boolean; /// deprecated function - please call AlgoSynLZ.DecompressPartial() method function SynLZDecompressPartial(P,Partial: PAnsiChar; PLen,PartialLen: integer): integer; 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 {$ifdef FPC} uses {$ifdef LINUX} Unix, dynlibs, termio, {$ifdef BSD} sysctl, {$else} Linux, SysCall, {$endif BSD} {$ifdef FPCUSEVERSIONINFO} // to be enabled in Synopse.inc fileinfo, // FPC 3.0 and up {$ifdef DARWIN} machoreader, // MACH-O executables {$else} elfreader, // ELF executables {$endif DARWIN} {$endif FPCUSEVERSIONINFO} {$ifdef ISFPC271} unixcp, // for GetSystemCodePage {$endif} SynFPCLinux, {$endif LINUX} SynFPCTypInfo; // small wrapper unit around FPC's TypInfo.pp {$endif FPC} { ************ some fast UTF-8 / Unicode / Ansi conversion routines } var // internal list of TSynAnsiConvert instances SynAnsiConvertList: TObjectList = 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 FPC} function _LStrLen(const s: RawByteString): SizeInt; inline; begin // here caller ensured s<>'' result := PSizeInt(PAnsiChar(pointer(s))-SizeOf(SizeInt))^; end; function _LStrLenP(s: pointer): SizeInt; inline; begin // here caller ensured s<>'' result := PSizeInt(PAnsiChar(s)-SizeOf(SizeInt))^; end; {$endif FPC} { TSynAnsiConvert } {$ifdef MSWINDOWS} const DefaultCharVar: AnsiChar = '?'; {$endif} function TSynAnsiConvert.AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PWideChar; var c: cardinal; {$ifndef MSWINDOWS} {$ifdef FPC} tmp: UnicodeString; {$endif} {$ifdef KYLIX3} ic: iconv_t; DestBegin: PAnsiChar; SourceCharsBegin: integer; {$endif} {$endif} begin {$ifdef KYLIX3} SourceCharsBegin := SourceChars; DestBegin := pointer(Dest); {$endif} // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) if SourceChars>=4 then repeat c := PCardinal(Source)^; if c and $80808080<>0 then break; // break on first non ASCII quad dec(SourceChars,4); inc(Source,4); PCardinal(Dest)^ := (c shl 8 or (c and $FF)) and $00ff00ff; c := c shr 16; PCardinal(Dest+2)^ := (c shl 8 or c) and $00ff00ff; inc(Dest,4); until SourceChars<4; if (SourceChars>0) and (ord(Source^)<128) then repeat dec(SourceChars); PWord(Dest)^ := ord(Source^); // much faster than dest^ := WideChar(c) for FPC inc(Source); inc(Dest); until (SourceChars=0) or (ord(Source^)>=128); // rely on the Operating System for all remaining ASCII characters if SourceChars=0 then result := Dest else begin {$ifdef MSWINDOWS} result := Dest+MultiByteToWideChar( fCodePage,MB_PRECOMPOSED,Source,SourceChars,Dest,SourceChars); {$else} {$ifdef ISDELPHIXE} // use cross-platform wrapper for MultiByteToWideChar() result := Dest+UnicodeFromLocaleChars( fCodePage,MB_PRECOMPOSED,Source,SourceChars,Dest,SourceChars); {$else} {$ifdef FPC} widestringmanager.Ansi2UnicodeMoveProc(Source, {$ifdef ISFPC27}fCodePage,{$endif}tmp,SourceChars); MoveFast(Pointer(tmp)^,Dest^,length(tmp)*2); result := Dest+length(tmp); {$else} {$ifdef KYLIX3} result := Dest; // makes compiler happy ic := LibC.iconv_open('UTF-16LE',Pointer(fIConvCodeName)); if PtrInt(ic)>=0 then try result := IconvBufConvert(ic,Source,SourceChars,1, Dest,SourceCharsBegin*2-(PAnsiChar(Dest)-DestBegin),2); finally LibC.iconv_close(ic); end else {$else} raise ESynException.CreateUTF8('%.AnsiBufferToUnicode() not supported yet for CP=%', [self,CodePage]); {$endif KYLIX3} {$endif FPC} {$endif ISDELPHIXE} {$endif MSWINDOWS} end; if not NoTrailingZero then result^ := #0; end; function TSynAnsiConvert.AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PUTF8Char; var tmp: array[0..256*6] of WideChar; c: cardinal; U: PWideChar; begin // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) if SourceChars>=4 then repeat c := PCardinal(Source)^; if c and $80808080<>0 then break; // break on first non ASCII quad PCardinal(Dest)^ := c; dec(SourceChars,4); inc(Source,4); inc(Dest,4); until SourceChars<4; if (SourceChars>0) and (ord(Source^)<128) then repeat Dest^ := Source^; dec(SourceChars); inc(Source); inc(Dest); until (SourceChars=0) or (ord(Source^)>=128); // rely on the Operating System for all remaining ASCII characters if SourceChars=0 then result := Dest else if SourceChars WideCharCount*3 below procedure TSynAnsiConvert.InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; DestTextWriter: TObject; Escape: TTextWriterKind); var W: TTextWriter absolute DestTextWriter; tmp: TSynTempBuffer; begin // rely on explicit conversion SourceChars := AnsiBufferToUTF8(tmp.Init(SourceChars*3+1),Source,SourceChars)-tmp.buf; W.Add(tmp.buf,SourceChars,Escape); tmp.Done; end; function TSynAnsiConvert.AnsiToRawUnicode(const AnsiText: RawByteString): RawUnicode; begin result := AnsiToRawUnicode(pointer(AnsiText),length(AnsiText)); end; function TSynAnsiConvert.AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; var U: PWideChar; begin if SourceChars=0 then result := '' else begin SetString(result,nil,SourceChars*2+1); U := AnsiBufferToUnicode(pointer(result),Source,SourceChars); U^ := #0; SetLength(result,PtrUInt(U)-PtrUInt(result)+1); end; end; function TSynAnsiConvert.AnsiToUnicodeString(Source: PAnsiChar; SourceChars: Cardinal): SynUnicode; var tmp: TSynTempBuffer; U: PWideChar; begin if SourceChars=0 then result := '' else begin tmp.Init(SourceChars*2+1); // max dest size in bytes (including trailing #0 widechar) U := AnsiBufferToUnicode(tmp.buf,Source,SourceChars); SetString(result,PWideChar(tmp.buf),(PtrUInt(U)-PtrUInt(tmp.buf))shr 1); tmp.Done; end; end; function TSynAnsiConvert.AnsiToUnicodeString(const Source: RawByteString): SynUnicode; var tmp: TSynTempBuffer; U: PWideChar; begin if Source='' then result := '' else begin tmp.Init(length(Source)*2+1); // max dest size in bytes U := AnsiBufferToUnicode(tmp.buf,pointer(Source),length(Source)); SetString(result,PWideChar(tmp.buf),(PtrUInt(U)-PtrUInt(tmp.buf))shr 1); tmp.Done; end; end; function TSynAnsiConvert.AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; begin result := AnsiBufferToRawUTF8(pointer(AnsiText),length(AnsiText)); end; function TSynAnsiConvert.AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; var tmp: TSynTempBuffer; begin if (Source=nil) or (SourceChars=0) then result := '' else tmp.Done(AnsiBufferToUTF8(tmp.Init(SourceChars*3+1),Source,SourceChars),result); end; constructor TSynAnsiConvert.Create(aCodePage: cardinal); begin fCodePage := aCodePage; fAnsiCharShift := 1; // default is safe {$ifdef KYLIX3} fIConvCodeName := 'CP'+UInt32ToUTF8(aCodePage); {$endif} end; function IsFixedWidthCodePage(aCodePage: cardinal): boolean; begin result := ((aCodePage>=1250) and (aCodePage<=1258)) or (aCodePage=CODEPAGE_LATIN1) or (aCodePage=CP_RAWBYTESTRING); end; class function TSynAnsiConvert.Engine(aCodePage: cardinal): TSynAnsiConvert; var i: integer; begin if SynAnsiConvertList=nil then begin GarbageCollectorFreeAndNil(SynAnsiConvertList,TObjectList.Create); CurrentAnsiConvert := TSynAnsiConvert.Engine(GetACP); WinAnsiConvert := TSynAnsiConvert.Engine(CODEPAGE_US) as TSynAnsiFixedWidth; UTF8AnsiConvert := TSynAnsiConvert.Engine(CP_UTF8) as TSynAnsiUTF8; end; if aCodePage<=0 then begin result := CurrentAnsiConvert; exit; end; with SynAnsiConvertList do for i := 0 to Count-1 do begin result := List[i]; if result.CodePage=aCodePage then exit; end; if aCodePage=CP_UTF8 then result := TSynAnsiUTF8.Create(CP_UTF8) else if aCodePage=CP_UTF16 then result := TSynAnsiUTF16.Create(CP_UTF16) else if IsFixedWidthCodePage(aCodePage) then result := TSynAnsiFixedWidth.Create(aCodePage) else result := TSynAnsiConvert.Create(aCodePage); SynAnsiConvertList.Add(result); end; function TSynAnsiConvert.UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; var c: cardinal; {$ifndef MSWINDOWS} {$ifdef FPC} tmp: RawByteString; {$endif} {$ifdef KYLIX3} ic: iconv_t; DestBegin: PAnsiChar; SourceCharsBegin: integer; {$endif} {$endif MSWINDOWS} begin {$ifdef KYLIX3} SourceCharsBegin := SourceChars; DestBegin := Dest; {$endif} // first handle trailing 7 bit ASCII chars, by pairs (Sha optimization) if SourceChars>=2 then repeat c := PCardinal(Source)^; if c and $ff80ff80<>0 then break; // break on first non ASCII pair dec(SourceChars,2); inc(Source,2); c := c shr 8 or c; PWord(Dest)^ := c; inc(Dest,2); until SourceChars<2; if (SourceChars>0) and (ord(Source^)<128) then repeat Dest^ := AnsiChar(ord(Source^)); dec(SourceChars); inc(Source); inc(Dest); until (SourceChars=0) or (ord(Source^)>=128); // rely on the Operating System for all remaining ASCII characters if SourceChars=0 then result := Dest else begin {$ifdef MSWINDOWS} result := Dest+WideCharToMultiByte( fCodePage,0,Source,SourceChars,Dest,SourceChars*3,@DefaultCharVar,nil); {$else} {$ifdef ISDELPHIXE} // use cross-platform wrapper for WideCharToMultiByte() result := Dest+System.LocaleCharsFromUnicode( fCodePage,0,Source,SourceChars,Dest,SourceChars*3,@DefaultCharVar,nil); {$else} {$ifdef FPC} widestringmanager.Unicode2AnsiMoveProc(Source,tmp, {$ifdef ISFPC27}fCodePage,{$endif}SourceChars); MoveFast(Pointer(tmp)^,Dest^,length(tmp)); result := Dest+length(tmp); {$else} {$ifdef KYLIX3} result := Dest; // makes compiler happy ic := LibC.iconv_open(Pointer(fIConvCodeName),'UTF-16LE'); if PtrInt(ic)>=0 then try result := IconvBufConvert(ic,Source,SourceChars,2, Dest,SourceCharsBegin*3-(PAnsiChar(Dest)-DestBegin),1); finally LibC.iconv_close(ic); end else {$else} raise ESynException.CreateUTF8('%.UnicodeBufferToAnsi() not supported yet for CP=%', [self,CodePage]); {$endif KYLIX3} {$endif FPC} {$endif ISDELPHIXE} {$endif MSWINDOWS} end; end; function TSynAnsiConvert.UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; var tmp: array[0..256*6] of WideChar; U: PWideChar; begin if SourceChars0 then begin if result>SizeOf(tmp) then result := SizeOf(tmp); result := UTF8BufferToAnsi(tmp,pointer(s),result)-tmp; if result>=DestSize then result := DestSize-1; {$ifdef FPC}Move{$else}MoveFast{$endif}(tmp,Dest^,result); end; Dest[result] := #0; end; function TSynAnsiConvert.UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString; var tmp: TSynTempBuffer; begin if (Source=nil) or (SourceChars=0) then result := '' else begin tmp.Init((SourceChars+1) shl fAnsiCharShift); FastSetStringCP(result,tmp.buf, UnicodeBufferToAnsi(tmp.buf,Source,SourceChars)-tmp.buf,fCodePage); tmp.Done; end; end; function TSynAnsiConvert.RawUnicodeToAnsi(const Source: RawUnicode): RawByteString; begin result := UnicodeBufferToAnsi(pointer(Source),length(Source) shr 1); end; function TSynAnsiConvert.AnsiToAnsi(From: TSynAnsiConvert; const Source: RawByteString): RawByteString; begin if From=self then result := Source else result := AnsiToAnsi(From,pointer(Source),length(Source)); end; function TSynAnsiConvert.AnsiToAnsi(From: TSynAnsiConvert; Source: PAnsiChar; SourceChars: cardinal): RawByteString; var tmpU: array[byte] of WideChar; U: PWideChar; begin if From=self then FastSetStringCP(result,Source,SourceChars,fCodePage) else if (Source=nil) or (SourceChars=0) then result := '' else if SourceCharsnil) and (SourceChars>0) then begin // handle 7 bit ASCII WideChars, by quads (Sha optimization) EndSource := Source+SourceChars; EndSourceBy4 := EndSource-4; if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then repeat By4: c := PCardinal(Source)^; if c and $80808080<>0 then goto By1; // break on first non ASCII quad inc(Source,4); PCardinal(Dest)^ := c; inc(Dest,4); until Source>EndSourceBy4; // generic loop, handling one WideChar per iteration if Source$7ff then begin Dest[0] := AnsiChar($E0 or (c shr 12)); Dest[1] := AnsiChar($80 or ((c shr 6) and $3F)); Dest[2] := AnsiChar($80 or (c and $3F)); Inc(Dest,3); if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then goto By4; if Source 255 // - values taken from MultiByteToWideChar(1252,0,@Tmp,256,@WinAnsiTable,256) // so these values are available outside the Windows platforms (e.g. Linux/BSD) // and even if registry has been tweaked as such: // http://www.fas.harvard.edu/~chgis/data/chgis/downloads/v4/howto/cyrillic.html WinAnsiUnicodeChars: packed array[128..159] of word = (8364, 129, 8218, 402, 8222, 8230, 8224, 8225, 710, 8240, 352, 8249, 338, 141, 381, 143, 144, 8216, 8217, 8220, 8221, 8226, 8211, 8212, 732, 8482, 353, 8250, 339, 157, 382, 376); constructor TSynAnsiFixedWidth.Create(aCodePage: cardinal); var i: PtrInt; A256: array[0..256] of AnsiChar; U256: array[0..256] of WideChar; // AnsiBufferToUnicode() write a last #0 begin inherited; if not IsFixedWidthCodePage(aCodePage) then // ESynException.CreateUTF8() uses UTF8ToString() -> use CreateFmt() here raise ESynException.CreateFmt('%s.Create - Invalid code page %d', [ClassName,fCodePage]); // create internal look-up tables SetLength(fAnsiToWide,256); if (aCodePage=CODEPAGE_US) or (aCodePage=CODEPAGE_LATIN1) or (aCodePage=CP_RAWBYTESTRING) then begin for i := 0 to 255 do fAnsiToWide[i] := i; if aCodePage=CODEPAGE_US then // do not trust the Windows API :( for i := low(WinAnsiUnicodeChars) to high(WinAnsiUnicodeChars) do fAnsiToWide[i] := WinAnsiUnicodeChars[i]; end else begin // from Operating System returned values for i := 0 to 255 do A256[i] := AnsiChar(i); FillcharFast(U256,SizeOf(U256),0); if PtrUInt(inherited AnsiBufferToUnicode(U256,A256,256))-PtrUInt(@U256)>512 then // ESynException.CreateUTF8() uses UTF8ToString() -> use CreateFmt() here raise ESynException.CreateFmt('OS error for %s.Create(%d)',[ClassName,aCodePage]); MoveFast(U256[0],fAnsiToWide[0],512); end; SetLength(fWideToAnsi,65536); for i := 1 to 126 do fWideToAnsi[i] := i; FillcharFast(fWideToAnsi[127],65536-127,ord('?')); // '?' for unknown char for i := 127 to 255 do if (fAnsiToWide[i]<>0) and (fAnsiToWide[i]<>ord('?')) then fWideToAnsi[fAnsiToWide[i]] := i; // fixed width Ansi will never be bigger than UTF-8 fAnsiCharShift := 0; end; function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar; Length: integer): boolean; var i: PtrInt; wc: cardinal; begin result := false; if WideText<>nil then for i := 0 to Length-1 do begin wc := cardinal(WideText[i]); if wc=0 then break else if wc<256 then if fAnsiToWide[wc]<256 then continue else exit else if fWideToAnsi[wc]=ord('?') then exit else continue; end; result := true; end; function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar): boolean; var wc: cardinal; begin result := false; if WideText<>nil then repeat wc := cardinal(WideText^); inc(WideText); if wc=0 then break else if wc<256 then if fAnsiToWide[wc]<256 then continue else exit else if fWideToAnsi[wc]=ord('?') then exit else continue; until false; result := true; end; function TSynAnsiFixedWidth.IsValidAnsiU(UTF8Text: PUTF8Char): boolean; var c: PtrUInt; i, extra: PtrInt; begin result := false; if UTF8Text<>nil then repeat c := byte(UTF8Text^); inc(UTF8Text); if c=0 then break else if c<=127 then continue else begin extra := UTF8_EXTRABYTES[c]; if UTF8_EXTRA[extra].minimum>$ffff then exit; for i := 1 to extra do begin if byte(UTF8Text^) and $c0<>$80 then exit; // invalid UTF-8 content c := c shl 6+byte(UTF8Text^); inc(UTF8Text); end; dec(c,UTF8_EXTRA[extra].offset); if (c>$ffff) or (fWideToAnsi[c]=ord('?')) then exit; // invalid char in the WinAnsi code page end; until false; result := true; end; function TSynAnsiFixedWidth.IsValidAnsiU8Bit(UTF8Text: PUTF8Char): boolean; var c: PtrUInt; i, extra: PtrInt; begin result := false; if UTF8Text<>nil then repeat c := byte(UTF8Text^); inc(UTF8Text); if c=0 then break else if c<=127 then continue else begin extra := UTF8_EXTRABYTES[c]; if UTF8_EXTRA[extra].minimum>$ffff then exit; for i := 1 to extra do begin if byte(UTF8Text^) and $c0<>$80 then exit; // invalid UTF-8 content c := c shl 6+byte(UTF8Text^); inc(UTF8Text); end; dec(c,UTF8_EXTRA[extra].offset); if (c>255) or (fAnsiToWide[c]>255) then exit; // not 8 bit char (like "tm" or such) is marked invalid end; until false; result := true; end; function TSynAnsiFixedWidth.UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; var c: cardinal; begin // first handle trailing 7 bit ASCII chars, by pairs (Sha optimization) if SourceChars>=2 then repeat c := PCardinal(Source)^; if c and $ff80ff80<>0 then break; // break on first non ASCII pair dec(SourceChars,2); inc(Source,2); c := c shr 8 or c; PWord(Dest)^ := c; inc(Dest,2); until SourceChars<2; // use internal lookup tables for fast process of remaining chars for c := 1 to SourceChars shr 2 do begin Dest[0] := AnsiChar(fWideToAnsi[Ord(Source[0])]); Dest[1] := AnsiChar(fWideToAnsi[Ord(Source[1])]); Dest[2] := AnsiChar(fWideToAnsi[Ord(Source[2])]); Dest[3] := AnsiChar(fWideToAnsi[Ord(Source[3])]); inc(Source,4); inc(Dest,4); end; for c := 1 to SourceChars and 3 do begin Dest^ := AnsiChar(fWideToAnsi[Ord(Source^)]); inc(Dest); inc(Source); end; result := Dest; end; function TSynAnsiFixedWidth.UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; var c: cardinal; endSource, endSourceBy4: PUTF8Char; i,extra: integer; label By1, By4, Quit; // ugly but faster begin // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) endSource := Source+SourceChars; endSourceBy4 := endSource-4; if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then repeat By4: c := PCardinal(Source)^; if c and $80808080<>0 then goto By1; // break on first non ASCII quad PCardinal(Dest)^ := c; inc(Source,4); inc(Dest,4); until Source>endSourceBy4; // generic loop, handling one UTF-8 code per iteration if SourceendSource) then break; for i := 1 to extra do begin if byte(Source^) and $c0<>$80 then goto Quit; // invalid UTF-8 content c := c shl 6+byte(Source^); inc(Source); end; dec(c,UTF8_EXTRA[extra].offset); if c>$ffff then Dest^ := '?' else // '?' as in unknown fWideToAnsi[] items Dest^ := AnsiChar(fWideToAnsi[c]); inc(Dest); if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then goto By4; if SourceCP_UTF8 then raise ESynException.CreateUTF8('%.Create(%)',[self,aCodePage]); inherited Create(aCodePage); end; function TSynAnsiUTF8.UnicodeBufferToUTF8(Dest: PAnsiChar; DestChars: Cardinal; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; begin result := Dest+RawUnicodeToUTF8(PUTF8Char(Dest),DestChars,Source,SourceChars, [ccfNoTrailingZero]); end; function TSynAnsiUTF8.UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; begin result := UnicodeBufferToUTF8(Dest,SourceChars,Source,SourceChars); end; function TSynAnsiUTF8.UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString; var tmp: TSynTempBuffer; begin if (Source=nil) or (SourceChars=0) then result := '' else begin tmp.Init(SourceChars*3+1); FastSetStringCP(result,tmp.buf,UnicodeBufferToUTF8(tmp.buf, SourceChars*3,Source,SourceChars)-tmp.buf,fCodePage); tmp.Done; end; end; function TSynAnsiUTF8.UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; begin {$ifdef FPC}Move{$else}MoveFast{$endif}(Source^,Dest^,SourceChars); result := Dest+SourceChars; end; procedure TSynAnsiUTF8.UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal; var result: RawByteString); begin FastSetString(RawUTF8(result),Source,SourceChars); end; function TSynAnsiUTF8.UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; begin result := UTF8; {$ifdef HASCODEPAGE} SetCodePage(result,CP_UTF8,false); {$endif} end; function TSynAnsiUTF8.AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; begin result := AnsiText; {$ifdef HASCODEPAGE} SetCodePage(RawByteString(result),CP_UTF8,false); {$endif} end; function TSynAnsiUTF8.AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; begin FastSetString(Result,Source,SourceChars); end; { TSynAnsiUTF16 } function TSynAnsiUTF16.AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PWideChar; begin {$ifdef FPC}Move{$else}MoveFast{$endif}(Source^,Dest^,SourceChars); result := Pointer(PtrUInt(Dest)+SourceChars); if not NoTrailingZero then result^ := #0; end; const NOTRAILING: array[boolean] of TCharConversionFlags = ([],[ccfNoTrailingZero]); function TSynAnsiUTF16.AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PUTF8Char; begin SourceChars := SourceChars shr 1; // from byte count to WideChar count result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3, PWideChar(Source),SourceChars,NOTRAILING[NoTrailingZero]); end; function TSynAnsiUTF16.AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; begin SetString(result,Source,SourceChars); // byte count end; constructor TSynAnsiUTF16.Create(aCodePage: cardinal); begin if aCodePage<>CP_UTF16 then raise ESynException.CreateUTF8('%.Create(%)',[self,aCodePage]); inherited Create(aCodePage); end; function TSynAnsiUTF16.UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; begin SourceChars := SourceChars shl 1; // from WideChar count to byte count {$ifdef FPC}Move{$else}MoveFast{$endif}(Source^,Dest^,SourceChars); result := Dest+SourceChars; end; function TSynAnsiUTF16.UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; begin result := Dest+UTF8ToWideChar(PWideChar(Dest),Source,SourceChars,true); end; { TSynTempBuffer } procedure TSynTempBuffer.Init(const Source: RawByteString); begin Init(pointer(Source),length(Source)); end; function TSynTempBuffer.Init(Source: PUTF8Char): PUTF8Char; begin Init(Source,StrLen(Source)); result := buf; end; function TSynTempBuffer.Init(SourceLen: integer): pointer; begin Init(nil,SourceLen); result := buf; end; procedure TSynTempBuffer.Init(Source: pointer; SourceLen: integer); begin len := SourceLen; if len<=0 then buf := nil else begin if len<=SizeOf(tmp)-16 then buf := @tmp else GetMem(buf,len+16); // +16 for trailing #0 and for PInteger() parsing if Source<>nil then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(Source^,buf^,len); PPtrInt(PAnsiChar(buf)+len)^ := 0; // init last 4/8 bytes (makes valgrid happy) end; end; end; function TSynTempBuffer.Init: integer; begin buf := @tmp; result := SizeOf(tmp)-16; len := result; end; function TSynTempBuffer.InitRandom(RandomLen: integer; forcegsl: boolean): pointer; begin Init(nil,RandomLen); if RandomLen>0 then FillRandom(buf,(RandomLen shr 2)+1,forcegsl); result := buf; end; function TSynTempBuffer.InitIncreasing(Count, Start: integer): PIntegerArray; begin Init(nil,(Count-Start)*4); FillIncreasing(buf,Start,Count); result := buf; end; function TSynTempBuffer.InitZero(ZeroLen: integer): pointer; begin Init(nil,ZeroLen-16); {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(buf^,ZeroLen,0); result := buf; end; procedure TSynTempBuffer.Done; begin if (buf<>@tmp) and (buf<>nil) then FreeMem(buf); end; procedure TSynTempBuffer.Done(EndBuf: pointer; var Dest: RawUTF8); begin if EndBuf=nil then Dest := '' else FastSetString(Dest,buf,PAnsiChar(EndBuf)-PAnsiChar(buf)); if (buf<>@tmp) and (buf<>nil) then FreeMem(buf); end; { TSynTempWriter } procedure TSynTempWriter.Init(maxsize: integer); begin if maxsize<=0 then maxsize := SizeOf(tmp.tmp)-16; // TSynTempBuffer allocates +16 pos := tmp.Init(maxsize); end; procedure TSynTempWriter.Done; begin tmp.Done; end; function TSynTempWriter.AsBinary: RawByteString; begin FastSetStringCP(result,PAnsiChar(tmp.buf),pos-tmp.buf,CP_RAWBYTESTRING); end; function TSynTempWriter.Position: integer; begin result := pos-tmp.buf; end; procedure TSynTempWriter.wr(const val; len: integer); begin if pos-tmp.buf+len>tmp.len then raise ESynException.CreateUTF8('TSynTempWriter(%) overflow',[tmp.len]); {$ifdef FPC}Move{$else}MoveFast{$endif}(val,pos^,len); inc(pos,len); end; procedure TSynTempWriter.wrb(b: byte); begin wr(b,1); end; procedure TSynTempWriter.wrint(int: integer); begin wr(int,4); end; procedure TSynTempWriter.wrptrint(int: PtrInt); begin wr(int,SizeOf(int)); end; procedure TSynTempWriter.wrptr(ptr: pointer); begin wr(ptr,SizeOf(ptr)); end; procedure TSynTempWriter.wrss(const str: shortstring); begin wr(str,ord(str[0])+1); end; procedure TSynTempWriter.wrw(w: word); begin wr(w,2); end; function TSynTempWriter.wrfillchar(count: integer; value: byte): PAnsiChar; begin if pos-tmp.buf+count>tmp.len then raise ESynException.CreateUTF8('TSynTempWriter(%) overflow',[tmp.len]); {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(pos^,count,value); result := pos; inc(pos,count); end; { TRawUTF8InterningSlot } procedure TRawUTF8InterningSlot.Init; begin Safe.Init; {$ifndef NOVARIANTS} Safe.LockedInt64[0] := 0; {$endif} Values.Init(TypeInfo(TRawUTF8DynArray),Value,HashAnsiString, SortDynArrayAnsiString,crc32c,@Safe.Padding[0].VInteger,false); Values.fHasher := InterningHasher; // consistent with TRawUTF8Interning end; procedure TRawUTF8InterningSlot.Done; begin Safe.Done; end; function TRawUTF8InterningSlot.Count: integer; begin {$ifdef NOVARIANTS} result := Safe.Padding[0].VInteger; {$else} result := Safe.LockedInt64[0]; {$endif} end; procedure TRawUTF8InterningSlot.Unique(var aResult: RawUTF8; const aText: RawUTF8; aTextHash: cardinal); var i: integer; added: boolean; begin EnterCriticalSection(Safe.fSection); try i := Values.FindHashedForAdding(aText,added,aTextHash); if added then begin Value[i] := aText; // copy new value to the pool aResult := aText; end else aResult := Value[i]; // return unified string instance finally LeaveCriticalSection(Safe.fSection); end; end; procedure TRawUTF8InterningSlot.UniqueText(var aText: RawUTF8; aTextHash: cardinal); var i: integer; added: boolean; begin EnterCriticalSection(Safe.fSection); try i := Values.FindHashedForAdding(aText,added,aTextHash); if added then Value[i] := aText else // copy new value to the pool aText := Value[i]; // return unified string instance finally LeaveCriticalSection(Safe.fSection); end; end; procedure TRawUTF8InterningSlot.Clear; begin Safe.Lock; try Values.Clear; Values.Rehash; finally Safe.Unlock; end; end; function TRawUTF8InterningSlot.Clean(aMaxRefCount: integer): integer; var i: integer; s,d: PPtrUInt; // points to RawUTF8 values (bypass COW assignments) begin result := 0; Safe.Lock; try if Safe.Padding[0].VInteger=0 then exit; s := pointer(Value); d := s; for i := 1 to Safe.Padding[0].VInteger do begin {$ifdef FPC} if StringRefCount(PAnsiString(s)^)<=aMaxRefCount then begin Finalize(PRawUTF8(s)^); {$else} if PInteger(s^-8)^<=aMaxRefCount then begin PRawUTF8(s)^ := ''; {$endif FPC} inc(result); end else begin if s<>d then begin d^ := s^; s^ := 0; // avoid GPF end; inc(d); end; inc(s); end; if result>0 then begin Values.SetCount((PtrUInt(d)-PtrUInt(Value))div SizeOf(d^)); Values.ReHash; end; finally Safe.UnLock; end; end; { TRawUTF8Interning } constructor TRawUTF8Interning.Create(aHashTables: integer); var p,i: integer; begin for p := 0 to 9 do if aHashTables=1 shl p then begin SetLength(fPool,aHashTables); fPoolLast := aHashTables-1; for i := 0 to fPoolLast do fPool[i].Init; exit; end; raise ESynException.CreateUTF8('%.Create(%) not allowed',[self,aHashTables]); end; destructor TRawUTF8Interning.Destroy; var i: integer; begin for i := 0 to fPoolLast do fPool[i].Done; inherited Destroy; end; procedure TRawUTF8Interning.Clear; var i: integer; begin if self<>nil then for i := 0 to fPoolLast do fPool[i].Clear; end; function TRawUTF8Interning.Clean(aMaxRefCount: integer): integer; var i: integer; begin result := 0; if self<>nil then for i := 0 to fPoolLast do inc(result,fPool[i].Clean(aMaxRefCount)); end; function TRawUTF8Interning.Count: integer; var i: integer; begin result := 0; if self<>nil then for i := 0 to fPoolLast do inc(result,fPool[i].Count); end; procedure TRawUTF8Interning.Unique(var aResult: RawUTF8; const aText: RawUTF8); var hash: cardinal; begin if aText='' then aResult := '' else if self=nil then aResult := aText else begin hash := InterningHasher(0,pointer(aText),length(aText)); // = fPool[].Values.HashElement fPool[hash and fPoolLast].Unique(aResult,aText,hash); end; end; procedure TRawUTF8Interning.UniqueText(var aText: RawUTF8); var hash: cardinal; begin if (self<>nil) and (aText<>'') then begin hash := InterningHasher(0,pointer(aText),length(aText)); // = fPool[].Values.HashElement fPool[hash and fPoolLast].UniqueText(aText,hash); end; end; function TRawUTF8Interning.Unique(const aText: RawUTF8): RawUTF8; var hash: cardinal; begin if aText='' then result := '' else if self=nil then result := aText else begin hash := InterningHasher(0,pointer(aText),length(aText)); // = fPool[].Values.HashElement fPool[hash and fPoolLast].Unique(result,aText,hash); end; end; function TRawUTF8Interning.Unique(aText: PUTF8Char; aTextLen: integer): RawUTF8; begin FastSetString(result,aText,aTextLen); UniqueText(result); end; procedure TRawUTF8Interning.Unique(var aResult: RawUTF8; aText: PUTF8Char; aTextLen: integer); begin FastSetString(aResult,aText,aTextLen); UniqueText(aResult); end; {$ifndef NOVARIANTS} procedure TRawUTF8Interning.UniqueVariant(var aResult: variant; const aText: RawUTF8); begin {$ifndef FPC}if TVarData(aResult).VType and VTYPE_STATIC<>0 then{$endif} VarClear(aResult); TVarData(aResult).VType := varString; TVarData(aResult).VAny := nil; Unique(RawUTF8(TVarData(aResult).VAny),aText); end; procedure TRawUTF8Interning.UniqueVariantString(var aResult: variant; const aText: string); var tmp: RawUTF8; begin StringToUTF8(aText,tmp); UniqueVariant(aResult,tmp); end; procedure TRawUTF8Interning.UniqueVariant(var aResult: variant; aText: PUTF8Char; aTextLen: integer; aAllowVarDouble: boolean); var tmp: RawUTF8; begin if not GetNumericVariantFromJSON(aText,TVarData(aResult),aAllowVarDouble) then begin FastSetString(tmp,aText,aTextLen); UniqueVariant(aResult,tmp); end; end; procedure TRawUTF8Interning.UniqueVariant(var aResult: variant); begin with TVarData(aresult) do if VType=varString then UniqueText(RawUTF8(VString)) else if VType=varVariant or varByRef then UniqueVariant(PVariant(VPointer)^) else if VType=varString or varByRef then UniqueText(PRawUTF8(VPointer)^); end; {$endif NOVARIANTS} function WideCharToUtf8(Dest: PUTF8Char; aWideChar: PtrUInt): integer; begin if aWideChar<=$7F then begin Dest^ := AnsiChar(aWideChar); result := 1; end else if aWideChar>$7ff then begin Dest[0] := AnsiChar($E0 or (aWideChar shr 12)); Dest[1] := AnsiChar($80 or ((aWideChar shr 6) and $3F)); Dest[2] := AnsiChar($80 or (aWideChar and $3F)); result := 3; end else begin Dest[0] := AnsiChar($C0 or (aWideChar shr 6)); Dest[1] := AnsiChar($80 or (aWideChar and $3F)); result := 2; end; end; function UTF16CharToUtf8(Dest: PUTF8Char; var Source: PWord): integer; var c: cardinal; j: integer; begin c := Source^; inc(Source); case c of 0..$7f: begin Dest^ := AnsiChar(c); result := 1; exit; end; UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX: begin c := ((c-$D7C0)shl 10)+(Source^ xor UTF16_LOSURROGATE_MIN); inc(Source); end; UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX: begin c := ((cardinal(Source^)-$D7C0)shl 10)+(c xor UTF16_LOSURROGATE_MIN); inc(Source); end; end; // now c is the UTF-32/UCS4 code point case c of 0..$7ff: result := 2; $800..$ffff: result := 3; $10000..$1FFFFF: result := 4; $200000..$3FFFFFF: result := 5; else result := 6; end; for j := result-1 downto 1 do begin Dest[j] := AnsiChar((c and $3f)+$80); c := c shr 6; end; Dest^ := AnsiChar(Byte(c) or UTF8_FIRSTBYTE[result]); end; function UCS4ToUTF8(ucs4: cardinal; Dest: PUTF8Char): integer; var j: integer; begin case ucs4 of 0..$7f: begin Dest^ := AnsiChar(ucs4); result := 1; exit; end; $80..$7ff: result := 2; $800..$ffff: result := 3; $10000..$1FFFFF: result := 4; $200000..$3FFFFFF: result := 5; else result := 6; end; for j := result-1 downto 1 do begin Dest[j] := AnsiChar((ucs4 and $3f)+$80); ucs4 := ucs4 shr 6; end; Dest^ := AnsiChar(Byte(ucs4) or UTF8_FIRSTBYTE[result]); end; procedure AnyAnsiToUTF8(const s: RawByteString; var result: RawUTF8); {$ifdef HASCODEPAGE}var CodePage: Cardinal;{$endif} begin if s='' then result := '' else begin {$ifdef HASCODEPAGE} CodePage := StringCodePage(s); if (CodePage=CP_UTF8) or (CodePage=CP_RAWBYTESTRING) then result := s else result := TSynAnsiConvert.Engine(CodePage). {$else} result := CurrentAnsiConvert. {$endif} AnsiBufferToRawUTF8(pointer(s),length(s)); end; end; function AnyAnsiToUTF8(const s: RawByteString): RawUTF8; begin AnyAnsiToUTF8(s,result); end; function WinAnsiBufferToUtf8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal): PUTF8Char; begin result := WinAnsiConvert.AnsiBufferToUTF8(Dest,Source,SourceChars); end; function ShortStringToUTF8(const source: ShortString): RawUTF8; begin result := WinAnsiConvert.AnsiBufferToRawUTF8(@source[1],ord(source[0])); end; procedure WinAnsiToUnicodeBuffer(const S: WinAnsiString; Dest: PWordArray; DestLen: integer); var L: PtrInt; begin L := length(S); if L<>0 then begin if L>=DestLen then L := DestLen-1; // truncate to avoid buffer overflow WinAnsiConvert.AnsiBufferToUnicode(PWideChar(Dest),pointer(S),L); // include last #0 end else Dest^[0] := 0; end; function WinAnsiToRawUnicode(const S: WinAnsiString): RawUnicode; begin result := WinAnsiConvert.AnsiToRawUnicode(S); end; function WinAnsiToUtf8(const S: WinAnsiString): RawUTF8; begin result := WinAnsiConvert.AnsiBufferToRawUTF8(pointer(S),length(s)); end; function WinAnsiToUtf8(WinAnsi: PAnsiChar; WinAnsiLen: integer): RawUTF8; begin result := WinAnsiConvert.AnsiBufferToRawUTF8(WinAnsi,WinAnsiLen); end; function WideCharToWinAnsiChar(wc: cardinal): AnsiChar; begin wc := WinAnsiConvert.WideCharToAnsiChar(wc); if integer(wc)=-1 then result := '?' else result := AnsiChar(wc); end; function WideCharToWinAnsi(wc: cardinal): integer; begin result := WinAnsiConvert.WideCharToAnsiChar(wc); end; function IsWinAnsi(WideText: PWideChar; Length: integer): boolean; begin result := WinAnsiConvert.IsValidAnsi(WideText,Length); end; function IsAnsiCompatible(PC: PAnsiChar): boolean; begin result := false; if PC<>nil then while true do if PC^=#0 then break else if PC^<=#127 then inc(PC) else // 7 bits chars are always OK, whatever codepage/charset is used exit; result := true; end; function IsAnsiCompatible(PC: PAnsiChar; Len: integer): boolean; var i: integer; begin result := false; if PC<>nil then begin for i := 1 to Len shr 2 do if PCardinal(PC)^ and $80808080<>0 then exit else inc(PC,4); for i := 0 to (Len and 3)-1 do if PC[i]>=#127 then exit; end; result := true; end; function IsAnsiCompatible(const Text: RawByteString): boolean; begin result := IsAnsiCompatible(PAnsiChar(pointer(Text)),length(Text)); end; function IsAnsiCompatible(PW: PWideChar): boolean; begin result := false; if PW<>nil then while true do if ord(PW^)=0 then break else if ord(PW^)<=127 then inc(PW) else // 7 bits chars are always OK, whatever codepage/charset is used exit; result := true; end; function IsAnsiCompatible(PW: PWideChar; Len: integer): boolean; var i: integer; begin result := false; if PW<>nil then for i := 0 to Len-1 do if ord(PW[i])>127 then exit; result := true; end; function IsWinAnsi(WideText: PWideChar): boolean; begin result := WinAnsiConvert.IsValidAnsi(WideText); end; function IsWinAnsiU(UTF8Text: PUTF8Char): boolean; begin result := WinAnsiConvert.IsValidAnsiU(UTF8Text); end; function IsWinAnsiU8Bit(UTF8Text: PUTF8Char): boolean; begin result := WinAnsiConvert.IsValidAnsiU8Bit(UTF8Text); end; function UTF8ToWinPChar(dest: PAnsiChar; source: PUTF8Char; count: integer): integer; begin result := WinAnsiConvert.UTF8BufferToAnsi(dest,source,count)-dest; end; function ShortStringToAnsi7String(const source: shortstring): RawByteString; begin FastSetString(RawUTF8(result),@source[1],ord(source[0])); end; procedure ShortStringToAnsi7String(const source: shortstring; var result: RawUTF8); begin FastSetString(result,@source[1],ord(source[0])); end; procedure UTF8ToShortString(var dest: shortstring; source: PUTF8Char); var c: cardinal; len,extra,i: integer; begin len := 0; if source<>nil then repeat c := byte(source^); inc(source); if c=0 then break else if c<=127 then begin inc(len); dest[len] := AnsiChar(c); if len<253 then continue else break; end else begin extra := UTF8_EXTRABYTES[c]; if extra=0 then break; // invalid leading byte for i := 1 to extra do begin if byte(source^) and $c0<>$80 then begin dest[0] := AnsiChar(len); exit; // invalid UTF-8 content end; c := c shl 6+byte(source^); inc(Source); end; dec(c,UTF8_EXTRA[extra].offset); // #256.. -> slower but accurate conversion inc(len); if c>$ffff then dest[len] := '?' else dest[len] := AnsiChar(WinAnsiConvert.fWideToAnsi[c]); if len<253 then continue else break; end; until false; dest[0] := AnsiChar(len); end; function Utf8ToWinAnsi(const S: RawUTF8): WinAnsiString; begin result := WinAnsiConvert.UTF8ToAnsi(S); end; function Utf8ToWinAnsi(P: PUTF8Char): WinAnsiString; begin result := WinAnsiConvert.UTF8ToAnsi(P); end; procedure Utf8ToRawUTF8(P: PUTF8Char; var result: RawUTF8); begin // fast and Delphi 2009+ ready FastSetString(result,P,StrLen(P)); end; function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; MaxDestChars, sourceBytes: PtrInt; NoTrailingZero: boolean): PtrInt; // faster than System.Utf8ToUnicode() var c: cardinal; begd: PWideChar; endSource: PUTF8Char; endDest: PWideChar; i,extra: integer; label Quit, NoSource; begin result := 0; if dest=nil then exit; if source=nil then goto NoSource; if sourceBytes=0 then begin if source^=#0 then goto NoSource; sourceBytes := StrLen(source); end; endSource := source+sourceBytes; endDest := dest+MaxDestChars; begd := dest; repeat c := byte(source^); inc(source); if c<=127 then begin PWord(dest)^ := c; // much faster than dest^ := WideChar(c) for FPC inc(dest); if (sourceendSource) then break; for i := 1 to extra do begin if byte(Source^) and $c0<>$80 then goto Quit; // invalid input content c := c shl 6+byte(Source^); inc(Source); end; with UTF8_EXTRA[extra] do begin dec(c,offset); if c=endsource) or (dest>=endDest) then break; until false; Quit: result := PtrUInt(dest)-PtrUInt(begd); // dest-begd return byte length NoSource: if not NoTrailingZero then dest^ := #0; // always append a WideChar(0) to the end of the buffer end; function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; sourceBytes: PtrInt; NoTrailingZero: boolean): PtrInt; // faster than System.UTF8Decode() var c: cardinal; begd: PWideChar; endSource, endSourceBy4: PUTF8Char; i,extra: PtrInt; label Quit, NoSource, By1, By4; begin result := 0; if dest=nil then exit; if source=nil then goto NoSource; if sourceBytes=0 then begin if source^=#0 then goto NoSource; sourceBytes := StrLen(source); end; begd := dest; endSource := Source+SourceBytes; endSourceBy4 := endSource-4; if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then repeat // handle 7 bit ASCII chars, by quad (Sha optimization) By4: c := PCardinal(Source)^; if c and $80808080<>0 then goto By1; // break on first non ASCII quad inc(Source,4); PCardinal(dest)^ := (c shl 8 or (c and $FF)) and $00ff00ff; c := c shr 16; PCardinal(dest+2)^ := (c shl 8 or c) and $00ff00ff; inc(dest,4); until Source>EndSourceBy4; if SourceendSource) then break; for i := 1 to extra do begin if byte(Source^) and $c0<>$80 then goto Quit; // invalid input content c := c shl 6+byte(Source^); inc(Source); end; with UTF8_EXTRA[extra] do begin dec(c,offset); if c=endSource then break; until false; Quit: result := PtrUInt(dest)-PtrUInt(begd); // dest-begd return char length NoSource: if not NoTrailingZero then 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; begin result := false; if source<>nil then repeat c := byte(source^); inc(source); if c=0 then break else if c<32 then exit else // disallow #1..#31 control char if c and $80<>0 then begin extra := UTF8_EXTRABYTES[c]; if extra=0 then exit else // invalid leading byte for i := 1 to extra do if byte(source^) and $c0<>$80 then // invalid UTF-8 encoding exit else inc(source); end; until false; result := true; end; function IsValidUTF8WithoutControlChars(const source: RawUTF8): Boolean; var s, extra, i, len: integer; c: cardinal; begin result := false; s := 1; len := length(source); while s<=len do begin c := byte(source[s]); inc(s); if c<32 then exit else // disallow #0..#31 control char if c and $80<>0 then begin extra := UTF8_EXTRABYTES[c]; if extra=0 then exit else // invalid leading byte for i := 1 to extra do if byte(source[s]) and $c0<>$80 then // reached #0 or invalid UTF-8 exit else inc(s); end; end; result := true; end; function Utf8ToUnicodeLength(source: PUTF8Char): PtrUInt; var c: PtrUInt; extra,i: integer; begin result := 0; if source<>nil then repeat c := byte(source^); inc(source); if c=0 then break else if c<=127 then inc(result) else begin extra := UTF8_EXTRABYTES[c]; if extra=0 then exit else // invalid leading byte if extra>=UTF8_EXTRA_SURROGATE then inc(result,2) else inc(result); for i := 1 to extra do // inc(source,extra) is faster but not safe if byte(source^) and $c0<>$80 then exit else inc(source); // check valid UTF-8 content end; until false; end; function Utf8TruncateToUnicodeLength(var text: RawUTF8; maxUTF16: integer): boolean; var c: PtrUInt; extra,i: integer; source: PUTF8Char; begin source := pointer(text); if (source<>nil) and (cardinal(maxUtf16)=UTF8_EXTRA_SURROGATE then dec(maxUTF16,2) else dec(maxUTF16); for i := 1 to extra do // inc(source,extra) is faster but not safe if byte(source^) and $c0<>$80 then break else inc(source); // check valid UTF-8 content end; until false; result := false; end; function Utf8TruncateToLength(var text: RawUTF8; maxBytes: cardinal): boolean; begin if cardinal(length(text))0) and (ord(text[maxBytes]) and $c0=$80) do dec(maxBytes); if (maxBytes>0) and (ord(text[maxBytes]) and $80<>0) then dec(maxBytes); SetLength(text,maxBytes); result := true; end; function Utf8TruncatedLength(const text: RawUTF8; maxBytes: cardinal): integer; begin result := length(text); if cardinal(result)0) and (ord(text[result]) and $c0=$80) do dec(result); if (result>0) and (ord(text[result]) and $80<>0) then dec(result); end; function Utf8TruncatedLength(text: PAnsiChar; textlen,maxBytes: cardinal): integer; begin if textlen0) and (ord(text[result]) and $c0=$80) do dec(result); if (result>0) and (ord(text[result]) and $80<>0) then dec(result); end; function Utf8FirstLineToUnicodeLength(source: PUTF8Char): PtrInt; var c: PtrUInt; extra: Integer; begin result := 0; if source<>nil then repeat c := byte(source^); inc(source); if c in [0,10,13] then break else // #0, #10 or #13 stop the count if c<=127 then inc(result) else begin extra := UTF8_EXTRABYTES[c]; if extra=0 then exit else // invalid leading byte if extra>=UTF8_EXTRA_SURROGATE then inc(result,2) else inc(result); inc(source,extra); // a bit less safe, but faster end; until false; end; function Utf8DecodeToRawUnicode(P: PUTF8Char; L: integer): RawUnicode; var short: array[0..256*6] of WideChar; U: PWideChar; begin result := ''; // somewhat faster if result is freed before any SetLength() if L=0 then L := StrLen(P); if L=0 then exit; // +1 below is for #0 ending -> true WideChar(#0) ending if Lnil then DestLen^ := L; end; function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; var Dest: RawUnicode): integer; begin Dest := ''; // somewhat faster if Dest is freed before any SetLength() if S='' then begin result := 0; exit; end; result := length(S); SetLength(Dest,result*2+2); result := UTF8ToWideChar(pointer(Dest),Pointer(S),result); end; function RawUnicodeToUtf8(Dest: PUTF8Char; DestLen: PtrInt; Source: PWideChar; SourceLen: PtrInt; Flags: TCharConversionFlags): PtrInt; var c: Cardinal; Tail: PWideChar; i,j: integer; label unmatch; begin result := PtrInt(Dest); inc(DestLen,PtrInt(Dest)); if (Source<>nil) and (Dest<>nil) then begin // first handle 7 bit ASCII WideChars, by pairs (Sha optimization) SourceLen := SourceLen*2+PtrInt(PtrUInt(Source)); Tail := PWideChar(SourceLen)-2; if (PtrInt(PtrUInt(Dest))0 then break; // break on first non ASCII pair inc(Source,2); c := c shr 8 or c; PWord(Dest)^ := c; inc(Dest,2); until (Source>Tail) or (PtrInt(PtrUInt(Dest))>=DestLen); // generic loop, handling one UCS4 char per iteration if (PtrInt(PtrUInt(Dest))=SourceLen) or ((cardinal(Source^)UTF16_LOSURROGATE_MAX)) then begin unmatch: if (PtrInt(PtrUInt(@Dest[3]))>DestLen) or not (ccfReplacementCharacterForUnmatchedSurrogate in Flags) then break; PWord(Dest)^ := $BFEF; Dest[2] := AnsiChar($BD); inc(Dest,3); if (PtrInt(PtrUInt(Dest))=SourceLen) or ((cardinal(Source^)UTF16_HISURROGATE_MAX)) then goto unmatch else begin c := ((cardinal(Source^)-$D7C0)shl 10)+(c xor UTF16_LOSURROGATE_MIN); inc(Source); end; end; // now c is the UTF-32/UCS4 code point case c of 0..$7ff: i := 2; $800..$ffff: i := 3; $10000..$1FFFFF: i := 4; $200000..$3FFFFFF: i := 5; else i := 6; end; if PtrInt(PtrUInt(Dest))+i>DestLen then break; for j := i-1 downto 1 do begin Dest[j] := AnsiChar((c and $3f)+$80); c := c shr 6; end; Dest^ := AnsiChar(Byte(c) or UTF8_FIRSTBYTE[i]); inc(Dest,i); if (PtrInt(PtrUInt(Dest)) direct assign end; {$endif} function Ansi7ToString(Text: PWinAnsiChar; Len: integer): string; begin {$ifdef UNICODE} Ansi7ToString(Text,Len,result); {$else} SetString(result,PAnsiChar(Text),Len); {$endif} end; procedure Ansi7ToString(Text: PWinAnsiChar; Len: integer; var result: string); {$ifdef UNICODE} var i: integer; begin SetString(result,nil,Len); for i := 0 to Len-1 do PWordArray(result)[i] := PByteArray(Text)[i]; // no conversion for 7 bit Ansi end; {$else} begin SetString(result,PAnsiChar(Text),Len); end; {$endif} function StringToAnsi7(const Text: string): RawByteString; {$ifdef UNICODE} var i: integer; begin SetString(result,nil,length(Text)); for i := 0 to length(Text)-1 do PByteArray(result)[i] := PWordArray(Text)[i]; // no conversion for 7 bit Ansi end; {$else} begin result := Text; // if we are SURE this text is 7 bit Ansi -> direct assign end; {$endif} function StringToWinAnsi(const Text: string): WinAnsiString; begin {$ifdef UNICODE} result := RawUnicodeToWinAnsi(Pointer(Text),length(Text)); {$else} result := WinAnsiConvert.AnsiToAnsi(CurrentAnsiConvert,Text); {$endif} end; function StringBufferToUtf8(Dest: PUTF8Char; Source: PChar; SourceChars: PtrInt): PUTF8Char; begin {$ifdef UNICODE} result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3,PWideChar(Source),SourceChars,[]); {$else} result := CurrentAnsiConvert.AnsiBufferToUTF8(Dest,Source,SourceChars); {$endif} end; procedure StringBufferToUtf8(Source: PChar; out result: RawUTF8); overload; begin {$ifdef UNICODE} RawUnicodeToUtf8(Source,StrLenW(Source),result); {$else} result := CurrentAnsiConvert.AnsiBufferToRawUTF8(Source,StrLen(Source)); {$endif} end; function StringToUTF8(const Text: string): RawUTF8; begin {$ifdef UNICODE} RawUnicodeToUtf8(pointer(Text),length(Text),result); {$else} result := CurrentAnsiConvert.AnsiToUTF8(Text); {$endif} end; procedure StringToUTF8(Text: PChar; TextLen: integer; var result: RawUTF8); begin {$ifdef UNICODE} RawUnicodeToUtf8(Text,TextLen,result); {$else} result := CurrentAnsiConvert.AnsiBufferToRawUTF8(Text, TextLen); {$endif} end; procedure StringToUTF8(const Text: string; var result: RawUTF8); begin {$ifdef UNICODE} RawUnicodeToUtf8(pointer(Text),length(Text),result); {$else} result := CurrentAnsiConvert.AnsiToUTF8(Text); {$endif} end; function ToUTF8(const Text: string): RawUTF8; begin {$ifdef UNICODE} RawUnicodeToUtf8(pointer(Text),length(Text),result); {$else} result := CurrentAnsiConvert.AnsiToUTF8(Text); {$endif} end; function ToUTF8(const Ansi7Text: ShortString): RawUTF8; begin FastSetString(result,@Ansi7Text[1],ord(Ansi7Text[0])); end; function ToUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; begin FastSetString(result,nil,36); GUIDToText(pointer(result),@guid); end; procedure Int32ToUTF8(Value: PtrInt; var result: RawUTF8); var tmp: array[0..23] of AnsiChar; P: PAnsiChar; begin if PtrUInt(Value)<=high(SmallUInt32UTF8) then result := SmallUInt32UTF8[Value] else begin P := StrInt32(@tmp[23],Value); FastSetString(result,P,@tmp[23]-P); end; end; procedure Int64ToUtf8(Value: Int64; var result: RawUTF8); var tmp: array[0..23] of AnsiChar; P: PAnsiChar; begin {$ifdef CPU64} if PtrUInt(Value)<=high(SmallUInt32UTF8) then {$else} // Int64Rec gives compiler internal error C4963 if (PCardinalArray(@Value)^[0]<=high(SmallUInt32UTF8)) and (PCardinalArray(@Value)^[1]=0) then {$endif CPU64} result := SmallUInt32UTF8[Value] else begin P := StrInt64(@tmp[23],Value); FastSetString(result,P,@tmp[23]-P); end; end; procedure UInt64ToUtf8(Value: QWord; var result: RawUTF8); var tmp: array[0..23] of AnsiChar; P: PAnsiChar; begin {$ifdef CPU64} if Value<=high(SmallUInt32UTF8) then {$else} // Int64Rec gives compiler internal error C4963 if (PCardinalArray(@Value)^[0]<=high(SmallUInt32UTF8)) and (PCardinalArray(@Value)^[1]=0) then {$endif CPU64} result := SmallUInt32UTF8[Value] else begin P := StrUInt64(@tmp[23],Value); FastSetString(result,P,@tmp[23]-P); end; end; function VarRecAsChar(const V: TVarRec): integer; begin case V.VType of vtChar: result := ord(V.VChar); vtWideChar: result := ord(V.VWideChar); else result := 0; end; end; function VarRecToInt64(const V: TVarRec; out value: Int64): boolean; begin case V.VType of vtInteger: value := V.VInteger; vtInt64 {$ifdef FPC}, vtQWord{$endif}: value := V.VInt64^; vtBoolean: if V.VBoolean then value := 1 else value := 0; // normalize {$ifndef NOVARIANTS} vtVariant: value := V.VVariant^; {$endif} else begin result := false; exit; end; end; result := true; end; function VarRecToDouble(const V: TVarRec; out value: double): boolean; begin case V.VType of vtInteger: value := V.VInteger; vtInt64: value := V.VInt64^; {$ifdef FPC} vtQWord: value := V.VQWord^; {$endif} vtBoolean: if V.VBoolean then value := 1 else value := 0; // normalize vtExtended: value := V.VExtended^; vtCurrency: value := V.VCurrency^; {$ifndef NOVARIANTS} vtVariant: value := V.VVariant^; {$endif} else begin result := false; exit; end; end; result := true; end; function VarRecToTempUTF8(const V: TVarRec; var Res: TTempUTF8): integer; {$ifndef NOVARIANTS} var v64: Int64; isString: boolean; {$endif} label smlu32; begin Res.TempRawUTF8 := nil; // avoid GPF case V.VType of vtString: begin Res.Text := @V.VString^[1]; Res.Len := ord(V.VString^[0]); result := Res.Len; exit; end; vtAnsiString: begin // expect UTF-8 content Res.Text := pointer(V.VAnsiString); Res.Len := length(RawUTF8(V.VAnsiString)); result := Res.Len; exit; end; {$ifdef HASVARUSTRING} vtUnicodeString: RawUnicodeToUtf8(V.VPWideChar,length(UnicodeString(V.VUnicodeString)),RawUTF8(Res.TempRawUTF8)); {$endif} vtWideString: RawUnicodeToUtf8(V.VPWideChar,length(WideString(V.VWideString)),RawUTF8(Res.TempRawUTF8)); vtPChar: begin // expect UTF-8 content Res.Text := V.VPointer; Res.Len := StrLen(V.VPointer); result := Res.Len; exit; end; vtChar: begin Res.Temp[0] := V.VChar; // V may be on transient stack (alf: FPC) Res.Text := @Res.Temp; Res.Len := 1; result := 1; exit; end; vtPWideChar: RawUnicodeToUtf8(V.VPWideChar,StrLenW(V.VPWideChar),RawUTF8(Res.TempRawUTF8)); vtWideChar: RawUnicodeToUtf8(@V.VWideChar,1,RawUTF8(Res.TempRawUTF8)); vtBoolean: begin if V.VBoolean then // normalize Res.Text := pointer(SmallUInt32UTF8[1]) else Res.Text := pointer(SmallUInt32UTF8[0]); Res.Len := 1; result := 1; exit; end; vtInteger: begin result := V.VInteger; if cardinal(result)<=high(SmallUInt32UTF8) then begin smlu32: Res.Text := pointer(SmallUInt32UTF8[result]); Res.Len := {$ifdef FPC}_LStrLenP(Res.Text){$else}PInteger(Res.Text-4)^{$endif}; end else begin Res.Text := PUTF8Char(StrInt32(@Res.Temp[23],result)); Res.Len := @Res.Temp[23]-Res.Text; end; result := Res.Len; exit; end; vtInt64: if (PCardinalArray(V.VInt64)^[0]<=high(SmallUInt32UTF8)) and (PCardinalArray(V.VInt64)^[1]=0) then begin result := V.VInt64^; goto smlu32; end else begin Res.Text := PUTF8Char(StrInt64(@Res.Temp[23],V.VInt64^)); Res.Len := @Res.Temp[23]-Res.Text; result := Res.Len; exit; end; {$ifdef FPC} vtQWord: if V.VQWord^<=high(SmallUInt32UTF8) then begin result := V.VQWord^; goto smlu32; end else begin Res.Text := PUTF8Char(StrUInt64(@Res.Temp[23],V.VQWord^)); Res.Len := @Res.Temp[23]-Res.Text; result := Res.Len; exit; end; {$endif} vtCurrency: begin Res.Text := @Res.Temp; Res.Len := Curr64ToPChar(V.VInt64^,Res.Temp); result := Res.Len; exit; end; vtExtended: ExtendedToStr(V.VExtended^,DOUBLE_PRECISION,RawUTF8(Res.TempRawUTF8)); vtPointer,vtInterface: begin Res.Text := @Res.Temp; Res.Len := SizeOf(pointer)*2; BinToHexDisplayLower(V.VPointer,@Res.Temp,SizeOf(Pointer)); result := SizeOf(pointer)*2; exit; end; vtClass: begin if V.VClass<>nil then begin Res.Text := PPUTF8Char(PtrInt(PtrUInt(V.VClass))+vmtClassName)^+1; Res.Len := ord(Res.Text[-1]); end else Res.Len := 0; result := Res.Len; exit; end; vtObject: begin if V.VObject<>nil then begin Res.Text := PPUTF8Char(PPtrInt(V.VObject)^+vmtClassName)^+1; Res.Len := ord(Res.Text[-1]); end else Res.Len := 0; result := Res.Len; exit; end; {$ifndef NOVARIANTS} vtVariant: if VariantToInt64(V.VVariant^,v64) then if (PCardinalArray(@v64)^[0]<=high(SmallUInt32UTF8)) and (PCardinalArray(@v64)^[1]=0) then begin result := v64; goto smlu32; end else begin Res.Text := PUTF8Char(StrInt64(@Res.Temp[23],v64)); Res.Len := @Res.Temp[23]-Res.Text; result := Res.Len; exit; end else VariantToUTF8(V.VVariant^,RawUTF8(Res.TempRawUTF8),isString); {$endif} else begin Res.Len := 0; result := 0; exit; end; end; Res.Text := Res.TempRawUTF8; Res.Len := length(RawUTF8(Res.TempRawUTF8)); result := Res.Len; end; procedure VarRecToUTF8(const V: TVarRec; var result: RawUTF8; wasString: PBoolean=nil); var isString: boolean; begin isString := not (V.VType in [ vtBoolean,vtInteger,vtInt64{$ifdef FPC},vtQWord{$endif},vtCurrency,vtExtended]); with V do case V.VType of vtString: FastSetString(result,@VString^[1],ord(VString^[0])); vtAnsiString: result := RawUTF8(VAnsiString); // expect UTF-8 content {$ifdef HASVARUSTRING} vtUnicodeString: result := UnicodeStringToUtf8(UnicodeString(VUnicodeString)); {$endif} vtWideString: RawUnicodeToUtf8(VWideString,length(WideString(VWideString)),result); vtPChar: FastSetString(result,VPChar,StrLen(VPChar)); vtChar: FastSetString(result,PAnsiChar(@VChar),1); vtPWideChar: RawUnicodeToUtf8(VPWideChar,StrLenW(VPWideChar),result); vtWideChar: RawUnicodeToUtf8(@VWideChar,1,result); vtBoolean: if VBoolean then // normalize result := SmallUInt32UTF8[1] else result := SmallUInt32UTF8[0]; vtInteger: Int32ToUtf8(VInteger,result); vtInt64: Int64ToUtf8(VInt64^,result); {$ifdef FPC} vtQWord: UInt64ToUtf8(VQWord^,result); {$endif} vtCurrency: Curr64ToStr(VInt64^,result); vtExtended: ExtendedToStr(VExtended^,DOUBLE_PRECISION,result); vtPointer: PointerToHex(VPointer,result); vtClass: if VClass<>nil then ToText(VClass,result) else result := ''; vtObject: if VObject<>nil then ToText(PClass(VObject)^,result) else result := ''; vtInterface: {$ifdef HASINTERFACEASTOBJECT} if VInterface<>nil then ToText((IInterface(VInterface) as TObject).ClassType,result) else result := ''; {$else} PointerToHex(VInterface,result); {$endif} {$ifndef NOVARIANTS} vtVariant: VariantToUTF8(VVariant^,result,isString); {$endif} else begin isString := false; result := ''; end; end; if wasString<>nil then wasString^ := isString; end; function VarRecToUTF8IsString(const V: TVarRec; var value: RawUTF8): boolean; begin VarRecToUTF8(V,value,@result); end; procedure VarRecToInlineValue(const V: TVarRec; var result: RawUTF8); var wasString: boolean; begin VarRecToUTF8(V,result,@wasString); if wasString then result := QuotedStr(pointer(result),'"'); end; {$ifdef UNICODE} function StringToRawUnicode(const S: string): RawUnicode; begin SetString(result,PAnsiChar(pointer(S)),length(S)*2+1); // +1 for last wide #0 end; {$else} function StringToRawUnicode(const S: string): RawUnicode; begin result := CurrentAnsiConvert.AnsiToRawUnicode(S); end; {$endif} {$ifdef UNICODE} function StringToSynUnicode(const S: string): SynUnicode; begin result := S; end; {$else} function StringToSynUnicode(const S: string): SynUnicode; begin result := CurrentAnsiConvert.AnsiToUnicodeString(pointer(S),length(S)); end; {$endif} {$ifdef UNICODE} function StringToRawUnicode(P: PChar; L: integer): RawUnicode; begin SetString(result,PAnsiChar(P),L*2+1); // +1 for last wide #0 end; {$else} function StringToRawUnicode(P: PChar; L: integer): RawUnicode; begin result := CurrentAnsiConvert.AnsiToRawUnicode(P,L); end; {$endif} {$ifdef UNICODE} function RawUnicodeToString(P: PWideChar; L: integer): string; begin SetString(result,P,L); end; {$else} function RawUnicodeToString(P: PWideChar; L: integer): string; begin result := CurrentAnsiConvert.UnicodeBufferToAnsi(P,L); end; {$endif} {$ifdef UNICODE} procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); begin SetString(result,P,L); end; {$else} procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); begin result := CurrentAnsiConvert.UnicodeBufferToAnsi(P,L); end; {$endif} {$ifdef UNICODE} function RawUnicodeToString(const U: RawUnicode): string; begin // uses StrLenW() and not length(U) to handle case when was used as buffer SetString(result,PWideChar(pointer(U)),StrLenW(Pointer(U))); end; {$else} function RawUnicodeToString(const U: RawUnicode): string; begin // uses StrLenW() and not length(U) to handle case when was used as buffer result := CurrentAnsiConvert.UnicodeBufferToAnsi(Pointer(U),StrLenW(Pointer(U))); end; {$endif} {$ifdef UNICODE} function SynUnicodeToString(const U: SynUnicode): string; begin result := U; end; {$else} function SynUnicodeToString(const U: SynUnicode): string; begin result := CurrentAnsiConvert.UnicodeBufferToAnsi(Pointer(U),length(U)); end; {$endif} {$ifdef UNICODE} function UTF8DecodeToString(P: PUTF8Char; L: integer): string; begin UTF8DecodeToUnicodeString(P,L,result); end; {$else} function UTF8DecodeToString(P: PUTF8Char; L: integer): string; begin CurrentAnsiConvert.UTF8BufferToAnsi(P,L,RawByteString(result)); end; {$endif} {$ifdef UNICODE} procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string); begin UTF8DecodeToUnicodeString(P,L,result); end; {$else} procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string); begin CurrentAnsiConvert.UTF8BufferToAnsi(P,L,RawByteString(result)); end; {$endif} {$ifdef UNICODE} function UTF8ToString(const Text: RawUTF8): string; begin UTF8DecodeToUnicodeString(pointer(Text),length(Text),result); end; {$else} function UTF8ToString(const Text: RawUTF8): string; begin CurrentAnsiConvert.UTF8BufferToAnsi(pointer(Text),length(Text),RawByteString(result)); end; {$endif} function UTF8ToWideString(const Text: RawUTF8): WideString; begin {$ifdef FPC} Finalize(result); {$endif} UTF8ToWideString(Text,result); end; procedure UTF8ToWideString(const Text: RawUTF8; var result: WideString); begin UTF8ToWideString(pointer(Text),Length(Text),result); end; procedure UTF8ToWideString(Text: PUTF8Char; Len: integer; var result: WideString); var short: array[0..256*6] of WideChar; U: PWideChar; begin if (Text=nil) or (Len=0) then result := '' else if Len=0 or -1 if val<0 xor rdx, r10 sub rdx, r10 // rdx=abs(val) cmp rdx, 10 jb @3 // direct process of common val<10 mov rax, rdx lea r8, [rip + TwoDigitLookup] @s: lea rcx, [rcx - 2] cmp rax, 100 jb @2 lea r9, [rax * 2] shr rax, 2 mov rdx, 2951479051793528259 // use power of two reciprocal to avoid division mul rdx shr rdx, 2 mov rax, rdx imul rdx, -200 lea rdx, [rdx + r8] movzx rdx, word ptr[rdx + r9] mov [rcx], dx cmp rax, 10 jae @s @1: or al, '0' mov byte ptr[rcx - 2], '-' mov [rcx - 1], al lea rax, [rcx + r10 - 1] // includes '-' if val<0 ret @2: movzx eax, word ptr[r8 + rax * 2] mov byte ptr[rcx - 1], '-' mov [rcx], ax lea rax, [rcx + r10] // includes '-' if val<0 ret @3: or dl, '0' mov byte ptr[rcx - 2], '-' mov [rcx - 1], dl lea rax, [rcx + r10 - 1] // includes '-' if val<0 end; {$else} asm // eax=P, edx=val mov ecx, edx sar ecx, 31 // 0 if val>=0 or -1 if val<0 push ecx xor edx, ecx sub edx, ecx // edx=abs(val) cmp edx, 10 jb @3 // direct process of common val<10 push edi mov edi, eax mov eax, edx @s: sub edi, 2 cmp eax, 100 jb @2 mov ecx, eax mov edx, 1374389535 // use power of two reciprocal to avoid division mul edx shr edx, 5 // now edx=eax div 100 mov eax, edx imul edx, -200 movzx edx, word ptr[TwoDigitLookup + ecx * 2 + edx] mov [edi], dx cmp eax, 10 jae @s @1: dec edi or al, '0' mov byte ptr[edi - 1], '-' mov [edi], al mov eax, edi pop edi pop ecx add eax, ecx // includes '-' if val<0 ret @2: movzx eax, word ptr[TwoDigitLookup + eax * 2] mov byte ptr[edi - 1], '-' mov [edi], ax mov eax, edi pop edi pop ecx add eax, ecx // includes '-' if val<0 ret @3: dec eax pop ecx or dl, '0' mov byte ptr[eax - 1], '-' mov [eax], dl add eax, ecx // includes '-' if val<0 end; {$endif CPUX64} {$endif ABSOLUTEPASCALORNOTINTEL} function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar; {$ifdef ABSOLUTEPASCALORNOTINTEL} // fallback to pure pascal version for ARM or PIC var c100: PtrUInt; // val/c100 are QWord on 64-bit CPU tab: PWordArray; begin // this code is faster than Borland's original str() or IntToStr() tab := @TwoDigitLookupW; repeat if val<10 then begin dec(P); P^ := AnsiChar(val+ord('0')); break; end else if val<100 then begin dec(P,2); PWord(P)^ := tab[val]; break; end; dec(P,2); c100 := val div 100; dec(val,c100*100); PWord(P)^ := tab[val]; val := c100; if c100=0 then break; until false; result := P; end; {$else} {$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} asm // rcx=P, rdx=val (Linux: rdi,rsi) - val is QWord on Intel 64-bit CPU .noframe {$endif FPC} {$ifndef win64} mov rcx, rdi mov rdx, rsi {$endif win64} cmp rdx, 10 jb @3 // direct process of common val<10 mov rax, rdx lea r8, [rip + TwoDigitLookup] @s: lea rcx, [rcx - 2] cmp rax, 100 jb @2 lea r9, [rax * 2] shr rax, 2 mov rdx, 2951479051793528259 // use power of two reciprocal to avoid division mul rdx shr rdx, 2 mov rax, rdx imul rdx, -200 add rdx, r8 movzx rdx, word ptr[rdx + r9] mov [rcx], dx cmp rax, 10 jae @s @1: dec rcx or al, '0' mov [rcx], al @0: mov rax, rcx ret @2: movzx eax, word ptr[r8 + rax * 2] mov [rcx], ax mov rax, rcx ret @3: lea rax, [rcx - 1] or dl, '0' mov [rax], dl end; {$else} asm // eax=P, edx=val cmp edx, 10 jb @3 // direct process of common val=0 (or val<10) push edi mov edi, eax mov eax, edx nop nop // @s loop alignment @s: sub edi, 2 cmp eax, 100 jb @2 mov ecx, eax mov edx, 1374389535 // use power of two reciprocal to avoid division mul edx shr edx, 5 // now edx=eax div 100 mov eax, edx imul edx, -200 movzx edx, word ptr[TwoDigitLookup + ecx * 2 + edx] mov [edi], dx cmp eax, 10 jae @s @1: dec edi or al, '0' mov [edi], al mov eax, edi pop edi ret @2: movzx eax, word ptr[TwoDigitLookup + eax * 2] mov [edi], ax mov eax, edi pop edi ret @3: dec eax or dl, '0' mov [eax], dl end; {$endif CPU64} {$endif ABSOLUTEPASCALORNOTINTEL} function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar; {$ifdef CPU64} begin result := StrUInt32(P,val); // StrUInt32 converts PtrUInt=QWord on 64-bit CPU end; {$else} var c,c100: QWord; tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; begin if PInt64Rec(@val)^.Hi=0 then P := StrUInt32(P,PCardinal(@val)^) else begin {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} c := val; repeat {$ifdef PUREPASCAL} c100 := c div 100; // one div by two digits dec(c,c100*100); // fast c := c mod 100 {$else} asm // by-passing the RTL is a good idea here push ebx mov edx, dword ptr[c + 4] mov eax, dword ptr[c] mov ebx, 100 mov ecx, eax mov eax, edx xor edx, edx div ebx mov dword ptr[c100 + 4], eax xchg eax, ecx div ebx mov dword ptr[c100], eax imul ebx, ecx mov ecx, 100 mul ecx add edx, ebx pop ebx sub dword ptr[c + 4], edx sbb dword ptr[c], eax end; {$endif} dec(P,2); PWord(P)^ := tab[c]; c := c100; if PInt64Rec(@c)^.Hi=0 then begin if PCardinal(@c)^<>0 then P := StrUInt32(P,PCardinal(@c)^); break; end; until false; end; result := P; end; {$endif} function StrInt64(P: PAnsiChar; const val: Int64): PAnsiChar; begin {$ifdef CPU64} result := StrInt32(P,val); // StrInt32 converts PtrInt=Int64 on 64-bit CPU {$else} if val<0 then begin P := StrUInt64(P,-val)-1; P^ := '-'; end else P := StrUInt64(P,val); result := P; {$endif CPU64} end; function IPToCardinal(P: PUTF8Char; out aValue: cardinal): boolean; var i,c: cardinal; b: array[0..3] of byte; begin aValue := 0; result := false; if (P=nil) or (IdemPChar(P,'127.0.0.1') and (P[9]=#0)) then exit; for i := 0 to 3 do begin c := GetNextItemCardinal(P,'.'); if (c>255) or ((P=nil) and (i<3)) then exit; b[i] := c; end; if PCardinal(@b)^<>$0100007f then begin aValue := PCardinal(@b)^; result := true; end; end; function IPToCardinal(const aIP: RawUTF8; out aValue: cardinal): boolean; begin result := IPToCardinal(pointer(aIP),aValue); end; function IPToCardinal(const aIP: RawUTF8): cardinal; begin IPToCardinal(pointer(aIP),result); end; const // see https://en.wikipedia.org/wiki/Baudot_code Baudot2Char: array[0..63] of AnsiChar = #0'e'#10'a siu'#13'drjnfcktzlwhypqobg'#254'mxv'#255+ #0'3'#10'- ''87'#13#0'4'#0',!:(5+)2$6019?@'#254'./;'#255; var Char2Baudot: array[AnsiChar] of byte; function AsciiToBaudot(const Text: RawUTF8): RawByteString; begin result := AsciiToBaudot(pointer(Text),length(Text)); end; function AsciiToBaudot(P: PAnsiChar; len: integer): RawByteString; var i,c,d,bits: integer; shift: boolean; dest: PByte; tmp: TSynTempBuffer; begin result := ''; if (P=nil) or (len=0) then exit; shift := false; dest := tmp.Init((len*10)shr 3); d := 0; bits := 0; for i := 0 to len-1 do begin c := Char2Baudot[P[i]]; if c>32 then begin if not shift then begin d := (d shl 5) or 27; inc(bits,5); shift := true; end; d := (d shl 5) or (c-32); inc(bits,5); end else if c>0 then begin if shift and (P[i]>=' ') then begin d := (d shl 5) or 31; inc(bits,5); shift := false; end; d := (d shl 5) or c; inc(bits,5); end; while bits>=8 do begin dec(bits,8); dest^ := d shr bits; inc(dest); end; end; if bits>0 then begin dest^ := d shl (8-bits); inc(dest); end; SetString(result,PAnsiChar(tmp.buf),PAnsiChar(dest)-PAnsiChar(tmp.buf)); tmp.Done; end; function BaudotToAscii(const Baudot: RawByteString): RawUTF8; begin result := BaudotToAscii(pointer(Baudot),length(Baudot)); end; function BaudotToAscii(Baudot: PByteArray; len: integer): RawUTF8; var i,c,b,bits,shift: integer; tmp: TSynTempBuffer; dest: PAnsiChar; begin result := ''; if (Baudot=nil) or (len<=0) then exit; dest := tmp.Init((len shl 3)div 5+1); try shift := 0; b := 0; bits := 0; for i := 0 to len-1 do begin b := (b shl 8) or Baudot[i]; inc(bits,8); while bits>=5 do begin dec(bits,5); c := (b shr bits) and 31; case c of 27: if shift<>0 then exit else shift := 32; 31: if shift<>0 then shift := 0 else exit; else begin c := ord(Baudot2Char[c+shift]); if c=0 then if Baudot[i+1]=0 then // allow triming of last 5 bits break else exit; dest^ := AnsiChar(c); inc(dest); end; end; end; end; finally tmp.Done(dest,result); end; end; function TrimControlChars(const text: RawUTF8; const controls: TSynAnsicharSet): RawUTF8; var len,i,j,n: integer; P: PAnsiChar; begin len := length(text); for i := 1 to len do if text[i] in controls then begin n := i-1; FastSetString(result,nil,len); P := pointer(result); {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(text)^,P^,n); for j := i+1 to len do if not(text[j] in controls) then begin P[n] := text[j]; inc(n); end; SetLength(result, n); exit; end; result := text; // no control char found end; {$ifdef CPU64} procedure Exchg16(P1,P2: PInt64Array); inline; var c: Int64; begin c := P1[0]; P1[0] := P2[0]; P2[0] := c; c := P1[1]; P1[1] := P2[1]; P2[1] := c; end; {$else} procedure Exchg16(P1,P2: PIntegerArray); var c: integer; begin c := P1[0]; P1[0] := P2[0]; P2[0] := c; c := P1[1]; P1[1] := P2[1]; P2[1] := c; c := P1[2]; P1[2] := P2[2]; P2[2] := c; c := P1[3]; P1[3] := P2[3]; P2[3] := c; end; {$endif} procedure Exchg(P1,P2: PAnsiChar; count: PtrInt); {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} var i, c: PtrInt; u: AnsiChar; begin for i := 1 to count shr POINTERSHR do begin c := PPtrInt(P1)^; PPtrInt(P1)^ := PPtrInt(P2)^; PPtrInt(P2)^ := c; inc(P1,SizeOf(c)); inc(P2,SizeOf(c)); end; for i := 0 to (count and pred(SizeOf(c)))-1 do begin u := P1[i]; P1[i] := P2[i]; P2[i] := u; end; end; {$else} asm // eax=P1, edx=P2, ecx=count push ebx push esi push ecx shr ecx, 2 jz @2 @4: mov ebx, [eax] mov esi, [edx] mov [eax], esi mov [edx], ebx add eax, 4 add edx, 4 dec ecx jnz @4 @2: pop ecx and ecx, 3 jz @0 @1: mov bl, [eax] mov bh, [edx] mov [eax], bh mov [edx], bl inc eax inc edx dec ecx jnz @1 @0: pop esi pop ebx end; {$endif} function GetAllBits(Bits, BitCount: Cardinal): boolean; begin if BitCount in [low(ALLBITS_CARDINAL)..high(ALLBITS_CARDINAL)] then begin BitCount := ALLBITS_CARDINAL[BitCount]; result := (Bits and BitCount)=BitCount; end else result := false; end; // naive code gives the best performance - bts [Bits] has an overhead function GetBit(const Bits; aIndex: PtrInt): boolean; begin result := TIntegerArray(Bits)[aIndex shr 5] and (1 shl (aIndex and 31)) <> 0; end; procedure SetBit(var Bits; aIndex: PtrInt); begin TIntegerArray(Bits)[aIndex shr 5] := TIntegerArray(Bits)[aIndex shr 5] or (1 shl (aIndex and 31)); end; procedure UnSetBit(var Bits; aIndex: PtrInt); begin PIntegerArray(@Bits)^[aIndex shr 5] := PIntegerArray(@Bits)^[aIndex shr 5] and not (1 shl (aIndex and 31)); end; function GetBitPtr(Bits: pointer; aIndex: PtrInt): boolean; begin result := PIntegerArray(Bits)[aIndex shr 5] and (1 shl (aIndex and 31)) <> 0; end; procedure SetBitPtr(Bits: pointer; aIndex: PtrInt); begin PIntegerArray(Bits)[aIndex shr 5] := PIntegerArray(Bits)[aIndex shr 5] or (1 shl (aIndex and 31)); end; procedure UnSetBitPtr(Bits: pointer; aIndex: PtrInt); begin PIntegerArray(Bits)^[aIndex shr 5] := PIntegerArray(Bits)^[aIndex shr 5] and not (1 shl (aIndex and 31)); end; function GetBit64(const Bits: Int64; aIndex: PtrInt): boolean; begin result := aIndex in TBits64(Bits); end; procedure SetBit64(var Bits: Int64; aIndex: PtrInt); begin include(PBits64(@Bits)^,aIndex); end; procedure UnSetBit64(var Bits: Int64; aIndex: PtrInt); begin exclude(PBits64(@Bits)^,aIndex); end; function GetBitsCount(const Bits; Count: PtrInt): integer; const POPCNTDATA: array[0..15+4] of integer = (0,1,1,2,1,2,2,3,1,2,2,3,2,3,3,4,0,1,3,7); var P: PByte; v: PtrUInt; tab: {$ifdef CPUX86NOTPIC}TIntegerArray absolute POPCNTDATA{$else}PIntegerArray{$endif}; begin {$ifndef CPUX86NOTPIC} tab := @POPCNTDATA; {$endif CPUX86NOTPIC} P := @Bits; result := 0; while Count>=8 do begin dec(Count,8); v := P^; inc(result,tab[v and $f]); inc(result,tab[v shr 4]); inc(P); end; v := P^; if Count>=4 then begin dec(Count,4); inc(result,tab[v and $f]); v := v shr 4; end; if Count>0 then inc(result,tab[v and tab[Count+16]]); end; {$ifdef FPC} type /// available type families for Free Pascal RTTI values // - values differs from Delphi, and are taken from FPC typinfo.pp unit // - here below, we defined tkLString instead of FPC tkAString to match // Delphi - see http://lists.freepascal.org/fpc-devel/2013-June/032233.html TTypeKind = (tkUnknown,tkInteger,tkChar,tkEnumeration,tkFloat, tkSet,tkMethod,tkSString,tkLStringOld,tkLString, tkWString,tkVariant,tkArray,tkRecord,tkInterface, tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord, tkDynArray,tkInterfaceRaw,tkProcVar,tkUString,tkUChar, tkHelper,tkFile,tkClassRef,tkPointer); const // all potentially managed types - should match ManagedType*() functions tkManagedTypes = [tkLStringOld,tkLString,tkWstring,tkUstring,tkArray, tkObject,tkRecord,tkDynArray,tkInterface,tkVariant]; // maps record or object types tkRecordTypes = [tkObject,tkRecord]; tkRecordKinds = [tkObject,tkRecord]; type // as defined in Delphi 6 and up TDelphiTypeKind = (dkUnknown, dkInteger, dkChar, dkEnumeration, dkFloat, dkString, dkSet, dkClass, dkMethod, dkWChar, dkLString, dkWString, dkVariant, dkArray, dkRecord, dkInterface, dkInt64, dkDynArray, dkUString, dkClassRef, dkPointer, dkProcedure); const FPCTODELPHI: array[TTypeKind] of TDelphiTypeKind = ( dkUnknown,dkInteger,dkChar,dkEnumeration,dkFloat, dkSet,dkMethod,dkString,dkLString,dkLString, dkWString,dkVariant,dkArray,dkRecord,dkInterface, dkClass,dkRecord,dkWChar,dkEnumeration,dkInt64,dkInt64, dkDynArray,dkInterface,dkProcedure,dkUString,dkWChar, dkPointer,dkPointer,dkClassRef,dkPointer); DELPHITOFPC: array[TDelphiTypeKind] of TTypeKind = ( tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkSString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString, tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray, tkUString, tkClassRef, tkPointer, tkProcVar); {$else FPC} type /// available type families for Delphi 6 and up, similar to typinfo.pas TTypeKind = (tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString, tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray {$ifdef UNICODE}, tkUString, tkClassRef, tkPointer, tkProcedure{$endif}); const // maps record or object types tkRecordTypes = [tkRecord]; tkRecordKinds = tkRecord; {$endif} type PTypeKind = ^TTypeKind; TOrdType = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong {$ifdef FPC_NEWRTTI},otSQWord,otUQWord{$endif}); TFloatType = (ftSingle,ftDoub,ftExtended,ftComp,ftCurr); TTypeKinds = set of TTypeKind; PStrRec = ^TStrRec; /// map the Delphi/FPC string header, as defined in System.pas {$ifdef FPC} // see TAnsiRec in astrings.inc TStrRec = record {$ifdef ISFPC27} codePage: TSystemCodePage; elemSize: Word; {$endif} {$ifdef CPU64} _Padding: DWord; {$endif} refCnt: SizeInt; length: SizeInt; {$else FPC} /// map the Delphi/FPC dynamic array header (stored before each instance) TDynArrayRec = packed record /// dynamic array reference count (basic garbage memory mechanism) {$ifdef CPUX64} _Padding: LongInt; // Delphi/FPC XE2+ expects 16 byte alignment {$endif} refCnt: Longint; /// length in element count // - size in bytes = length*ElemSize length: PtrInt; end; PDynArrayRec = ^TDynArrayRec; TStrRec = packed record {$ifdef UNICODE} {$ifdef CPU64} /// padding bytes for 16 byte alignment of the header _Padding: LongInt; {$endif} /// the associated code page used for this string // - exist only since Delphi/FPC 2009 // - 0 or 65535 for RawByteString // - 1200=CP_UTF16 for UnicodeString // - 65001=CP_UTF8 for RawUTF8 // - the current code page for AnsiString codePage: Word; /// either 1 (for AnsiString) or 2 (for UnicodeString) // - exist only since Delphi/FPC 2009 elemSize: Word; {$endif UNICODE} /// COW string reference count (basic garbage memory mechanism) refCnt: Longint; /// length in characters // - size in bytes = length*elemSize length: Longint; {$endif FPC} end; {$ifdef FPC} {$PACKRECORDS C} {$endif FPC} PTypeInfo = ^TTypeInfo; {$ifdef HASDIRECTTYPEINFO} PTypeInfoStored = PTypeInfo; {$else} PTypeInfoStored = ^PTypeInfo; // = TypeInfoPtr macro in FPC typinfo.pp {$endif} // note: FPC TRecInitData is taken from typinfo.pp via SynFPCTypInfo // since this information is evolving/breaking a lot in the current FPC trunk /// map the Delphi/FPC record field RTTI TFieldInfo = {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} packed {$endif FPC_REQUIRES_PROPER_ALIGNMENT} record TypeInfo: PTypeInfoStored; {$ifdef FPC} Offset: sizeint; {$else} Offset: PtrUInt; {$endif FPC} end; PFieldInfo = ^TFieldInfo; {$ifdef ISDELPHI2010_OR_FPC_NEWRTTI} /// map the Delphi record field enhanced RTTI (available since Delphi 2010) TEnhancedFieldInfo = packed record TypeInfo: PTypeInfoStored; Offset: PtrUInt; // match TInitManagedField/TManagedField in FPC typinfo.pp {$ifdef ISDELPHI2010} Flags: Byte; NameLen: byte; // = Name[0] = length(Name) {$ENDIF} end; PEnhancedFieldInfo = ^TEnhancedFieldInfo; {$endif} TTypeInfo = {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} packed {$endif FPC_REQUIRES_PROPER_ALIGNMENT} record kind: TTypeKind; NameLen: byte; case TTypeKind of tkUnknown: ( NameFirst: AnsiChar; ); tkDynArray: ( {$ifdef FPC} elSize: SizeUInt; elType2: PTypeInfoStored; varType: LongInt; elType: PTypeInfoStored; //DynUnitName: ShortStringBase; {$else} // storage byte count for this field elSize: Longint; // nil for unmanaged field elType: PTypeInfoStored; // OleAuto compatible type varType: Integer; // also unmanaged field elType2: PTypeInfoStored; {$endif} ); tkArray: ( {$ifdef FPC} // warning: in VER2_6, this is the element size, not full array size arraySize: SizeInt; // product of lengths of all dimensions elCount: SizeInt; {$else} arraySize: Integer; // product of lengths of all dimensions elCount: Integer; {$endif} arrayType: PTypeInfoStored; dimCount: Byte; dims: array[0..255 {DimCount-1}] of PTypeInfoStored; ); {$ifdef FPC} tkRecord, tkObject:( {$ifdef FPC_NEWRTTI} RecInitInfo: Pointer; {$endif} recSize: longint; {$ifdef FPC_NEWRTTI} TotalFieldCount: longint; // note: for FPC 3.1.x and newer ManagedCount is deprecated {$else} ManagedCount: longint; // note: FPC for 3.0.x and previous generates RTTI for unmanaged fields (as in TEnhancedFieldInfo) {$endif} {$else} tkRecord: ( recSize: cardinal; ManagedCount: integer; {$endif FPC} {$ifdef DELPHI_OR_FPC_OLDRTTI} ManagedFields: array[0..0] of TFieldInfo; {$else} AllFields: array[0..0] of TEnhancedFieldInfo; {$endif} {$ifdef ISDELPHI2010} // enhanced RTTI containing info about all fields NumOps: Byte; //RecOps: array[0..0] of Pointer; AllCount: Integer; // !!!! may need $RTTI EXPLICIT FIELDS([vcPublic]) AllFields: array[0..0] of TEnhancedFieldInfo; {$endif ISDELPHI2010} ); tkEnumeration: ( EnumType: TOrdType; {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} tkEnumerationAlignment:DWORD; // needed for correct alignment !!?? {$endif} {$ifdef FPC_ENUMHASINNER} inner: {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} packed {$endif} record {$endif} MinValue: longint; MaxValue: longint; EnumBaseType: PTypeInfoStored; {$ifdef FPC_ENUMHASINNER} end; {$endif FPC_ENUMHASINNER} NameList: string[255]; ); tkInteger: ( IntegerType: TOrdType; ); tkInt64: ( MinInt64Value, MaxInt64Value: Int64; ); tkSet: ( SetType: TOrdType; {$ifdef FPC} {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} tkSetAlignment: DWORD; // needed for correct alignment !!?? {$endif} {$ifndef VER3_0} SetSize: SizeInt; {$endif VER3_0} {$endif FPC} SetBaseType: PTypeInfoStored; ); tkFloat: ( FloatType: TFloatType; ); tkClass: ( ClassType: PAnsiChar; // TClass; ParentInfo: PTypeInfoStored; PropCount: SmallInt; UnitNameLen: byte; ); end; TPropInfo = packed record PropType: PTypeInfoStored; GetProc: PtrInt; SetProc: PtrInt; StoredProc: PtrInt; Index: Integer; Default: Longint; NameIndex: SmallInt; {$ifdef FPC} PropProcs : Byte; {$endif} NameLen: byte; end; PPropInfo = ^TPropInfo; {$ifdef HASDIRECTTYPEINFO} type Deref = PTypeInfo; {$else} function Deref(Info: PTypeInfoStored): PTypeInfo; {$ifdef HASINLINE} inline; begin if Info=nil then result := pointer(Info) else result := Info^; end; {$else} asm // Delphi is so bad at compiling above code... or eax, eax jz @z mov eax, [eax] ret @z: db $f3 // rep ret end; {$endif HASINLINE} {$endif HASDIRECTTYPEINFO} const /// codePage offset = string header size // - used to calc the beginning of memory allocation of a string STRRECSIZE = SizeOf(TStrRec); {$ifdef HASCODEPAGE} procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt); var r: PAnsiChar; // s may = p -> stand-alone variable sr: PStrRec; // local copy of r, to use register begin if len<=0 then r := nil else begin GetMem(r,len+(STRRECSIZE+2)); sr := pointer(r); sr^.codePage := codepage; sr^.elemSize := 1; sr^.refCnt := 1; sr^.length := len; inc(sr); PWord(PAnsiChar(sr)+len)^ := 0; // ensure ends with two #0 r := pointer(sr); if p<>nil then {$ifdef FPC}Move{$else}MoveFast{$endif}(p^,sr^,len); end; {$ifdef FPC}Finalize(RawByteString(s)){$else}RawByteString(s) := ''{$endif}; pointer(s) := r; end; procedure FastSetString(var s: RawUTF8; p: pointer; len: PtrInt); var r: PAnsiChar; sr: PStrRec; begin if len<=0 then r := nil else begin GetMem(r,len+(STRRECSIZE+4)); sr := pointer(r); sr^.codePage := CP_UTF8; sr^.elemSize := 1; sr^.refCnt := 1; sr^.length := len; inc(sr); PCardinal(PAnsiChar(sr)+len)^ := 0; // ends with four #0 r := pointer(sr); if p<>nil then {$ifdef FPC}Move{$else}MoveFast{$endif}(p^,sr^,len); end; {$ifdef FPC}Finalize(s){$else}s := ''{$endif}; pointer(s) := r; end; {$else} procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt); begin SetString(RawByteString(s),PAnsiChar(p),len); end; procedure FastSetString(var s: RawUTF8; p: pointer; len: PtrInt); begin SetString(RawByteString(s),PAnsiChar(p),len); end; {$endif HASCODEPAGE} procedure GetMemAligned(var s: RawByteString; p: pointer; len: PtrInt; out aligned: pointer); begin SetString(s,nil,len+16); aligned := pointer(s); inc(PtrUInt(aligned),PtrUInt(aligned) and 15); if p<>nil then {$ifdef FPC}Move{$else}MoveFast{$endif}(p^,aligned^,len); end; function ToText(k: TTypeKind): PShortString; overload; begin result := GetEnumName(TypeInfo(TTypeKind),ord(k)); end; function ToText(k: TDynArrayKind): PShortString; begin result := GetEnumName(TypeInfo(TDynArrayKind),ord(k)); end; function UniqueRawUTF8(var UTF8: RawUTF8): pointer; begin {$ifdef FPC} UniqueString(UTF8); // @UTF8[1] won't call UniqueString() under FPC :( {$endif} result := @UTF8[1]; end; procedure UniqueRawUTF8ZeroToTilde(var UTF8: RawUTF8; MaxSize: integer); var i: integer; begin i := length(UTF8); if i>MaxSize then PByteArray(UTF8)[MaxSize] := 0 else MaxSize := i; for i := 0 to MaxSize-1 do if PByteArray(UTF8)[i]=0 then PByteArray(UTF8)[i] := ord('~'); end; {$ifdef FPC} function TDynArrayRec.GetLength: sizeint; begin result := high+1; end; procedure TDynArrayRec.SetLength(len: sizeint); begin high := len-1; end; {$endif FPC} function DynArrayLength(Value: Pointer): integer; {$ifdef HASINLINE}inline;{$endif} begin if Value=nil then result := PtrInt(Value) else begin {$ifdef FPC} result := PDynArrayRec(PtrUInt(Value)-SizeOf(TDynArrayRec))^.high+1; {$else} result := PInteger(PtrUInt(Value)-SizeOf(PtrInt))^; {$endif} end; end; function GetTypeInfo(aTypeInfo: pointer; aExpectedKind: TTypeKind): PTypeInfo; overload; {$ifdef HASINLINE} inline; begin if (aTypeInfo<>nil) and (PTypeKind(aTypeInfo)^=aExpectedKind) then begin {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} result := GetFPCAlignPtr(aTypeInfo); {$else} result := aTypeInfo; inc(PByte(result),result^.NameLen); {$endif} end else result := nil; end; {$else} asm test eax, eax jz @n movzx ecx, byte ptr[eax + TTypeInfo.NameLen] cmp dl, [eax] jne @n add eax, ecx ret @n: xor eax, eax end; {$endif HASINLINE} function GetTypeInfo(aTypeInfo: pointer; const aExpectedKind: TTypeKinds): PTypeInfo; overload; {$ifdef HASINLINE} inline; begin result := aTypeInfo; if result<>nil then if result^.Kind in aExpectedKind then {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} result := GetFPCAlignPtr(result) {$else} inc(PByte(result),result^.NameLen) {$endif} else result := nil; end; {$else} asm // eax=aTypeInfo edx=aExpectedKind test eax, eax jz @n movzx ecx, byte ptr[eax] bt edx, ecx movzx ecx, byte ptr[eax + TTypeInfo.NameLen] jnb @n add eax, ecx ret @n: xor eax, eax end; {$endif HASINLINE} function GetTypeInfo(aTypeInfo: pointer): PTypeInfo; overload; {$ifdef HASINLINE} inline; begin {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} result := GetFPCAlignPtr(aTypeInfo); {$else} result := @PAnsiChar(aTypeInfo)[PTypeInfo(aTypeInfo)^.NameLen]; {$endif} end; {$else} asm movzx ecx, byte ptr[eax + TTypeInfo.NameLen] add eax, ecx end; {$endif HASINLINE} function DynArrayTypeInfoToRecordInfo(aDynArrayTypeInfo: pointer; aDataSize: PInteger=nil): pointer; var info: PTypeInfo; begin result := nil; info := GetTypeInfo(aDynArrayTypeInfo,tkDynArray); if info=nil then exit; if info^.elType<>nil then result := Deref(info^.elType); if aDataSize<>nil then aDataSize^ := info^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}; end; procedure TypeInfoToName(aTypeInfo: pointer; var result: RawUTF8; const default: RawUTF8); begin if aTypeInfo<>nil then FastSetString(result,PAnsiChar(@PTypeInfo(aTypeInfo)^.NameLen)+1, PTypeInfo(aTypeInfo)^.NameLen) else result := default; end; function TypeInfoToShortString(aTypeInfo: pointer): PShortString; begin if aTypeInfo<>nil then result := @PTypeInfo(aTypeInfo)^.NameLen else result := nil; end; procedure TypeInfoToQualifiedName(aTypeInfo: pointer; var result: RawUTF8; const default: RawUTF8); var unitname: RawUTF8; begin if aTypeInfo<>nil then begin FastSetString(result,PAnsiChar(@PTypeInfo(aTypeInfo)^.NameLen)+1, PTypeInfo(aTypeInfo)^.NameLen); if PTypeInfo(aTypeInfo)^.Kind=tkClass then begin with GetTypeInfo(aTypeInfo)^ do FastSetString(unitname,PAnsiChar(@UnitNameLen)+1,UnitNameLen); result := unitname+'.'+result; end; end else result := default; end; function TypeInfoToName(aTypeInfo: pointer): RawUTF8; begin TypeInfoToName(aTypeInfo,Result,''); end; function RecordTypeInfoSize(aRecordTypeInfo: pointer): integer; var info: PTypeInfo; begin info := GetTypeInfo(aRecordTypeInfo,tkRecordKinds); if info=nil then result := 0 else result := info^.recSize; end; function GetEnumInfo(aTypeInfo: pointer; out MaxValue: Integer): PShortString; {$ifdef HASINLINE} inline; var info: PTypeInfo; base: PTypeInfoStored; begin if (aTypeInfo<>nil) and (PTypeKind(aTypeInfo)^=tkEnumeration) then begin info := GetTypeInfo(aTypeInfo); base := info^.{$ifdef FPC_ENUMHASINNER}inner.{$endif}EnumBaseType; {$ifdef FPC} // no redirection if aTypeInfo is already the base type if (base<>nil) and (base<>aTypeInfo) then {$endif} info := GetTypeInfo(base{$ifndef HASDIRECTTYPEINFO}^{$endif}); MaxValue := info^.{$ifdef FPC_ENUMHASINNER}inner.{$endif}MaxValue; result := @info.NameList; end else result := nil; end; {$else} asm // eax=aTypeInfo edx=@MaxValue test eax, eax jz @n cmp byte ptr[eax], tkEnumeration jnz @n movzx ecx, byte ptr[eax + TTypeInfo.NameLen] mov eax, [eax + ecx + TTypeInfo.EnumBaseType] mov eax, [eax] movzx ecx, byte ptr[eax + TTypeInfo.NameLen] add eax, ecx mov ecx, [eax + TTypeInfo.MaxValue] mov [edx], ecx lea eax, [eax + TTypeInfo.NameList] ret @n: xor eax, eax end; {$endif HASINLINE} function GetSetInfo(aTypeInfo: pointer; out MaxValue: Integer; out Names: PShortString): boolean; var info: PTypeInfo; begin info := GetTypeInfo(aTypeInfo,tkSet); if info<>nil then begin Names := GetEnumInfo(Deref(info^.SetBaseType),MaxValue); result := Names<>nil; end else result := false; end; const NULL_LOW = ord('n')+ord('u')shl 8+ord('l')shl 16+ord('l')shl 24; FALSE_LOW = ord('f')+ord('a')shl 8+ord('l')shl 16+ord('s')shl 24; TRUE_LOW = ord('t')+ord('r')shl 8+ord('u')shl 16+ord('e')shl 24; NULL_UPP = ord('N')+ord('U')shl 8+ord('L')shl 16+ord('L')shl 24; EndOfJSONValueField = [#0,#9,#10,#13,' ',',','}',']']; EndOfJSONField = [',',']','}',':']; DigitChars = ['-','+','0'..'9']; DigitFirstChars = ['-','1'..'9']; // 0/- excluded by JSON! DigitFloatChars = ['-','+','0'..'9','.','E','e']; NULL_SHORTSTRING: string[1] = ''; procedure GetEnumNames(aTypeInfo: pointer; aDest: PPShortString); var MaxValue, i: integer; res: PShortString; begin res := GetEnumInfo(aTypeInfo,MaxValue); if res<>nil then for i := 0 to MaxValue do begin aDest^ := res; inc(PByte(res),ord(res^[0])+1); // next short string inc(aDest); end; end; procedure GetEnumTrimmedNames(aTypeInfo: pointer; aDest: PRawUTF8); var MaxValue, i: integer; res: PShortString; begin res := GetEnumInfo(aTypeInfo,MaxValue); if res<>nil then for i := 0 to MaxValue do begin aDest^ := TrimLeftLowerCaseShort(res); inc(PByte(res),ord(res^[0])+1); // next short string inc(aDest); end; end; function GetEnumTrimmedNames(aTypeInfo: pointer): TRawUTF8DynArray; var MaxValue, i: integer; res: PShortString; begin res := GetEnumInfo(aTypeInfo,MaxValue); if res=nil then result := nil else begin SetLength(result,MaxValue+1); for i := 0 to MaxValue do begin result[i] := TrimLeftLowerCaseShort(res); inc(PByte(res),ord(res^[0])+1); // next short string end; end; end; procedure GetCaptionFromTrimmed(PS: PShortString; var result: string); var tmp: array[byte] of AnsiChar; L: integer; begin L := ord(PS^[0]); inc(PByte(PS)); while (L>0) and (PS^[0] in ['a'..'z']) do begin inc(PByte(PS)); dec(L); end; tmp[L] := #0; // as expected by GetCaptionFromPCharLen/UnCamelCase {$ifdef FPC}Move{$else}MoveFast{$endif}(PS^,tmp,L); GetCaptionFromPCharLen(tmp,result); end; procedure GetEnumCaptions(aTypeInfo: pointer; aDest: PString); var MaxValue, i: integer; res: PShortString; begin res := GetEnumInfo(aTypeInfo,MaxValue); if res<>nil then for i := 0 to MaxValue do begin GetCaptionFromTrimmed(res,aDest^); inc(PByte(res),ord(res^[0])+1); // next short string inc(aDest); end; end; function GetEnumName(aTypeInfo: pointer; aIndex: integer): PShortString; {$ifdef HASINLINENOTX86} var MaxValue: integer; begin result := GetEnumInfo(aTypeInfo,MaxValue); if (result<>nil) and (cardinal(aIndex)<=cardinal(MaxValue)) then begin if aIndex>0 then repeat inc(PByte(result),ord(result^[0])+1); // next short string dec(aIndex); if aIndex=0 then break; inc(PByte(result),ord(result^[0])+1); // loop unrolled twice dec(aIndex); if aIndex=0 then break; until false; end else result := @NULL_SHORTSTRING; end; {$else} asm // eax=aTypeInfo edx=aIndex test eax, eax jz @0 cmp byte ptr[eax], tkEnumeration jnz @0 movzx ecx, byte ptr[eax + TTypeInfo.NameLen] mov eax, [eax + ecx + TTypeInfo.EnumBaseType] mov eax, [eax] movzx ecx, byte ptr[eax + TTypeInfo.NameLen] cmp edx, [eax + ecx + TTypeInfo.MaxValue] ja @0 lea eax, [eax + ecx + TTypeInfo.NameList] test edx, edx jz @z push edx shr edx, 2 // fast by-four scanning jz @1 @4: dec edx movzx ecx, byte ptr[eax] lea eax, [eax + ecx + 1] movzx ecx, byte ptr[eax] lea eax, [eax + ecx + 1] movzx ecx, byte ptr[eax] lea eax, [eax + ecx + 1] movzx ecx, byte ptr[eax] lea eax, [eax + ecx + 1] jnz @4 pop edx and edx, 3 jnz @s ret @1: pop edx @s: movzx ecx, byte ptr[eax] dec edx lea eax, [eax + ecx + 1] // next short string jnz @s ret @z: rep ret @0: lea eax, NULL_SHORTSTRING end; {$endif HASINLINENOTX86} {$ifdef PUREPASCAL} // for proper inlining function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: PtrInt): boolean; var i,j: PtrInt; begin result := false; j := 0; for i := 1 to P1P2Len shr 2 do if (PCardinalArray(P1)[j] xor PCardinalArray(P2)[j]) and $dfdfdfdf<>0 then exit else inc(j); for i := j*4 to P1P2Len-1 do if (ord(P1[i]) xor ord(P2[i])) and $df<>0 then exit; result := true; end; {$endif PUREPASCAL} function FindShortStringListExact(List: PShortString; MaxValue: integer; aValue: PUTF8Char; aValueLen: PtrInt): integer; var PLen: PtrInt; begin if aValueLen<>0 then for result := 0 to MaxValue do begin PLen := ord(List^[0]); if (PLen=aValuelen) and IdemPropNameUSameLen(@List^[1],aValue,aValueLen) then exit; inc(PByte(List),PLen+1); // next short string end; result := -1; end; function FindShortStringListTrimLowerCase(List: PShortString; MaxValue: integer; aValue: PUTF8Char; aValueLen: PtrInt): integer; var PLen: PtrInt; begin if aValueLen<>0 then for result := 0 to MaxValue do begin PLen := ord(List^[0]); inc(PUTF8Char(List)); repeat if not(PUTF8Char(List)^ in ['a'..'z']) then break; inc(PUTF8Char(List)); dec(PLen); until PLen=0; if (PLen=aValueLen) and IdemPropNameUSameLen(aValue,PUTF8Char(List),PLen) then exit; inc(PUTF8Char(List),PLen); end; result := -1; end; function GetEnumNameValue(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: integer; AlsoTrimLowerCase: boolean): Integer; var List: PShortString; MaxValue: integer; begin List := GetEnumInfo(aTypeInfo,MaxValue); if (aValueLen<>0) and (List<>nil) then begin result := FindShortStringListExact(List,MaxValue,aValue,aValueLen); if (result<0) and AlsoTrimLowerCase then result := FindShortStringListTrimLowerCase(List,MaxValue,aValue,aValueLen); end else result := -1; end; function GetEnumNameValueTrimmed(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: integer): integer; var List: PShortString; MaxValue: integer; begin List := GetEnumInfo(aTypeInfo,MaxValue); if (aValueLen<>0) and (List<>nil) then result := FindShortStringListTrimLowerCase(List,MaxValue,aValue,aValueLen) else result := -1; end; function GetEnumNameValue(aTypeInfo: pointer; const aValue: RawUTF8; AlsoTrimLowerCase: boolean=false): Integer; begin result := GetEnumNameValue(aTypeInfo, pointer(aValue), length(aValue), AlsoTrimLowerCase); end; function GetSetName(aTypeInfo: pointer; const value): RawUTF8; var PS: PShortString; i,max: integer; begin result := ''; if GetSetInfo(aTypeInfo,max,PS) then begin for i := 0 to max do begin if GetBitPtr(@value,i) then result := FormatUTF8('%%,',[result,PS^]); inc(PByte(PS),ord(PS^[0])+1); // next short string end; end; if result<>'' then SetLength(result,length(result)-1); // trim last comma end; procedure AppendShortComma(text: PAnsiChar; len: integer; var result: shortstring; trimlowercase: boolean); begin if trimlowercase then while text^ in ['a'..'z'] do if len=1 then exit else begin inc(text); dec(len); end; if integer(ord(result[0]))+len>=255 then exit; {$ifdef FPC}Move{$else}MoveFast{$endif}(text^,result[ord(result[0])+1],len); inc(result[0],len+1); result[ord(result[0])] := ','; end; procedure GetSetNameShort(aTypeInfo: pointer; const value; out result: ShortString; trimlowercase: boolean); var PS: PShortString; i,max: integer; begin result := ''; if GetSetInfo(aTypeInfo,max,PS) then begin for i := 0 to max do begin if GetBitPtr(@value,i) then AppendShortComma(@PS^[1],ord(PS^[0]),result,trimlowercase); inc(PByte(PS),ord(PS^[0])+1); // next short string end; end; if result[ord(result[0])]=',' then dec(result[0]); end; function GetSetNameValue(aTypeInfo: pointer; var P: PUTF8Char; out EndOfObject: AnsiChar): cardinal; var names: PShortString; Text: PUTF8Char; wasString: boolean; MaxValue, TextLen, i: integer; begin result := 0; if (P<>nil) and GetSetInfo(aTypeInfo,MaxValue,names) then begin P := GotoNextNotSpace(P); if P^='[' then begin P := GotoNextNotSpace(P+1); if P^=']' then inc(P) else begin repeat Text := GetJSONField(P,P,@wasString,@EndOfObject,@TextLen); if (Text=nil) or not wasString then begin P := nil; // invalid input (expects a JSON array of strings) exit; end; if Text^='*' then begin if MaxValue<32 then result := ALLBITS_CARDINAL[MaxValue+1] else result := cardinal(-1); break; end; if Text^ in ['a'..'z'] then i := FindShortStringListExact(names,MaxValue,Text,TextLen) else i := -1; if i<0 then i := FindShortStringListTrimLowerCase(names,MaxValue,Text,TextLen); if i>=0 then SetBitPtr(@result,i); // unknown enum names (i=-1) would just be ignored until EndOfObject=']'; if P=nil then exit; // avoid GPF below if already reached the input end end; while not (P^ in EndOfJSONField) do begin // mimics GetJSONField() if P^=#0 then begin P := nil; exit; // unexpected end end; inc(P); end; EndOfObject := P^; P := GotoNextNotSpace(P+1); end else result := GetCardinal(GetJSONField(P,P,nil,@EndOfObject)); end; end; { note: those low-level VariantTo*() functions are expected to be there even if NOVARIANTS conditional is defined (used e.g. by SynDB.TQuery) } function VariantToInteger(const V: Variant; var Value: integer): boolean; var tmp: TVarData; begin with TVarData(V) do case VType of varNull, varEmpty: Value := 0; varBoolean: if VBoolean then Value := 1 else Value := 0; // normalize varSmallint: Value := VSmallInt; {$ifndef DELPHI5OROLDER} varShortInt: Value := VShortInt; varWord: Value := VWord; varLongWord: if VLongWord<=cardinal(High(integer)) then Value := VLongWord else begin result := false; exit; end; {$endif} varByte: Value := VByte; varInteger: Value := VInteger; varWord64: if (VInt64>=0) and (VInt64<=High(integer)) then Value := VInt64 else begin result := False; exit; end; varInt64: if (VInt64>=Low(integer)) and (VInt64<=High(integer)) then Value := VInt64 else begin result := False; exit; end; else if SetVariantUnRefSimpleValue(V,tmp) then begin result := VariantToInteger(variant(tmp),Value); exit; end else begin result := false; exit; end; end; result := true; end; function VariantToDouble(const V: Variant; var Value: double): boolean; var tmp: TVarData; begin with TVarData(V) do if VType=varVariant or varByRef then result := VariantToDouble(PVariant(VPointer)^,Value) else if VariantToInt64(V,tmp.VInt64) then begin // also handle varEmpty,varNull Value := tmp.VInt64; result := true; end else case VType of varDouble,varDate: begin Value := VDouble; result := true; end; varSingle: begin Value := VSingle; result := true; end; varCurrency: begin Value := VCurrency; result := true; end else if SetVariantUnRefSimpleValue(V,tmp) then result := VariantToDouble(variant(tmp),Value) else result := false; end; end; function VariantToDoubleDef(const V: Variant; const default: double=0): double; begin if not VariantToDouble(V,result) then result := default; end; function VariantToCurrency(const V: Variant; var Value: currency): boolean; var tmp: TVarData; begin with TVarData(V) do if VType=varVariant or varByRef then result := VariantToCurrency(PVariant(VPointer)^,Value) else if VariantToInt64(V,tmp.VInt64) then begin Value := tmp.VInt64; result := true; end else case VType of varDouble,varDate: begin Value := VDouble; result := true; end; varSingle: begin Value := VSingle; result := true; end; varCurrency: begin Value := VCurrency; result := true; end else if SetVariantUnRefSimpleValue(V,tmp) then result := VariantToCurrency(variant(tmp),Value) else result := false; end; end; function VariantToBoolean(const V: Variant; var Value: Boolean): boolean; var tmp: TVarData; begin case TVarData(V).VType of varEmpty, varNull: begin result := false; exit; end; varBoolean: Value := TVarData(V).VBoolean; varInteger: // coming e.g. from GetJsonField() Value := TVarData(V).VInteger=1; else if SetVariantUnRefSimpleValue(V,tmp) then if tmp.VType=varBoolean then Value := tmp.VBoolean else begin result := false; exit; end else begin result := false; exit; end; end; result := true; end; function VariantToInt64(const V: Variant; var Value: Int64): boolean; var tmp: TVarData; begin with TVarData(V) do case VType of varNull, varEmpty: Value := 0; varBoolean: if VBoolean then Value := 1 else Value := 0; // normalize varSmallint: Value := VSmallInt; {$ifndef DELPHI5OROLDER} varShortInt: Value := VShortInt; varWord: Value := VWord; varLongWord: Value := VLongWord; {$endif} varByte: Value := VByte; varInteger: Value := VInteger; varWord64: if VInt64>=0 then Value := VInt64 else begin result := false; exit; end; varInt64: Value := VInt64; else if SetVariantUnRefSimpleValue(V,tmp) then begin result := VariantToInt64(variant(tmp),Value); exit; end else begin result := false; exit; end; end; result := true; end; function VariantToInt64Def(const V: Variant; DefaultValue: Int64): Int64; begin if not VariantToInt64(V,result) then result := DefaultValue; end; function VariantToIntegerDef(const V: Variant; DefaultValue: integer): integer; begin if not VariantToInteger(V,result) then result := DefaultValue; end; {$ifndef NOVARIANTS} function BinToHexDisplayLowerVariant(Bin: pointer; BinBytes: integer): variant; begin RawUTF8ToVariant(BinToHexDisplayLower(Bin,BinBytes),result); end; function VariantHexDisplayToBin(const Hex: variant; Bin: PByte; BinBytes: integer): boolean; var tmp: RawUTF8; wasString: boolean; begin VariantToUTF8(hex,tmp,wasString); result := wasstring and HexDisplayToBin(pointer(tmp),Bin,BinBytes); end; function VariantToDateTime(const V: Variant; var Value: TDateTime): boolean; var tmp: RawUTF8; vd: TVarData; begin with TVarData(V) do if VType=varVariant or varByRef then result := VariantToDateTime(PVariant(VPointer)^,Value) else case VType of varDouble,varDate: begin Value := VDouble; result := true; end; varSingle: begin Value := VSingle; result := true; end; varCurrency: begin Value := VCurrency; result := true; end else if SetVariantUnRefSimpleValue(V,vd) then result := VariantToDateTime(variant(vd),Value) else begin VariantToUTF8(V,tmp); Iso8601ToDateTimePUTF8CharVar(pointer(tmp),length(tmp),Value); result := Value<>0; end; end; end; procedure VariantToInlineValue(const V: Variant; var result: RawUTF8); var wasString: boolean; begin VariantToUTF8(V,result,wasString); if wasString then result := QuotedStr(pointer(result),'"'); end; function VariantToVariantUTF8(const V: Variant): variant; var tmp: RawUTF8; wasString: boolean; begin VariantToUTF8(V,tmp,wasString); if wasString then result := V else RawUTF8ToVariant(tmp,result); end; procedure VariantToUTF8(const V: Variant; var result: RawUTF8; var wasString: boolean); var tmp: TVarData; begin wasString := false; with TVarData(V) do case VType of varEmpty, varNull: result := NULL_STR_VAR; varSmallint: Int32ToUTF8(VSmallInt,result); {$ifndef DELPHI5OROLDER} varShortInt: Int32ToUTF8(VShortInt,result); varWord: UInt32ToUTF8(VWord,result); varLongWord: UInt32ToUTF8(VLongWord,result); {$endif} varByte: result := SmallUInt32UTF8[VByte]; varBoolean: if VBoolean then result := SmallUInt32UTF8[1] else result := SmallUInt32UTF8[0]; varInteger: Int32ToUTF8(VInteger,result); varInt64: Int64ToUTF8(VInt64,result); varWord64: UInt64ToUTF8(VInt64,result); varSingle: ExtendedToStr(VSingle,SINGLE_PRECISION,result); varDouble: ExtendedToStr(VDouble,DOUBLE_PRECISION,result); varCurrency: Curr64ToStr(VInt64,result); varDate: begin wasString := true; DateTimeToIso8601TextVar(VDate,'T',result); end; varString: begin wasString := true; {$ifdef HASCODEPAGE} AnyAnsiToUTF8(RawByteString(VString),result); {$else} result := RawUTF8(VString); {$endif} end; {$ifdef HASVARUSTRING} varUString: begin wasString := true; RawUnicodeToUtf8(VAny,length(UnicodeString(VAny)),result); end; {$endif} varOleStr: begin wasString := true; RawUnicodeToUtf8(VAny,length(WideString(VAny)),result); end; else if SetVariantUnRefSimpleValue(V,tmp) then VariantToUTF8(Variant(tmp),result,wasString) else if VType=varVariant or varByRef then // complex varByRef VariantToUTF8(PVariant(VPointer)^,result,wasString) else if VType=varByRef or varString then begin wasString := true; {$ifdef HASCODEPAGE} AnyAnsiToUTF8(PRawByteString(VString)^,result); {$else} result := PRawUTF8(VString)^; {$endif} end else if VType=varByRef or varOleStr then begin wasString := true; RawUnicodeToUtf8(pointer(PWideString(VAny)^),length(PWideString(VAny)^),result); end else {$ifdef HASVARUSTRING} if VType=varByRef or varUString then begin wasString := true; RawUnicodeToUtf8(pointer(PUnicodeString(VAny)^),length(PUnicodeString(VAny)^),result); end else {$endif} VariantSaveJSON(V,twJSONEscape,result); // will handle also custom types end; end; function VariantToUTF8(const V: Variant): RawUTF8; var wasString: boolean; begin VariantToUTF8(V,result,wasString); end; function ToUTF8(const V: Variant): RawUTF8; var wasString: boolean; begin VariantToUTF8(V,result,wasString); end; function VariantToUTF8(const V: Variant; var Text: RawUTF8): boolean; begin VariantToUTF8(V,Text,result); end; function VariantEquals(const V: Variant; const Str: RawUTF8; CaseSensitive: boolean): boolean; function Complex: boolean; var wasString: boolean; tmp: RawUTF8; begin VariantToUTF8(V,tmp,wasString); if CaseSensitive then result := (tmp=Str) else result := IdemPropNameU(tmp,Str); end; var v1,v2: Int64; begin with TVarData(V) do case VType of varEmpty,varNull: result := Str=''; varBoolean: result := VBoolean=(Str<>''); varString: if CaseSensitive then result := RawUTF8(VString)=Str else result := IdemPropNameU(RawUTF8(VString),Str); else if VariantToInt64(V,v1) then begin SetInt64(pointer(Str),v2); result := v1=v2; end else result := Complex; end; end; function VariantToString(const V: Variant): string; var wasString: boolean; tmp: RawUTF8; begin with TVarData(V) do case VType of varEmpty,varNull: result := ''; // default VariantToUTF8(null)='null' {$ifdef UNICODE} // not HASVARUSTRING: here we handle string=UnicodeString varUString: result := UnicodeString(VAny); else if VType=varByRef or varUString then result := PUnicodeString(VAny)^ {$endif} else begin VariantToUTF8(V,tmp,wasString); if tmp='' then result := '' else UTF8DecodeToString(pointer(tmp),length(tmp),result); end; end; end; procedure VariantDynArrayClear(var Value: TVariantDynArray); var p: PDynArrayRec; V: PVarData; i: integer; docv: word; handler: TCustomVariantType; begin if pointer(Value)=nil then exit; p := pointer(PtrUInt(Value)-SizeOf(TDynArrayRec)); // p^ = start of heap object V := pointer(Value); pointer(Value) := nil; if p^.refCnt>1 then begin InterlockedDecrement(PInteger(@p^.refCnt)^); // FPC has refCnt: PtrInt exit; end; handler := nil; docv := DocVariantVType; for i := 1 to p^.length do begin case V^.VType of varEmpty..varDate,varError,varBoolean,varShortInt..varWord64: ; varString: {$ifdef FPC}Finalize(RawUTF8(V^.VAny)){$else}RawUTF8(V^.VAny) := ''{$endif}; varOleStr: WideString(V^.VAny) := ''; {$ifdef HASVARUSTRING} varUString: UnicodeString(V^.VAny) := ''; {$endif} else if V^.VType=docv then DocVariantType.Clear(V^) else if V^.VType=varVariant or varByRef then VarClear(PVariant(V^.VPointer)^) else if handler=nil then if (V^.VType and varByRef=0) and FindCustomVariantType(V^.VType,handler) then handler.Clear(V^) else VarClear(variant(V^)) else if V^.VType=handler.VarType then handler.Clear(V^) else VarClear(variant(V^)); end; inc(V); end; FreeMem(p); end; {$endif NOVARIANTS} {$ifdef UNICODE} // this Pos() is seldom used, it was decided to only define it under // Delphi 2009+ (which expect such a RawUTF8 specific overloaded version) function Pos(const substr, str: RawUTF8): Integer; overload; begin Result := PosEx(substr, str, 1); end; function IntToString(Value: integer): string; var tmp: array[0..23] of AnsiChar; P: PAnsiChar; begin P := StrInt32(@tmp[23],Value); Ansi7ToString(PWinAnsiChar(P),@tmp[23]-P,result); end; function IntToString(Value: cardinal): string; var tmp: array[0..23] of AnsiChar; P: PAnsiChar; begin P := StrUInt32(@tmp[23],Value); Ansi7ToString(PWinAnsiChar(P),@tmp[23]-P,result); end; function IntToString(Value: Int64): string; var tmp: array[0..31] of AnsiChar; P: PAnsiChar; begin P := StrInt64(@tmp[31],Value); Ansi7ToString(PWinAnsiChar(P),@tmp[31]-P,result); end; function DoubleToString(Value: Double): string; var tmp: ShortString; begin if Value=0 then result := '0' else Ansi7ToString(PWinAnsiChar(@tmp[1]), ExtendedToString(tmp,Value,DOUBLE_PRECISION),result); end; function Curr64ToString(Value: Int64): string; var tmp: array[0..31] of AnsiChar; begin Ansi7ToString(tmp,Curr64ToPChar(Value,tmp),result); end; {$else UNICODE} {$ifdef PUREPASCAL} function IntToString(Value: integer): string; var tmp: array[0..23] of AnsiChar; P: PAnsiChar; begin if cardinal(Value)<=high(SmallUInt32UTF8) then result := SmallUInt32UTF8[Value] else begin P := StrInt32(@tmp[23],Value); SetString(result,P,@tmp[23]-P); end; end; {$else} function IntToString(Value: integer): string; asm jmp Int32ToUTF8 end; {$endif PUREPASCAL} function IntToString(Value: cardinal): string; var tmp: array[0..23] of AnsiChar; P: PAnsiChar; begin if Value<=high(SmallUInt32UTF8) then result := SmallUInt32UTF8[Value] else begin P := StrUInt32(@tmp[23],Value); SetString(result,P,@tmp[23]-P); end; end; function IntToString(Value: Int64): string; var tmp: array[0..31] of AnsiChar; P: PAnsiChar; begin if (Value>=0) and (Value<=high(SmallUInt32UTF8)) then result := SmallUInt32UTF8[Value] else begin P := StrInt64(@tmp[31],Value); SetString(result,P,@tmp[31]-P); end; end; function DoubleToString(Value: Double): string; var tmp: ShortString; begin if Value=0 then result := '0' else SetString(result,PAnsiChar(@tmp[1]),ExtendedToString(tmp,Value,DOUBLE_PRECISION)); end; function Curr64ToString(Value: Int64): string; begin result := Curr64ToStr(Value); end; {$endif UNICODE} procedure bswap64array(a,b: PQWordArray; n: PtrInt); {$ifdef CPUX86} {$ifdef FPC}nostackframe; assembler;{$endif} asm push ebx push esi @1: mov ebx, dword ptr[eax] mov esi, dword ptr[eax + 4] bswap ebx bswap esi mov dword ptr[edx + 4], ebx mov dword ptr[edx], esi add eax, 8 add edx, 8 dec ecx jnz @1 pop esi pop ebx end; {$else} {$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe // rcx=@a rdx=@b r8=n (Linux: rdi,rsi,rdx) {$endif FPC} @1: {$ifdef win64} mov rax, qword ptr[rcx] bswap rax mov qword ptr[rdx], rax add rcx, 8 add rdx, 8 dec r8 {$else} mov rax, qword ptr[rdi] bswap rax mov qword ptr[rsi], rax add rdi, 8 add rsi, 8 dec rdx {$endif win64} jnz @1 end; {$else} var i: PtrInt; begin for i := 0 to n-1 do b^[i] := {$ifdef FPC}SwapEndian{$else}bswap64{$endif}(a^[i]); end; {$endif CPUX64} {$endif CPUX86} {$ifdef FPC} function bswap32(a: cardinal): cardinal; begin result := SwapEndian(a); // use fast platform-specific function end; function bswap64(const a: QWord): QWord; begin result := SwapEndian(a); // use fast platform-specific function end; {$else} {$ifdef CPUX64} function bswap32(a: cardinal): cardinal; asm .NOFRAME // ecx=a (Linux: edi) {$ifdef win64} mov eax, ecx {$else} mov eax, edi {$endif win64} bswap eax end; function bswap64(const a: QWord): QWord; asm .NOFRAME // rcx=a (Linux: rdi) {$ifdef win64} mov rax, rcx {$else} mov rax, rdi {$endif win64} bswap rax end; {$else} {$ifdef CPUX86} function bswap32(a: cardinal): cardinal; asm bswap eax end; function bswap64(const a: QWord): QWord; asm mov edx, a.TQWordRec.L mov eax, a.TQWordRec.H bswap edx bswap eax end; {$else} function bswap32(a: cardinal): cardinal; begin result := ((a and $ff)shl 24)or((a and $ff00)shl 8)or ((a and $ff0000)shr 8)or((a and $ff000000)shr 24); end; function bswap64(const a: QWord): QWord; begin TQWordRec(result).L := bswap32(TQWordRec(a).H); TQWordRec(result).H := bswap32(TQWordRec(a).L); end; {$endif CPUX86} {$endif CPUX64} {$endif FPC} {$ifndef PUREPASCAL} { these functions are implemented in asm } {$ifndef LVCL} { don't define these functions twice } {$ifndef FPC} { some asm functions use some low-level system.pas calls } {$define DEFINED_INT32TOUTF8} function Int32ToUTF8(Value : PtrInt): RawUtf8; // 3x faster than SysUtils.IntToStr // from IntToStr32_JOH_IA32_6_a, adapted for Delphi 2009+ asm // eax=Value, edx=@result push ebx push edi push esi mov ebx, eax // value sar ebx, 31 // 0 for +ve value or -1 for -ve value xor eax, ebx sub eax, ebx // abs(value) mov esi, 10 // max dig in result mov edi, edx // @result cmp eax, 10 sbb esi, 0 cmp eax, 100 sbb esi, 0 cmp eax, 1000 sbb esi, 0 cmp eax, 10000 sbb esi, 0 cmp eax, 100000 sbb esi, 0 cmp eax, 1000000 sbb esi, 0 cmp eax, 10000000 sbb esi, 0 cmp eax, 100000000 sbb esi, 0 cmp eax, 1000000000 sbb esi, ebx // esi=dig (including sign character) mov ecx, [edx] // result test ecx, ecx je @newstr // create new string for result cmp dword ptr[ecx - 8], 1 jne @chgstr // reference count <> 1 cmp esi, [ecx - 4] je @lenok // existing length = required length sub ecx, STRRECSIZE // allocation address push eax // abs(value) push ecx mov eax, esp lea edx, [esi + STRRECSIZE + 1] // new allocation size call System.@ReallocMem // reallocate result string pop ecx pop eax // abs(value) add ecx, STRRECSIZE // result mov [ecx - 4], esi // set new length mov byte ptr[ecx + esi], 0 // add null terminator mov [edi], ecx // set result address jmp @lenok @chgstr:mov edx, dword ptr[ecx - 8] // reference count add edx, 1 jz @newstr // refcount = -1 (string constant) lock dec dword ptr[ecx - 8] // decrement existing reference count @newstr:push eax // abs(value) mov eax, esi // length {$ifdef UNICODE} mov edx, CP_UTF8 // utf-8 code page for delphi 2009+ {$endif} call System.@NewAnsiString mov [edi], eax // set result address mov ecx, eax // result pop eax // abs(value) @lenok: mov byte ptr[ecx], '-' // store '-' character (may be overwritten) add esi, ebx // dig (excluding sign character) sub ecx, ebx // destination of 1st dig sub esi, 2 // dig (excluding sign character) - 2 jle @findig // 1 or 2 dig value cmp esi, 8 // 10 dig value? jne @setres // not a 10 dig value sub eax, 2000000000 // dig 10 must be either '1' or '2' mov dl, '2' jnc @set10 // dig 10 = '2' mov dl, '1' // dig 10 = '1' add eax, 1000000000 @set10: mov [ecx], dl // save dig 10 mov esi, 7 // 9 dig remaining add ecx, 1 // destination of 2nd dig @setres:mov edi, $28f5c29 // ((2^32)+100-1)/100 @loop: mov ebx, eax // dividend mul edi // edx = dividend div 100 mov eax, edx // set next dividend imul edx, -200 // -2 * (100 * dividend div 100) movzx edx, word ptr[TwoDigitLookup + ebx * 2 + edx] // dividend mod 100 in ascii mov [ecx + esi], dx sub esi, 2 jg @loop // loop until 1 or 2 dig remaining @findig:pop esi pop edi pop ebx jnz @last movzx eax, word ptr[TwoDigitLookup + eax * 2] mov [ecx], ax // save final 2 dig ret @last: or al, '0' // ascii adjustment mov [ecx], al // save final dig end; function Int64ToUTF8(Value: Int64): RawUtf8; asm // from IntToStr64_JOH_IA32_6_b, adapted for Delphi 2009+ push ebx mov ecx, [ebp + 8] // low integer of val mov edx, [ebp + 12] // high integer of val xor ebp, ebp // clear sign flag (ebp already pushed) mov ebx, ecx // low integer of val test edx, edx jnl @absval mov ebp, 1 // ebp = 1 for -ve val or 0 for +ve val neg ecx adc edx, 0 neg edx @absval:jnz @large // edx:ecx = abs(val) test ecx, ecx js @large mov edx, eax // @result mov eax, ebx // low integer of val call Int32ToUtf8 // call fastest integer inttostr function pop ebx @exit: pop ebp // restore stack and exit ret 8 @large: push edi push esi mov edi, eax xor ebx, ebx xor eax, eax @t15: cmp edx, $00005af3 // test for 15 or more dig jne @chk15 // 100000000000000 div $100000000 cmp ecx, $107a4000 // 100000000000000 mod $100000000 @chk15: jb @t13 @t17: cmp edx, $002386f2 // test for 17 or more dig jne @chk17 // 10000000000000000 div $100000000 cmp ecx, $6fc10000 // 10000000000000000 mod $100000000 @chk17: jb @t1516 @t19: cmp edx, $0de0b6b3 // test for 19 dig jne @chk19 // 1000000000000000000 div $100000000 cmp ecx, $a7640000 // 1000000000000000000 mod $100000000 @chk19: jb @t1718 mov al, 19 jmp @setl2 @t1718: mov bl, 18 // 17 or 18 dig cmp edx, $01634578 // 100000000000000000 div $100000000 jne @setlen cmp ecx, $5d8a0000 // 100000000000000000 mod $100000000 jmp @setlen @t1516: mov bl, 16 // 15 or 16 dig cmp edx, $00038d7e // 1000000000000000 div $100000000 jne @setlen cmp ecx, $a4c68000 // 1000000000000000 mod $100000000 jmp @setlen @t13: cmp edx, $000000e8 // test for 13 or more dig jne @chk13 // 1000000000000 div $100000000 cmp ecx, $d4a51000 // 1000000000000 mod $100000000 @chk13: jb @t11 @t1314: mov bl, 14 // 13 or 14 dig cmp edx, $00000918 // 10000000000000 div $100000000 jne @setlen cmp ecx, $4e72a000 // 10000000000000 mod $100000000 jmp @setlen @t11: cmp edx, $02 // 10, 11 or 12 dig jne @chk11 // 10000000000 div $100000000 cmp ecx, $540be400 // 10000000000 mod $100000000 @chk11: mov bl, 11 jb @setlen // 10 dig @t1112: mov bl, 12 // 11 or 12 dig cmp edx, $17 // 100000000000 div $100000000 jne @setlen cmp ecx, $4876e800 // 100000000000 mod $100000000 @setlen:sbb eax, 0 // adjust for odd/evem digit count add eax, ebx @setl2: push ecx // abs(val) in edx:ecx, dig in eax push edx // save abs(val) lea edx, [eax + ebp] // digit needed (including sign character) mov ecx, [edi] // @result mov esi, edx // digit needed (including sign character) test ecx, ecx je @newstr // create new ansistring for result cmp dword ptr[ecx - 8], 1 jne @chgstr // reference count <> 1 cmp esi, [ecx - 4] je @lenok // existing length = required length sub ecx, STRRECSIZE // allocation address push eax // abs(val) push ecx mov eax, esp lea edx, [esi + STRRECSIZE + 1] // new allocation size call System.@ReallocMem // reallocate result ansistring pop ecx pop eax // abs(val) add ecx, STRRECSIZE // @result mov [ecx - 4], esi // set new length mov byte ptr[ecx + esi], 0 // add null terminator mov [edi], ecx // set result address jmp @lenok @chgstr:mov edx, dword ptr[ecx - 8] // reference count add edx, 1 jz @newstr // refcount = -1 (ansistring constant) lock dec dword ptr[ecx - 8] // decrement existing reference count @newstr:push eax // abs(val) mov eax, esi // length {$ifdef UNICODE} mov edx, CP_UTF8 // utf-8 code page for delphi 2009+ {$endif} call System.@NewAnsiString mov [edi], eax // set result address mov ecx, eax // @result pop eax // abs(val) @lenok: mov edi, [edi] // @result sub esi, ebp // digit needed (excluding sign character) mov byte ptr[edi], '-' // store '-' character (may be overwritten) add edi, ebp // destination of 1st digit pop edx // restore abs(val) pop eax cmp esi, 17 jl @less17 // dig < 17 je @set17 // dig = 17 cmp esi, 18 je @set18 // dig = 18 mov cl, '0' - 1 mov ebx, $a7640000 // 1000000000000000000 mod $100000000 mov ebp, $0de0b6b3 // 1000000000000000000 div $100000000 @dig19: add ecx, 1 sub eax, ebx sbb edx, ebp jnc @dig19 add eax, ebx adc edx, ebp mov [edi], cl add edi, 1 @set18: mov cl, '0' - 1 mov ebx, $5d8a0000 // 100000000000000000 mod $100000000 mov ebp, $01634578 // 100000000000000000 div $100000000 @dig18: add ecx, 1 sub eax, ebx sbb edx, ebp jnc @dig18 add eax, ebx adc edx, ebp mov [edi], cl add edi, 1 @set17: mov cl, '0' - 1 mov ebx, $6fc10000 // 10000000000000000 mod $100000000 mov ebp, $002386f2 // 10000000000000000 div $100000000 @dig17: add ecx, 1 sub eax, ebx sbb edx, ebp jnc @dig17 add eax, ebx adc edx, ebp mov [edi], cl add edi, 1 // update destination mov esi, 16 // set 16 dig left @less17:mov ecx, 100000000 // process next 8 dig div ecx // edx:eax = abs(val) = dividend mov ebp, eax // dividend div 100000000 mov ebx, edx mov eax, edx // dividend mod 100000000 mov edx, $51eb851f mul edx shr edx, 5 // dividend div 100 mov eax, edx // set next dividend lea edx, [edx * 4 + edx] lea edx, [edx * 4 + edx] shl edx, 2 // dividend div 100 * 100 sub ebx, edx // remainder (0..99) movzx ebx, word ptr[TwoDigitLookup + ebx * 2] shl ebx, 16 mov edx, $51eb851f mov ecx, eax // dividend mul edx shr edx, 5 // dividend div 100 mov eax, edx lea edx, [edx * 4 + edx] lea edx, [edx * 4 + edx] shl edx, 2 // dividend div 100 * 100 sub ecx, edx // remainder (0..99) or bx, word ptr[TwoDigitLookup + ecx * 2] mov [edi + esi - 4], ebx // store 4 dig mov ebx, eax mov edx, $51eb851f mul edx shr edx, 5 // edx = dividend div 100 lea eax, [edx * 4 + edx] lea eax, [eax * 4 + eax] shl eax, 2 // eax = dividend div 100 * 100 sub ebx, eax // remainder (0..99) movzx ebx, word ptr[TwoDigitLookup + ebx * 2] movzx ecx, word ptr[TwoDigitLookup + edx * 2] shl ebx, 16 or ebx, ecx mov [edi + esi - 8], ebx // store 4 dig mov eax, ebp // remainder sub esi, 10 // dig left - 2 jz @last2 @small: mov edx, $28f5c29 // ((2^32)+100-1)/100 mov ebx, eax // dividend mul edx mov eax, edx // set next dividend imul edx, -200 movzx edx, word ptr[TwoDigitLookup + ebx * 2 + edx] // dividend mod 100 in ascii mov [edi + esi], dx sub esi, 2 jg @small // repeat until less than 2 dig remaining jz @last2 or al, '0' // ascii adjustment mov [edi], al // save final digit jmp @done @last2: movzx eax, word ptr[TwoDigitLookup + eax * 2] mov [edi], ax // save final 2 dig @done: pop esi pop edi pop ebx end; function Trim(const S: RawUTF8): RawUTF8; asm // fast implementation by John O'Harrow, modified for Delphi 2009+ test eax, eax // S = nil? xchg eax, edx jz System.@LStrClr // Yes, Return Empty String mov ecx, [edx - 4] // Length(S) cmp byte ptr[edx], ' ' // S[1] <= ' '? jbe @left // Yes, Trim Leading Spaces cmp byte ptr[edx + ecx - 1], ' ' // S[Length(S)] <= ' '? jbe @right // Yes, Trim Trailing Spaces jmp System.@LStrLAsg // No, Result := S (which occurs most time) @left: dec ecx // Strip Leading Whitespace jle System.@LStrClr // All Whitespace inc edx cmp byte ptr[edx], ' ' jbe @left @done: cmp byte ptr[edx + ecx - 1], ' ' {$ifdef UNICODE} jbe @right push CP_UTF8 // UTF-8 code page for Delphi 2009+ call System.@LStrFromPCharLen // we need a call, not a jmp here rep ret {$else} ja System.@LStrFromPCharLen {$endif} @right: dec ecx // Strip Trailing Whitespace jmp @done end; {$endif FPC} { above asm function had some low-level system.pas calls } {$endif LVCL} {$endif PUREPASCAL} {$ifdef HASINLINE} function CompareMemFixed(P1, P2: Pointer; Length: PtrInt): Boolean; var i: PtrInt; begin result := false; for i := 0 to (Length shr POINTERSHR)-1 do if PPtrIntArray(P1)[i]<>PPtrIntArray(P2)[i] then exit; for i := Length-(Length and POINTERAND) to Length-1 do if PByteArray(P1)[i]<>PByteArray(P2)[i] then exit; result := true; end; {$endif HASINLINE} function CompareMemSmall(P1, P2: Pointer; Length: PtrInt): Boolean; var i: PtrInt; begin result := false; for i := 0 to Length-1 do if PByteArray(P1)[i]<>PByteArray(P2)[i] then exit; result := true; end; {$ifdef HASINLINE} procedure FillZero(var dest; count: PtrInt); begin {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(dest,count,0); end; {$else} procedure FillZero(var dest; count: PtrInt); asm xor ecx, ecx jmp dword ptr [FillCharFast] end; {$endif} function PosCharAny(Str: PUTF8Char; Characters: PAnsiChar): PUTF8Char; var s: PAnsiChar; c: AnsiChar; begin if (Str<>nil) and (Characters<>nil) and (Characters^<>#0) then repeat c := Str^; if c=#0 then break; s := Characters; repeat if s^=c then begin result := Str; exit; end; inc(s); until s^=#0; inc(Str); until false; result := nil; end; function StringReplaceChars(const Source: RawUTF8; OldChar, NewChar: AnsiChar): RawUTF8; var i,j,n: PtrInt; begin if (OldChar<>NewChar) and (Source<>'') then begin n := length(Source); for i := 0 to n-1 do if PAnsiChar(pointer(Source))[i]=OldChar then begin FastSetString(result,PAnsiChar(pointer(Source)),n); for j := i to n-1 do if PAnsiChar(pointer(result))[j]=OldChar then PAnsiChar(pointer(result))[j] := NewChar; exit; end; end; result := Source; end; function IdemPChar2(table: PNormTable; p: PUTF8Char; up: PAnsiChar): boolean; {$ifdef HASINLINE}inline;{$endif} var u: AnsiChar; begin // here p and up are expected to be <> nil result := false; dec(PtrUInt(p),PtrUInt(up)); repeat u := up^; if u=#0 then break; if table^[up[PtrUInt(p)]]<>u then exit; inc(up); until false; result := true; end; function PosI(uppersubstr: PUTF8Char; const str: RawUTF8): PtrInt; var u: AnsiChar; table: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif}; begin if uppersubstr<>nil then begin {$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7;{$endif} u := uppersubstr^; for result := 1 to Length(str) do if table[str[result]]=u then if {$ifdef CPUX86NOTPIC}IdemPChar({$else}IdemPChar2(table,{$endif} @PUTF8Char(pointer(str))[result],PAnsiChar(uppersubstr)+1) then exit; end; result := 0; end; function StrPosI(uppersubstr,str: PUTF8Char): PUTF8Char; var u: AnsiChar; table: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif}; begin if (uppersubstr<>nil) and (str<>nil) then begin {$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7;{$endif} u := uppersubstr^; result := str; while result^<>#0 do begin if table[result^]=u then if {$ifdef CPUX86NOTPIC}IdemPChar({$else}IdemPChar2(table,{$endif} result+1,PAnsiChar(uppersubstr)+1) then exit; inc(result); end; end; result := nil; end; function PosIU(substr: PUTF8Char; const str: RawUTF8): Integer; var p: PUTF8Char; begin if (substr<>nil) and (str<>'') then begin p := pointer(str); repeat if GetNextUTF8Upper(p)=ord(substr^) then if IdemPCharU(p,substr+1) then begin result := p-pointer(str); exit; end; until p^=#0; end; result := 0; end; procedure AppendCharToRawUTF8(var Text: RawUTF8; Ch: AnsiChar); var L: integer; begin L := length(Text); SetLength(Text,L+1); PByteArray(Text)[L] := ord(Ch); end; procedure AppendBufferToRawUTF8(var Text: RawUTF8; Buffer: pointer; BufferLen: PtrInt); var L: PtrInt; begin if BufferLen<=0 then exit; L := length(Text); SetLength(Text,L+BufferLen); {$ifdef FPC}Move{$else}MoveFast{$endif}(Buffer^,pointer(PtrInt(Text)+L)^,BufferLen); end; procedure AppendBuffersToRawUTF8(var Text: RawUTF8; const Buffers: array of PUTF8Char); var i,len,TextLen: integer; lens: array[0..63] of integer; P: PUTF8Char; begin if high(Buffers)>high(lens) then raise ESynException.Create('Too many params in AppendBuffersToRawUTF8()'); len := 0; for i := 0 to high(Buffers) do begin lens[i] := StrLen(Buffers[i]); inc(len,lens[i]); end; TextLen := Length(Text); SetLength(Text,TextLen+len); P := pointer(Text); inc(P,TextLen); for i := 0 to high(Buffers) do if Buffers[i]<>nil then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(Buffers[i]^,P^,lens[i]); inc(P,lens[i]); end; end; function AppendRawUTF8ToBuffer(Buffer: PUTF8Char; const Text: RawUTF8): PUTF8Char; var L: PtrInt; begin L := length(Text); if L<>0 then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(Pointer(Text)^,Buffer^,L); inc(Buffer,L); end; result := Buffer; end; function AppendUInt32ToBuffer(Buffer: PUTF8Char; Value: cardinal): PUTF8Char; var L: integer; tmp: array[0..23] of AnsiChar; P: PAnsiChar; begin if Value<=high(SmallUInt32UTF8) then result := AppendRawUTF8ToBuffer(Buffer,SmallUInt32UTF8[Value]) else begin P := StrUInt32(@tmp[23],Value); L := @tmp[23]-P; {$ifdef FPC}Move{$else}MoveFast{$endif}(P^,Buffer^,L); result := Buffer+L; end; end; function QuotedStr(const S: RawUTF8; Quote: AnsiChar): RawUTF8; begin QuotedStr(Pointer(S),Quote,result); end; function QuotedStr(Text: PUTF8Char; Quote: AnsiChar): RawUTF8; begin QuotedStr(Text,Quote,result); end; procedure QuotedStr(Text: PUTF8Char; Quote: AnsiChar; var result: RawUTF8); var n, L, first: integer; P: PUTF8Char; label quot; begin n := 0; L := 0; first := n; if Text<>nil then begin P := Text; repeat if P[L]=#0 then break else if P[L]<>Quote then begin inc(L); continue; end; first := L; inc(L); inc(n); repeat if P[L]=#0 then break else if P[L]<>Quote then begin inc(L); continue; end; inc(L); inc(n); until false; break; until false; end; FastSetString(result,nil,L+n+2); P := pointer(Result); P^ := Quote; inc(P); if n=0 then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(Text^,P^,L); inc(P,L); end else begin {$ifdef FPC}Move{$else}MoveFast{$endif}(Text^,P^,first); n := first; L := first; goto quot; repeat if Text[L]=#0 then break else if Text[L]<>Quote then begin P[n] := Text[L]; inc(L); inc(n); end else begin quot: PWord(P+n)^ := ord(Quote)+ord(Quote) shl 8; inc(L); inc(n,2); end; until false; inc(P,n); end; P^ := Quote; //Assert(P-pointer(Result)+1=length(result)); end; function GotoEndOfQuotedString(P: PUTF8Char): PUTF8Char; var quote: AnsiChar; begin // P^=" or P^=' at function call quote := P^; inc(P); repeat if P^=#0 then break else if P^<>quote then inc(P) else if P[1]=quote then // allow double quotes inside string inc(P,2) else break; // end quote until false; result := P; end; // P^='"' at function return procedure QuotedStrJSON(const aText: RawUTF8; var result: RawUTF8; const aPrefix, aSuffix: RawUTF8); var temp: TTextWriterStackBuffer; begin if NeedsJsonEscape(aText) then with TTextWriter.CreateOwnedStream(temp) do try AddString(aPrefix); Add('"'); AddJSONEscape(pointer(aText)); Add('"'); AddString(aSuffix); SetText(result); exit; finally Free; end else result := aPrefix+'"'+aText+'"'+aSuffix; end; function GotoEndOfJSONString(P: PUTF8Char): PUTF8Char; var c: AnsiChar; begin // P^='"' at function call inc(P); repeat c := P^; if c=#0 then break else if c<>'\' then if c<>'"' then // ignore \" inc(P) else break else // found ending " if P[1]=#0 then // avoid potential buffer overflow issue for \#0 break else inc(P,2); // ignore \? until false; result := P; end; // P^='"' at function return function GotoNextNotSpace(P: PUTF8Char): PUTF8Char; begin {$ifdef FPC} while (P^<=' ') and (P^<>#0) do inc(P); {$else} if P^ in [#1..' '] then repeat inc(P) until not(P^ in [#1..' ']); {$endif} result := P; end; function GotoNextSpace(P: PUTF8Char): PUTF8Char; begin if P^>' ' then repeat inc(P) until P^<=' '; result := P; end; function NextNotSpaceCharIs(var P: PUTF8Char; ch: AnsiChar): boolean; begin while (P^<=' ') and (P^<>#0) do inc(P); if P^=ch then begin inc(P); result := true; end else result := false; end; function UnQuoteSQLStringVar(P: PUTF8Char; out Value: RawUTF8): PUTF8Char; var quote: AnsiChar; PBeg, PS: PUTF8Char; n: PtrInt; begin if P=nil then begin result := nil; exit; end; quote := P^; // " or ' inc(P); // compute unquoted string length PBeg := P; n := 0; repeat if P^=#0 then break; if P^<>quote then inc(P) else if P[1]=quote then begin inc(P,2); // allow double quotes inside string inc(n); end else break; // end quote until false; if P^=#0 then begin result := nil; // end of string before end quote -> incorrect exit; end; // create unquoted string if n=0 then // no quote within FastSetString(Value,PBeg,P-PBeg) else begin // unescape internal quotes SetLength(Value,P-PBeg-n); P := PBeg; PS := Pointer(Value); repeat if P^=quote then if P[1]=quote then inc(P) else // allow double quotes inside string break; // end quote PS^ := P^; inc(PByte(PS)); inc(P); until false; end; result := P+1; end; function UnQuoteSQLString(const Value: RawUTF8): RawUTF8; begin UnQuoteSQLStringVar(pointer(Value),result); end; function UnQuotedSQLSymbolName(const ExternalDBSymbol: RawUTF8): RawUTF8; begin if (ExternalDBSymbol<>'') and (ExternalDBSymbol[1] in ['[','"','''','(']) then // e.g. for ZDBC's GetFields() result := copy(ExternalDBSymbol,2,length(ExternalDBSymbol)-2) else result := ExternalDBSymbol; end; function isSelect(P: PUTF8Char; SelectClause: PRawUTF8): boolean; var from: PUTF8Char; begin if P<>nil then begin P := SQLBegin(P); case IdemPCharArray(P, ['SELECT','EXPLAIN ','VACUUM','PRAGMA','WITH']) of 0: if P[6]<=' ' then begin if SelectClause<>nil then begin inc(P,7); from := StrPosI(' FROM ',P); if from=nil then SelectClause^ := '' else FastSetString(SelectClause^,P,from-P); end; result := true; end else result := false; 1: result := true; 2,3: result := P[6] in [#0..' ',';']; 4: result := (P[4]<=' ') and not (ContainsUTF8(P+5,'INSERT') or ContainsUTF8(P+5,'UPDATE') or ContainsUTF8(P+5,'DELETE')); else result := false; end; end else result := true; // assume '' statement is SELECT command end; function SQLBegin(P: PUTF8Char): PUTF8Char; begin if P<>nil then repeat if P^<=' ' then // ignore blanks repeat if P^=#0 then break else inc(P) until P^>' '; if PWord(P)^=ord('-')+ord('-')shl 8 then // SQL comments repeat inc(P) until P^ in [#0,#10] else if PWord(P)^=ord('/')+ord('*')shl 8 then begin // C comments inc(P); repeat inc(P); if PWord(P)^=ord('*')+ord('/')shl 8 then begin inc(P,2); break; end; until P^=#0; end else break; until false; result := P; end; procedure SQLAddWhereAnd(var where: RawUTF8; const condition: RawUTF8); begin if where='' then where := condition else where := where+' and '+condition; end; procedure Base64MagicDecode(var ParamValue: RawUTF8); var tmp: RawUTF8; begin // '\uFFF0base64encodedbinary' decode into binary (input shall have been checked) tmp := ParamValue; if not Base64ToBinSafe(PAnsiChar(pointer(tmp))+3,length(tmp)-3,RawByteString(ParamValue)) then ParamValue := ''; end; function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: RawByteString): boolean; var ValueLen: integer; begin // '\uFFF0base64encodedbinary' checked and decode into binary if (Value=nil) or (Value[0]=#0) or (Value[1]=#0) or (Value[2]=#0) or (PCardinal(Value)^ and $ffffff<>JSON_BASE64_MAGIC) then result := false else begin ValueLen := StrLen(Value)-3; if ValueLen>0 then result := Base64ToBinSafe(PAnsiChar(Value)+3,ValueLen,Blob) else result := false; end; end; function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: TSynTempBuffer): boolean; var ValueLen: integer; begin // '\uFFF0base64encodedbinary' checked and decode into binary if (Value=nil) or (Value[0]=#0) or (Value[1]=#0) or (Value[2]=#0) or (PCardinal(Value)^ and $ffffff<>JSON_BASE64_MAGIC) then result := false else begin ValueLen := StrLen(Value)-3; if ValueLen>0 then result := Base64ToBin(PAnsiChar(Value)+3,ValueLen,Blob) else result := false; end; end; function Base64MagicCheckAndDecode(Value: PUTF8Char; ValueLen: integer; var Blob: RawByteString): boolean; begin // '\uFFF0base64encodedbinary' checked and decode into binary if (ValueLen<4) or (PCardinal(Value)^ and $ffffff<>JSON_BASE64_MAGIC) then result := false else result := Base64ToBinSafe(PAnsiChar(Value)+3,ValueLen-3,Blob); end; {$ifndef DEFINED_INT32TOUTF8} function Int32ToUtf8(Value: PtrInt): RawUTF8; // faster than SysUtils.IntToStr var tmp: array[0..23] of AnsiChar; P: PAnsiChar; begin if PtrUInt(Value)<=high(SmallUInt32UTF8) then result := SmallUInt32UTF8[Value] else begin P := StrInt32(@tmp[23],Value); FastSetString(result,P,@tmp[23]-P); end; end; function Int64ToUtf8(Value: Int64): RawUTF8; // faster than SysUtils.IntToStr begin Int64ToUtf8(Value,result); end; function Trim(const S: RawUTF8): RawUTF8; var I,L: PtrInt; begin L := Length(S); I := 1; while (I<=L) and (S[I]<=' ') do inc(I); if I>L then result := '' else if (I=1) and (S[L]>' ') then result := S else begin while S[L]<=' ' do dec(L); result := Copy(S,I,L-I+1); end; end; {$endif DEFINED_INT32TOUTF8} {$ifndef CPU64} // already implemented by ToUTF8(Value: PtrInt) below function ToUTF8(Value: Int64): RawUTF8; var tmp: array[0..23] of AnsiChar; P: PAnsiChar; begin P := StrInt64(@tmp[23],Value); FastSetString(result,P,@tmp[23]-P); end; {$endif CPU64} function ToUTF8(Value: PtrInt): RawUTF8; var tmp: array[0..23] of AnsiChar; P: PAnsiChar; begin P := StrInt32(@tmp[23],Value); FastSetString(result,P,@tmp[23]-P); end; function UInt32ToUtf8(Value: PtrUInt): RawUTF8; var tmp: array[0..23] of AnsiChar; P: PAnsiChar; begin if Value<=high(SmallUInt32UTF8) then result := SmallUInt32UTF8[Value] else begin P := StrUInt32(@tmp[23],Value); FastSetString(result,P,@tmp[23]-P); end; end; procedure UInt32ToUtf8(Value: PtrUInt; var result: RawUTF8); var tmp: array[0..23] of AnsiChar; P: PAnsiChar; begin if Value<=high(SmallUInt32UTF8) then result := SmallUInt32UTF8[Value] else begin P := StrUInt32(@tmp[23],Value); FastSetString(result,P,@tmp[23]-P); end; end; {$ifndef EXTENDEDTOSTRING_USESTR} var // standard FormatSettings (US) SettingsUS: TFormatSettings; {$endif} function ExtendedToStringNoExp(var S: ShortString; Value: TSynExtended; Precision: integer): integer; var i,prec: integer; begin str(Value:0:Precision,S); // not str(Value:0,S) -> ' 0.0E+0000' // using str() here avoid FloatToStrF() usage -> LVCL is enough result := length(S); prec := result; // if no decimal if S[1]='-' then dec(prec); for i := 2 to result do // test if scientific format -> return as this case S[i] of 'E': exit; // pos('E',S)>0; which Delphi 2009+ doesn't like '.': if i>=precision then begin // return huge decimal number as is result := i-1; exit; end else dec(prec); end; if (prec>=Precision) and (prec<>result) then begin dec(result,prec-Precision); if S[result+1]>'5' then begin // manual rounding prec := result; repeat case S[prec] of '.': ; // just ignore decimal separator '0'..'8': begin inc(S[prec]); break; end; '9': begin S[prec] := '0'; if ((prec=2) and (S[1]='-')) or (prec=1) then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(S[prec],S[prec+1],result); S[prec] := '1'; break; end; end; else break; end; dec(prec); until prec=0; end; // note: this fixes http://stackoverflow.com/questions/2335162 end; while S[result]='0' do begin dec(result); // trunc any trimming 0 if S[result]='.' then begin dec(result); if (result=2) and (S[1]='-') and (S[2]='0') then begin result := 1; S[1] := '0'; // '-0.000' -> '0' end; break; // decimal were all '0' -> return only integer part end; end; end; function ExtendedToString(var S: ShortString; Value: TSynExtended; Precision: integer): integer; {$ifdef EXTENDEDTOSTRING_USESTR} var scientificneeded: boolean; valueabs: TSynExtended; const SINGLE_HI: TSynExtended = 1E9; // for proper Delphi 5 compilation SINGLE_LO: TSynExtended = 1E-9; DOUBLE_HI: TSynExtended = 1E14; DOUBLE_LO: TSynExtended = 1E-14; {$ifndef CPU64} EXT_HI: TSynExtended = 1E17; EXT_LO: TSynExtended = 1E-17; {$endif} begin if Value=0 then begin s[1] := '0'; result := 1; exit; end; scientificneeded := false; valueabs := abs(Value); if Precision<=SINGLE_PRECISION then begin if (valueabs>SINGLE_HI) or (valueabsDOUBLE_PRECISION then begin if (valueabs>EXT_HI) or (valueabsDOUBLE_HI) or (valueabs=high(blocks) then raise ESynException.Create('FormatUTF8: too many args (max=32)!'); L := 0; argN := 0; b := @blocks; F := pointer(Format); repeat if F^<>'%' then begin FDeb := F; while (F^<>'%') and (F^<>#0) do inc(F); b^.Text := FDeb; b^.Len := F-FDeb; b^.TempRawUTF8 := nil; inc(L,b^.Len); inc(b); end; if F^=#0 then break; inc(F); // jump '%' if argN<=high(Args) then begin inc(L,VarRecToTempUTF8(Args[argN],b^)); inc(b); inc(argN); if F^=#0 then break; end else if F^=#0 then break else begin b^.Text := F; // no more available Args -> add all remaining text b^.Len := length(Format)-(F-pointer(Format)); b^.TempRawUTF8 := nil; inc(L,b^.Len); inc(b); break; end; until false; end; procedure TFormatUTF8.Write(Dest: PUTF8Char); var d: PTempUTF8; begin d := @blocks; repeat {$ifdef FPC}Move{$else}MoveFast{$endif}(d^.Text^,Dest^,d^.Len); inc(Dest,d^.Len); if d^.TempRawUTF8<>nil then {$ifdef FPC}Finalize(RawUTF8(d^.TempRawUTF8)){$else}RawUTF8(d^.TempRawUTF8) := ''{$endif}; inc(d); until d=b; end; function TFormatUTF8.WriteMax(Dest: PUTF8Char; Max: PtrUInt): PUTF8Char; var d: PTempUTF8; begin inc(Max,PtrUInt(Dest)); d := @blocks; repeat if PtrUInt(Dest)+PtrUInt(d^.Len)>Max then begin // avoid buffer overflow {$ifdef FPC}Move{$else}MoveFast{$endif}(d^.Text^,Dest^,Max-PtrUInt(Dest)); repeat if d^.TempRawUTF8<>nil then {$ifdef FPC}Finalize(RawUTF8(d^.TempRawUTF8)){$else}RawUTF8(d^.TempRawUTF8) := ''{$endif}; inc(d); until d=b; // avoid memory leak result := PUTF8Char(Max); exit; end; {$ifdef FPC}Move{$else}MoveFast{$endif}(d^.Text^,Dest^,d^.Len); inc(Dest,d^.Len); if d^.TempRawUTF8<>nil then {$ifdef FPC}Finalize(RawUTF8(d^.TempRawUTF8)){$else}RawUTF8(d^.TempRawUTF8) := ''{$endif}; inc(d); until d=b; result := Dest; end; procedure FormatUTF8(const Format: RawUTF8; const Args: array of const; out result: RawUTF8); var process: TFormatUTF8; begin if (Format='') or (high(Args)<0) then // no formatting needed result := Format else if PWord(Format)^=ord('%') then // optimize raw conversion VarRecToUTF8(Args[0],result) else begin process.Parse(Format,Args); if process.L<>0 then begin SetLength(result,process.L); process.Write(pointer(result)); end; end; end; procedure FormatShort(const Format: RawUTF8; const Args: array of const; var result: shortstring); var process: TFormatUTF8; begin if (Format='') or (high(Args)<0) then // no formatting needed SetString(result,PAnsiChar(pointer(Format)),length(Format)) else begin process.Parse(Format,Args); result[0] := AnsiChar(process.WriteMax(@result[1],255)-@result[1]); end; end; function FormatToShort(const Format: RawUTF8; const Args: array of const): shortstring; var process: TFormatUTF8; begin // Delphi 5 has troubles compiling overloaded FormatShort() process.Parse(Format,Args); result[0] := AnsiChar(process.WriteMax(@result[1],255)-@result[1]); end; procedure FormatShort16(const Format: RawUTF8; const Args: array of const; var result: TShort16); var process: TFormatUTF8; begin if (Format='') or (high(Args)<0) then // no formatting needed SetString(result,PAnsiChar(pointer(Format)),length(Format)) else begin process.Parse(Format,Args); result[0] := AnsiChar(process.WriteMax(@result[1],16)-@result[1]); end; end; procedure FormatString(const Format: RawUTF8; const Args: array of const; out result: string); var process: TFormatUTF8; temp: TSynTempBuffer; // will avoid most memory allocations begin if (Format='') or (high(Args)<0) then begin // no formatting needed UTF8DecodeToString(pointer(Format),length(Format),result); exit; end; process.Parse(Format,Args); temp.Init(process.L); process.Write(temp.buf); UTF8DecodeToString(temp.buf,process.L,result); temp.Done; end; function FormatString(const Format: RawUTF8; const Args: array of const): string; begin FormatString(Format,Args,result); end; function FormatUTF8(const Format: RawUTF8; const Args, Params: array of const; JSONFormat: boolean): RawUTF8; var i, tmpN, L, A, P, len: PtrInt; isParam: AnsiChar; tmp: TRawUTF8DynArray; inlin: set of 0..255; F,FDeb: PUTF8Char; wasString: Boolean; const NOTTOQUOTE: array[boolean] of set of 0..31 = ( [vtBoolean,vtInteger,vtInt64{$ifdef FPC},vtQWord{$endif},vtCurrency,vtExtended], [vtBoolean,vtInteger,vtInt64{$ifdef FPC},vtQWord{$endif},vtCurrency,vtExtended,vtVariant]); label Txt; begin if Format='' then begin result := ''; exit; end; if (high(Args)<0) and (high(Params)<0) then begin // no formatting to process, but may be a const -> make unique FastSetString(result,pointer(Format),length(Format)); exit; // e.g. _JsonFmt() will parse it in-place end; if high(Params)<0 then begin FormatUTF8(Format,Args,result); // slightly faster overloaded function exit; end; if Format='%' then begin VarRecToUTF8(Args[0],result); // optimize raw conversion exit; end; result := ''; tmpN := 0; {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(inlin,SizeOf(inlin),0); L := 0; A := 0; P := 0; F := pointer(Format); while F^<>#0 do begin if F^<>'%' then begin FDeb := F; while not (F^ in [#0,'%','?']) do inc(F); Txt: len := F-FDeb; if len>0 then begin inc(L,len); if tmpN=length(tmp) then SetLength(tmp,tmpN+8); FastSetString(tmp[tmpN],FDeb,len); // add inbetween text inc(tmpN); end; end; if F^=#0 then break; isParam := F^; inc(F); // jump '%' or '?' if (isParam='%') and (A<=high(Args)) then begin // handle % substitution if tmpN=length(tmp) then SetLength(tmp,tmpN+8); VarRecToUTF8(Args[A],tmp[tmpN]); inc(A); if tmp[tmpN]<>'' then begin inc(L,length(tmp[tmpN])); inc(tmpN); end; end else if (isParam='?') and (P<=high(Params)) then begin // handle ? substitution if tmpN=length(tmp) then SetLength(tmp,tmpN+8); {$ifndef NOVARIANTS} if JSONFormat and (Params[P].VType=vtVariant) then VariantSaveJSON(Params[P].VVariant^,twJSONEscape,tmp[tmpN]) else {$endif} begin VarRecToUTF8(Params[P],tmp[tmpN]); wasString := not (Params[P].VType in NOTTOQUOTE[JSONFormat]); if wasString then if JSONFormat then QuotedStrJSON(tmp[tmpN],tmp[tmpN]) else tmp[tmpN] := QuotedStr(pointer(tmp[tmpN]),''''); if not JSONFormat then begin inc(L,4); // space for :(): include(inlin,tmpN); end; end; inc(P); inc(L,length(tmp[tmpN])); inc(tmpN); end else if F^<>#0 then begin // no more available Args -> add all remaining text FDeb := F; repeat inc(F) until (F^=#0); goto Txt; end; end; if L=0 then exit; if not JSONFormat and (tmpN>SizeOf(inlin)shl 3) then raise ESynException.CreateUTF8( 'Too many parameters for FormatUTF8(): %>%',[tmpN,SizeOf(inlin)shl 3]); SetLength(result,L); F := pointer(result); for i := 0 to tmpN-1 do if tmp[i]<>'' then begin if i in inlin then begin PWord(F)^ := ord(':')+ord('(')shl 8; inc(F,2); end; L := {$ifdef FPC}_LStrLen(tmp[i]){$else}PInteger(PtrInt(tmp[i])-SizeOf(integer))^{$endif}; {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(tmp[i])^,F^,L); inc(F,L); if i in inlin then begin PWord(F)^ := ord(')')+ord(':')shl 8; inc(F,2); end; end; end; function ScanUTF8(P: PUTF8Char; PLen: integer; const fmt: RawUTF8; const values: array of pointer; ident: PRawUTF8DynArray): integer; var v,w: PtrInt; F,FEnd,PEnd: PUTF8Char; label next; begin result := 0; if (fmt='') or (P=nil) or (PLen<=0) or (high(values)<0) then exit; if ident<>nil then SetLength(ident^,length(values)); F := pointer(fmt); FEnd := F+length(fmt); PEnd := P+PLen; for v := 0 to high(values) do repeat if (P^<=' ') and (P^<>#0) then // ignore any whitespace char in text repeat inc(P); if P=PEnd then exit; until (P^>' ') or (P^=#0); if F^ in [#1..' '] then // ignore any whitespace char in fmt repeat inc(F); if F=FEnd then exit; until not (F^ in [#1..' ']); if F^='%' then begin // format specifier inc(F); if F=FEnd then exit; case F^ of 'd': PInteger(values[v])^ := GetNextItemInteger(P,#0); 'D': PInt64(values[v])^ := GetNextItemInt64(P,#0); 'u': PCardinal(values[v])^ := GetNextItemCardinal(P,#0); 'U': PQword(values[v])^ := GetNextItemQword(P,#0); 'f': PDouble(values[v])^ := GetNextItemDouble(P,#0); 'F': GetNextItemCurrency(P,PCurrency(values[v])^,#0); 'x': if not GetNextItemHexDisplayToBin(P,values[v],4,#0) then exit; 'X': if not GetNextItemHexDisplayToBin(P,values[v],8,#0) then exit; 's','S': begin w := 0; while (P[w]>' ') and (P+w<=PEnd) do inc(w); if F^='s' then SetString(PShortString(values[v])^,PAnsiChar(P),w) else FastSetString(PRawUTF8(values[v])^,P,w); inc(P,w); while (P^<=' ') and (P^<>#0) and (P<=PEnd) do inc(P); end; 'L': begin w := 0; while not(P[w] in [#0,#10,#13]) and (P+w<=PEnd) do inc(w); FastSetString(PRawUTF8(values[v])^,P,w); inc(P,w); end; '%': goto next; else raise ESynException.CreateUTF8('ScanUTF8: unknown ''%'' specifier [%]',[F^,fmt]); end; inc(result); if (ord(F[1]) in IsIdentifier) or (ident<>nil) then begin w := 0; repeat inc(w) until not(ord(F[w]) in IsIdentifier) or (F+w=FEnd); if ident<>nil then FastSetString(ident^[v],F,w); inc(F,w); end else inc(F); if (F>=FEnd) or (P>=PEnd) then exit; break; end else begin next: while (P^<>F^) and (P<=PEnd) do inc(P); inc(F); inc(P); if (F>=FEnd) or (P>=PEnd) then exit; end; until false; end; function ScanUTF8(const text, fmt: RawUTF8; const values: array of pointer; ident: PRawUTF8DynArray): integer; begin result := ScanUTF8(pointer(text),length(text),fmt,values,ident); end; function RawByteStringArrayConcat(const Values: array of RawByteString): RawByteString; var i, L: PtrInt; P: PAnsiChar; begin L := 0; for i := 0 to high(Values) do inc(L,length(Values[i])); SetString(Result,nil,L); P := pointer(Result); for i := 0 to high(Values) do begin L := length(Values[i]); {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(Values[i])^,P^,L); inc(P,L); end; end; procedure RawByteStringToBytes(const buf: RawByteString; out bytes: TBytes); var L: Integer; begin L := Length(buf); if L<>0 then begin SetLength(bytes,L); {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(buf)^,pointer(bytes)^,L); end; end; procedure BytesToRawByteString(const bytes: TBytes; out buf: RawByteString); begin SetString(buf,PAnsiChar(pointer(bytes)),Length(bytes)); end; procedure ResourceToRawByteString(const ResName: string; ResType: PChar; out buf: RawByteString; Instance: THandle); var HResInfo: THandle; HGlobal: THandle; begin if Instance=0 then Instance := HInstance; HResInfo := FindResource(Instance,PChar(ResName),ResType); if HResInfo=0 then exit; HGlobal := LoadResource(Instance,HResInfo); if HGlobal<>0 then begin SetString(buf,PAnsiChar(LockResource(HGlobal)),SizeofResource(Instance,HResInfo)); UnlockResource(HGlobal); // only needed outside of Windows FreeResource(HGlobal); end; end; procedure ResourceSynLZToRawByteString(const ResName: string; out buf: RawByteString; Instance: THandle); var HResInfo: THandle; HGlobal: THandle; begin if Instance=0 then Instance := HInstance; HResInfo := FindResource(Instance,PChar(ResName),PChar(10)); if HResInfo=0 then exit; HGlobal := LoadResource(Instance,HResInfo); if HGlobal<>0 then // direct decompression from memory mapped .exe content try AlgoSynLZ.Decompress(LockResource(HGlobal),SizeofResource(Instance,HResInfo),buf); finally UnlockResource(HGlobal); // only needed outside of Windows FreeResource(HGlobal); end; end; function StrLenW(S: PWideChar): PtrInt; begin result := 0; if S<>nil then while true do if S[result+0]<>#0 then if S[result+1]<>#0 then if S[result+2]<>#0 then if S[result+3]<>#0 then inc(result,4) else begin inc(result,3); exit; end else begin inc(result,2); exit; end else begin inc(result); exit; end else exit; end; function StrCompW(Str1, Str2: PWideChar): PtrInt; begin if Str1<>Str2 then if Str1<>nil then if Str2<>nil then begin if Str1^=Str2^ then repeat if (Str1^=#0) or (Str2^=#0) then break; inc(Str1); inc(Str2); until Str1^<>Str2^; result := PWord(Str1)^-PWord(Str2)^; exit; end else result := 1 else // Str2='' result := -1 else // Str1='' result := 0; // Str1=Str2 end; {$ifdef PUREPASCAL} function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean; // if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper) var table: PNormTable; u: AnsiChar; begin result := false; if p=nil then exit; if up<>nil then begin dec(PtrUInt(p),PtrUInt(up)); table := @NormToUpperAnsi7; repeat u := up^; if u=#0 then break; if u<>table^[up[PtrUInt(p)]] then exit; inc(up); until false; end; result := true; end; function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt; var i: PtrInt; // very optimized code for speed begin if P<>nil then begin result := 0; for i := 1 to Count shr 2 do // 4 DWORD by loop - aligned read if P^[0]<>Value then if P^[1]<>Value then if P^[2]<>Value then if P^[3]<>Value then begin inc(PByte(P),SizeOf(P^[0])*4); inc(result,4); end else begin inc(result,3); exit; end else begin inc(result,2); exit; end else begin inc(result,1); exit; end else exit; for i := 0 to (Count and 3)-1 do // last 0..3 DWORD if P^[i]=Value then exit else inc(result); end; result := -1; end; function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal; var i: PtrInt; begin // very optimized code if P<>nil then begin for i := 1 to Count shr 2 do // 4 DWORD by loop - aligned read if P^[0]<>Value then if P^[1]<>Value then if P^[2]<>Value then if P^[3]=Value then begin result := @P^[3]; exit; end else inc(PByte(P),SizeOf(P^[0])*4) else begin result := @P^[2]; exit; end else begin result := @P^[1]; exit; end else begin result := pointer(P); exit; end; for i := 0 to (Count and 3)-1 do // last 0..3 DWORD if P^[i]=Value then begin result := @P^[i]; exit; end; end; result := nil; end; function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean; var i: PtrInt; // very optimized code for speed begin if P<>nil then begin result := true; for i := 1 to (Count shr 2) do // 4 DWORD by loop - aligned read if (P^[0]=Value) or (P^[1]=Value) or (P^[2]=Value) or (P^[3]=Value) then exit else inc(PByte(P),SizeOf(P^[0])*4); for i := 0 to (Count and 3)-1 do // last 0..3 DWORD if P^[i]=Value then exit; end; result := false; end; function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char; var c: cardinal; begin // FPC is efficient at compiling this code result := nil; if Str<>nil then begin repeat c := PCardinal(str)^; if ToByte(c)=0 then exit else if ToByte(c)=byte(Chr) then break; c := c shr 8; inc(Str); if ToByte(c)=0 then exit else if ToByte(c)=byte(Chr) then break; c := c shr 8; inc(Str); if ToByte(c)=0 then exit else if ToByte(c)=byte(Chr) then break; c := c shr 8; inc(Str); if ToByte(c)=0 then exit else if ToByte(c)=byte(Chr) then break; inc(Str); until false; result := Str; end; end; function CompareMem(P1, P2: Pointer; Length: PtrInt): Boolean; label zero; begin // this code compiles well under FPC and Delphi on both 32-bit and 64-bit inc(Length,PtrInt(PtrUInt(P1))-SizeOf(PtrInt)*2); if Length>=PtrInt(PtrUInt(P1)) then begin if PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^ then goto zero; inc(PtrInt(PtrUInt(P1)),SizeOf(PtrInt)); inc(PtrInt(P2),SizeOf(PtrInt)); dec(PtrInt(P2),PtrInt(PtrUInt(P1))); PtrInt(PtrUInt(P1)) := PtrInt(PtrUInt(P1)) and -SizeOf(PtrInt); inc(PtrInt(P2),PtrInt(PtrUInt(P1))); if Length>=PtrInt(PtrUInt(P1)) then repeat // compare 4 aligned PtrInt per loop if (PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^) or (PPtrIntArray(P1)[1]<>PPtrIntArray(P2)[1]) then goto zero; inc(PtrInt(PtrUInt(P1)),SizeOf(PtrInt)*2); inc(PtrInt(P2),SizeOf(PtrInt)*2); if LengthPPtrInt(P2)^) or (PPtrIntArray(P1)[1]<>PPtrIntArray(P2)[1]) then goto zero; inc(PtrInt(PtrUInt(P1)),SizeOf(PtrInt)*2); inc(PtrInt(P2),SizeOf(PtrInt)*2); until Length=SizeOf(PtrInt) then begin if PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^ then goto zero; inc(PtrInt(PtrUInt(P1)),SizeOf(PtrInt)); inc(PtrInt(P2),SizeOf(PtrInt)); dec(Length,SizeOf(PtrInt)); end; {$ifdef CPU64} if Length>=4 then begin if PCardinal(P1)^<>PCardinal(P2)^ then goto zero; inc(PtrInt(PtrUInt(P1)),4); inc(PtrInt(P2),4); dec(Length,4); end; {$endif} if Length>=2 then begin if PWord(P1)^<>PWord(P2)^ then goto zero; inc(PtrInt(PtrUInt(P1)),2); inc(PtrInt(P2),2); dec(Length,2); end; if Length>=1 then if PByte(P1)^<>PByte(P2)^ then goto zero; result := true; exit; zero: result := false; end; {$ifdef HASINLINE} // to use directly the SubStr/S arguments registers function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt): PtrInt; begin result := PosExPas(pointer(SubStr),pointer(S),Offset); end; {$endif HASINLINE} // from Aleksandr Sharahov's PosEx_Sha_Pas_2() - refactored for cross-platform function PosExPas(pSub, p: PUTF8Char; Offset: PtrUInt): PtrInt; var len, lenSub: PtrInt; ch: AnsiChar; pStart, pStop: PUTF8Char; label Loop2, Loop6, TestT, Test0, Test1, Test2, Test3, Test4, AfterTestT, AfterTest0, Ret, Exit; begin result := 0; if (p=nil) or (pSub=nil) or (Offset<1) then goto Exit; {$ifdef FPC} len := _LStrLenP(p); lenSub := _LStrLenP(pSub)-1; {$else} len := PInteger(p-4)^; lenSub := PInteger(pSub-4)^-1; {$endif} if (len=pStop then goto Exit; goto Loop2; Test4: dec(p,2); Test2: dec(p,2); goto Test0; Test3: dec(p,2); Test1: dec(p,2); TestT: len := lenSub; if lenSub<>0 then repeat if (psub[len]<>p[len+1]) or (psub[len+1]<>p[len+2]) then goto AfterTestT; inc(len,2); until len>=0; inc(p,2); if p<=pStop then goto Ret; goto Exit; Test0: len := lenSub; if lenSub<>0 then repeat if (psub[len]<>p[len]) or (psub[len+1]<>p[len+1]) then goto AfterTest0; inc(len,2); until len>=0; inc(p); Ret: result := p-pStart; Exit: end; function IdemPropNameU(const P1,P2: RawUTF8): boolean; var L: PtrInt; begin L := length(P1); if length(P2)=L then result := IdemPropNameUSameLen(pointer(P1),pointer(P2),L) else result := false; end; function StrIComp(Str1, Str2: pointer): PtrInt; var C1,C2: PtrInt; lookupper: PByteArray; // better x86-64 / PIC asm generation begin result := PtrInt(PtrUInt(Str2))-PtrInt(PtrUInt(Str1)); if result<>0 then if Str1<>nil then if Str2<>nil then begin lookupper := @NormToUpperAnsi7Byte; repeat C1 := PByteArray(Str1)[0]; C2 := PByteArray(Str1)[result]; inc(PByte(Str1)); if C1=0 then break; if C1=C2 then continue; // fast optimistic loop for exact chars match C1 := lookupper[C1]; C2 := lookupper[C2]; if C1<>C2 then break; // no branch taken if first chars differ until false; // slower "continue" above if "until C1<>C2" result := C1-C2; end else result := 1 else // Str2='' result := -1; // Str1='' end; function StrLenPas(S: pointer): PtrInt; begin result := 0; if S<>nil then while true do if PAnsiChar(S)[result+0]<>#0 then if PAnsiChar(S)[result+1]<>#0 then if PAnsiChar(S)[result+2]<>#0 then if PAnsiChar(S)[result+3]<>#0 then inc(result,4) else begin inc(result,3); exit; end else begin inc(result,2); exit; end else begin inc(result); exit; end else exit; end; function StrCompFast(Str1, Str2: pointer): PtrInt; var c: byte; begin if Str1<>Str2 then if Str1<>nil then if Str2<>nil then begin c := PByte(Str1)^; if c=PByte(Str2)^ then repeat if c=0 then break; inc(PByte(Str1)); inc(PByte(Str2)); c := PByte(Str1)^; until c<>PByte(Str2)^; result := c-PByte(Str2)^; exit; end else result := 1 else // Str2='' result := -1 else // Str1='' result := 0; // Str1=Str2 end; procedure YearToPChar(Y: PtrUInt; P: PUTF8Char); var d100: PtrUInt; tab: PWordArray; begin tab := @TwoDigitLookupW; d100 := Y div 100; PWordArray(P)[0] := tab[d100]; PWordArray(P)[1] := tab[Y-(d100*100)]; end; procedure YearToPChar2(tab: PWordArray; Y: PtrUInt; P: PUTF8Char); {$ifdef HASINLINE}inline;{$endif} var d100: PtrUInt; begin d100 := Y div 100; PWordArray(P)[0] := tab[d100]; PWordArray(P)[1] := tab[Y-(d100*100)]; end; function Iso8601ToTimeLog(const S: RawByteString): TTimeLog; begin result := Iso8601ToTimeLogPUTF8Char(pointer(S),length(S)); end; function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; var s: PAnsiChar; c: cardinal; begin s := pointer(source); if s<>nil then repeat c := ord(s^); if c=0 then break else dest^ := AnsiChar(NormToUpperAnsi7Byte[c]); inc(s); inc(dest); until false; result := dest; end; function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar; var i: PtrInt; begin for i := 1 to ord(source[0]) do begin dest^ := AnsiChar(NormToUpperAnsi7Byte[ord(source[i])]); inc(dest); end; result := dest; end; function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean; begin if source=nil then result := false else begin result := IdemPChar(source,searchUp); source := GotoNextLine(source); end; end; function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; var i: PtrInt; begin if buf<>nil then for i := 0 to len-1 do crc := (crc xor ord(buf[i]))*16777619; result := crc; end; function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; var i: PtrInt; begin for i := 0 to len-1 do crc := ord(buf[i])+crc*31; result := crc; end; procedure crcblockNoSSE42(crc128, data128: PBlock128); var c: cardinal; tab: ^TCrc32tab; begin tab := @crc32ctab; c := crc128^[0] xor data128^[0]; crc128^[0] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] xor tab[1,ToByte(c shr 16)] xor tab[0,c shr 24]; c := crc128^[1] xor data128^[1]; crc128^[1] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] xor tab[1,ToByte(c shr 16)] xor tab[0,c shr 24]; c := crc128^[2] xor data128^[2]; crc128^[2] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] xor tab[1,ToByte(c shr 16)] xor tab[0,c shr 24]; c := crc128^[3] xor data128^[3]; crc128^[3] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] xor tab[1,ToByte(c shr 16)] xor tab[0,c shr 24]; end; function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; var tab: ^TCrc32tab; begin tab := @crc32ctab; result := not crc; if (buf<>nil) and (len>0) then begin repeat if PtrUInt(buf) and 3=0 then // align to 4 bytes boundary break; result := tab[0,ToByte(result xor ord(buf^))] xor (result shr 8); dec(len); inc(buf); until len=0; if len>=4 then repeat result := result xor PCardinal(buf)^; inc(buf,4); dec(len,4); result := tab[3,ToByte(result)] xor tab[2,ToByte(result shr 8)] xor tab[1,ToByte(result shr 16)] xor tab[0,result shr 24]; until len<4; while len>0 do begin result := tab[0,ToByte(result xor ord(buf^))] xor (result shr 8); dec(len); inc(buf); end; end; result := not result; end; function ToVarInt32(Value: PtrInt; Dest: PByte): PByte; begin // 0=0,1=1,2=-1,3=2,4=-2... if Value<0 then // -1->2, -2->4.. Value := (-Value) shl 1 else if Value>0 then // 1->1, 2->3.. Value := (Value shl 1)-1; // 0->0 result := ToVarUInt32(Value,Dest); end; function ToVarUInt32(Value: PtrUInt; Dest: PByte): PByte; label _1,_2,_3; // ugly but fast begin if Value>$7f then begin if Value<$80 shl 7 then goto _1 else if Value<$80 shl 14 then goto _2 else if Value<$80 shl 21 then goto _3; Dest^ := (Value and $7F) or $80; Value := Value shr 7; inc(Dest); _3: Dest^ := (Value and $7F) or $80; Value := Value shr 7; inc(Dest); _2: Dest^ := (Value and $7F) or $80; Value := Value shr 7; inc(Dest); _1: Dest^ := (Value and $7F) or $80; Value := Value shr 7; inc(Dest); end; Dest^ := Value; inc(Dest); result := Dest; end; function SortDynArrayInteger(const A,B): integer; begin if integer(A)integer(B) then result := 1 else result := 0; end; function SortDynArrayInt64(const A,B): integer; {$ifdef CPU64} begin if Int64(A)Int64(B) then result := 1 else result := 0; end; {$else} var tmp: Int64; begin tmp := Int64(A)-Int64(B); if tmp<0 then result := -1 else if tmp>0 then result := 1 else result := 0; end; {$endif CPU64} function SortDynArrayQWord(const A,B): integer; begin {$ifdef CPU64} if QWord(A)QWord(B) then {$else} if PQWord(@A)PQWord(@B) then {$endif CPU64} result := 1 else result := 0; end; function CompareQWord(A, B: QWord): integer; begin if AB then result := 1 else result := 0; end; function SortDynArrayAnsiString(const A,B): integer; begin result := StrComp(pointer(A),pointer(B)); end; function SortDynArrayAnsiStringI(const A,B): integer; begin result := StrIComp(PUTF8Char(A),PUTF8Char(B)); end; function SortDynArrayRawByteString(const A,B): integer; var p1,p2: PByteArray; l1,l2,i,l: PtrInt; // FPC uses efficiently the CPU registers begin // we can't use StrComp() since a RawByteString may contain #0 p1 := pointer(A); p2 := pointer(B); if p1<>p2 then if p1<>nil then if p2<>nil then begin l1 := PStrRec(Pointer(PtrUInt(p1)-STRRECSIZE))^.length; l2 := PStrRec(Pointer(PtrUInt(p2)-STRRECSIZE))^.length; l := l1; if l20 then exit; inc(i); until i>=l; result := l1-l2; end else result := 1 else // p2='' result := -1 else // p1='' result := 0; // p1=p2 end; function SortDynArrayPUTF8Char(const A,B): integer; begin result := StrComp(pointer(A),pointer(B)); end; {$else PUREPASCAL} function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean; {$ifdef FPC}nostackframe; assembler;{$endif} asm test eax, eax jz @e // P=nil -> false test edx, edx push ebx jz @t // up=nil -> true xor ebx, ebx @1: mov ecx, [edx] // optimized for DWORD aligned read up^ test cl, cl mov bl, [eax] jz @t // up^[0]=#0 -> OK cmp cl, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[0]] jne @f mov bl, [eax + 1] test ch, ch jz @t // up^[1]=#0 -> OK cmp ch, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[1]] jne @f shr ecx, 16 // cl=up^[2] ch=up^[3] mov bl, [eax + 2] test cl, cl jz @t // up^[2]=#0 -> OK cmp cl, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[2]] jne @f mov bl, [eax + 3] add eax, 4 add edx, 4 test ch, ch jz @t // up^[3]=#0 -> OK cmp ch, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[3]] je @1 @f: pop ebx // NormToUpperAnsi7[p^]<>up^ -> FALSE @e: xor eax, eax ret @t: pop ebx // up^=#0 -> TRUE mov al, 1 end; function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt; {$ifdef FPC}nostackframe; assembler;{$endif} asm push eax call IntegerScan pop edx test eax, eax jnz @e dec eax // returns -1 ret @e: sub eax, edx shr eax, 2 end; function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal; {$ifdef FPC}nostackframe; assembler;{$endif} asm // eax=P, edx=Count, Value=ecx test eax, eax jz @ok0 // avoid GPF cmp edx, 8 jb @s2 nop nop nop // @s1 loop align @s1: sub edx, 8 cmp [eax], ecx je @ok0 cmp [eax + 4], ecx je @ok4 cmp [eax + 8], ecx je @ok8 cmp [eax + 12], ecx je @ok12 cmp [eax + 16], ecx je @ok16 cmp [eax + 20], ecx je @ok20 cmp [eax + 24], ecx je @ok24 cmp [eax + 28], ecx je @ok28 add eax, 32 cmp edx, 8 jae @s1 @s2: test edx, edx jz @z cmp [eax], ecx je @ok0 dec edx jz @z cmp [eax + 4], ecx je @ok4 dec edx jz @z cmp [eax + 8], ecx je @ok8 dec edx jz @z cmp [eax + 12], ecx je @ok12 dec edx jz @z cmp [eax + 16], ecx je @ok16 dec edx jz @z cmp [eax + 20], ecx je @ok20 dec edx jz @z cmp [eax + 24], ecx je @ok24 @z: xor eax, eax // return nil if not found ret @ok0: rep ret @ok28: add eax, 28 ret @ok24: add eax, 24 ret @ok20: add eax, 20 ret @ok16: add eax, 16 ret @ok12: add eax, 12 ret @ok8: add eax, 8 ret @ok4: add eax, 4 end; function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean; {$ifdef FPC}nostackframe; assembler;{$endif} asm // eax=P, edx=Count, Value=ecx test eax, eax jz @z // avoid GPF cmp edx, 8 jae @s1 jmp dword ptr[edx * 4 + @Table] @Table: dd @z, @1, @2, @3, @4, @5, @6, @7 @s1: // fast search by 8 integers (pipelined instructions) sub edx, 8 cmp [eax], ecx je @ok cmp [eax + 4], ecx je @ok cmp [eax + 8], ecx je @ok cmp [eax + 12], ecx je @ok cmp [eax + 16], ecx je @ok cmp [eax + 20], ecx je @ok cmp [eax + 24], ecx je @ok cmp [eax + 28], ecx je @ok add eax, 32 cmp edx, 8 jae @s1 jmp dword ptr[edx * 4 + @Table] @7: cmp [eax + 24], ecx je @ok @6: cmp [eax + 20], ecx je @ok @5: cmp [eax + 16], ecx je @ok @4: cmp [eax + 12], ecx je @ok @3: cmp [eax + 8], ecx je @ok @2: cmp [eax + 4], ecx je @ok @1: cmp [eax], ecx je @ok @z: xor eax, eax ret @ok: mov al, 1 end; function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char; {$ifdef FPC}nostackframe; assembler;{$endif} asm // faster version by AB - eax=Str dl=Chr test eax, eax jz @z @1: mov ecx, dword ptr [eax] cmp cl, dl je @z inc eax test cl, cl jz @e cmp ch, dl je @z inc eax test ch, ch jz @e shr ecx, 16 cmp cl, dl je @z inc eax test cl, cl jz @e cmp ch, dl je @z inc eax test ch, ch jnz @1 @e: xor eax, eax ret @z: db $f3 // rep ret end; function CompareMem(P1, P2: Pointer; Length: PtrInt): Boolean; {$ifdef FPC}nostackframe; assembler;{$endif} asm // eax=P1 edx=P2 ecx=Length cmp eax, edx je @0 // P1=P2 sub ecx, 8 jl @small push ebx mov ebx, [eax] // Compare First 4 Bytes cmp ebx, [edx] jne @setbig lea ebx, [eax + ecx] // Compare Last 8 Bytes add edx, ecx mov eax, [ebx] cmp eax, [edx] jne @setbig mov eax, [ebx + 4] cmp eax, [edx + 4] jne @setbig sub ecx, 4 jle @true // All Bytes already Compared neg ecx // ecx=-(Length-12) add ecx, ebx // DWORD Align Reads and ecx, -4 sub ecx, ebx @loop: mov eax, [ebx + ecx] // Compare 8 Bytes per Loop cmp eax, [edx + ecx] jne @setbig mov eax, [ebx + ecx + 4] cmp eax, [edx + ecx + 4] jne @setbig add ecx, 8 jl @loop @true: pop ebx @0: mov al, 1 ret @setbig:pop ebx setz al ret @small: add ecx, 8 // ecx=0..7 jle @0 // Length <= 0 neg ecx // ecx=-1..-7 lea ecx, [@1 + ecx * 8 + 8] // each @#: block below = 8 bytes jmp ecx @7: mov cl, [eax + 6] cmp cl, [edx + 6] jne @setsml @6: mov ch, [eax + 5] cmp ch, [edx + 5] jne @setsml @5: mov cl, [eax + 4] cmp cl, [edx + 4] jne @setsml @4: mov ch, [eax + 3] cmp ch, [edx + 3] jne @setsml @3: mov cl, [eax + 2] cmp cl, [edx + 2] jne @setsml @2: mov ch, [eax + 1] cmp ch, [edx + 1] jne @setsml @1: mov al, [eax] cmp al, [edx] @setsml:setz al end; function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt): integer; {$ifdef FPC}nostackframe; assembler;{$endif} asm // eax=SubStr, edx=S, ecx=Offset push ebx push esi push edx test eax, eax jz @notfnd // exit if SubStr='' test edx, edx jz @notfnd // exit if S='' mov esi, ecx mov ecx, [edx - 4] // length(S) mov ebx, [eax - 4] // length(SubStr) add ecx, edx sub ecx, ebx // ecx = max start pos for full match lea edx, [edx + esi - 1] // edx = start position cmp edx, ecx jg @notfnd // startpos > max start pos cmp ebx, 1 jle @onec // optimized loop for length(SubStr)<=1 push edi push ebp lea edi, [ebx - 2] // edi = length(SubStr)-2 mov esi, eax // esi = SubStr movzx ebx, byte ptr[eax] // bl = search character nop; nop @l: cmp bl, [edx] // compare 2 characters per @l je @c1fnd @notc1: cmp bl, [edx + 1] je @c2fnd @notc2: add edx, 2 cmp edx, ecx // next start position <= max start position jle @l pop ebp pop edi @notfnd:xor eax, eax // returns 0 if not fnd pop edx pop esi pop ebx ret @c1fnd: mov ebp, edi // ebp = length(SubStr)-2 @c1l: movzx eax, word ptr[esi + ebp] cmp ax, [edx + ebp] // compare 2 chars per @c1l (may include #0) jne @notc1 sub ebp, 2 jnc @c1l pop ebp pop edi jmp @setres @c2fnd: mov ebp, edi // ebp = length(SubStr)-2 @c2l: movzx eax, word ptr[esi + ebp] cmp ax, [edx + ebp + 1] // compare 2 chars per @c2l (may include #0) jne @notc2 sub ebp, 2 jnc @c2l pop ebp pop edi jmp @chkres @onec: jl @notfnd // needed for zero-length non-nil strings movzx eax, byte ptr[eax] // search character @charl: cmp al, [edx] je @setres cmp al, [edx + 1] je @chkres add edx, 2 cmp edx, ecx jle @charl jmp @notfnd @chkres:cmp edx, ecx // check within ansistring jge @notfnd add edx, 1 @setres:pop ecx // ecx = S pop esi pop ebx neg ecx lea eax, [edx + ecx + 1] end; function IdemPropNameU(const P1,P2: RawUTF8): boolean; {$ifdef FPC}nostackframe; assembler;{$endif} asm // eax=p1, edx=p2 cmp eax, edx je @out1 test eax, edx jz @maybenil @notnil:mov ecx, [eax - 4] // compare lengths cmp ecx, [edx - 4] jne @out1 push ebx lea edx, [edx + ecx - 4] // may include the length for shortest strings lea ebx, [eax + ecx - 4] neg ecx mov eax, [ebx] // compare last 4 chars xor eax, [edx] and eax, $dfdfdfdf // case insensitive jne @out2 @by4: add ecx, 4 jns @match mov eax, [ebx + ecx] xor eax, [edx + ecx] and eax, $dfdfdfdf // case insensitive je @by4 @out2: pop ebx @out1: setz al ret @match: mov al, 1 pop ebx ret @maybenil: // here we know that eax<>edx test eax, eax jz @nil0 // eax=nil and eax<>edx -> edx<>nil -> false test edx, edx jnz @notnil mov al, dl // eax<>nil and edx=nil -> false @nil0: end; function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: PtrInt): boolean; {$ifdef FPC}nostackframe; assembler;{$endif} asm // eax=p1, edx=p2, ecx=P1P2Len cmp eax, edx je @out2 cmp ecx, 4 jbe @sml push ebx lea edx, [edx + ecx - 4] lea ebx, [eax + ecx - 4] neg ecx mov eax, [ebx] // compare last 4 chars xor eax, [edx] and eax, $dfdfdfdf // case insensitive jne @out1 @by4: add ecx, 4 jns @match mov eax, [ebx + ecx] xor eax, [edx + ecx] and eax, $dfdfdfdf // case insensitive je @by4 @out1: pop ebx @out2: setz al ret nop nop @match: pop ebx mov al, 1 ret @mask: dd 0, $df, $dfdf, $dfdfdf, $dfdfdfdf // compare 1..4 chars @sml: test ecx, ecx jz @smlo // p1p2len=0 mov eax, [eax] xor eax, [edx] and eax, dword ptr[@mask + ecx * 4] @smlo: setz al end; function StrIComp(Str1, Str2: pointer): PtrInt; {$ifdef FPC}nostackframe; assembler;{$endif} asm // faster version by AB, from Agner Fog's original mov ecx, eax test eax, edx jz @n @ok: sub edx, eax jz @0 @10: mov al, [ecx] cmp al, [ecx + edx] jne @20 inc ecx test al, al jnz @10 // continue with next byte // terminating zero found. Strings are equal @0: xor eax, eax ret @20: // bytes are different. check case xor al, 20H // toggle case cmp al, [ecx + edx] jne @30 // possibly differing only by case. Check if a-z or al, 20H // upper case sub al, 'a' cmp al, 'z' - 'a' ja @30 // not a-z // a-z and differing only by case inc ecx jmp @10 // continue with next byte @30: // bytes are different,even after changing case movzx eax, byte[ecx] // get original value again sub eax, 'A' cmp eax, 'Z' - 'A' ja @40 add eax, 20H @40: movzx edx, byte[ecx + edx] sub edx, 'A' cmp edx, 'Z' - 'A' ja @50 add edx, 20H @50: sub eax, edx // subtract to get result ret @n: cmp eax, edx je @0 test eax, eax // Str1='' ? jz @max test edx, edx // Str2='' ? jnz @ok mov eax, 1 ret @max: dec eax end; function StrLenPas(S: pointer): PtrInt; {$ifdef FPC}nostackframe; assembler;{$endif} asm // slower than x86/SSE* StrLen(), but won't read any byte beyond the string mov edx, eax test eax, eax jz @0 xor eax, eax @s: cmp byte ptr[eax + edx + 0], 0 je @0 cmp byte ptr[eax + edx + 1], 0 je @1 cmp byte ptr[eax + edx + 2], 0 je @2 cmp byte ptr[eax + edx + 3], 0 je @3 add eax, 4 jmp @s @1: inc eax ret @0: rep ret @2: add eax, 2 ret @3: add eax, 3 end; function StrCompFast(Str1, Str2: pointer): PtrInt; {$ifdef FPC}nostackframe; assembler;{$endif} asm // no branch taken in case of not equal first char cmp eax, edx je @zero // same string or both nil test eax, edx jz @maynil @1: mov cl, [eax] mov ch, [edx] inc eax inc edx test cl, cl jz @exit cmp cl, ch je @1 @exit: movzx eax, cl movzx edx, ch sub eax, edx ret @maynil:test eax, eax // Str1='' ? jz @max test edx, edx // Str2='' ? jnz @1 mov eax, 1 ret @max: dec eax ret @zero: xor eax, eax end; const EQUAL_EACH = 8; // see https://msdn.microsoft.com/en-us/library/bb531463 NEGATIVE_POLARITY = 16; function StrCompSSE42(Str1, Str2: pointer): PtrInt; {$ifdef FPC}nostackframe; assembler;{$endif} asm // warning: may read up to 15 bytes beyond the string itself test eax, edx jz @n @ok: sub eax, edx {$ifdef HASAESNI} movdqu xmm0, dqword [edx] pcmpistri xmm0, dqword [edx + eax], EQUAL_EACH + NEGATIVE_POLARITY // result in ecx {$else} db $F3,$0F,$6F,$02 db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY {$endif} ja @1 jc @2 xor eax, eax ret @1: add edx, 16 {$ifdef HASAESNI} movdqu xmm0, dqword [edx] pcmpistri xmm0, dqword [edx + eax], EQUAL_EACH + NEGATIVE_POLARITY // result in ecx {$else} db $F3,$0F,$6F,$02 db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY {$endif} ja @1 jc @2 @0: xor eax, eax // Str1=Str2 ret @n: cmp eax, edx je @0 test eax, eax // Str1='' ? jz @max test edx, edx // Str2='' ? jnz @ok mov eax, 1 ret @max: dec eax ret @2: add eax, edx movzx eax, byte ptr [eax+ecx] movzx edx, byte ptr [edx+ecx] sub eax, edx end; function SortDynArrayAnsiStringSSE42(const A,B): integer; {$ifdef FPC}nostackframe; assembler;{$endif} asm // warning: may read up to 15 bytes beyond the string itself mov eax, [eax] mov edx, [edx] test eax, edx jz @n @ok: sub eax, edx jz @0 {$ifdef HASAESNI} movdqu xmm0, dqword [edx] // result in ecx pcmpistri xmm0, dqword [edx+eax], EQUAL_EACH + NEGATIVE_POLARITY {$else} db $F3,$0F,$6F,$02 db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY {$endif} ja @1 jc @2 xor eax, eax ret @1: add edx, 16 {$ifdef HASAESNI} movdqu xmm0, dqword [edx] // result in ecx pcmpistri xmm0, dqword [edx+eax], EQUAL_EACH + NEGATIVE_POLARITY {$else} db $F3,$0F,$6F,$02 db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY {$endif} ja @1 jc @2 @0: xor eax, eax // Str1=Str2 ret @n: cmp eax, edx je @0 test eax, eax // Str1='' ? jz @max test edx, edx // Str2='' ? jnz @ok or eax, -1 ret @max: inc eax ret @2: add eax, edx movzx eax, byte ptr [eax+ecx] movzx edx, byte ptr [edx+ecx] sub eax, edx end; function StrLenSSE42(S: pointer): PtrInt; {$ifdef FPC}nostackframe; assembler;{$endif} asm // warning: may read up to 15 bytes beyond the string itself mov edx, eax // copy pointer test eax, eax jz @null // returns 0 if S=nil xor eax, eax {$ifdef HASAESNI} pxor xmm0, xmm0 pcmpistri xmm0, dqword[edx], EQUAL_EACH // comparison result in ecx {$else} db $66, $0F, $EF, $C0 db $66, $0F, $3A, $63, $02, EQUAL_EACH {$endif} jnz @loop mov eax, ecx ret nop // for @loop alignment @loop: add eax, 16 {$ifdef HASAESNI} pcmpistri xmm0, dqword[edx + eax], EQUAL_EACH // comparison result in ecx {$else} db $66, $0F, $3A, $63, $04, $10, EQUAL_EACH {$endif} jnz @loop @ok: add eax, ecx ret @null: db $f3 // rep ret end; procedure YearToPChar(Y: PtrUInt; P: PUTF8Char); asm // eax=Y, edx=P push edx mov ecx, eax mov edx, 1374389535 // use power of two reciprocal to avoid division mul edx shr edx, 5 // now edx=Y div 100 movzx eax, word ptr[TwoDigitLookup + edx * 2] imul edx, -200 movzx edx, word ptr[TwoDigitLookup + ecx * 2 + edx] pop ecx shl edx, 16 or eax, edx mov [ecx], eax end; function Iso8601ToTimeLog(const S: RawByteString): TTimeLog; asm xor ecx,ecx // ContainsNoTime=nil test eax,eax // if s='' -> p=nil -> will return 0, whatever L value is jz Iso8601ToTimeLogPUTF8Char mov edx,[eax-4] // edx=L @1: jmp Iso8601ToTimeLogPUTF8Char end; function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; asm // eax=dest source=edx test edx, edx jz @z push esi mov esi, offset NormToUpperAnsi7 xor ecx, ecx @1: mov cl, [edx] inc edx test cl, cl mov cl, [esi + ecx] jz @2 mov [eax], cl inc eax jmp @1 @2: pop esi @z: end; function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar; asm // eax=dest source=edx push esi push ebx movzx ebx, byte ptr[edx] // ebx = length(source) xor ecx, ecx test ebx, ebx mov esi, offset NormToUpperAnsi7 jz @2 // source='' inc edx @1: mov cl, [edx] inc edx dec ebx mov cl, [esi + ecx] mov [eax], cl lea eax, [eax + 1] jnz @1 @2: pop ebx pop esi @z: end; function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean; asm // eax=source edx=searchUp push eax // save source var mov eax, [eax] // eax=source test eax, eax jz @z push eax call IdemPChar pop ecx // ecx=source push eax // save result @1: mov dl, [ecx] // while not (source^ in [#0,#10,#13]) do inc(source) inc ecx cmp dl, 13 ja @1 je @e or dl, dl jz @0 cmp dl, 10 jne @1 jmp @4 @e: cmp byte ptr[ecx], 10 // jump #13#10 jne @4 @3: inc ecx @4: pop eax // restore result pop edx // restore source var mov [edx], ecx // update source var ret @0: xor ecx, ecx // set source=nil jmp @4 @z: pop edx // ignore source var, result := false end; procedure crcblockNoSSE42(crc128, data128: PBlock128); asm // Delphi is not efficient about compiling above pascal code push ebp push edi push esi mov ebp, eax // ebp=crc128 edi=data128 mov edi, edx mov edx, dword ptr[eax] mov ecx, dword ptr[eax + 4] xor edx, dword ptr[edi] xor ecx, dword ptr[edi + 4] movzx esi, dl mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] movzx esi, dh shr edx, 16 xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] movzx esi, dl xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] movzx esi, dh xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] mov edx, dword ptr[ebp + 8] xor edx, dword ptr[edi + 8] mov dword ptr[ebp], eax movzx esi, cl mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] movzx esi, ch shr ecx, 16 xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] movzx esi, cl xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] movzx esi, ch xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] mov dword ptr[ebp + 4], eax mov ecx, dword ptr[ebp + 12] xor ecx, dword ptr[edi + 12] movzx esi, dl mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] movzx esi, dh shr edx, 16 xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] movzx esi, dl xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] movzx esi, dh xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] mov dword ptr[ebp + 8], eax movzx esi, cl mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] movzx esi, ch shr ecx, 16 xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] movzx esi, cl xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] movzx esi, ch xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] mov dword ptr[ebp + 12], eax pop esi pop edi pop ebp end; function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; asm // adapted from fast Aleksandr Sharahov version test edx, edx jz @ret neg ecx jz @ret not eax push ebx @head: test dl, 3 jz @aligned movzx ebx, byte[edx] inc edx xor bl, al shr eax, 8 xor eax, dword ptr[ebx * 4 + crc32ctab] inc ecx jnz @head pop ebx not eax ret @ret: rep ret @aligned: sub edx, ecx add ecx, 8 jg @bodydone push esi push edi mov edi, edx mov edx, eax @bodyloop: mov ebx, [edi + ecx - 4] xor edx, [edi + ecx - 8] movzx esi, bl mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] movzx esi, bh xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] shr ebx, 16 movzx esi, bl xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] movzx esi, bh xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] movzx esi, dl xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 7] movzx esi, dh xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 6] shr edx, 16 movzx esi, dl xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 5] movzx esi, dh xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 4] add ecx, 8 jg @done mov ebx, [edi + ecx - 4] xor eax, [edi + ecx - 8] movzx esi, bl mov edx, dword ptr[esi * 4 + crc32ctab + 1024 * 3] movzx esi, bh xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 2] shr ebx, 16 movzx esi, bl xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 1] movzx esi, bh xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 0] movzx esi, al xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 7] movzx esi, ah xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 6] shr eax, 16 movzx esi, al xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 5] movzx esi, ah xor edx, dword ptr[esi * 4 + crc32ctab + 1024 * 4] add ecx, 8 jle @bodyloop mov eax, edx @done: mov edx, edi pop edi pop esi @bodydone: sub ecx, 8 jl @tail pop ebx not eax ret @tail: movzx ebx, byte[edx + ecx] xor bl, al shr eax, 8 xor eax, dword ptr[ebx * 4 + crc32ctab] inc ecx jnz @tail pop ebx not eax end; {$ifndef DELPHI5OROLDER} const CMP_RANGES = $44; // see https://msdn.microsoft.com/en-us/library/bb531425 function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; asm // eax=dest edx=source ecx=sourceLen test ecx,ecx jz @z movdqu xmm1, dqword ptr [@az] movdqu xmm3, dqword ptr [@bits] cmp ecx, 16 ja @big // optimize the common case of sourceLen<=16 movdqu xmm2, [edx] {$ifdef HASAESNI} pcmpistrm xmm1, xmm2, CMP_RANGES // find in range a-z, return mask in xmm0 {$else} db $66, $0F, $3A, $62, $CA, CMP_RANGES {$endif} pand xmm0, xmm3 pxor xmm2, xmm0 movdqu [eax], xmm2 add eax, ecx @z: ret @big: push eax cmp ecx, 240 jb @ok mov ecx, 239 @ok: add [esp], ecx // save to return end position with the exact size shr ecx, 4 sub edx, eax inc ecx @s: movdqu xmm2, [edx+eax] {$ifdef HASAESNI} pcmpistrm xmm1, xmm2, CMP_RANGES {$else} db $66, $0F, $3A, $62, $CA, CMP_RANGES {$endif} pand xmm0, xmm3 pxor xmm2, xmm0 movdqu [eax], xmm2 add eax, 16 dec ecx jnz @s pop eax ret @az: db 'azazazazazazazaz' // define range for upper case conversion @bits: db ' ' // $20 = bit to change when changing case end; {$endif DELPHI5OROLDER} function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; asm // eax=crc, edx=buf, ecx=len push ebx test edx, edx jz @0 neg ecx jz @0 sub edx, ecx @1: movzx ebx, byte ptr[edx + ecx] xor eax, ebx imul eax, eax, 16777619 inc ecx jnz @1 @0: pop ebx end; // we tried an unrolled version, but it was slower on our Core i7! function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; asm // eax=crc, edx=buf, ecx=len test ecx, ecx push edi push esi push ebx push ebp jz @z cmp ecx, 4 jb @s @8: mov ebx, [edx] // unrolled version reading per dword add edx, 4 mov esi, eax movzx edi, bl movzx ebp, bh shr ebx, 16 shl eax, 5 sub eax, esi add eax, edi mov esi, eax shl eax, 5 sub eax, esi lea esi, [eax + ebp] add eax, ebp movzx edi, bl movzx ebx, bh shl eax, 5 sub eax, esi lea ebp, [eax + edi] add eax, edi shl eax, 5 sub eax, ebp add eax, ebx cmp ecx, 8 lea ecx, [ecx - 4] jae @8 test ecx, ecx jz @z @s: mov esi, eax @1: shl eax, 5 movzx ebx, byte ptr[edx] inc edx sub eax, esi lea esi, [eax + ebx] add eax, ebx dec ecx jnz @1 @z: pop ebp pop ebx pop esi pop edi end; function ToVarInt32(Value: PtrInt; Dest: PByte): PByte; asm test eax, eax jnl @pos neg eax add eax, eax jmp ToVarUInt32 @pos: jz @zer lea eax, [eax * 2 - 1] jmp ToVarUInt32 @zer: mov [edx], al lea eax, [edx + 1] end; function ToVarUInt32(Value: PtrUInt; Dest: PByte): PByte; asm cmp eax, $7f jbe @0 cmp eax, $00004000 jb @1 cmp eax, $00200000 jb @2 cmp eax, $10000000 jb @3 mov ecx, eax shr eax, 7 and cl, $7f or cl, $80 mov [edx], cl inc edx @3: mov ecx, eax shr eax, 7 and cl, $7f or cl, $80 mov [edx], cl inc edx @2: mov ecx, eax shr eax, 7 and cl, $7f or cl, $80 mov [edx], cl inc edx @1: mov ecx, eax shr eax, 7 and cl, $7f or cl, $80 mov [edx], cl inc edx @0: mov [edx], al lea eax, [edx + 1] end; function SortDynArrayInteger(const A,B): integer; asm mov ecx, [eax] xor eax, eax mov edx, [edx] cmp ecx, edx je @0 jg @1 dec eax @0: ret @1: inc eax end; function SortDynArrayInt64(const A,B): integer; asm // Delphi x86 compiler is not efficient at compiling below code mov ecx, [eax] mov eax, [eax + 4] cmp eax, [edx + 4] jnz @nz cmp ecx, [edx] jz @0 jnb @p @n: or eax, -1 ret @0: xor eax, eax ret @nz: jl @n @p: mov eax, 1 end; function CompareQWord(A, B: QWord): integer; begin {$ifdef FPC_OR_UNICODE} // recent compilers are able to generate correct code if AB then result := 1 else result := 0; {$else} result := SortDynArrayQWord(A,B); // use correct x86 asm version below {$endif} end; function SortDynArrayQWord(const A,B): integer; asm // Delphi x86 compiler is not efficient, and oldest even incorrect mov ecx, [eax] mov eax, [eax + 4] cmp eax, [edx + 4] jnz @nz cmp ecx, [edx] jz @0 @nz: jnb @p or eax, -1 ret @0: xor eax, eax ret @p: mov eax, 1 end; function SortDynArrayRawByteString(const A,B): integer; asm jmp SortDynArrayAnsiString end; function SortDynArrayAnsiString(const A,B): integer; asm // x86 version optimized for AnsiString/RawUTF8 types mov eax, [eax] mov edx, [edx] cmp eax, edx je @0 test eax, edx jz @n1 @n2: movzx ecx, byte ptr[eax] // first char comparison (quicksort speedup) sub cl, [edx] jne @no push ebx mov ebx, [eax - 4] sub ebx, [edx - 4] push ebx adc ecx, -1 and ecx, ebx sub ecx, [eax - 4] sub eax, ecx sub edx, ecx @s: mov ebx, [eax + ecx] // compare by dword xor ebx, [edx + ecx] jnz @d add ecx, 4 js @s @l: pop eax // all chars equal -> returns length(a)-length(b) pop ebx ret @d: bsf ebx, ebx // char differs -> returns pbyte(a)^-pbyte(b)^ shr ebx, 3 add ecx, ebx jns @l movzx eax, byte ptr[eax + ecx] movzx edx, byte ptr[edx + ecx] pop ebx pop ebx sub eax, edx ret @n1: test eax, eax // a or b may be '' jz @n0 test edx, edx jnz @n2 cmp [eax - 4], edx je @0 @no: jnc @1 or eax, -1 ret @n0: cmp eax, [edx - 4] je @0 jnc @1 or eax, -1 ret @0: xor eax, eax ret @1: mov eax, 1 end; function SortDynArrayAnsiStringI(const A,B): integer; asm // avoid a call on the stack on x86 platform mov eax, [eax] mov edx, [edx] jmp StrIComp end; function SortDynArrayPUTF8Char(const A,B): integer; asm // avoid a call on the stack on x86 platform mov eax, [eax] mov edx, [edx] jmp dword ptr[StrComp] end; {$endif PUREPASCAL} function PosExChar(Chr: AnsiChar; const Str: RawUTF8): PtrInt; begin {$ifdef FPC} if Str<>'' then // // will use fast FPC SSE version result := IndexByte(pointer(Str)^,_LStrLen(Str),byte(chr))+1 else {$else} if Str<>'' then for result := 1 to PInteger(PtrInt(Str)-sizeof(Integer))^ do if Str[result]=Chr then exit; {$endif FPC} result := 0; end; function SplitRight(const Str: RawUTF8; SepChar: AnsiChar; LeftStr: PRawUTF8): RawUTF8; var i: PtrInt; begin for i := length(Str) downto 1 do if Str[i]=SepChar then begin result := copy(Str,i+1,maxInt); if LeftStr<>nil then LeftStr^ := copy(Str,1,i-1); exit; end; result := Str; if LeftStr<>nil then LeftStr^ := ''; end; function SplitRights(const Str, SepChar: RawUTF8): RawUTF8; var i, j, sep: PtrInt; c: AnsiChar; begin sep := length(SepChar); if sep > 0 then if sep = 1 then result := SplitRight(Str,SepChar[1]) else begin for i := length(Str) downto 1 do begin c := Str[i]; for j := 1 to sep do if c=SepChar[j] then begin result := copy(Str,i+1,maxInt); exit; end; end; end; result := Str; end; function Split(const Str, SepStr: RawUTF8; StartPos: integer): RawUTF8; var i: integer; begin i := PosEx(SepStr,Str,StartPos); if i>0 then result := Copy(Str,StartPos,i-StartPos) else if StartPos=1 then result := Str else result := Copy(Str,StartPos,maxInt); end; procedure Split(const Str, SepStr: RawUTF8; var LeftStr, RightStr: RawUTF8; ToUpperCase: boolean); var i: integer; tmp: RawUTF8; // may be called as Split(Str,SepStr,Str,RightStr) begin i := PosEx(SepStr,Str); if i=0 then begin LeftStr := Str; RightStr := ''; end else begin tmp := copy(Str,1,i-1); RightStr := copy(Str,i+length(SepStr),maxInt); LeftStr := tmp; end; if ToUpperCase then begin LeftStr := UpperCaseU(LeftStr); RightStr := UpperCaseU(RightStr); end; end; function Split(const Str, SepStr: RawUTF8; var LeftStr: RawUTF8; ToUpperCase: boolean=false): RawUTF8; begin Split(Str,SepStr,LeftStr,result,ToUpperCase); end; procedure Split(const Str: RawUTF8; const SepStr: array of RawUTF8; const DestPtr: array of PRawUTF8); var s,i,j,n: integer; begin j := 1; n := 0; s := 0; if high(SepStr)>=0 then while n<=high(DestPtr) do begin i := PosEx(SepStr[s],Str,j); if i=0 then begin if DestPtr[n]<>nil then DestPtr[n]^ := copy(Str,j,MaxInt); inc(n); break; end; if DestPtr[n]<>nil then DestPtr[n]^ := copy(Str,j,i-j); inc(n); if snil then DestPtr[i]^ := ''; end; function StringReplaceAll(const S, OldPattern, NewPattern: RawUTF8): RawUTF8; procedure Process(found: integer); var oldlen,newlen,i,last,posCount,sharedlen: integer; pos: TIntegerDynArray; src,dst: PAnsiChar; begin oldlen := length(OldPattern); newlen := length(NewPattern); SetLength(pos,64); pos[0] := found; posCount := 1; repeat found := PosEx(OldPattern,S,found+oldlen); if found=0 then break; AddInteger(pos,posCount,found); until false; FastSetString(result,nil,Length(S)+(newlen-oldlen)*posCount); last := 1; src := pointer(s); dst := pointer(result); for i := 0 to posCount-1 do begin sharedlen := pos[i]-last; {$ifdef FPC}Move{$else}MoveFast{$endif}(src^,dst^,sharedlen); inc(src,sharedlen+oldlen); inc(dst,sharedlen); {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(NewPattern)^,dst^,newlen); inc(dst,newlen); last := pos[i]+oldlen; end; {$ifdef FPC}Move{$else}MoveFast{$endif}(src^,dst^,length(S)-last+1); end; var j: integer; begin if (S='') or (OldPattern='') or (OldPattern=NewPattern) then result := S else begin j := PosEx(OldPattern, S, 1); // our PosEx() is faster than Pos() if j=0 then result := S else Process(j); end; end; function StringReplaceTabs(const Source,TabText: RawUTF8): RawUTF8; procedure Process(S,D,T: PAnsiChar; TLen: integer); begin repeat if S^=#0 then break else if S^<>#9 then begin D^ := S^; inc(D); inc(S); end else begin {$ifdef FPC}Move{$else}MoveFast{$endif}(T^,D^,TLen); inc(D,TLen); inc(S); end; until false; end; var L,i,n,ttl: PtrInt; begin ttl := length(TabText); L := Length(Source); n := 0; if ttl<>0 then for i := 1 to L do if Source[i]=#9 then inc(n); if n=0 then begin result := Source; exit; end; SetLength(result,L+n*pred(ttl)); Process(pointer(Source),pointer(result),pointer(TabText),ttl); end; function strspnpas(s,accept: pointer): integer; var p: PCardinal; c: AnsiChar; d: cardinal; begin // returns size of initial segment of s which are in accept result := 0; repeat c := PAnsiChar(s)[result]; if c=#0 then break; p := accept; repeat // stop as soon as we find any character not from accept d := p^; inc(p); if AnsiChar(d)=c then break else if AnsiChar(d)=#0 then exit; d := d shr 8; if AnsiChar(d)=c then break else if AnsiChar(d)=#0 then exit; d := d shr 8; if AnsiChar(d)=c then break else if AnsiChar(d)=#0 then exit; d := d shr 8; if AnsiChar(d)=c then break else if AnsiChar(d)=#0 then exit; until false; inc(result); until false; end; function strcspnpas(s,reject: pointer): integer; var p: PCardinal; c: AnsiChar; d: cardinal; begin // returns size of initial segment of s which are not in reject result := 0; repeat c := PAnsiChar(s)[result]; if c=#0 then break; p := reject; repeat // stop as soon as we find any character from reject d := p^; inc(p); if AnsiChar(d)=c then exit else if AnsiChar(d)=#0 then break; d := d shr 8; if AnsiChar(d)=c then exit else if AnsiChar(d)=#0 then break; d := d shr 8; if AnsiChar(d)=c then exit else if AnsiChar(d)=#0 then break; d := d shr 8; if AnsiChar(d)=c then exit else if AnsiChar(d)=#0 then break; until false; inc(result); until false; end; {$ifndef ABSOLUTEPASCAL} {$ifdef CPUINTEL} {$ifdef CPUX64} // inspired by Agner Fog's strspn64.asm function strcspnsse42(s,reject: pointer): integer; {$ifdef FPC}nostackframe; assembler; asm {$else} asm // rcx=s, rdx=reject (Linux: rdi,rsi) .noframe {$endif FPC} {$ifdef win64} push rdi push rsi mov rdi, rcx mov rsi, rdx {$endif}mov r8, rsi xor ecx, ecx @1: movdqu xmm2, [rdi] movdqu xmm1, [rsi] {$ifdef HASAESNI} pcmpistrm xmm1, xmm2, $30 // find in set, invert valid bits, return bit mask in xmm0 {$else} db $66,$0F,$3A,$62,$CA,$30 {$endif} movd eax, xmm0 jns @5 @2: cmp eax, 65535 jne @3 add rdi, 16 // first 16 chars matched, continue with next 16 chars add rcx, 16 jmp @1 @3: not eax bsf eax, eax add rax, rcx {$ifdef win64} pop rsi pop rdi {$endif}ret @4: and eax, edx // accumulate matches @5: add rsi, 16 // the set is more than 16 bytes movdqu xmm1, [rsi] {$ifdef HASAESNI} pcmpistrm xmm1, xmm2, $30 {$else} db $66,$0F,$3A,$62,$CA,$30 {$endif} movd edx, xmm0 jns @4 mov rsi, r8 // restore set pointer and eax, edx // accumulate matches cmp eax, 65535 jne @3 add rdi, 16 add rcx, 16 jmp @1 end; function strspnsse42(s,accept: pointer): integer; {$ifdef FPC}nostackframe; assembler; asm {$else} asm // rcx=s, rdx=accept (Linux: rdi,rsi) .noframe {$endif FPC} {$ifdef win64} push rdi push rsi mov rdi, rcx mov rsi, rdx {$endif}mov r8, rsi xor ecx, ecx @1: movdqu xmm2, [rdi] movdqu xmm1, [rsi] {$ifdef HASAESNI} pcmpistrm xmm1, xmm2, $00 // find in set, return bit mask in xmm0 {$else} db $66,$0F,$3A,$62,$CA,$00 {$endif} movd eax, xmm0 jns @5 @2: cmp eax, 65535 jne @3 add rdi, 16 // first 16 chars matched, continue with next 16 chars add rcx, 16 jmp @1 @3: not eax bsf eax, eax add rax, rcx {$ifdef win64} pop rsi pop rdi {$endif}ret @4: or eax, edx // accumulate matches @5: add rsi, 16 // the set is more than 16 bytes movdqu xmm1, [rsi] {$ifdef HASAESNI} pcmpistrm xmm1, xmm2, $00 {$else} db $66,$0F,$3A,$62,$CA,$00 {$endif} movd edx, xmm0 jns @4 mov rsi, r8 // restore set pointer or eax, edx // accumulate matches cmp eax, 65535 jne @3 add rdi, 16 // first 16 chars matched, continue with next 16 chars add rcx, 16 jmp @1 end; {$endif CPUX64} {$ifdef CPUX86} function strcspnsse42(s,reject: pointer): integer; asm // eax=s, edx=reject push edi push esi push ebx mov edi, eax mov esi, edx mov ebx, esi xor ecx, ecx @1: {$ifdef HASAESNI} movdqu xmm2, dqword [edi] movdqu xmm1, dqword [esi] pcmpistrm xmm1, xmm2, $30 // find in set, invert valid bits, return bit mask in xmm0 movd eax, xmm0 {$else} db $F3,$0F,$6F,$17 db $F3,$0F,$6F,$0E db $66,$0F,$3A,$62,$CA,$30 db $66,$0F,$7E,$C0 {$endif} jns @5 @2: cmp eax, 65535 jne @3 add edi, 16 // first 16 chars matched, continue with next 16 chars add ecx, 16 jmp @1 @3: not eax bsf eax, eax add eax, ecx pop ebx pop esi pop edi ret @4: and eax, edx // accumulate matches @5: add esi, 16 // the set is more than 16 bytes {$ifdef HASAESNI} movdqu xmm1, [esi] pcmpistrm xmm1, xmm2, $30 movd edx, xmm0 {$else} db $F3,$0F,$6F,$0E db $66,$0F,$3A,$62,$CA,$30 db $66,$0F,$7E,$C2 {$endif} jns @4 mov esi, ebx // restore set pointer and eax, edx // accumulate matches cmp eax, 65535 jne @3 add edi, 16 // first 16 chars matched, continue with next 16 chars add ecx, 16 jmp @1 end; function strspnsse42(s,accept: pointer): integer; asm // eax=s, edx=accept push edi push esi push ebx mov edi, eax mov esi, edx mov ebx, esi xor ecx, ecx @1: {$ifdef HASAESNI} movdqu xmm2, dqword [edi] movdqu xmm1, dqword [esi] pcmpistrm xmm1, xmm2, $00 // find in set, return bit mask in xmm0 movd eax, xmm0 {$else} db $F3,$0F,$6F,$17 db $F3,$0F,$6F,$0E db $66,$0F,$3A,$62,$CA,$00 db $66,$0F,$7E,$C0 {$endif} jns @5 @2: cmp eax, 65535 jne @3 add edi, 16 // first 16 chars matched, continue with next 16 chars add ecx, 16 jmp @1 @3: not eax bsf eax, eax add eax, ecx pop ebx pop esi pop edi ret @4: or eax, edx // accumulate matches @5: add esi, 16 // the set is more than 16 bytes {$ifdef HASAESNI} movdqu xmm1, [esi] pcmpistrm xmm1, xmm2, $00 movd edx, xmm0 {$else} db $F3,$0F,$6F,$0E db $66,$0F,$3A,$62,$CA,$00 db $66,$0F,$7E,$C2 {$endif} jns @4 mov esi, ebx // restore set pointer or eax, edx // accumulate matches cmp eax, 65535 jne @3 add edi, 16 // first 16 chars matched, continue with next 16 chars add ecx, 16 jmp @1 end; {$ifndef DELPHI5OROLDER} function StrLenSSE2(S: pointer): PtrInt; asm // from GPL strlen32.asm by Agner Fog - www.agner.org/optimize mov ecx, eax // copy pointer test eax, eax jz @null // returns 0 if S=nil push eax // save start address pxor xmm0, xmm0 // set to zero and ecx, 15 // lower 4 bits indicate misalignment and eax, -16 // align pointer by 16 // will never read outside a memory page boundary, so won't trigger GPF movdqa xmm1, [eax] // read from nearest preceding boundary pcmpeqb xmm1, xmm0 // compare 16 bytes with zero pmovmskb edx, xmm1 // get one bit for each byte result shr edx, cl // shift out false bits shl edx, cl // shift back again bsf edx, edx // find first 1-bit jnz @A200 // found // Main loop, search 16 bytes at a time @A100: add eax, 10H // increment pointer by 16 movdqa xmm1, [eax] // read 16 bytes aligned pcmpeqb xmm1, xmm0 // compare 16 bytes with zero pmovmskb edx, xmm1 // get one bit for each byte result bsf edx, edx // find first 1-bit // (moving the bsf out of the loop and using test here would be faster // for long strings on old processors, but we are assuming that most // strings are short, and newer processors have higher priority) jz @A100 // loop if not found @A200: // Zero-byte found. Compute string length pop ecx // restore start address sub eax, ecx // subtract start address add eax, edx // add byte index @null: end; {$endif DELPHI5OROLDER} {$endif CPUX86} {$endif CPUINTEL} {$endif ABSOLUTEPASCAL} function IdemPropName(const P1,P2: shortstring): boolean; begin if P1[0]=P2[0] then result := IdemPropNameUSameLen(@P1[1],@P2[1],ord(P2[0])) else result := false; end; function IdemPropName(const P1: shortstring; P2: PUTF8Char; P2Len: PtrInt): boolean; begin if ord(P1[0])=P2Len then result := IdemPropNameUSameLen(@P1[1],P2,P2Len) else result := false; end; function IdemPropName(P1,P2: PUTF8Char; P1Len,P2Len: PtrInt): boolean; begin if P1Len=P2Len then result := IdemPropNameUSameLen(P1,P2,P2Len) else result := false; end; function IdemPropNameU(const P1: RawUTF8; P2: PUTF8Char; P2Len: PtrInt): boolean; begin if length(P1)=P2Len then result := IdemPropNameUSameLen(pointer(P1),P2,P2Len) else result := false; end; function ToText(os: TOperatingSystem): PShortString; begin result := GetEnumName(TypeInfo(TOperatingSystem),ord(os)); end; function ToText(const osv: TOperatingSystemVersion): ShortString; begin if osv.os=osWindows then FormatShort('Windows %', [WINDOWS_NAME[osv.win]], result) else TrimLeftLowerCaseToShort(ToText(osv.os),result); end; function ToTextOS(osint32: integer): RawUTF8; var osv: TOperatingSystemVersion absolute osint32; ost: ShortString; begin ost := ToText(osv); if (osv.os>=osLinux) and (osv.utsrelease[2]<>0) then result := FormatUTF8('% %.%.%',[ost,osv.utsrelease[2],osv.utsrelease[1],osv.utsrelease[0]]) else result := ShortStringToUTF8(ost); end; {$ifdef MSWINDOWS} procedure FileTimeToInt64(const FT: TFileTime; out I64: Int64); begin {$ifdef CPU64} PInt64Rec(@I64)^.Lo := FT.dwLowDateTime; PInt64Rec(@I64)^.Hi := FT.dwHighDateTime; {$else} I64 := PInt64(@FT)^; {$endif} end; const // lpMinimumApplicationAddress retrieved from Windows is very low $10000 // - i.e. maximum number of ID per table would be 65536 in TSQLRecord.GetID // - so we'll force an higher and almost "safe" value as 1,048,576 // (real value from runnning Windows is greater than $400000) MIN_PTR_VALUE = $100000; // see http://msdn.microsoft.com/en-us/library/ms724833(v=vs.85).aspx VER_NT_WORKSTATION = 1; VER_NT_DOMAIN_CONTROLLER = 2; VER_NT_SERVER = 3; SM_SERVERR2 = 89; PROCESSOR_ARCHITECTURE_AMD64 = 9; {$ifndef UNICODE} function GetVersionEx(var lpVersionInformation: TOSVersionInfoEx): BOOL; stdcall; external kernel32 name 'GetVersionExA'; {$endif} var GetTickXP: Int64Rec; function GetTickCount64ForXP: Int64; stdcall; var t32: cardinal; t64: Int64Rec absolute result; begin // warning: GetSystemTimeAsFileTime() is fast, but not monotonic! t32 := Windows.GetTickCount; t64 := GetTickXP; // (almost) atomic read if t320) or not SwitchToThread then Windows.Sleep(ms); end; procedure RetrieveSystemInfo; var IsWow64Process: function(Handle: THandle; var Res: BOOL): BOOL; stdcall; GetNativeSystemInfo: procedure(var SystemInfo: TSystemInfo); stdcall; Res: BOOL; Kernel: THandle; P: pointer; Vers: TWindowsVersion; cpu, manuf, prod, prodver: string; begin Kernel := GetModuleHandle(kernel32); GetTickCount64 := GetProcAddress(Kernel,'GetTickCount64'); if not Assigned(GetTickCount64) then GetTickCount64 := @GetTickCount64ForXP; IsWow64Process := GetProcAddress(Kernel,'IsWow64Process'); Res := false; IsWow64 := Assigned(IsWow64Process) and IsWow64Process(GetCurrentProcess,Res) and Res; FillcharFast(SystemInfo,SizeOf(SystemInfo),0); if IsWow64 then // see http://msdn.microsoft.com/en-us/library/ms724381(v=VS.85).aspx GetNativeSystemInfo := GetProcAddress(Kernel,'GetNativeSystemInfo') else @GetNativeSystemInfo := nil; if Assigned(GetNativeSystemInfo) then GetNativeSystemInfo(SystemInfo) else Windows.GetSystemInfo(SystemInfo); GetMem(P,10); // ensure that using MIN_PTR_VALUE won't break anything if (PtrUInt(P)>MIN_PTR_VALUE) and (PtrUInt(SystemInfo.lpMinimumApplicationAddress)<=MIN_PTR_VALUE) then PtrUInt(SystemInfo.lpMinimumApplicationAddress) := MIN_PTR_VALUE; Freemem(P); OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo); GetVersionEx(OSVersionInfo); Vers := wUnknown; with OSVersionInfo do // see https://msdn.microsoft.com/en-us/library/windows/desktop/ms724833 case dwMajorVersion of 5: case dwMinorVersion of 0: Vers := w2000; 1: Vers := wXP; 2: if (wProductType=VER_NT_WORKSTATION) and (SystemInfo.wProcessorArchitecture=PROCESSOR_ARCHITECTURE_AMD64) then Vers := wXP_64 else if GetSystemMetrics(SM_SERVERR2)=0 then Vers := wServer2003 else Vers := wServer2003_R2; end; 6: case dwMinorVersion of 0: Vers := wVista; 1: Vers := wSeven; 2: Vers := wEight; 3: Vers := wEightOne; 4: Vers := wTen; end; 10: Vers := wTen; end; if Vers>=wVista then begin if OSVersionInfo.wProductType<>VER_NT_WORKSTATION then begin // Server edition inc(Vers,2); // e.g. wEight -> wServer2012 if (Vers=wServer2016) and (OSVersionInfo.dwBuildNumber>=17763) then Vers := wServer2019_64; // https://stackoverflow.com/q/53393150 end; if (SystemInfo.wProcessorArchitecture=PROCESSOR_ARCHITECTURE_AMD64) and (Vers < wServer2019_64) then inc(Vers); // e.g. wEight -> wEight64 end; OSVersion := Vers; with OSVersionInfo do if wServicePackMajor=0 then FormatUTF8('Windows % (%.%.%)',[WINDOWS_NAME[Vers], dwMajorVersion,dwMinorVersion,dwBuildNumber],OSVersionText) else FormatUTF8('Windows % SP% (%.%.%)',[WINDOWS_NAME[Vers],wServicePackMajor, dwMajorVersion,dwMinorVersion,dwBuildNumber],OSVersionText); OSVersionInt32 := (integer(Vers) shl 8)+ord(osWindows); {$ifndef LVCL} with TRegistry.Create do try RootKey := HKEY_LOCAL_MACHINE; if OpenKeyReadOnly('\Hardware\Description\System\CentralProcessor\0') then begin cpu := ReadString('ProcessorNameString'); if cpu='' then cpu := ReadString('Identifier'); end; if OpenKeyReadOnly('\Hardware\Description\System\BIOS') then begin manuf := SysUtils.Trim(ReadString('SystemManufacturer')); if manuf<>'' then manuf := manuf+' '; prod := SysUtils.Trim(ReadString('SystemProductName')); prodver := SysUtils.Trim(ReadString('SystemVersion')); if prodver='' then prodver := SysUtils.Trim(ReadString('BIOSVersion')); if prodver<>'' then FormatUTF8('%% %',[manuf,prod,prodver],BiosInfoText) else FormatUTF8('%%',[manuf,prod],BiosInfoText); end; finally Free; end; {$endif} if cpu='' then cpu := GetEnvironmentVariable('PROCESSOR_IDENTIFIER'); cpu := SysUtils.Trim(cpu); FormatUTF8('% x % ('+CPU_ARCH_TEXT+')',[SystemInfo.dwNumberOfProcessors,cpu],CpuInfoText); end; {$else} {$ifndef BSD} procedure SetLinuxDistrib(const release: RawUTF8); var distrib: TOperatingSystem; dist: RawUTF8; begin for distrib := osArch to high(distrib) do begin dist := UpperCase(TrimLeftLowerCaseShort(ToText(distrib))); if PosI(pointer(dist),release)>0 then begin OS_KIND := distrib; break; end; end; end; {$endif BSD} procedure RetrieveSystemInfo; var modname, beg: PUTF8Char; {$ifdef BSD} temp: shortstring; {$else} cpuinfo: PUTF8Char; proccpuinfo,prod,prodver,release,dist: RawUTF8; SR: TSearchRec; {$endif BSD} begin modname := nil; {$ifdef BSD} fpuname(SystemInfo.uts); SystemInfo.dwNumberOfProcessors := fpsysctlhwint(HW_NCPU); Utf8ToRawUTF8(fpsysctlhwstr(HW_MACHINE,temp),BiosInfoText); modname := fpsysctlhwstr(HW_MODEL,temp); with SystemInfo.uts do FormatUTF8('%-% %',[sysname,release,version],OSVersionText); {$else} {$ifdef KYLIX3} uname(SystemInfo.uts); {$else} fpuname(SystemInfo.uts); {$endif KYLIX3} prod := Trim(StringFromFile('/sys/class/dmi/id/product_name',true)); if prod<>'' then begin prodver := Trim(StringFromFile('/sys/class/dmi/id/product_version',true)); if prodver<>'' then FormatUTF8('% %',[prod,prodver],BiosInfoText) else BiosInfoText := prod; end; SystemInfo.dwNumberOfProcessors := 0; proccpuinfo := StringFromFile('/proc/cpuinfo',true); cpuinfo := pointer(proccpuinfo); while cpuinfo<>nil do begin beg := cpuinfo; cpuinfo := GotoNextLine(cpuinfo); if IdemPChar(beg,'PROCESSOR') then if beg^='P' then modname := beg else // Processor : ARMv7 inc(SystemInfo.dwNumberOfProcessors) else // processor : 0 if IdemPChar(beg,'MODEL NAME') then modname := beg; end; modname := PosChar(modname,':'); if modname<>nil then modname := GotoNextNotSpace(modname+1); release := trim(FindIniNameValue(pointer(StringFromFile('/etc/os-release')),'PRETTY_NAME=')); if (release<>'') and (release[1]='"') then release := copy(release,2,length(release)-2); release := trim(release); if release='' then begin release := trim(FindIniNameValue(pointer(StringFromFile('/etc/lsb-release')),'DISTRIB_DESCRIPTION=')); if (release<>'') and (release[1]='"') then release := copy(release,2,length(release)-2); end; if (release='') and (FindFirst('/etc/*-release',faAnyFile,SR)=0) then begin release := StringToUTF8(SR.Name); // 'redhat-release' 'SuSE-release' if IdemPChar(pointer(release),'LSB-') and (FindNext(SR)=0) then release := StringToUTF8(SR.Name); release := split(release,'-'); dist := split(trim(StringFromFile('/etc/'+SR.Name)),#10); if (dist<>'') and (PosExChar('=',dist)=0) and (PosExChar(' ',dist)>0) then SetLinuxDistrib(dist) // e.g. 'Red Hat Enterprise Linux Server release 6.7 (Santiago)' else dist := ''; FindClose(SR); end; if (release<>'') and (OS_KIND=osLinux) then begin SetLinuxDistrib(release); if (OS_KIND=osLinux) and (dist<>'') then begin SetLinuxDistrib(dist); release := dist; end; if (OS_KIND=osLinux) and ((PosEx('RH',release)>0) or (PosEx('Red Hat',release)>0)) then OS_KIND := osRedHat; end; SystemInfo.release := release; {$endif BSD} OSVersionInt32 := {$ifdef FPC}integer(KernelRevision shl 8)+{$endif}ord(OS_KIND); with SystemInfo.uts do FormatUTF8('% %',[sysname,release],OSVersionText); if SystemInfo.release<>'' then OSVersionText := FormatUTF8('% - %',[SystemInfo.release,OSVersionText]); if (SystemInfo.dwNumberOfProcessors>0) and (modname<>nil) then begin beg := modname; while not (ord(modname^) in [0,10,13]) do begin if modname^<' ' then modname^ := ' '; inc(modname); end; modname^ := #0; FormatUTF8('% x % ('+CPU_ARCH_TEXT+')',[SystemInfo.dwNumberOfProcessors,beg],CpuInfoText); end; end; {$ifdef KYLIX3} function FileOpen(const FileName: string; Mode: LongWord): Integer; const SHAREMODE: array[0..fmShareDenyNone shr 4] of Byte = ( 0, // No share mode specified F_WRLCK, // fmShareExclusive F_RDLCK, // fmShareDenyWrite 0); // fmShareDenyNone var FileHandle, Tvar: Integer; LockVar: TFlock; smode: Byte; begin result := -1; if FileExists(FileName) and ((Mode and 3)<=fmOpenReadWrite) and ((Mode and $F0)<=fmShareDenyNone) then begin FileHandle := open64(pointer(FileName),(Mode and 3),FileAccessRights); if FileHandle=-1 then exit; smode := Mode and $F0 shr 4; if SHAREMODE[smode]<>0 then begin with LockVar do begin l_whence := SEEK_SET; l_start := 0; l_len := 0; l_type := SHAREMODE[smode]; end; Tvar := fcntl(FileHandle,F_SETLK,LockVar); if Tvar=-1 then begin __close(FileHandle); exit; end; end; result := FileHandle; end; end; function GetTickCount64: Int64; begin result := SynKylix.GetTickCount64; end; {$endif KYLIX3} {$ifdef FPC} function GetTickCount64: Int64; begin result := SynFPCLinux.GetTickCount64; end; {$endif} {$endif MSWINDOWS} function FileOpenSequentialRead(const FileName: string): Integer; begin {$ifdef MSWINDOWS} result := CreateFile(pointer(FileName),GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE,nil, // same as fmShareDenyNone OPEN_EXISTING,FILE_FLAG_SEQUENTIAL_SCAN,0); {$else} result := FileOpen(FileName,fmOpenRead or fmShareDenyNone); {$endif MSWINDOWS} end; function FileStreamSequentialRead(const FileName: string): TFileStream; begin {$ifdef DELPHI5ORFPC} result := TFileStream.Create(FileName,fmOpenRead or fmShareDenyNone); {$else} result := TFileStream.Create(FileOpenSequentialRead(FileName)); {$endif} end; function Elapsed(var PreviousTix: Int64; Interval: Integer): Boolean; var now: Int64; begin if Interval<=0 then result := false else begin now := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64; if now-PreviousTix>Interval then begin PreviousTix := now; result := true; end else result := false; end; end; {$ifndef FPC} // FPC has its built-in InterlockedIncrement/InterlockedDecrement {$ifdef PUREPASCAL} function InterlockedIncrement(var I: Integer): Integer; begin {$ifdef MSWINDOWS} // AtomicIncrement() may not be available e.g. on Delphi XE2 result := Windows.InterlockedIncrement(I); {$else} result := AtomicIncrement(I); {$endif} end; function InterlockedDecrement(var I: Integer): Integer; begin {$ifdef MSWINDOWS} // AtomicDecrement() may not be available e.g. on Delphi XE2 result := Windows.InterlockedDecrement(I); {$else} result := AtomicDecrement(I); {$endif} end; {$else} function InterlockedIncrement(var I: Integer): Integer; asm mov edx, 1 xchg eax, edx lock xadd [edx], eax inc eax end; function InterlockedDecrement(var I: Integer): Integer; asm mov edx, -1 xchg eax, edx lock xadd [edx], eax dec eax end; {$endif} {$endif FPC} procedure SoundExComputeAnsi(var p: PAnsiChar; var result: cardinal; Values: PSoundExValues); var n,v,old: PtrUInt; begin n := 0; old := 0; if Values<>nil then repeat {$ifdef USENORMTOUPPER} v := NormToUpperByte[ord(p^)]; // also handle 8 bit WinAnsi (1252 accents) {$else} v := NormToUpperAnsi7Byte[ord(p^)]; // 7 bit char uppercase {$endif} if not (v in IsWord) then break; inc(p); dec(v,ord('B')); if v>high(TSoundExValues) then continue; v := Values[v]; // get soundex value if (v=0) or (v=old) then continue; // invalid or dopple value old := v; result := result shl SOUNDEX_BITS; inc(result,v); inc(n); if n=((32-8)div SOUNDEX_BITS) then // first char use up to 8 bits break; // result up to a cardinal size until false; end; function SoundExComputeFirstCharAnsi(var p: PAnsiChar): cardinal; label Err; begin if p=nil then begin Err:result := 0; exit; end; repeat {$ifdef USENORMTOUPPER} result := NormToUpperByte[ord(p^)]; // also handle 8 bit WinAnsi (CP 1252) {$else} result := NormToUpperAnsi7Byte[ord(p^)]; // 7 bit char uppercase {$endif} if result=0 then goto Err; // end of input text, without a word inc(p); // trim initial spaces or 'H' until AnsiChar(result) in ['A'..'G','I'..'Z']; end; function GetHighUTF8UCS4(var U: PUTF8Char): PtrUInt; var extra,i: PtrInt; c: PtrUInt; begin result := 0; c := byte(U^); // here U^>=#80 inc(U); extra := UTF8_EXTRABYTES[c]; if extra=0 then exit else // invalid leading byte for i := 1 to extra do begin if byte(U^) and $c0<>$80 then exit; // invalid input content c := c shl 6+byte(U^); inc(U); end; with UTF8_EXTRA[extra] do begin dec(c,offset); if c=#80 inc(U); extra := UTF8_EXTRABYTES[c]; if extra=0 then exit else // invalid leading byte for i := 1 to extra do begin if byte(U^) and $c0<>$80 then exit; // invalid input content c := c shl 6+byte(U^); inc(U); end; with UTF8_EXTRA[extra] do begin dec(c,offset); if cnil then repeat v := GetNextUTF8Upper(U); if not (v in IsWord) then break; dec(v,ord('B')); if v>high(TSoundExValues) then continue; v := Values[v]; // get soundex value if (v=0) or (v=old) then continue; // invalid or dopple value old := v; result := result shl SOUNDEX_BITS; inc(result,v); inc(n); if n=((32-8)div SOUNDEX_BITS) then // first char use up to 8 bits break; // result up to a cardinal size until false; end; function SoundExComputeFirstCharUTF8(var U: PUTF8Char): cardinal; label Err; begin if U=nil then begin Err:result := 0; exit; end; repeat result := GetNextUTF8Upper(U); if result=0 then goto Err; // end of input text, without a word // trim initial spaces or 'H' until AnsiChar(result) in ['A'..'G','I'..'Z']; end; function FindNextUTF8WordBegin(U: PUTF8Char): PUTF8Char; var c: cardinal; V: PUTF8Char; begin result := nil; repeat c := GetNextUTF8Upper(U); if c=0 then exit; until not(c in IsWord); repeat V := U; c := GetNextUTF8Upper(U); if c=0 then exit; until c in IsWord; result := V; end; { TSynSoundEx } const /// english Soundex pronunciation scores // - defines the default values used for the SoundEx() function below // (used if Values parameter is nil) ValueEnglish: TSoundExValues = // B C D E F G H I J K L M N O P Q R S T U V W X Y Z (1,2,3,0,1,2,0,0,2,2,4,5,5,0,1,2,6,2,3,0,1,0,2,0,2); /// french Soundex pronunciation scores // - can be used to override default values used for the SoundEx() // function below ValueFrench: TSoundExValues = // B C D E F G H I J K L M N O P Q R S T U V W X Y Z (1,2,3,0,9,7,0,0,7,2,4,5,5,0,1,2,6,8,3,0,9,0,8,0,8); /// spanish Soundex pronunciation scores // - can be used to override default values used for the SoundEx() // function below ValueSpanish: TSoundExValues = // B C D E F G H I J K L M N O P Q R S T U V W X Y Z (1,2,3,0,1,2,0,0,0,2,0,5,5,0,1,2,6,2,3,0,1,0,2,0,2); SOUNDEXVALUES: array[TSynSoundExPronunciation] of PSoundExValues = (@ValueEnglish,@ValueFrench,@ValueSpanish,@ValueEnglish); function TSynSoundEx.Ansi(A: PAnsiChar): boolean; var Value, c: cardinal; begin result := false; if A=nil then exit; repeat // test beginning of word c := SoundExComputeFirstCharAnsi(A); if c=0 then exit else if c=FirstChar then begin // here we had the first char match -> check if word match UpperValue Value := c-(ord('A')-1); SoundExComputeAnsi(A,Value,fValues); if Value=search then begin result := true; // UpperValue found! exit; end; end else repeat if A^=#0 then exit else {$ifdef USENORMTOUPPER} if not(NormToUpperByte[ord(A^)] in IsWord) then break else inc(A); {$else} if not(ord(A^) in IsWord) then break else inc(A); {$endif} until false; // find beginning of next word repeat if A^=#0 then exit else {$ifdef USENORMTOUPPER} if NormToUpperByte[ord(A^)] in IsWord then break else inc(A); {$else} if ord(A^) in IsWord then break else inc(A); {$endif} until false; until false; end; function TSynSoundEx.UTF8(U: PUTF8Char): boolean; var Value, c: cardinal; V: PUTF8Char; begin result := false; if U=nil then exit; repeat // find beginning of word c := SoundExComputeFirstCharUTF8(U); if c=0 then exit else if c=FirstChar then begin // here we had the first char match -> check if word match UpperValue Value := c-(ord('A')-1); SoundExComputeUTF8(U,Value,fValues); if Value=search then begin result := true; // UpperValue found! exit; end; end else repeat c := GetNextUTF8Upper(U); if c=0 then exit; until not(c in IsWord); // find beginning of next word repeat if U=nil then exit; V := U; c := GetNextUTF8Upper(U); if c=0 then exit; until c in IsWord; U := V; until U=nil; end; function TSynSoundEx.Prepare(UpperValue: PAnsiChar; Lang: PSoundExValues): boolean; begin fValues := Lang; Search := SoundExAnsi(UpperValue,nil,Lang); if Search=0 then result := false else begin FirstChar := SoundExComputeFirstCharAnsi(UpperValue); result := true; end; end; function TSynSoundEx.Prepare(UpperValue: PAnsiChar; Lang: TSynSoundExPronunciation): boolean; begin result := Prepare(UpperValue,SOUNDEXVALUES[Lang]); end; function SoundExAnsi(A: PAnsiChar; next: PPAnsiChar; Lang: PSoundExValues): cardinal; begin result := SoundExComputeFirstCharAnsi(A); if result<>0 then begin dec(result,ord('A')-1); // first Soundex char is first char SoundExComputeAnsi(A,result,Lang); end; if next<>nil then begin {$ifdef USENORMTOUPPER} while NormToUpperByte[ord(A^)] in IsWord do inc(A); // go to end of word {$else} while ord(A^) in IsWord do inc(A); // go to end of word {$endif} next^ := A; end; end; function SoundExAnsi(A: PAnsiChar; next: PPAnsiChar; Lang: TSynSoundExPronunciation): cardinal; begin result := SoundExAnsi(A,next,SOUNDEXVALUES[Lang]); end; function SoundExUTF8(U: PUTF8Char; next: PPUTF8Char; Lang: TSynSoundExPronunciation): cardinal; begin result := SoundExComputeFirstCharUTF8(U); if result<>0 then begin dec(result,ord('A')-1); // first Soundex char is first char SoundExComputeUTF8(U,result,SOUNDEXVALUES[Lang]); end; if next<>nil then next^ := FindNextUTF8WordBegin(U); end; {$ifdef USENORMTOUPPER} function AnsiICompW(u1, u2: PWideChar): PtrInt; {$ifdef HASINLINE}inline;{$endif} begin if u1<>u2 then if u1<>nil then if u2<>nil then repeat result := PtrInt(u1^)-PtrInt(u2^); if result<>0 then begin if (PtrInt(u1^)>255) or (PtrInt(u2^)>255) then exit; result := NormToUpperAnsi7Byte[PtrInt(u1^)]-NormToUpperAnsi7Byte[PtrInt(u2^)]; if result<>0 then exit; end; if (u1^=#0) or (u2^=#0) then break; inc(u1); inc(u2); until false else result := 1 else // u2='' result := -1 else // u1='' result := 0; // u1=u2 end; {$ifdef PUREPASCAL} function AnsiIComp(Str1, Str2: PWinAnsiChar): PtrInt; var table: PNormTableByte; begin if Str1<>Str2 then if Str1<>nil then if Str2<>nil then begin table := @NormToUpperByte; repeat result := table[ord(Str1^)]-table[pByte(Str2)^]; if result<>0 then exit; if (Str1^=#0) or (Str2^=#0) then break; inc(Str1); inc(Str2); until false; end else result := 1 else // Str2='' result := -1 else // Str1='' result := 0; // Str1=Str2 end; {$else} function AnsiIComp(Str1, Str2: PWinAnsiChar): PtrInt; asm // fast 8 bits WinAnsi comparaison using the NormToUpper[] array cmp eax, edx je @2 test eax, edx // is either of the strings perhaps nil? jz @3 @0: push ebx // compare the first character (faster quicksort) movzx ebx, byte ptr[eax] // ebx=S1[1] movzx ecx, byte ptr[edx] // ecx=S2[1] test ebx, ebx jz @z cmp ebx, ecx je @s mov bl, byte ptr[NormToUpper + ebx] mov cl, byte ptr[NormToUpper + ecx] cmp ebx, ecx je @s mov eax, ebx pop ebx sub eax, ecx // return S1[1]-S2[1] ret @2b: pop ebx @2: xor eax, eax ret @3: test eax, eax // S1='' jz @4 test edx, edx // S2='' ? jnz @0 mov eax, 1 // return 1 (S1>S2) ret @s: inc eax inc edx mov bl, [eax] // ebx=S1[i] mov cl, [edx] // ecx=S2[i] test ebx, ebx je @z // end of S1 cmp ebx, ecx je @s mov bl, byte ptr[NormToUpper + ebx] mov cl, byte ptr[NormToUpper + ecx] cmp ebx, ecx je @s mov eax, ebx pop ebx sub eax, ecx // return S1[i]-S2[i] ret @z: cmp ebx, ecx // S1=S2? jz @2b pop ebx @4: or eax, -1 // return -1 (S1$80 then exit else // invalid input content c := c shl 6+byte(P[i]); with UTF8_EXTRA[extra] do begin dec(c,offset); if cLD then SetLength(result,LD); end; function LowerCaseU(const S: RawUTF8): RawUTF8; var LS,LD: integer; begin LS := length(S); FastSetString(result,pointer(S),LS); LD := ConvertCaseUTF8(pointer(result),NormToLowerByte); if LS<>LD then SetLength(result,LD); end; function UTF8IComp(u1, u2: PUTF8Char): PtrInt; var c2: PtrInt; table: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperByte{$else}PNormTableByte{$endif}; begin // fast UTF-8 comparaison using the NormToUpper[] array for all 8 bits values {$ifndef CPUX86NOTPIC}table := @NormToUpperByte;{$endif} if u1<>u2 then if u1<>nil then if u2<>nil then repeat result := ord(u1^); c2 := ord(u2^); if result<=127 then if result<>0 then begin inc(u1); result := table[result]; if c2<=127 then begin if c2=0 then exit; // u1>u2 -> return u1^ inc(u2); dec(result,table[c2]); if result<>0 then exit; continue; end; end else begin // u1^=#0 -> end of u1 reached if c2<>0 then // end of u2 reached -> u1=u2 -> return 0 result := -1; // u1u2 -> return u1^ inc(u2); dec(result,table[c2]); if result<>0 then exit; continue; end else begin c2 := GetHighUTF8UCS4Inlined(u2); if c2<=255 then dec(result,table[c2]) else // 8 bits to upper dec(result,c2); // 32-bit widechar returns diff if result<>0 then exit; end; until false else result := 1 else // u2='' result := -1 else // u1='' result := 0; // u1=u2 end; function UTF8ILComp(u1, u2: PUTF8Char; L1,L2: cardinal): PtrInt; var c2: PtrInt; extra,i: integer; table: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperByte{$else}PNormTableByte{$endif}; label neg,pos; begin // fast UTF-8 comparaison using the NormToUpper[] array for all 8 bits values {$ifndef CPUX86NOTPIC}table := @NormToUpperByte;{$endif} if u1<>u2 then if (u1<>nil) and (L1<>0) then if (u2<>nil) and (L2<>0) then repeat result := ord(u1^); c2 := ord(u2^); inc(u1); dec(L1); if result<=127 then begin result := table[result]; if c2<=127 then begin dec(result,table[c2]); dec(L2); inc(u2); if result<>0 then exit else if L1<>0 then if L2<>0 then continue else // L1>0 and L2>0 -> next char goto pos else // L1>0 and L2=0 -> u1>u2 if L2<>0 then goto neg else // L1=0 and L2>0 -> u1 u1=u2 end; end else begin extra := UTF8_EXTRABYTES[result]; if extra=0 then goto neg; // invalid leading byte dec(L1,extra); if Integer(L1)<0 then goto neg; for i := 0 to extra-1 do result := result shl 6+PByteArray(u1)[i]; dec(result,UTF8_EXTRA[extra].offset); inc(u1,extra); if result and $ffffff00=0 then result := table[result]; // 8 bits to upper, 32-bit as is end; // here result=NormToUpper[u1^] inc(u2); dec(L2); if c2<=127 then begin dec(result,table[c2]); if result<>0 then exit; end else begin extra := UTF8_EXTRABYTES[c2]; if extra=0 then goto pos; dec(L2,extra); if integer(L2)<0 then goto pos; for i := 0 to extra-1 do c2 := c2 shl 6+PByteArray(u2)[i]; dec(c2,UTF8_EXTRA[extra].offset); inc(u2,extra); if c2 and $ffffff00=0 then dec(result,table[c2]) else // 8 bits to upper dec(result,c2); // returns 32-bit diff if result<>0 then exit; end; // here we have result=NormToUpper[u2^]-NormToUpper[u1^]=0 if L1=0 then // test if we reached end of u1 or end of u2 if L2=0 then exit // u1=u2 else goto neg else // u1u2 until false else pos: result := 1 else // u2='' or u1>u2 neg: result := -1 else // u1='' or u1UpperValue^ then break; {$else} if NormToUpperAnsi7[A^]<>UpperValue^ then break; {$endif} inc(UpperValue); if UpperValue^=#0 then begin result := true; // UpperValue found! exit; end; inc(A); if A^=#0 then exit; until false; // find beginning of next word repeat if A^=#0 then exit else {$ifdef USENORMTOUPPER} if not (NormToUpperByte[ord(A^)] in IsWord) then break else inc(A); {$else} if not (ord(A^) in IsWord) then break else inc(A); {$endif} until false; until false; end; function FindUnicode(PW, Upper: PWideChar; UpperLen: integer): boolean; var Start: PWideChar; begin result := false; if (PW=nil) or (Upper=nil) then exit; repeat // go to beginning of next word repeat if ord(PW^)=0 then exit else if (ord(PW^)>126) or (ord(PW^) in IsWord) then Break; inc(PW); until false; Start := PW; // search end of word matching UpperLen characters repeat inc(PW); until (PW-Start>=UpperLen) or (ord(PW^)=0) or ((ord(PW^)<126) and (not(ord(PW^) in IsWord))); if PW-Start>=UpperLen then if CompareStringW(LOCALE_USER_DEFAULT,NORM_IGNORECASE,Start,UpperLen,Upper,UpperLen)=2 then begin result := true; // match found exit; end; // not found: go to end of current word repeat if PW^=#0 then exit else if ((ord(PW^)<126) and (not(ord(PW^) in IsWord))) then Break; inc(PW); until false; until false; end; function FindUTF8(U: PUTF8Char; UpperValue: PAnsiChar): boolean; var ValueStart: PAnsiChar; {$ifdef USENORMTOUPPER} c: PtrUInt; FirstChar: AnsiChar; label Next; {$else} ch: AnsiChar; {$endif} begin result := false; if (U=nil) or (UpperValue=nil) then exit; {$ifdef USENORMTOUPPER} // handles 8-bits WinAnsi chars inside UTF-8 encoded data FirstChar := UpperValue^; ValueStart := UpperValue+1; repeat // test beginning of word repeat c := byte(U^); inc(U); if c=0 then exit else if c<=127 then begin if c in IsWord then if PAnsiChar(@NormToUpper)[c]<>FirstChar then goto Next else break; end else if c and $20=0 then begin // fast direct process $0..$7ff c := c shl 6+byte(U^)-$3080; inc(U); if c<=255 then begin c := NormToUpperByte[c]; if c in IsWord then if AnsiChar(c)<>FirstChar then goto Next else break; end; end else if UTF8_EXTRABYTES[c]=0 then exit else // invalid leading byte inc(U,UTF8_EXTRABYTES[c]); // just ignore surrogates for soundex until false; // here we had the first char match -> check if this word match UpperValue UpperValue := ValueStart; repeat if UpperValue^=#0 then begin result := true; // UpperValue found! exit; end; c := byte(U^); inc(U); // next chars if c=0 then exit else if c<=127 then begin if PAnsiChar(@NormToUpper)[c]<>UpperValue^ then break; end else if c and $20=0 then begin c := c shl 6+byte(U^)-$3080; inc(U); if (c>255) or (PAnsiChar(@NormToUpper)[c]<>UpperValue^) then break; end else begin if UTF8_EXTRABYTES[c]=0 then exit else // invalid leading byte inc(U,UTF8_EXTRABYTES[c]); break; end; inc(UpperValue); until false; Next: // find beginning of next word U := FindNextUTF8WordBegin(U); until U=nil; {$else} // this tiny version only handles 7-bits ansi chars and ignore all UTF-8 chars ValueStart := UpperValue; repeat // find beginning of word repeat if byte(U^)=0 then exit else if byte(U^)<=127 then if byte(U^) in IsWord then break else inc(U) else if byte(U^) and $20=0 then inc(U,2) else inc(U,3); until false; // check if this word is the UpperValue UpperValue := ValueStart; repeat ch := NormToUpperAnsi7[U^]; if ch<>UpperValue^ then break; inc(UpperValue); if UpperValue^=#0 then begin result := true; // UpperValue found! exit; end; inc(U); if byte(U^)=0 then exit else if byte(U^) and $80<>0 then break; // 7 bits char check only until false; // find beginning of next word U := FindNextUTF8WordBegin(U); until U=nil; {$endif} end; function HexDisplayToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: integer): boolean; var B,C: PtrUInt; i: integer; tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; begin result := false; // return false if any invalid char if (Hex=nil) or (Bin=nil) then exit; {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 inc(Bin,BinBytes-1); for i := 1 to BinBytes do begin B := tab[Ord(Hex^)]; inc(Hex); if B>15 then exit; B := B shl 4; C := tab[Ord(Hex^)]; inc(Hex); if C>15 then exit; Bin^ := B+C; dec(Bin); end; result := true; // correct content in Hex end; function HexDisplayToCardinal(Hex: PAnsiChar; out aValue: cardinal): boolean; begin result := HexDisplayToBin(Hex,@aValue,SizeOf(aValue)); if not result then aValue := 0; end; function HexDisplayToInt64(Hex: PAnsiChar; out aValue: Int64): boolean; begin result := HexDisplayToBin(Hex,@aValue,SizeOf(aValue)); if not result then aValue := 0; end; function HexDisplayToInt64(const Hex: RawByteString): Int64; begin if not HexDisplayToBin(pointer(Hex),@result,SizeOf(result)) then result := 0; end; function HexToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer): boolean; var I: Integer; B,C: PtrUInt; tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; begin result := false; // return false if any invalid char if Hex=nil then exit; {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 if Bin<>nil then for I := 1 to BinBytes do begin B := tab[Ord(Hex^)]; inc(Hex); if B>15 then exit; B := B shl 4; C := tab[Ord(Hex^)]; inc(Hex); if C>15 then exit; Bin^ := B+C; inc(Bin); end else for I := 1 to BinBytes do begin // Bin=nil -> validate Hex^ input B := tab[Ord(Hex^)]; inc(Hex); if B>15 then exit; C := tab[Ord(Hex^)]; inc(Hex); if C>15 then exit; end; result := true; // conversion OK end; function IsHex(const Hex: RawByteString; BinBytes: integer): boolean; begin result := (length(Hex)=BinBytes*2) and SynCommons.HexToBin(pointer(Hex),nil,BinBytes); end; function HexToCharValid(Hex: PAnsiChar): boolean; begin result := (ConvertHexToBin[Ord(Hex[0])]<=15) and (ConvertHexToBin[Ord(Hex[1])]<=15); end; function HexToChar(Hex: PAnsiChar; Bin: PUTF8Char): boolean; var B,C: PtrUInt; begin if Hex<>nil then begin B := ConvertHexToBin[Ord(Hex[0])]; if B<=15 then begin C := ConvertHexToBin[Ord(Hex[1])]; if C<=15 then begin if Bin<>nil then Bin^ := AnsiChar(B shl 4+C); result := true; exit; end; end; end; result := false; // return false if any invalid char end; function HexToWideChar(Hex: PAnsiChar): cardinal; var B: PtrUInt; begin result := ConvertHexToBin[Ord(Hex[0])]; if result<=15 then begin B := ConvertHexToBin[Ord(Hex[1])]; if B<=15 then begin result := result shl 4+B; B := ConvertHexToBin[Ord(Hex[2])]; if B<=15 then begin result := result shl 4+B; B := ConvertHexToBin[Ord(Hex[3])]; if B<=15 then begin result := result shl 4+B; exit; end; end; end; end; result := 0; end; { --------- Base64 encoding/decoding } type TBase64Enc = array[0..63] of AnsiChar; TBase64Dec = array[AnsiChar] of shortint; const b64enc: TBase64Enc = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; b64URIenc: TBase64Enc = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_'; var /// a conversion table from Base64 text into binary data // - used by Base64ToBin/IsBase64 functions // - contains -1 for invalid char, -2 for '=', 0..63 for b64enc[] chars ConvertBase64ToBin, ConvertBase64URIToBin: TBase64Dec; function Base64AnyDecode(const decode: TBase64Dec; sp,rp: PAnsiChar; len: PtrInt): boolean; var c, ch: PtrInt; begin result := false; while len>=4 do begin c := decode[sp[0]]; if c<0 then exit; c := c shl 6; ch := decode[sp[1]]; if ch<0 then exit; c := (c or ch) shl 6; ch := decode[sp[2]]; if ch<0 then exit; c := (c or ch) shl 6; ch := decode[sp[3]]; if ch<0 then exit; c := c or ch; rp[2] := AnsiChar(c); c := c shr 8; rp[1] := AnsiChar(c); c := c shr 8; rp[0] := AnsiChar(c); dec(len,4); inc(rp,3); inc(sp,4); end; if len>=2 then begin c := decode[sp[0]]; if c<0 then exit; c := c shl 6; ch := decode[sp[1]]; if ch<0 then exit; if len=2 then rp[0] := AnsiChar((c or ch) shr 4) else begin c := (c or ch) shl 6; ch := decode[sp[2]]; if ch<0 then exit; c := (c or ch) shr 2; rp[1] := AnsiChar(c); rp[0] := AnsiChar(c shr 8); end; end; result := true; end; function Base64Decode(sp,rp: PAnsiChar; len: PtrInt): boolean; {$ifdef FPC}inline;{$endif} begin len := len shl 2; // len was the number of 4 chars chunks in sp if (len>0) and (ConvertBase64ToBin[sp[len-2]]>=0) then if ConvertBase64ToBin[sp[len-1]]>=0 then else dec(len) else dec(len,2); // Base64AnyDecode() algorithm ignores the trailing '=' result := Base64AnyDecode(ConvertBase64ToBin,sp,rp,len); end; {$ifdef PUREPASCAL} function Base64EncodeMain(rp, sp: PAnsiChar; len: cardinal): integer; var i: integer; c: cardinal; enc: TBase64Enc; // a local stack copy makes the loop slightly faster begin enc := b64enc; result := len div 3; for i := 1 to result do begin c := ord(sp[0]) shl 16 + ord(sp[1]) shl 8 + ord(sp[2]); rp[0] := enc[(c shr 18) and $3f]; rp[1] := enc[(c shr 12) and $3f]; rp[2] := enc[(c shr 6) and $3f]; rp[3] := enc[c and $3f]; inc(rp,4); inc(sp,3); end; end; {$else PUREPASCAL} function Base64EncodeMain(rp, sp: PAnsiChar; len: cardinal): integer; asm // eax=rp edx=sp ecx=len - pipeline optimized version by AB push ebx push esi push edi push ebp mov ebx, edx mov esi, eax mov eax, ecx mov edx, 1431655766 // faster eax=len div 3 using reciprocal sar ecx, 31 imul edx mov eax, edx sub eax, ecx mov edi, offset b64enc mov ebp, eax push eax jz @z // edi=b64enc[] ebx=sp esi=rp ebp=len div 3 xor eax, eax @1: // read 3 bytes from sp movzx edx, byte ptr[ebx] shl edx, 16 mov al, [ebx + 2] mov ah, [ebx + 1] add ebx, 3 or eax, edx // encode as Base64 mov ecx, eax mov edx, eax shr ecx, 6 and edx, $3f and ecx, $3f mov dh, [edi + edx] mov dl, [edi + ecx] mov ecx, eax shr eax, 12 shr ecx, 18 shl edx, 16 and ecx, $3f and eax, $3f mov cl, [edi + ecx] mov ch, [edi + eax] or ecx, edx // write the 4 encoded bytes into rp mov [esi], ecx add esi, 4 dec ebp jnz @1 @z: pop eax // result := len div 3 pop ebp pop edi pop esi pop ebx end; {$endif PUREPASCAL} procedure Base64EncodeTrailing(rp, sp: PAnsiChar; len: cardinal); {$ifdef HASINLINE}inline;{$endif} var c: cardinal; begin case len of 1: begin c := ord(sp[0]) shl 4; rp[0] := b64enc[(c shr 6) and $3f]; rp[1] := b64enc[c and $3f]; rp[2] := '='; rp[3] := '='; end; 2: begin c := ord(sp[0]) shl 10 + ord(sp[1]) shl 2; rp[0] := b64enc[(c shr 12) and $3f]; rp[1] := b64enc[(c shr 6) and $3f]; rp[2] := b64enc[c and $3f]; rp[3] := '='; end; end; end; procedure Base64Encode(rp, sp: PAnsiChar; len: cardinal); var main: cardinal; begin main := Base64EncodeMain(rp,sp,len); Base64EncodeTrailing(rp+main*4,sp+main*3,len-main*3); end; function BinToBase64Length(len: PtrUInt): PtrUInt; begin result := ((len+2)div 3)*4; end; function BinToBase64(const s: RawByteString): RawUTF8; var len: integer; begin result := ''; len := length(s); if len=0 then exit; SetLength(result,BinToBase64Length(len)); Base64Encode(pointer(result),pointer(s),len); end; function BinToBase64(Bin: PAnsiChar; BinBytes: integer): RawUTF8; begin result := ''; if BinBytes=0 then exit; SetLength(result,BinToBase64Length(BinBytes)); Base64Encode(pointer(result),Bin,BinBytes); end; function BinToBase64(const data, Prefix, Suffix: RawByteString; WithMagic: boolean): RawUTF8; var lendata,lenprefix,lensuffix,len: integer; res: PByteArray absolute result; begin result := ''; lendata := length(data); lenprefix := length(Prefix); lensuffix := length(Suffix); if lendata+lenprefix+lensuffix=0 then exit; len := ((lendata+2) div 3)*4+lenprefix+lensuffix; if WithMagic then inc(len,3); SetLength(result,len); {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(Prefix)^,res[0],lenprefix); if WithMagic then begin PInteger(@res[lenprefix])^ := JSON_BASE64_MAGIC; inc(lenprefix,3); end; Base64Encode(@res[lenprefix],pointer(data),lendata); {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(Suffix)^,res[len-lensuffix],lensuffix); end; function BinToBase64WithMagic(const data: RawByteString): RawUTF8; var len: integer; begin result := ''; len := length(data); if len=0 then exit; SetLength(result,((len+2) div 3)*4+3); PInteger(pointer(result))^ := JSON_BASE64_MAGIC; Base64Encode(PAnsiChar(pointer(result))+3,pointer(data),len); end; function BinToBase64WithMagic(Data: pointer; DataLen: integer): RawUTF8; begin result := ''; if DataLen<=0 then exit; SetLength(result,((DataLen+2) div 3)*4+3); PInteger(pointer(result))^ := JSON_BASE64_MAGIC; Base64Encode(PAnsiChar(pointer(result))+3,Data,DataLen); end; function IsBase64(sp: PAnsiChar; len: PtrInt): boolean; var i: PtrInt; begin result := false; if (len=0) or (len and 3<>0) then exit; for i := 0 to len-5 do if ConvertBase64ToBin[sp[i]]<0 then exit; inc(sp,len-4); if (ConvertBase64ToBin[sp[0]]=-1) or (ConvertBase64ToBin[sp[1]]=-1) or (ConvertBase64ToBin[sp[2]]=-1) or (ConvertBase64ToBin[sp[3]]=-1) then exit; result := true; // layout seems correct end; function IsBase64(const s: RawByteString): boolean; begin result := IsBase64(pointer(s),length(s)); end; function Base64ToBinLengthSafe(sp: PAnsiChar; len: PtrInt): PtrInt; begin if IsBase64(sp,len) then begin if ConvertBase64ToBin[sp[len-2]]>=0 then if ConvertBase64ToBin[sp[len-1]]>=0 then result := 0 else result := 1 else result := 2; result := (len shr 2)*3-result; end else result := 0; end; function Base64ToBinLength(sp: PAnsiChar; len: PtrInt): PtrInt; begin result := 0; if (len=0) or (len and 3<>0) then exit; if ConvertBase64ToBin[sp[len-2]]>=0 then if ConvertBase64ToBin[sp[len-1]]>=0 then result := 0 else result := 1 else result := 2; result := (len shr 2)*3-result; end; function Base64ToBin(const s: RawByteString): RawByteString; begin Base64ToBinSafe(pointer(s),length(s),result); end; function Base64ToBin(sp: PAnsiChar; len: PtrInt): RawByteString; begin Base64ToBinSafe(sp,len,result); end; function Base64ToBin(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; begin result := Base64ToBinSafe(sp,len,data); end; function Base64ToBinSafe(const s: RawByteString): RawByteString; begin Base64ToBinSafe(pointer(s),length(s),result); end; function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt): RawByteString; begin Base64ToBinSafe(sp,len,result); end; function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; var resultLen: PtrInt; begin resultLen := Base64ToBinLength(sp,len); if resultLen<>0 then begin SetString(data,nil,resultLen); if ConvertBase64ToBin[sp[len-2]]>=0 then if ConvertBase64ToBin[sp[len-1]]>=0 then else dec(len) else dec(len,2); // adjust for Base64AnyDecode() algorithm result := Base64AnyDecode(ConvertBase64ToBin,sp,pointer(data),len); if not result then data := ''; end else begin result := false; data := ''; end; end; function Base64ToBin(sp: PAnsiChar; len: PtrInt; var blob: TSynTempBuffer): boolean; begin blob.Init(Base64ToBinLength(sp,len)); result := (blob.len>0) and Base64Decode(sp,blob.buf,len shr 2); end; function Base64ToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt; nofullcheck: boolean): boolean; begin // nofullcheck is just ignored and deprecated result := (bin<>nil) and (Base64ToBinLength(base64,base64len)=binlen) and Base64Decode(base64,bin,base64len shr 2); end; function Base64ToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt; nofullcheck: boolean): boolean; begin result := Base64ToBin(pointer(base64),bin,length(base64),binlen,nofullcheck); end; { --------- Base64 URI encoding/decoding } {$ifdef PUREPASCAL} procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal); var i, main, c: cardinal; enc: TBase64Enc; // a local stack copy makes the loop slightly faster begin enc := b64URIenc; main := len div 3; for i := 1 to main do begin c := ord(sp[0]) shl 16 + ord(sp[1]) shl 8 + ord(sp[2]); rp[0] := enc[(c shr 18) and $3f]; rp[1] := enc[(c shr 12) and $3f]; rp[2] := enc[(c shr 6) and $3f]; rp[3] := enc[c and $3f]; inc(rp,4); inc(sp,3); end; case len-main*3 of 1: begin c := ord(sp[0]) shl 4; rp[0] := enc[(c shr 6) and $3f]; rp[1] := enc[c and $3f]; end; 2: begin c := ord(sp[0]) shl 10 + ord(sp[1]) shl 2; rp[0] := enc[(c shr 12) and $3f]; rp[1] := enc[(c shr 6) and $3f]; rp[2] := enc[c and $3f]; end; end; end; {$else PUREPASCAL} function Base64uriEncodeMain(rp, sp: PAnsiChar; len: cardinal): integer; asm // eax=rp edx=sp ecx=len - pipeline optimized version by AB push ebx push esi push edi push ebp mov ebx, edx mov esi, eax mov eax, ecx mov edx, 1431655766 // faster eax=len div 3 using reciprocal sar ecx, 31 imul edx mov eax, edx sub eax, ecx mov edi, offset b64urienc mov ebp, eax push eax jz @z // edi=b64urienc[] ebx=sp esi=rp ebp=len div 3 xor eax, eax @1: // read 3 bytes from sp movzx edx, byte ptr[ebx] shl edx, 16 mov al, [ebx + 2] mov ah, [ebx + 1] add ebx, 3 or eax, edx // encode as Base64uri mov ecx, eax mov edx, eax shr ecx, 6 and edx, $3f and ecx, $3f mov dh, [edi + edx] mov dl, [edi + ecx] mov ecx, eax shr eax, 12 shr ecx, 18 shl edx, 16 and ecx, $3f and eax, $3f mov cl, [edi + ecx] mov ch, [edi + eax] or ecx, edx // write the 4 encoded bytes into rp mov [esi], ecx add esi, 4 dec ebp jnz @1 @z: pop eax // result := len div 3 pop ebp pop edi pop esi pop ebx end; procedure Base64uriEncodeTrailing(rp, sp: PAnsiChar; len: cardinal); {$ifdef HASINLINE}inline;{$endif} var c: cardinal; begin case len of 1: begin c := ord(sp[0]) shl 4; rp[0] := b64urienc[(c shr 6) and $3f]; rp[1] := b64urienc[c and $3f]; end; 2: begin c := ord(sp[0]) shl 10 + ord(sp[1]) shl 2; rp[0] := b64urienc[(c shr 12) and $3f]; rp[1] := b64urienc[(c shr 6) and $3f]; rp[2] := b64urienc[c and $3f]; end; end; end; procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal); var main: cardinal; begin main := Base64uriEncodeMain(rp,sp,len); Base64uriEncodeTrailing(rp+main*4,sp+main*3,len-main*3); end; {$endif PUREPASCAL} function BinToBase64uriLength(len: PtrUInt): PtrUInt; begin result := (len div 3)*4; case len-(result shr 2)*3 of // fast len mod 3 1: inc(result,2); 2: inc(result,3); end; end; function BinToBase64uri(const s: RawByteString): RawUTF8; var len: integer; begin result := ''; len := length(s); if len=0 then exit; SetLength(result,BinToBase64uriLength(len)); Base64uriEncode(pointer(result),pointer(s),len); end; function BinToBase64uri(Bin: PAnsiChar; BinBytes: integer): RawUTF8; begin result := ''; if BinBytes<=0 then exit; SetLength(result,BinToBase64uriLength(BinBytes)); Base64uriEncode(pointer(result),Bin,BinBytes); end; function BinToBase64uriShort(Bin: PAnsiChar; BinBytes: integer): shortstring; var len: integer; begin result := ''; if BinBytes<=0 then exit; len := BinToBase64uriLength(BinBytes); if len>255 then exit; byte(result[0]) := len; Base64uriEncode(@result[1],Bin,BinBytes); end; function Base64uriToBinLength(len: PtrInt): PtrInt; begin if len=0 then result := 0 else begin result := (len shr 2)*3; case len and 3 of 1: result := 0; 2: inc(result,1); 3: inc(result,2); end; end; end; function Base64uriDecode(sp,rp: PAnsiChar; len: PtrInt): boolean; begin result := Base64AnyDecode(ConvertBase64URIToBin,sp,rp,len); end; function Base64uriToBin(sp: PAnsiChar; len: PtrInt): RawByteString; begin Base64uriToBin(sp,len,result); end; function Base64uriToBin(const s: RawByteString): RawByteString; begin Base64uriToBin(pointer(s),length(s),result); end; procedure Base64uriToBin(sp: PAnsiChar; len: PtrInt; var result: RawByteString); var resultLen: PtrInt; begin resultLen := Base64uriToBinLength(len); if resultLen<>0 then begin SetString(result,nil,resultLen); if Base64AnyDecode(ConvertBase64URIToBin,sp,pointer(result),len) then exit; end; result := ''; end; function Base64uriToBin(sp: PAnsiChar; len: PtrInt; var temp: TSynTempBuffer): boolean; begin temp.Init(Base64uriToBinLength(len)); result := (temp.len>0) and Base64AnyDecode(ConvertBase64URIToBin,sp,temp.buf,len); end; function Base64uriToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt): boolean; begin result := Base64uriToBin(pointer(base64),bin,length(base64),binlen); end; function Base64uriToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt): boolean; var resultLen: PtrInt; begin resultLen := Base64uriToBinLength(base64len); result := (resultLen=binlen) and Base64AnyDecode(ConvertBase64URIToBin,base64,bin,base64len); end; procedure Base64ToURI(var base64: RawUTF8); var P: PUTF8Char; begin P := UniqueRawUTF8(base64); if P<>nil then repeat case P^ of #0: break; '+': P^ := '-'; '/': P^ := '_'; '=': begin // trim unsignificant trailing '=' characters SetLength(base64,P-pointer(base64)); break; end; end; inc(P); until false; end; function BinToSource(const ConstName, Comment: RawUTF8; Data: pointer; Len, PerLine: integer; const Suffix: RawUTF8): RawUTF8; var W: TTextWriter; temp: TTextWriterStackBuffer; begin if (Data=nil) or (Len<=0) or (PerLine<=0) then result := '' else begin W := TTextWriter.CreateOwnedStream(temp,Len*5+50+length(Comment)+length(Suffix)); try BinToSource(W,ConstName,Comment,Data,Len,PerLine); if Suffix<>'' then begin W.AddString(Suffix); W.AddCR; end; W.SetText(result); finally W.Free; end; end; end; procedure BinToSource(Dest: TTextWriter; const ConstName, Comment: RawUTF8; Data: pointer; Len, PerLine: integer); var line,i: integer; P: PByte; begin if (Dest=nil) or (Data=nil) or (Len<=0) or (PerLine<=0) then exit; Dest.AddShort('const'); if Comment<>'' then Dest.Add(#13#10' // %',[Comment]); Dest.Add(#13#10' %: array[0..%] of byte = (',[ConstName,Len-1]); P := pointer(Data); repeat if len>PerLine then line := PerLine else line := Len; Dest.AddShort(#13#10' '); for i := 0 to line-1 do begin Dest.Add('$'); Dest.AddByteToHex(P^); inc(P); Dest.Add(','); end; dec(Len,line); until Len=0; Dest.CancelLastComma; Dest.Add(');'#13#10' %_LEN = SizeOf(%);'#13#10,[ConstName,ConstName]); end; function UpperCaseUnicode(const S: RawUTF8): RawUTF8; {$ifdef MSWINDOWS} var tmp: RawUnicode; TmpLen: integer; {$endif} begin {$ifdef MSWINDOWS} tmp := Utf8DecodeToRawUnicodeUI(S,@TmpLen); TmpLen := TmpLen shr 1; CharUpperBuffW(pointer(tmp),TmpLen); RawUnicodeToUtf8(pointer(tmp),TmpLen,result); {$endif} {$ifdef POSIX} result := WideStringToUTF8(WideUpperCase(UTF8ToWideString(S))); {$endif} end; function LowerCaseUnicode(const S: RawUTF8): RawUTF8; {$ifdef MSWINDOWS} var tmp: RawUnicode; TmpLen: integer; {$endif} begin {$ifdef MSWINDOWS} tmp := Utf8DecodeToRawUnicodeUI(S,@TmpLen); TmpLen := TmpLen shr 1; CharLowerBuffW(pointer(tmp),TmpLen); RawUnicodeToUtf8(pointer(tmp),TmpLen,result); {$endif} {$ifdef POSIX} result := WideStringToUTF8(WideLowerCase(UTF8ToWideString(S))); {$endif} end; function IsCaseSensitive(const S: RawUTF8): boolean; begin result := IsCaseSensitive(pointer(S),length(S)); end; function IsCaseSensitive(P: PUTF8Char; PLen: integer): boolean; begin result := true; if (P<>nil) and (PLen>0) then repeat if ord(P^) in [ord('a')..ord('z'), ord('A')..ord('Z')] then exit; inc(P); dec(PLen); until PLen=0; result := false; end; function UpperCase(const S: RawUTF8): RawUTF8; var L, i: PtrInt; begin L := length(S); FastSetString(Result,pointer(S),L); for i := 0 to L-1 do if PByteArray(result)[i] in [ord('a')..ord('z')] then dec(PByteArray(result)[i],32); end; procedure UpperCaseCopy(Text: PUTF8Char; Len: integer; var result: RawUTF8); var i: integer; begin FastSetString(result,Text,Len); for i := 0 to Len-1 do if PByteArray(result)[i] in [ord('a')..ord('z')] then dec(PByteArray(result)[i],32); end; procedure UpperCaseCopy(const Source: RawUTF8; var Dest: RawUTF8); var L, i: PtrInt; begin L := length(Source); FastSetString(Dest,pointer(Source),L); for i := 0 to L-1 do if PByteArray(Dest)[i] in [ord('a')..ord('z')] then dec(PByteArray(Dest)[i],32); end; procedure UpperCaseSelf(var S: RawUTF8); var i: PtrInt; P: PByteArray; begin P := UniqueRawUTF8(S); for i := 0 to length(S)-1 do if P[i] in [ord('a')..ord('z')] then dec(P[i],32); end; function LowerCase(const S: RawUTF8): RawUTF8; var L, i: PtrInt; begin L := length(S); FastSetString(result,pointer(S),L); for i := 0 to L-1 do if PByteArray(result)[i] in [ord('A')..ord('Z')] then inc(PByteArray(result)[i],32); end; procedure LowerCaseCopy(Text: PUTF8Char; Len: integer; var result: RawUTF8); var i: integer; begin FastSetString(result,Text,Len); for i := 0 to Len-1 do if PByteArray(result)[i] in [ord('A')..ord('Z')] then inc(PByteArray(result)[i],32); end; procedure LowerCaseSelf(var S: RawUTF8); var i: PtrInt; P: PByteArray; begin P := UniqueRawUTF8(S); for i := 0 to length(S)-1 do if P[i] in [ord('A')..ord('Z')] then inc(P[i],32); end; function TrimLeft(const S: RawUTF8): RawUTF8; var i, l: Integer; begin l := Length(S); i := 1; while (i <= l) and (S[i] <= ' ') do Inc(i); Result := Copy(S, i, Maxint); end; function TrimRight(const S: RawUTF8): RawUTF8; var i: Integer; begin i := Length(S); while (i > 0) and (S[i] <= ' ') do Dec(i); FastSetString(result,pointer(S),i); end; type TAnsiCharToWord = array[AnsiChar] of word; TByteToWord = array[byte] of word; var /// fast lookup table for converting hexadecimal numbers from 0 to 15 // into their ASCII equivalence // - is local for better code generation TwoDigitsHex: array[byte] of array[1..2] of AnsiChar; TwoDigitsHexW: TAnsiCharToWord absolute TwoDigitsHex; TwoDigitsHexWB: array[byte] of word absolute TwoDigitsHex; /// lowercase hexadecimal lookup table TwoDigitsHexLower: array[byte] of array[1..2] of AnsiChar; TwoDigitsHexWLower: TAnsiCharToWord absolute TwoDigitsHexLower; TwoDigitsHexWBLower: array[byte] of word absolute TwoDigitsHexLower; procedure BinToHex(Bin, Hex: PAnsiChar; BinBytes: integer); {$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} begin {$ifdef PUREPASCAL}tab := @TwoDigitsHexW;{$endif} if BinBytes>0 then repeat PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexW{$else}tab{$endif}[Bin^]; inc(Bin); inc(Hex,2); dec(BinBytes); until BinBytes=0; end; function BinToHex(const Bin: RawByteString): RawUTF8; var L: integer; begin L := length(Bin); FastSetString(result,nil,L*2); SynCommons.BinToHex(pointer(Bin),pointer(Result),L); end; function BinToHex(Bin: PAnsiChar; BinBytes: integer): RawUTF8; begin FastSetString(result,nil,BinBytes*2); SynCommons.BinToHex(Bin,pointer(Result),BinBytes); end; function HexToBin(const Hex: RawUTF8): RawByteString; var L: integer; begin L := length(Hex); if L and 1<>0 then L := 0 else // hexadecimal should be in char pairs L := L shr 1; SetLength(result,L); if not SynCommons.HexToBin(pointer(Hex),pointer(result),L) then result := ''; end; function ByteToHex(P: PAnsiChar; Value: byte): PAnsiChar; begin PWord(P)^ := TwoDigitsHexWB[Value]; result := P+2; end; function EscapeBuffer(s,d: PAnsiChar; len,max: integer): PAnsiChar; var i: integer; begin if len>max then len := max; for i := 1 to len do begin if s^ in [' '..#126] then begin d^ := s^; inc(d); end else begin d^ := '$'; inc(d); PWord(d)^ := TwoDigitsHexWB[ord(s^)]; inc(d,2); end; inc(s); end; if len=max then begin PCardinal(d)^ := ord('.')+ord('.')shl 8+ord('.')shl 16; inc(d,3); end else d^ := #0; result := d; end; function LogEscape(source: PAnsiChar; sourcelen: integer; var temp: TLogEscape; enabled: boolean): PAnsiChar; begin if enabled then begin temp[0] := ' '; EscapeBuffer(source,@temp[1],sourcelen,LOGESCAPELEN); end else temp[0] := #0; result := @temp; end; function LogEscapeFull(const source: RawByteString): RawUTF8; begin result := LogEscapeFull(pointer(source),length(source)); end; function LogEscapeFull(source: PAnsiChar; sourcelen: integer): RawUTF8; begin SetLength(result,sourcelen*3); // worse case if sourcelen=0 then exit; sourcelen := EscapeBuffer(source,pointer(result),sourcelen,length(result))-pointer(result); SetLength(result,sourcelen); end; function EscapeToShort(source: PAnsiChar; sourcelen: integer): shortstring; begin result[0] := AnsiChar(EscapeBuffer(source,@result[1],sourcelen,80)-@result[1]); end; function EscapeToShort(const source: RawByteString): shortstring; overload; begin result[0] := AnsiChar(EscapeBuffer(pointer(source),@result[1],length(source),80)-@result[1]); end; procedure BinToHexDisplay(Bin, Hex: PAnsiChar; BinBytes: integer); {$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} begin {$ifdef PUREPASCAL}tab := @TwoDigitsHexW;{$endif} inc(Hex,BinBytes*2); if BinBytes>0 then repeat dec(Hex,2); PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexW{$else}tab{$endif}[Bin^]; inc(Bin); dec(BinBytes); until BinBytes=0; end; function BinToHexDisplay(Bin: PAnsiChar; BinBytes: integer): RawUTF8; begin FastSetString(result,nil,BinBytes*2); BinToHexDisplay(Bin,pointer(result),BinBytes); end; procedure BinToHexLower(Bin, Hex: PAnsiChar; BinBytes: integer); {$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} begin {$ifdef PUREPASCAL}tab := @TwoDigitsHexWLower;{$endif} if BinBytes>0 then repeat PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexWLower{$else}tab{$endif}[Bin^]; inc(Bin); inc(Hex,2); dec(BinBytes); until BinBytes=0; end; function BinToHexLower(const Bin: RawByteString): RawUTF8; begin BinToHexLower(pointer(Bin),length(Bin),result); end; procedure BinToHexLower(Bin: PAnsiChar; BinBytes: integer; var result: RawUTF8); begin FastSetString(result,nil,BinBytes*2); BinToHexLower(Bin,pointer(result),BinBytes); end; function BinToHexLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; begin BinToHexLower(Bin,BinBytes,result); end; procedure BinToHexDisplayLower(Bin, Hex: PAnsiChar; BinBytes: PtrInt); {$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} begin {$ifdef PUREPASCAL}tab := @TwoDigitsHexWLower;{$endif} inc(Hex,BinBytes*2); if BinBytes>0 then repeat dec(Hex,2); PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexWLower{$else}tab{$endif}[Bin^]; inc(Bin); dec(BinBytes); until BinBytes=0; end; function BinToHexDisplayLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; begin FastSetString(result,nil,BinBytes*2); BinToHexDisplayLower(Bin,pointer(result),BinBytes); end; function BinToHexDisplayLowerShort(Bin: PAnsiChar; BinBytes: integer): shortstring; begin if BinBytes>127 then BinBytes := 127; result[0] := AnsiChar(BinBytes * 2); BinToHexDisplayLower(Bin,@result[1],BinBytes); end; function BinToHexDisplayLowerShort16(Bin: Int64; BinBytes: integer): TShort16; begin if BinBytes>8 then BinBytes := 8; result[0] := AnsiChar(BinBytes * 2); BinToHexDisplayLower(@Bin,@result[1],BinBytes); end; function BinToHexDisplayFile(Bin: PAnsiChar; BinBytes: integer): TFileName; {$ifdef UNICODE} var temp: TSynTempBuffer; begin temp.Init(BinBytes*2); BinToHexDisplayLower(Bin,temp.Buf,BinBytes); Ansi7ToString(PWinAnsiChar(temp.buf),BinBytes*2,string(result)); temp.Done; end; {$else} begin SetString(result,nil,BinBytes*2); BinToHexDisplayLower(Bin,pointer(result),BinBytes); end; {$endif} procedure PointerToHex(aPointer: Pointer; var result: RawUTF8); begin FastSetString(result,nil,SizeOf(Pointer)*2); BinToHexDisplay(@aPointer,pointer(result),SizeOf(Pointer)); end; function PointerToHex(aPointer: Pointer): RawUTF8; begin FastSetString(result,nil,SizeOf(aPointer)*2); BinToHexDisplay(@aPointer,pointer(result),SizeOf(aPointer)); end; function CardinalToHex(aCardinal: Cardinal): RawUTF8; begin FastSetString(result,nil,SizeOf(aCardinal)*2); BinToHexDisplay(@aCardinal,pointer(result),SizeOf(aCardinal)); end; function CardinalToHexLower(aCardinal: Cardinal): RawUTF8; begin FastSetString(result,nil,SizeOf(aCardinal)*2); BinToHexDisplayLower(@aCardinal,pointer(result),SizeOf(aCardinal)); end; function Int64ToHex(aInt64: Int64): RawUTF8; begin FastSetString(result,nil,SizeOf(Int64)*2); BinToHexDisplay(@aInt64,pointer(result),SizeOf(Int64)); end; procedure Int64ToHex(aInt64: Int64; var result: RawUTF8); begin FastSetString(result,nil,SizeOf(Int64)*2); BinToHexDisplay(@aInt64,pointer(result),SizeOf(Int64)); end; function PointerToHexShort(aPointer: Pointer): TShort16; begin result[0] := AnsiChar(SizeOf(aPointer)*2); BinToHexDisplay(@aPointer,@result[1],SizeOf(aPointer)); end; function CardinalToHexShort(aCardinal: Cardinal): TShort16; begin result[0] := AnsiChar(SizeOf(aCardinal)*2); BinToHexDisplay(@aCardinal,@result[1],SizeOf(aCardinal)); end; function Int64ToHexShort(aInt64: Int64): TShort16; begin result[0] := AnsiChar(SizeOf(aInt64)*2); BinToHexDisplay(@aInt64,@result[1],SizeOf(aInt64)); end; procedure Int64ToHexShort(aInt64: Int64; out result: TShort16); begin result[0] := AnsiChar(SizeOf(aInt64)*2); BinToHexDisplay(@aInt64,@result[1],SizeOf(aInt64)); end; function Int64ToHexString(aInt64: Int64): string; var temp: TShort16; begin Int64ToHexShort(aInt64,temp); Ansi7ToString(@temp[1],ord(temp[0]),result); end; type TDiv100Rec = packed record D, M: cardinal; end; procedure Div100(Y: cardinal; var result: TDiv100Rec); {$ifdef HASINLINENOTX86} inline; begin result.D := Y div 100; // FPC will use fast reciprocal result.M := Y-(result.D*100); // avoid div twice end; {$else} asm push ebx mov ecx, eax // ecx=Y mov ebx, edx // ebx=result mov edx, eax mov eax, 1374389535 mul edx shr edx, 5 // edx=Y div 100 mov dword ptr [ebx].TDiv100Rec.D, edx mov eax, 100 mul edx sub ecx, eax // ecx=Y-(edx*100) mov dword ptr [ebx].TDiv100Rec.M, ecx pop ebx end; {$endif HASINLINENOTX86} function UInt3DigitsToUTF8(Value: Cardinal): RawUTF8; begin FastSetString(result,nil,3); PWordArray(result)[0] := TwoDigitLookupW[Value div 10]; PByteArray(result)[2] := (Value mod 10)+48; end; function UInt4DigitsToUTF8(Value: Cardinal): RawUTF8; begin FastSetString(result,nil,4); if Value>9999 then Value := 9999; YearToPChar(Value,pointer(result)); end; function UInt4DigitsToShort(Value: Cardinal): TShort4; begin result[0] := #4; if Value>9999 then Value := 9999; YearToPChar(Value,@result[1]); end; function UInt3DigitsToShort(Value: Cardinal): TShort4; begin if Value>999 then Value := 999; YearToPChar(Value,@result[0]); result[0] := #3; // override first digit end; function UInt2DigitsToShort(Value: byte): TShort4; begin result[0] := #2; if Value>99 then Value := 99; PWord(@result[1])^ := TwoDigitLookupW[Value]; end; function UInt2DigitsToShortFast(Value: byte): TShort4; begin result[0] := #2; PWord(@result[1])^ := TwoDigitLookupW[Value]; end; function SameValue(const A, B: Double; DoublePrec: double): Boolean; var AbsA,AbsB,Res: double; begin if PInt64(@DoublePrec)^=0 then begin // Max(Min(Abs(A),Abs(B))*1E-12,1E-12) AbsA := Abs(A); AbsB := Abs(B); Res := 1E-12; if AbsAB then result := 1 else result := 0; end; function CompareInteger(const A, B: integer): integer; begin if AB then result := 1 else result := 0; end; function CompareInt64(const A, B: Int64): integer; begin if AB then result := 1 else result := 0; end; function CompareCardinal(const A, B: cardinal): integer; begin if AB then result := 1 else result := 0; end; procedure KahanSum(const Data: double; var Sum, Carry: double); var y, t: double; begin y := Data - Carry; t := Sum + y; Carry := (t - Sum) - y; Sum := t; end; function FindRawUTF8(const Values: TRawUTF8DynArray; const Value: RawUTF8; CaseSensitive: boolean=true): integer; begin if CaseSensitive then begin for result := 0 to length(Values)-1 do if Values[result]=Value then exit; end else for result := 0 to length(Values)-1 do if UTF8IComp(pointer(Values[result]),pointer(Value))=0 then exit; result := -1; end; function FindRawUTF8(const Values: array of RawUTF8; const Value: RawUTF8; CaseSensitive: boolean=true): integer; begin if CaseSensitive then begin for result := 0 to high(Values) do if Values[result]=Value then exit; end else for result := 0 to high(Values) do if UTF8IComp(pointer(Values[result]),pointer(Value))=0 then exit; result := -1; end; function FindRawUTF8(const Values: TRawUTF8DynArray; ValuesCount: integer; const Value: RawUTF8; SearchPropName: boolean): integer; begin if SearchPropName then begin for result := 0 to ValuesCount-1 do if IdemPropNameU(Values[result],Value) then exit; end else for result := 0 to ValuesCount-1 do if Values[result]=Value then exit; result := -1; end; function FindPropName(const Names: array of RawUTF8; const Name: RawUTF8): integer; {$ifdef HASINLINE} var NameLen: integer; begin NameLen := Length(Name); for result := 0 to high(Names) do if (Length(Names[result])=NameLen) and IdemPropNameUSameLen(pointer(Names[result]),pointer(Name),NameLen) then exit; result := -1; end; {$else} begin for result := 0 to high(names) do if IdemPropNameU(names[result],Name) then exit; result := -1; end; {$endif} function AddRawUTF8(var Values: TRawUTF8DynArray; const Value: RawUTF8; NoDuplicates: boolean=false; CaseSensitive: boolean=true): boolean; var i: integer; begin if NoDuplicates then begin i := FindRawUTF8(Values,Value,CaseSensitive); if i>=0 then begin result := false; exit; end; end; i := length(Values); SetLength(Values,i+1); Values[i] := Value; result := true; end; function NextGrow(capacity: integer): integer; begin // algorithm similar to TFPList.Expand for the increasing ranges result := capacity; if result<128 shl 20 then if result<8 shl 20 then if result<=128 then if result>8 then inc(result,16) else inc(result,4) else inc(result,result shr 2) else inc(result,result shr 3) else inc(result,16 shl 20); end; procedure AddRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; const Value: RawUTF8); var capacity: integer; begin capacity := Length(Values); if ValuesCount=capacity then SetLength(Values,NextGrow(capacity)); Values[ValuesCount] := Value; inc(ValuesCount); end; function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray): boolean; var i: integer; begin result := false; if length(A)<>length(B) then exit; for i := 0 to high(A) do if A[i]<>B[i] then exit; result := true; end; function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray; Count: integer): boolean; var i: integer; begin result := false; for i := 0 to Count - 1 do if A[i]<>B[i] then exit; result := true; end; procedure StringDynArrayToRawUTF8DynArray(const Source: TStringDynArray; var Result: TRawUTF8DynArray); var i: Integer; begin SetLength(Result,length(Source)); for i := 0 to high(Source) do StringToUTF8(Source[i],Result[i]); end; procedure StringListToRawUTF8DynArray(Source: TStringList; var Result: TRawUTF8DynArray); var i: Integer; begin SetLength(Result,Source.Count); for i := 0 to Source.Count-1 do StringToUTF8(Source[i],Result[i]); end; function FindSectionFirstLine(var source: PUTF8Char; search: PAnsiChar): boolean; {$ifdef PUREPASCAL} begin result := false; if source=nil then exit; repeat if source^='[' then begin inc(source); result := IdemPChar(source,search); end; while source^ in ANSICHARNOT01310 do inc(source); while source^ in [#10,#13] do inc(source); if result then exit; // found until source^=#0; source := nil; end; {$else} asm // eax=source edx=search push eax // save source var mov eax, [eax] // eax=source test eax, eax jz @z push ebx mov ebx, edx // save search cmp byte ptr[eax], '[' lea eax, [eax + 1] jne @s @i: push eax mov edx, ebx // edx=search call IdemPChar pop ecx // ecx=source jmp @1 @s: mov ecx, eax xor eax, eax // result := false @1: mov dl, [ecx] // while not (source^ in [#0,#10,#13]) do inc(source); inc ecx cmp dl, 13 ja @1 je @e or dl, dl jz @0 cmp dl, 10 jne @1 cmp byte[ecx], 13 jbe @1 jmp @4 @e: cmp byte ptr[ecx], 10 // jump #13#10 jne @4 inc ecx @4: test al, al jnz @x // exit if IdemPChar returned true cmp byte ptr[ecx], '[' lea ecx, [ecx + 1] jne @1 mov eax, ecx jmp @i @0: xor ecx, ecx // set source=nil @x: pop ebx pop edx // restore source var mov [edx], ecx // update source var ret @z: pop edx // ignore source var, result := false end; {$endif} {$ifdef USENORMTOUPPER} {$ifdef PUREPASCAL} function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; begin result := false; if (p=nil) or (up=nil) then exit; while up^<>#0 do begin if (p^>#255) or (up^<>AnsiChar(NormToUpperByte[ord(p^)])) then exit; inc(up); inc(p); end; result := true; end; {$else} function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; asm // eax=p edx=up test eax, eax jz @e // P=nil -> false test edx, edx push ebx push esi jz @z // up=nil -> true mov esi, offset NormToUpper xor ebx, ebx xor ecx, ecx @1: mov bx, [eax] // bl=p^ mov cl, [edx] // cl=up^ test bh, bh // p^ > #255 -> FALSE jnz @n test cl, cl mov bl, [ebx + esi] // bl=NormToUpper[p^] jz @z // up^=#0 -> OK inc edx add eax, 2 cmp bl, cl je @1 @n: pop esi pop ebx @e: xor eax, eax ret @z: mov al, 1 // up^=#0 -> OK pop esi pop ebx end; {$endif PUREPASCAL} {$else} function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; // if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper) begin result := false; if (p=nil) or (up=nil) then exit; while up^<>#0 do begin if (p^>#255) or (up^<>AnsiChar(NormToUpperByteAnsi7[ord(p^)])) then exit; inc(up); inc(p); end; result := true; end; {$endif USENORMTOUPPER} function FindSectionFirstLineW(var source: PWideChar; search: PUTF8Char): boolean; {$ifdef PUREPASCAL} begin result := false; if source=nil then exit; repeat if source^='[' then begin inc(source); result := IdemPCharW(source,search); end; while not (cardinal(source^) in [0,10,13]) do inc(source); while cardinal(source^) in [10,13] do inc(source); if result then exit; // found until source^=#0; source := nil; end; {$else} asm // eax=source edx=search push eax // save source var mov eax, [eax] // eax=source test eax, eax jz @z push ebx mov ebx, edx // save search cmp word ptr[eax], '[' lea eax, [eax + 2] jne @s @i: push eax mov edx, ebx // edx=search call IdemPCharW pop ecx // ecx=source jmp @1 @s: mov ecx, eax xor eax, eax // result := false @1: mov dx, [ecx] // while not (source^ in [#0,#10,#13]) do inc(source) add ecx, 2 cmp dx, 13 ja @1 je @e or dx, dx jz @0 cmp dx, 10 jne @1 jmp @4 @e: cmp word ptr[ecx], 10 // jump #13#10 jne @4 add ecx, 2 @4: test al, al jnz @x // exit if IdemPChar returned true cmp word ptr[ecx], '[' lea ecx, [ecx + 2] jne @1 mov eax, ecx jmp @i @0: xor ecx, ecx // set source=nil @x: pop ebx pop edx // restore source var mov [edx], ecx // update source var ret @z: pop edx // ignore source var, result := false end; {$endif PUREPASCAL} function FindIniNameValue(P: PUTF8Char; UpperName: PAnsiChar): RawUTF8; var u, PBeg: PUTF8Char; by4: cardinal; table: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif}; begin // expect UpperName as 'NAME=' if (P<>nil) and (P^<>'[') and (UpperName<>nil) then begin {$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7;{$endif} PBeg := nil; u := P; repeat while u^=' ' do inc(u); // trim left ' ' if u^=#0 then break; if table[u^]=UpperName[0] then PBeg := u; repeat by4 := PCardinal(u)^; if ToByte(by4)>13 then if ToByte(by4 shr 8)>13 then if ToByte(by4 shr 16)>13 then if by4 shr 24>13 then begin inc(u,4); continue; end else inc(u,3) else inc(u,2) else inc(u); if u^ in [#0,#10,#13] then break else inc(u); until false; if PBeg<>nil then begin inc(PBeg); P := u; u := pointer(UpperName+1); repeat if u^<>#0 then if table[PBeg^]<>u^ then break else begin inc(u); inc(PBeg); end else begin FastSetString(result,PBeg,P-PBeg); exit; end; until false; PBeg := nil; u := P; end; if u^=#13 then inc(u); if u^=#10 then inc(u); until u^ in [#0,'[']; end; result := ''; end; function ExistsIniName(P: PUTF8Char; UpperName: PAnsiChar): boolean; var table: PNormTable; begin result := false; table := @NormToUpperAnsi7; if (P<>nil) and (P^<>'[') then repeat if P^=' ' then begin repeat inc(P) until P^<>' '; // trim left ' ' if P^=#0 then break; end; if IdemPChar2(table,P,UpperName) then begin result := true; exit; end; repeat if P[0]>#13 then if P[1]>#13 then if P[2]>#13 then if P[3]>#13 then begin inc(P,4); continue; end else inc(P,3) else inc(P,2) else inc(P); case P^ of #0: exit; #10: begin inc(P); break; end; #13: begin if P[1]=#10 then inc(P,2) else inc(P); break; end; else inc(P); end; until false; until P^='['; end; function ExistsIniNameValue(P: PUTF8Char; const UpperName: RawUTF8; const UpperValues: array of PAnsiChar): boolean; var PBeg: PUTF8Char; begin result := true; if high(UpperValues)>=0 then while (P<>nil) and (P^<>'[') do begin if P^=' ' then repeat inc(P) until P^<>' '; // trim left ' ' PBeg := P; if IdemPChar(PBeg,pointer(UpperName)) then begin inc(PBeg,length(UpperName)); if IdemPCharArray(PBeg,UpperValues)>=0 then exit; // found one value break; end; P := GotoNextLine(P); end; result := false; end; function GetSectionContent(SectionFirstLine: PUTF8Char): RawUTF8; var PBeg: PUTF8Char; begin PBeg := SectionFirstLine; while (SectionFirstLine<>nil) and (SectionFirstLine^<>'[') do SectionFirstLine := GotoNextLine(SectionFirstLine); if SectionFirstLine=nil then result := PBeg else FastSetString(result,PBeg,SectionFirstLine-PBeg); end; function GetSectionContent(const Content, SectionName: RawUTF8): RawUTF8; var P: PUTF8Char; UpperSection: array[byte] of AnsiChar; begin P := pointer(Content); PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']'); if FindSectionFirstLine(P,UpperSection) then result := GetSectionContent(P) else result := ''; end; function DeleteSection(var Content: RawUTF8; const SectionName: RawUTF8; EraseSectionHeader: boolean=true): boolean; var P: PUTF8Char; UpperSection: array[byte] of AnsiChar; begin result := false; // no modification P := pointer(Content); PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']'); if FindSectionFirstLine(P,UpperSection) then result := DeleteSection(P,Content,EraseSectionHeader); end; function DeleteSection(SectionFirstLine: PUTF8Char; var Content: RawUTF8; EraseSectionHeader: boolean=true): boolean; var PEnd: PUTF8Char; IndexBegin: PtrInt; begin result := false; PEnd := SectionFirstLine; if EraseSectionHeader then // erase [Section] header line while (PtrUInt(SectionFirstLine)>PtrUInt(Content)) and (SectionFirstLine^<>'[') do dec(SectionFirstLine); while (PEnd<>nil) and (PEnd^<>'[') do PEnd := GotoNextLine(PEnd); IndexBegin := SectionFirstLine-pointer(Content); if IndexBegin=0 then exit; // no modification if PEnd=nil then SetLength(Content,IndexBegin) else delete(Content,IndexBegin+1,PEnd-SectionFirstLine); result := true; // Content was modified end; procedure ReplaceSection(SectionFirstLine: PUTF8Char; var Content: RawUTF8; const NewSectionContent: RawUTF8); var PEnd: PUTF8Char; IndexBegin: PtrInt; begin if SectionFirstLine=nil then exit; // delete existing [Section] content PEnd := SectionFirstLine; while (PEnd<>nil) and (PEnd^<>'[') do PEnd := GotoNextLine(PEnd); IndexBegin := SectionFirstLine-pointer(Content); if PEnd=nil then SetLength(Content,IndexBegin) else delete(Content,IndexBegin+1,PEnd-SectionFirstLine); // insert section content insert(NewSectionContent,Content,IndexBegin+1); end; procedure ReplaceSection(var Content: RawUTF8; const SectionName, NewSectionContent: RawUTF8); var UpperSection: array[byte] of AnsiChar; P: PUTF8Char; begin P := pointer(Content); PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']'); if FindSectionFirstLine(P,UpperSection) then ReplaceSection(P,Content,NewSectionContent) else Content := Content+'['+SectionName+']'#13#10+NewSectionContent; end; function FindIniNameValueInteger(P: PUTF8Char; UpperName: PAnsiChar): PtrInt; begin result := GetInteger(pointer(FindIniNameValue(P,UpperName))); end; function FindIniEntry(const Content, Section, Name: RawUTF8): RawUTF8; var P: PUTF8Char; UpperSection, UpperName: array[byte] of AnsiChar; // possible GPF if length(Section/Name)>255, but should const in code begin result := ''; P := pointer(Content); if P=nil then exit; // UpperName := UpperCase(Name)+'='; PWord(UpperCopy255(UpperName,Name))^ := ord('='); if Section='' then // find the Name= entry before any [Section] result := FindIniNameValue(P,UpperName) else begin // find the Name= entry in the specified [Section] PWord(UpperCopy255(UpperSection,Section))^ := ord(']'); if FindSectionFirstLine(P,UpperSection) then result := FindIniNameValue(P,UpperName); end; end; function FindWinAnsiIniEntry(const Content, Section,Name: RawUTF8): RawUTF8; begin result := WinAnsiToUtf8(WinAnsiString(FindIniEntry(Content,Section,Name))); end; function FindIniEntryInteger(const Content,Section,Name: RawUTF8): integer; begin result := GetInteger(pointer(FindIniEntry(Content,Section,Name))); end; function FindIniEntryFile(const FileName: TFileName; const Section,Name: RawUTF8): RawUTF8; var Content: RawUTF8; begin Content := StringFromFile(FileName); if Content='' then result := '' else result := FindIniEntry(Content,Section,Name); end; function UpdateIniNameValueInternal(var Content: RawUTF8; const NewValue, NewValueCRLF: RawUTF8; var P: PUTF8Char; UpperName: PAnsiChar; UpperNameLength: integer): boolean; var PBeg: PUTF8Char; i: integer; begin while (P<>nil) and (P^<>'[') do begin while P^=' ' do inc(P); // trim left ' ' PBeg := P; P := GotoNextLine(P); if IdemPChar(PBeg,UpperName) then begin // update Name=Value entry result := true; inc(PBeg,UpperNameLength); i := (PBeg-pointer(Content))+1; if (i=length(NewValue)) and CompareMem(PBeg,pointer(NewValue),i) then exit; // new Value is identical to the old one -> no change if P=nil then // avoid last line (P-PBeg) calculation error SetLength(Content,i-1) else delete(Content,i,P-PBeg); // delete old Value insert(NewValueCRLF,Content,i); // set new value exit; end; end; result := false; end; function UpdateIniNameValue(var Content: RawUTF8; const Name, UpperName, NewValue: RawUTF8): boolean; var P: PUTF8Char; begin if UpperName='' then result := false else begin P := pointer(Content); result := UpdateIniNameValueInternal(Content,NewValue,NewValue+#13#10,P, pointer(UpperName),length(UpperName)); if result or (Name='') then exit; if Content<>'' then Content := Content+#13#10; Content := Content+Name+NewValue; result := true; end; end; procedure UpdateIniEntry(var Content: RawUTF8; const Section,Name,Value: RawUTF8); const CRLF = #13#10; var P: PUTF8Char; SectionFound: boolean; i, UpperNameLength: PtrInt; V: RawUTF8; UpperSection, UpperName: array[byte] of AnsiChar; label Sec; begin UpperNameLength := length(Name); PWord(UpperCopy255Buf(UpperName,pointer(Name),UpperNameLength))^ := ord('='); inc(UpperNameLength); V := Value+CRLF; P := pointer(Content); // 1. find Section, and try update within it if Section='' then goto Sec; // find the Name= entry before any [Section] SectionFound := false; PWord(UpperCopy255(UpperSection,Section))^ := ord(']'); if FindSectionFirstLine(P,UpperSection) then begin Sec:SectionFound := true; if UpdateIniNameValueInternal(Content,Value,V,P,@UpperName,UpperNameLength) then exit; // we reached next [Section] without having found Name= end; // 2. section or Name= entry not found: add Name=Value V := Name+'='+V; if not SectionFound then // create not existing [Section] V := '['+Section+(']'+CRLF)+V; // insert Name=Value at P^ (end of file or end of [Section]) if P=nil then // insert at end of file Content := Content+V else begin // insert at end of [Section] i := (P-pointer(Content))+1; insert(V,Content,i); end; end; procedure UpdateIniEntryFile(const FileName: TFileName; const Section,Name,Value: RawUTF8); var Content: RawUTF8; begin Content := StringFromFile(FileName); UpdateIniEntry(Content,Section,Name,Value); FileFromString(Content,FileName); end; function StringFromFile(const FileName: TFileName; HasNoSize: boolean): RawByteString; var F: THandle; Read, Size: integer; tmp: array[0..$7fff] of AnsiChar; begin result := ''; if FileName='' then exit; F := FileOpenSequentialRead(FileName); if PtrInt(F)>=0 then begin if HasNoSize then begin Size := 0; repeat Read := FileRead(F,tmp,SizeOf(tmp)); if Read<=0 then break; SetLength(result,Size+Read); {$ifdef FPC}Move{$else}MoveFast{$endif}(tmp,PByteArray(result)^[Size],Read); inc(Size,Read); until false; end else begin Size := GetFileSize(F,nil); if Size>0 then begin SetLength(result,Size); if FileRead(F,pointer(result)^,Size)<>Size then result := ''; end; end; FileClose(F); end; end; function FileFromString(const Content: RawByteString; const FileName: TFileName; FlushOnDisk: boolean; FileDate: TDateTime): boolean; var F: THandle; P: PByte; L,written: integer; begin result := false; if FileName='' then exit; F := FileCreate(FileName); if PtrInt(F)<0 then exit; L := length(Content); P := pointer(Content); while L>0 do begin written := FileWrite(F,P^,L); if written<0 then begin FileClose(F); exit; end; dec(L,written); inc(P,written); end; if FlushOnDisk then FlushFileBuffers(F); {$ifdef MSWINDOWS} if FileDate<>0 then FileSetDate(F,DateTimeToFileDate(FileDate)); FileClose(F); {$else} FileClose(F); if FileDate<>0 then FileSetDate(FileName,DateTimeToFileDate(FileDate)); {$endif} result := true; end; type TTextFileKind = (isUnicode, isUTF8, isAnsi); function TextFileKind(const Map: TMemoryMap): TTextFileKind; begin result := isAnsi; if (Map.Buffer<>nil) and (Map.Size>3) then if PWord(Map.Buffer)^=$FEFF then result := isUnicode else if (PWord(Map.Buffer)^=$BBEF) and (PByteArray(Map.Buffer)[2]=$BF) then result := isUTF8; end; function AnyTextFileToSynUnicode(const FileName: TFileName; ForceUTF8: boolean): SynUnicode; var Map: TMemoryMap; begin result := ''; if Map.Map(FileName) then try if ForceUTF8 then UTF8ToSynUnicode(PUTF8Char(Map.Buffer),Map.Size,Result) else case TextFileKind(Map) of isUnicode: SetString(result,PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1); isUTF8: UTF8ToSynUnicode(PUTF8Char(pointer(PtrUInt(Map.Buffer)+3)),Map.Size-3,Result); isAnsi: result := CurrentAnsiConvert.AnsiToUnicodeString(Map.Buffer, Map.Size); end; finally Map.UnMap; end; end; function AnyTextFileToRawUTF8(const FileName: TFileName; AssumeUTF8IfNoBOM: boolean): RawUTF8; var Map: TMemoryMap; begin result := ''; if Map.Map(FileName) then try case TextFileKind(Map) of isUnicode: RawUnicodeToUtf8(PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1,Result); isUTF8: FastSetString(result,pointer(PtrUInt(Map.Buffer)+3),Map.Size-3); isAnsi: if AssumeUTF8IfNoBOM then FastSetString(result,Map.Buffer,Map.Size) else result := CurrentAnsiConvert.AnsiBufferToRawUTF8(Map.Buffer, Map.Size); end; finally Map.UnMap; end; end; function AnyTextFileToString(const FileName: TFileName; ForceUTF8: boolean): string; var Map: TMemoryMap; begin result := ''; if Map.Map(FileName) then try if ForceUTF8 then {$ifdef UNICODE} UTF8DecodeToString(PUTF8Char(Map.Buffer),Map.Size,result) {$else} result := CurrentAnsiConvert.UTF8BufferToAnsi(PUTF8Char(Map.Buffer),Map.Size) {$endif} else case TextFileKind(Map) of {$ifdef UNICODE} isUnicode: SetString(result,PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1); isUTF8: UTF8DecodeToString(pointer(PtrUInt(Map.Buffer)+3),Map.Size-3,result); isAnsi: result := CurrentAnsiConvert.AnsiToUnicodeString(Map.Buffer,Map.Size); {$else} isUnicode: result := CurrentAnsiConvert.UnicodeBufferToAnsi(PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1); isUTF8: result := CurrentAnsiConvert.UTF8BufferToAnsi(pointer(PtrUInt(Map.Buffer)+3),Map.Size-3); isAnsi: SetString(result,PAnsiChar(Map.Buffer),Map.Size); {$endif} end; finally Map.UnMap; end; end; function StreamToRawByteString(aStream: TStream): RawByteString; var current, size: Int64; begin result := ''; if aStream=nil then exit; current := aStream.Position; if (current=0) and aStream.InheritsFrom(TRawByteStringStream) then begin result := TRawByteStringStream(aStream).DataString; // fast COW exit; end; size := aStream.Size-current; if (size=0) or (size>maxInt) then exit; SetLength(result,size); aStream.Read(pointer(result)^,size); aStream.Position := current; end; function RawByteStringToStream(const aString: RawByteString): TStream; begin result := TRawByteStringStream.Create(aString); end; function ReadStringFromStream(S: TStream; MaxAllowedSize: integer): RawUTF8; var L: integer; begin result := ''; L := 0; if (S.Read(L,4)<>4) or (L<=0) or (L>MaxAllowedSize) then exit; SetLength(result,L); if S.Read(pointer(result)^,L)<>L then result := ''; end; function WriteStringToStream(S: TStream; const Text: RawUTF8): boolean; var L: integer; begin L := length(Text); if L=0 then result := S.Write(L,4)=4 else {$ifdef FPC} result := (S.Write(L,4)=4) and (S.Write(pointer(Text)^,L)=L); {$else} result := S.Write(pointer(PtrInt(Text)-SizeOf(integer))^,L+4)=L+4; {$endif} end; function GetFileNameWithoutExt(const FileName: TFileName; Extension: PFileName): TFileName; var i, max: PtrInt; begin i := length(FileName); max := i-16; while (i>0) and not(cardinal(FileName[i]) in [ord('\'),ord('/'),ord('.')]) and (i>=max) do dec(i); if (i=0) or (FileName[i]<>'.') then begin result := FileName; if Extension<>nil then Extension^ := ''; end else begin result := copy(FileName,1,i-1); if Extension<>nil then Extension^ := copy(FileName,i,20); end; end; function GetFileNameExtIndex(const FileName, CSVExt: TFileName): integer; var Ext: TFileName; P: PChar; begin result := -1; P := pointer(CSVExt); Ext := ExtractFileExt(FileName); if (P=nil) or (Ext='') or (Ext[1]<>'.') then exit; delete(Ext,1,1); repeat inc(result); if SameText(GetNextItemString(P),Ext) then exit; until P=nil; result := -1; end; function FileSize(const FileName: TFileName): Int64; {$ifdef MSWINDOWS} var FA: WIN32_FILE_ATTRIBUTE_DATA; begin // 5 times faster than CreateFile, GetFileSizeEx, CloseHandle if GetFileAttributesEx(pointer(FileName),GetFileExInfoStandard,@FA) then begin PInt64Rec(@result)^.Lo := FA.nFileSizeLow; PInt64Rec(@result)^.Hi := FA.nFileSizeHigh; end else result := 0; end; {$else} var f: THandle; res: Int64Rec absolute result; begin result := 0; f := FileOpen(FileName,fmOpenRead or fmShareDenyNone); if PtrInt(f)>0 then begin res.Lo := GetFileSize(f,@res.Hi); // from SynKylix/SynFPCLinux FileClose(f); end; end; {$endif} function FileSize(F: THandle): Int64; var res: Int64Rec absolute result; begin result := 0; if PtrInt(F)>0 then res.Lo := GetFileSize(F,@res.Hi); // from WinAPI or SynKylix/SynFPCLinux end; function FileInfoByHandle(aFileHandle: THandle; out FileId, FileSize, LastWriteAccess, FileCreateDateTime: Int64): Boolean; var lastreadaccess: TUnixMSTime; {$ifdef MSWINDOWS} lp: TByHandleFileInformation; {$else} lp: {$ifdef FPC}stat{$else}TStatBuf64{$endif}; r: integer; {$endif MSWINDOWS} begin {$ifdef MSWINDOWS} result := GetFileInformationByHandle(aFileHandle,lp); if not result then exit; LastWriteAccess := FileTimeToUnixMSTime(lp.ftLastWriteTime); FileCreateDateTime := FileTimeToUnixMSTime(lp.ftCreationTime); lastreadaccess := FileTimeToUnixMSTime(lp.ftLastAccessTime); PInt64Rec(@FileSize).lo := lp.nFileSizeLow; PInt64Rec(@FileSize).hi := lp.nFileSizeHigh; PInt64Rec(@FileId).lo := lp.nFileIndexLow; PInt64Rec(@FileId).hi := lp.nFileIndexHigh; {$else} r := {$ifdef FPC}FpFStat{$else}fstat64{$endif}(aFileHandle, lp); result := r >= 0; if not result then exit; FileId := lp.st_ino; FileSize := lp.st_size; lastreadaccess := lp.st_atime * MSecsPerSec; LastWriteAccess := lp.st_mtime * MSecsPerSec; {$ifdef OPENBSD} if (lp.st_birthtime <> 0) and (lp.st_birthtime < lp.st_ctime) then lp.st_ctime:= lp.st_birthtime; {$endif} FileCreateDateTime := lp.st_ctime * MSecsPerSec; {$endif MSWINDOWS} if LastWriteAccess <> 0 then if (FileCreateDateTime = 0) or (FileCreateDateTime > LastWriteAccess) then FileCreateDateTime:= LastWriteAccess; if lastreadaccess <> 0 then if (FileCreateDateTime = 0) or (FileCreateDateTime > lastreadaccess) then FileCreateDateTime:= lastreadaccess; end; function FileAgeToDateTime(const FileName: TFileName): TDateTime; {$ifdef MSWINDOWS} var FA: WIN32_FILE_ATTRIBUTE_DATA; ST,LT: TSystemTime; begin // 5 times faster than CreateFile, GetFileSizeEx, CloseHandle if GetFileAttributesEx(pointer(FileName),GetFileExInfoStandard,@FA) and FileTimeToSystemTime(FA.ftLastWriteTime,ST) and SystemTimeToTzSpecificLocalTime(nil,ST,LT) then result := SystemTimeToDateTime(LT) else result := 0; end; {$else} {$ifdef HASNEWFILEAGE} begin if not FileAge(FileName,result) then {$else} var Age: integer; begin Age := FileAge(FileName); if Age<>-1 then result := FileDateToDateTime(Age) else {$endif HASNEWFILEAGE} result := 0; end; {$endif MSWINDOWS} function CopyFile(const Source, Target: TFileName; FailIfExists: boolean): boolean; {$ifdef MSWINDOWS} begin result := Windows.CopyFile(pointer(Source),pointer(Target),FailIfExists); end; {$else} var SourceF, DestF: TFileStream; begin result := false; if FailIfExists then if FileExists(Target) then exit else DeleteFile(Target); try SourceF := TFileStream.Create(Source,fmOpenRead); try DestF := TFileStream.Create(Target,fmCreate); try DestF.CopyFrom(SourceF, SourceF.Size); finally DestF.Free; end; FileSetDateFrom(Target,SourceF.Handle); finally SourceF.Free; end; result := true; except result := false; end; end; {$endif} function SearchRecToDateTime(const F: TSearchRec): TDateTime; begin {$ifdef ISDELPHIXE} result := F.Timestamp; {$else} result := FileDateToDateTime(F.Time); {$endif} end; function SearchRecValidFile(const F: TSearchRec): boolean; begin {$ifndef DELPHI5OROLDER} {$WARN SYMBOL_DEPRECATED OFF} // for faVolumeID {$endif} result := (F.Name<>'') and (F.Attr and (faDirectory {$ifdef MSWINDOWS}+faVolumeID+faSysFile+faHidden)=0) and (F.Name[1]<>'.') {$else})=0){$endif}; {$ifndef DELPHI5OROLDER} {$WARN SYMBOL_DEPRECATED ON} {$endif} end; function DirectoryDelete(const Directory: TFileName; const Mask: TFileName; DeleteOnlyFilesNotDirectory: Boolean; DeletedCount: PInteger): Boolean; var F: TSearchRec; Dir: TFileName; n: integer; begin n := 0; result := true; if DirectoryExists(Directory) then begin Dir := IncludeTrailingPathDelimiter(Directory); if FindFirst(Dir+Mask,faAnyFile-faDirectory,F)=0 then begin repeat if SearchRecValidFile(F) then if DeleteFile(Dir+F.Name) then inc(n) else result := false; until FindNext(F)<>0; FindClose(F); end; if not DeleteOnlyFilesNotDirectory and not RemoveDir(Dir) then result := false; end; if DeletedCount<>nil then DeletedCount^ := n; end; function DirectoryDeleteOlderFiles(const Directory: TFileName; TimePeriod: TDateTime; const Mask: TFileName; Recursive: Boolean; TotalSize: PInt64): Boolean; var F: TSearchRec; Dir: TFileName; old: TDateTime; begin if not Recursive and (TotalSize<>nil) then TotalSize^ := 0; result := true; if (Directory='') or not DirectoryExists(Directory) then exit; Dir := IncludeTrailingPathDelimiter(Directory); if FindFirst(Dir+Mask,faAnyFile,F)=0 then begin old := Now - TimePeriod; repeat if F.Name[1]<>'.' then if Recursive and (F.Attr and faDirectory<>0) then DirectoryDeleteOlderFiles(Dir+F.Name,TimePeriod,Mask,true,TotalSize) else if SearchRecValidFile(F) and (SearchRecToDateTime(F) < old) then if not DeleteFile(Dir+F.Name) then result := false else if TotalSize<>nil then inc(TotalSize^,F.Size); until FindNext(F)<>0; FindClose(F); end; end; procedure TFindFiles.FromSearchRec(const Directory: TFileName; const F: TSearchRec); begin Name := Directory+F.Name; {$ifdef MSWINDOWS} {$ifdef HASINLINE} // FPC or Delphi 2006+ Size := F.Size; {$else} // F.Size was limited to 32-bit on older Delphi PInt64Rec(@Size)^.Lo := F.FindData.nFileSizeLow; PInt64Rec(@Size)^.Hi := F.FindData.nFileSizeHigh; {$endif} {$else} Size := F.Size; {$endif} Attr := F.Attr; Timestamp := SearchRecToDateTime(F); end; function TFindFiles.ToText: shortstring; begin FormatShort('% % %',[Name,KB(Size),DateTimeToFileShort(Timestamp)],result); end; function FindFiles(const Directory,Mask,IgnoreFileName: TFileName; SortByName,IncludesDir,SubFolder: boolean): TFindFilesDynArray; var m,count: integer; Dir: TFileName; da: TDynArray; masks: TRawUTF8DynArray; masked: TFindFilesDynArray; procedure SearchFolder(const folder : TFileName); var F: TSearchRec; ff: TFindFiles; begin if FindFirst(Dir+folder+Mask,faAnyfile-faDirectory,F)=0 then begin repeat if SearchRecValidFile(F) and ((IgnoreFileName='') or (AnsiCompareFileName(F.Name,IgnoreFileName)<>0)) then begin if IncludesDir then ff.FromSearchRec(Dir+folder,F) else ff.FromSearchRec(folder,F); da.Add(ff); end; until FindNext(F)<>0; FindClose(F); end; if SubFolder and (FindFirst(Dir+folder+'*',faDirectory,F)=0) then begin repeat if (F.Name<>'.') and (F.Name<>'..') and ((IgnoreFileName='') or (AnsiCompareFileName(F.Name,IgnoreFileName)<>0)) then SearchFolder(IncludeTrailingPathDelimiter(folder+F.Name)); until FindNext(F)<>0; FindClose(F); end; end; begin result := nil; da.Init(TypeInfo(TFindFilesDynArray),result,@count); if Pos(';',Mask)>0 then CSVToRawUTF8DynArray(pointer(StringToUTF8(Mask)),masks,';'); if masks<>nil then begin if SortByName then QuickSortRawUTF8(masks,length(masks),nil,{$ifdef MSWINDOWS}@StrIComp{$else}@StrComp{$endif}); for m := 0 to high(masks) do begin // masks[] recursion masked := FindFiles(Directory,UTF8ToString(masks[m]), IgnoreFileName,SortByName,IncludesDir,SubFolder); da.AddArray(masked); end; end else begin if Directory<>'' then Dir := IncludeTrailingPathDelimiter(Directory); SearchFolder(''); if SortByName and (da.Count>0) then da.Sort(SortDynArrayFileName); end; da.Capacity := count; // trim result[] end; function FindFilesDynArrayToFileNames(const Files: TFindFilesDynArray): TFileNameDynArray; var i,n: integer; begin n := length(Files); SetLength(result,n); for i := 0 to n-1 do result[i] := Files[i].Name; end; function EnsureDirectoryExists(const Directory: TFileName; RaiseExceptionOnCreationFailure: boolean=false): TFileName; begin result := IncludeTrailingPathDelimiter(ExpandFileName(Directory)); if not DirectoryExists(result) then if not CreateDir(result) then if not RaiseExceptionOnCreationFailure then result := '' else raise ESynException.CreateUTF8('Impossible to create folder %',[result]); end; var TemporaryFileNameRandom: integer; function TemporaryFileName: TFileName; var folder: TFileName; begin // fast cross-platform implementation folder := GetSystemPath(spTempFolder); if TemporaryFileNameRandom=0 then TemporaryFileNameRandom := Random32; repeat // thread-safe unique file name generation FormatString('%%_%.tmp',[folder,ExeVersion.ProgramName, CardinalToHexShort(InterlockedIncrement(TemporaryFileNameRandom))],string(result)); until not FileExists(result); end; function IsDirectoryWritable(const Directory: TFileName): boolean; var fn: TFileName; begin fn := ExcludeTrailingPathDelimiter(Directory); result := {$ifndef DELPHI5OROLDER}not FileIsReadOnly{$else}DirectoryExists{$endif}(fn); if not result then exit; fn := FormatString('%%.%%',[fn,PathDelim,CardinalToHexShort(integer(GetCurrentThreadID)), BinToBase64uriShort(@ExeVersion.Hash,SizeOf(ExeVersion.Hash))]); result := FileFromString('tobedeleted',fn); // actually try to write something DeleteFile(fn); end; {$ifdef DELPHI5OROLDER} function DirectoryExists(const Directory: string): boolean; var Code: Integer; begin Code := GetFileAttributes(pointer(Directory)); result := (Code<>-1) and (FILE_ATTRIBUTE_DIRECTORY and Code<>0); end; function SameFileName(const S1, S2: TFileName): Boolean; begin result := AnsiCompareFileName(S1,S2)=0; end; function GetEnvironmentVariable(const Name: string): string; var Len: Integer; Buffer: array[0..1023] of Char; begin Result := ''; Len := Windows.GetEnvironmentVariable(pointer(Name),@Buffer,SizeOf(Buffer)); if Len 0 then Error := EOSError.CreateFmt('System Error. Code: %d.'#13#10'%s', [LastError,SysErrorMessage(LastError)]) else Error := EOSError.Create('A call to an OS function failed'); Error.ErrorCode := LastError; raise Error; end; {$endif DELPHI5OROLDER} {$ifdef DELPHI6OROLDER} procedure VarCastError; begin raise EVariantError.Create('Variant Type Cast Error'); end; {$endif} {$ifdef MSWINDOWS} function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean; var FileTime: TFileTime; D: THandle; begin D := FileOpen(Dest,fmOpenWrite); if D<>THandle(-1) then begin result := GetFileTime(SourceHandle,nil,nil,@FileTime) and SetFileTime(D,nil,nil,@FileTime); FileClose(D); end else result := false; end; {$else} function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean; begin result := FileSetDate(Dest,FileGetDate(SourceHandle))=0; end; {$endif} {$IFDEF PUREPASCAL} {$IFNDEF HASCODEPAGE} function Pos(const substr, str: RawUTF8): Integer; overload; begin // the RawByteString version is fast enough Result := PosEx(substr,str,1); end; {$ENDIF} {$ENDIF} function FindObjectEntry(const Content, Name: RawUTF8): RawUTF8; var L: integer; begin result := Trim(FindIniEntry(Content,'',Name+' ')); // 'Name = Value' format if (result<>'') and (result[1]='''') then begin L := length(result); if result[L]='''' then result := copy(result,2,L-2); // 'testDI6322.IAS' -> testDI6322.IAS end; end; function FindObjectEntryWithoutExt(const Content, Name: RawUTF8): RawUTF8; begin result := RawUTF8(GetFileNameWithoutExt( ExtractFileName(TFileName(FindObjectEntry(Content,Name))))); end; procedure TPropNameList.Init; begin Count := 0; end; function TPropNameList.FindPropName(const Value: RawUTF8): Integer; begin for result := 0 to Count-1 do if IdemPropNameU(Values[result],Value) then exit; result := -1; end; function TPropNameList.AddPropName(const Value: RawUTF8): Boolean; begin if FindPropName(Value)<0 then begin if Count=length(Values) then SetLength(Values,Count+16); Values[Count] := Value; inc(Count); result := true; end else result := false; end; function Int64ScanExists(P: PInt64Array; Count: PtrInt; const Value: Int64): boolean; var i: PtrInt; begin if P<>nil then begin result := true; for i := 1 to (Count shr 2) do // 4 QWORD by loop - aligned read if (P^[0]=Value) or (P^[1]=Value) or (P^[2]=Value) or (P^[3]=Value) then exit else inc(PByte(P),SizeOf(P^[0])*4); for i := 0 to (Count and 3)-1 do // last 0..3 QWORD if P^[i]=Value then exit; end; result := false; end; function Int64Scan(P: PInt64Array; Count: PtrInt; const Value: Int64): PInt64; var i: PtrInt; begin if P<>nil then begin for i := 1 to Count shr 2 do // 4 QWORD by loop - aligned read if P^[0]<>Value then if P^[1]<>Value then if P^[2]<>Value then if P^[3]=Value then begin result := @P^[3]; exit; end else inc(PByte(P),SizeOf(P^[0])*4) else begin result := @P^[2]; exit; end else begin result := @P^[1]; exit; end else begin result := pointer(P); exit; end; for i := 0 to (Count and 3)-1 do // last 0..3 QWORD if P^[i]=Value then begin result := @P^[i]; exit; end; end; result := nil; end; function AddInteger(var Values: TIntegerDynArray; Value: integer; NoDuplicates: boolean=false): boolean; var n: PtrInt; begin n := Length(Values); if NoDuplicates and IntegerScanExists(pointer(Values),n,Value) then begin result := false; exit; end; SetLength(Values,n+1); Values[n] := Value; result := true end; procedure AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; Value: integer); begin if ValuesCount=length(Values) then SetLength(Values,NextGrow(ValuesCount)); Values[ValuesCount] := Value; inc(ValuesCount); end; function AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; Value: integer; NoDuplicates: boolean): boolean; begin if NoDuplicates and IntegerScanExists(pointer(Values),ValuesCount,Value) then begin result := false; exit; end; if ValuesCount=length(Values) then SetLength(Values,NextGrow(ValuesCount)); Values[ValuesCount] := Value; inc(ValuesCount); result := true; end; function AddInteger(var Values: TIntegerDynArray; const Another: TIntegerDynArray): PtrInt; var v,a: PtrInt; begin v := length(Values); a := length(Another); if a>0 then begin SetLength(Values,v+a); {$ifdef FPC}Move{$else}MoveFast{$endif}(Another[0],Values[v],a*SizeOf(Integer)); end; result := v+a; end; function AddWord(var Values: TWordDynArray; var ValuesCount: integer; Value: Word): PtrInt; begin result := ValuesCount; if result=length(Values) then SetLength(Values,NextGrow(result)); Values[result] := Value; inc(ValuesCount); end; function AddInt64(var Values: TInt64DynArray; var ValuesCount: integer; Value: Int64): PtrInt; begin result := ValuesCount; if result=length(Values) then SetLength(Values,NextGrow(result)); Values[result] := Value; inc(ValuesCount); end; function AddInt64(var Values: TInt64DynArray; Value: Int64): PtrInt; begin result := length(Values); SetLength(Values,result+1); Values[result] := Value; end; function AddInt64(var Values: TInt64DynArray; const Another: TInt64DynArray): PtrInt; var v,a: PtrInt; begin v := length(Values); a := length(Another); if a>0 then begin SetLength(Values,v+a); {$ifdef FPC}Move{$else}MoveFast{$endif}(Another[0],Values[v],a*SizeOf(Int64)); end; result := v+a; end; procedure AddInt64Sorted(var Values: TInt64DynArray; Value: Int64); var last: integer; begin last := high(Values); if FastFindInt64Sorted(pointer(Values),last,Value)<0 then begin inc(last); SetLength(Values,last+1); Values[last] := Value; QuickSortInt64(pointer(Values),0,last); end; end; function AddInt64Once(var Values: TInt64DynArray; Value: Int64): PtrInt; begin result := Int64ScanIndex(pointer(Values),length(Values),Value); if result<0 then result := AddInt64(Values,Value); end; procedure DeleteWord(var Values: TWordDynArray; Index: PtrInt); var n: PtrInt; begin n := Length(Values); if PtrUInt(Index)>=PtrUInt(n) then exit; // wrong Index dec(n); if n>Index then {$ifdef FPC}Move{$else}MoveFast{$endif}(Values[Index+1],Values[Index],(n-Index)*SizeOf(Word)); SetLength(Values,n); end; procedure DeleteInteger(var Values: TIntegerDynArray; Index: PtrInt); var n: PtrInt; begin n := Length(Values); if PtrUInt(Index)>=PtrUInt(n) then exit; // wrong Index dec(n); if n>Index then {$ifdef FPC}Move{$else}MoveFast{$endif}(Values[Index+1],Values[Index],(n-Index)*SizeOf(Integer)); SetLength(Values,n); end; procedure DeleteInteger(var Values: TIntegerDynArray; var ValuesCount: Integer; Index: PtrInt); var n: PtrInt; begin n := ValuesCount; if PtrUInt(Index)>=PtrUInt(n) then exit; // wrong Index dec(n,Index+1); if n>0 then {$ifdef FPC}Move{$else}MoveFast{$endif}(Values[Index+1],Values[Index],n*SizeOf(Integer)); dec(ValuesCount); end; procedure DeleteInt64(var Values: TInt64DynArray; Index: PtrInt); var n: PtrInt; begin n := Length(Values); if PtrUInt(Index)>=PtrUInt(n) then exit; // wrong Index dec(n); if n>Index then {$ifdef FPC}Move{$else}MoveFast{$endif}(Values[Index+1],Values[Index],(n-Index)*SizeOf(Int64)); SetLength(Values,n); end; procedure DeleteInt64(var Values: TInt64DynArray; var ValuesCount: Integer; Index: PtrInt); var n: PtrInt; begin n := ValuesCount; if PtrUInt(Index)>=PtrUInt(n) then exit; // wrong Index dec(n,Index+1); if n>0 then {$ifdef FPC}Move{$else}MoveFast{$endif}(Values[Index+1],Values[Index],n*SizeOf(Int64)); dec(ValuesCount); end; procedure ExcludeInteger(var Values, Excluded: TIntegerDynArray; ExcludedSortSize: integer); var i,v,x,n: PtrInt; begin if (Values=nil) or (Excluded=nil) then exit; // nothing to exclude v := length(Values); n := 0; x := Length(Excluded); if (x>ExcludedSortSize) or (v>ExcludedSortSize) then begin // sort if worth it dec(x); QuickSortInteger(pointer(Excluded),0,x); for i := 0 to v-1 do if FastFindIntegerSorted(pointer(Excluded),x,Values[i])<0 then begin if n<>i then Values[n] := Values[i]; inc(n); end; end else for i := 0 to v-1 do if not IntegerScanExists(pointer(Excluded),x,Values[i]) then begin if n<>i then Values[n] := Values[i]; inc(n); end; if n<>v then SetLength(Values,n); end; procedure IncludeInteger(var Values, Included: TIntegerDynArray; IncludedSortSize: Integer); var i,v,x,n: PtrInt; begin if (Values=nil) or (Included=nil) then begin Values := nil; exit; end; v := length(Values); n := 0; x := Length(Included); if (x>IncludedSortSize) or (v>IncludedSortSize) then begin // sort if worth it dec(x); QuickSortInteger(pointer(Included),0,x); for i := 0 to v-1 do if FastFindIntegerSorted(pointer(Included),x,Values[i])>=0 then begin if n<>i then Values[n] := Values[i]; inc(n); end; end else for i := 0 to v-1 do if IntegerScanExists(pointer(Included),x,Values[i]) then begin if n<>i then Values[n] := Values[i]; inc(n); end; if n<>v then SetLength(Values,n); end; procedure ExcludeInt64(var Values, Excluded: TInt64DynArray; ExcludedSortSize: Integer); var i,v,x,n: PtrInt; begin if (Values=nil) or (Excluded=nil) then exit; // nothing to exclude v := length(Values); n := 0; x := Length(Excluded); if (x>ExcludedSortSize) or (v>ExcludedSortSize) then begin // sort if worth it dec(x); QuickSortInt64(pointer(Excluded),0,x); for i := 0 to v-1 do if FastFindInt64Sorted(pointer(Excluded),x,Values[i])<0 then begin if n<>i then Values[n] := Values[i]; inc(n); end; end else for i := 0 to v-1 do if not Int64ScanExists(pointer(Excluded),x,Values[i]) then begin if n<>i then Values[n] := Values[i]; inc(n); end; if n<>v then SetLength(Values,n); end; procedure IncludeInt64(var Values, Included: TInt64DynArray; IncludedSortSize: integer); var i,v,x,n: PtrInt; begin if (Values=nil) or (Included=nil) then begin Values := nil; exit; end; v := length(Values); n := 0; x := Length(Included); if (x>IncludedSortSize) or (v>IncludedSortSize) then begin // sort if worth it dec(x); QuickSortInt64(pointer(Included),0,x); for i := 0 to v-1 do if FastFindInt64Sorted(pointer(Included),x,Values[i])>=0 then begin if n<>i then Values[n] := Values[i]; inc(n); end; end else for i := 0 to v-1 do if Int64ScanExists(pointer(Included),x,Values[i]) then begin if n<>i then Values[n] := Values[i]; inc(n); end; if n<>v then SetLength(Values,n); end; procedure DeduplicateInteger(var Values: TIntegerDynArray); begin DeduplicateInteger(Values, length(Values)); end; function DeduplicateIntegerSorted(val: PIntegerArray; last: PtrInt): PtrInt; var i: PtrInt; begin // sub-function for better code generation i := 0; repeat // here last>0 so ilast then continue; result := i; exit; until false; result := i; inc(i); if i<>last then begin repeat if val[i]<>val[i+1] then begin val[result] := val[i]; inc(result); end; inc(i); until i=last; val[result] := val[i]; end; end; function DeduplicateInteger(var Values: TIntegerDynArray; Count: integer): integer; begin result := Count; dec(Count); if Count>0 then begin QuickSortInteger(pointer(Values),0,Count); result := DeduplicateIntegerSorted(pointer(Values),Count)+1; end; if result<>length(Values) then SetLength(Values,result); end; procedure DeduplicateInt64(var Values: TInt64DynArray); begin DeduplicateInt64(Values, length(Values)); end; function DeduplicateInt64Sorted(val: PInt64Array; last: PtrInt): PtrInt; var i: PtrInt; begin // sub-function for better code generation i := 0; repeat // here last>0 so ilast then continue; result := i; exit; until false; result := i; inc(i); if i<>last then begin repeat if val[i]<>val[i+1] then begin val[result] := val[i]; inc(result); end; inc(i); until i=last; val[result] := val[i]; end; end; function DeduplicateInt64(var Values: TInt64DynArray; Count: integer): integer; begin result := Count; dec(Count); if Count>0 then begin QuickSortInt64(pointer(Values),0,Count); result := DeduplicateInt64Sorted(pointer(Values),Count)+1; end; if result<>length(Values) then SetLength(Values,result); end; procedure CopyInteger(const Source: TIntegerDynArray; out Dest: TIntegerDynArray); var n: integer; begin n := length(Source); SetLength(Dest,n); {$ifdef FPC}Move{$else}MoveFast{$endif}(Source[0],Dest[0],n*SizeOf(Integer)); end; procedure CopyInt64(const Source: TInt64DynArray; out Dest: TInt64DynArray); var n: integer; begin n := length(Source); SetLength(Dest,n); {$ifdef FPC}Move{$else}MoveFast{$endif}(Source[0],Dest[0],n*SizeOf(Int64)); end; function MaxInteger(const Values: TIntegerDynArray; ValuesCount, MaxStart: integer): Integer; var i: integer; begin result := MaxStart; for i := 0 to ValuesCount-1 do if Values[i]>result then result := Values[i]; end; function SumInteger(const Values: TIntegerDynArray; ValuesCount: integer): Integer; var i: integer; begin result := 0; for i := 0 to ValuesCount-1 do inc(result,Values[i]); end; procedure Reverse(const Values: TIntegerDynArray; ValuesCount: integer; Reversed: PIntegerArray); var i: integer; begin i := 0; if ValuesCount>=4 then begin dec(ValuesCount,4); while i0 then if StartValue=0 then for i := 0 to Count-1 do Values[i] := i else for i := 0 to Count-1 do begin Values[i] := StartValue; inc(StartValue); end; end; procedure Int64ToUInt32(Values64: PInt64Array; Values32: PCardinalArray; Count: integer); var i: integer; begin for i := 0 to Count-1 do Values32[i] := Values64[i]; end; procedure CSVToIntegerDynArray(CSV: PUTF8Char; var Result: TIntegerDynArray; Sep: AnsiChar); begin while CSV<>nil do begin SetLength(Result,length(Result)+1); Result[high(Result)] := GetNextItemInteger(CSV,Sep); end; end; procedure CSVToInt64DynArray(CSV: PUTF8Char; var Result: TInt64DynArray; Sep: AnsiChar); begin while CSV<>nil do begin SetLength(Result,length(Result)+1); Result[high(Result)] := GetNextItemInt64(CSV,Sep); end; end; function CSVToInt64DynArray(CSV: PUTF8Char; Sep: AnsiChar): TInt64DynArray; begin while CSV<>nil do begin SetLength(Result,length(Result)+1); Result[high(Result)] := GetNextItemInt64(CSV,Sep); end; end; function IntegerDynArrayToCSV(Values: PIntegerArray; ValuesCount: integer; const Prefix, Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; type TInts16 = packed array[word] of string[15]; // shortstring are faster (no heap allocation) var i, L, Len: PtrInt; tmp: array[0..15] of AnsiChar; ints: ^TInts16; P: PAnsiChar; tmpbuf: TSynTempBuffer; begin result := ''; if ValuesCount=0 then exit; if InlinedValue then Len := 4*ValuesCount else Len := 0; tmpbuf.Init(ValuesCount*SizeOf(ints[0])+Len); // faster than a dynamic array try ints := tmpbuf.buf; // compute whole result length at once dec(ValuesCount); inc(Len,length(Prefix)+length(Suffix)); tmp[15] := ','; for i := 0 to ValuesCount do begin P := StrInt32(@tmp[15],Values[i]); L := @tmp[15]-P; if i'' then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(Prefix)^,P^,length(Prefix)); inc(P,length(Prefix)); end; for i := 0 to ValuesCount do begin if InlinedValue then begin PWord(P)^ := ord(':')+ord('(')shl 8; inc(P,2); end; {$ifdef FPC}Move{$else}MoveFast{$endif}(ints[i][1],P^,ord(ints[i][0])); inc(P,ord(ints[i][0])); if InlinedValue then begin PWord(P)^ := ord(')')+ord(':')shl 8; inc(P,2); end; end; if Suffix<>'' then {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(Suffix)^,P^,length(Suffix)); finally tmpbuf.Done; end; end; function Int64DynArrayToCSV(Values: PInt64Array; ValuesCount: integer; const Prefix, Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; type TInt = packed record Len: byte; Val: array[0..19] of AnsiChar; // Int64: 19 digits, then - sign end; var i, L, Len: PtrInt; int: ^TInt; P: PAnsiChar; tmp: TSynTempBuffer; begin result := ''; if ValuesCount=0 then exit; if InlinedValue then Len := 4*ValuesCount else Len := 0; int := tmp.Init(ValuesCount*SizeOf(TInt)+Len); // faster than a dynamic array try // compute whole result length at once dec(ValuesCount); inc(Len,length(Prefix)+length(Suffix)); for i := 0 to ValuesCount do begin P := StrInt64(PAnsiChar(int)+21,Values[i]); L := PAnsiChar(int)+21-P; int^.Len := L; if i'' then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(Prefix)^,P^,length(Prefix)); inc(P,length(Prefix)); end; int := tmp.buf; repeat if InlinedValue then begin PWord(P)^ := ord(':')+ord('(')shl 8; inc(P,2); end; L := int^.Len; {$ifdef FPC}Move{$else}MoveFast{$endif}(PAnsiChar(int)[21-L],P^,L); inc(P,L); if InlinedValue then begin PWord(P)^ := ord(')')+ord(':')shl 8; inc(P,2); end; if ValuesCount=0 then break; inc(int); P^ := ','; inc(P); dec(ValuesCount); until false; if Suffix<>'' then {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(Suffix)^,P^,length(Suffix)); finally tmp.Done; end; end; function IntegerDynArrayToCSV(const Values: TIntegerDynArray; const Prefix, Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; begin result := IntegerDynArrayToCSV(pointer(Values),length(Values),Prefix,Suffix,InlinedValue); end; function Int64DynArrayToCSV(const Values: TInt64DynArray; const Prefix: RawUTF8; const Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; begin result := Int64DynArrayToCSV(pointer(Values),length(Values),Prefix,Suffix,InlinedValue); end; function Int64ScanIndex(P: PInt64Array; Count: PtrInt; const Value: Int64): PtrInt; var i: PtrInt; // optimized code for speed begin if P<>nil then begin result := 0; for i := 1 to Count shr 2 do // 4 PtrUInt by loop - aligned read if P^[0]<>Value then if P^[1]<>Value then if P^[2]<>Value then if P^[3]<>Value then begin inc(PByte(P),SizeOf(P^[0])*4); inc(result,4); end else begin inc(result,3); exit; end else begin inc(result,2); exit; end else begin inc(result,1); exit; end else exit; for i := 0 to (Count and 3)-1 do // last 0..3 Int64 if P^[i]=Value then exit else inc(result); end; result := -1; end; function QWordScanIndex(P: PQWordArray; Count: PtrInt; const Value: QWord): PtrInt; begin result := Int64ScanIndex(pointer(P),Count,Value); // this is the very same code end; function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean; {$ifdef HASINLINE} begin result := {$ifdef CPU64}Int64ScanExists{$else}IntegerScanExists{$endif}(pointer(P),Count,Value); end; {$else} asm jmp IntegerScanExists; end; {$endif HASINLINE} function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt; {$ifdef HASINLINE} begin result := {$ifdef CPU64}Int64ScanIndex{$else}IntegerScanIndex{$endif}(pointer(P),Count,Value); end; {$else} asm // identical to IntegerScanIndex() asm stub push eax call IntegerScan pop edx test eax, eax jnz @e dec eax // returns -1 ret @e: sub eax, edx shr eax, 2 end; {$endif HASINLINE} function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: Byte): integer; begin {$ifdef FPC} result := IndexByte(P^,Count,Value); // will use fast FPC SSE version {$else} for result := 0 to Count-1 do if P^[result]=Value then exit; result := -1; {$endif FPC} end; function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): integer; begin {$ifdef FPC} result := IndexWord(P^,Count,Value); // will use fast FPC SSE version {$else} for result := 0 to Count-1 do if P^[result]=Value then exit; result := -1; {$endif FPC} end; procedure QuickSortInteger(ID: PIntegerArray; L,R: PtrInt); var I, J, P: PtrInt; tmp: integer; begin if L=tmp; if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; if I <= J then begin tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; if P = I then P := J else if P = J then P := I; inc(I); dec(J); end; until I > J; if J - L < R - I then begin // use recursion only for smaller range if L < J then QuickSortInteger(ID, L, J); L := I; end else begin if I < R then QuickSortInteger(ID, I, R); R := J; end; until L >= R; end; procedure QuickSortInteger(var ID: TIntegerDynArray); begin QuickSortInteger(pointer(ID),0,high(ID)); end; procedure QuickSortInteger(ID,CoValues: PIntegerArray; L,R: PtrInt); var I, J, P: PtrInt; tmp: integer; begin if L=tmp; if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; if I <= J then begin tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; tmp := CoValues[J]; CoValues[J] := CoValues[I]; CoValues[I] := tmp; if P = I then P := J else if P = J then P := I; inc(I); dec(J); end; until I > J; if J - L < R - I then begin // use recursion only for smaller range if L < J then QuickSortInteger(ID, CoValues, L, J); L := I; end else begin if I < R then QuickSortInteger(ID, CoValues, I, R); R := J; end; until L >= R; end; procedure QuickSortWord(ID: PWordArray; L, R: PtrInt); var I, J, P: PtrInt; tmp: word; begin if L=tmp; if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; if I <= J then begin tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; if P = I then P := J else if P = J then P := I; inc(I); dec(J); end; until I > J; if J - L < R - I then begin // use recursion only for smaller range if L < J then QuickSortWord(ID, L, J); L := I; end else begin if I < R then QuickSortWord(ID, I, R); R := J; end; until L >= R; end; procedure QuickSortInt64(ID: PInt64Array; L, R: PtrInt); var I, J, P: PtrInt; tmp: Int64; begin if L=tmp; if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; {$else} while ID[I]ID[P] do dec(J); {$endif} if I <= J then begin tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; if P = I then P := J else if P = J then P := I; inc(I); dec(J); end; until I > J; if J - L < R - I then begin // use recursion only for smaller range if L < J then QuickSortInt64(ID, L, J); L := I; end else begin if I < R then QuickSortInt64(ID, I, R); R := J; end; until L >= R; end; procedure QuickSortQWord(ID: PQWordArray; L, R: PtrInt); var I, J, P: PtrInt; tmp: QWord; begin if L0 do dec(J); {$else} tmp := ID[P]; if ID[I]=tmp; if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; {$endif} if I <= J then begin tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; if P = I then P := J else if P = J then P := I; inc(I); dec(J); end; until I > J; if J - L < R - I then begin // use recursion only for smaller range if L < J then QuickSortQWord(ID, L, J); L := I; end else begin if I < R then QuickSortQWord(ID, I, R); R := J; end; until L >= R; end; procedure QuickSortInt64(ID,CoValues: PInt64Array; L, R: PtrInt); var I, J, P: PtrInt; tmp: Int64; begin if L=tmp; if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; {$else} while ID[I]ID[P] do dec(J); {$endif} if I <= J then begin tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; tmp := CoValues[J]; CoValues[J] := CoValues[I]; CoValues[I] := tmp; if P = I then P := J else if P = J then P := I; inc(I); dec(J); end; until I > J; if J - L < R - I then begin // use recursion only for smaller range if L < J then QuickSortInt64(ID, CoValues, L, J); L := I; end else begin if I < R then QuickSortInt64(ID, CoValues, I, R); R := J; end; until L >= R; end; procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt); begin {$ifdef CPU64} QuickSortInt64(PInt64Array(P),L,R); {$else} QuickSortInteger(PIntegerArray(P),L,R); {$endif} end; function FastFindPtrIntSorted(P: PPtrIntArray; R: PtrInt; Value: PtrInt): PtrInt; begin {$ifdef CPU64} result := FastFindInt64Sorted(PInt64Array(P),R,Value); {$else} result := FastFindIntegerSorted(PIntegerArray(P),R,Value); {$endif} end; procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt); begin {$ifdef CPU64} QuickSortInt64(PInt64Array(P),L,R); {$else} QuickSortInteger(PIntegerArray(P),L,R); {$endif} end; function FastFindPointerSorted(P: PPointerArray; R: PtrInt; Value: pointer): PtrInt; begin {$ifdef CPU64} result := FastFindInt64Sorted(PInt64Array(P),R,Int64(Value)); {$else} result := FastFindIntegerSorted(PIntegerArray(P),R,integer(Value)); {$endif} end; procedure NotifySortedIntegerChanges(old, new: PIntegerArray; oldn, newn: PtrInt; const added, deleted: TOnNotifySortedIntegerChange; const sender); var o, n: PtrInt; begin o := 0; n := 0; repeat while (n=newn) or (old[o]=oldn) or (new[n]=oldn) and (n>=newn); end; procedure CopyAndSortInteger(Values: PIntegerArray; ValuesCount: integer; var Dest: TIntegerDynArray); begin if ValuesCount>length(Dest) then SetLength(Dest,ValuesCount); {$ifdef FPC}Move{$else}MoveFast{$endif}(Values^[0],Dest[0],ValuesCount*SizeOf(Integer)); QuickSortInteger(pointer(Dest),0,ValuesCount-1); end; procedure CopyAndSortInt64(Values: PInt64Array; ValuesCount: integer; var Dest: TInt64DynArray); begin if ValuesCount>length(Dest) then SetLength(Dest,ValuesCount); {$ifdef FPC}Move{$else}MoveFast{$endif}(Values^[0],Dest[0],ValuesCount*SizeOf(Int64)); QuickSortInt64(pointer(Dest),0,ValuesCount-1); end; function FastFindIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt; var L: PtrInt; cmp: integer; begin L := 0; if 0<=R then repeat result := (L + R) shr 1; cmp := P^[result]-Value; if cmp=0 then exit; if cmp<0 then begin L := result+1; if L<=R then continue; break; end; R := result-1; if L<=R then continue; break; until false; result := -1 end; function FastFindIntegerSorted(const Values: TIntegerDynArray; Value: integer): PtrInt; begin result := FastFindIntegerSorted(pointer(Values),length(Values)-1,Value); end; function FastFindInt64Sorted(P: PInt64Array; R: PtrInt; const Value: Int64): PtrInt; var L: PtrInt; {$ifdef CPUX86} cmp: Integer; {$endif} begin L := 0; if 0<=R then repeat result := (L + R) shr 1; {$ifndef CPUX86} if P^[result]=Value then exit else if P^[result] R; while (i>=0) and (P^[i]>=Value) do dec(i); result := i+1; // return the index where to insert end; end; function AddSortedInteger(var Values: TIntegerDynArray; var ValuesCount: integer; Value: integer; CoValues: PIntegerDynArray=nil): PtrInt; begin result := FastLocateIntegerSorted(pointer(Values),ValuesCount-1,Value); if result>=0 then // if Value exists -> fails result := InsertInteger(Values,ValuesCount,Value,result,CoValues); end; function AddSortedInteger(var Values: TIntegerDynArray; Value: integer; CoValues: PIntegerDynArray=nil): PtrInt; var ValuesCount: integer; begin ValuesCount := length(Values); result := FastLocateIntegerSorted(pointer(Values),ValuesCount-1,Value); if result>=0 then begin // if Value exists -> fails SetLength(Values,ValuesCount+1); // manual size increase result := InsertInteger(Values,ValuesCount,Value,result,CoValues); end; end; function InsertInteger(var Values: TIntegerDynArray; var ValuesCount: integer; Value: Integer; Index: PtrInt; CoValues: PIntegerDynArray=nil): PtrInt; var n: PtrInt; begin result := Index; n := Length(Values); if ValuesCount=n then begin n := NextGrow(n); SetLength(Values,n); if CoValues<>nil then SetLength(CoValues^,n); end; n := ValuesCount; if PtrUInt(result)nil then {$ifdef FPC}Move{$else}MoveFast{$endif}(CoValues^[result],CoValues^[result+1],n); end else result := n; Values[result] := Value; inc(ValuesCount); end; function TIntegerDynArrayFrom(const Values: array of integer): TIntegerDynArray; var i: integer; begin SetLength(result,length(Values)); for i := 0 to high(Values) do result[i] := Values[i]; end; function TIntegerDynArrayFrom64(const Values: TInt64DynArray; raiseExceptionOnOverflow: boolean=true): TIntegerDynArray; var i: integer; const MinInt = -MaxInt-1; begin SetLength(result,length(Values)); for i := 0 to high(Values) do if Values[i]>MaxInt then if raiseExceptionOnOverflow then raise ESynException.CreateUTF8('TIntegerDynArrayFrom64: Values[%]=%>%', [i,Values[i],MaxInt]) else result[i] := MaxInt else if Values[i]#0) do inc(P); if P^='-' then begin minus := true; repeat inc(P) until P^<>' '; end else begin minus := false; if P^='+' then repeat inc(P) until P^<>' '; end; c := byte(P^)-48; if c>9 then result := 0 else begin result := c; inc(P); repeat c := byte(P^)-48; if c>9 then break else result := result*10+PtrInt(c); inc(P); until false; if minus then result := -result; end; end; function GetInteger(P,PEnd: PUTF8Char): PtrInt; var c: PtrUInt; minus: boolean; begin result := 0; if (P=nil) or (P>=PEnd) then exit; while (P^<=' ') and (P^<>#0) do begin inc(P); if P=PEnd then exit; end; if P^='-' then begin minus := true; repeat inc(P); if P=PEnd then exit; until P^<>' '; end else begin minus := false; if P^='+' then repeat inc(P); if P=PEnd then exit; until P^<>' '; end; c := byte(P^)-48; if c<=9 then begin result := c; inc(P); repeat c := byte(P^)-48; if c>9 then break else result := result*10+PtrInt(c); inc(P); until P=PEnd; if minus then result := -result; end; end; function GetInteger(P: PUTF8Char; var err: integer): PtrInt; var c: PtrUInt; minus: boolean; begin if P=nil then begin result := 0; err := 1; exit; end else err := 0; while (P^<=' ') and (P^<>#0) do inc(P); if P^='-' then begin minus := true; repeat inc(P) until P^<>' '; end else begin minus := false; if P^='+' then repeat inc(P) until P^<>' '; end; c := byte(P^)-48; if c>9 then begin err := 1; result := 0; exit; end else begin result := c; inc(P); repeat c := byte(P^)-48; if c>9 then begin if byte(P^)<>0 then err := 1; // always return 1 as err code -> don't care about char index break; end else result := result*10+PtrInt(c); inc(P); until false; end; if minus then result := -result; end; function GetIntegerDef(P: PUTF8Char; Default: PtrInt): PtrInt; var err: integer; begin result := GetInteger(P,err); if err<>0 then result := Default; end; function UTF8ToInteger(const value: RawUTF8; Default: PtrInt=0): PtrInt; var err: integer; begin result := GetInteger(pointer(value),err); if err<>0 then result := Default; end; function UTF8ToInteger(const value: RawUTF8; Min,max: PtrInt; Default: PtrInt=0): PtrInt; var err: integer; begin result := GetInteger(pointer(value),err); if (err<>0) or (resultmax) then result := Default; end; function ToInteger(const text: RawUTF8; out value: integer): boolean; var err: integer; begin value := GetInteger(pointer(text),err); result := err=0; end; function ToCardinal(const text: RawUTF8; out value: cardinal; minimal: cardinal): boolean; begin value := GetCardinalDef(pointer(text),cardinal(-1)); result := (value<>cardinal(-1)) and (value>=minimal); end; function ToInt64(const text: RawUTF8; out value: Int64): boolean; var err: integer; begin value := GetInt64(pointer(text),err); result := err=0; end; function UTF8ToInt64(const text: RawUTF8; const default: Int64): Int64; var err: integer; begin result := GetInt64(pointer(text),err); if err<>0 then result := default; end; function GetBoolean(P: PUTF8Char): boolean; begin if P<>nil then case PInteger(P)^ of TRUE_LOW: result := true; FALSE_LOW: result := false; else result := PWord(P)^<>ord('0'); end else result := false; end; function GetCardinalDef(P: PUTF8Char; Default: PtrUInt): PtrUInt; var c: PtrUInt; begin if P=nil then begin result := Default; exit; end; while (P^<=' ') and (P^<>#0) do inc(P); c := byte(P^)-48; if c>9 then result := Default else begin result := c; inc(P); repeat c := byte(P^)-48; if c>9 then break else result := result*10+PtrUInt(c); inc(P); until false; end; end; function GetCardinal(P: PUTF8Char): PtrUInt; var c: PtrUInt; begin if P=nil then begin result := 0; exit; end; while (P^<=' ') and (P^<>#0) do inc(P); c := byte(P^)-48; if c>9 then result := 0 else begin result := c; inc(P); repeat c := byte(P^)-48; if c>9 then break else result := result*10+PtrUInt(c); inc(P); until false; end; end; function GetCardinalW(P: PWideChar): PtrUInt; var c: PtrUInt; begin if P=nil then begin result := 0; exit; end; if ord(P^) in [1..32] then repeat inc(P) until not(ord(P^) in [1..32]); c := word(P^)-48; if c>9 then result := 0 else begin result := c; inc(P); repeat c := word(P^)-48; if c>9 then break else result := result*10+c; inc(P); until false; end; end; {$ifdef CPU64} procedure SetInt64(P: PUTF8Char; var result: Int64); begin // PtrInt is already int64 -> call PtrInt version result := GetInteger(P); end; {$else} procedure SetInt64(P: PUTF8Char; var result: Int64); var c: cardinal; minus: boolean; begin result := 0; if P=nil then exit; while (P^<=' ') and (P^<>#0) do inc(P); if P^='-' then begin minus := true; repeat inc(P) until P^<>' '; end else begin minus := false; if P^='+' then repeat inc(P) until P^<>' '; end; c := byte(P^)-48; if c>9 then exit; PCardinal(@result)^ := c; inc(P); repeat // fast 32-bit loop c := byte(P^)-48; if c>9 then break else PCardinal(@result)^ := PCardinal(@result)^*10+c; inc(P); if PCardinal(@result)^>=high(cardinal)div 10 then begin repeat // 64-bit loop c := byte(P^)-48; if c>9 then break; result := result shl 3+result+result; // fast result := result*10 inc(result,c); inc(P); until false; break; end; until false; if minus then result := -result; end; {$endif} {$ifdef CPU64} procedure SetQWord(P: PUTF8Char; var result: QWord); begin // PtrUInt is already QWord -> call PtrUInt version result := GetCardinal(P); end; {$else} procedure SetQWord(P: PUTF8Char; var result: QWord); var c: cardinal; begin result := 0; if P=nil then exit; while (P^<=' ') and (P^<>#0) do inc(P); if P^='+' then repeat inc(P) until P^<>' '; c := byte(P^)-48; if c>9 then exit; PCardinal(@result)^ := c; inc(P); repeat // fast 32-bit loop c := byte(P^)-48; if c>9 then break else PCardinal(@result)^ := PCardinal(@result)^*10+c; inc(P); if PCardinal(@result)^>=high(cardinal)div 10 then begin repeat // 64-bit loop c := byte(P^)-48; if c>9 then break; result := result shl 3+result+result; // fast result := result*10 inc(result,c); inc(P); until false; break; end; until false; end; {$endif} {$ifdef CPU64} function GetInt64(P: PUTF8Char): Int64; begin // PtrInt is already int64 -> call previous version result := GetInteger(P); end; {$else} function GetInt64(P: PUTF8Char): Int64; begin SetInt64(P,result); end; {$endif} function GetInt64Def(P: PUTF8Char; const Default: Int64): Int64; var err: integer; begin result := GetInt64(P,err); if err>0 then result := Default; end; {$ifdef CPU64} function GetInt64(P: PUTF8Char; var err: integer): Int64; begin // PtrInt is already int64 -> call previous version result := GetInteger(P,err); end; {$else} function GetInt64(P: PUTF8Char; var err: integer): Int64; var c: cardinal; minus: boolean; begin err := 0; result := 0; if P=nil then exit; while (P^<=' ') and (P^<>#0) do inc(P); if P^='-' then begin minus := true; repeat inc(P) until P^<>' '; end else begin minus := false; if P^='+' then repeat inc(P) until P^<>' '; end; inc(err); c := byte(P^)-48; if c>9 then exit; PCardinal(@result)^ := c; inc(P); repeat // fast 32-bit loop c := byte(P^); if c<>0 then begin dec(c,48); inc(err); if c>9 then exit; PCardinal(@result)^ := PCardinal(@result)^*10+c; inc(P); if PCardinal(@result)^>=high(cardinal)div 10 then begin repeat // 64-bit loop c := byte(P^); if c=0 then begin err := 0; // conversion success without error break; end; dec(c,48); inc(err); if c>9 then exit else {$ifdef CPU32DELPHI} result := result shl 3+result+result; {$else} result := result*10; {$endif} inc(result,c); if result<0 then exit; // overflow (>$7FFFFFFFFFFFFFFF) inc(P); until false; break; end; end else begin err := 0; // reached P^=#0 -> conversion success without error break; end; until false; if minus then result := -result; end; {$endif} function GetQWord(P: PUTF8Char; var err: integer): QWord; var c: PtrUInt; begin err := 1; // error result := 0; if P=nil then exit; while (P^<=' ') and (P^<>#0) do inc(P); c := byte(P^)-48; if c>9 then exit; {$ifdef CPU64} result := c; inc(P); repeat c := byte(P^); if c=0 then break; dec(c,48); if c>9 then exit; result := result*10+c; inc(P); until false; err := 0; // success {$else} PByte(@result)^ := c; inc(P); repeat // fast 32-bit loop c := byte(P^); if c<>0 then begin dec(c,48); inc(err); if c>9 then exit; PCardinal(@result)^ := PCardinal(@result)^*10+c; inc(P); if PCardinal(@result)^>=high(cardinal)div 10 then begin repeat // 64-bit loop c := byte(P^); if c=0 then begin err := 0; // conversion success without error break; end; dec(c,48); inc(err); if c>9 then exit else {$ifdef CPU32DELPHI} result := result shl 3+result+result; {$else} result := result*10; {$endif} inc(result,c); inc(P); until false; break; end; end else begin err := 0; // reached P^=#0 -> conversion success without error break; end; until false; {$endif CPU64} end; function GetExtended(P: PUTF8Char): TSynExtended; var err: integer; begin result := GetExtended(P,err); if err<>0 then result := 0; end; function HugePower10(exponent: integer): TSynExtended; {$ifdef HASINLINE}inline;{$endif} var pow10: TSynExtended; begin result := 1.0; if exponent<0 then begin pow10 := 0.1; exponent := -exponent; end else pow10 := 10; repeat while exponent and 1=0 do begin exponent := exponent shr 1; pow10 := sqr(pow10); end; result := result*pow10; dec(exponent); until exponent=0; end; function GetExtended(P: PUTF8Char; out err: integer): TSynExtended; {$ifndef CPU32DELPHI} // inspired from ValExt_JOH_PAS_8_a by John O'Harrow const POW10: array[-31..31] of TSynExtended = ( 1E-31,1E-30,1E-29,1E-28,1E-27,1E-26,1E-25,1E-24,1E-23,1E-22,1E-21,1E-20, 1E-19,1E-18,1E-17,1E-16,1E-15,1E-14,1E-13,1E-12,1E-11,1E-10,1E-9,1E-8,1E-7, 1E-6,1E-5,1E-4,1E-3,1E-2,1E-1,1E0,1E1,1E2,1E3,1E4,1E5,1E6,1E7,1E8,1E9,1E10, 1E11,1E12,1E13,1E14,1E15,1E16,1E17,1E18,1E19,1E20,1E21,1E22,1E23,1E24,1E25, 1E26,1E27,1E28,1E29,1E30,1E31); var digits, exp: PtrInt; ch: byte; flags: set of (fNeg, fNegExp, fValid); U: PByte; // Delphi Win64 doesn't like if P^ is used directly {$ifndef CPUX86}ten: TSynExtended;{$endif} // stored in (e.g. xmm2) register begin {$ifndef CPUX86} ten := 10.0; {$endif} result := 0; if P=nil then begin err := 1; exit; end; byte(flags) := 0; U := pointer(P); if P^=' ' then repeat inc(U) until U^<>32; // trailing spaces ch := U^; if ch=ord('+') then inc(U) else if ch=ord('-') then begin inc(U); include(flags,fNeg); end; repeat ch := U^; inc(U); if (chord('9')) then break; dec(ch,ord('0')); {$ifdef CPUX86} result := (result*10.0)+ch; {$else} result := result*ten; // better FPC+Delphi64 code generation in two steps result := result+ch; {$endif} include(flags,fValid); until false; digits := 0; if ch=ord('.') then repeat ch := U^; inc(U); if (chord('9')) then begin if not(fValid in flags) then // starts with '.' if ch=0 then dec(U); // U^='.' break; end; dec(ch,ord('0')); {$ifdef CPUX86} result := (result*10.0)+ch; {$else} result := result*ten; result := result+ch; {$endif} dec(digits); include(flags,fValid); until false; if (ch=ord('E')) or (ch=ord('e')) then begin exp := 0; exclude(flags,fValid); ch := U^; if ch=ord('+') then inc(U) else if ch=ord('-') then begin inc(U); include(flags,fNegExp); end; repeat ch := U^; inc(U); if (chord('9')) then break; dec(ch,ord('0')); exp := (exp*10)+PtrInt(ch); include(flags,fValid); until false; if fNegExp in flags then dec(digits,exp) else inc(digits,exp); end; if digits<>0 then if (digits>=low(POW10)) and (digits<=high(POW10)) then result := result*POW10[digits] else result := result*HugePower10(digits); if fNeg in flags then result := -result; if (fValid in flags) and (ch=0) then err := 0 else err := PUTF8Char(U)-P+1; end; {$else} const Ten: double = 10.0; asm // in: eax=text, edx=@err out: st(0)=result push ebx // save used registers push esi push edi mov esi, eax // string pointer push eax // save for error condition xor ebx, ebx push eax // allocate local storage for loading fpu test esi, esi jz @nil // nil string @trim: movzx ebx, byte ptr[esi] // strip leading spaces inc esi cmp bl, ' ' je @trim xor ecx, ecx // clear sign flag fld qword[Ten] // load 10 into fpu xor eax, eax // zero number of decimal places fldz // zero result in fpu cmp bl, '0' jl @chksig // check for sign character @dig1: xor edi, edi // zero exponent value @digl: sub bl, '0' cmp bl, 9 ja @frac // non-digit mov cl, 1 // set digit found flag mov [esp], ebx // store for fpu use fmul st(0), st(1) // multply by 10 fiadd dword ptr[esp] // add next digit movzx ebx, byte ptr[esi] // get next char inc esi test bl, bl // end reached? jnz @digl // no,get next digit jmp @finish // yes,finished @chksig:cmp bl, '-' je @minus cmp bl, '+' je @sigset @gdig1: test bl, bl jz @error // no digits found jmp @dig1 @minus: mov ch, 1 // set sign flag @sigset:movzx ebx, byte ptr[esi] // get next char inc esi jmp @gdig1 @frac: cmp bl, '.' - '0' jne @exp // no decimal point movzx ebx, byte ptr[esi] // get next char test bl, bl jz @dotend // string ends with '.' inc esi @fracl: sub bl, '0' cmp bl, 9 ja @exp // non-digit mov [esp], ebx dec eax // -(number of decimal places) fmul st(0), st(1) // multply by 10 fiadd dword ptr[esp] // add next digit movzx ebx, byte ptr[esi] // get next char inc esi test bl, bl // end reached? jnz @fracl // no, get next digit jmp @finish // yes, finished (no exponent) @dotend:test cl, cl // any digits found before '.'? jnz @finish // yes, valid jmp @error // no,invalid @exp: or bl, $20 cmp bl, 'e' - '0' jne @error // not 'e' or 'e' movzx ebx, byte ptr[esi] // get next char inc esi mov cl, 0 // clear exponent sign flag cmp bl, '-' je @minexp cmp bl, '+' je @expset jmp @expl @minexp:mov cl, 1 // set exponent sign flag @expset:movzx ebx, byte ptr[esi] // get next char inc esi @expl: sub bl, '0' cmp bl, 9 ja @error // non-digit lea edi, [edi + edi * 4]// multiply by 10 add edi, edi add edi, ebx // add next digit movzx ebx, byte ptr[esi] // get next char inc esi test bl, bl // end reached? jnz @expl // no, get next digit @endexp:test cl, cl // positive exponent? jz @finish // yes, keep exponent value neg edi // no, negate exponent value @finish:add eax, edi // exponent value - number of decimal places mov [edx], ebx // result code = 0 jz @pow // no call to _pow10 needed mov edi, ecx // save decimal sign flag call System.@Pow10 // raise to power of 10 mov ecx, edi // restore decimal sign flag @pow: test ch, ch // decimal sign flag set? jnz @negate // yes, negate value @ok: add esp, 8 // dump local storage and string pointer @exit: ffree st(1) // remove ten value from fpu pop edi // restore used registers pop esi pop ebx ret // finished @negate:fchs // negate result in fpu jmp @ok @nil: inc esi // force result code = 1 fldz // result value = 0 @error: pop ebx // dump local storage pop eax // string pointer sub esi, eax // error offset mov [edx], esi // set result code test ch, ch // decimal sign flag set? jz @exit // no,exit fchs // yes. negate result in fpu jmp @exit // exit setting result code end; {$endif CPU32DELPHI} function GetUTF8Char(P: PUTF8Char): cardinal; begin if P<>nil then begin result := ord(P[0]); if result and $80<>0 then begin result := GetHighUTF8UCS4(P); if result>$ffff then result := ord('?'); // do not handle surrogates now end; end else result := PtrUInt(P); end; function NextUTF8UCS4(var P: PUTF8Char): cardinal; begin if P<>nil then begin result := byte(P[0]); if result<=127 then inc(P) else begin if result and $20=0 then begin result := result shl 6+byte(P[1])-$3080; // fast direct process $0..$7ff inc(P,2); end else result := GetHighUTF8UCS4(P); // handle even surrogates end; end else result := 0; end; function ContainsUTF8(p, up: PUTF8Char): boolean; var u: PByte; begin if (p<>nil) and (up<>nil) and (up^<>#0) then begin result := true; repeat u := pointer(up); repeat if GetNextUTF8Upper(p)<>u^ then break else inc(u); if u^=0 then exit; // up^ was found inside p^ until false; p := FindNextUTF8WordBegin(p); until p=nil; end; result := false; end; function IdemFileExt(p: PUTF8Char; extup: PAnsiChar; sepChar: AnsiChar): Boolean; var ext: PUTF8Char; begin if (p<>nil) and (extup<>nil) then begin ext := nil; repeat if p^=sepChar then ext := p; // get last '.' position from p into ext inc(p); until p^=#0; if ext<>nil then result := IdemPChar(ext,extup) else result := false; end else result := false; end; function IdemPCharWithoutWhiteSpace(p: PUTF8Char; up: PAnsiChar): boolean; begin result := False; if p=nil then exit; if up<>nil then while up^<>#0 do begin while p<=' ' do // trim white space if p^=#0 then exit else inc(p); if up^<>NormToUpperAnsi7[p^] then exit; inc(up); inc(p); end; result := true; end; function IdemPCharArray(p: PUTF8Char; const upArray: array of PAnsiChar): integer; var w: word; tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperAnsi7{$else}PNormTableByte{$endif}; up: ^PAnsiChar; begin if p<>nil then begin {$ifndef CPUX86NOTPIC}tab := @NormToUpperAnsi7;{$endif} // faster on PIC and x86_64 w := tab[ord(p[0])]+tab[ord(p[1])]shl 8; up := @upArray[0]; for result := 0 to high(upArray) do if (PWord(up^)^=w) and {$ifdef CPUX86NOTPIC}IdemPChar({$else}IdemPChar2(pointer(tab),{$endif}p+2,up^+2) then exit else inc(up); end; result := -1; end; function IdemPCharArray(p: PUTF8Char; const upArrayBy2Chars: RawUTF8): integer; var w: word; begin if p<>nil then begin w := NormToUpperAnsi7Byte[ord(p[0])]+NormToUpperAnsi7Byte[ord(p[1])]shl 8; for result := 0 to pred(length(upArrayBy2Chars) shr 1) do if PWordArray(upArrayBy2Chars)[result]=w then exit; end; result := -1; end; function IdemPCharU(p, up: PUTF8Char): boolean; begin result := false; if (p=nil) or (up=nil) then exit; while up^<>#0 do begin if GetNextUTF8Upper(p)<>ord(up^) then exit; inc(up); end; result := true; end; function EndWith(const text, upText: RawUTF8): boolean; var o: PtrInt; begin o := length(text)-length(upText); result := (o>=0) and IdemPChar(PUTF8Char(pointer(text))+o,pointer(upText)); end; function EndWithArray(const text: RawUTF8; const upArray: array of RawUTF8): integer; var t,o: PtrInt; begin t := length(text); if t>0 then for result := 0 to high(upArray) do begin o := t-length(UpArray[result]); if (o>=0) and IdemPChar(PUTF8Char(pointer(text))+o,pointer(upArray[result])) then exit; end; result := -1; end; function UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; begin if source<>'' then result := UpperCopy255Buf(dest,pointer(source), {$ifdef FPC}_LStrLen(source){$else}PInteger(PtrInt(source)-4)^{$endif}) else result := dest; end; function UpperCopy255BufPas(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; var i,c,d{$ifdef CPU64},_80,_61,_7b{$endif}: PtrUInt; begin if sourceLen>0 then begin if sourceLen>248 then sourceLen := 248; // avoid buffer overflow // we allow to copy up to 3/7 more chars in Dest^ since its size is 255 {$ifdef CPU64} // unbranched uppercase conversion of 8 chars blocks _80 := PtrUInt($8080808080808080); // use registers for constants _61 := $6161616161616161; _7b := $7b7b7b7b7b7b7b7b; for i := 0 to sourceLen 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 c := PPtrUIntArray(source)^[i]; d := c or $80808080; PPtrUIntArray(dest)^[i] := c-((d-$61616161) and not(d-$7b7b7b7b)) and ((not c) and $80808080)shr 2; end; {$endif} result := dest+sourceLen; // but we always return the exact size end else result := dest; end; function UpperCopyWin255(dest: PWinAnsiChar; const source: RawUTF8): PWinAnsiChar; var i, L: integer; tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperByte{$else}PNormTableByte{$endif}; begin L := {$ifdef FPC}_LStrLen(source){$else}PInteger(PtrInt(source)-SizeOf(integer))^{$endif}; if L>0 then begin if L>250 then L := 250; // avoid buffer overflow result := dest+L; {$ifndef CPUX86NOTPIC}tab := @NormToUpperByte;{$endif} // faster on PIC and x86_64 for i := 0 to L-1 do dest[i] := AnsiChar(tab[PByteArray(source)[i]]); end else result := dest; end; function UTF8UpperCopy(Dest, Source: PUTF8Char; SourceChars: Cardinal): PUTF8Char; var c: PtrUInt; endSource, endSourceBy4, S: PUTF8Char; extra,i: PtrInt; label By1, By4, set1; // ugly but faster begin if (Source<>nil) and (Dest<>nil) then begin // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) endSource := Source+SourceChars; endSourceBy4 := endSource-4; if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then repeat By4:c := PCardinal(Source)^; if c and $80808080<>0 then goto By1; // break on first non ASCII quad inc(Source,4); Dest[0] := AnsiChar(NormToUpperByte[ToByte(c)]); Dest[1] := AnsiChar(NormToUpperByte[ToByte(c shr 8)]); Dest[2] := AnsiChar(NormToUpperByte[ToByte(c shr 16)]); Dest[3] := AnsiChar(NormToUpperByte[c shr 24]); inc(Dest,4); until Source>endSourceBy4; // generic loop, handling one UCS4 char per iteration if SourceendSource) then break; for i := 0 to extra-1 do c := c shl 6+byte(Source[i]); with UTF8_EXTRA[extra] do begin dec(c,offset); if c0 then begin if L>250 then L := 250; // avoid buffer overflow result := UTF8UpperCopy(pointer(dest),pointer(source),L); end else result := pointer(dest); end; function UpperCopy255W(dest: PAnsiChar; const source: SynUnicode): PAnsiChar; var c: cardinal; i,L: integer; begin L := length(source); if L>0 then begin if L>250 then L := 250; // avoid buffer overflow result := dest+L; for i := 0 to L-1 do begin c := PWordArray(source)[i]; if c<255 then dest[i] := AnsiChar(NormToUpperAnsi7Byte[c]) else dest[i] := '?'; end; end else result := dest; end; function UpperCopy255W(dest: PAnsiChar; source: PWideChar; L: integer): PAnsiChar; var c: cardinal; i: integer; begin if L>0 then begin if L>250 then L := 250; // avoid buffer overflow result := dest+L; for i := 0 to L-1 do begin c := PWordArray(source)[i]; if c<255 then dest[i] := AnsiChar(NormToUpperAnsi7Byte[c]) else dest[i] := '?'; end; end else result := dest; end; function GetNextLine(source: PUTF8Char; out next: PUTF8Char): RawUTF8; var beg: PUTF8Char; begin if source=nil then begin {$ifdef FPC}Finalize(result){$else}result := ''{$endif}; next := source; exit; end; beg := source; repeat if source[0]>#13 then if source[1]>#13 then if source[2]>#13 then if source[3]>#13 then begin inc(source,4); continue; end else inc(source,3) else inc(source,2) else inc(source); case source^ of #0: next := nil; #10: next := source+1; #13: if source[1]=#10 then next := source+2 else next := source+1; else begin inc(source); continue; end; end; FastSetString(result,beg,source-beg); exit; until false; end; {$ifdef UNICODE} function GetNextLineW(source: PWideChar; out next: PWideChar): string; begin next := source; if source=nil then begin result := ''; exit; end; while not (cardinal(source^) in [0,10,13]) do inc(source); SetString(result,PChar(next),source-next); if source^=#13 then inc(source); if source^=#10 then inc(source); if source^=#0 then next := nil else next := source; end; function FindIniNameValueW(P: PWideChar; UpperName: PUTF8Char): string; var PBeg: PWideChar; L: PtrInt; begin while (P<>nil) and (P^<>'[') do begin PBeg := P; while not (cardinal(P^) in [0,10,13]) do inc(P); while cardinal(P^) in [10,13] do inc(P); if P^=#0 then P := nil; if PBeg^=' ' then repeat inc(PBeg) until PBeg^<>' '; // trim left ' ' if IdemPCharW(PBeg,UpperName) then begin inc(PBeg,StrLen(UpperName)); L := 0; while PBeg[L]>=' ' do inc(L); // get line length SetString(result,PBeg,L); exit; end; end; result := ''; end; function FindIniEntryW(const Content: string; const Section, Name: RawUTF8): string; var P: PWideChar; UpperSection, UpperName: array[byte] of AnsiChar; // possible GPF if length(Section/Name)>255, but should const in code begin result := ''; P := pointer(Content); if P=nil then exit; // UpperName := UpperCase(Name)+'='; PWord(UpperCopy255(UpperName,Name))^ := ord('='); if Section='' then // find the Name= entry before any [Section] result := FindIniNameValueW(P,UpperName) else begin // find the Name= entry in the specified [Section] PWord(UpperCopy255(UpperSection,Section))^ := ord(']'); if FindSectionFirstLineW(P,UpperSection) then result := FindIniNameValueW(P,UpperName); end; end; {$endif UNICODE} function IdemPCharAndGetNextItem(var source: PUTF8Char; const searchUp: RawUTF8; var Item: RawUTF8; Sep: AnsiChar): boolean; begin if source=nil then result := false else begin result := IdemPChar(source,Pointer(searchUp)); if result then begin inc(source,Length(searchUp)); GetNextItem(source,Sep,Item); end; end; end; {$ifdef FPC}{$push}{$endif} {$WARNINGS OFF} // some Delphi compilers do not analyze well code below function GotoNextLine(source: PUTF8Char): PUTF8Char; begin if source<>nil then repeat if source[0]>#13 then if source[1]>#13 then if source[2]>#13 then if source[3]>#13 then begin inc(source,4); continue; end else inc(source,3) else inc(source,2) else inc(source); case source^ of #0: result := nil; #10: result := source+1; #13: if source[1]=#10 then result := source+2 else result := source+1; else begin inc(source); continue; end; end; exit; until false else result := source; end; {$ifdef FPC}{$pop}{$else}{$WARNINGS ON}{$endif} function BufferLineLength(Text, TextEnd: PUTF8Char): PtrInt; {$ifdef CPUX64} {$ifdef FPC} nostackframe; assembler; asm {$else} asm .NOFRAME {$endif} {$ifdef MSWINDOWS} // Win64 ABI to System-V ABI push rsi push rdi mov rdi, rcx mov rsi, rdx {$endif}mov r8, rsi sub r8, rdi // rdi=Text, rsi=TextEnd, r8=TextLen jz @fail mov ecx, edi movdqa xmm0, [rip + @for10] movdqa xmm1, [rip + @for13] and rdi, -16 // check first aligned 16 bytes and ecx, 15 // lower 4 bits indicate misalignment movdqa xmm2, [rdi] movdqa xmm3, xmm2 pcmpeqb xmm2, xmm0 pcmpeqb xmm3, xmm1 por xmm3, xmm2 pmovmskb eax, xmm3 shr eax, cl // shift out unaligned bytes test eax, eax jz @main bsf eax, eax add rax, rcx add rax, rdi sub rax, rsi jae @fail // don't exceed TextEnd add rax, r8 // rax = TextFound - TextEnd + (TextEnd - Text) = offset {$ifdef MSWINDOWS} pop rdi pop rsi {$endif}ret @main: add rdi, 16 sub rdi, rsi jae @fail jmp @by16 {$ifdef FPC} align 16 {$else} .align 16 {$endif} @for10: dq $0a0a0a0a0a0a0a0a dq $0a0a0a0a0a0a0a0a @for13: dq $0d0d0d0d0d0d0d0d dq $0d0d0d0d0d0d0d0d @by16: movdqa xmm2, [rdi + rsi] // check 16 bytes per loop movdqa xmm3, xmm2 pcmpeqb xmm2, xmm0 pcmpeqb xmm3, xmm1 por xmm3, xmm2 pmovmskb eax, xmm3 test eax, eax jnz @found add rdi, 16 jnc @by16 @fail: mov rax, r8 // returns TextLen if no CR/LF found {$ifdef MSWINDOWS} pop rdi pop rsi {$endif}ret @found: bsf eax, eax add rax, rdi jc @fail add rax, r8 {$ifdef MSWINDOWS} pop rdi pop rsi {$endif} end; {$else} {$ifdef FPC}inline;{$endif} var c: cardinal; begin result := 0; dec(PtrInt(TextEnd),PtrInt(Text)); // compute TextLen if TextEnd<>nil then repeat c := ord(Text[result]); if c>13 then begin inc(result); if result>=PtrInt(PtrUInt(TextEnd)) then break; continue; end; if (c=10) or (c=13) then break; inc(result); if result>=PtrInt(PtrUInt(TextEnd)) then break; until false; end; {$endif CPUX64} function GetLineSize(P,PEnd: PUTF8Char): PtrUInt; var c: cardinal; begin if PEnd=nil then dec(PtrUInt(PEnd)); result := PtrUInt(P); if P<>nil then repeat c := ord(P^); if c>13 then begin inc(P); if P>=PEnd then break; continue; end; if (c=0) or (c=10) or (c=13) then break; inc(P); if P>=PEnd then break; until false; result := PtrUInt(P)-result; end; function GetNextItem(var P: PUTF8Char; Sep: AnsiChar): RawUTF8; begin GetNextItem(P,Sep,result); end; procedure GetNextItem(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); var S: PUTF8Char; begin if P=nil then result := '' else begin S := P; while (S^<>#0) and (S^<>Sep) do inc(S); FastSetString(result,P,S-P); if S^<>#0 then P := S+1 else P := nil; end; end; procedure GetNextItem(var P: PUTF8Char; Sep, Quote: AnsiChar; var result: RawUTF8); begin if P=nil then result := '' else if P^=Quote then begin P := UnQuoteSQLStringVar(P,result); if P=nil then result := '' else if P^<>#0 then inc(P); end else GetNextItem(P,Sep,result); end; procedure GetNextItemTrimed(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); var S,E: PUTF8Char; begin if (P=nil) or (Sep<=' ') then result := '' else begin while (P^<=' ') and (P^<>#0) do inc(P); // trim left S := P; while (S^<>#0) and (S^<>Sep) do inc(S); E := S; while (E>P) and (E[-1] in [#1..' ']) do dec(E); // trim right FastSetString(result,P,E-P); if S^<>#0 then P := S+1 else P := nil; end; end; procedure GetNextItemTrimedCRLF(var P: PUTF8Char; var result: RawUTF8); var S,E: PUTF8Char; begin if P=nil then result := '' else begin S := P; while (S^<>#0) and (S^<>#10) do inc(S); E := S; if (E>P) and (E[-1]=#13) then dec(E); FastSetString(result,P,E-P); if S^<>#0 then P := S+1 else P := nil; end; end; function GetNextItemString(var P: PChar; Sep: Char= ','): string; // this function will compile into AnsiString or UnicodeString, depending // of the compiler version var S: PChar; begin if P=nil then result := '' else begin S := P; while (S^<>#0) and (S^<>Sep) do inc(S); SetString(result,P,S-P); if S^<>#0 then P := S+1 else P := nil; end; end; function GetNextStringLineToRawUnicode(var P: PChar): RawUnicode; var S: PChar; begin if P=nil then result := '' else begin S := P; while S^>=' ' do inc(S); result := StringToRawUnicode(P,S-P); while (S^<>#0) and (S^<' ') do inc(S); // ignore e.g. #13 or #10 if S^<>#0 then P := S else P := nil; end; end; procedure AppendCSVValues(const CSV: string; const Values: array of string; var Result: string; const AppendBefore: string); var Caption: string; i, bool: integer; P: PChar; first: Boolean; begin P := pointer(CSV); if P=nil then exit; first := True; for i := 0 to high(Values) do begin Caption := GetNextItemString(P); if Values[i]<>'' then begin if first then begin Result := Result+#13#10; first := false; end else Result := Result+AppendBefore; bool := FindCSVIndex('0,-1',RawUTF8(Values[i])); Result := Result+Caption+': '; if bool<0 then Result := Result+Values[i] else Result := Result+GetCSVItemString(pointer(GetNextItemString(P)),bool,'/'); end; end; end; procedure GetNextItemShortString(var P: PUTF8Char; out Dest: ShortString; Sep: AnsiChar= ','); var S: PUTF8Char; len: integer; begin if P=nil then Dest[0] := #0 else begin while (P^<=' ') and (P^<>#0) do inc(P); S := P; while (S^<>#0) and (S^<>Sep) do inc(S); len := S-P; while (P[len-1] in [#1..' ']) and (len>0) do dec(len); // trim right spaces SetString(Dest,P,len); if S^<>#0 then P := S+1 else P := nil; end; end; function GetNextItemHexDisplayToBin(var P: PUTF8Char; Bin: PByte; BinBytes: integer; Sep: AnsiChar= ','): boolean; var S: PUTF8Char; len: integer; begin result := false; FillCharFast(Bin^,BinBytes,0); if P=nil then exit; if P^ = ' ' then repeat inc(P) until P^ <> ' '; S := P; if Sep=#0 then while S^>' ' do inc(S) else while (S^<>#0) and (S^<>Sep) do inc(S); len := S-P; while (P[len-1] in [#1..' ']) and (len>0) do dec(len); // trim right spaces if len<>BinBytes*2 then exit; if not HexDisplayToBin(PAnsiChar(P),Bin,BinBytes) then FillCharFast(Bin^,BinBytes,0) else begin if S^=#0 then P := nil else if Sep<>#0 then P := S+1 else P := S; result := true; end; end; function GetNextItemCardinal(var P: PUTF8Char; Sep: AnsiChar): PtrUInt; var c: PtrUInt; begin if P=nil then begin result := 0; exit; end; if P^ = ' ' then repeat inc(P) until P^ <> ' '; c := byte(P^)-48; if c>9 then result := 0 else begin result := c; inc(P); repeat c := byte(P^)-48; if c>9 then break else result := result*10+c; inc(P); until false; end; if Sep<>#0 then while (P^<>#0) and (P^<>Sep) do // go to end of CSV item (ignore any decimal) inc(P); if P^=#0 then P := nil else if Sep<>#0 then inc(P); end; function GetNextItemCardinalStrict(var P: PUTF8Char): PtrUInt; var c: PtrUInt; begin if P=nil then begin result := 0; exit; end; c := byte(P^)-48; if c>9 then result := 0 else begin result := c; inc(P); repeat c := byte(P^)-48; if c>9 then break else result := result*10+c; inc(P); until false; end; if P^=#0 then P := nil; end; function CSVOfValue(const Value: RawUTF8; Count: cardinal; const Sep: RawUTF8): RawUTF8; var ValueLen, SepLen: cardinal; i: cardinal; P: PAnsiChar; begin // CSVOfValue('?',3)='?,?,?' result := ''; if Count=0 then exit; ValueLen := length(Value); SepLen := Length(Sep); Setlength(result,ValueLen*Count+SepLen*pred(Count)); P := pointer(result); i := 1; repeat {$ifdef FPC}Move{$else}MoveFast{$endif}(Pointer(Value)^,P^,ValueLen); inc(P,ValueLen); if i=Count then break; {$ifdef FPC}Move{$else}MoveFast{$endif}(Pointer(Sep)^,P^,SepLen); inc(P,SepLen); inc(i); until false; // assert(P-pointer(result)=length(result)); end; procedure SetBitCSV(var Bits; BitsCount: integer; var P: PUTF8Char); var bit,last: cardinal; begin while P<>nil do begin bit := GetNextItemCardinalStrict(P)-1; // '0' marks end of list if bit>=cardinal(BitsCount) then break; // avoid GPF if (P=nil) or (P^=',') then SetBitPtr(@Bits,bit) else if P^='-' then begin inc(P); last := GetNextItemCardinalStrict(P)-1; // '0' marks end of list if last>=Cardinal(BitsCount) then exit; while bit<=last do begin SetBitPtr(@Bits,bit); inc(bit); end; end; if (P<>nil) and (P^=',') then inc(P); end; if (P<>nil) and (P^=',') then inc(P); end; function GetBitCSV(const Bits; BitsCount: integer): RawUTF8; var i,j: integer; begin result := ''; i := 0; while i9 then result := 0 else begin result := c; inc(P); repeat c := word(P^)-48; if c>9 then break else result := result*10+c; inc(P); until false; end; while (P^<>#0) and (P^<>Sep) do // go to end of CSV item (ignore any decimal) inc(P); if P^=#0 then P := nil else inc(P); end; function GetNextItemInteger(var P: PUTF8Char; Sep: AnsiChar= ','): PtrInt; var minus: boolean; begin if P=nil then begin result := 0; exit; end; if (P^ in ['+','-']) then begin minus := P^='-'; inc(P); end else minus := false; result := PtrInt(GetNextItemCardinal(P,Sep)); if minus then result := -result; end; function GetNextTChar64(var P: PUTF8Char; Sep: AnsiChar; out Buf: TChar64): PtrInt; begin result := 0; if P=nil then exit; if Sep=#0 then // store up to next whitespace while P[result]>' ' do begin Buf[result] := P[result]; inc(result); if result>=SizeOf(Buf) then exit; // avoid buffer overflow end else while (P[result]<>#0) and (P[result]<>Sep) do begin Buf[result] := P[result]; inc(result); if result>=SizeOf(Buf) then exit; // avoid buffer overflow end; Buf[result] := #0; // make asciiz inc(P,result); // P[result]=Sep or #0 if P^=#0 then P := nil else if Sep<>#0 then inc(P); end; function GetNextItemInt64(var P: PUTF8Char; Sep: AnsiChar): Int64; {$ifdef CPU64} begin result := GetNextItemInteger(P,Sep); // PtrInt=Int64 end; {$else} var tmp: TChar64; begin if GetNextTChar64(P,Sep,tmp)>0 then SetInt64(tmp,result) else result := 0; end; {$endif} function GetNextItemQWord(var P: PUTF8Char; Sep: AnsiChar): QWord; {$ifdef CPU64} begin result := GetNextItemCardinal(P,Sep); // PtrUInt=QWord end; {$else} var tmp: TChar64; begin if GetNextTChar64(P,Sep,tmp)>0 then SetQWord(tmp,result) else result := 0; end; {$endif} function GetNextItemHexa(var P: PUTF8Char; Sep: AnsiChar): QWord; var tmp: TChar64; L: integer; begin result := 0; L := GetNextTChar64(P,Sep,tmp); if (L>0) and (L and 1=0) then if not HexDisplayToBin(@tmp,@result,L shr 1) then result := 0; end; function GetNextItemDouble(var P: PUTF8Char; Sep: AnsiChar): double; var tmp: TChar64; err: integer; begin if GetNextTChar64(P,Sep,tmp)>0 then begin result := GetExtended(tmp,err); if err<>0 then result := 0; end else result := 0; end; function GetNextItemCurrency(var P: PUTF8Char; Sep: AnsiChar): currency; begin GetNextItemCurrency(P,result,Sep); end; procedure GetNextItemCurrency(var P: PUTF8Char; out result: currency; Sep: AnsiChar); var tmp: TChar64; begin if GetNextTChar64(P,Sep,tmp)>0 then PInt64(@result)^ := StrToCurr64(tmp) else result := 0; end; function GetCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar): RawUTF8; var i: PtrUInt; begin if P=nil then result := '' else for i := 0 to Index do GetNextItem(P,Sep,result); end; function GetUnQuoteCSVItem(P: PUTF8Char; Index: PtrUInt; Sep, Quote: AnsiChar): RawUTF8; var i: PtrUInt; begin if P=nil then result := '' else for i := 0 to Index do GetNextItem(P,Sep,Quote,result); end; function GetLastCSVItem(const CSV: RawUTF8; Sep: AnsiChar): RawUTF8; var i: integer; begin for i := length(CSV) downto 1 do if CSV[i]=Sep then begin result := copy(CSV,i+1,maxInt); exit; end; result := CSV; end; function GetCSVItemString(P: PChar; Index: PtrUInt; Sep: Char): string; var i: PtrUInt; begin if P=nil then result := '' else for i := 0 to Index do result := GetNextItemString(P,Sep); end; function FindCSVIndex(CSV: PUTF8Char; const Value: RawUTF8; Sep: AnsiChar; CaseSensitive,TrimValue: boolean): integer; var s: RawUTF8; begin result := 0; while CSV<>nil do begin GetNextItem(CSV,Sep,s); if TrimValue then s := trim(s); if CaseSensitive then begin if s=Value then exit; end else if SameTextU(s,Value) then exit; inc(result); end; result := -1; // not found end; procedure CSVToRawUTF8DynArray(CSV: PUTF8Char; var Result: TRawUTF8DynArray; Sep: AnsiChar; TrimItems, AddVoidItems: boolean); var s: RawUTF8; n: integer; begin n := length(Result); while CSV<>nil do begin if TrimItems then GetNextItemTrimed(CSV,Sep,s) else GetNextItem(CSV,Sep,s); if (s<>'') or AddVoidItems then AddRawUTF8(Result,n,s); end; if n<>length(Result) then SetLength(Result,n); end; procedure CSVToRawUTF8DynArray(const CSV,Sep,SepEnd: RawUTF8; var Result: TRawUTF8DynArray); var offs,i: integer; begin offs := 1; while offsnil do begin GetNextItem(CSV,Sep,s); if s<>'' then result := result+','+Prefix+s; end; end; procedure AddToCSV(const Value: RawUTF8; var CSV: RawUTF8; const Sep: RawUTF8); begin if CSV='' then CSV := Value else CSV := CSV+Sep+Value; end; function RenameInCSV(const OldValue, NewValue: RawUTF8; var CSV: RawUTF8; const Sep: RawUTF8): boolean; var pattern: RawUTF8; i,j: integer; begin result := OldValue=NewValue; i := length(OldValue); if result or (length(Sep)<>1) or (length(CSV)0) or (PosEx(Sep,NewValue)>0) then exit; if CompareMem(pointer(OldValue),pointer(CSV),i) and // first (or unique) item ((CSV[i+1]=Sep[1]) or (CSV[i+1]=#0)) then i := 1 else begin j := 1; pattern := Sep+OldValue; repeat i := PosEx(pattern,CSV,j); if i=0 then exit; j := i+length(pattern); until (CSV[j]=Sep[1]) or (CSV[j]=#0); inc(i); end; delete(CSV,i,length(OldValue)); insert(NewValue,CSV,i); result := true; end; function RawUTF8ArrayToCSV(const Values: array of RawUTF8; const Sep: RawUTF8): RawUTF8; var i, len, seplen, L: Integer; P: PAnsiChar; begin result := ''; if high(Values)<0 then exit; seplen := length(Sep); len := seplen*high(Values); for i := 0 to high(Values) do inc(len,length(Values[i])); SetLength(result,len); P := pointer(result); i := 0; repeat L := length(Values[i]); if L>0 then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(Values[i])^,P^,L); inc(P,L); end; if i=high(Values) then Break; if seplen>0 then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(Sep)^,P^,seplen); inc(P,seplen); end; inc(i); until false; end; function RawUTF8ArrayToQuotedCSV(const Values: array of RawUTF8; const Sep: RawUTF8; Quote: AnsiChar): RawUTF8; var i: integer; tmp: TRawUTF8DynArray; begin SetLength(tmp,length(Values)); for i := 0 to High(Values) do tmp[i] := QuotedStr(Values[i],Quote); result := RawUTF8ArrayToCSV(tmp,Sep); end; function TRawUTF8DynArrayFrom(const Values: array of RawUTF8): TRawUTF8DynArray; var i: integer; begin SetLength(result,length(Values)); for i := 0 to high(Values) do result[i] := Values[i]; end; procedure AddArrayOfConst(var Dest: TTVarRecDynArray; const Values: array of const); var i,n: Integer; begin n := length(Dest); SetLength(Dest,n+length(Values)); for i := 0 to high(Values) do Dest[i+n] := Values[i]; end; var DefaultTextWriterJSONClass: TTextWriterClass = TTextWriter; DefaultTextWriterTrimEnum: boolean; function ObjectToJSON(Value: TObject; Options: TTextWriterWriteObjectOptions): RawUTF8; var temp: TTextWriterStackBuffer; begin if Value=nil then result := NULL_STR_VAR else with DefaultTextWriterJSONClass.CreateOwnedStream(temp) do try include(fCustomOptions,twoForceJSONStandard); WriteObject(Value,Options); SetText(result); finally Free; end; end; function ObjectsToJSON(const Names: array of RawUTF8; const Values: array of TObject; Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8; var i,n: integer; temp: TTextWriterStackBuffer; begin with DefaultTextWriterJSONClass.CreateOwnedStream(temp) do try n := length(Names); Add('{'); for i := 0 to high(Values) do if Values[i]<>nil then begin if inil then repeat case s^ of #0: exit; '0'..'9','a'..'z','A'..'Z','_','-','.','~',' ': begin inc(result); inc(s); continue; end; else inc(result,3); end; inc(s); until false; end; begin result := ''; if Text=nil then exit; SetLength(result,Size(Text)); // reserve exact memory count Enc(Text,pointer(result)); end; function UrlEncode(const NameValuePairs: array of const): RawUTF8; // (['select','*','where','ID=12','offset',23,'object',aObject]); var A, n: PtrInt; name, value: RawUTF8; begin result := ''; n := high(NameValuePairs); if n>0 then begin for A := 0 to n shr 1 do begin VarRecToUTF8(NameValuePairs[A*2],name); if not IsUrlValid(pointer(name)) then continue; // just skip invalid names with NameValuePairs[A*2+1] do if VType=vtObject then value := ObjectToJSON(VObject,[]) else VarRecToUTF8(NameValuePairs[A*2+1],value); result := result+'&'+name+'='+UrlEncode(value); end; result[1] := '?'; end; end; function IsUrlValid(P: PUTF8Char): boolean; begin result := false; if P<>nil then begin repeat // cf. rfc3986 2.3. Unreserved Characters if ord(P^) in IsURIUnreserved then inc(P) else exit; until P^=#0; result := true; end; end; function AreUrlValid(const Url: array of RawUTF8): boolean; var i: integer; begin result := false; for i := 0 to high(Url) do if not IsUrlValid(pointer(Url[i])) then exit; result := true; end; function IncludeTrailingURIDelimiter(const URI: RawByteString): RawByteString; begin if (URI<>'') and (URI[length(URI)]<>'/') then result := URI+'/' else result := URI; end; function UrlEncodeJsonObject(const URIName: RawUTF8; ParametersJSON: PUTF8Char; const PropNamesToIgnore: array of RawUTF8): RawUTF8; var i,j: integer; sep: AnsiChar; Params: TNameValuePUTF8CharDynArray; temp: TTextWriterStackBuffer; begin if ParametersJSON=nil then result := URIName else with TTextWriter.CreateOwnedStream(temp) do try AddString(URIName); if (JSONDecode(ParametersJSON,Params,true)<>nil) and (Params<>nil) then begin sep := '?'; for i := 0 to High(Params) do with Params[i] do begin for j := 0 to high(PropNamesToIgnore) do if IdemPropNameU(PropNamesToIgnore[j],Name,NameLen) then begin NameLen := 0; break; end; if NameLen=0 then continue; Add(sep); AddNoJSONEscape(Name,NameLen); Add('='); AddString(UrlEncode(Value)); sep := '&'; end; end; SetText(result); finally Free; end; end; function UrlDecode(const s: RawUTF8; i: PtrInt = 1; len: PtrInt = -1): RawUTF8; var L: PtrInt; P: PUTF8Char; begin result := ''; if s='' then exit; L := PStrRec(Pointer(PtrInt(s)-STRRECSIZE))^.length; if len<0 then len := L; if i>L then exit; dec(i); if len=i then exit; Setlength(result,len-i); // reserve enough space for result P := pointer(result); while iSizeOf(tmp) then begin SetLength(result,L); Dest := pointer(result); end else Dest := @tmp; P := Dest; repeat case U^ of #0: break; // reached end of URI '%': if not HexToChar(PAnsiChar(U+1),P) then P^ := U^ else inc(U,2); // browsers may not follow the RFC (e.g. encode % as % !) '+': P^ := ' '; else P^ := U^; end; // case s[i] of inc(U); inc(P); until false; if Dest=@tmp then FastSetString(result,@tmp,P-Dest) else SetLength(result,P-Dest); end; function UrlDecodeNextValue(U: PUTF8Char; out Value: RawUTF8): PUTF8Char; var Beg,V: PUTF8Char; len, i: PtrInt; begin if U<>nil then begin // compute resulting length of value Beg := U; len := 0; while (U^<>#0) and (U^<>'&') do begin if (U^='%') and HexToCharValid(PAnsiChar(U+1)) then inc(U,3) else inc(U); inc(len); end; // decode value content SetLength(Value,len); V := pointer(Value); U := Beg; for i := 1 to len do if (U^='%') and HexToChar(PAnsiChar(U+1),V) then begin inc(V); inc(U,3); end else begin if U^='+' then V^ := ' ' else V^ := U^; inc(V); inc(U); end; end; result := U; end; function UrlDecodeNextName(U: PUTF8Char; out Name: RawUTF8): PUTF8Char; var Beg, V: PUTF8Char; len, i: PtrInt; begin result := nil; if U=nil then exit; // compute resulting length of name Beg := U; len := 0; repeat case U^ of #0: exit; '=': begin result := U+1; break; end; '%': if (U[1]='3') and (U[2] in ['D','d']) then begin result := U+3; break; // %3d means = according to the RFC end else if HexToCharValid(PAnsiChar(U+1)) then inc(U,3) else inc(U); else inc(U); end; inc(len); until false; // decode name content SetLength(Name,len); V := pointer(Name); U := Beg; for i := 1 to len do if (U^='%') and HexToChar(PAnsiChar(U+1),V) then begin inc(V); inc(U,3); end else begin if U^='+' then V^ := ' ' else V^ := U^; inc(V); inc(U); end; end; function UrlDecodeNextNameValue(U: PUTF8Char; var Name,Value: RawUTF8): PUTF8Char; begin result := nil; if U=nil then exit; U := UrlDecodeNextName(U,Name); if U=nil then exit; U := UrlDecodeNextValue(U,Value); if U^=#0 then result := U else result := U+1; // jump '&' to let decode the next name=value pair end; function UrlDecodeValue(U: PUTF8Char; const Upper: RawUTF8; var Value: RawUTF8; Next: PPUTF8Char): boolean; begin // UrlDecodeValue('select=%2A&where=LastName%3D%27M%C3%B4net%27','SELECT=',V,@U) // -> U^='where=...' and V='*' result := false; // mark value not modified by default if U=nil then begin if Next<>nil then Next^ := U; exit; end; if IdemPChar(U,pointer(Upper)) then begin result := true; inc(U,length(Upper)); U := UrlDecodeNextValue(U,Value); end; if Next=nil then exit; while not(U^ in [#0,'&']) do inc(U); if U^=#0 then Next^ := nil else Next^ := U+1; // jump '&' end; function UrlDecodeInteger(U: PUTF8Char; const Upper: RawUTF8; var Value: integer; Next: PPUTF8Char): boolean; var V: PtrInt; SignNeg: boolean; begin // UrlDecodeInteger('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) // -> Next^='where=...' and O=20 result := false; // mark value not modified by default if U=nil then begin if Next<>nil then Next^ := U; exit; end; if IdemPChar(U,pointer(Upper)) then begin inc(U,length(Upper)); if U^='-' then begin SignNeg := True; Inc(U); end else SignNeg := false; if U^ in ['0'..'9'] then begin V := 0; repeat V := (V*10)+ord(U^)-48; inc(U); until not (U^ in ['0'..'9']); if SignNeg then Value := -V else Value := V; result := true; end; end; if Next=nil then exit; while not(U^ in [#0,'&']) do inc(U); if U^=#0 then Next^ := nil else Next^ := U+1; // jump '&' end; function UrlDecodeCardinal(U: PUTF8Char; const Upper: RawUTF8; var Value: Cardinal; Next: PPUTF8Char): boolean; var V: PtrInt; begin // UrlDecodeInteger('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) // -> Next^='where=...' and O=20 result := false; // mark value not modified by default if U=nil then begin if Next<>nil then Next^ := U; exit; end; if IdemPChar(U,pointer(Upper)) then begin inc(U,length(Upper)); if U^ in ['0'..'9'] then begin V := 0; repeat V := (V*10)+ord(U^)-48; inc(U); until not (U^ in ['0'..'9']); Value := V; result := true; end; end; if Next=nil then exit; while not(U^ in [#0,'&']) do inc(U); if U^=#0 then Next^ := nil else Next^ := U+1; // jump '&' end; function UrlDecodeInt64(U: PUTF8Char; const Upper: RawUTF8; var Value: Int64; Next: PPUTF8Char): boolean; var tmp: RawUTF8; begin result := UrlDecodeValue(U,Upper,tmp,Next); if result then SetInt64(pointer(tmp),Value); end; function UrlDecodeExtended(U: PUTF8Char; const Upper: RawUTF8; var Value: TSynExtended; Next: PPUTF8Char=nil): boolean; var tmp: RawUTF8; err: integer; begin result := UrlDecodeValue(U,Upper,tmp,Next); if result then begin Value := GetExtended(pointer(tmp),err); if err<>0 then result := false; end; end; function UrlDecodeDouble(U: PUTF8Char; const Upper: RawUTF8; var Value: double; Next: PPUTF8Char=nil): boolean; var tmp: RawUTF8; err: integer; begin result := UrlDecodeValue(U,Upper,tmp,Next); if result then begin Value := GetExtended(pointer(tmp),err); if err<>0 then result := false; end; end; function UrlDecodeNeedParameters(U, CSVNames: PUTF8Char): boolean; var tmp: array[byte] of AnsiChar; L: integer; Beg: PUTF8Char; // UrlDecodeNeedParameters('price=20.45&where=LastName%3D','price,where') will // return TRUE begin result := (CSVNames=nil); if result then exit; // no parameter to check -> success if U=nil then exit; // no input data -> error repeat L := 0; while (CSVNames^<>#0) and (CSVNames^<>',') do begin tmp[L] := NormToUpper[CSVNames^]; if L=high(tmp) then exit else // invalid CSV parameter inc(L); inc(CSVNames); end; if L=0 then exit; // invalid CSV parameter PWord(@tmp[L])^ := ord('='); Beg := U; repeat if IdemPChar(U,tmp) then break; while not(U^ in [#0,'&']) do inc(U); if U^=#0 then exit else // didn't find tmp in U inc(U); // Jump & until false; U := Beg; if CSVNames^=#0 then Break else // no more parameter to check inc(CSVNames); // jump & until false; result := true; // all parameters found end; function CSVEncode(const NameValuePairs: array of const; const KeySeparator, ValueSeparator: RawUTF8): RawUTF8; var i: integer; temp: TTextWriterStackBuffer; begin if length(NameValuePairs)<2 then result := '' else with DefaultTextWriterJSONClass.CreateOwnedStream(temp) do try for i := 1 to length(NameValuePairs) shr 1 do begin Add(NameValuePairs[i*2-2],twNone); AddNoJSONEscape(pointer(KeySeparator),length(KeySeparator)); Add(NameValuePairs[i*2-1],twNone); AddNoJSONEscape(pointer(ValueSeparator),length(ValueSeparator)); end; SetText(result); finally Free; end; end; function ArrayOfConstValueAsText(const NameValuePairs: array of const; const aName: RawUTF8): RawUTF8; var i: integer; name: RawUTF8; begin for i := 1 to length(NameValuePairs) shr 1 do if VarRecToUTF8IsString(NameValuePairs[i*2-2],name) and IdemPropNameU(name,aName) then begin VarRecToUTF8(NameValuePairs[i*2-1],result); exit; end; result := ''; end; function IsZero(P: pointer; Length: integer): boolean; var i: integer; begin result := false; for i := 1 to Length shr 4 do // 16 bytes (4 DWORD) by loop - aligned read {$ifdef CPU64} if (PInt64Array(P)^[0]<>0) or (PInt64Array(P)^[1]<>0) then {$else} if (PCardinalArray(P)^[0]<>0) or (PCardinalArray(P)^[1]<>0) or (PCardinalArray(P)^[2]<>0) or (PCardinalArray(P)^[3]<>0) then {$endif} exit else inc(PByte(P),16); for i := 1 to (Length shr 2)and 3 do // 4 bytes (1 DWORD) by loop if PCardinal(P)^<>0 then exit else inc(PByte(P),4); for i := 1 to Length and 3 do // remaining content if PByte(P)^<>0 then exit else inc(PByte(P)); result := true; end; function IsZero(const Values: TRawUTF8DynArray): boolean; var i: integer; begin result := false; for i := 0 to length(Values)-1 do if Values[i]<>'' then exit; result := true; end; function IsZero(const Values: TIntegerDynArray): boolean; var i: integer; begin result := false; for i := 0 to length(Values)-1 do if Values[i]<>0 then exit; result := true; end; function IsZero(const Values: TInt64DynArray): boolean; var i: integer; begin result := false; for i := 0 to length(Values)-1 do if Values[i]<>0 then exit; result := true; end; procedure FillZero(var Values: TRawUTF8DynArray); var i: integer; begin for i := 0 to length(Values)-1 do {$ifdef FPC}Finalize(Values[i]){$else}Values[i] := ''{$endif}; end; procedure FillZero(var Values: TIntegerDynArray); begin {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(Values[0],length(Values)*SizeOf(integer),0); end; procedure FillZero(var Values: TInt64DynArray); begin {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(Values[0],length(Values)*SizeOf(Int64),0); end; function crc16(Data: PAnsiChar; Len: integer): cardinal; var i, j: Integer; begin result := $ffff; for i := 0 to Len-1 do begin result := result xor (ord(Data[i]) shl 8); for j := 1 to 8 do if result and $8000<>0 then result := (result shl 1) xor $1021 else result := result shl 1; end; result := result and $ffff; end; function Hash32(const Text: RawByteString): cardinal; begin result := Hash32(pointer(Text),length(Text)); end; function Hash32(Data: PCardinalArray; Len: integer): cardinal; var s1,s2: cardinal; i: integer; begin if Data<>nil then begin s1 := 0; s2 := 0; for i := 1 to Len shr 4 do begin // 16 bytes (128-bit) loop - aligned read inc(s1,Data[0]); inc(s2,s1); inc(s1,Data[1]); inc(s2,s1); inc(s1,Data[2]); inc(s2,s1); inc(s1,Data[3]); inc(s2,s1); Data := @Data[4]; end; for i := 1 to (Len shr 2)and 3 do begin // 4 bytes (DWORD) by loop inc(s1,Data[0]); inc(s2,s1); Data := @Data[1]; end; case Len and 3 of // remaining 0..3 bytes 1: inc(s1,PByte(Data)^); 2: inc(s1,PWord(Data)^); 3: inc(s1,PWord(Data)^ or (PByteArray(Data)^[2] shl 16)); end; inc(s2,s1); result := s1 xor (s2 shl 16); end else result := 0; end; procedure OrMemory(Dest,Source: PByteArray; size: PtrInt); begin while size>=SizeOf(PtrInt) do begin dec(size,SizeOf(PtrInt)); PPtrInt(Dest)^ := PPtrInt(Dest)^ or PPtrInt(Source)^; inc(PPtrInt(Dest)); inc(PPtrInt(Source)); end; while size>0 do begin dec(size); Dest[size] := Dest[size] or Source[size]; end; end; procedure XorMemory(Dest,Source: PByteArray; size: PtrInt); begin while size>=SizeOf(PtrInt) do begin dec(size,SizeOf(PtrInt)); PPtrInt(Dest)^ := PPtrInt(Dest)^ xor PPtrInt(Source)^; inc(PPtrInt(Dest)); inc(PPtrInt(Source)); end; while size>0 do begin dec(size); Dest[size] := Dest[size] xor Source[size]; end; end; procedure XorMemory(Dest,Source1,Source2: PByteArray; size: PtrInt); begin while size>=SizeOf(PtrInt) do begin dec(size,SizeOf(PtrInt)); PPtrInt(Dest)^ := PPtrInt(Source1)^ xor PPtrInt(Source2)^; inc(PPtrInt(Dest)); inc(PPtrInt(Source1)); inc(PPtrInt(Source2)); end; while size>0 do begin dec(size); Dest[size] := Source1[size] xor Source2[size]; end; end; procedure AndMemory(Dest,Source: PByteArray; size: PtrInt); begin while size>=SizeOf(PtrInt) do begin dec(size,SizeOf(PtrInt)); PPtrInt(Dest)^ := PPtrInt(Dest)^ and PPtrInt(Source)^; inc(PPtrInt(Dest)); inc(PPtrInt(Source)); end; while size>0 do begin dec(size); Dest[size] := Dest[size] and Source[size]; end; end; {$ifdef CPUINTEL} // use optimized x86/x64 asm versions for xxHash32 {$ifdef CPUX86} function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; {$ifdef FPC}nostackframe; assembler;{$endif} asm xchg edx, ecx push ebp push edi lea ebp, [ecx+edx] push esi push ebx sub esp, 8 mov ebx, eax mov dword ptr [esp], edx lea eax, [ebx+165667B1H] cmp edx, 15 jbe @2 lea eax, [ebp-10H] lea edi, [ebx+24234428H] lea esi, [ebx-7A143589H] mov dword ptr [esp+4H], ebp mov edx, eax lea eax, [ebx+61C8864FH] mov ebp, edx @1: mov edx, dword ptr [ecx] imul edx, -2048144777 add edi, edx rol edi, 13 imul edi, -1640531535 mov edx, dword ptr [ecx+4] imul edx, -2048144777 add esi, edx rol esi, 13 imul esi, -1640531535 mov edx, dword ptr [ecx+8] imul edx, -2048144777 add ebx, edx rol ebx, 13 imul ebx, -1640531535 mov edx, dword ptr [ecx+12] lea ecx, [ecx+16] imul edx, -2048144777 add eax, edx rol eax, 13 imul eax, -1640531535 cmp ebp, ecx jnc @1 rol edi, 1 rol esi, 7 rol ebx, 12 add esi, edi mov ebp, dword ptr [esp+4H] ror eax, 14 add ebx, esi add eax, ebx @2: lea esi, [ecx+4H] add eax, dword ptr [esp] cmp ebp, esi jc @4 mov ebx, esi nop @3: imul edx, dword ptr [ebx-4H], -1028477379 add ebx, 4 add eax, edx ror eax, 15 imul eax, 668265263 cmp ebp, ebx jnc @3 lea edx, [ebp-4H] sub edx, ecx mov ecx, edx and ecx, 0FFFFFFFCH add ecx, esi @4: cmp ebp, ecx jbe @6 @5: movzx edx, byte ptr [ecx] add ecx, 1 imul edx, 374761393 add eax, edx rol eax, 11 imul eax, -1640531535 cmp ebp, ecx jnz @5 nop @6: mov edx, eax add esp, 8 shr edx, 15 xor eax, edx imul eax, -2048144777 pop ebx pop esi mov edx, eax shr edx, 13 xor eax, edx imul eax, -1028477379 pop edi pop ebp mov edx, eax shr edx, 16 xor eax, edx end; {$endif CPUX86} {$ifdef CPUX64} function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; {$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe{$endif} {$ifdef LINUX} // crc=rdi P=rsi len=rdx mov r8, rdi mov rcx, rsi {$else} // crc=r8 P=rcx len=rdx mov r10, r8 mov r8, rcx mov rcx, rdx mov rdx, r10 push rsi // Win64 expects those registers to be preserved push rdi {$endif} // P=r8 len=rcx crc=rdx push r12 push rbx mov r12d, -1640531535 lea r10, [rcx+rdx] lea eax, [r8+165667B1H] cmp rdx, 15 jbe @2 lea rsi, [r10-10H] lea ebx, [r8+24234428H] lea edi, [r8-7A143589H] lea eax, [r8+61C8864FH] @1: imul r9d, dword ptr [rcx], -2048144777 add rcx, 16 imul r11d, dword ptr [rcx-0CH], -2048144777 add ebx, r9d lea r9d, [r11+rdi] rol ebx, 13 rol r9d, 13 imul ebx, r12d imul edi, r9d, -1640531535 imul r9d, dword ptr [rcx-8H], -2048144777 add r8d, r9d imul r9d, dword ptr [rcx-4H], -2048144777 rol r8d, 13 imul r8d, r12d add eax, r9d rol eax, 13 imul eax, r12d cmp rsi, rcx jnc @1 rol edi, 7 rol ebx, 1 rol r8d, 12 mov r9d, edi ror eax, 14 add r9d, ebx add r8d, r9d add eax, r8d @2: lea r9, [rcx+4H] add eax, edx cmp r10, r9 jc @4 mov r8, r9 @3: imul edx, dword ptr [r8-4H], -1028477379 add r8, 4 add eax, edx ror eax, 15 imul eax, 668265263 cmp r10, r8 jnc @3 lea rdx, [r10-4H] sub rdx, rcx mov rcx, rdx and rcx, 0FFFFFFFFFFFFFFFCH add rcx, r9 @4: cmp r10, rcx jbe @6 @5: movzx edx, byte ptr [rcx] add rcx, 1 imul edx, 374761393 add eax, edx rol eax, 11 imul eax, r12d cmp r10, rcx jnz @5 @6: mov edx, eax shr edx, 15 xor eax, edx imul eax, -2048144777 mov edx, eax shr edx, 13 xor eax, edx imul eax, -1028477379 mov edx, eax shr edx, 16 xor eax, edx pop rbx pop r12 {$ifndef LINUX} pop rdi pop rsi {$endif} end; {$endif CPUX64} {$else not CPUINTEL} const PRIME32_1 = 2654435761; PRIME32_2 = 2246822519; PRIME32_3 = 3266489917; PRIME32_4 = 668265263; PRIME32_5 = 374761393; {$ifdef FPC} // RolDWord is an intrinsic function under FPC :) function Rol13(value: cardinal): cardinal; inline; begin result := RolDWord(value, 13); end; {$else} {$ifdef HASINLINENOTX86} function RolDWord(value: cardinal; count: integer): cardinal; inline; begin result := (value shl count) or (value shr (32-count)); end; function Rol13(value: cardinal): cardinal; inline; begin result := (value shl 13) or (value shr 19); end; {$else} function RolDWord(value: cardinal; count: integer): cardinal; asm mov cl, dl rol eax, cl end; function Rol13(value: cardinal): cardinal; asm rol eax, 13 end; {$endif HASINLINENOTX86} {$endif FPC} function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; var c1, c2, c3, c4: cardinal; PLimit, PEnd: PAnsiChar; begin PEnd := P + len; if len >= 16 then begin PLimit := PEnd - 16; c3 := crc; c2 := c3 + PRIME32_2; c1 := c2 + PRIME32_1; c4 := c3 - PRIME32_1; repeat c1 := PRIME32_1 * Rol13(c1 + PRIME32_2 * PCardinal(P)^); c2 := PRIME32_1 * Rol13(c2 + PRIME32_2 * PCardinal(P+4)^); c3 := PRIME32_1 * Rol13(c3 + PRIME32_2 * PCardinal(P+8)^); c4 := PRIME32_1 * Rol13(c4 + PRIME32_2 * PCardinal(P+12)^); inc(P, 16); until not (P <= PLimit); result := RolDWord(c1, 1) + RolDWord(c2, 7) + RolDWord(c3, 12) + RolDWord(c4, 18); end else result := crc + PRIME32_5; inc(result, len); while P + 4 <= PEnd do begin inc(result, PCardinal(P)^ * PRIME32_3); result := RolDWord(result, 17) * PRIME32_4; inc(P, 4); end; while P < PEnd do begin inc(result, PByte(P)^ * PRIME32_5); result := RolDWord(result, 11) * PRIME32_1; inc(P); end; result := result xor (result shr 15); result := result * PRIME32_2; result := result xor (result shr 13); result := result * PRIME32_3; result := result xor (result shr 16); end; {$endif CPUINTEL} type TRegisters = record eax,ebx,ecx,edx: cardinal; end; {$ifdef CPUINTEL} {$ifdef CPU64} procedure GetCPUID(Param: Cardinal; var Registers: TRegisters); {$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe // ecx=param, rdx=Registers (Linux: edi,rsi) {$endif FPC} {$ifdef win64} mov eax, ecx mov r9, rdx {$else} mov eax, edi mov r9, rsi {$endif win64} mov r10, rbx // preserve rbx xor ebx, ebx xor ecx, ecx xor edx, edx cpuid mov TRegisters(r9).&eax, eax mov TRegisters(r9).&ebx, ebx mov TRegisters(r9).&ecx, ecx mov TRegisters(r9).&edx, edx mov rbx, r10 end; const CMP_RANGES = $44; // see https://msdn.microsoft.com/en-us/library/bb531425 _UpperCopy255BufSSE42: array[0..31] of AnsiChar = 'azazazazazazazaz '; function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; {$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe // rcx=dest, rdx=source, r8=len (Linux: rdi,rsi,rdx) {$endif FPC} {$ifdef win64} mov rax, rcx mov r9, rdx mov rdx, r8 {$else} mov rax, rdi mov r9, rsi {$endif} lea rcx, [rip + _UpperCopy255BufSSE42] test rdx, rdx jz @z movdqu xmm1, dqword ptr [rcx] movdqu xmm3, dqword ptr [rcx + 16] cmp rdx, 16 ja @big // optimize the common case of sourceLen<=16 movdqu xmm2, [r9] {$ifdef HASAESNI} pcmpistrm xmm1, xmm2, CMP_RANGES // find in range a-z, return mask in xmm0 {$else} db $66, $0F, $3A, $62, $CA, CMP_RANGES {$endif} pand xmm0, xmm3 pxor xmm2, xmm0 movdqu [rax], xmm2 add rax, rdx @z: ret @big: mov rcx, rax cmp rdx, 240 jb @ok mov rdx, 239 @ok: add rax, rdx // return end position with the exact size shr rdx, 4 sub r9, rcx add rdx, 1 {$ifdef FPC}align 8{$endif} @s: movdqu xmm2, [r9 + rcx] {$ifdef HASAESNI} pcmpistrm xmm1, xmm2, CMP_RANGES {$else} db $66, $0F, $3A, $62, $CA, CMP_RANGES {$endif} pand xmm0, xmm3 pxor xmm2, xmm0 movdqu [rcx], xmm2 add rcx, 16 dec rdx jnz @s end; function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; {$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe // ecx=crc, rdx=buf, r8=len (Linux: edi,rsi,rdx) {$endif FPC} {$ifdef win64} mov eax, ecx {$else} mov eax, edi mov r8, rdx mov rdx, rsi {$endif win64} not eax test rdx, rdx jz @0 test r8, r8 jz @0 test dl, 7 jz @8 // align to 8 bytes boundary {$ifdef FPC}align 8{$endif} @7: crc32 eax, byte ptr[rdx] inc rdx dec r8 jz @0 test dl, 7 jnz @7 @8: mov rcx, r8 shr r8, 3 jz @2 {$ifdef FPC}align 8{$endif} @1: {$ifdef FPC} crc32 rax, qword [rdx] // hash 8 bytes per loop {$else} db $F2,$48,$0F,$38,$F1,$02 // circumvent Delphi inline asm compiler bug {$endif} add rdx, 8 dec r8 jnz @1 @2: and ecx, 7 jz @0 cmp ecx, 4 jb @4 crc32 eax, dword ptr[rdx] add rdx, 4 sub ecx, 4 jz @0 @4: crc32 eax, byte ptr[rdx] dec ecx jz @0 crc32 eax, byte ptr[rdx + 1] dec ecx jz @0 crc32 eax, byte ptr[rdx + 2] @0: not eax end; function StrLenSSE2(S: pointer): PtrInt; {$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe // rcx=S (Linux: rdi) {$endif FPC} // from GPL strlen64.asm by Agner Fog - www.agner.org/optimize {$ifdef win64} mov rax, rcx // get pointer to string from rcx mov r8, rcx // copy pointer test rcx, rcx {$else} mov rax, rdi mov ecx, edi test rdi, rdi {$endif} jz @null // returns 0 if S=nil // rax=s,ecx=32-bit of s pxor xmm0, xmm0 // set to zero and ecx, 15 // lower 4 bits indicate misalignment and rax, -16 // align pointer by 16 // will never read outside a memory page boundary, so won't trigger GPF movdqa xmm1, [rax] // read from nearest preceding boundary pcmpeqb xmm1, xmm0 // compare 16 bytes with zero pmovmskb edx, xmm1 // get one bit for each byte result shr edx, cl // shift out false bits shl edx, cl // shift back again bsf edx, edx // find first 1-bit jnz @L2 // found // Main loop, search 16 bytes at a time {$ifdef FPC}align 8{$endif} @L1: add rax, 10H // increment pointer by 16 movdqa xmm1, [rax] // read 16 bytes aligned pcmpeqb xmm1, xmm0 // compare 16 bytes with zero pmovmskb edx, xmm1 // get one bit for each byte result bsf edx, edx // find first 1-bit // (moving the bsf out of the loop and using test here would be faster // for long strings on old processors, but we are assuming that most // strings are short, and newer processors have higher priority) jz @L1 // loop if not found @L2: // Zero-byte found. Compute string length {$ifdef win64} sub rax, r8 // subtract start address {$else} sub rax, rdi {$endif} add rax, rdx // add byte index @null: end; const EQUAL_EACH = 8; // see https://msdn.microsoft.com/en-us/library/bb531463 NEGATIVE_POLARITY = 16; {$ifdef HASAESNI} function StrLenSSE42(S: pointer): PtrInt; {$ifdef FPC}nostackframe; assembler; asm {$else} asm // rcx=S (Linux: rdi) .noframe {$endif FPC} xor rax, rax {$ifdef win64} mov rdx, rcx test rcx, rcx {$else} mov rdx, rdi test rdi, rdi {$endif} jz @null xor rcx, rcx pxor xmm0, xmm0 pcmpistri xmm0, [rdx], EQUAL_EACH // result in ecx jnz @L mov eax, ecx @null: ret {$ifdef FPC}align 8{$endif} @L: add rax, 16 // add before comparison flag pcmpistri xmm0, [rdx + rax], EQUAL_EACH // result in ecx jnz @L add rax, rcx end; function StrCompSSE42(Str1, Str2: pointer): PtrInt; {$ifdef FPC}nostackframe; assembler; asm {$else} asm // rcx=Str1, rdx=Str2 (Linux: rdi,rsi) .noframe {$endif FPC} {$ifdef win64} mov rax, rcx test rcx, rdx {$else} mov rax, rdi mov rdx, rsi test rdi, rsi // is one of Str1/Str2 nil ? {$endif} jz @n @ok: sub rax, rdx xor rcx, rcx movdqu xmm0, dqword [rdx] pcmpistri xmm0, dqword [rdx + rax], EQUAL_EACH + NEGATIVE_POLARITY // result in rcx ja @1 jc @2 xor rax, rax ret {$ifdef FPC}align 8{$endif} @1: add rdx, 16 movdqu xmm0, dqword [rdx] pcmpistri xmm0, dqword [rdx + rax], EQUAL_EACH + NEGATIVE_POLARITY ja @1 jc @2 @0: xor rax, rax // Str1=Str2 ret @n: cmp rax, rdx je @0 test rax, rax // Str1='' ? jz @max test rdx, rdx // Str2='' ? jnz @ok mov rax, 1 ret @max: dec rax // returns -1 ret @2: add rax, rdx movzx rax, byte ptr [rax + rcx] movzx rdx, byte ptr [rdx + rcx] sub rax, rdx end; {$endif HASAESNI} {$endif CPU64} {$endif CPUINTEL} procedure crcblocks(crc128, data128: PBlock128; count: integer); var oneblock: procedure(crc128, data128: PBlock128); i: integer; begin if count>0 then {$ifndef DISABLE_SSE42} {$ifdef CPUX86} if cfSSE42 in CpuFeatures then asm mov ecx, crc128 mov edx, data128 @s: mov eax, dword ptr[ecx] db $F2, $0F, $38, $F1, $02 // crc32 eax, dword ptr [edx] mov dword ptr[ecx], eax mov eax, dword ptr[ecx + 4] db $F2, $0F, $38, $F1, $42, $04 // crc32 eax, dword ptr [edx+4] mov dword ptr[ecx + 4], eax mov eax, dword ptr[ecx + 8] db $F2, $0F, $38, $F1, $42, $08 // crc32 eax, dword ptr [edx+8] mov dword ptr[ecx + 8], eax mov eax, dword ptr[ecx + 12] db $F2, $0F, $38, $F1, $42, $0C // crc32 eax, dword ptr [edx+12] mov dword ptr[ecx + 12], eax add edx, 16 dec count jnz @s end else {$endif CPUX86} {$ifdef CPUX64} {$ifdef FPC} // only FPC is able to compile such inlined asm block if cfSSE42 in CpuFeatures then asm mov rax, data128 mov rdx, crc128 mov ecx, count mov r8d, dword ptr [rdx] mov r9d, dword ptr [rdx + 4] mov r10d, dword ptr [rdx + 8] mov r11d, dword ptr [rdx + 12] align 8 @s: crc32 r8d, dword ptr [rax] crc32 r9d, dword ptr [rax + 4] crc32 r10d, dword ptr [rax + 8] crc32 r11d, dword ptr [rax + 12] add rax, 16 dec ecx jnz @s mov dword ptr [rdx], r8d mov dword ptr [rdx + 4], r9d mov dword ptr [rdx + 8], r10d mov dword ptr [rdx + 12], r11d end else {$endif FPC} {$endif CPUX64} {$endif DISABLE_SSE42} begin oneblock := @crcblock; for i := 1 to count do begin oneblock(crc128,data128); inc(data128); end; end; end; {$ifdef CPUINTEL} function crc32cBy4SSE42(crc, value: cardinal): cardinal; {$ifdef CPU64} {$ifdef FPC}nostackframe; assembler; asm {$else} asm // rcx=crc, rdx=value(Linux: rdi,rsi) .noframe {$endif FPC} {$ifdef Linux} mov eax, edi crc32 eax, esi {$else} mov eax, ecx crc32 eax, edx {$endif} end; {$else} {$ifdef FPC}nostackframe; assembler;{$endif} asm // eax=crc, edx=value {$ifdef FPC_OR_UNICODE} crc32 eax, edx {$else} db $F2, $0F, $38, $F1, $C2 {$endif} end; {$endif CPU64} procedure crcblockSSE42(crc128, data128: PBlock128); {$ifdef CPU64} {$ifdef FPC}nostackframe; assembler; asm {$else} asm // rcx=crc128, rdx=data128 (Linux: rdi,rsi) .noframe {$endif FPC} {$ifdef Linux} mov eax, dword ptr[rdi] mov r8d, dword ptr[rdi + 4] mov r9d, dword ptr[rdi + 8] mov r10d, dword ptr[rdi + 12] crc32 eax, dword ptr[rsi] crc32 r8d, dword ptr[rsi + 4] crc32 r9d, dword ptr[rsi + 8] crc32 r10d, dword ptr[rsi + 12] mov dword ptr[rdi], eax mov dword ptr[rdi + 4], r8d mov dword ptr[rdi + 8], r9d mov dword ptr[rdi + 12], r10d {$else} mov eax, dword ptr[rcx] mov r8d, dword ptr[rcx + 4] mov r9d, dword ptr[rcx + 8] mov r10d, dword ptr[rcx + 12] crc32 eax, dword ptr[rdx] crc32 r8d, dword ptr[rdx + 4] crc32 r9d, dword ptr[rdx + 8] crc32 r10d, dword ptr[rdx + 12] mov dword ptr[rcx], eax mov dword ptr[rcx + 4], r8d mov dword ptr[rcx + 8], r9d mov dword ptr[rcx + 12], r10d {$endif Linux} end; {$else} {$ifdef FPC}nostackframe; assembler;{$endif} asm // eax=crc128, edx=data128 mov ecx, eax {$ifdef FPC_OR_UNICODE} mov eax, dword ptr[ecx] crc32 eax, dword ptr[edx] mov dword ptr[ecx], eax mov eax, dword ptr[ecx + 4] crc32 eax, dword ptr[edx + 4] mov dword ptr[ecx + 4], eax mov eax, dword ptr[ecx + 8] crc32 eax, dword ptr[edx + 8] mov dword ptr[ecx + 8], eax mov eax, dword ptr[ecx + 12] crc32 eax, dword ptr[edx + 12] mov dword ptr[ecx + 12], eax {$else} mov eax, dword ptr[ecx] db $F2, $0F, $38, $F1, $02 mov dword ptr[ecx], eax mov eax, dword ptr[ecx + 4] db $F2, $0F, $38, $F1, $42, $04 mov dword ptr[ecx + 4], eax mov eax, dword ptr[ecx + 8] db $F2, $0F, $38, $F1, $42, $08 mov dword ptr[ecx + 8], eax mov eax, dword ptr[ecx + 12] db $F2, $0F, $38, $F1, $42, $0C mov dword ptr[ecx + 12], eax {$endif FPC_OR_UNICODE} end; {$endif CPU64} {$endif CPUINTEL} function crc32cBy4fast(crc, value: cardinal): cardinal; var tab: ^TCrc32tab; begin tab := @crc32ctab; result := crc xor value; result := tab[3,ToByte(result)] xor tab[2,ToByte(result shr 8)] xor tab[1,ToByte(result shr 16)] xor tab[0,result shr 24]; end; function crc32cinlined(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; {$ifdef HASINLINE} var tab: ^TCrc32tab; begin result := not crc; if len>0 then begin tab := @crc32ctab; repeat result := tab[0,(result xor ord(buf^))and 255] xor (result shr 8); inc(buf); dec(len); until len=0; end; result := not result; end; {$else} begin result := crc32c(crc,buf,len); end; {$endif} {$ifdef CPUX86} procedure GetCPUID(Param: Cardinal; var Registers: TRegisters); {$ifdef FPC}nostackframe; assembler;{$endif} asm push esi push edi mov esi, edx mov edi, eax pushfd pop eax mov edx, eax xor eax, $200000 push eax popfd pushfd pop eax xor eax, edx jz @nocpuid push ebx mov eax, edi xor ecx, ecx {$ifdef DELPHI5OROLDER} db $0f, $a2 {$else} cpuid {$endif} mov TRegisters(esi).&eax, eax mov TRegisters(esi).&ebx, ebx mov TRegisters(esi).&ecx, ecx mov TRegisters(esi).&edx, edx pop ebx @nocpuid: pop edi pop esi end; function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; {$ifdef FPC}nostackframe; assembler;{$endif} asm // eax=crc, edx=buf, ecx=len not eax test ecx, ecx jz @0 test edx, edx jz @0 @3: test edx, 3 jz @8 // align to 4 bytes boundary {$ifdef FPC_OR_UNICODE} crc32 eax, byte ptr[edx] {$else} db $F2, $0F, $38, $F0, $02 {$endif} inc edx dec ecx jz @0 test edx, 3 jnz @3 @8: push ecx shr ecx, 3 jz @2 @1: {$ifdef FPC_OR_UNICODE} crc32 eax, dword ptr[edx] crc32 eax, dword ptr[edx + 4] {$else} db $F2, $0F, $38, $F1, $02 db $F2, $0F, $38, $F1, $42, $04 {$endif} add edx, 8 dec ecx jnz @1 @2: pop ecx and ecx, 7 jz @0 cmp ecx, 4 jb @4 {$ifdef FPC_OR_UNICODE} crc32 eax, dword ptr[edx] {$else} db $F2, $0F, $38, $F1, $02 {$endif} add edx, 4 sub ecx, 4 jz @0 @4: {$ifdef FPC_OR_UNICODE} crc32 eax, byte ptr[edx] dec ecx jz @0 crc32 eax, byte ptr[edx + 1] dec ecx jz @0 crc32 eax, byte ptr[edx + 2] {$else} db $F2, $0F, $38, $F0, $02 dec ecx jz @0 db $F2, $0F, $38, $F0, $42, $01 dec ecx jz @0 db $F2, $0F, $38, $F0, $42, $02 {$endif} @0: not eax end; {$endif CPUX86} function crc32cUTF8ToHex(const str: RawUTF8): RawUTF8; begin result := CardinalToHex(crc32c(0,pointer(str),length(str))); end; function crc64c(buf: PAnsiChar; len: cardinal): Int64; var hilo: Int64Rec absolute result; begin hilo.Lo := crc32c(0,buf,len); hilo.Hi := crc32c(hilo.Lo,buf,len); end; function crc63c(buf: PAnsiChar; len: cardinal): Int64; var hilo: Int64Rec absolute result; begin hilo.Lo := crc32c(0,buf,len); hilo.Hi := crc32c(hilo.Lo,buf,len) and $7fffffff; end; procedure crc128c(buf: PAnsiChar; len: cardinal; out crc: THash128); var h: THash128Rec absolute crc; h1,h2: cardinal; begin // see https://goo.gl/Pls5wi assert(SizeOf(h)=SizeOf(crc)); h1 := crc32c(0,buf,len); h2 := crc32c(h1,buf,len); h.i0 := h1; inc(h1,h2); h.i1 := h1; inc(h1,h2); h.i2 := h1; inc(h1,h2); h.i3 := h1; end; function IsZero(const dig: THash128): boolean; var a: TPtrIntArray absolute dig; begin result := (a[0]=0) and (a[1]=0) {$ifndef CPU64} and (a[2]=0) and (a[3]=0){$endif}; end; function IsEqual(const A,B: THash128): boolean; var a_: TPtrIntArray absolute A; b_: TPtrIntArray absolute B; begin // uses anti-forensic time constant "xor/or" pattern result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) {$ifndef CPU64} or (a_[2] xor b_[2]) or (a_[3] xor b_[3]){$endif})=0; end; procedure FillZero(out dig: THash128); begin PInt64Array(@dig)^[0] := 0; PInt64Array(@dig)^[1] := 0; end; function HashFound(P: PHash128Rec; Count: integer; const h: THash128Rec): boolean; var first{$ifdef CPU64}, second{$endif}: PtrInt; i: integer; begin // fast O(n) brute force search if P<>nil then begin result := true; first := h.Lo; {$ifdef CPU64} second := h.hi; for i := 1 to Count do if (P^.Lo=first) and (P^.Hi=second) then {$else} for i := 1 to Count do if (P^.i0=first) and (P^.i1=h.i1) and (P^.i2=h.i2) and (P^.i3=h.i3) then {$endif} exit else inc(P); end; result := false; end; function IP4Text(ip4: cardinal): shortstring; var b: array[0..3] of byte absolute ip4; begin if ip4=0 then result := '' else FormatShort('%.%.%.%',[b[0],b[1],b[2],b[3]],result); end; procedure IP6Text(ip6: PHash128; result: PShortString); var i: integer; p: PByte; {$ifdef PUREPASCAL}tab: ^TByteToWord;{$endif} begin if IsZero(ip6^) then result^ := '' else begin result^[0] := AnsiChar(39); p := @result^[1]; {$ifdef PUREPASCAL}tab := @TwoDigitsHexWBLower;{$endif} for i := 0 to 7 do begin PWord(p)^ := {$ifdef PUREPASCAL}tab{$else}TwoDigitsHexWBLower{$endif}[ip6^[0]]; inc(p,2); PWord(p)^ := {$ifdef PUREPASCAL}tab{$else}TwoDigitsHexWBLower{$endif}[ip6^[1]]; inc(p,2); inc(PWord(ip6)); p^ := ord(':'); inc(p); end; end; end; function IP6Text(ip6: PHash128): shortstring; begin IP6Text(ip6, @result); end; function IsZero(const dig: THash160): boolean; var a: TIntegerArray absolute dig; begin result := (a[0]=0) and (a[1]=0) and (a[2]=0) and (a[3]=0) and (a[4]=0); end; function IsEqual(const A,B: THash160): boolean; var a_: TIntegerArray absolute A; b_: TIntegerArray absolute B; begin // uses anti-forensic time constant "xor/or" pattern result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or (a_[3] xor b_[3]) or (a_[4] xor b_[4]))=0; end; procedure FillZero(out dig: THash160); begin PInt64Array(@dig)^[0] := 0; PInt64Array(@dig)^[1] := 0; PIntegerArray(@dig)^[4] := 0; end; procedure crc256c(buf: PAnsiChar; len: cardinal; out crc: THash256); var h: THash256Rec absolute crc; h1,h2: cardinal; begin // see https://goo.gl/Pls5wi h1 := crc32c(0,buf,len); h2 := crc32c(h1,buf,len); h.i0 := h1; inc(h1,h2); h.i1 := h1; inc(h1,h2); h.i2 := h1; inc(h1,h2); h.i3 := h1; inc(h1,h2); h.i4 := h1; inc(h1,h2); h.i5 := h1; inc(h1,h2); h.i6 := h1; inc(h1,h2); h.i7 := h1; end; function IsZero(const dig: THash256): boolean; var a: TPtrIntArray absolute dig; begin result := (a[0]=0) and (a[1]=0) and (a[2]=0) and (a[3]=0) {$ifndef CPU64} and (a[4]=0) and (a[5]=0) and (a[6]=0) and (a[7]=0){$endif}; end; function IsEqual(const A,B: THash256): boolean; var a_: TPtrIntArray absolute A; b_: TPtrIntArray absolute B; begin // uses anti-forensic time constant "xor/or" pattern result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or (a_[3] xor b_[3]) {$ifndef CPU64} or (a_[4] xor b_[4]) or (a_[5] xor b_[5]) or (a_[6] xor b_[6]) or (a_[7] xor b_[7]) {$endif})=0; end; procedure FillZero(out dig: THash256); begin PInt64Array(@dig)^[0] := 0; PInt64Array(@dig)^[1] := 0; PInt64Array(@dig)^[2] := 0; PInt64Array(@dig)^[3] := 0; end; function IsZero(const dig: THash384): boolean; var a: TPtrIntArray absolute dig; begin result := (a[0]=0) and (a[1]=0) and (a[2]=0) and (a[3]=0) and (a[4]=0) and (a[5]=0) {$ifndef CPU64} and (a[6]=0) and (a[7]=0) and (a[8]=0) and (a[9]=0) and (a[10]=0) and (a[11]=0){$endif}; end; function IsEqual(const A,B: THash384): boolean; var a_: TPtrIntArray absolute A; b_: TPtrIntArray absolute B; begin // uses anti-forensic time constant "xor/or" pattern result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or (a_[3] xor b_[3]) or (a_[4] xor b_[4]) or (a_[5] xor b_[5]) {$ifndef CPU64} or (a_[6] xor b_[6]) or (a_[7] xor b_[7]) or (a_[8] xor b_[8]) or (a_[9] xor b_[9]) or (a_[10] xor b_[10]) or (a_[11] xor b_[11]) {$endif})=0; end; procedure FillZero(out dig: THash384); begin PInt64Array(@dig)^[0] := 0; PInt64Array(@dig)^[1] := 0; PInt64Array(@dig)^[2] := 0; PInt64Array(@dig)^[3] := 0; PInt64Array(@dig)^[4] := 0; PInt64Array(@dig)^[5] := 0; end; function IsZero(const dig: THash512): boolean; var a: TPtrIntArray absolute dig; begin result := (a[0]=0) and (a[1]=0) and (a[2]=0) and (a[3]=0) and (a[4]=0) and (a[5]=0) and (a[6]=0) and (a[7]=0) {$ifndef CPU64} and (a[8]=0) and (a[9]=0) and (a[10]=0) and (a[11]=0) and (a[12]=0) and (a[13]=0) and (a[14]=0) and (a[15]=0){$endif}; end; function IsEqual(const A,B: THash512): boolean; var a_: TPtrIntArray absolute A; b_: TPtrIntArray absolute B; begin // uses anti-forensic time constant "xor/or" pattern result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or (a_[3] xor b_[3]) or (a_[4] xor b_[4]) or (a_[5] xor b_[5]) or (a_[6] xor b_[6]) or (a_[7] xor b_[7]) {$ifndef CPU64} or (a_[8] xor b_[8]) or (a_[9] xor b_[9]) or (a_[10] xor b_[10]) or (a_[11] xor b_[11]) or (a_[12] xor b_[12]) or (a_[13] xor b_[13]) or (a_[14] xor b_[14]) or (a_[15] xor b_[15]) {$endif})=0; end; procedure FillZero(out dig: THash512); begin PInt64Array(@dig)^[0] := 0; PInt64Array(@dig)^[1] := 0; PInt64Array(@dig)^[2] := 0; PInt64Array(@dig)^[3] := 0; PInt64Array(@dig)^[4] := 0; PInt64Array(@dig)^[5] := 0; PInt64Array(@dig)^[6] := 0; PInt64Array(@dig)^[7] := 0; end; procedure crc512c(buf: PAnsiChar; len: cardinal; out crc: THash512); var h: THash512Rec absolute crc; h1,h2: cardinal; begin // see https://goo.gl/Pls5wi h1 := crc32c(0,buf,len); h2 := crc32c(h1,buf,len); h.i0 := h1; inc(h1,h2); h.i1 := h1; inc(h1,h2); h.i2 := h1; inc(h1,h2); h.i3 := h1; inc(h1,h2); h.i4 := h1; inc(h1,h2); h.i5 := h1; inc(h1,h2); h.i6 := h1; inc(h1,h2); h.i7 := h1; inc(h1,h2); h.i8 := h1; inc(h1,h2); h.i9 := h1; inc(h1,h2); h.i10 := h1; inc(h1,h2); h.i11 := h1; inc(h1,h2); h.i12 := h1; inc(h1,h2); h.i13 := h1; inc(h1,h2); h.i14 := h1; inc(h1,h2); h.i15 := h1; end; procedure FillZero(var secret: RawByteString); begin if secret<>'' then with PStrRec(Pointer(PtrInt(secret)-STRRECSIZE))^ do if refCnt=1 then // avoid GPF if const {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(pointer(secret)^,length,0); end; procedure FillZero(var secret: RawUTF8); begin if secret<>'' then with PStrRec(Pointer(PtrInt(secret)-STRRECSIZE))^ do if refCnt=1 then // avoid GPF if const {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(pointer(secret)^,length,0); end; procedure mul64x64(const left, right: QWord; out product: THash128Rec); {$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} asm // rcx/rdi=left, rdx/rsi=right r8/rdx=product .noframe {$endif}{$ifdef WIN64} mov rax, rcx mul rdx // uses built-in 64-bit -> 128-bit multiplication {$else} mov r8, rdx mov rax, rdi mul rsi {$endif}mov qword ptr [r8], rax mov qword ptr [r8+8], rdx end; {$else} {$ifdef CPU32DELPHI} asm // adapted from FPC compiler output, which is much better than Delphi's here mov ecx, eax mov eax, dword ptr [ebp+8H] mul dword ptr [ebp+10H] mov dword ptr [ecx], eax mov dword ptr [ebp-4H], edx mov eax, dword ptr [ebp+8H] mul dword ptr [ebp+14H] add eax, dword ptr [ebp-4H] adc edx, 0 mov dword ptr [ebp-10H], eax mov dword ptr [ebp-0CH], edx mov eax, dword ptr [ebp+0CH] mul dword ptr [ebp+10H] add eax, dword ptr [ebp-10H] adc edx, 0 mov dword ptr [ecx+4H], eax mov dword ptr [ebp-14H], edx mov eax, dword ptr [ebp+0CH] mul dword ptr [ebp+14H] add eax, dword ptr [ebp-0CH] adc edx, 0 add eax, dword ptr [ebp-14H] adc edx, 0 mov dword ptr [ecx+8H], eax mov dword ptr [ecx+0CH], edx end; {$else} // CPU-neutral implementation var l: TQWordRec absolute left; r: TQWordRec absolute right; t1,t2,t3: TQWordRec; begin t1.V := QWord(l.L)*r.L; t2.V := QWord(l.H)*r.L+t1.H; t3.V := QWord(l.L)*r.H+t2.L; product.H := QWord(l.H)*r.H+t2.H+t3.H; product.L := t3.V shl 32 or t1.L; end; {$endif CPU32DELPHI} {$endif CPUX64} procedure SymmetricEncrypt(key: cardinal; var data: RawByteString); var i,len: integer; d: PCardinal; tab: ^TCrc32tab; begin tab := @crc32ctab; {$ifdef FPC} UniqueString(data); // @data[1] won't call UniqueString() under FPC :( {$endif} d := @data[1]; len := length(data); key := key xor cardinal(len); for i := 0 to (len shr 2)-1 do begin key := key xor tab[0,(cardinal(i) xor key)and 1023]; d^ := d^ xor key; inc(d); end; for i := 0 to (len and 3)-1 do PByteArray(d)^[i] := PByteArray(d)^[i] xor key xor tab[0,17 shl i]; end; function UnixTimeToDateTime(const UnixTime: TUnixTime): TDateTime; begin result := UnixTime / SecsPerDay + UnixDateDelta; end; function DateTimeToUnixTime(const AValue: TDateTime): TUnixTime; begin result := Round((AValue - UnixDateDelta) * SecsPerDay); end; const UnixFileTimeDelta = 116444736000000000; // from year 1601 to 1970 DateFileTimeDelta = 94353120000000000; // from year 1601 to 1899 {$ifdef MSWINDOWS} function FileTimeToUnixTime(const FT: TFileTime): TUnixTime; {$ifdef CPU64}var nano100: Int64;{$endif} begin {$ifdef CPU64} FileTimeToInt64(ft,nano100); result := (nano100-UnixFileTimeDelta) div 10000000; {$else} // use PInt64 to avoid URW699 with Delphi 6 / Kylix result := (PInt64(@ft)^-UnixFileTimeDelta) div 10000000; {$endif} end; function FileTimeToUnixMSTime(const FT: TFileTime): TUnixMSTime; {$ifdef CPU64}var nano100: Int64;{$endif} begin {$ifdef CPU64} FileTimeToInt64(ft,nano100); result := (nano100-UnixFileTimeDelta) div 10000; {$else} // use PInt64 to avoid URW699 with Delphi 6 / Kylix result := (PInt64(@ft)^-UnixFileTimeDelta) div 10000; {$endif} end; function UnixTimeUTC: TUnixTime; var ft: TFileTime; begin GetSystemTimeAsFileTime(ft); // very fast, with 100 ns unit result := FileTimeToUnixTime(ft); end; function UnixMSTimeUTC: TUnixMSTime; var ft: TFileTime; begin GetSystemTimeAsFileTime(ft); // very fast, with 100 ns unit result := FileTimeToUnixMSTime(ft); end; {$else MSWINDOWS} function UnixTimeUTC: TUnixTime; begin result := GetUnixUTC; // direct retrieval from UNIX API end; function UnixMSTimeUTC: TUnixMSTime; begin result := GetUnixMSUTC; // direct retrieval from UNIX API end; {$endif MSWINDOWS} function DaysToIso8601(Days: cardinal; Expanded: boolean): RawUTF8; var Y,M: cardinal; begin Y := 0; while Days>365 do begin dec(Days,366); inc(Y); end; M := 0; if Days>31 then begin inc(M); while Days>MonthDays[false][M] do begin dec(Days,MonthDays[false][M]); inc(M); end; end; result := DateToIso8601(Y,M,Days,Expanded); end; function UnixTimeToString(const UnixTime: TUnixTime; Expanded: boolean; FirstTimeChar: AnsiChar): RawUTF8; begin // inlined UnixTimeToDateTime result := DateTimeToIso8601(UnixTime/SecsPerDay+UnixDateDelta,Expanded, FirstTimeChar,false); end; function DateTimeToFileShort(const DateTime: TDateTime): TShort16; begin DateTimeToFileShort(DateTime,result); end; procedure DateTimeToFileShort(const DateTime: TDateTime; out result: TShort16); var T: TSynSystemTime; tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; begin // use 'YYMMDDHHMMSS' format if DateTime<=0 then begin PWord(@result[0])^ := 1+ord('0') shl 8; exit; end; T.FromDate(DateTime); if T.Year > 1999 then if T.Year < 2100 then dec(T.Year,2000) else T.Year := 99 else T.Year := 0; T.FromTime(DateTime); {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} result[0] := #12; PWord(@result[1])^ := tab[T.Year]; PWord(@result[3])^ := tab[T.Month]; PWord(@result[5])^ := tab[T.Day]; PWord(@result[7])^ := tab[T.Hour]; PWord(@result[9])^ := tab[T.Minute]; PWord(@result[11])^ := tab[T.Second]; end; procedure UnixTimeToFileShort(const UnixTime: TUnixTime; out result: TShort16); begin // use 'YYMMDDHHMMSS' format if UnixTime<=0 then PWord(@result[0])^ := 1+ord('0') shl 8 else DateTimeToFileShort(UnixTime/SecsPerDay+UnixDateDelta, result); end; function UnixTimeToFileShort(const UnixTime: TUnixTime): TShort16; begin UnixTimeToFileShort(UnixTime, result); end; function UnixMSTimeToFileShort(const UnixMSTime: TUnixMSTime): TShort16; begin UnixTimeToFileShort(UnixMSTime div MSecsPerSec, result); end; function UnixTimePeriodToString(const UnixTime: TUnixTime; FirstTimeChar: AnsiChar): RawUTF8; begin if UnixTime0; end else result := false; end; {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} type unaligned = Double; {$endif} function Char2ToByte(P: PUTF8Char; out Value: Cardinal): Boolean; var B: PtrUInt; begin B := ConvertHexToBin[ord(P[0])]; if B<=9 then begin Value := B; B := ConvertHexToBin[ord(P[1])]; if B<=9 then begin Value := Value*10+B; result := false; exit; end; end; result := true; // error end; function Char3ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; var B: PtrUInt; begin B := ConvertHexToBin[ord(P[0])]; if B<=9 then begin Value := B; B := ConvertHexToBin[ord(P[1])]; if B<=9 then begin Value := Value*10+B; B := ConvertHexToBin[ord(P[2])]; if B<=9 then begin Value := Value*10+B; result := false; exit; end; end; end; result := true; // error end; function Char4ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; var B: PtrUInt; begin B := ConvertHexToBin[ord(P[0])]; if B<=9 then begin Value := B; B := ConvertHexToBin[ord(P[1])]; if B<=9 then begin Value := Value*10+B; B := ConvertHexToBin[ord(P[2])]; if B<=9 then begin Value := Value*10+B; B := ConvertHexToBin[ord(P[3])]; if B<=9 then begin Value := Value*10+B; result := false; exit; end; end; end; end; result := true; // error end; procedure Iso8601ToDateTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); var B: cardinal; Y,M,D, H,MI,SS,MS: cardinal; d100: TDiv100Rec; tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; // expect 'YYYYMMDDThhmmss[.sss]' format but handle also 'YYYY-MM-DDThh:mm:ss[.sss]' begin unaligned(result) := 0; if P=nil then exit; if L=0 then L := StrLen(P); if L<4 then exit; // we need 'YYYY' at least if P[0]='T' then begin dec(P,8); inc(L,8); end else begin {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 B := tab[ord(P[0])]; // first digit if B>9 then exit else Y := B; // fast check '0'..'9' B := tab[ord(P[1])]; if B>9 then exit else Y := Y*10+B; B := tab[ord(P[2])]; if B>9 then exit else Y := Y*10+B; B := tab[ord(P[3])]; if B>9 then exit else Y := Y*10+B; if P[4] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD D := 1; if L>=6 then begin // YYYYMM M := ord(P[4])*10+ord(P[5])-(48+480); if (M=0) or (M>12) then exit; if P[6] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD if L>=8 then begin // YYYYMMDD if not(P[8] in [#0,' ','T']) then exit; // invalid date format D := ord(P[6])*10+ord(P[7])-(48+480); if (D=0) or (D>MonthDays[true][M]) then exit; // worse is leap year=true end; end else M := 1; if M>2 then // inlined EncodeDate(Y,M,D) dec(M,3) else if M>0 then begin inc(M,9); dec(Y); end; if Y>9999 then exit; // avoid integer overflow e.g. if '0000' is an invalid date Div100(Y,d100); unaligned(result) := (146097*d100.d) shr 2 + (1461*d100.m) shr 2 + (153*M+2) div 5+D-693900; if L<15 then exit; // not enough space to retrieve the time end; H := ord(P[9])*10+ord(P[10])-(48+480); if P[11]=':' then begin inc(P); dec(L); end;// allow hh:mm:ss MI := ord(P[11])*10+ord(P[12])-(48+480); if P[13]=':' then begin inc(P); dec(L); end; // allow hh:mm:ss SS := ord(P[13])*10+ord(P[14])-(48+480); if (L>16) and (P[15]='.') then begin // one or more digits representing a decimal fraction of a second MS := ord(P[16])*100-4800; if L>17 then MS := MS+ord(P[17])*10-480; if L>18 then MS := MS+ord(P[18])-48; if MS>1000 then MS := 0; end else MS := 0; if (H<24) and (MI<60) and (SS<60) then // inlined EncodeTime() result := result+(H*(MinsPerHour*SecsPerMin*MSecsPerSec)+ MI*(SecsPerMin*MSecsPerSec)+SS*MSecsPerSec+MS)/MSecsPerDay; end; function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer=0): TDateTime; begin Iso8601ToTimePUTF8CharVar(P,L,result); end; procedure Iso8601ToTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); var H,MI,SS,MS: cardinal; begin if Iso8601ToTimePUTF8Char(P,L,H,MI,SS,MS) then result := (H*(MinsPerHour*SecsPerMin*MSecsPerSec)+ MI*(SecsPerMin*MSecsPerSec)+SS*MSecsPerSec+MS)/MSecsPerDay else result := 0; end; function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer; var H,M,S,MS: cardinal): boolean; begin result := false; // error if P=nil then exit; if L=0 then L := StrLen(P); if L<6 then exit; // we need 'hhmmss' at least H := ord(P[0])*10+ord(P[1])-(48+480); if P[2]=':' then begin inc(P); dec(L); end; // allow hh:mm:ss M := ord(P[2])*10+ord(P[3])-(48+480); if P[4]=':' then begin inc(P); dec(L); end; // allow hh:mm:ss S := ord(P[4])*10+ord(P[5])-(48+480); if (L>6) and (P[6]='.') then begin // one or more digits representing a decimal fraction of a second MS := ord(P[7])*100-4800; if L>7 then MS := MS+ord(P[8])*10-480; if L>8 then MS := MS+ord(P[9])-48; end else MS := 0; if (H<24) and (M<60) and (S<60) and (MS<1000) then result := true; end; function IntervalTextToDateTime(Text: PUTF8Char): TDateTime; begin IntervalTextToDateTimeVar(Text,result); end; procedure IntervalTextToDateTimeVar(Text: PUTF8Char; var result: TDateTime); var negative: boolean; Time: TDateTime; begin // e.g. IntervalTextToDateTime('+0 06:03:20') result := 0; if Text=nil then exit; if Text^ in ['+','-'] then begin negative := (Text^='-'); result := GetNextItemDouble(Text,' '); end else negative := false; Iso8601ToTimePUTF8CharVar(Text,0,Time); if negative then result := result-Time else result := result+Time; end; function Iso8601ToDateTime(const S: RawByteString): TDateTime; begin result := Iso8601ToDateTimePUTF8Char(pointer(S),length(S)); end; function TimeLogToDateTime(const Timestamp: TTimeLog): TDateTime; begin result := PTimeLogBits(@Timestamp)^.ToDateTime; end; function TimeLogToUnixTime(const Timestamp: TTimeLog): TUnixTime; begin result := PTimeLogBits(@Timestamp)^.ToUnixTime; end; procedure DateToIso8601PChar(P: PUTF8Char; Expanded: boolean; Y,M,D: PtrUInt); // use 'YYYYMMDD' format if not Expanded, 'YYYY-MM-DD' format if Expanded var tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; begin {$ifdef CPUX86NOTPIC} YearToPChar(Y,P); {$else} tab := @TwoDigitLookupW; YearToPChar2(tab,Y,P); {$endif} inc(P,4); if Expanded then begin P^ := '-'; inc(P); end; PWord(P)^ := tab[M]; inc(P,2); if Expanded then begin P^ := '-'; inc(P); end; PWord(P)^ := tab[D]; end; procedure TimeToIso8601PChar(P: PUTF8Char; Expanded: boolean; H,M,S,MS: PtrUInt; FirstChar: AnsiChar; WithMS: boolean); var tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; begin // use Thhmmss[.sss] format if FirstChar<>#0 then begin P^ := FirstChar; inc(P); end; {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} PWord(P)^ := tab[H]; inc(P,2); if Expanded then begin P^ := ':'; inc(P); end; PWord(P)^ := tab[M]; inc(P,2); if Expanded then begin P^ := ':'; inc(P); end; PWord(P)^ := tab[S]; if WithMS then begin inc(P,2); {$ifdef CPUX86NOTPIC}YearToPChar(MS{$else}YearToPChar2(tab,MS{$endif},P); P^ := '.'; // override first digit end; end; procedure DateToIso8601PChar(Date: TDateTime; P: PUTF8Char; Expanded: boolean); var T: TSynSystemTime; begin // use YYYYMMDD / YYYY-MM-DD date format T.FromDate(Date); DateToIso8601PChar(P,Expanded,T.Year,T.Month,T.Day); end; function DateToIso8601Text(Date: TDateTime): RawUTF8; begin // into 'YYYY-MM-DD' date format if Date=0 then result := '' else begin SetLength(result,10); DateToIso8601PChar(Date,pointer(result),True); end; end; procedure TimeToIso8601PChar(Time: TDateTime; P: PUTF8Char; Expanded: boolean; FirstChar: AnsiChar; WithMS: boolean); var T: TSynSystemTime; begin T.FromTime(Time); TimeToIso8601PChar(P,Expanded,T.Hour,T.Minute,T.Second,T.MilliSecond,FirstChar,WithMS); end; function DateTimeToIso8601(D: TDateTime; Expanded: boolean; FirstChar: AnsiChar; WithMS: boolean): RawUTF8; const ISO8601_LEN: array[boolean,boolean] of integer = ((15,14),(19,18)); 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)); end; function DateToIso8601(Date: TDateTime; Expanded: boolean): RawUTF8; // use YYYYMMDD / YYYY-MM-DD date format begin FastSetString(result,nil,8+2*integer(Expanded)); DateToIso8601PChar(Date,pointer(result),Expanded); end; function DateToIso8601(Y,M,D: cardinal; Expanded: boolean): RawUTF8; // use 'YYYYMMDD' format if not Expanded, 'YYYY-MM-DD' format if Expanded begin FastSetString(result,nil,8+2*integer(Expanded)); DateToIso8601PChar(pointer(result),Expanded,Y,M,D); end; function TimeToIso8601(Time: TDateTime; Expanded: boolean; FirstChar: AnsiChar; WithMS: boolean): RawUTF8; // use Thhmmss[.sss] / Thh:mm:ss[.sss] format begin FastSetString(result,nil,7+2*integer(Expanded)+4*integer(WithMS)); TimeToIso8601PChar(Time,pointer(result),Expanded,FirstChar,WithMS); end; function DateTimeToIso8601Text(DT: TDateTime; FirstChar: AnsiChar; WithMS: boolean): RawUTF8; begin DateTimeToIso8601TextVar(DT,FirstChar,result,WithMS); end; procedure DateTimeToIso8601TextVar(DT: TDateTime; FirstChar: AnsiChar; var result: RawUTF8; WithMS: boolean); begin if DT=0 then result := '' else if frac(DT)=0 then result := DateToIso8601(DT,true) else if trunc(DT)=0 then result := TimeToIso8601(DT,true,FirstChar,WithMS) else result := DateTimeToIso8601(DT,true,FirstChar,WithMS); end; procedure DateTimeToIso8601StringVar(DT: TDateTime; FirstChar: AnsiChar; var result: string; WithMS: boolean); var tmp: RawUTF8; begin DateTimeToIso8601TextVar(DT,FirstChar,tmp,WithMS); Ansi7ToString(Pointer(tmp),length(tmp),result); end; procedure DateTimeToIso8601ExpandedPChar(const Value: TDateTime; Dest: PUTF8Char; FirstChar: AnsiChar='T'; WithMS: boolean=false); 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; end; Dest^ := #0; end; function Iso8601ToTimeLogPUTF8Char(P: PUTF8Char; L: integer; ContainsNoTime: PBoolean=nil): TTimeLog; // bits: S=0..5 M=6..11 H=12..16 D=17..21 M=22..25 Y=26..38 // i.e. S<64 M<64 H<32 D<32 M<16 Y<4096: power of 2 -> use fast shl/shr var V,B: PtrUInt; i: integer; begin result := 0; if P=nil then exit; if L=0 then L := StrLen(P); if L<4 then exit; // we need 'YYYY' at least if P[0]='T' then dec(P,8) else begin // 'YYYY' -> year decode V := ConvertHexToBin[ord(P[0])]; if V>9 then exit; for i := 1 to 3 do begin B := ConvertHexToBin[ord(P[i])]; if B>9 then exit else V := V*10+B; end; result := Int64(V) shl 26; // store YYYY if P[4] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD if L>=6 then begin // YYYYMM V := ord(P[4])*10+ord(P[5])-(48+480+1); // Month 1..12 -> 0..11 if V<=11 then inc(result,V shl 22) else begin result := 0; exit; end; if P[6] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD if L>=8 then begin // YYYYMMDD V := ord(P[6])*10+ord(P[7])-(48+480+1); // Day 1..31 -> 0..30 if (V<=30) and(P[8] in [#0,' ','T']) then inc(result,V shl 17) else begin result := 0; exit; end; end; end; if L<15 then begin // not enough place to retrieve a time if ContainsNoTime<>nil then ContainsNoTime^ := true; exit; end; end; if ContainsNoTime<>nil then ContainsNoTime^ := false; B := ord(P[9])*10+ord(P[10])-(48+480); if B<=23 then V := B shl 12 else exit; if P[11]=':' then inc(P); // allow hh:mm:ss B := ord(P[11])*10+ord(P[12])-(48+480); if B<=59 then inc(V,B shl 6) else exit; if P[13]=':' then inc(P); // allow hh:mm:ss B := ord(P[13])*10+ord(P[14])-(48+480); if B<=59 then inc(result,PtrUInt(V+B)); end; function IsIso8601(P: PUTF8Char; L: integer): boolean; begin result := Iso8601ToTimeLogPUTF8Char(P,L)<>0; end; function DateTimeToi18n(const DateTime: TDateTime): string; begin if Assigned(i18nDateTimeText) then result := i18nDateTimeText(DateTime) else result := {$ifdef UNICODE}Ansi7ToString{$endif}(DateTimeToIso8601(DateTime,true,' ',true)); end; { TTimeLogBits } // bits: S=0..5 M=6..11 H=12..16 D=17..21 M=22..25 Y=26..38 // size: S=6 M=6 H=5 D=5 M=4 Y=12 // i.e. S<64 M<64 H<32 D<32 M<16 Y<4096: power of 2 -> use fast shl/shr procedure TTimeLogBits.From(Y, M, D, HH, MM, SS: cardinal); begin inc(HH,D shl 5+M shl 10+Y shl 14-(1 shl 5+1 shl 10)); Value := SS+MM shl 6+Int64(HH) shl 12; end; procedure TTimeLogBits.From(P: PUTF8Char; L: integer); begin Value := Iso8601ToTimeLogPUTF8Char(P,L); end; procedure TTimeLogBits.Expand(out Date: TSynSystemTime); begin Date.Year := (Value shr (6+6+5+5+4)) and 4095; Date.Month := 1+(PCardinal(@Value)^ shr (6+6+5+5)) and 15; Date.Day := 1+(PCardinal(@Value)^ shr (6+6+5)) and 31; Date.DayOfWeek := 0; Date.Hour := (PCardinal(@Value)^ shr (6+6)) and 31; Date.Minute := (PCardinal(@Value)^ shr 6) and 63; Date.Second := PCardinal(@Value)^ and 63; end; procedure TTimeLogBits.From(const S: RawUTF8); begin Value := Iso8601ToTimeLog(S); end; procedure TTimeLogBits.From(FileDate: integer); begin {$ifdef MSWINDOWS} From(PInt64Rec(@FileDate)^.Hi shr 9+1980, PInt64Rec(@FileDate)^.Hi shr 5 and 15, PInt64Rec(@FileDate)^.Hi and 31, PInt64Rec(@FileDate)^.Lo shr 11, PInt64Rec(@FileDate)^.Lo shr 5 and 63, PInt64Rec(@FileDate)^.Lo and 31 shl 1); {$else} // FileDate depends on the running OS From(FileDateToDateTime(FileDate)); {$endif} end; procedure TTimeLogBits.From(DateTime: TDateTime; DateOnly: Boolean); var T: TSynSystemTime; V: PtrInt; begin T.FromDate(DateTime); if DateOnly then T.Hour := 0 else T.FromTime(DateTime); V := T.Day shl 5+T.Month shl 10+T.Year shl 14-(1 shl 5+1 shl 10); Value := V; // circumvent C1093 error on Delphi 5 Value := Value shl 12; if not DateOnly then begin V := T.Second+T.Minute shl 6+T.Hour shl 12; Value := Value+V; end; end; procedure TTimeLogBits.FromUnixTime(const UnixTime: TUnixTime); begin From(UnixTimeToDateTime(UnixTime)); end; procedure TTimeLogBits.FromUnixMSTime(const UnixMSTime: TUnixMSTime); begin From(UnixMSTimeToDateTime(UnixMSTime)); end; procedure TTimeLogBits.From(Time: PSynSystemTime); var V: PtrInt; begin V := Time^.Hour+Time^.Day shl 5+Time^.Month shl 10+Time^.Year shl 14-(1 shl 5+1 shl 10); Value := V; // circumvent C1093 error on Delphi 5 V := Time^.Second+Time^.Minute shl 6; Value := (Value shl 12)+V; end; var // GlobalTime[LocalTime] cache protected using RCU128() GlobalTime: array[boolean] of record time: TSystemTime; clock: PtrInt; // avoid slower API call with 8-16ms loss of precision end; {$ifndef FPC}{$ifdef CPUINTEL} // intrinsic in FPC procedure ReadBarrier; asm {$ifdef CPUX86} lock add dword ptr [esp], 0 {$else} lfence // lfence requires an SSE CPU, which is OK on x86-64 {$endif} end; {$endif}{$endif} procedure RCU32(var src,dst); begin repeat Integer(dst) := Integer(src); ReadBarrier; until Integer(dst)=Integer(src); end; procedure RCU64(var src,dst); begin repeat Int64(dst) := Int64(src); ReadBarrier; until Int64(dst)=Int64(src); end; procedure RCUPtr(var src,dst); begin repeat PtrInt(dst) := PtrInt(src); ReadBarrier; until PtrInt(dst)=PtrInt(src); end; procedure RCU128(var src,dst); var s: THash128Rec absolute src; d: THash128Rec absolute dst; begin repeat d := s; ReadBarrier; until (d.L=s.L) and (d.H=s.H); end; procedure RCU(var src,dst; len: integer); begin repeat {$ifdef FPC}Move{$else}MoveFast{$endif}(src,dst,len); ReadBarrier; until CompareMem(@src,@dst,len); end; procedure FromGlobalTime(LocalTime: boolean; out NewTime: TSynSystemTime); var tix: PtrInt; newtimesys: TSystemTime absolute NewTime; begin with GlobalTime[LocalTime] do begin tix := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 {$ifndef MSWINDOWS}shr 3{$endif}; // Linux: 8ms refresh if clock<>tix then begin // Windows: typically in range of 10-16 ms clock := tix; NewTime.Clear; if LocalTime then GetLocalTime(newtimesys) else {$ifdef MSWINDOWS}GetSystemTime{$else}GetNowUTCSystem{$endif}(newtimesys); RCU128(newtimesys,time); end else RCU128(time,NewTime); end; {$ifndef MSWINDOWS} // those TSystemTime fields are inverted in datih.inc :( tix := newtimesys.DayOfWeek; NewTime.Day := newtimesys.Day; NewTime.DayOfWeek := tix; {$endif} end; procedure TTimeLogBits.FromUTCTime; var now: TSynSystemTime; begin FromGlobalTime(false,now); From(@now); end; procedure TTimeLogBits.FromNow; var now: TSynSystemTime; begin FromGlobalTime(true,now); From(@now); end; function TTimeLogBits.ToTime: TDateTime; var lo: PtrUInt; begin lo := {$ifdef CPU64}Value{$else}PCardinal(@Value)^{$endif}; if lo and (1 shl (6+6+5)-1)=0 then result := 0 else result := EncodeTime((lo shr(6+6))and 31, (lo shr 6)and 63, lo and 63, 0); end; function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean; var d100: TDiv100Rec; begin // faster version by AB Result := False; if (Month<1) or (Month>12) then exit; if (Day <= MonthDays[ ((Year and 3)=0) and ((Year mod 100>0) or (Year mod 400=0))][Month]) and (Year>=1) and (Year<10000) and (Month<13) and (Day>0) then begin if Month>2 then dec(Month,3) else if (Month>0) then begin inc(Month,9); dec(Year); end else exit; // Month <= 0 Div100(Year,d100); Date := (146097*d100.D) shr 2+(1461*d100.M) shr 2+ (153*Month+2) div 5+Day-693900; result := true; end; end; function TTimeLogBits.ToDate: TDateTime; var Y, lo: PtrUInt; begin {$ifdef CPU64} lo := Value; Y := (lo shr (6+6+5+5+4)) and 4095; {$else} Y := (Value shr (6+6+5+5+4)) and 4095; lo := PCardinal(@Value)^; {$endif} if (Y=0) or not TryEncodeDate(Y,1+(lo shr(6+6+5+5))and 15,1+(lo shr(6+6+5))and 31,result) then result := 0; end; function TTimeLogBits.ToDateTime: TDateTime; var Y, lo: PtrUInt; Time: TDateTime; begin {$ifdef CPU64} lo := Value; Y := (lo shr (6+6+5+5+4)) and 4095; {$else} Y := (Value shr (6+6+5+5+4)) and 4095; lo := PCardinal(@Value)^; {$endif} if (Y=0) or not TryEncodeDate(Y,1+(lo shr(6+6+5+5))and 15,1+(lo shr(6+6+5))and 31,result) then result := 0; if (lo and (1 shl(6+6+5)-1)<>0) and TryEncodeTime((lo shr(6+6)) and 31, (lo shr 6)and 63, lo and 63, 0, Time) then result := result+Time; end; function TTimeLogBits.Year: Integer; begin result := (Value shr (6+6+5+5+4)) and 4095; end; function TTimeLogBits.Month: Integer; begin result := 1+(PCardinal(@Value)^ shr (6+6+5+5)) and 15; end; function TTimeLogBits.Day: Integer; begin result := 1+(PCardinal(@Value)^ shr (6+6+5)) and 31; end; function TTimeLogBits.Hour: Integer; begin result := (PCardinal(@Value)^ shr (6+6)) and 31; end; function TTimeLogBits.Minute: Integer; begin result := (PCardinal(@Value)^ shr 6) and 63; end; function TTimeLogBits.Second: Integer; begin result := PCardinal(@Value)^ and 63; end; function TTimeLogBits.ToUnixTime: TUnixTime; begin result := DateTimeToUnixTime(ToDateTime); end; function TTimeLogBits.ToUnixMSTime: TUnixMSTime; begin result := DateTimeToUnixMSTime(ToDateTime); end; function TTimeLogBits.Text(Dest: PUTF8Char; Expanded: boolean; FirstTimeChar: AnsiChar): integer; var lo: PtrUInt; begin if Value=0 then begin result := 0; exit; end; lo := {$ifdef CPU64}Value{$else}PCardinal(@Value)^{$endif}; if lo and (1 shl (6+6+5)-1)=0 then begin // no Time: just convert date DateToIso8601PChar(Dest, Expanded, ({$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5+5+4)) and 4095, 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 // 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 // convert time and date DateToIso8601PChar(Dest, Expanded, ({$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5+5+4)) and 4095, 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); end; end; function TTimeLogBits.Text(Expanded: boolean; FirstTimeChar: AnsiChar = 'T'): RawUTF8; var tmp: array[0..31] of AnsiChar; begin if Value=0 then result := '' else FastSetString(result,@tmp,Text(tmp,Expanded,FirstTimeChar)); end; function TTimeLogBits.i18nText: string; begin if Assigned(i18nDateText) then result := i18nDateText(Value) else result := {$ifdef UNICODE}Ansi7ToString{$endif}(Text(true,' ')); end; function TimeLogNow: TTimeLog; begin PTimeLogBits(@result)^.FromNow; end; function TimeLogNowUTC: TTimeLog; begin PTimeLogBits(@result)^.FromUTCTime; end; function NowToString(Expanded: boolean=true; FirstTimeChar: AnsiChar = ' '): RawUTF8; var I: TTimeLogBits; begin I.FromNow; result := I.Text(Expanded,FirstTimeChar); end; function NowUTCToString(Expanded: boolean=true; FirstTimeChar: AnsiChar = ' '): RawUTF8; var I: TTimeLogBits; begin I.FromUTCTime; result := I.Text(Expanded,FirstTimeChar); end; const DTMS_FMT: array[boolean] of RawUTF8 = ('%%%%%%%%%', '%-%-%%%:%:%.%%'); function DateTimeMSToString(DateTime: TDateTime; Expanded: boolean; FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8; var T: TSynSystemTime; begin // 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format if DateTime=0 then result := '' else begin T.FromDateTime(DateTime); result := DateTimeMSToString(T.Hour,T.Minute,T.Second,T.MilliSecond, T.Year,T.Month,T.Day,Expanded,FirstTimeChar,TZD); end; end; function DateTimeMSToString(HH,MM,SS,MS,Y,M,D: cardinal; Expanded: boolean; FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8; begin // 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format FormatUTF8(DTMS_FMT[Expanded], [UInt4DigitsToShort(Y),UInt2DigitsToShortFast(M), UInt2DigitsToShortFast(D),FirstTimeChar,UInt2DigitsToShortFast(HH), UInt2DigitsToShortFast(MM),UInt2DigitsToShortFast(SS),UInt3DigitsToShort(MS),TZD], result); end; const HTML_WEEK_DAYS: array[1..7] of string[3] = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); HTML_MONTH_NAMES: array[1..12] of string[3] = ('Jan','Feb','Mar','Apr','May','Jun', 'Jul','Aug','Sep','Oct','Nov','Dec'); function DateTimeToHTTPDate(UTCDateTime: TDateTime): RawUTF8; var T: TSynSystemTime; begin if UTCDateTime=0 then begin result := ''; exit; end; T.FromDateTime(UTCDateTime); FormatUTF8('%, % % % %:%:% GMT', [HTML_WEEK_DAYS[DayOfWeek(UTCDateTime)], UInt2DigitsToShortFast(T.Day),HTML_MONTH_NAMES[T.Month],UInt4DigitsToShort(T.Year), UInt2DigitsToShortFast(T.Hour),UInt2DigitsToShortFast(T.Minute), UInt2DigitsToShortFast(T.Second)], result); end; function TimeToString: RawUTF8; var I: TTimeLogBits; begin I.FromNow; I.Value := I.Value and (1 shl (6+6+5)-1); // keep only time result := I.Text(true,' '); end; function TimeLogFromFile(const FileName: TFileName): TTimeLog; var Date: TDateTime; begin Date := FileAgeToDateTime(FileName); if Date=0 then result := 0 else PTimeLogBits(@result)^.From(Date); end; function TimeLogFromDateTime(const DateTime: TDateTime): TTimeLog; begin PTimeLogBits(@result)^.From(DateTime); end; function TimeLogFromUnixTime(const UnixTime: TUnixTime): TTimeLog; begin PTimeLogBits(@result)^.FromUnixTime(UnixTime); end; { TSynSystemTime } function TryEncodeDayOfWeekInMonth(AYear, AMonth, ANthDayOfWeek, ADayOfWeek: integer; out AValue: TDateTime): Boolean; var LStartOfMonth, LDay: integer; begin // adapted from DateUtils result := TryEncodeDate(AYear,AMonth,1,aValue); if not result then exit; LStartOfMonth := (DateTimeToTimestamp(aValue).Date-1)mod 7+1; if LStartOfMonth<=ADayOfWeek then dec(ANthDayOfWeek); LDay := (ADayOfWeek-LStartOfMonth+1)+7*ANthDayOfWeek; result := TryEncodeDate(AYear,AMonth,LDay,AValue); end; function TSynSystemTime.EncodeForTimeChange(const aYear: word): TDateTime; var dow,d: word; begin if DayOfWeek=0 then dow := 7 else // Delphi Sunday = 7 dow := DayOfWeek; // Encoding the day of change d := Day; while not TryEncodeDayOfWeekInMonth(aYear,Month,d,dow,Result) do begin // if Day = 5 then try it and if needed decrement to find the last // occurence of the day in this month if d=0 then begin TryEncodeDayOfWeekInMonth(aYear,Month,1,7,Result); break; end; dec(d); end; // finally add the time when change is due result := result+EncodeTime(Hour,Minute,Second,MilliSecond); end; procedure TSynSystemTime.Clear; begin PInt64Array(@self)[0] := 0; PInt64Array(@self)[1] := 0; end; function TSynSystemTime.IsZero: boolean; begin result := (PInt64Array(@self)[0]=0) and (PInt64Array(@self)[1]=0); end; function TSynSystemTime.IsEqual(const another{$ifndef DELPHI5OROLDER}: TSynSystemTime{$endif}): boolean; begin result := (PInt64Array(@self)[0]=PInt64Array(@another)[0]) and (PInt64Array(@self)[1]=PInt64Array(@another)[1]); end; procedure TSynSystemTime.FromNowUTC; begin FromGlobalTime(false,self); end; procedure TSynSystemTime.FromNowLocal; begin FromGlobalTime(true,self); end; procedure TSynSystemTime.FromDateTime(const dt: TDateTime); begin FromDate(dt); FromTime(dt); end; procedure TSynSystemTime.FromDate(const dt: TDateTime); var t,t2,t3: PtrUInt; begin t := Trunc(dt); t := (t+693900)*4-1; if PtrInt(t)>=0 then begin t3 := t div 146097; t2 := (t-t3*146097) and not 3; t := PtrUInt(t2+3) div 1461; // PtrUInt() needed for FPC i386 Year := t3*100+t; t2 := ((t2+7-t*1461)shr 2)*5; t3 := PtrUInt(t2-3) div 153; Day := PtrUInt(t2+2-t3*153) div 5; if t3<10 then inc(t3,3) else begin dec(t3,9); inc(Year); end; Month := t3; DayOfWeek := 0; end else PInt64(@Year)^ := 0; end; procedure TSynSystemTime.FromTime(const dt: TDateTime); var t,t2: PtrUInt; begin t := round(abs(dt)*MSecsPerDay) mod MSecsPerDay; t2 := t div 3600000; Hour := t2; dec(t,t2*3600000); t2 := t div 60000; Minute := t2; dec(t,t2*60000); t2 := t div 1000; Second := t2; MilliSecond := t-t2*1000; end; function TSynSystemTime.ToText(Expanded: boolean; FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8; begin result := DateTimeMSToString(Hour,Minute,Second,MilliSecond,Year,Month,Day, Expanded,FirstTimeChar,TZD); end; procedure TSynSystemTime.AddLogTime(WR: TTextWriter); var y,d100: PtrUInt; P: PUTF8Char; tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; begin if WR.BEnd-WR.B<=18 then WR.FlushToStream; {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} y := Year; d100 := y div 100; P := WR.B+1; PWord(P)^ := tab[d100]; PWord(P+2)^ := tab[y-(d100*100)]; PWord(P+4)^ := tab[Month]; PWord(P+6)^ := tab[Day]; P[8] := ' '; PWord(P+9)^ := tab[Hour]; PWord(P+11)^ := tab[Minute]; PWord(P+13)^ := tab[Second]; y := Millisecond; PWord(P+15)^ := tab[y shr 4]; inc(WR.B,17); end; function TSynSystemTime.ToNCSAText(P: PUTF8Char): PtrInt; var y,d100: PtrUInt; tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; begin {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} PWord(P)^ := tab[Day]; PCardinal(P+2)^ := PCardinal(@HTML_MONTH_NAMES[Month])^; P[2] := '/'; // overwrite HTML_MONTH_NAMES[][0] P[6] := '/'; y := Year; d100 := y div 100; PWord(P+7)^ := tab[d100]; PWord(P+9)^ := tab[y-(d100*100)]; P[11] := ':'; PWord(P+12)^ := tab[Hour]; P[14] := ':'; PWord(P+15)^ := tab[Minute]; P[17] := ':'; PWord(P+18)^ := tab[Second]; P[20] := ' '; result := 21; end; procedure TSynSystemTime.AddNCSAText(WR: TTextWriter); begin if WR.BEnd-WR.B<=21 then WR.FlushToStream; inc(WR.B,ToNCSAText(WR.B+1)); end; function TSynSystemTime.ToDateTime: TDateTime; var time: TDateTime; begin if TryEncodeDate(Year,Month,Day,result) then if TryEncodeTime(Hour,Minute,Second,MilliSecond,time) then result := result+time else result := 0 else result := 0; end; procedure TSynSystemTime.IncrementMS(ms: integer); begin inc(MilliSecond, ms); if MilliSecond >= 1000 then repeat dec(MilliSecond, 1000); if Second < 60 then inc(Second) else begin Second := 0; if Minute < 60 then inc(Minute) else begin Minute := 0; if Hour < 24 then inc(Hour) else begin Hour := 0; if Day < MonthDays[false, Month] then inc(Day) else begin Day := 1; if Month < 12 then inc(Month) else begin Month := 1; inc(Year); end; end; end; end; end; until MilliSecond < 1000; end; { TTimeZoneData } function TTimeZoneData.GetTziFor(year: integer): PTimeZoneInfo; var i,last: integer; begin if dyn=nil then result := @tzi else if year<=dyn[0].year then result := @dyn[0].tzi else begin last := high(dyn); if year>=dyn[last].year then result := @dyn[last].tzi else begin for i := 1 to last do if year'' then LoadFromBuffer(buf); end; {$ifdef MSWINDOWS} {$ifndef LVCL} procedure TSynTimeZone.LoadFromRegistry; const REGKEY = '\Software\Microsoft\Windows NT\CurrentVersion\Time Zones\'; var Reg: TRegistry; Keys: TStringList; i,first,last,year,n: integer; item: TTimeZoneData; begin fZones.Clear; Keys := TStringList.Create; Reg := TRegistry.Create; try Reg.RootKey := HKEY_LOCAL_MACHINE; if Reg.OpenKeyReadOnly(REGKEY) then try Reg.GetKeyNames(Keys); finally Reg.CloseKey; end; for i := 0 to Keys.Count-1 do begin Finalize(item); FillcharFast(item.tzi,SizeOf(item.tzi),0); if Reg.OpenKeyReadOnly(REGKEY+Keys[i]) then try StringToUTF8(Keys[i],RawUTF8(item.id)); StringToUTF8(Reg.ReadString('Display'),item.Display); Reg.ReadBinaryData('TZI', item.tzi, SizeOf(item.tzi)); finally Reg.CloseKey; end; if Reg.OpenKeyReadOnly(REGKEY+Keys[i]+'\Dynamic DST') then try first := Reg.ReadInteger('FirstEntry'); last := Reg.ReadInteger('LastEntry'); n := 0; SetLength(item.dyn,last-first+1); for year := first to last do if Reg.ReadBinaryData(IntToStr(year),item.dyn[n].tzi, SizeOf(TTimeZoneInfo))=SizeOf(TTimeZoneInfo) then begin item.dyn[n].year := year; inc(n); end; SetLength(item.dyn,n); finally Reg.CloseKey; end; fZones.Add(item); end; finally Reg.Free; Keys.Free; end; fZones.ReHash; FreeAndNil(fIds); FreeAndNil(fDisplays); end; {$endif LVCL} {$endif MSWINDOWS} function TSynTimeZone.GetDisplay(const TzId: TTimeZoneID): RawUTF8; var ndx: integer; begin if self=nil then ndx := -1 else ndx := fZones.FindHashed(TzID); if ndx<0 then result := '' else result := fZone[ndx].display; end; function TSynTimeZone.GetBiasForDateTime(const Value: TDateTime; const TzId: TTimeZoneID; out Bias: integer; out HaveDaylight: boolean): boolean; var ndx: integer; y,m,d: word; tzi: PTimeZoneInfo; std,dlt: TDateTime; begin if (self=nil) or (TzId='') then ndx := -1 else if TzID=fLastZone then ndx := fLastIndex else begin ndx := fZones.FindHashed(TzID); fLastZone := TzID; flastIndex := ndx; end; if ndx<0 then begin Bias := 0; HaveDayLight := false; result := false; exit; end; DecodeDate(Value,y,m,d); tzi := fZone[ndx].GetTziFor(y); if tzi.change_time_std.IsZero then begin HaveDaylight := false; Bias := tzi.Bias+tzi.bias_std; end else begin HaveDaylight := true; std := tzi.change_time_std.EncodeForTimeChange(y); dlt := tzi.change_time_dlt.EncodeForTimeChange(y); if std0) and (size>aMaxSize) then begin // rotate log file if too big FileClose(F); Old := aFileName+'.bak'; // '.log.bak' DeleteFile(Old); // rotate once RenameFile(aFileName,Old); F := FileCreate(aFileName); if PtrInt(F)<0 then exit; end; PWord(@Date)^ := 13+10 shl 8; // first go to next line if aUTCTimeStamp then now.FromNowUTC else now.FromNowLocal; DateToIso8601PChar(@Date[3],true,Now.Year,Now.Month,Now.Day); TimeToIso8601PChar(@Date[13],true,Now.Hour,Now.Minute,Now.Second,0,' '); Date[22] := ' '; FileWrite(F,Date,SizeOf(Date)); for i := 1 to length(aLine) do if aLine[i]<' ' then aLine[i] := ' '; // avoid line feed in text log file FileWrite(F,pointer(aLine)^,length(aLine)); FileClose(F); end; procedure LogToTextFile(Msg: RawUTF8); begin if Msg='' then begin StringToUTF8(SysErrorMessage(GetLastError),Msg); if Msg='' then exit; end; AppendToTextFile(Msg,{$ifndef MSWINDOWS}ExtractFileName{$endif} (ChangeFileExt(ExeVersion.ProgramFileName,'.log'))); end; function IsEqualGUID({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid1, guid2: TGUID): Boolean; begin result := (PHash128Rec(@guid1).L=PHash128Rec(@guid2).L) and (PHash128Rec(@guid1).H=PHash128Rec(@guid2).H); end; function IsEqualGUIDArray({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID; const guids: array of TGUID): integer; begin for result := 0 to high(guids) do if IsEqualGUID(guid,guids[result]) then exit; result := -1; end; function IsNullGUID({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): Boolean; var a: TPtrIntArray absolute guid; begin result := (a[0]=0) and (a[1]=0) {$ifndef CPU64} and (a[2]=0) and (a[3]=0){$endif}; end; function AddGUID(var guids: TGUIDDynArray; const guid: TGUID; NoDuplicates: boolean): integer; begin if NoDuplicates then for result := 0 to length(guids)-1 do if IsEqualGUID(guid,guids[result]) then exit; result := length(guids); SetLength(guids,result+1); guids[result] := guid; end; function GUIDToText(P: PUTF8Char; guid: PByteArray): PUTF8Char; var i: integer; begin // encode as '3F2504E0-4F89-11D3-9A0C-0305E82C3301' for i := 3 downto 0 do begin PWord(P)^ := TwoDigitsHexWB[guid[i]]; inc(P,2); end; inc(PByte(guid),4); for i := 1 to 2 do begin P[0] := '-'; PWord(P+1)^ := TwoDigitsHexWB[guid[1]]; PWord(P+3)^ := TwoDigitsHexWB[guid[0]]; inc(PByte(guid),2); inc(P,5); end; P[0] := '-'; PWord(P+1)^ := TwoDigitsHexWB[guid[0]]; PWord(P+3)^ := TwoDigitsHexWB[guid[1]]; P[5] := '-'; inc(PByte(guid),2); inc(P,6); for i := 0 to 5 do begin PWord(P)^ := TwoDigitsHexWB[guid[i]]; inc(P,2); end; result := P; end; function HexaToByte(P: PUTF8Char; var Dest: byte): boolean; {$ifdef HASINLINE}inline;{$endif} var B,C: PtrUInt; begin B := ConvertHexToBin[Ord(P[0])]; if B<=15 then begin C := ConvertHexToBin[Ord(P[1])]; if C<=15 then begin Dest := B shl 4+C; result := true; exit; end; end; result := false; // mark error end; function TextToGUID(P: PUTF8Char; guid: PByteArray): PUTF8Char; var i: integer; begin // decode from '3F2504E0-4F89-11D3-9A0C-0305E82C3301' result := nil; for i := 3 downto 0 do begin if not HexaToByte(P,guid[i]) then exit; inc(P,2); end; inc(PByte(guid),4); for i := 1 to 2 do begin if (P^<>'-') or not HexaToByte(P+1,guid[1]) or not HexaToByte(P+3,guid[0]) then exit; inc(P,5); inc(PByte(guid),2); end; if (P[0]<>'-') or (P[5]<>'-') or not HexaToByte(P+1,guid[0]) or not HexaToByte(P+3,guid[1]) then exit; inc(PByte(guid),2); inc(P,6); for i := 0 to 5 do if HexaToByte(P,guid[i]) then inc(P,2) else exit; result := P; end; function GUIDToRawUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; var P: PUTF8Char; begin FastSetString(result,nil,38); P := pointer(result); P^ := '{'; GUIDToText(P+1,@guid)^ := '}'; end; function GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): TGUIDShortString; begin GUIDToShort(guid,result); end; procedure GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID; out dest: TGUIDShortString); begin dest[0] := #38; dest[1] := '{'; dest[38] := '}'; GUIDToText(@dest[2],@guid); end; function GUIDToString({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): string; {$ifdef UNICODE} var tmp: array[0..35] of AnsiChar; i: integer; begin GUIDToText(tmp,@guid); SetString(result,nil,38); PWordArray(result)[0] := ord('{'); for i := 1 to 36 do PWordArray(result)[i] := ord(tmp[i-1]); // no conversion for 7 bit Ansi PWordArray(result)[37] := ord('}'); end; {$else} begin result := GUIDToRawUTF8(guid); end; {$endif} {$ifdef CPUINTEL} /// NIST SP 800-90A compliant RDRAND Intel x86/x64 opcode function RdRand32: cardinal; {$ifdef CPU64}{$ifdef FPC}nostackframe; assembler; asm{$else} asm .noframe {$endif FPC} {$else} {$ifdef FPC}nostackframe; assembler;{$endif} asm {$endif} // rdrand eax: same opcodes for x86 and x64 db $0f,$c7,$f0 // returns in eax, ignore carry flag (eax=0 won't hurt) end; {$endif CPUINTEL} threadvar _Lecuyer: TLecuyer; // uses only 16 bytes per thread procedure TLecuyer.Seed(entropy: PByteArray; entropylen: PtrInt); var time, crc: THash128Rec; i, j: PtrInt; begin repeat QueryPerformanceCounter(time.Lo); time.Hi := UnixMSTimeUTC xor PtrUInt(GetCurrentThreadID); crcblock(@crc.b,@time.b); crcblock(@crc.b,@ExeVersion.Hash.b); if entropy<>nil then for i := 0 to entropylen-1 do begin j := i and 15; crc.b[j] := crc.b[j] xor entropy^[i]; end; rs1 := rs1 xor crc.c0; rs2 := rs2 xor crc.c1; rs3 := rs3 xor crc.c2; {$ifdef CPUINTEL} if cfRAND in CpuFeatures then begin // won't hurt e.g. from Random32gsl rs1 := rs1 xor RdRand32; rs2 := rs2 xor RdRand32; rs3 := rs3 xor RdRand32; end; {$endif CPUINTEL} until (rs1>1) and (rs2>7) and (rs3>15); seedcount := 1; for i := 1 to crc.i3 and 15 do Next; // warm up end; function TLecuyer.Next: cardinal; begin if word(seedcount)=0 then // reseed after 256KB of output Seed(nil,0) else inc(seedcount); result := rs1; rs1 := ((result and -2)shl 12) xor (((result shl 13)xor result)shr 19); result := rs2; rs2 := ((result and -8)shl 4) xor (((result shl 2)xor result)shr 25); result := rs3; rs3 := ((result and -16)shl 17) xor (((result shl 3)xor result)shr 11); result := rs1 xor rs2 xor result; end; function TLecuyer.Next(max: cardinal): cardinal; begin result := (QWord(Next)*max)shr 32; end; procedure Random32Seed(entropy: pointer; entropylen: integer); begin _Lecuyer.Seed(entropy,entropylen); end; function Random32: cardinal; begin {$ifdef CPUINTEL} if cfRAND in CpuFeatures then result := RdRand32 else {$endif} result := _Lecuyer.Next; end; function Random32(max: cardinal): cardinal; begin result := (QWord(Random32)*max)shr 32; end; function Random32gsl: cardinal; begin result := _Lecuyer.Next; end; function Random32gsl(max: cardinal): cardinal; begin result := (QWord(_Lecuyer.Next)*max)shr 32; end; procedure FillRandom(Dest: PCardinalArray; CardinalCount: integer; forcegsl: boolean); var i: PtrInt; c: cardinal; seed: TQWordRec; lecuyer: ^TLecuyer; begin {$ifdef CPUINTEL} if (cfRAND in CpuFeatures) and not forcegsl then lecuyer := nil else {$endif} lecuyer := @_Lecuyer; QueryPerformanceCounter(PInt64(@seed)^); c := crc32cBy4(seed.L,seed.H); {$ifdef CPUINTEL} if lecuyer=nil then for i := 0 to CardinalCount-1 do begin c := crc32cBy4(c,RdRand32); // won't trust plain Intel values Dest^[i] := Dest^[i] xor c; end else {$endif} for i := 0 to CardinalCount-1 do begin c := c xor lecuyer^.Next; Dest^[i] := Dest^[i] xor c; end; end; function RandomGUID: TGUID; begin FillRandom(@result,SizeOf(TGUID) shr 2); end; procedure RandomGUID(out result: TGUID); begin FillRandom(@result,SizeOf(TGUID) shr 2); end; procedure FillZero(var result: TGUID); begin FillZero(PHash128(@result)^); end; function RawUTF8ToGUID(const text: RawByteString): TGUID; begin if (length(text)<>38) or (text[1]<>'{') or (text[38]<>'}') or (TextToGUID(@text[2],@result)=nil) then FillZero(PHash128(@result)^); end; function StringToGUID(const text: string): TGUID; {$ifdef UNICODE} var tmp: array[0..35] of byte; i: integer; {$endif} begin if (length(text)=38) and (text[1]='{') and (text[38]='}') then begin {$ifdef UNICODE} for i := 0 to 35 do tmp[i] := PWordArray(text)[i+1]; if TextToGUID(@tmp,@result)<>nil then {$else} if TextToGUID(@text[2],@result)<>nil then {$endif} exit; // conversion OK end; FillZero(PHash128(@result)^); end; function StrCurr64(P: PAnsiChar; const Value: Int64): PAnsiChar; var c: QWord; d: cardinal; {$ifndef CPU64}c64: Int64Rec absolute c;{$endif} begin if Value=0 then begin result := P-1; result^ := '0'; exit; end; if Value<0 then c := -Value else c := Value; if {$ifdef CPU64}c<10000{$else}(c64.Hi=0) and (c64.Lo<10000){$endif} then begin result := P-6; // only decimals -> append '0.xxxx' PWord(result)^ := ord('0')+ord('.')shl 8; YearToPChar(c,PUTF8Char(P)-4); end else begin result := StrUInt64(P-1,c); d := PCardinal(P-5)^; // in two explit steps for CPUARM (alf) PCardinal(P-4)^ := d; P[-5] := '.'; // insert '.' just before last 4 decimals end; if Value<0 then begin dec(result); result^ := '-'; end; end; procedure Curr64ToStr(const Value: Int64; var result: RawUTF8); var tmp: array[0..31] of AnsiChar; P: PAnsiChar; Decim, L: Cardinal; begin if Value=0 then result := SmallUInt32UTF8[0] else begin P := StrCurr64(@tmp[31],Value); L := @tmp[31]-P; if L>4 then begin Decim := PCardinal(P+L-SizeOf(cardinal))^; // 4 last digits = 4 decimals if Decim=ord('0')+ord('0')shl 8+ord('0')shl 16+ord('0')shl 24 then dec(L,5) else // no decimal if Decim and $ffff0000=ord('0')shl 16+ord('0')shl 24 then dec(L,2); // 2 decimals end; FastSetString(result,P,L); end; end; function Curr64ToStr(const Value: Int64): RawUTF8; begin Curr64ToStr(Value,result); end; function CurrencyToStr(Value: currency): RawUTF8; begin result := Curr64ToStr(PInt64(@Value)^); end; function Curr64ToPChar(const Value: Int64; Dest: PUTF8Char): PtrInt; var tmp: array[0..31] of AnsiChar; P: PAnsiChar; Decim: Cardinal; begin P := StrCurr64(@tmp[31],Value); result := @tmp[31]-P; if result>4 then begin Decim := PCardinal(P+result-SizeOf(cardinal))^; // 4 last digits = 4 decimals if Decim=ord('0')+ord('0')shl 8+ord('0')shl 16+ord('0')shl 24 then dec(result,5) else // no decimal if Decim and $ffff0000=ord('0')shl 16+ord('0')shl 24 then dec(result,2); // 2 decimals end; {$ifdef FPC}Move{$else}MoveFast{$endif}(P^,Dest^,result); end; function StrToCurr64(P: PUTF8Char; NoDecimal: PBoolean=nil): Int64; var c: cardinal; minus: boolean; Dec: cardinal; begin result := 0; if P=nil then exit; while (P^<=' ') and (P^<>#0) do inc(P); if P^='-' then begin minus := true; repeat inc(P) until P^<>' '; end else begin minus := false; if P^='+' then repeat inc(P) until P^<>' '; end; if P^='.' then begin // '.5' -> 500 Dec := 2; inc(P); end else Dec := 0; c := byte(P^)-48; if c>9 then exit; PCardinal(@result)^ := c; inc(P); repeat if P^<>'.' then begin c := byte(P^)-48; if c>9 then break; {$ifdef CPU32DELPHI} result := result shl 3+result+result; {$else} result := result*10; {$endif} inc(result,c); inc(P); if Dec<>0 then begin inc(Dec); if Dec<5 then continue else break; end; end else begin inc(Dec); inc(P); end; until false; if NoDecimal<>nil then if Dec=0 then begin NoDecimal^ := true; if minus then result := -result; exit; end else NoDecimal^ := false; if Dec<>5 then // Dec=5 most of the time case Dec of 0,1: result := result*10000; {$ifdef CPU32DELPHI} 2: result := result shl 10-result shl 4-result shl 3; 3: result := result shl 6+result shl 5+result shl 2; 4: result := result shl 3+result+result; {$else} 2: result := result*1000; 3: result := result*100; 4: result := result*10; {$endif} end; if minus then result := -result; end; function StrToCurrency(P: PUTF8Char): currency; begin PInt64(@result)^ := StrToCurr64(P,nil); end; function TruncTo2Digits(Value: Currency): Currency; var V64: Int64 absolute Value; // to avoid any floating-point precision issues begin dec(V64,V64 mod 100); result := Value; end; procedure TruncTo2DigitsCurr64(var Value: Int64); begin dec(Value,Value mod 100); end; function SimpleRoundTo2Digits(Value: Currency): Currency; var V64: Int64 absolute Value; // to avoid any floating-point precision issues begin SimpleRoundTo2DigitsCurr64(V64); result := Value; end; procedure SimpleRoundTo2DigitsCurr64(var Value: Int64); var Spare: PtrInt; begin Spare := Value mod 100; if Spare<>0 then if Spare>50 then inc(Value,100-Spare) else if Spare<-50 then dec(Value,100+Spare) else dec(Value,Spare); end; function TrimLeftLowerCase(const V: RawUTF8): PUTF8Char; begin result := Pointer(V); if result<>nil then begin while result^ in ['a'..'z'] do inc(result); if result^=#0 then result := Pointer(V); end; end; function TrimLeftLowerCaseToShort(V: PShortString): ShortString; begin TrimLeftLowerCaseToShort(V,result); end; procedure TrimLeftLowerCaseToShort(V: PShortString; out result: ShortString); var P: PAnsiChar; L: integer; begin L := length(V^); P := @V^[1]; while (L>0) and (P^ in ['a'..'z']) do begin inc(P); dec(L); end; if L=0 then result := V^ else SetString(result,P,L); end; {$ifdef FPC_OR_PUREPASCAL} function TrimLeftLowerCaseShort(V: PShortString): RawUTF8; var P: PAnsiChar; L: integer; begin L := length(V^); P := @V^[1]; while (L>0) and (P^ in ['a'..'z']) do begin inc(P); dec(L); end; if L=0 then FastSetString(result,@V^[1],length(V^)) else FastSetString(result,P,L); end; {$else} function TrimLeftLowerCaseShort(V: PShortString): RawUTF8; asm // eax=V xor ecx, ecx push edx // save result RawUTF8 test eax, eax jz @2 // avoid GPF lea edx, [eax + 1] mov cl, [eax] @1: mov ch, [edx] // edx=source cl=length sub ch, 'a' sub ch, 'z' - 'a' ja @2 // not a lower char -> create a result string starting at edx inc edx dec cl jnz @1 mov cl, [eax] lea edx, [eax + 1] // no UpperCase -> retrieve full text (result := V^) @2: pop eax movzx ecx, cl {$ifdef UNICODE} push CP_UTF8 // UTF-8 code page for Delphi 2009+ + call below, not jump call System.@LStrFromPCharLen // eax=Dest edx=Source ecx=Length rep ret // we need a call just above for right push CP_UTF8 retrieval {$else} jmp System.@LStrFromPCharLen // eax=dest edx=source ecx=length(source) {$endif} end; {$endif FPC_OR_PUREPASCAL} function UnCamelCase(const S: RawUTF8): RawUTF8; begin result := ''; if S='' then exit; SetLength(result,length(S)*2); // max length SetLength(result,UnCamelCase(pointer(result),pointer(S))); end; function UnCamelCase(D, P: PUTF8Char): integer; var Space, SpaceBeg, DBeg: PUTF8Char; CapitalCount: integer; Number: boolean; label Next; begin DBeg := D; if (D<>nil) and (P<>nil) then begin // avoid GPF Space := D; SpaceBeg := D; repeat CapitalCount := 0; Number := P^ in ['0'..'9']; if Number then repeat inc(CapitalCount); D^ := P^; inc(P); inc(D); until not (P^ in ['0'..'9']) else repeat inc(CapitalCount); D^ := P^; inc(P); inc(D); until not (P^ in ['A'..'Z']); if P^=#0 then break; // no lowercase conversion of last fully uppercased word if (CapitalCount > 1) and not Number then begin dec(P); dec(D); end; while P^ in ['a'..'z'] do begin D^ := P^; inc(D); inc(P); end; if P^='_' then if P[1]='_' then begin D^ := ':'; inc(P); inc(D); goto Next; end else begin PWord(D)^ := ord(' ')+ord('-')shl 8; inc(D,2); Next: if Space=SpaceBeg then SpaceBeg := D+1; inc(P); Space := D+1; end else Space := D; if P^=#0 then break; D^ := ' '; inc(D); until false; if Space>DBeg then dec(Space); while Space>SpaceBeg do begin if Space^ in ['A'..'Z'] then if not (Space[1] in ['A'..'Z',' ']) then inc(Space^,32); // lowercase conversion of not last fully uppercased word dec(Space); end; end; result := D-DBeg; end; procedure CamelCase(P: PAnsiChar; len: integer; var s: RawUTF8; const isWord: TSynByteSet); var i: integer; d: PAnsiChar; tmp: array[byte] of AnsiChar; begin if len > SizeOf(tmp) then len := SizeOf(tmp); for i := 0 to len - 1 do if not (ord(P[i]) in isWord) then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(P^,tmp,i); inc(P,i); d := @tmp[i]; dec(len,i); while len > 0 do begin while (len > 0) and not (ord(P^) in isWord) do begin inc(P); dec(len); end; if len = 0 then break; d^ := NormToUpperAnsi7[P^]; inc(d); repeat inc(P); dec(len); if not (ord(P^) in isWord) then break; d^ := P^; inc(d); until len = 0; end; P := @tmp; len := d-tmp; break; end; FastSetString(s,P,len); end; procedure CamelCase(const text: RawUTF8; var s: RawUTF8; const isWord: TSynByteSet); begin CamelCase(pointer(text), length(text), s, isWord); end; procedure GetCaptionFromPCharLen(P: PUTF8Char; out result: string); var Temp: array[byte] of AnsiChar; begin // "out result" parameter definition already made result := '' if P=nil then exit; {$ifdef UNICODE} // property and enumeration names are UTF-8 encoded with Delphi 2009+ UTF8DecodeToUnicodeString(Temp,UnCamelCase(@Temp,P),result); {$else} SetString(result,Temp,UnCamelCase(@Temp,P)); {$endif} {$ifndef LVCL} // LVCL system.pas doesn't implement LoadResStringTranslate() if Assigned(LoadResStringTranslate) then LoadResStringTranslate(result); {$endif} end; function GetDisplayNameFromClass(C: TClass): RawUTF8; var DelphiName: PShortString; TrimLeft: integer; begin if C=nil then begin result := ''; exit; end; DelphiName := ClassNameShort(C); TrimLeft := 0; if DelphiName^[0]>#4 then case PInteger(@DelphiName^[1])^ and $DFDFDFDF of // fast case-insensitive compare ord('T')+ord('S')shl 8+ord('Q')shl 16+ord('L')shl 24: if (DelphiName^[0]<=#10) or (PInteger(@DelphiName^[5])^ and $DFDFDFDF<> // fast case-insensitive compare ord('R')+ord('E')shl 8+ord('C')shl 16+ord('O')shl 24) or (PWord(@DelphiName^[9])^ and $DFDF<>ord('R')+ord('D')shl 8) then TrimLeft := 4 else TrimLeft := 10; ord('T')+ord('S')shl 8+ord('Y')shl 16+ord('N')shl 24: TrimLeft := 4; end; if (Trimleft=0) and (DelphiName^[1]='T') then Trimleft := 1; FastSetString(result,@DelphiName^[TrimLeft+1],ord(DelphiName^[0])-TrimLeft); end; function ClassNameShort(C: TClass): PShortString; // new TObject.ClassName is UnicodeString (since Delphi 2009) -> inline code // with vmtClassName = UTF-8 encoded text stored in a shortstring = -44 begin result := PPointer(PtrInt(PtrUInt(C))+vmtClassName)^; end; function ClassNameShort(Instance: TObject): PShortString; begin result := PPointer(PPtrInt(Instance)^+vmtClassName)^; end; function ToText(C: TClass): RawUTF8; var P: PShortString; begin if C=nil then result := '' else begin P := PPointer(PtrInt(PtrUInt(C))+vmtClassName)^; FastSetString(result,@P^[1],ord(P^[0])); end; end; procedure ToText(C: TClass; var result: RawUTF8); var P: PShortString; begin if C=nil then result := '' else begin P := PPointer(PtrInt(PtrUInt(C))+vmtClassName)^; FastSetString(result,@P^[1],ord(P^[0])); end; end; function GetPublishedMethods(Instance: TObject; out Methods: TPublishedMethodInfoDynArray; aClass: TClass): integer; procedure AddParentsFirst(C: TClass); type TMethodInfo = packed record {$ifdef FPC} Name: PShortString; Addr: Pointer; {$else} Len: Word; Addr: Pointer; Name: ShortString; {$endif} end; var Table: {$ifdef FPC}PCardinalArray{$else}PWordArray{$endif}; M: ^TMethodInfo; i: integer; begin if C=nil then exit; AddParentsFirst(C.ClassParent); // put children published methods afterward Table := PPointer(PtrUInt(C)+PtrUInt(vmtMethodTable))^; if Table=nil then exit; SetLength(Methods,result+Table^[0]); M := @Table^[1]; for i := 1 to Table^[0] do // Table^[0] = methods count with Methods[result] do begin ShortStringToAnsi7String(M^.Name{$ifdef FPC}^{$endif},Name); Method.Data := Instance; Method.Code := M^.Addr; {$ifdef FPC} inc(M); {$else} inc(PByte(M),M^.Len); {$endif} inc(result); end; end; begin result := 0; if aClass <> nil then AddParentsFirst(aClass) else if Instance<>nil then AddParentsFirst(PPointer(Instance)^); // use recursion for adding end; function GetCaptionFromClass(C: TClass): string; var tmp: RawUTF8; P: PUTF8Char; begin if C=nil then result := '' else begin ToText(C,tmp); P := pointer(tmp); if IdemPChar(P,'TSQL') or IdemPChar(P,'TSYN') then inc(P,4) else if P^='T' then inc(P); GetCaptionFromPCharLen(P,result); end; end; function GetCaptionFromEnum(aTypeInfo: pointer; aIndex: integer): string; begin GetCaptionFromTrimmed(GetEnumName(aTypeInfo,aIndex),result); end; function CharSetToCodePage(CharSet: integer): cardinal; begin case CharSet of SHIFTJIS_CHARSET: result := 932; HANGEUL_CHARSET: result := 949; GB2312_CHARSET: result := 936; HEBREW_CHARSET: result := 1255; ARABIC_CHARSET: result := 1256; GREEK_CHARSET: result := 1253; TURKISH_CHARSET: result := 1254; VIETNAMESE_CHARSET: result := 1258; THAI_CHARSET: result := 874; EASTEUROPE_CHARSET: result := 1250; RUSSIAN_CHARSET: result := 1251; BALTIC_CHARSET: result := 1257; else result := CODEPAGE_US; // default is ANSI_CHARSET = iso-8859-1 = windows-1252 end; end; function CodePageToCharSet(CodePage: Cardinal): Integer; begin case CodePage of 932: result := SHIFTJIS_CHARSET; 949: result := HANGEUL_CHARSET; 936: result := GB2312_CHARSET; 1255: result := HEBREW_CHARSET; 1256: result := ARABIC_CHARSET; 1253: result := GREEK_CHARSET; 1254: result := TURKISH_CHARSET; 1258: result := VIETNAMESE_CHARSET; 874: result := THAI_CHARSET; 1250: result := EASTEUROPE_CHARSET; 1251: result := RUSSIAN_CHARSET; 1257: result := BALTIC_CHARSET; else result := ANSI_CHARSET; // default is iso-8859-1 = windows-1252 end; end; function GetMimeContentTypeFromBuffer(Content: Pointer; Len: integer; const DefaultContentType: RawUTF8): RawUTF8; begin result := DefaultContentType; if (Content<>nil) and (Len>4) then case PCardinal(Content)^ of $04034B50: result := 'application/zip'; // 50 4B 03 04 $46445025: result := 'application/pdf'; // 25 50 44 46 2D 31 2E $21726152: result := 'application/x-rar-compressed'; // 52 61 72 21 1A 07 00 $AFBC7A37: result := 'application/x-7z-compressed'; // 37 7A BC AF 27 1C $694C5153: result := 'application/x-sqlite3'; // SQlite format 3 = 53 51 4C 69 $75B22630: result := 'audio/x-ms-wma'; // 30 26 B2 75 8E 66 $9AC6CDD7: result := 'video/x-ms-wmv'; // D7 CD C6 9A 00 00 $474E5089: result := 'image/png'; // 89 50 4E 47 0D 0A 1A 0A $38464947: result := 'image/gif'; // 47 49 46 38 $46464F77: result := 'application/font-woff'; // wOFF in BigEndian $46464952: if Len>16 then // RIFF case PCardinalArray(Content)^[2] of $50424557: result := 'image/webp'; $20495641: if PCardinalArray(Content)^[3]=$5453494C then result := 'video/x-msvideo'; // Windows Audio Video Interleave file end; $002A4949, $2A004D4D, $2B004D4D: result := 'image/tiff'; // 49 49 2A 00 or 4D 4D 00 2A or 4D 4D 00 2B $E011CFD0: // Microsoft Office applications D0 CF 11 E0=DOCFILE if Len>600 then case PWordArray(Content)^[256] of // at offset 512 $A5EC: result := 'application/msword'; // EC A5 C1 00 $FFFD: // FD FF FF case PByteArray(Content)^[516] of $0E,$1C,$43: result := 'application/vnd.ms-powerpoint'; $10,$1F,$20,$22,$23,$28,$29: result := 'application/vnd.ms-excel'; end; end; $5367674F: if Len>14 then // OggS if (PCardinalArray(Content)^[1]=$00000200) and (PCardinalArray(Content)^[2]=$00000000) and (PWordArray(Content)^[6]=$0000) then result := 'video/ogg'; $1C000000: if Len>12 then if PCardinalArray(Content)^[1]=$70797466 then // ftyp case PCardinalArray(Content)^[2] of $6D6F7369, // isom: ISO Base Media file (MPEG-4) v1 $3234706D: // mp42: MPEG-4 video/QuickTime file result := 'video/mp4'; $35706733: // 3gp5: MPEG-4 video files result := 'video/3gpp'; end; else case PCardinal(Content)^ and $00ffffff of $685A42: result := 'application/bzip2'; // 42 5A 68 $088B1F: result := 'application/gzip'; // 1F 8B 08 $492049: result := 'image/tiff'; // 49 20 49 $FFD8FF: result := JPEG_CONTENT_TYPE; // FF D8 FF DB/E0/E1/E2/E3/E8 else case PWord(Content)^ of $4D42: result := 'image/bmp'; // 42 4D end; end; end; end; function GetMimeContentType(Content: Pointer; Len: integer; const FileName: TFileName): RawUTF8; begin // see http://www.garykessler.net/library/file_sigs.html for magic numbers if Content<>nil then result := GetMimeContentTypeFromBuffer(Content,Len,'') else result := ''; if (result='') and (FileName<>'') then begin result := LowerCase(StringToAnsi7(ExtractFileExt(FileName))); case PosEx(copy(result,2,4), 'png,gif,tiff,jpg,jpeg,bmp,doc,htm,html,css,js,ico,wof,txt,svg,'+ // 1 5 9 14 18 23 27 31 35 40 44 47 51 55 59 'atom,rdf,rss,webp,appc,mani,docx,xml,json,woff,ogg,ogv,mp4,m2v,'+ // 63 68 72 76 81 86 91 96 100 105 110 114 118 122 'm2p,mp3,h264,text,log,gz') of // 126 130 134 139 144 148 1: result := 'image/png'; 5: result := 'image/gif'; 9: result := 'image/tiff'; 14,18: result := JPEG_CONTENT_TYPE; 23: result := 'image/bmp'; 27,91: result := 'application/msword'; 31,35: result := HTML_CONTENT_TYPE; 40: result := 'text/css'; 44: result := 'application/javascript'; // text/javascript and application/x-javascript are obsolete (RFC 4329) 47: result := 'image/x-icon'; 51,105: result := 'application/font-woff'; 55,139,144: result := TEXT_CONTENT_TYPE; 59: result := 'image/svg+xml'; 63,68,72,96: result := XML_CONTENT_TYPE; 76: result := 'image/webp'; 81,86: result := 'text/cache-manifest'; 100: result := JSON_CONTENT_TYPE_VAR; 110,114: result := 'video/ogg'; // RFC 5334 118: result := 'video/mp4'; // RFC 4337 6381 122,126: result := 'video/mp2'; 130: result := 'audio/mpeg'; // RFC 3003 134: result := 'video/H264'; // RFC 6184 148: result := 'application/gzip'; else if result<>'' then result := 'application/'+copy(result,2,10); end; end; if result='' then result := BINARY_CONTENT_TYPE; end; function GetMimeContentTypeHeader(const Content: RawByteString; const FileName: TFileName): RawUTF8; begin result := HEADER_CONTENT_TYPE+ GetMimeContentType(Pointer(Content),length(Content),FileName); end; function IsContentCompressed(Content: Pointer; Len: integer): boolean; begin // see http://www.garykessler.net/library/file_sigs.html result := false; if (Content<>nil) and (Len>8) then case PCardinal(Content)^ of $002a4949, $2a004d4d, $2b004d4d, // 'image/tiff' $04034b50, // 'application/zip' = 50 4B 03 04 $184d2204, // LZ4 stream format = 04 22 4D 18 $21726152, // 'application/x-rar-compressed' = 52 61 72 21 1A 07 00 $28635349, // cab = 49 53 63 28 $38464947, // 'image/gif' = 47 49 46 38 $43614c66, // FLAC = 66 4C 61 43 00 00 00 22 $4643534d, // cab = 4D 53 43 46 [MSCF] $46464952, // avi,webp,wav = 52 49 46 46 [RIFF] $46464f77, // 'application/font-woff' = wOFF in BigEndian $474e5089, // 'image/png' = 89 50 4E 47 0D 0A 1A 0A $4d5a4cff, // LZMA = FF 4C 5A 4D 41 00 $75b22630, // 'audio/x-ms-wma' = 30 26 B2 75 8E 66 $766f6f6d, // mov = 6D 6F 6F 76 [....moov] $89a8275f, // jar = 5F 27 A8 89 $9ac6cdd7, // 'video/x-ms-wmv' = D7 CD C6 9A 00 00 $a5a5a5a5, // .mab file = MAGIC_MAB in SynLog.pas $a5aba5a5, // .data = TSQLRESTSTORAGEINMEMORY_MAGIC in mORMot.pas $aba51051, // .log.synlz = LOG_MAGIC in SynLog.pas $aba5a5ab, // .dbsynlz = SQLITE3_MAGIC in SynSQLite3.pas $afbc7a37, // 'application/x-7z-compressed' = 37 7A BC AF 27 1C $b7010000, $ba010000, // mpeg = 00 00 01 Bx $cececece, // jceks = CE CE CE CE $e011cfd0: // msi = D0 CF 11 E0 A1 B1 1A E1 result := true; else case PCardinal(Content)^ and $00ffffff of $088b1f, // 'application/gzip' = 1F 8B 08 $334449, // mp3 = 49 44 33 [ID3] $492049, // 'image/tiff' = 49 20 49 $535746, // swf = 46 57 53 [FWS] $535743, // swf = 43 57 53 [zlib] $53575a, // zws/swf = 5A 57 53 [FWS] $564c46, // flv = 46 4C 56 [FLV] $685a42, // 'application/bzip2' = 42 5A 68 $ffd8ff: // JPEG_CONTENT_TYPE = FF D8 FF DB/E0/E1/E2/E3/E8 result := true; else case PCardinalArray(Content)^[1] of // 4 byte offset 1{TAlgoSynLZ.AlgoID}: // crc32 01 00 00 00 crc32 = Compress() header result := PCardinalArray(Content)^[0]<>PCardinalArray(Content)^[2]; $70797466, // mp4,mov = 66 74 79 70 [33 67 70 35/4D 53 4E 56..] $766f6f6d: // mov = 6D 6F 6F 76 result := true; end; end; end; end; function GetJpegSize(jpeg: PAnsiChar; len: integer; out Height, Width: integer): boolean; var je: PAnsiChar; begin // see https://en.wikipedia.org/wiki/JPEG#Syntax_and_structure result := false; if (jpeg=nil) or (len<100) or (PWord(jpeg)^<>$d8ff) then // SOI exit; je := jpeg+len-1; inc(jpeg,2); while jpeg#$ff then exit; inc(jpeg); case ord(jpeg^) of $c0..$c3,$c5..$c7,$c9..$cb,$cd..$cf: begin // SOF Height := swap(PWord(jpeg+4)^); Width := swap(PWord(jpeg+6)^); result := (Height>0) and (Height<20000) and (Width>0) and (Width<20000); exit; end; $d0..$d8,$01: inc(jpeg); // RST, SOI $d9: break; // EOI $ff: ; // padding else inc(jpeg,swap(PWord(jpeg+1)^)+1); end; end; end; function GetJpegSize(const jpeg: TFileName; out Height, Width: integer): boolean; var map: TMemoryMap; begin if map.Map(jpeg) then try result := GetJpegSize(map.Buffer,map.Size,Height,Width); finally map.UnMap; end else result := false; end; function IsHTMLContentTypeTextual(Headers: PUTF8Char): Boolean; begin result := ExistsIniNameValue(Headers,HEADER_CONTENT_TYPE_UPPER, [JSON_CONTENT_TYPE_UPPER,'TEXT/','APPLICATION/XML','APPLICATION/JAVASCRIPT', 'APPLICATION/X-JAVASCRIPT','IMAGE/SVG+XML']); end; function MultiPartFormDataDecode(const MimeType,Body: RawUTF8; var MultiPart: TMultiPartDynArray): boolean; var boundary,endBoundary: RawUTF8; i,j: integer; P: PUTF8Char; part: TMultiPart; begin result := false; i := PosEx('boundary=',MimeType); if i=0 then exit; boundary := trim(copy(MimeType,i+9,200)); if (boundary<>'') and (boundary[1]='"') then boundary := copy(boundary,2,length(boundary)-2); // "boundary" -> boundary boundary := '--'+boundary; endBoundary := boundary+'--'+#13#10; boundary := boundary+#13#10; i := PosEx(boundary,Body); if i<>0 then repeat inc(i,length(boundary)); if i=length(body) then exit; // reached the end P := PUTF8Char(Pointer(Body))+i-1; Finalize(part); repeat if IdemPChar(P,'CONTENT-DISPOSITION: ') then begin inc(P,21); if IdemPCharAndGetNextItem(P,'FORM-DATA; NAME="',part.Name,'"') then IdemPCharAndGetNextItem(P,'; FILENAME="',part.FileName,'"') else IdemPCharAndGetNextItem(P,'FILE; FILENAME="',part.FileName,'"') end else if not IdemPCharAndGetNextItem(P,'CONTENT-TYPE: ',part.ContentType) then IdemPCharAndGetNextItem(P,'CONTENT-TRANSFER-ENCODING: ',part.Encoding); P := GotoNextLine(P); if P=nil then exit; until PWord(P)^=13+10 shl 8; i := P-PUTF8Char(Pointer(Body))+3; // i = just after header j := PosEx(boundary,Body,i); if j=0 then begin j := PosEx(endboundary,Body,i); // try last boundary if j=0 then exit; end; part.Content := copy(Body,i,j-i-2); // -2 to ignore latest #13#10 if (part.ContentType='') or (PosEx('-8',part.ContentType)>0) then begin part.ContentType := TEXT_CONTENT_TYPE; {$ifdef HASCODEPAGE} SetCodePage(part.Content,CP_UTF8,false); // ensure raw field value is UTF-8 {$endif} end; if IdemPropNameU(part.Encoding,'base64') then part.Content := Base64ToBin(part.Content); // note: "quoted-printable" not yet handled here SetLength(MultiPart,length(MultiPart)+1); MultiPart[high(MultiPart)] := part; result := true; i := j; until false; end; function MultiPartFormDataEncode(const MultiPart: TMultiPartDynArray; var MultiPartContentType, MultiPartContent: RawUTF8): boolean; var len, boundcount, filescount, i: integer; boundaries: array of RawUTF8; bound: RawUTF8; W: TTextWriter; temp: TTextWriterStackBuffer; procedure NewBound; var random: array[1..3] of cardinal; begin FillRandom(@random,3); bound := BinToBase64(@random,SizeOf(Random)); SetLength(boundaries,boundcount+1); boundaries[boundcount] := bound; inc(boundcount); end; begin result := false; len := length(MultiPart); if len=0 then exit; boundcount := 0; filescount := 0; W := TTextWriter.CreateOwnedStream(temp); try // header - see https://www.w3.org/Protocols/rfc1341/7_2_Multipart.html NewBound; MultiPartContentType := 'Content-Type: multipart/form-data; boundary='+bound; for i := 0 to len-1 do with MultiPart[i] do begin if FileName='' then W.Add('--%'#13#10'Content-Disposition: form-data; name="%"'#13#10+ 'Content-Type: %'#13#10#13#10'%'#13#10'--%'#13#10, [bound,Name,ContentType,Content,bound]) else begin // if this is the first file, create the header for files if filescount=0 then begin if i>0 then NewBound; W.Add('Content-Disposition: form-data; name="files"'#13#10+ 'Content-Type: multipart/mixed; boundary=%'#13#10#13#10,[bound]); end; inc(filescount); W.Add('--%'#13#10'Content-Disposition: file; filename="%"'#13#10+ 'Content-Type: %'#13#10,[bound,FileName,ContentType]); if Encoding<>'' then W.Add('Content-Transfer-Encoding: %'#13#10,[Encoding]); W.AddCR; W.AddString(MultiPart[i].Content); W.Add(#13#10'--%'#13#10,[bound]); end; end; // footer multipart for i := boundcount-1 downto 0 do W.Add('--%--'#13#10, [boundaries[i]]); W.SetText(MultiPartContent); result := True; finally W.Free; end; end; function MultiPartFormDataAddFile(const FileName: TFileName; var MultiPart: TMultiPartDynArray; const Name: RawUTF8): boolean; var part: TMultiPart; newlen: integer; content: RawByteString; begin result := false; content := StringFromFile(FileName); if content='' then exit; newlen := length(MultiPart)+1; if Name='' then FormatUTF8('File%',[newlen],part.Name) else part.Name := Name; part.FileName := StringToUTF8(ExtractFileName(FileName)); part.ContentType := GetMimeContentType(pointer(content),length(content),FileName); part.Encoding := 'base64'; part.Content := BinToBase64(content); SetLength(MultiPart,newlen); MultiPart[newlen-1] := part; result := true; end; function MultiPartFormDataAddField(const FieldName, FieldValue: RawUTF8; var MultiPart: TMultiPartDynArray): boolean; var part: TMultiPart; newlen: integer; begin result := false; if FieldName='' then exit; newlen := length(MultiPart)+1; part.Name := FieldName; part.ContentType := GetMimeContentTypeFromBuffer( pointer(FieldValue),length(FieldValue),'text/plain'); part.Content := FieldValue; SetLength(MultiPart,newlen); MultiPart[newlen-1] := part; result := true; end; function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; begin result := FastLocatePUTF8CharSorted(P,R,Value,TUTF8Compare(@StrComp)); end; function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; Compare: TUTF8Compare): PtrInt; var L,i,cmp: PtrInt; begin // fast O(log(n)) binary search if not Assigned(Compare) or (R<0) then result := 0 else if Compare(P^[R],Value)<0 then // quick return if already sorted result := R+1 else begin L := 0; result := -1; // return -1 if found repeat i := (L + R) shr 1; cmp := Compare(P^[i],Value); if cmp=0 then exit; if cmp<0 then L := i + 1 else R := i - 1; until (L > R); while (i>=0) and (Compare(P^[i],Value)>=0) do dec(i); result := i+1; // return the index where to insert end; end; function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; Compare: TUTF8Compare): PtrInt; var L, cmp: PtrInt; begin // fast O(log(n)) binary search L := 0; if Assigned(Compare) and (R>=0) then repeat result := (L+R) shr 1; cmp := Compare(P^[result],Value); if cmp=0 then exit; if cmp<0 then begin L := result+1; if L<=R then continue; break; end; R := result-1; if L<=R then continue; break; until false; result := -1; end; function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; begin result := FastFindPUTF8CharSorted(P,R,Value,TUTF8Compare(@StrComp)); end; function FastFindIndexedPUTF8Char(P: PPUTF8CharArray; R: PtrInt; var SortedIndexes: TCardinalDynArray; Value: PUTF8Char; ItemComp: TUTF8Compare): PtrInt; var L, cmp: PtrInt; begin // fast O(log(n)) binary search L := 0; if 0<=R then repeat result := (L + R) shr 1; cmp := ItemComp(P^[SortedIndexes[result]],Value); if cmp=0 then begin result := SortedIndexes[result]; exit; end; if cmp<0 then begin L := result+1; if L<=R then continue; break; end; R := result-1; if L<=R then continue; break; until false; result := -1; end; function AddSortedRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; const Value: RawUTF8; CoValues: PIntegerDynArray; ForcedIndex: PtrInt; Compare: TUTF8Compare): PtrInt; var n: PtrInt; begin if ForcedIndex>=0 then result := ForcedIndex else begin if not Assigned(Compare) then Compare := @StrComp; result := FastLocatePUTF8CharSorted(pointer(Values),ValuesCount-1,pointer(Value),Compare); if result<0 then exit; // Value exists -> fails end; n := Length(Values); if ValuesCount=n then begin n := NextGrow(n); SetLength(Values,n); if CoValues<>nil then SetLength(CoValues^,n); end; n := ValuesCount; if resultnil then begin {$ifdef CPU64}n := n shr 1;{$endif} // 64-bit pointer size is twice an integer {$ifdef FPC}Move{$else}MoveFast{$endif}(CoValues^[result],CoValues^[result+1],n); end; end else result := n; Values[result] := Value; inc(ValuesCount); end; type /// used internaly for faster quick sort {$ifdef FPC_OR_UNICODE}TQuickSortRawUTF8 = record{$else}TQuickSortRawUTF8 = object{$endif} public Values: PPointerArray; Compare: TUTF8Compare; CoValues: PIntegerArray; pivot: pointer; procedure Sort(L,R: PtrInt); end; procedure TQuickSortRawUTF8.Sort(L, R: PtrInt); var I, J, P: integer; Tmp: Pointer; TmpInt: integer; begin if L0 do Dec(J); if I <= J then begin Tmp := Values^[J]; Values^[J] := Values^[I]; Values^[I] := Tmp; if CoValues<>nil then begin TmpInt := CoValues^[J]; CoValues^[J] := CoValues^[I]; CoValues^[I] := TmpInt; end; if P = I then P := J else if P = J then P := I; Inc(I); Dec(J); end; until I > J; if J - L < R - I then begin // use recursion only for smaller range if L < J then Sort(L, J); L := I; end else begin if I < R then Sort(I, R); R := J; end; until L >= R; end; procedure QuickSortRawUTF8(var Values: TRawUTF8DynArray; ValuesCount: integer; CoValues: PIntegerDynArray=nil; Compare: TUTF8Compare=nil); var QS: TQuickSortRawUTF8; begin QS.Values := pointer(Values); if Assigned(Compare) then QS.Compare := Compare else QS.Compare := @StrComp; if CoValues=nil then QS.CoValues := nil else QS.CoValues := pointer(CoValues^); QS.Sort(0,ValuesCount-1); end; function DeleteRawUTF8(var Values: TRawUTF8DynArray; Index: integer): boolean; var n: integer; begin n := length(Values); if cardinal(Index)>=cardinal(n) then result := false else begin dec(n); Values[Index] := ''; // avoid GPF if n>Index then begin {$ifdef FPC}Move{$else}MoveFast{$endif}( pointer(Values[Index+1]),pointer(Values[Index]),(n-Index)*SizeOf(pointer)); PtrUInt(Values[n]) := 0; // avoid GPF end; SetLength(Values,n); result := true; end; end; function DeleteRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; Index: integer; CoValues: PIntegerDynArray=nil): boolean; var n: integer; begin n := ValuesCount; if cardinal(Index)>=cardinal(n) then result := false else begin dec(n); ValuesCount := n; Values[Index] := ''; // avoid GPF dec(n,Index); if n>0 then begin if CoValues<>nil then {$ifdef FPC}Move{$else}MoveFast{$endif}( CoValues^[Index+1],CoValues^[Index],n*SizeOf(Integer)); {$ifdef FPC}Move{$else}MoveFast{$endif}( pointer(Values[Index+1]),pointer(Values[Index]),n*SizeOf(pointer)); PtrUInt(Values[ValuesCount]) := 0; // avoid GPF end; result := true; end; end; function ToText(const aIntelCPUFeatures: TIntelCpuFeatures; const Sep: RawUTF8): RawUTF8; var f: TIntelCpuFeature; List: PShortString; MaxValue: integer; begin result := ''; List := GetEnumInfo(TypeInfo(TIntelCpuFeature),MaxValue); if List<>nil then for f := low(f) to high(f) do begin if (f in aIntelCPUFeatures) and (List^[3]<>'_') then begin if result<>'' then result := result+Sep; result := result+RawUTF8(copy(List^,3,10)); end; inc(PByte(List),ord(List^[0])+1); // next short string end; end; {$ifdef MSWINDOWS} // wrapper around some low-level Windows-specific API {$ifdef DELPHI6OROLDER} function GetFileVersion(const FileName: TFileName): cardinal; var Size, Size2: DWord; Pt: Pointer; Info: ^TVSFixedFileInfo; tmp: TFileName; begin result := cardinal(-1); if FileName='' then exit; // GetFileVersionInfo modifies the filename parameter data while parsing // Copy the string const into a local variable to create a writeable copy SetString(tmp,PChar(FileName),length(FileName)); Size := GetFileVersionInfoSize(pointer(tmp), Size2); if Size>0 then begin GetMem(Pt, Size); try GetFileVersionInfo(pointer(FileName), 0, Size, Pt); if VerQueryValue(Pt, '\', pointer(Info), Size2) then result := Info^.dwFileVersionMS; finally Freemem(Pt); end; end; end; {$endif DELPHI6OROLDER} function WndProcMethod(Hwnd: HWND; Msg,wParam,lParam: integer): integer; stdcall; var obj: TObject; dsp: TMessage; begin {$ifdef CPU64} obj := pointer(GetWindowLongPtr(HWnd,GWLP_USERDATA)); {$else} obj := pointer(GetWindowLong(HWnd,GWL_USERDATA)); // faster than GetProp() {$endif CPU64} if not Assigned(obj) then result := DefWindowProc(HWnd,Msg,wParam,lParam) else begin dsp.msg := Msg; dsp.wParam := WParam; dsp.lParam := lParam; dsp.result := 0; obj.Dispatch(dsp); result := dsp.result; end; end; function CreateInternalWindow(const aWindowName: string; aObject: TObject): HWND; var TempClass: TWndClass; begin result := 0; if GetClassInfo(HInstance, pointer(aWindowName), TempClass) then exit; // class name already registered -> fail {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(TempClass,SizeOf(TempClass),0); TempClass.hInstance := HInstance; TempClass.lpfnWndProc := @DefWindowProc; TempClass.lpszClassName := pointer(aWindowName); Windows.RegisterClass(TempClass); result := CreateWindowEx(WS_EX_TOOLWINDOW, pointer(aWindowName), '', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil); if result=0 then exit; // impossible to create window -> fail {$ifdef CPU64} SetWindowLongPtr(result,GWLP_USERDATA,PtrInt(aObject)); SetWindowLongPtr(result,GWLP_WNDPROC,PtrInt(@WndProcMethod)); {$else} SetWindowLong(result,GWL_USERDATA,PtrInt(aObject)); // faster than SetProp() SetWindowLong(result,GWL_WNDPROC,PtrInt(@WndProcMethod)); {$endif CPU64} end; function ReleaseInternalWindow(var aWindowName: string; var aWindow: HWND): boolean; begin if (aWindow<>0) and (aWindowName<>'') then begin {$ifdef CPU64} SetWindowLongPtr(aWindow,GWLP_WNDPROC,PtrInt(@DefWindowProc)); {$else} SetWindowLong(aWindow,GWL_WNDPROC,PtrInt(@DefWindowProc)); {$endif CPU64} DestroyWindow(aWindow); Windows.UnregisterClass(pointer(aWindowName),HInstance); aWindow := 0; aWindowName := ''; result := true; end else result := false; end; var LastAppUserModelID: string; function SetAppUserModelID(const AppUserModelID: string): boolean; var shell32: THandle; id: SynUnicode; SetCurrentProcessExplicitAppUserModelID: function(appID: PWidechar): HResult; stdcall; begin if AppUserModelID=LastAppUserModelID then begin result := true; exit; // nothing to set end; result := false; shell32 := GetModuleHandle('shell32.dll'); if shell32=0 then exit; SetCurrentProcessExplicitAppUserModelID := GetProcAddress( shell32,'SetCurrentProcessExplicitAppUserModelID'); if not Assigned(SetCurrentProcessExplicitAppUserModelID) then exit; // API available since Windows Seven / Server 2008 R2 id := StringToSynUnicode(AppUserModelID); if Pos('.',AppUserModelID)=0 then id := id+'.'+id; // at least CompanyName.ProductName if SetCurrentProcessExplicitAppUserModelID(pointer(id))<>S_OK then exit; result := true; LastAppUserModelID := AppUserModelID; end; {$endif MSWINDOWS} { TFileVersion } constructor TFileVersion.Create(const aFileName: TFileName; aMajor,aMinor,aRelease,aBuild: integer); var M,D: word; {$ifdef MSWINDOWS} Size, Size2: DWord; Pt, StrPt, StrValPt: Pointer; LanguageInfo: RawUTF8; Info: ^TVSFixedFileInfo; FileTime: TFILETIME; SystemTime: TSYSTEMTIME; tmp: TFileName; function ReadResourceByName(const From: RawUTF8): RawUTF8; var sz: DWord; begin VerQueryValueA(Pt,PAnsiChar('\StringFileInfo\'+LanguageInfo+'\'+From),StrValPt,sz); if sz>0 then FastSetString(Result,StrValPt,sz) end; {$else} {$ifdef FPCUSEVERSIONINFO} VI: TVersionInfo; LanguageInfo: String; TI, I: Integer; {$endif} {$endif MSWINDOWS} begin fFileName := aFileName; {$ifdef MSWINDOWS} if aFileName<>'' then begin // GetFileVersionInfo modifies the filename parameter data while parsing. // Copy the string const into a local variable to create a writeable copy. SetString(tmp,PChar(aFileName),length(aFileName)); Size := GetFileVersionInfoSize(pointer(tmp), Size2); if Size>0 then begin GetMem(Pt, Size); try GetFileVersionInfo(pointer(aFileName), 0, Size, Pt); VerQueryValue(Pt, '\', pointer(Info), Size2); with Info^ do begin if Version32=0 then begin aMajor := dwFileVersionMS shr 16; aMinor := word(dwFileVersionMS); aRelease := dwFileVersionLS shr 16; end; aBuild := word(dwFileVersionLS); BuildYear := 2010; if (dwFileDateLS<>0) and (dwFileDateMS<>0) then begin FileTime.dwLowDateTime:= dwFileDateLS; // built date from version info FileTime.dwHighDateTime:= dwFileDateMS; FileTimeToSystemTime(FileTime, SystemTime); fBuildDateTime := EncodeDate( SystemTime.wYear,SystemTime.wMonth,SystemTime.wDay); end; end; VerQueryValue(Pt, '\VarFileInfo\Translation', StrPt, Size2); if Size2 >= 4 then begin LanguageInfo := BinToHexDisplay(PAnsiChar(StrPt), 2) + BinToHexDisplay(PAnsiChar(StrPt)+2, 2); CompanyName := ReadResourceByName('CompanyName'); FileDescription := ReadResourceByName('FileDescription'); FileVersion := ReadResourceByName('FileVersion'); InternalName := ReadResourceByName('InternalName'); LegalCopyright := ReadResourceByName('LegalCopyright'); OriginalFilename := ReadResourceByName('OriginalFilename'); ProductName := ReadResourceByName('ProductName'); ProductVersion := ReadResourceByName('ProductVersion'); Comments := ReadResourceByName('Comments'); end finally Freemem(Pt); end; end; end; {$else MSWINDOWS} {$ifdef FPCUSEVERSIONINFO} // FPC 3.0+ if enabled in Synopse.inc / project options if aFileName<>'' then begin VI := TVersionInfo.Create; try if (aFileName<>ExeVersion.ProgramFileName) and (aFileName<>ParamStr(0)) then VI.Load(aFileName) else VI.Load(HInstance); // load info for currently running program aMajor := VI.FixedInfo.FileVersion[0]; aMinor := VI.FixedInfo.FileVersion[1]; aRelease := VI.FixedInfo.FileVersion[2]; aBuild := VI.FixedInfo.FileVersion[3]; //fBuildDateTime := TDateTime(VI.FixedInfo.FileDate); << need to find out how to convert this before uncommenting // detect translation. if VI.VarFileInfo.Count>0 then with VI.VarFileInfo.Items[0] do LanguageInfo := Format('%.4x%.4x',[language,codepage]); if LanguageInfo='' then begin // take first language Ti := 0; if VI.StringFileInfo.Count>0 then LanguageInfo := VI.StringFileInfo.Items[0].Name end else begin // look for index of language TI := VI.StringFileInfo.Count-1; while (TI>=0) and (CompareText(VI.StringFileInfo.Items[TI].Name,LanguageInfo)<>0) do dec(TI); if (TI < 0) then begin TI := 0; // revert to first translation LanguageInfo := VI.StringFileInfo.Items[TI].Name; end; end; with VI.StringFileInfo.Items[TI] do begin CompanyName := Values['CompanyName']; FileDescription := Values['FileDescription']; FileVersion := Values['FileVersion']; InternalName := Values['InternalName']; LegalCopyright := Values['LegalCopyright']; OriginalFilename := Values['OriginalFilename']; ProductName := Values['ProductName']; ProductVersion := Values['ProductVersion']; Comments := Values['Comments']; end; finally VI.Free; end; end; {$endif FPCUSEVERSIONINFO} {$endif MSWINDOWS} SetVersion(aMajor,aMinor,aRelease,aBuild); if fBuildDateTime=0 then // get build date from file age fBuildDateTime := FileAgeToDateTime(aFileName); if fBuildDateTime<>0 then DecodeDate(fBuildDateTime,BuildYear,M,D); end; function TFileVersion.Version32: integer; begin result := Major shl 16+Minor shl 8+Release; end; procedure TFileVersion.SetVersion(aMajor,aMinor,aRelease,aBuild: integer); begin Major := aMajor; Minor := aMinor; Release := aRelease; Build := aBuild; Main := IntToString(Major)+'.'+IntToString(Minor); fDetailed := Main+ '.'+IntToString(Release)+'.'+IntToString(Build); end; function TFileVersion.BuildDateTimeString: string; begin DateTimeToIso8601StringVar(fBuildDateTime,' ',result); end; function TFileVersion.DetailedOrVoid: string; begin if (self=nil) or (fDetailed='0.0.0.0') then result := '' else result := fDetailed; end; function TFileVersion.VersionInfo: RawUTF8; begin FormatUTF8('% % %',[ExtractFileName(fFileName),fDetailed,BuildDateTimeString],result); end; function TFileVersion.UserAgent: RawUTF8; begin if self=nil then result := '' else FormatUTF8('%/%%',[GetFileNameWithoutExt(ExtractFileName(fFileName)), DetailedOrVoid,OS_INITIAL[OS_KIND]],result); {$ifdef MSWINDOWS} if OSVersion in WINDOWS_32 then result := result+'32'; {$endif} end; class function TFileVersion.GetVersionInfo(const aFileName: TFileName): RawUTF8; begin with Create(aFileName,0,0,0,0) do try result := VersionInfo; finally Free; end; end; procedure SetExecutableVersion(const aVersionText: RawUTF8); var P: PUTF8Char; i: integer; ver: array[0..3] of integer; begin P := pointer(aVersionText); for i := 0 to 3 do ver[i] := GetNextItemCardinal(P,'.'); SetExecutableVersion(ver[0],ver[1],ver[2],ver[3]); end; procedure SetExecutableVersion(aMajor,aMinor,aRelease,aBuild: integer); var {$ifdef MSWINDOWS} tmp: array[byte] of WideChar; tmpsize: cardinal; {$else} tmp: string; {$endif} begin with ExeVersion do begin if Version=nil then begin {$ifdef MSWINDOWS} ProgramFileName := paramstr(0); {$else} ProgramFileName := GetModuleName(HInstance); if ProgramFileName='' then ProgramFileName := ExpandFileName(paramstr(0)); {$endif} ProgramFilePath := ExtractFilePath(ProgramFileName); if IsLibrary then InstanceFileName := GetModuleName(HInstance) else InstanceFileName := ProgramFileName; ProgramName := StringToUTF8(GetFileNameWithoutExt(ExtractFileName(ProgramFileName))); {$ifdef MSWINDOWS} tmpsize := SizeOf(tmp); GetComputerNameW(tmp,tmpsize); RawUnicodeToUtf8(@tmp,StrLenW(tmp),Host); tmpsize := SizeOf(tmp); GetUserNameW(tmp,tmpsize); RawUnicodeToUtf8(@tmp,StrLenW(tmp),User); {$else} StringToUTF8(GetHostName,Host); if Host='' then StringToUTF8(GetEnvironmentVariable('HOSTNAME'),Host); tmp := GetEnvironmentVariable('LOGNAME'); // POSIX if tmp='' then tmp := GetEnvironmentVariable('USER'); {$ifdef KYLIX3} if tmp='' then User := LibC.getpwuid(LibC.getuid)^.pw_name else {$endif} StringToUTF8(tmp,User); {$endif} if Host='' then Host := 'unknown'; if User='' then User := 'unknown'; GarbageCollectorFreeAndNil(Version, TFileVersion.Create(InstanceFileName,aMajor,aMinor,aRelease,aBuild)); end else Version.SetVersion(aMajor,aMinor,aRelease,aBuild); FormatUTF8('% % (%)',[ProgramFileName,Version.Detailed, DateTimeToIso8601(Version.BuildDateTime,True,' ')],ProgramFullSpec); Hash.c0 := Version.Version32; {$ifdef CPUINTEL} Hash.c0 := crc32c(Hash.c0,@CpuFeatures,SizeOf(CpuFeatures)); {$endif} Hash.c0 := crc32c(Hash.c0,pointer(Host),length(Host)); Hash.c1 := crc32c(Hash.c0,pointer(User),length(User)); Hash.c2 := crc32c(Hash.c1,pointer(ProgramFullSpec),length(ProgramFullSpec)); Hash.c3 := crc32c(Hash.c2,pointer(InstanceFileName),length(InstanceFileName)); end; end; {$ifdef MSWINDOWS} // avoid unneeded reference to ShlObj.pas function SHGetFolderPath(hwnd: HWND; csidl: Integer; hToken: THandle; dwFlags: DWord; pszPath: PChar): HRESULT; stdcall; external 'SHFolder.dll' name {$ifdef UNICODE}'SHGetFolderPathW'{$else}'SHGetFolderPathA'{$endif}; var _SystemPath: array[TSystemPath] of TFileName; function GetSystemPath(kind: TSystemPath): TFileName; const CSIDL_PERSONAL = $0005; CSIDL_LOCAL_APPDATA = $001C; // local non roaming user folder CSIDL_COMMON_APPDATA = $0023; CSIDL_COMMON_DOCUMENTS = $002E; CSIDL: array[TSystemPath] of integer = ( // spCommonData, spUserData, spCommonDocuments CSIDL_COMMON_APPDATA, CSIDL_LOCAL_APPDATA, CSIDL_COMMON_DOCUMENTS, // spUserDocuments, spTempFolder, spLog CSIDL_PERSONAL, 0, CSIDL_LOCAL_APPDATA); ENV: array[TSystemPath] of TFileName = ( 'ALLUSERSAPPDATA', 'LOCALAPPDATA', '', '', 'TEMP', 'LOCALAPPDATA'); var tmp: array[0..MAX_PATH] of char; k: TSystemPath; begin if _SystemPath[spCommonData]='' then for k := low(k) to high(k) do if (k=spLog) and IsDirectoryWritable(ExeVersion.ProgramFilePath) then _SystemPath[k] := EnsureDirectoryExists(ExeVersion.ProgramFilePath+'log') else if (CSIDL[k]<>0) and (SHGetFolderPath(0,CSIDL[k],0,0,@tmp)=S_OK) then _SystemPath[k] := IncludeTrailingPathDelimiter(tmp) else begin _SystemPath[k] := GetEnvironmentVariable(ENV[k]); if _SystemPath[k]='' then _SystemPath[k] := GetEnvironmentVariable('APPDATA'); _SystemPath[k] := IncludeTrailingPathDelimiter(_SystemPath[k]); end; result := _SystemPath[kind]; end; {$else MSWINDOWS} var _HomePath, _TempPath, _UserPath, _LogPath: TFileName; function GetSystemPath(kind: TSystemPath): TFileName; begin case kind of spLog: begin if _LogPath='' then if IsDirectoryWritable('/var/log') then _LogPath := '/var/log/' else // may not be writable by not root on POSIX if IsDirectoryWritable(ExeVersion.ProgramFilePath) then _LogPath := ExeVersion.ProgramFilePath else _LogPath := GetSystemPath(spUserData); result := _LogPath; end; spUserData: begin if _UserPath='' then begin // ~/.cache/appname _UserPath := GetEnvironmentVariable('XDG_CACHE_HOME'); if (_UserPath='') or not IsDirectoryWritable(_UserPath) then _UserPath := EnsureDirectoryExists(GetSystemPath(spUserDocuments)+'.cache'); _UserPath := EnsureDirectoryExists(_UserPath+UTF8ToString(ExeVersion.ProgramName)); end; result := _UserPath; end; spTempFolder: begin if _TempPath='' then begin _TempPath := GetEnvironmentVariable('TMPDIR'); // POSIX if _TempPath='' then _TempPath := GetEnvironmentVariable('TMP'); if _TempPath='' then if DirectoryExists('/tmp') then _TempPath := '/tmp' else _TempPath := '/var/tmp'; _TempPath := IncludeTrailingPathDelimiter(_TempPath); end; result := _TempPath; end else begin if _HomePath='' then // POSIX requires a value for $HOME _HomePath := IncludeTrailingPathDelimiter(GetEnvironmentVariable('HOME')); result := _HomePath; end; end; end; {$endif MSWINDOWS} {$ifdef BSD} function mprotect(Addr: Pointer; Len: size_t; Prot: Integer): Integer; {$ifdef Darwin} cdecl external 'libc.dylib' name 'mprotect'; {$else} cdecl external 'libc.so' name 'mprotect'; {$endif} {$define USEMPROTECT} {$endif} {$ifdef KYLIX3} {$define USEMPROTECT} {$endif} procedure PatchCode(Old,New: pointer; Size: integer; Backup: pointer=nil; LeaveUnprotected: boolean=false); {$ifdef MSWINDOWS} var RestoreProtection, Ignore: DWORD; i: integer; begin if VirtualProtect(Old, Size, PAGE_EXECUTE_READWRITE, RestoreProtection) then begin if Backup<>nil then for i := 0 to Size-1 do // do not use Move() here PByteArray(Backup)^[i] := PByteArray(Old)^[i]; for i := 0 to Size-1 do // do not use Move() here PByteArray(Old)^[i] := PByteArray(New)^[i]; if not LeaveUnprotected then VirtualProtect(Old, Size, RestoreProtection, Ignore); FlushInstructionCache(GetCurrentProcess, Old, Size); if not CompareMemFixed(Old,New,Size) then raise ESynException.Create('PatchCode?'); end; end; {$else} var PageSize, AlignedAddr: PtrUInt; i: integer; begin if Backup<>nil then for i := 0 to Size-1 do // do not use Move() here PByteArray(Backup)^[i] := PByteArray(Old)^[i]; PageSize := SystemInfo.dwPageSize; AlignedAddr := PtrUInt(Old) and not (PageSize-1); while PtrUInt(Old)+PtrUInt(Size)>=AlignedAddr+PageSize do Inc(PageSize,SystemInfo.dwPageSize); {$ifdef USEMPROTECT} if mprotect(Pointer(AlignedAddr),PageSize,PROT_READ or PROT_WRITE or PROT_EXEC)=0 then {$else} Do_SysCall(syscall_nr_mprotect,PtrUInt(AlignedAddr),PageSize,PROT_READ or PROT_WRITE or PROT_EXEC); {$endif} try for i := 0 to Size-1 do // do not use Move() here PByteArray(Old)^[i] := PByteArray(New)^[i]; except end; end; {$endif} procedure PatchCodePtrUInt(Code: PPtrUInt; Value: PtrUInt; LeaveUnprotected: boolean=false); begin PatchCode(Code,@Value,SizeOf(Code^),nil,LeaveUnprotected); end; {$ifdef CPUINTEL} procedure RedirectCode(Func, RedirectFunc: Pointer; Backup: PPatchCode=nil); var NewJump: packed record Code: byte; // $e9 = jmp {relative} Distance: integer; // relative jump is 32-bit even on CPU64 end; begin if (Func=nil) or (RedirectFunc=nil) then exit; // nothing to redirect to assert(SizeOf(TPatchCode)=SizeOf(NewJump)); NewJump.Code := $e9; NewJump.Distance := integer(PtrUInt(RedirectFunc)-PtrUInt(Func)-SizeOf(NewJump)); PatchCode(Func,@NewJump,SizeOf(NewJump),Backup); {$ifndef LVCL} assert(pByte(Func)^=$e9); {$endif} end; procedure RedirectCodeRestore(Func: pointer; const Backup: TPatchCode); begin PatchCode(Func,@Backup,SizeOf(TPatchCode)); end; {$endif CPUINTEL} {$ifndef LVCL} {$ifndef FPC} {$ifdef MSWINDOWS} const MemoryDelta = $8000; // 32 KB granularity (must be a power of 2) function THeapMemoryStream.Realloc(var NewCapacity: longint): Pointer; // allocates memory from Delphi heap (FastMM4/SynScaleMM) and not windows.Global*() // and uses bigger growing size -> a lot faster var i: PtrInt; begin if NewCapacity>0 then begin i := Seek(0,soFromCurrent); // no direct access to fSize -> use Seek() trick if NewCapacity=Seek(0,soFromEnd) then begin // avoid ReallocMem() if just truncate result := Memory; Seek(i,soBeginning); exit; end; NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1); Seek(i,soBeginning); end; Result := Memory; if NewCapacity <> Capacity then begin if NewCapacity = 0 then begin FreeMem(Memory); Result := nil; end else begin if Capacity = 0 then GetMem(Result, NewCapacity) else if NewCapacity > Capacity then // only realloc if necessary (grow up) ReallocMem(Result, NewCapacity) else NewCapacity := Capacity; // same capacity as before if Result = nil then raise EStreamError.Create('THeapMemoryStream'); // memory allocation bug end; end; end; {$endif MSWINDOWS} {$endif FPC} {$endif LVCL} { TSortedWordArray } function FastLocateWordSorted(P: PWordArray; R: integer; Value: word): PtrInt; var L,cmp: PtrInt; begin if R<0 then result := 0 else begin L := 0; repeat result := (L + R) shr 1; cmp := P^[result]-Value; if cmp=0 then begin result := -result-1; // return -(foundindex+1) if already exists exit; end; if cmp<0 then L := result + 1 else R := result - 1; until (L > R); while (result>=0) and (P^[result]>=Value) do dec(result); result := result+1; // return the index where to insert end; end; function FastFindWordSorted(P: PWordArray; R: PtrInt; Value: Word): PtrInt; var L: PtrInt; cmp: integer; begin L := 0; if 0<=R then repeat result := (L + R) shr 1; cmp := P^[result]-Value; if cmp=0 then exit; if cmp<0 then begin L := result+1; if L<=R then continue; break; end; R := result-1; if L<=R then continue; break; until false; result := -1 end; function TSortedWordArray.Add(aValue: Word): PtrInt; begin result := FastLocateWordSorted(pointer(Values),Count-1,aValue); if result<0 then // aValue already exists in Values[] -> fails exit; if Count=length(Values) then SetLength(Values,Count+100); if result J; if J - L < R - I then begin // use recursion only for smaller range if L < J then QuickSortCompare(OnCompare, Index, L, J); L := I; end else begin if I < R then QuickSortCompare(OnCompare, Index, I, R); R := J; end; until L >= R; end; procedure Exchg32(var A,B: integer); {$ifdef HASINLINE}inline;{$endif} var tmp: integer; begin tmp := A; A := B; B := tmp; end; function MedianQuickSelectInteger(Values: PIntegerArray; n: integer): integer; var low, high, median, middle, ll, hh: PtrInt; begin if n=0 then begin result := 0; exit; end; if n=1 then begin result := Values[0]; exit; end; low := 0; high := n-1; median := high shr 1; repeat if high<=low then begin // one item left result := Values[median]; exit; end; if high=low+1 then begin // two items -> return the smallest (not average) if Values[low]>Values[high] then Exchg32(Values[low],Values[high]); result := Values[median]; exit; end; // find median of low, middle and high items; swap into position low middle := (low+high) shr 1; if Values[middle]>Values[high] then Exchg32(Values[middle],Values[high]); if Values[low]>Values[high] then Exchg32(Values[low],Values[high]); if Values[middle]>Values[low] then Exchg32(Values[middle],Values[low]); // swap low item (now in position middle) into position (low+1) Exchg32(Values[middle],Values[low+1]); // nibble from each end towards middle, swapping items when stuck ll := low+1; hh := high; repeat repeat inc(ll); until not (Values[low]>Values[ll]); repeat dec(hh); until not (Values[hh]>Values[low]); if hh=median then high := hh-1; until false; end; function MedianQuickSelect(const OnCompare: TOnValueGreater; n: integer; var TempBuffer: TSynTempBuffer): integer; var low, high, middle, median, ll, hh: PtrInt; tmp: integer; ndx: PIntegerArray; begin if n<=1 then begin TempBuffer.buf := nil; // avoid GPF in TempBuffer.Done result := 0; exit; end; low := 0; high := n-1; ndx := TempBuffer.InitIncreasing(n*4); // no heap alloacation until n>1024 median := high shr 1; repeat if high<=low then begin // one item left result := ndx[median]; TempBuffer.Done; exit; end; if high=low+1 then begin // two items -> return the smallest (not average) if OnCompare(ndx[low],ndx[high]) then Exchg32(ndx[low],ndx[high]); result := ndx[median]; TempBuffer.Done; exit; end; // find median of low, middle and high items; swap into position low middle := (low+high) shr 1; if OnCompare(ndx[middle],ndx[high]) then Exchg32(ndx[middle],ndx[high]); if OnCompare(ndx[low],ndx[high]) then Exchg32(ndx[low],ndx[high]); if OnCompare(ndx[middle],ndx[low]) then Exchg32(ndx[middle],ndx[low]); // swap low item (now in position middle) into position (low+1) Exchg32(ndx[middle],ndx[low+1]); // nibble from each end towards middle, swapping items when stuck ll := low+1; hh := high; repeat tmp := ndx[low]; repeat inc(ll); until not OnCompare(tmp,ndx[ll]); repeat dec(hh); until not OnCompare(ndx[hh],tmp); if hh=median then high := hh-1; until false; end; function gcd(a, b: cardinal): cardinal; begin while a <> b do if a > b then dec(a, b) else dec(b, a); result := a; end; function ToVarUInt32Length(Value: PtrUInt): PtrUInt; begin if Value<=$7f then result := 1 else if Value<$80 shl 7 then result := 2 else if Value<$80 shl 14 then result := 3 else if Value <$80 shl 21 then result := 4 else result := 5; end; function ToVarUInt32LengthWithData(Value: PtrUInt): PtrUInt; begin if Value<=$7f then result := Value+1 else if Value<$80 shl 7 then result := Value+2 else if Value<$80 shl 14 then result := Value+3 else if Value<$80 shl 21 then result := Value+4 else result := Value+5; end; {$ifdef HASINLINE} function FromVarUInt32(var Source: PByte): cardinal; begin result := Source^; inc(Source); if result>$7f then result := (result and $7F) or FromVarUInt32Up128(Source); end; function FromVarUInt32Big(var Source: PByte): cardinal; {$else} function FromVarUInt32Big(var Source: PByte): cardinal; asm jmp FromVarUInt32 end; function FromVarUInt32(var Source: PByte): cardinal; {$endif} var c: cardinal; p: PByte; begin p := Source; result := p^; inc(p); if result>$7f then begin c := p^; c := c shl 7; result := result and $7F or c; inc(p); if c>$7f shl 7 then begin // Values between 128 and 16256 c := p^; c := c shl 14; inc(p); result := result and $3FFF or c; if c>$7f shl 14 then begin // Values between 16257 and 2080768 c := p^; c := c shl 21; inc(p); result := result and $1FFFFF or c; if c>$7f shl 21 then begin // Values between 2080769 and 266338304 c := p^; c := c shl 28; inc(p); result := result and $FFFFFFF or c; end; end; end; end; Source := p; end; function FromVarUInt32Up128(var Source: PByte): cardinal; var c: cardinal; p: PByte; begin p := Source; result := p^ shl 7; inc(p); if result>$7f shl 7 then begin // Values between 128 and 16256 c := p^; c := c shl 14; inc(p); result := result and $3FFF or c; if c>$7f shl 14 then begin // Values between 16257 and 2080768 c := p^; c := c shl 21; inc(p); result := result and $1FFFFF or c; if c>$7f shl 21 then begin // Values between 2080769 and 266338304 c := p^; c := c shl 28; inc(p); result := result and $FFFFFFF or c; end; end; end; Source := p; end; function FromVarInt32(var Source: PByte): integer; var c: cardinal; p: PByte; begin // faster as stand-alone function with inlined FromVarUInt32 p := Source; result := p^; inc(p); if result>$7f then begin c := p^; c := c shl 7; result := result and $7F or integer(c); inc(p); if c>$7f shl 7 then begin // Values between 128 and 16256 c := p^; c := c shl 14; inc(p); result := result and $3FFF or integer(c); if c>$7f shl 14 then begin // Values between 16257 and 2080768 c := p^; c := c shl 21; inc(p); result := result and $1FFFFF or integer(c); if c>$7f shl 21 then begin // Values between 2080769 and 266338304 c := p^; c := c shl 28; inc(p); result := result and $FFFFFFF or integer(c); end; end; end; end; Source := p; // 0=0,1=1,2=-1,3=2,4=-2... if result and 1<>0 then // 1->1, 3->2.. result := result shr 1+1 else // 0->0, 2->-1, 4->-2.. result := -(result shr 1); end; function FromVarUInt32High(var Source: PByte): cardinal; var c: cardinal; begin result := Source^; inc(Source); c := Source^ shl 7; inc(Source); result := result and $7F or c; if c<=$7f shl 7 then exit; // Values between 128 and 16256 c := Source^ shl 14; inc(Source); result := result and $3FFF or c; if c<=$7f shl 14 then exit; // Values between 16257 and 2080768 c := Source^ shl 21; inc(Source); result := result and $1FFFFF or c; if c<=$7f shl 21 then exit; // Values between 2080769 and 266338304 c := Source^ shl 28; inc(Source); result := result and $FFFFFFF or c; end; function ToVarInt64(Value: Int64; Dest: PByte): PByte; begin // 0=0,1=1,2=-1,3=2,4=-2... {$ifdef CPU32} if Value<=0 then // 0->0, -1->2, -2->4.. result := ToVarUInt64((-Value) shl 1,Dest) else // 1->1, 2->3.. result := ToVarUInt64((Value shl 1)-1,Dest); {$else} if Value<=0 then // 0->0, -1->2, -2->4.. Value := (-Value) shl 1 else // 1->1, 2->3.. Value := (Value shl 1)-1; result := ToVarUInt64(Value,Dest); {$endif} end; function ToVarUInt64(Value: QWord; Dest: PByte): PByte; label _1,_2,_3; // ugly but fast var c: cardinal; begin c := Value; if {$ifdef CPU32}PInt64Rec(@Value)^.Hi=0{$else}Value shr 32=0{$endif} then begin if c>$7f then begin // inlined result := ToVarUInt32(Value,Dest); if c<$80 shl 7 then goto _1 else if c<$80 shl 14 then goto _2 else if c<$80 shl 21 then goto _3; Dest^ := (c and $7F) or $80; c := c shr 7; inc(Dest); _3: Dest^ := (c and $7F) or $80; c := c shr 7; inc(Dest); _2: Dest^ := (c and $7F) or $80; c := c shr 7; inc(Dest); _1: Dest^ := (c and $7F) or $80; c := c shr 7; inc(Dest); end; Dest^ := c; inc(Dest); result := Dest; exit; end; PCardinal(Dest)^ := (c and $7F) or (((c shr 7)and $7F)shl 8) or (((c shr 14)and $7F)shl 16) or (((c shr 21)and $7F)shl 24) or $80808080; Value := Value shr 28; inc(Dest,4); repeat Dest^ := (Value and $7F) or $80; Value := Value shr 7; inc(Dest); until Value<=$7f; Dest^ := Value; inc(Dest); result := Dest; end; function FromVarUInt64(var Source: PByte): QWord; var c,n: PtrUInt; p: PByte; begin p := Source; {$ifdef CPU64} result := p^; if result>$7f then begin result := result and $7F; {$else} if p^>$7f then begin result := PtrUInt(p^) and $7F; {$endif} n := 0; inc(p); repeat c := p^; inc(n,7); if c<=$7f then break; result := result or (QWord(c and $7f) shl n); inc(p); until false; result := result or (QWord(c) shl n); end{$ifndef CPU64} else result := p^{$endif}; inc(p); Source := p; end; function FromVarInt64(var Source: PByte): Int64; var c,n: PtrUInt; begin // 0=0,1=1,2=-1,3=2,4=-2... {$ifdef CPU64} result := Source^; if result>$7f then begin result := result and $7F; n := 0; inc(Source); repeat c := Source^; inc(n,7); if c<=$7f then break; result := result or (Int64(c and $7f) shl n); inc(Source); until false; result := result or (Int64(c) shl n); end; if result and 1<>0 then // 1->1, 3->2.. result := result shr 1+1 else // 0->0, 2->-1, 4->-2.. result := -(result shr 1); {$else} c := Source^; if c>$7f then begin result := c and $7F; n := 0; inc(Source); repeat c := Source^; inc(n,7); if c<=$7f then break; result := result or (Int64(c and $7f) shl n); inc(Source); until false; result := result or (Int64(c) shl n); if PCardinal(@result)^ and 1<>0 then // 1->1, 3->2.. result := result shr 1+1 else // 0->0, 2->-1, 4->-2.. result := -(result shr 1); end else begin if c=0 then result := 0 else if c and 1=0 then // 0->0, 2->-1, 4->-2.. result := -Int64(c shr 1) else // 1->1, 3->2.. result := (c shr 1)+1; end; {$endif} inc(Source); end; function FromVarInt64Value(Source: PByte): Int64; {$ifdef DELPHI5OROLDER} begin // try to circumvent Internal Error C1093 on Delphi 5 :( result := FromVarInt64(Source); end; {$else} var c,n: PtrUInt; begin // 0=0,1=1,2=-1,3=2,4=-2... c := Source^; if c>$7f then begin result := c and $7F; n := 0; inc(Source); repeat c := Source^; inc(n,7); if c<=$7f then break; result := result or (Int64(c and $7f) shl n); inc(Source); until false; result := result or (Int64(c) shl n); if {$ifdef CPU64}result{$else}PCardinal(@result)^{$endif} and 1<>0 then // 1->1, 3->2.. result := result shr 1+1 else // 0->0, 2->-1, 4->-2.. result := -Int64(result shr 1); end else if c=0 then result := 0 else if c and 1=0 then // 0->0, 2->-1, 4->-2.. result := -Int64(c shr 1) else // 1->1, 3->2.. result := (c shr 1)+1; end; {$endif DELPHI5OROLDER} function GotoNextVarInt(Source: PByte): pointer; begin if Source<>nil then begin if Source^>$7f then repeat inc(Source) until Source^<=$7f; inc(Source); end; result := Source; end; function ToVarString(const Value: RawUTF8; Dest: PByte): PByte; var Len: integer; begin Len := Length(Value); Dest := ToVarUInt32(Len,Dest); if Len>0 then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(Value)^,Dest^,Len); result := pointer(PAnsiChar(Dest)+Len); end else result := Dest; end; function GotoNextVarString(Source: PByte): pointer; begin result := Pointer(PtrUInt(Source)+FromVarUInt32(Source)); end; function FromVarString(var Source: PByte): RawUTF8; var Len: PtrUInt; begin Len := FromVarUInt32(Source); FastSetStringCP(Result,Source,Len,CP_UTF8); inc(Source,Len); end; procedure FromVarString(var Source: PByte; var Value: TSynTempBuffer); var len: integer; begin len := FromVarUInt32(Source); Value.Init(Source,len); PByteArray(Value.buf)[len] := 0; // include trailing #0 inc(Source,len); end; procedure FromVarString(var Source: PByte; var Value: RawByteString; CodePage: integer); var Len: PtrUInt; begin Len := FromVarUInt32(Source); FastSetStringCP(Value,Source,Len,CodePage); inc(Source,Len); end; function FromVarBlob(Data: PByte): TValueResult; begin Result.Len := FromVarUInt32(Data); Result.Ptr := pointer(Data); end; { ************ low-level RTTI types and conversion routines } {$ifdef FPC} {$ifdef FPC_OLDRTTI} function OldRTTIFirstManagedField(info: PTypeInfo): PFieldInfo; var fieldtype: PTypeInfo; i: integer; begin result := @info^.ManagedFields[0]; for i := 1 to info^.ManagedCount do begin fieldtype := DeRef(result^.TypeInfo); if (fieldtype<>nil) and (fieldtype^.Kind in tkManagedTypes) then exit; inc(result); end; result := nil; end; function OldRTTIManagedSize(typeInfo: Pointer): SizeInt; inline; begin case PTypeKind(typeInfo)^ of // match tkManagedTypes tkLString,tkLStringOld,tkWString,tkUString, tkInterface,tkDynarray: result := SizeOf(Pointer); {$ifndef NOVARIANTS} tkVariant: result := SizeOf(TVarData); {$endif} tkArray: with GetTypeInfo(typeInfo)^ do result := arraySize{$ifdef VER2_6}*elCount{$endif}; tkObject,tkRecord: result := GetTypeInfo(typeInfo)^.recSize; else raise ESynException.CreateUTF8('OldRTTIManagedSize unhandled % (%)', [ToText(PTypeKind(typeInfo)^)^,PByte(typeInfo)^]); end; end; procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); begin // external name 'FPC_COPY' does not work as we need FPCFinalize(@Dest,TypeInfo); Move(Source,Dest,OldRTTIManagedSize(TypeInfo)); FPCRecordAddRef(Dest,TypeInfo); end; {$else} procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); begin FPCRecordCopy(Source,Dest,TypeInfo); end; {$endif FPC_OLDRTTI} procedure RecordClear(var Dest; TypeInfo: pointer); begin FPCFinalize(@Dest,TypeInfo); end; {$else FPC} procedure CopyArray(dest, source, typeInfo: Pointer; cnt: PtrUInt); asm {$ifdef CPU64} .NOFRAME jmp System.@CopyArray {$else} push dword ptr[EBP + 8] call System.@CopyArray // RTL is fast enough for this {$endif} end; procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer); asm {$ifdef CPU64} .NOFRAME {$endif} jmp System.@DynArrayClear end; procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: PtrUInt); asm {$ifdef CPU64} .NOFRAME {$endif} jmp System.@FinalizeArray end; procedure _Finalize(Data: Pointer; TypeInfo: Pointer); asm {$ifdef CPU64} .NOFRAME mov r8, 1 // rcx=p rdx=typeInfo r8=ElemCount jmp System.@FinalizeArray {$else} // much faster than FinalizeArray(Data,TypeInfo,1) movzx ecx, byte ptr[edx] // eax=ptr edx=typeinfo ecx=datatype sub cl, tkLString {$ifdef UNICODE} cmp cl, tkUString - tkLString + 1 {$else} cmp cl, tkDynArray - tkLString + 1 {$endif} jnb @@err jmp dword ptr[@@Tab + ecx * 4] nop nop // for @@Tab alignment @@Tab: dd System.@LStrClr {$IFDEF LINUX} // under Linux, WideString are refcounted as AnsiString dd System.@LStrClr {$else} dd System.@WStrClr {$endif LINUX} {$ifdef LVCL} dd @@err {$else} dd System.@VarClr {$endif LVCL} dd @@ARRAY dd RecordClear dd System.@IntfClear dd @@err dd System.@DynArrayClear {$ifdef UNICODE} dd System.@UStrClr {$endif} @@err: mov al, reInvalidPtr {$ifdef DELPHI5OROLDER} jmp System.@RunError {$else} jmp System.Error {$endif} @@array:movzx ecx, [edx].TTypeInfo.NameLen add ecx, edx mov edx, dword ptr[ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^ mov ecx, [ecx].TTypeInfo.ManagedCount mov edx, [edx] jmp System.@FinalizeArray {$endif CPU64} end; {$endif FPC} function ArrayItemType(var info: PTypeInfo; out len: integer): PTypeInfo; {$ifdef HASINLINE}inline;{$endif} begin {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} // inlined info := GetTypeInfo(info) info := GetFPCAlignPtr(info); {$else} info := @PAnsiChar(info)[info^.NameLen]; {$endif} result := nil; if (info=nil) or (info^.dimCount<>1) then begin len := 0; info := nil; // supports single dimension static array only end else begin len := info^.arraySize{$ifdef VER2_6}*info^.elCount{$endif}; {$ifdef HASDIRECTTYPEINFO} // inlined result := DeRef(info^.arrayType) result := info^.arrayType; {$else} if info^.arrayType=nil then exit; result := info^.arrayType^; {$endif} {$ifdef FPC} if (result<>nil) and not(result^.Kind in tkManagedTypes) then result := nil; // as with Delphi {$endif} end; end; function ManagedTypeCompare(A,B: PAnsiChar; info: PTypeInfo): integer; // returns -1 if info was not handled, 0 if A^<>B^, or SizeOf(A^) if A^=B^ var i,arraysize: integer; itemtype: PTypeInfo; {$ifndef DELPHI5OROLDER} // do not know why this compiler does not like it DynA, DynB: TDynArray; {$endif} begin // info is expected to come from a DeRef() if retrieved from RTTI result := 0; // A^<>B^ case info^.Kind of // should match tkManagedTypes tkLString{$ifdef FPC},tkLStringOld{$endif}: if PAnsiString(A)^=PAnsiString(B)^ then result := SizeOf(pointer); tkWString: if PWideString(A)^=PWideString(B)^ then result := SizeOf(pointer); {$ifdef HASVARUSTRING} tkUString: if PUnicodeString(A)^=PUnicodeString(B)^ then result := SizeOf(pointer); {$endif} tkRecord{$ifdef FPC},tkObject{$endif}: if not RecordEquals(A^,B^,info,@result) then result := 0; // A^<>B^ {$ifndef NOVARIANTS} tkVariant: // slightly more optimized than PVariant(A)^=PVariant(B)^ if SortDynArrayVariantComp(PVarData(A)^,PVarData(B)^,false)=0 then result := SizeOf(variant); {$endif} {$ifndef DELPHI5OROLDER} tkDynArray: begin DynA.Init(info,A^); DynB.Init(info,B^); if DynA.Equals(DynB) then result := SizeOf(pointer); end; {$endif} tkInterface: if PPointer(A)^=PPointer(B)^ then result := SizeOf(pointer); tkArray: begin itemtype := ArrayItemType(info,arraysize); if info=nil then result := -1 else if itemtype=nil then if CompareMemFixed(A,B,arraysize) then result := arraysize else result := 0 else begin for i := 1 to info^.elCount do begin // only compare managed fields result := ManagedTypeCompare(A,B,itemtype); if result<=0 then exit; // invalid (-1) or not equals (0) inc(A,result); inc(B,result); end; result := arraysize; end; end; else result := -1; // Unhandled field end; end; function ManagedTypeSaveLength(data: PAnsiChar; info: PTypeInfo; out len: integer): integer; // returns 0 on error, or saved bytes + len=data^ length var DynArray: TDynArray; itemtype: PTypeInfo; itemsize,size,i: integer; P: PPtrUInt absolute data; begin // info is expected to come from a DeRef() if retrieved from RTTI case info^.Kind of // should match tkManagedTypes tkLString,tkWString{$ifdef FPC},tkLStringOld{$endif}: begin len := SizeOf(pointer); // length stored within WideString is in bytes if P^=0 then result := 1 else result := ToVarUInt32LengthWithData(PStrRec(Pointer(P^-STRRECSIZE))^.length); end; {$ifdef HASVARUSTRING} tkUString: begin len := SizeOf(pointer); if P^=0 then result := 1 else result := ToVarUInt32LengthWithData(PStrRec(Pointer(P^-STRRECSIZE))^.length*2); end; {$endif} tkRecord{$ifdef FPC},tkObject{$endif}: result := RecordSaveLength(data^,info,@len); tkArray: begin itemtype := ArrayItemType(info,len); result := 0; if info<>nil then if itemtype=nil then result := len else for i := 1 to info^.elCount do begin size := ManagedTypeSaveLength(data,itemtype,itemsize); if size=0 then begin result := 0; exit; end; inc(result,size); inc(data,itemsize); end; end; {$ifndef NOVARIANTS} tkVariant: begin len := SizeOf(variant); result := VariantSaveLength(PVariant(data)^); end; {$endif} tkDynArray: begin DynArray.Init(info,data^); len := SizeOf(pointer); result := DynArray.SaveToLength; end; tkInterface: begin len := SizeOf(Int64); // consume 64-bit even on CPU32 result := SizeOf(PtrUInt); end; else result := 0; // invalid/unhandled record content end; end; function ManagedTypeSave(data, dest: PAnsiChar; info: PTypeInfo; out len: integer): PAnsiChar; // returns nil on error, or final dest + len=data^ length var DynArray: TDynArray; itemtype: PTypeInfo; itemsize,i: integer; P: PPtrUInt absolute data; begin // info is expected to come from a DeRef() if retrieved from RTTI case info^.Kind of tkLString, tkWString {$ifdef HASVARUSTRING}, tkUString{$endif} {$ifdef FPC}, tkLStringOld{$endif}: if P^=0 then begin dest^ := #0; result := dest+1; len := SizeOf(PtrUInt); // size of tkLString+tkWString+tkUString in record end else begin itemsize := PStrRec(Pointer(P^-STRRECSIZE))^.length; {$ifdef HASVARUSTRING} // WideString has length in bytes, UnicodeString in WideChars if info^.Kind=tkUString then itemsize := itemsize*2; {$endif} result := pointer(ToVarUInt32(itemsize,pointer(dest))); {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(P^)^,result^,itemsize); inc(result,itemsize); len := SizeOf(PtrUInt); // size of tkLString+tkWString+tkUString in record end; tkRecord{$ifdef FPC},tkObject{$endif}: result := RecordSave(data^,dest,info,len); tkArray: begin itemtype := ArrayItemType(info,len); if info=nil then result := nil else if itemtype=nil then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(data^,dest^,len); result := dest+len; end else begin for i := 1 to info^.elCount do begin dest := ManagedTypeSave(data,dest,itemtype,itemsize); if dest=nil then break; // invalid/unhandled content inc(data,itemsize) end; result := dest; end; end; {$ifndef NOVARIANTS} tkVariant: begin result := VariantSave(PVariant(data)^,dest); len := SizeOf(Variant); // size of tkVariant in record end; {$endif} tkDynArray: begin DynArray.Init(info,data^); result := DynArray.SaveTo(dest); len := SizeOf(PtrUInt); // size of tkDynArray in record end; {$ifndef DELPHI5OROLDER} tkInterface: begin PIInterface(dest)^ := PIInterface(data)^; // with proper refcount result := dest+SizeOf(Int64); // consume 64-bit even on CPU32 len := SizeOf(PtrUInt); end; {$endif} else result := nil; // invalid/unhandled record content end; end; function ManagedTypeLoad(data: PAnsiChar; var source: PAnsiChar; info: PTypeInfo): integer; // returns source=nil on error, or final source + result=data^ length var DynArray: TDynArray; itemtype: PTypeInfo; itemsize,i: integer; begin // info is expected to come from a DeRef() if retrieved from RTTI case info^.Kind of tkLString: begin // most used type of string itemsize := FromVarUInt32(PByte(source)); FastSetStringCP(data^,source,itemsize,PWord({$ifdef FPC} GetFPCTypeData(pointer(info)){$else}PtrUInt(info)+info^.NameLen+2{$endif})^); inc(source,itemsize); result := SizeOf(PtrUInt); // size of tkLString end; tkWString {$ifdef HASVARUSTRING}, tkUString{$endif} {$ifdef FPC}, tkLStringOld{$endif}: begin itemsize := FromVarUInt32(PByte(source)); case info^.Kind of {$ifdef FPC} tkLStringOld: SetString(PRawByteString(data)^,source,itemsize); {$endif} tkWString: SetString(PWideString(data)^,PWideChar(source),itemsize shr 1); {$ifdef HASVARUSTRING} tkUString: SetString(PUnicodeString(data)^,PWideChar(source),itemsize shr 1); {$endif} end; inc(source,itemsize); result := SizeOf(PtrUInt); // size of tkWString+tkUString in record end; tkRecord{$ifdef FPC},tkObject{$endif}: source := RecordLoad(data^,source,info,@result); tkArray: begin itemtype := ArrayItemType(info,result); if info=nil then source := nil else if itemtype=nil then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(source^,data^,result); inc(source,result); end else for i := 1 to info^.elCount do begin inc(data,ManagedTypeLoad(data,source,itemtype)); if source=nil then exit; end; end; {$ifndef NOVARIANTS} tkVariant: begin source := VariantLoad(PVariant(data)^,source,@JSON_OPTIONS[true]); result := SizeOf(Variant); // size of tkVariant in record end; {$endif} tkDynArray: begin DynArray.Init(info,data^); source := DynArray.LoadFrom(source); result := SizeOf(PtrUInt); // size of tkDynArray in record end; {$ifndef DELPHI5OROLDER} tkInterface: begin PIInterface(data)^ := PIInterface(source)^; // with proper refcount inc(source,SizeOf(Int64)); // consume 64-bit even on CPU32 result := SizeOf(PtrUInt); end; {$endif} else begin source := nil; result := 0; end; end; end; function GetManagedFields(info: PTypeInfo; out firstfield: PFieldInfo): integer; {$ifdef HASINLINE}inline;{$endif} {$ifdef FPC_NEWRTTI} var recInitData: PRecInitData; // low-level structure from typinfo.pp begin recInitData := GetFPCRecInitData(AlignTypeData(PByte(info)+2)); firstfield := pointer(PtrUInt(recInitData)+SizeOf(recInitData^)); // =ManagedFields[0] result := recInitData^.ManagedFieldCount; {$else} begin firstfield := @info^.ManagedFields[0]; result := info^.ManagedCount; {$endif} end; function RecordEquals(const RecA, RecB; TypeInfo: pointer; PRecSize: PInteger): boolean; var info,fieldinfo: PTypeInfo; F, offset: PtrInt; field: PFieldInfo; A, B: PAnsiChar; begin A := @RecA; B := @RecB; result := false; info := GetTypeInfo(TypeInfo,tkRecordKinds); if info=nil then exit; // raise Exception.CreateUTF8('% is not a record',[Typ^.Name]); if PRecSize<>nil then PRecSize^ := info^.recSize; if A=B then begin // both nil or same pointer result := true; exit; end; offset := 0; for F := 1 to GetManagedFields(info,field) do begin fieldinfo := DeRef(field^.TypeInfo); {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields if not (fieldinfo^.Kind in tkManagedTypes) then begin inc(field); continue; // as with Delphi end; {$endif} offset := integer(field^.Offset)-offset; if offset<>0 then begin if not CompareMemFixed(A,B,offset) then exit; // binary block not equal inc(A,offset); inc(B,offset); end; offset := ManagedTypeCompare(A,B,fieldinfo); if offset<=0 then if offset=0 then // A^<>B^ exit else // Diff=-1 for unexpected type raise ESynException.CreateUTF8('RecordEquals: unexpected %', [ToText(fieldinfo^.Kind)^]); inc(A,offset); inc(B,offset); inc(offset,field^.Offset); inc(field); end; if CompareMemFixed(A,B,integer(info^.recSize)-offset) then result := true; end; function RecordSaveLength(const Rec; TypeInfo: pointer; Len: PInteger): integer; var info,fieldinfo: PTypeInfo; F, recsize,saved: integer; field: PFieldInfo; R: PAnsiChar; begin R := @Rec; info := GetTypeInfo(TypeInfo,tkRecordKinds); if (R=nil) or (info=nil) then begin result := 0; // should have been checked before exit; end; result := info^.recSize; if Len<>nil then Len^ := result; for F := 1 to GetManagedFields(info,field) do begin fieldinfo := DeRef(field^.TypeInfo); {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields! :) if not (fieldinfo^.Kind in tkManagedTypes) then begin inc(field); continue; // as with Delphi end; {$endif}; saved := ManagedTypeSaveLength(R+field^.Offset,fieldinfo,recsize); if saved=0 then begin result := 0; // invalid type exit; end; inc(result,saved-recsize); // extract recsize from info^.recSize inc(field); end; end; function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer; out Len: integer): PAnsiChar; var info,fieldinfo: PTypeInfo; F, offset: integer; field: PFieldInfo; R: PAnsiChar; begin R := @Rec; info := GetTypeInfo(TypeInfo,tkRecordKinds); if (R=nil) or (info=nil) then begin result := nil; // should have been checked before exit; end; Len := info^.recSize; offset := 0; for F := 1 to GetManagedFields(info,field) do begin {$ifdef HASDIRECTTYPEINFO} // inlined DeRef() fieldinfo := field^.TypeInfo; {$else} {$ifdef CPUINTEL} fieldinfo := PPointer(field^.TypeInfo)^; {$else} fieldinfo := DeRef(field^.TypeInfo); {$endif} {$endif} {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields! :) if not (fieldinfo^.Kind in tkManagedTypes) then begin inc(field); continue; // as with Delphi end; {$endif}; offset := integer(field^.Offset)-offset; if offset>0 then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(R^,Dest^,offset); inc(R,offset); inc(Dest,offset); end; Dest := ManagedTypeSave(R,Dest,fieldinfo,offset); if Dest=nil then begin result := nil; // invalid/unhandled record content exit; end; inc(R,offset); inc(offset,field.Offset); inc(field); end; offset := integer(info^.recSize)-offset; if offset<0 then raise ESynException.Create('RecordSave offset<0') else if offset<>0 then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(R^,Dest^,offset); result := Dest+offset; end else result := Dest; end; function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer): PAnsiChar; var dummylen: integer; begin result := RecordSave(Rec,Dest,TypeInfo,dummylen); end; function RecordSave(const Rec; TypeInfo: pointer): RawByteString; var destlen,dummylen: integer; dest: PAnsiChar; begin destlen := RecordSaveLength(Rec,TypeInfo); SetString(result,nil,destlen); if destlen<>0 then begin dest := RecordSave(Rec,pointer(result),TypeInfo,dummylen); if (dest=nil) or (dest-pointer(result)<>destlen) then // paranoid check raise ESynException.CreateUTF8('RecordSave % len=%<>%', [TypeInfoToShortString(TypeInfo)^,dest-pointer(result),destlen]); end; end; function RecordSaveBytes(const Rec; TypeInfo: pointer): TBytes; var destlen,dummylen: integer; dest: PAnsiChar; begin destlen := RecordSaveLength(Rec,TypeInfo); result := nil; // don't reallocate TBytes data from a previous call SetLength(result,destlen); if destlen<>0 then begin dest := RecordSave(Rec,pointer(result),TypeInfo,dummylen); if (dest=nil) or (dest-pointer(result)<>destlen) then // paranoid check raise ESynException.CreateUTF8('RecordSave % len=%<>%', [TypeInfoToShortString(TypeInfo)^,dest-pointer(result),destlen]); end; end; procedure RecordSave(const Rec; var Dest: TSynTempBuffer; TypeInfo: pointer); var dummy: integer; begin Dest.Init(RecordSaveLength(Rec,TypeInfo)); RecordSave(Rec,Dest.buf,TypeInfo,dummy); end; function RecordSaveBase64(const Rec; TypeInfo: pointer; UriCompatible: boolean): RawUTF8; var len,dummy: integer; temp: TSynTempBuffer; begin result := ''; len := RecordSaveLength(Rec,TypeInfo); if len=0 then exit; temp.Init(len+4); RecordSave(Rec,PAnsiChar(temp.buf)+4,TypeInfo,dummy); PCardinal(temp.buf)^ := crc32c(0,PAnsiChar(temp.buf)+4,len); if UriCompatible then result := BinToBase64uri(temp.buf,temp.len) else result := BinToBase64(temp.buf,temp.len); temp.Done; end; function RecordLoadBase64(Source: PAnsiChar; Len: integer; var Rec; TypeInfo: pointer; UriCompatible: boolean): boolean; var temp: TSynTempBuffer; begin result := false; if Len<=6 then exit; if UriCompatible then result := Base64uriToBin(Source,Len,temp) else result := Base64ToBin(Source,Len,temp); result := result and (temp.len>=4) and (crc32c(0,PAnsiChar(temp.buf)+4,temp.len-4)=PCardinal(temp.buf)^) and (RecordLoad(Rec,PAnsiChar(temp.buf)+4,TypeInfo)<>nil); temp.Done; end; function RecordLoad(var Rec; Source: PAnsiChar; TypeInfo: pointer; Len: PInteger): PAnsiChar; var info,fieldinfo: PTypeInfo; n, F, offset: integer; field: PFieldInfo; R: PAnsiChar; begin result := nil; // indicates error R := @Rec; info := GetTypeInfo(TypeInfo,tkRecordKinds); if (R=nil) or (info=nil) then // should have been checked before exit; if Len<>nil then Len^ := info^.recSize; n := GetManagedFields(info,field); if Source=nil then begin // inline RecordClear() function for F := 1 to n do begin {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(R+field^.Offset,Deref(field^.TypeInfo)); inc(field); end; exit; end; offset := 0; for F := 1 to n do begin {$ifdef HASDIRECTTYPEINFO} // inlined DeRef() fieldinfo := field^.TypeInfo; {$else} {$ifdef CPUINTEL} fieldinfo := PPointer(field^.TypeInfo)^; {$else} fieldinfo := DeRef(field^.TypeInfo); {$endif} {$endif} {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields! :) if not (fieldinfo^.Kind in tkManagedTypes) then begin inc(field); continue; // as with Delphi end; {$endif}; offset := integer(field^.Offset)-offset; if offset<>0 then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(Source^,R^,offset); inc(Source,offset); inc(R,offset); end; offset := ManagedTypeLoad(R,Source,fieldinfo); if Source=nil then exit; // error at loading inc(R,offset); inc(offset,field^.Offset); inc(field); end; offset := integer(info^.recSize)-offset; if offset<0 then raise ESynException.Create('RecordLoad offset<0') else if offset<>0 then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(Source^,R^,offset); result := Source+offset; end else result := Source; end; function RecordLoad(var Res; const Source: RawByteString; TypeInfo: pointer): boolean; overload; var P: PAnsiChar; begin P := RecordLoad(Res,pointer(Source),TypeInfo,nil); result := (P<>nil) and (P-pointer(Source)=length(Source)); end; {$ifndef FPC} {$ifdef USEPACKAGES} {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} {$endif} {$ifdef DELPHI5OROLDER} {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} {$endif} {$ifdef PUREPASCAL} {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} {$endif} {$ifndef DOPATCHTRTL} {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} {$endif} {$ifdef EXPECTSDELPHIRTLRECORDCOPYCLEAR} procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); asm // same params than _CopyRecord{ dest, source, typeInfo: Pointer } {$ifdef CPU64} .NOFRAME {$endif} jmp System.@CopyRecord end; procedure RecordClear(var Dest; TypeInfo: pointer); asm {$ifdef CPU64} .NOFRAME {$endif} jmp System.@FinalizeRecord end; {$endif EXPECTSDELPHIRTLRECORDCOPYCLEAR} {$ifdef DOPATCHTRTL} function SystemRecordCopyAddress: Pointer; asm {$ifdef CPU64} mov rax,offset System.@CopyRecord {$else} mov eax,offset System.@CopyRecord {$endif} end; function SystemFinalizeRecordAddress: Pointer; asm {$ifdef CPU64} mov rax,offset System.@FinalizeRecord {$else} mov eax,offset System.@FinalizeRecord {$endif} end; function SystemInitializeRecordAddress: Pointer; asm {$ifdef CPU64} mov rax,offset System.@InitializeRecord {$else} mov eax,offset System.@InitializeRecord {$endif} end; {$ifdef CPUX86} procedure _InitializeRecord(P: Pointer; TypeInfo: Pointer); asm // faster version by AB { -> EAX pointer to record to be finalized } { EDX pointer to type info } (* // this TObject.Create-like initialization sounds slower movzx ecx,byte ptr [edx].TTypeInfo.NameLen mov edx,[edx+ecx].TTypeInfo.Size xor ecx,ecx jmp dword ptr [FillCharFast] *) movzx ecx, byte ptr[edx].TTypeInfo.NameLen push ebx mov ebx, eax push esi push edi mov edi, [edx + ecx].TTypeInfo.ManagedCount lea esi, [edx + ecx].TTypeInfo.ManagedFields test edi, edi jz @end @loop: mov edx, [esi].TFieldInfo.TypeInfo mov eax, [esi].TFieldInfo.&Offset mov edx, [edx] add esi, 8 movzx ecx, [edx].TTypeInfo.Kind add eax, ebx // eax=data to be initialized jmp dword ptr[@tab + ecx * 4 - tkLString * 4] @tab: dd @ptr, @ptr, @varrec, @array, @array, @ptr, @ptr, @ptr, @ptr @ptr: dec edi mov dword ptr[eax], 0 // pointer initialization jg @loop @end: pop edi pop esi pop ebx ret @varrec:xor ecx, ecx dec edi mov dword ptr[eax], ecx mov dword ptr[eax + 4], ecx mov dword ptr[eax + 8], ecx mov dword ptr[eax + 12], ecx jg @loop pop edi pop esi pop ebx ret @array: mov ecx, 1 // here eax=data edx=typeinfo call System.@InitializeArray dec edi jg @loop pop edi pop esi pop ebx end; {$ifndef UNICODE} // TMonitor.Destroy is not available ! -> apply to D2007 only procedure TObjectCleanupInstance; asm // faster version by AB push ebx mov ebx, eax @loop: mov ebx, [ebx] // handle three VMT levels per iteration mov edx, [ebx].vmtInitTable mov ebx, [ebx].vmtParent test edx, edx jnz @clr test ebx, ebx jz @end mov ebx, [ebx] mov edx, [ebx].vmtInitTable mov ebx, [ebx].vmtParent test edx, edx jnz @clr test ebx, ebx jz @end mov ebx, [ebx] mov edx, [ebx].vmtInitTable mov ebx, [ebx].vmtParent test edx, edx jnz @clr test ebx, ebx jnz @loop @end: pop ebx ret @clr: push offset @loop // TObject has no vmtInitTable -> safe jmp RecordClear // eax=self edx=typeinfo end; {$endif} procedure RecordClear(var Dest; TypeInfo: pointer); asm // faster version by AB (direct call to finalization procedures) { -> EAX pointer to record to be finalized } { EDX pointer to type info } { <- EAX pointer to record to be finalized } movzx ecx, byte ptr[edx].TTypeInfo.NameLen push ebx mov ebx, eax push esi push edi mov edi, [edx + ecx].TTypeInfo.ManagedCount lea esi, [edx + ecx].TTypeInfo.ManagedFields test edi, edi jz @end @loop: mov edx, [esi].TFieldInfo.TypeInfo mov eax, [esi].TFieldInfo.&Offset mov edx, [edx] add esi, 8 movzx ecx, [edx].TTypeInfo.Kind add eax, ebx // eax=data to be initialized sub cl, tkLString {$ifdef UNICODE} cmp cl, tkUString - tkLString + 1 {$else} cmp cl, tkDynArray - tkLString + 1 {$endif} jnb @err call dword ptr[@Tab + ecx * 4] dec edi jg @loop @end: mov eax, ebx // keep eax at return (see e.g. TObject.CleanupInstance) pop edi pop esi pop ebx ret nop nop nop // align @Tab @Tab: dd System.@LStrClr {$IFDEF LINUX} // under Linux, WideString are refcounted as AnsiString dd System.@LStrClr {$else} dd System.@WStrClr {$endif} {$ifdef LVCL} dd @err {$else} dd System.@VarClr {$endif} dd @array dd RecordClear dd System.@IntfClear dd @err dd System.@DynArrayClear {$ifdef UNICODE} dd System.@UStrClr {$endif} @err: mov al, reInvalidPtr pop edi pop esi pop ebx jmp System.Error @array: movzx ecx, [edx].TTypeInfo.NameLen add ecx, edx mov edx, dword ptr[ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^ mov ecx, [ecx].TTypeInfo.ManagedCount mov edx, [edx] call System.@FinalizeArray // we made Call @Array -> ret to continue end; procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); asm // faster version of _CopyRecord{dest, source, typeInfo: Pointer} by AB { -> EAX pointer to dest } { EDX pointer to source } { ECX pointer to typeInfo } push ebp push ebx push esi push edi movzx ebx, byte ptr[ecx].TTypeInfo.NameLen mov esi, edx // esi = source mov edi, eax // edi = dest add ebx, ecx // ebx = TFieldTable xor eax, eax // eax = current offset mov ebp, [ebx].TTypeInfo.ManagedCount // ebp = TFieldInfo count mov ecx, [ebx].TTypeInfo.recSize test ebp, ebp jz @fullcopy push ecx // SizeOf(record) on stack add ebx, offset TTypeInfo.ManagedFields[0] // ebx = first TFieldInfo @next: mov ecx, [ebx].TFieldInfo.&Offset mov edx, [ebx].TFieldInfo.TypeInfo sub ecx, eax mov edx, [edx] jle @nomov add esi, ecx add edi, ecx neg ecx @mov1: mov al, [esi + ecx] // fast copy not destructable data mov [edi + ecx], al inc ecx jnz @mov1 @nomov: mov eax, edi movzx ecx, [edx].TTypeInfo.Kind cmp ecx, tkLString je @LString jb @err {$ifdef UNICODE} cmp ecx, tkUString je @UString {$else} cmp ecx, tkDynArray je @dynaray {$endif} ja @err jmp dword ptr[ecx * 4 + @tab - tkWString * 4] @Tab: dd @WString, @variant, @array, @record, @interface, @err {$ifdef UNICODE} dd @dynaray {$endif} @errv: mov al, reVarInvalidOp jmp @err2 @err: mov al, reInvalidPtr @err2: pop edi pop esi pop ebx pop ebp jmp System.Error nop // all functions below have esi=source edi=dest @array: movzx ecx, byte ptr[edx].TTypeInfo.NameLen push dword ptr[edx + ecx].TTypeInfo.recSize push dword ptr[edx + ecx].TTypeInfo.ManagedCount mov ecx, dword ptr[edx + ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^ mov ecx, [ecx] mov edx, esi call System.@CopyArray pop eax // restore SizeOf(Array) jmp @finish @record:movzx ecx, byte ptr[edx].TTypeInfo.NameLen mov ecx, [edx + ecx].TTypeInfo.recSize push ecx mov ecx, edx mov edx, esi call RecordCopy pop eax // restore SizeOf(Record) jmp @finish nop nop nop @variant: {$ifdef NOVARCOPYPROC} mov edx, esi call System.@VarCopy {$else} mov edx, esi cmp dword ptr[VarCopyProc], 0 jz @errv call [VarCopyProc] {$endif} mov eax, 16 jmp @finish {$ifdef DELPHI6OROLDER} nop nop {$endif} @interface: mov edx, [esi] call System.@IntfCopy jmp @fin4 nop nop nop @dynaray: mov ecx, edx // ecx=TypeInfo mov edx, [esi] call System.@DynArrayAsg jmp @fin4 @WString: {$ifndef LINUX} mov edx, [esi] call System.@WStrAsg jmp @fin4 {$endif} @LString: mov edx, [esi] call System.@LStrAsg {$ifdef UNICODE} jmp @fin4 nop nop @UString: mov edx, [esi] call System.@UStrAsg {$endif} @fin4: mov eax, 4 @finish: add esi, eax add edi, eax add eax, [ebx].TFieldInfo.&Offset add ebx, 8 dec ebp // any other TFieldInfo? jnz @next pop ecx // ecx= SizeOf(record) @fullcopy: mov edx, edi sub ecx, eax mov eax, esi jle @nomov2 call dword ptr[MoveFast] @nomov2: pop edi pop esi pop ebx pop ebp end; {$endif CPUX86} {$endif DOPATCHTRTL} {$ifndef CPUARM} function SystemFillCharAddress: Pointer; asm {$ifdef CPU64} mov rax,offset System.@FillChar {$else} mov eax,offset System.@FillChar {$endif} end; {$ifdef CPU64} { Some notes about MOVNTI opcode use below: - Delphi inline assembler is not able to compile the instruction -> so we had to write some manual DB $... values instead :( - The I in MOVNTI means "non-temporal hint". It is implemented by using a write combining (WC) memory type protocol when writing the data to memory. The processor does not write the data into the cache hierarchy, nor does it fetch the corresponding cache line from memory into the cache hierarchy. By-passing the cache should enhance move() speed of big memory blocks. } procedure Movex64; // A. Bouchez' version asm // rcx=Source, rdx=Dest, r8=Count .noframe mov rax, r8 sub rcx, rdx je @11 jnc @03 add rax, rcx jc @17 @03: cmp r8, 8 jl @09 test dl, 07H jz @06 test dl, 01H jz @04 mov al, byte ptr[rcx + rdx] dec r8 mov byte ptr[rdx], al add rdx, 1 @04: test dl, 02H jz @05 mov ax, word ptr[rcx + rdx] sub r8, 2 mov word ptr[rdx], ax add rdx, 2 @05: test dl, 04H jz @06 mov eax, dword ptr[rcx + rdx] sub r8, 4 mov dword ptr[rdx], eax add rdx, 4 @06: mov r9, r8 shr r9, 5 jnz @12 @07: mov r9, r8 shr r9, 3 jz @09 nop @08: mov rax, qword ptr[rcx + rdx] mov qword ptr[rdx], rax add rdx, 8 dec r9 jnz @08 and r8, 07H @09: test r8, r8 jle @11 @10: mov al, byte ptr[rcx + rdx] mov byte ptr[rdx], al add rdx, 1 dec r8 jnz @10 @11: ret @12: cmp r9, 8192 jc @13 cmp rcx, 4096 jnc @14 @13: add rdx, 32 mov rax, qword ptr[rcx + rdx - 20H] mov r10, qword ptr[rcx + rdx - 18H] mov qword ptr[rdx - 20H], rax mov qword ptr[rdx - 18H], r10 mov rax, qword ptr[rcx + rdx - 10H] mov r10, qword ptr[rcx + rdx - 8H] mov qword ptr[rdx - 10H], rax mov qword ptr[rdx - 8H], r10 dec r9 jnz @13 and r8, 1FH jmp @07 @14: mov eax, 32 @15: prefetchnta [rcx + rdx] prefetchnta [rcx + rdx + 40H] add rdx, 128 dec eax jnz @15 sub rdx, 4096 mov eax, 64 @16: add rdx, 64 mov r9, qword ptr[rcx + rdx - 40H] mov r10, qword ptr[rcx + rdx - 38H] db $4C, $0F, $C3, $4A, $C0 // movnti qword ptr [rdx-40H],r9 db $4C, $0F, $C3, $52, $C8 // movnti qword ptr [rdx-38H],r10 mov r9, qword ptr[rcx + rdx - 30H] mov r10, qword ptr[rcx + rdx - 28H] db $4C, $0F, $C3, $4A, $D0 // movnti qword ptr [rdx-30H],r9 db $4C, $0F, $C3, $52, $D8 // movnti qword ptr [rdx-28H],r10 dec eax mov r9, qword ptr[rcx + rdx - 20H] mov r10, qword ptr[rcx + rdx - 18H] db $4C, $0F, $C3, $4A, $E0 // movnti qword ptr [rdx-20H],r9 db $4C, $0F, $C3, $52, $E8 // movnti qword ptr [rdx-18H],r10 mov r9, qword ptr[rcx + rdx - 10H] mov r10, qword ptr[rcx + rdx - 8H] db $4C, $0F, $C3, $4A, $F0 // movnti qword ptr [rdx-10H],r9 db $4C, $0F, $C3, $52, $F8 // movnti qword ptr [rdx-8H],r10 jnz @16 sub r8, 4096 cmp r8, 4096 jnc @14 mfence jmp @06 @17: add rdx, r8 cmp r8, 8 jl @23 test dl, 07H jz @20 test dl, 01H jz @18 dec rdx mov al, byte ptr[rcx + rdx] dec r8 mov byte ptr[rdx], al @18: test dl, 02H jz @19 sub rdx, 2 mov ax, word ptr[rcx + rdx] sub r8, 2 mov word ptr[rdx], ax @19: test dl, 04H jz @20 sub rdx, 4 mov eax, dword ptr[rcx + rdx] sub r8, 4 mov dword ptr[rdx], eax @20: mov r9, r8 shr r9, 5 jnz @26 @21: mov r9, r8 shr r9, 3 jz @23 @22: sub rdx, 8 mov rax, qword ptr[rcx + rdx] dec r9 mov qword ptr[rdx], rax jnz @22 and r8, 07H @23: test r8, r8 jle @25 @24: dec rdx mov al, byte ptr[rcx + rdx] dec r8 mov byte ptr[rdx], al jnz @24 @25: ret @26: cmp r9, 8192 jc @27 cmp rcx, - 4096 jc @28 @27: sub rdx, 32 mov rax, qword ptr[rcx + rdx + 18H] mov r10, qword ptr[rcx + rdx + 10H] mov qword ptr[rdx + 18H], rax mov qword ptr[rdx + 10H], r10 dec r9 mov rax, qword ptr[rcx + rdx + 8H] mov r10, qword ptr[rcx + rdx] mov qword ptr[rdx + 8H], rax mov qword ptr[rdx], r10 jnz @27 and r8, 1FH jmp @21 @28: mov eax, 32 @29: sub rdx, 128 prefetchnta [rcx + rdx] prefetchnta [rcx + rdx + 40H] dec eax jnz @29 add rdx, 4096 mov eax, 64 @30: sub rdx, 64 sub r8, 4096 mov r9, qword ptr[rcx + rdx + 38H] mov r10, qword ptr[rcx + rdx + 30H] db $4C, $0F, $C3, $4A, $38 // movnti qword ptr [rdx+38H],r9 db $4C, $0F, $C3, $52, $30 // movnti qword ptr [rdx+30H],r10 mov r9, qword ptr[rcx + rdx + 28H] mov r10, qword ptr[rcx + rdx + 20H] db $4C, $0F, $C3, $4A, $28 // movnti qword ptr [rdx+28H],r9 db $4C, $0F, $C3, $52, $20 // movnti qword ptr [rdx+20H],r10 dec eax mov r9, qword ptr[rcx + rdx + 18H] mov r10, qword ptr[rcx + rdx + 10H] db $4C, $0F, $C3, $4A, $18 // movnti qword ptr [rdx+18H],r9 db $4C, $0F, $C3, $52, $10 // movnti qword ptr [rdx+10H],r10 mov r9, qword ptr[rcx + rdx + 8H] mov r10, qword ptr[rcx + rdx] db $4C, $0F, $C3, $4A, $08 // movnti qword ptr [rdx+8H],r9 db $4C, $0F, $C3, $12 // movnti qword ptr [rdx],r10 jnz @30 cmp r8, 4096 jnc @28 mfence jmp @20 end; procedure FillCharx64; // A. Bouchez' version asm // rcx=Dest rdx=Count r8=Value .noframe mov rax, r8 cmp rdx, 32 jle @small and r8, 0FFH mov r9, 101010101010101H imul r8, r9 test cl, 07H jz @27C5 test cl, 01H jz @27A4 mov byte ptr[rcx], r8b add rcx, 1 sub rdx, 1 @27A4: test cl, 02H jz @27B5 mov word ptr[rcx], r8w add rcx, 2 sub rdx, 2 @27B5: test cl, 04H jz @27C5 mov dword ptr[rcx], r8d add rcx, 4 sub rdx, 4 @27C5: mov rax, rdx and rdx, 3FH shr rax, 6 jnz @27FD @27D2: mov rax, rdx and rdx, 07H shr rax, 3 jz @27EC @27E0: mov qword ptr[rcx], r8 add rcx, 8 dec rax jnz @27E0 @27EC: test rdx, rdx jle @27FC @27F1: mov byte ptr[rcx], r8b inc rcx dec rdx jnz @27F1 @27FC: ret @27FD: cmp rax, 8192 jnc @2840 @2810: add rcx, 64 mov qword ptr[rcx - 40H], r8 mov qword ptr[rcx - 38H], r8 mov qword ptr[rcx - 30H], r8 mov qword ptr[rcx - 28H], r8 dec rax mov qword ptr[rcx - 20H], r8 mov qword ptr[rcx - 18H], r8 mov qword ptr[rcx - 10H], r8 mov qword ptr[rcx - 8H], r8 jnz @2810 jmp @27D2 @2840: add rcx, 64 db $4C, $0F, $C3, $41, $C0 // movnti qword ptr [rcx-40H],r8 db $4C, $0F, $C3, $41, $C8 // movnti qword ptr [rcx-38H],r8 db $4C, $0F, $C3, $41, $D0 // movnti qword ptr [rcx-30H],r8 db $4C, $0F, $C3, $41, $D8 // movnti qword ptr [rcx-28H],r8 dec rax db $4C, $0F, $C3, $41, $E0 // movnti qword ptr [rcx-20H],r8 db $4C, $0F, $C3, $41, $E8 // movnti qword ptr [rcx-18H],r8 db $4C, $0F, $C3, $41, $F0 // movnti qword ptr [rcx-10H],r8 db $4C, $0F, $C3, $41, $F8 // movnti qword ptr [rcx-8H],r8 jnz @2840 mfence jmp @27D2 @small: // rcx=Dest rdx=Count r8=Value<=32 test rdx, rdx jle @@done mov ah, al mov [rcx + rdx - 1], al lea r8, [@table] and rdx, - 2 neg rdx lea rdx, [r8 + rdx * 2 + 64] jmp rdx @table: mov [rcx + 30], ax mov [rcx + 28], ax mov [rcx + 26], ax mov [rcx + 24], ax mov [rcx + 22], ax mov [rcx + 20], ax mov [rcx + 18], ax mov [rcx + 16], ax mov [rcx + 14], ax mov [rcx + 12], ax mov [rcx + 10], ax mov [rcx + 8], ax mov [rcx + 6], ax mov [rcx + 4], ax mov [rcx + 2], ax mov [rcx], ax ret @@done: end; {$ifdef WITH_ERMS} // x64 version only for Windows ABI procedure MoveERMSB; // Ivy Bridge+ Enhanced REP MOVSB/STOSB CPUs asm // rcx=Source, rdx=Dest, r8=Count .noframe test r8, r8 jle @none cld push rsi push rdi cmp rdx, rcx ja @down mov rsi, rcx mov rdi, rdx mov rcx, r8 rep movsb pop rdi pop rsi @none: ret @down: lea rsi, [rcx + r8 - 1] lea rdi, [rdx + r8 - 1] mov rcx, r8 std rep movsb cld pop rdi pop rsi end; procedure FillCharERMSB; // Ivy Bridge+ Enhanced REP MOVSB/STOSB CPUs asm // rcx=Dest, rdx=Count, r8b=Value .noframe test rdx, rdx jle @none cld push rdi mov rdi, rcx mov rax, r8 mov rcx, rdx rep stosb pop rdi @none: end; {$endif WITH_ERMS} {$else CPU64} {$ifndef PUREPASCAL} procedure FillCharX87; asm // eax=Dest edx=Count cl=Value // faster version by John O'Harrow (Code Size = 153 Bytes) mov ch, cl // copy value into both bytes of cx cmp edx, 32 jl @small mov [eax], cx // fill first 8 bytes mov [eax + 2], cx mov [eax + 4], cx mov [eax + 6], cx sub edx, 16 fld qword ptr[eax] fst qword ptr[eax + edx] // fill last 16 bytes fst qword ptr[eax + edx + 8] mov ecx, eax and ecx, 7 // 8-byte align writes sub ecx, 8 sub eax, ecx add edx, ecx add eax, edx neg edx @loop: fst qword ptr[eax + edx] // fill 16 bytes per loop fst qword ptr[eax + edx + 8] add edx, 16 jl @loop ffree st(0) fincstp ret nop @small: test edx, edx jle @done mov [eax + edx - 1], cl // fill last byte and edx, -2 // no. of words to fill neg edx lea edx, [@fill + 60 + edx * 2] jmp edx nop // align jump destinations nop @fill: mov [eax + 28], cx mov [eax + 26], cx mov [eax + 24], cx mov [eax + 22], cx mov [eax + 20], cx mov [eax + 18], cx mov [eax + 16], cx mov [eax + 14], cx mov [eax + 12], cx mov [eax + 10], cx mov [eax + 8], cx mov [eax + 6], cx mov [eax + 4], cx mov [eax + 2], cx mov [eax], cx ret // for alignment @done: db $f3 // rep ret AMD trick here end; /// faster implementation of Move() for Delphi versions with no FastCode inside procedure MoveX87; asm // eax=source edx=dest ecx=count // original code by John O'Harrow - included since delphi 2007 cmp eax, edx jz @exit // exit if source=dest cmp ecx, 32 ja @lrg // count > 32 or count < 0 sub ecx, 8 jg @sml // 9..32 byte move jmp dword ptr[@table + 32 + ecx * 4] // 0..8 byte move @sml: fild qword ptr[eax + ecx] // load last 8 fild qword ptr[eax] // load first 8 cmp ecx, 8 jle @sml16 fild qword ptr[eax + 8] // load second 8 cmp ecx, 16 jle @sml24 fild qword ptr[eax + 16] // load third 8 fistp qword ptr[edx + 16] // save third 8 @sml24: fistp qword ptr[edx + 8] // save second 8 @sml16: fistp qword ptr[edx] // save first 8 fistp qword ptr[edx + ecx] // save last 8 ret @exit: rep ret @table: dd @exit, @m01, @m02, @m03, @m04, @m05, @m06, @m07, @m08 @lrgfwd:push edx fild qword ptr[eax] // first 8 lea eax, [eax + ecx - 8] lea ecx, [ecx + edx - 8] fild qword ptr[eax] // last 8 push ecx neg ecx and edx, -8 // 8-byte align writes lea ecx, [ecx + edx + 8] pop edx @fwd: fild qword ptr[eax + ecx] fistp qword ptr[edx + ecx] add ecx, 8 jl @fwd fistp qword ptr[edx] // last 8 pop edx fistp qword ptr[edx] // first 8 ret @lrg: jng @exit // count < 0 cmp eax, edx ja @lrgfwd sub edx, ecx cmp eax, edx lea edx, [edx + ecx] jna @lrgfwd sub ecx, 8 // backward move push ecx fild qword ptr[eax + ecx] // last 8 fild qword ptr[eax] // first 8 add ecx, edx and ecx, -8 // 8-byte align writes sub ecx, edx @bwd: fild qword ptr[eax + ecx] fistp qword ptr[edx + ecx] sub ecx, 8 jg @bwd pop ecx fistp qword ptr[edx] // first 8 fistp qword ptr[edx + ecx] // last 8 ret @m01: movzx ecx, byte ptr[eax] mov [edx], cl ret @m02: movzx ecx, word ptr[eax] mov [edx], cx ret @m03: mov cx, [eax] mov al, [eax + 2] mov [edx], cx mov [edx + 2], al ret @m04: mov ecx, [eax] mov [edx], ecx ret @m05: mov ecx, [eax] mov al, [eax + 4] mov [edx], ecx mov [edx + 4], al ret @m06: mov ecx, [eax] mov ax, [eax + 4] mov [edx], ecx mov [edx + 4], ax ret @m07: mov ecx, [eax] mov eax, [eax + 3] mov [edx], ecx mov [edx + 3], eax ret @m08: mov ecx, [eax] mov eax, [eax + 4] mov [edx], ecx mov [edx + 4], eax end; procedure FillCharERMSB; // Ivy Bridge+ Enhanced REP MOVSB/STOSB CPUs asm // eax=Dest edx=Count cl=Value test edx, edx jle @none cld push edi mov edi, eax mov al, cl mov ecx, edx rep stosb pop edi @none: end; procedure MoveERMSB; // Ivy Bridge+ Enhanced REP MOVSB/STOSB CPUs asm // eax=source edx=dest ecx=count test ecx, ecx jle @none cld push esi push edi cmp edx, eax ja @down mov esi, eax mov edi, edx rep movsb pop edi pop esi @none:ret @down:lea esi, [eax + ecx - 1] lea edi, [edx + ecx - 1] std rep movsb pop edi pop esi cld end; function StrLenX86(S: pointer): PtrInt; // pure x86 function (if SSE2 not available) - faster than SysUtils' version asm test eax, eax jz @0 cmp byte ptr[eax + 0], 0 je @0 cmp byte ptr[eax + 1], 0 je @1 cmp byte ptr[eax + 2], 0 je @2 cmp byte ptr[eax + 3], 0 je @3 push eax and eax, -4 { DWORD Align Reads } @Loop: add eax, 4 mov edx, [eax] { 4 Chars per Loop } lea ecx, [edx - $01010101] not edx and edx, ecx and edx, $80808080 { Set Byte to $80 at each #0 Position } jz @Loop { Loop until any #0 Found } pop ecx bsf edx, edx { Find First #0 Position } shr edx, 3 { Byte Offset of First #0 } add eax, edx { Address of First #0 } sub eax, ecx { Returns Length } ret @0: xor eax, eax ret @1: mov eax, 1 ret @2: mov eax, 2 ret @3: mov eax, 3 end; {$ifndef DELPHI5OROLDER} // need SSE2 asm instruction set procedure FillCharSSE2; asm // Dest=eax Count=edx Value=cl mov ch, cl {copy value into both bytes of cx} cmp edx, 32 jl @small sub edx, 16 movd xmm0, ecx pshuflw xmm0, xmm0, 0 pshufd xmm0, xmm0, 0 movups [eax], xmm0 {fill first 16 bytes} movups [eax + edx], xmm0 {fill last 16 bytes} mov ecx, eax {16-byte align writes} and ecx, 15 sub ecx, 16 sub eax, ecx add edx, ecx add eax, edx neg edx cmp edx, - 512 * 1024 jb @large @loop: movaps [eax + edx], xmm0 {fill 16 bytes per loop} add edx, 16 jl @loop ret @large: movntdq [eax + edx], xmm0 {fill 16 bytes per loop} add edx, 16 jl @large ret @small: test edx, edx jle @done mov [eax + edx - 1], cl {fill last byte} and edx, -2 {no. of words to fill} neg edx lea edx, [@smallfill + 60 + edx * 2] jmp edx nop {align jump destinations} nop @smallfill: mov [eax + 28], cx mov [eax + 26], cx mov [eax + 24], cx mov [eax + 22], cx mov [eax + 20], cx mov [eax + 18], cx mov [eax + 16], cx mov [eax + 14], cx mov [eax + 12], cx mov [eax + 10], cx mov [eax + 8], cx mov [eax + 6], cx mov [eax + 4], cx mov [eax + 2], cx mov [eax], cx ret {do not remove - this is for alignment} @done: end; {$endif DELPHI5OROLDER} {$endif PUREPASCAL} {$endif CPU64} procedure InitRedirectCode; begin {$ifdef DELPHI5OROLDER} StrLen := @StrLenX86; MoveFast := @MoveX87; FillcharFast := @FillCharX87; {$else DELPHI5OROLDER} {$ifdef CPU64} {$ifdef HASAESNI} {$ifdef FORCE_STRSSE42} if cfSSE42 in CpuFeatures then begin StrLen := @StrLenSSE42; StrComp := @StrCompSSE42; end else {$endif FORCE_STRSSE42} {$endif HASAESNI} StrLen := @StrLenSSE2; {$ifdef WITH_ERMS}{$ifdef MSWINDOWS} // disabled (slower for small blocks) if cfERMS in CpuFeatures then begin MoveFast := @MoveERMSB; FillcharFast := @FillCharERMSB; end else {$endif}{$endif} begin MoveFast := @Movex64; FillCharFast := @Fillcharx64; end; {$else CPU64} {$ifdef CPUINTEL} if cfSSE2 in CpuFeatures then begin {$ifdef FORCE_STRSSE42} if cfSSE42 in CpuFeatures then StrLen := @StrLenSSE42 else {$endif FORCE_STRSSE42} StrLen := @StrLenSSE2; FillcharFast := @FillCharSSE2; end else begin StrLen := @StrLenX86; FillcharFast := @FillCharX87; end; {$ifdef WITH_ERMS} // disabled by default (much slower for small blocks) if cfERMS in CpuFeatures then begin MoveFast := @MoveERMSB; FillcharFast := @FillCharERMSB; end else {$endif} MoveFast := @MoveX87; // SSE2 is not faster than X87 version on 32-bit CPU {$endif CPUINTEL} {$endif CPU64} {$endif DELPHI5OROLDER} // do redirection from RTL to our fastest version {$ifdef DOPATCHTRTL} if DebugHook=0 then begin // patch only outside debugging RedirectCode(SystemFillCharAddress,@FillcharFast); RedirectCode(@System.Move,@MoveFast); {$ifdef CPUX86} RedirectCode(SystemRecordCopyAddress,@RecordCopy); RedirectCode(SystemFinalizeRecordAddress,@RecordClear); RedirectCode(SystemInitializeRecordAddress,@_InitializeRecord); {$ifndef UNICODE} // buggy Delphi 2009+ RTL expects a TMonitor.Destroy call RedirectCode(@TObject.CleanupInstance,@TObjectCleanupInstance); {$endif UNICODE} {$endif} end; {$endif DOPATCHTRTL} end; {$endif CPUARM} {$endif FPC} { ************ Custom record / dynamic array JSON serialization } procedure SaveJSON(const Value; TypeInfo: pointer; Options: TTextWriterOptions; var result: RawUTF8); var temp: TTextWriterStackBuffer; begin with DefaultTextWriterJSONClass.CreateOwnedStream(temp) do try fCustomOptions := fCustomOptions+Options; AddTypedJSON(TypeInfo,Value); SetText(result); finally Free; end; end; function SaveJSON(const Value; TypeInfo: pointer; EnumSetsAsText: boolean): RawUTF8; var options: TTextWriterOptions; begin if EnumSetsAsText then options := [twoEnumSetsAsTextInRecord,twoFullSetsAsStar] else options := [twoFullSetsAsStar]; SaveJSON(Value,TypeInfo,options,result); end; type /// information about one customized JSON serialization TJSONCustomParserRegistration = record RecordTypeName: RawUTF8; RecordTextDefinition: RawUTF8; DynArrayTypeInfo: pointer; RecordTypeInfo: pointer; Reader: TDynArrayJSONCustomReader; Writer: TDynArrayJSONCustomWriter; RecordCustomParser: TJSONRecordAbstract; end; PJSONCustomParserRegistration = ^TJSONCustomParserRegistration; TJSONCustomParserRegistrations = array of TJSONCustomParserRegistration; PTJSONCustomParserAbstract = ^TJSONRecordAbstract; /// used internally to manage custom record / dynamic array JSON serialization // - e.g. used by TTextWriter.RegisterCustomJSONSerializer*() TJSONCustomParsers = class protected fLastDynArrayIndex: integer; fLastRecordIndex: integer; fParser: TJSONCustomParserRegistrations; fParsersCount: Integer; fParsers: TDynArrayHashed; {$ifndef NOVARIANTS} fVariants: array of record TypeClass: TCustomVariantType; Reader: TDynArrayJSONCustomReader; Writer: TDynArrayJSONCustomWriter; end; function VariantSearch(aClass: TCustomVariantType): integer; procedure VariantWrite(aClass: TCustomVariantType; aWriter: TTextWriter; const aValue: variant; Escape: TTextWriterKind); {$endif} function TryToGetFromRTTI(aDynArrayTypeInfo, aRecordTypeInfo: pointer): integer; function Search(aTypeInfo: pointer; var Reg: TJSONCustomParserRegistration; AddIfNotExisting: boolean): integer; function DynArraySearch(aDynArrayTypeInfo, aRecordTypeInfo: pointer; AddIfNotExisting: boolean=true): integer; overload; function RecordSearch(aRecordTypeInfo: pointer; AddIfNotExisting: boolean=true): integer; overload; function RecordSearch(aRecordTypeInfo: pointer; out Reader: TDynArrayJSONCustomReader): boolean; overload; function RecordSearch(aRecordTypeInfo: pointer; out Writer: TDynArrayJSONCustomWriter; PParser: PTJSONCustomParserAbstract): boolean; overload; function RecordSearch(const aTypeName: RawUTF8): integer; overload; function RecordRTTITextHash(aRecordTypeInfo: pointer; var crc: cardinal; out recsize: integer): boolean; public constructor Create; procedure RegisterCallbacks(aTypeInfo: pointer; aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); function RegisterFromText(aTypeInfo: pointer; const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; {$ifndef NOVARIANTS} procedure RegisterCallbacksVariant(aClass: TCustomVariantType; aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); {$endif} property Parser: TJSONCustomParserRegistrations read fParser; property ParsersCount: Integer read fParsersCount; end; var GlobalJSONCustomParsers: TJSONCustomParsers; constructor TJSONCustomParsers.Create; begin fParsers.InitSpecific(TypeInfo(TJSONCustomParserRegistrations), fParser,djRawUTF8,@fParsersCount,true); GarbageCollectorFreeAndNil(GlobalJSONCustomParsers,self); end; function TJSONCustomParsers.TryToGetFromRTTI(aDynArrayTypeInfo, aRecordTypeInfo: pointer): integer; var Reg: TJSONCustomParserRegistration; RegRoot: TJSONCustomParserRTTI; {$ifdef ISDELPHI2010} info: PTypeInfo; {$endif} added: boolean; ndx, len: integer; name: PShortString; begin result := -1; Reg.RecordTypeInfo := aRecordTypeInfo; Reg.DynArrayTypeInfo := aDynArrayTypeInfo; TypeInfoToName(Reg.RecordTypeInfo,Reg.RecordTypeName); if Reg.RecordTypeName='' then begin name := TypeInfoToShortString(Reg.DynArrayTypeInfo); if name=nil then exit; // we need a type name! len := length(name^); // try to guess from T*DynArray or T*s names if (len>12) and (IdemPropName('DynArray',@name^[len-7],8)) then FastSetString(Reg.RecordTypeName,@name^[1],len-8) else if (len>3) and (name^[len]='s') then FastSetString(Reg.RecordTypeName,@name^[1],len-1) else exit; end; RegRoot := TJSONCustomParserRTTI.CreateFromTypeName('',Reg.RecordTypeName); {$ifdef ISDELPHI2010} if RegRoot=nil then begin info := GetTypeInfo(aRecordTypeInfo,tkRecordKinds); if info=nil then exit; // not enough RTTI inc(PByte(info),info^.ManagedCount*SizeOf(TFieldInfo)-SizeOf(TFieldInfo)); inc(PByte(info),info^.NumOps*SizeOf(pointer)); // jump RecOps[] if info^.AllCount=0 then exit; // not enough RTTI -> avoid exception in constructor below end; {$else} if RegRoot=nil then exit; // not enough RTTI for older versions of Delphi {$endif} Reg.RecordCustomParser := TJSONRecordRTTI.Create(Reg.RecordTypeInfo,RegRoot); Reg.Reader := Reg.RecordCustomParser.CustomReader; Reg.Writer := Reg.RecordCustomParser.CustomWriter; if self=nil then if GlobalJSONCustomParsers<>nil then // may have been set just above self := GlobalJSONCustomParsers else self := TJSONCustomParsers.Create; ndx := fParsers.FindHashedForAdding(Reg.RecordTypeName,added); if not added then exit; // name should be unique fParser[ndx] := Reg; result := ndx; end; function TJSONCustomParsers.DynArraySearch(aDynArrayTypeInfo,aRecordTypeInfo: pointer; AddIfNotExisting: boolean): Integer; var threadsafe: integer; parser: PJSONCustomParserRegistration; begin // O(n) brute force is fast enough, since n remains small (mostly<64) if self<>nil then if (aDynArrayTypeInfo<>nil) and (fParsersCount<>0) then begin threadsafe := fLastDynArrayIndex; if (cardinal(threadsafe)=0 then fLastRecordIndex := result; end else result := -1; end; function TJSONCustomParsers.RecordSearch(aRecordTypeInfo: pointer; AddIfNotExisting: boolean): integer; begin if aRecordTypeInfo=nil then begin result := -1; exit; end; if self<>nil then if (cardinal(fLastRecordIndex)=0 then fLastRecordIndex := result; end else result := -1; end; function TJSONCustomParsers.RecordSearch(const aTypeName: RawUTF8): integer; begin if self=nil then result := -1 else if (cardinal(fLastRecordIndex)=0 then fLastRecordIndex := result; end; end; function TJSONCustomParsers.RecordSearch(aRecordTypeInfo: pointer; out Reader: TDynArrayJSONCustomReader): boolean; var ndx: integer; begin ndx := RecordSearch(aRecordTypeInfo); if (ndx>=0) and Assigned(fParser[ndx].Reader) then begin Reader := fParser[ndx].Reader; result := true; end else result := false; end; function TJSONCustomParsers.RecordRTTITextHash(aRecordTypeInfo: pointer; var crc: cardinal; out recsize: integer): boolean; var ndx: integer; begin if (self<>nil) and (aRecordTypeInfo<>nil) then for ndx := 0 to fParsersCount-1 do with fParser[ndx] do if RecordTypeInfo=aRecordTypeInfo then begin if RecordTextDefinition='' then break; crc := crc32c(crc,pointer(RecordTextDefinition),length(RecordTextDefinition)); recsize := RecordTypeInfoSize(aRecordTypeInfo); result := true; exit; end; result := false; end; function TJSONCustomParsers.RecordSearch(aRecordTypeInfo: pointer; out Writer: TDynArrayJSONCustomWriter; PParser: PTJSONCustomParserAbstract): boolean; var ndx: integer; begin result := false; ndx := RecordSearch(aRecordTypeInfo); if (ndx>=0) and Assigned(fParser[ndx].Writer) then begin Writer := fParser[ndx].Writer; if PParser<>nil then PParser^ := fParser[ndx].RecordCustomParser; result := true; end; end; function TJSONCustomParsers.Search(aTypeInfo: pointer; var Reg: TJSONCustomParserRegistration; AddIfNotExisting: boolean): integer; var added: boolean; begin if (aTypeInfo=nil) or (self=nil) then raise ESynException.CreateUTF8('%.Search(%)',[self,aTypeInfo]); {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(Reg,SizeOf(Reg),0); case PTypeKind(aTypeInfo)^ of tkDynArray: begin Reg.DynArrayTypeInfo := aTypeInfo; Reg.RecordTypeInfo := DynArrayTypeInfoToRecordInfo(aTypeInfo); result := DynArraySearch(Reg.DynArrayTypeInfo,Reg.RecordTypeInfo,false); end; tkRecord{$ifdef FPC},tkObject{$endif}: begin Reg.DynArrayTypeInfo := nil; Reg.RecordTypeInfo := aTypeInfo; result := RecordSearch(Reg.RecordTypeInfo,false); end; else raise ESynException.CreateUTF8('%.Search: % not a tkDynArray/tkRecord', [self,ToText(PTypeKind(aTypeInfo)^)^]); end; if not AddIfNotExisting then exit; TypeInfoToName(Reg.RecordTypeInfo,Reg.RecordTypeName); if Reg.RecordTypeName='' then TypeInfoToName(Reg.DynArrayTypeInfo,Reg.RecordTypeName); if Reg.RecordTypeName='' then raise ESynException.CreateUTF8('%.Search(%) has no type name',[self,aTypeInfo]); if result<0 then result := fParsers.FindHashedForAdding(Reg.RecordTypeName,added); end; {$ifndef NOVARIANTS} function TJSONCustomParsers.VariantSearch(aClass: TCustomVariantType): integer; begin if self<>nil then for result := 0 to length(fVariants)-1 do if fVariants[result].TypeClass=aClass then exit; result := -1; end; procedure TJSONCustomParsers.VariantWrite(aClass: TCustomVariantType; aWriter: TTextWriter; const aValue: variant; Escape: TTextWriterKind); var ndx: integer; temp: string; begin ndx := VariantSearch(aClass); if (ndx>=0) and Assigned(fVariants[ndx].Writer) then fVariants[ndx].Writer(aWriter,aValue) else begin temp := aValue; // fallback to JSON string from variant-to-string conversion if Escape=twJSONEscape then aWriter.Add('"'); {$ifdef UNICODE} aWriter.AddW(pointer(temp),length(temp),Escape); {$else} aWriter.AddAnsiString(temp,Escape); {$endif} if Escape=twJSONEscape then aWriter.Add('"'); end; end; procedure TJSONCustomParsers.RegisterCallbacksVariant(aClass: TCustomVariantType; aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); var ndx: integer; begin if self=nil then self := TJSONCustomParsers.Create; ndx := VariantSearch(aClass); if ndx<0 then begin ndx := length(fVariants); SetLength(fVariants,ndx+1); fVariants[ndx].TypeClass := aClass; end; fVariants[ndx].Writer := aWriter; fVariants[ndx].Reader := aReader; end; {$endif} procedure TJSONCustomParsers.RegisterCallbacks(aTypeInfo: pointer; aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); var Reg: TJSONCustomParserRegistration; ForAdding: boolean; ndx: integer; begin if self=nil then self := TJSONCustomParsers.Create; ForAdding := Assigned(aReader) or Assigned(aWriter); ndx := Search(aTypeInfo,Reg,ForAdding); if ForAdding then begin Reg.Writer := aWriter; Reg.Reader := aReader; fParser[ndx] := Reg; end else if ndx>=0 then begin fParsers.Delete(ndx); fParsers.ReHash; end; end; function TJSONCustomParsers.RegisterFromText(aTypeInfo: pointer; const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; var Reg: TJSONCustomParserRegistration; ForAdding: boolean; ndx: integer; begin if self=nil then self := TJSONCustomParsers.Create; ForAdding := aRTTIDefinition<>''; ndx := Search(aTypeInfo,Reg,ForAdding); if ForAdding then begin result := TJSONRecordTextDefinition.FromCache(Reg.RecordTypeInfo,aRTTIDefinition); Reg.RecordTextDefinition := aRTTIDefinition; Reg.Reader := result.CustomReader; Reg.Writer := result.CustomWriter; Reg.RecordCustomParser := result; fParser[ndx] := Reg; end else begin result := nil; if ndx>=0 then begin fParsers.Delete(ndx); fParsers.ReHash; end; end; end; function ManagedTypeSaveRTTIHash(info: PTypeInfo; var crc: cardinal): integer; var itemtype: PTypeInfo; i, unmanagedsize: integer; field: PFieldInfo; dynarray: TDynArray; begin // info is expected to come from a DeRef() if retrieved from RTTI result := 0; if info=nil then exit; {$ifdef FPC} // storage binary layout as Delphi's ordinal value crc := crc32c(crc,@FPCTODELPHI[info^.Kind],1); {$else} crc := crc32c(crc,@info^.Kind,1); // hash RTTI kind, but not name {$endif} case info^.Kind of // handle nested RTTI tkLString,{$ifdef FPC}tkLStringOld,{$endif}{$ifdef HASVARUSTRING}tkUString,{$endif} tkWString,tkInterface: result := SizeOf(pointer); {$ifndef NOVARIANTS} tkVariant: result := SizeOf(variant); {$endif} tkRecord{$ifdef FPC},tkObject{$endif}: // first search from custom RTTI text if not GlobalJSONCustomParsers.RecordRTTITextHash(info,crc,result) then begin itemtype := GetTypeInfo(info,tkRecordKinds); if itemtype<>nil then begin unmanagedsize := itemtype^.recsize; for i := 1 to GetManagedFields(itemtype,field) do begin info := DeRef(field^.TypeInfo); {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields if info^.Kind in tkManagedTypes then // as with Delphi {$endif} dec(unmanagedsize,ManagedTypeSaveRTTIHash(info,crc)); inc(field); end; crc := crc32c(crc,@unmanagedsize,4); result := itemtype^.recSize; end; end; tkArray: begin itemtype := ArrayItemType(info,result); if info=nil then exit; unmanagedsize := result; if itemtype<>nil then for i := 1 to info^.elCount do dec(unmanagedsize,ManagedTypeSaveRTTIHash(itemtype,crc)); crc := crc32c(crc,@unmanagedsize,4); end; tkDynArray: begin dynarray.Init(info,field); // fake void array pointer crc := dynarray.SaveToTypeInfoHash(crc); result := SizeOf(pointer); end; end; end; function TypeInfoToHash(aTypeInfo: pointer): cardinal; begin result := 0; ManagedTypeSaveRTTIHash(aTypeInfo,result); end; function RecordSaveJSON(const Rec; TypeInfo: pointer; EnumSetsAsText: boolean): RawUTF8; begin result := SaveJSON(Rec,TypeInfo,EnumSetsAsText); end; const NULCHAR: AnsiChar = #0; function RecordLoadJSON(var Rec; JSON: PUTF8Char; TypeInfo: pointer; EndOfObject: PUTF8Char=nil): PUTF8Char; var wasString, wasValid: boolean; Reader: TDynArrayJSONCustomReader; FirstChar,EndOfObj: AnsiChar; Val: PUTF8Char; ValLen: integer; begin // code below must match TTextWriter.AddRecordJSON result := nil; // indicates error if JSON=nil then exit; if (@Rec=nil) or (TypeInfo=nil) then raise ESynException.CreateUTF8('Invalid RecordLoadJSON(%) call',[TypeInfo]); if JSON^=' ' then repeat inc(JSON); if JSON^=#0 then exit; until JSON^<>' '; if PCardinal(JSON)^=JSON_BASE64_MAGIC_QUOTE then begin if not (PTypeKind(TypeInfo)^ in tkRecordTypes) then raise ESynException.CreateUTF8('RecordLoadJSON(%/%)', [PShortString(@PTypeInfo(TypeInfo).NameLen)^,ToText(PTypeKind(TypeInfo)^)^]); Val := GetJSONField(JSON,JSON,@wasString,@EndOfObj,@ValLen); if (Val=nil) or not wasString or (ValLen<3) or (PInteger(Val)^ and $00ffffff<>JSON_BASE64_MAGIC) or (RecordLoad(Rec,pointer(Base64ToBin(PAnsiChar(Val)+3,ValLen-3)),TypeInfo)=nil) then exit; // invalid content end else begin if not GlobalJSONCustomParsers.RecordSearch(TypeInfo,Reader) then exit; FirstChar := JSON^; JSON := Reader(JSON,Rec,wasValid); if not wasValid then exit; if (JSON<>nil) and (JSON^ in [#1..' ']) then repeat inc(JSON) until not(JSON^ in [#1..' ']); if (JSON<>nil) and (JSON^<>#0) then if FirstChar='"' then // special case e.g. for TGUID string EndOfObj := FirstChar else begin EndOfObj := JSON^; inc(JSON); end else EndOfObj := #0; end; if JSON=nil then // end reached, but valid content decoded result := @NULCHAR else result := JSON; if EndOfObject<>nil then EndOfObject^ := EndOfObj; end; function RecordLoadJSON(var Rec; const JSON: RawUTF8; TypeInfo: pointer): boolean; var tmp: TSynTempBuffer; begin tmp.Init(JSON); try result := RecordLoadJSON(Rec,tmp.buf,TypeInfo)<>nil; finally tmp.Done; end; end; { TJSONCustomParserCustom } constructor TJSONCustomParserCustom.Create(const aPropertyName, aCustomTypeName: RawUTF8); begin inherited Create(aPropertyName,ptCustom); fCustomTypeName := aCustomTypeName; end; procedure TJSONCustomParserCustom.FinalizeItem(Data: Pointer); begin // nothing to be done by default end; { TJSONCustomParserCustomSimple } constructor TJSONCustomParserCustomSimple.Create( const aPropertyName, aCustomTypeName: RawUTF8; aCustomType: pointer); var info: PTypeInfo; kind: TTypeKind; begin inherited Create(aPropertyName,aCustomTypeName); fCustomTypeInfo := aCustomType; if IdemPropNameU(aCustomTypeName,'TGUID') then begin fKnownType := ktGUID; fDataSize := SizeOf(TGUID); end else if fCustomTypeInfo<>nil then begin TypeInfoToName(fCustomTypeInfo,fCustomTypeName,aCustomTypeName); kind := PTypeKind(fCustomTypeInfo)^; info := GetTypeInfo(fCustomTypeInfo,[tkEnumeration,tkSet,tkArray,tkDynArray]); fTypeData := info; if info<>nil then case kind of tkEnumeration, tkSet: begin case info^.EnumType of otSByte,otUByte: fDataSize := 1; otSWord,otUWord: fDataSize := 2; otSLong,otULong: fDataSize := 4; {$ifdef FPC_NEWRTTI} otSQWord,otUQWord: fDataSize := 8; {$endif} end; if kind=tkEnumeration then fKnownType := ktEnumeration else fKnownType := ktSet; exit; // success end; tkArray: begin if info^.dimCount<>1 then raise ESynException.CreateUTF8('%.Create("%") supports only single '+ 'dimension static array)',[self,fCustomTypeName]); fKnownType := ktStaticArray; {$ifdef VER2_6} fFixedSize := info^.arraySize; // is elSize in fact fDataSize := fFixedSize*info^.elCount; {$else} fDataSize := info^.arraySize; fFixedSize := fDataSize div info^.elCount; {$endif} fNestedArray := TJSONCustomParserRTTI.CreateFromRTTI( '',Deref(info^.arrayType),fFixedSize); exit; // success end; tkDynArray: begin fKnownType := ktDynamicArray; exit; // success end; end; raise ESynException.CreateUTF8('%.Create("%") unsupported type: % (%)', [self,fCustomTypeName,ToText(kind)^,ord(kind)]); end; end; constructor TJSONCustomParserCustomSimple.CreateFixedArray( const aPropertyName: RawUTF8; aFixedSize: cardinal); begin inherited Create(aPropertyName,FormatUTF8('Fixed%Byte',[aFixedSize])); fKnownType := ktFixedArray; fFixedSize := aFixedSize; fDataSize := aFixedSize; end; constructor TJSONCustomParserCustomSimple.CreateBinary( const aPropertyName: RawUTF8; aDataSize, aFixedSize: cardinal); begin inherited Create(aPropertyName,FormatUTF8('BinHex%Byte',[aFixedSize])); fKnownType := ktBinary; fFixedSize := aFixedSize; fDataSize := aDataSize; end; destructor TJSONCustomParserCustomSimple.Destroy; begin inherited; fNestedArray.Free; end; procedure TJSONCustomParserCustomSimple.CustomWriter( const aWriter: TTextWriter; const aValue); var i: integer; V: PByte; begin case fKnownType of ktStaticArray: begin aWriter.Add('['); V := @aValue; for i := 1 to PTypeInfo(fTypeData)^.elCount do begin fNestedArray.WriteOneLevel(aWriter,V,[]); aWriter.Add(','); end; aWriter.CancelLastComma; aWriter.Add(']'); end; ktEnumeration, ktSet: aWriter.AddTypedJSON(fCustomTypeInfo,aValue); ktDynamicArray: raise ESynException.CreateUTF8('%.CustomWriter("%"): unsupported', [self,fCustomTypeName]); ktBinary: if (fFixedSize<=SizeOf(QWord)) and IsZero(@aValue,fFixedSize) then aWriter.AddShort('""') else // 0 -> "" aWriter.AddBinToHexDisplayQuoted(@aValue,fFixedSize); else begin // encoded as JSON strings aWriter.Add('"'); case fKnownType of ktGUID: aWriter.Add(TGUID(aValue)); ktFixedArray: aWriter.AddBinToHex(@aValue,fFixedSize); end; aWriter.Add('"'); end; end; end; function TJSONCustomParserCustomSimple.CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar): PUTF8Char; var PropValue: PUTF8Char; i, PropValueLen, i32: integer; u64: QWord; wasString: boolean; Val: PByte; begin result := nil; // indicates error case fKnownType of ktStaticArray: begin if P^<>'[' then exit; // we expect a true array here P := GotoNextNotSpace(P+1); if JSONArrayCount(P)<>PTypeInfo(fTypeData)^.elCount then exit; // invalid number of items Val := @aValue; for i := 1 to PTypeInfo(fTypeData)^.elCount do if not fNestedArray.ReadOneLevel(P,Val,[]) then exit else if P=nil then exit; P := GotoNextNotSpace(P); EndOfObject := P^; if P^ in [',','}'] then inc(P); result := P; end; ktDynamicArray: raise ESynException.CreateUTF8('%.CustomReader("%"): unsupported', [self,fCustomTypeName]); ktSet: begin i32 := GetSetNameValue(fCustomTypeInfo,P,EndOfObject); {$ifdef FPC}Move{$else}MoveFast{$endif}(i32,aValue,fDataSize); result := P; end; else begin // encoded as JSON strings or number PropValue := GetJSONField(P,P,@wasString,@EndOfObject,@PropValueLen); if PropValue=nil then exit; // not a JSON string or number if P=nil then // result=nil=error + caller may dec(P); P^:=EndOfObject; P := PropValue+PropValueLen; case fKnownType of ktGUID: if wasString and (TextToGUID(PropValue,@aValue)<>nil) then result := P; ktEnumeration: begin if wasString then i32 := GetEnumNameValue(fCustomTypeInfo,PropValue,PropValueLen,true) else i32 := GetCardinal(PropValue); if i32<0 then exit; {$ifdef FPC}Move{$else}MoveFast{$endif}(i32,aValue,fDataSize); result := P; end; ktFixedArray: if wasString and (PropValueLen=fFixedSize*2) and SynCommons.HexToBin(PAnsiChar(PropValue),@aValue,fFixedSize) then result := P; ktBinary: if wasString then begin // default hexa serialization {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(aValue,fDataSize,0); if (PropValueLen=0) or ((PropValueLen=fFixedSize*2) and HexDisplayToBin(PAnsiChar(PropValue),@aValue,fFixedSize)) then result := P; end else if fFixedSize<=SizeOf(u64) then begin // allow integer serialization SetQWord(PropValue,u64); {$ifdef FPC}Move{$else}MoveFast{$endif}(u64,aValue,fDataSize); result := P; end; end; end; end; end; { TJSONCustomParserCustomRecord } constructor TJSONCustomParserCustomRecord.Create( const aPropertyName: RawUTF8; aCustomTypeIndex: integer); begin fCustomTypeIndex := aCustomTypeIndex; with GlobalJSONCustomParsers.fParser[fCustomTypeIndex] do begin inherited Create(aPropertyName,RecordTypeName); fCustomTypeInfo := RecordTypeInfo; fCustomTypeName := RecordTypeName; end; fDataSize := RecordTypeInfoSize(fCustomTypeInfo); end; function TJSONCustomParserCustomRecord.GetJSONCustomParserRegistration: pointer; begin result := nil; if GlobalJSONCustomParsers<>nil then begin if (Cardinal(fCustomTypeIndex)>=Cardinal(GlobalJSONCustomParsers.fParsersCount)) or not IdemPropNameU(fCustomTypeName, GlobalJSONCustomParsers.fParser[fCustomTypeIndex].RecordTypeName) then fCustomTypeIndex := GlobalJSONCustomParsers.RecordSearch(fCustomTypeInfo); if fCustomTypeIndex>=0 then result := @GlobalJSONCustomParsers.fParser[fCustomTypeIndex]; end; if result=nil then raise ESynException.CreateUTF8( '%: "%" type should not have been un-registered',[self,fCustomTypeName]); end; procedure TJSONCustomParserCustomRecord.CustomWriter( const aWriter: TTextWriter; const aValue); var parser: PJSONCustomParserRegistration; begin parser := GetJSONCustomParserRegistration; parser^.Writer(aWriter,aValue); end; function TJSONCustomParserCustomRecord.CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar): PUTF8Char; var valid: boolean; callback: PJSONCustomParserRegistration; // D5/D6 Internal error: C3890 begin callback := GetJSONCustomParserRegistration; result := callback^.Reader(P,aValue,valid); if not valid then result := nil; if result=nil then exit; EndOfObject := result^; if result^ in [',','}',']'] then inc(result); end; procedure TJSONCustomParserCustomRecord.FinalizeItem(Data: Pointer); begin RecordClear(Data^,fCustomTypeInfo); end; { TJSONCustomParserRTTI } type TJSONSerializerFromTextSimple = record TypeInfo: pointer; BinaryDataSize, BinaryFieldSize: integer; end; TJSONSerializerFromTextSimpleDynArray = array of TJSONSerializerFromTextSimple; var // RawUTF8/TJSONSerializerFromTextSimpleDynArray GlobalCustomJSONSerializerFromTextSimpleType: TSynDictionary; procedure JSONSerializerFromTextSimpleTypeAdd(aTypeName: RawUTF8; aTypeInfo: pointer; aDataSize, aFieldSize: integer); var simple: TJSONSerializerFromTextSimple; begin if aTypeName='' then TypeInfoToName(aTypeInfo,aTypeName); if aDataSize<>0 then if aFieldSize>aDataSize then raise ESynException.CreateUTF8('JSONSerializerFromTextSimpleTypeAdd(%) fieldsize=%>%', [aTypeName,aFieldSize,aDataSize]) else if aFieldSize=0 then aFieldSize := aDataSize; // not truncated simple.TypeInfo := aTypeInfo; simple.BinaryDataSize := aDataSize; simple.BinaryFieldSize := aFieldSize; UpperCaseSelf(aTypeName); if GlobalCustomJSONSerializerFromTextSimpleType.Add(aTypeName,simple)<0 then raise ESynException.CreateUTF8('JSONSerializerFromTextSimpleTypeAdd(%) duplicated', [aTypeName]); end; /// if defined, will try to mimic the default record alignment // -> is buggy, and compiler revision specific -> we would rather use packed records {.$define ALIGNCUSTOMREC} constructor TJSONCustomParserRTTI.Create(const aPropertyName: RawUTF8; aPropertyType: TJSONCustomParserRTTIType); begin fPropertyName := aPropertyName; fPropertyType := aPropertyType; end; class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType(TypeName: PUTF8Char; TypeNameLen: Integer; var ItemTypeName: RawUTF8): TJSONCustomParserRTTIType; const SORTEDMAX = {$ifdef NOVARIANTS}32{$else}33{$endif}; SORTEDNAMES: array[0..SORTEDMAX] of PUTF8Char = ('ARRAY','BOOLEAN','BYTE','CARDINAL','CURRENCY', 'DOUBLE','EXTENDED','INT64','INTEGER','PTRINT','PTRUINT','QWORD', 'RAWBYTESTRING','RAWJSON','RAWUTF8','RECORD','SINGLE', 'STRING','SYNUNICODE','TCREATETIME','TDATETIME','TDATETIMEMS','TGUID', 'TID','TMODTIME','TRECORDREFERENCE','TRECORDREFERENCETOBEDELETED', 'TRECORDVERSION','TSQLRAWBLOB','TTIMELOG','UTF8STRING', {$ifndef NOVARIANTS}'VARIANT',{$endif} 'WIDESTRING','WORD'); // warning: recognized types should match at binary storage level! SORTEDTYPES: array[0..SORTEDMAX] of TJSONCustomParserRTTIType = (ptArray,ptBoolean,ptByte,ptCardinal,ptCurrency, ptDouble,ptExtended,ptInt64,ptInteger,ptPtrInt,ptPtrUInt,ptQWord, ptRawByteString,ptRawJSON,ptRawUTF8,ptRecord,ptSingle, ptString,ptSynUnicode,ptTimeLog,ptDateTime,ptDateTimeMS,ptGUID, ptID,ptTimeLog,ptInt64,ptInt64, ptInt64,ptRawByteString,ptTimeLog,ptRawUTF8, {$ifndef NOVARIANTS}ptVariant,{$endif} ptWideString,ptWord); var ndx: integer; begin UpperCaseCopy(TypeName,TypeNameLen,ItemTypeName); //for ndx := 1 to SORTEDMAX do assert(StrComp(SORTEDNAMES[ndx],SORTEDNAMES[ndx-1])>0,SORTEDNAMES[ndx]); ndx := FastFindPUTF8CharSorted(@SORTEDNAMES,SORTEDMAX,pointer(ItemTypeName)); if ndx>=0 then result := SORTEDTYPES[ndx] else result := ptCustom; end; class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( const TypeName: RawUTF8): TJSONCustomParserRTTIType; var ItemTypeName: RawUTF8; begin if TypeName='' then result := ptCustom else result := TypeNameToSimpleRTTIType(Pointer(TypeName),length(TypeName),ItemTypeName); end; class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( TypeName: PShortString): TJSONCustomParserRTTIType; var ItemTypeName: RawUTF8; begin if TypeName=nil then result := ptCustom else result := TypeNameToSimpleRTTIType(@TypeName^[1],Ord(TypeName^[0]),ItemTypeName); end; class function TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(Info: pointer; ItemSize: integer): TJSONCustomParserRTTIType; begin result := ptCustom; if Info=nil then exit; case PTypeKind(Info)^ of tkLString{$ifdef FPC},tkLStringOld{$endif}: result := ptRawUTF8; tkWString: result := ptWideString; {$ifdef UNICODE} tkUString: result := ptSynUnicode; tkClassRef, tkPointer, tkProcedure: case ItemSize of 1: result := ptByte; 2: result := ptWord; 4: result := ptCardinal; 8: result := ptQWord; else result := ptPtrInt; end; {$endif} {$ifndef NOVARIANTS} tkVariant: result := ptVariant; {$endif} tkDynArray: result := ptArray; tkChar: result := ptByte; tkWChar: result := ptWord; tkClass, tkMethod, tkInterface: result := ptPtrInt; tkInteger: case GetTypeInfo(Info)^.IntegerType of otSByte,otUByte: result := ptByte; otSWord,otUWord: result := ptWord; otSLong: result := ptInteger; otULong: result := ptCardinal; {$ifdef FPC_NEWRTTI} otSQWord: result := ptInt64; otUQWord: result := ptQWord; {$endif} end; tkInt64: {$ifndef FPC} if Info=TypeInfo(QWord) then result := ptQWord else {$ifdef UNICODE}with GetTypeInfo(Info)^ do // detect QWord/UInt64 if MinInt64Value>MaxInt64Value then result := ptQWord else{$endif}{$endif} result := ptInt64; {$ifdef FPC} tkQWord: result := ptQWord; tkBool: result := ptBoolean; {$else} tkEnumeration: if Info=TypeInfo(boolean) then result := ptBoolean; // other enumerates (or tkSet) will use TJSONCustomParserCustomSimple {$endif} tkFloat: case GetTypeInfo(Info)^.FloatType of ftSingle: result := ptSingle; ftDoub: result := ptDouble; ftCurr: result := ptCurrency; ftExtended: result := ptExtended; // ftComp: not implemented yet end; end; end; class function TJSONCustomParserRTTI.TypeNameToSimpleBinary(const aTypeName: RawUTF8; out aDataSize, aFieldSize: integer): boolean; var simple: ^TJSONSerializerFromTextSimple; begin simple := GlobalCustomJSONSerializerFromTextSimpleType.FindValue(aTypeName); if (simple<>nil) and (simple^.BinaryFieldSize<>0) then begin aDataSize := simple^.BinaryDataSize; aFieldSize := simple^.BinaryFieldSize; result := true; end else result := false; end; class function TJSONCustomParserRTTI.CreateFromRTTI( const PropertyName: RawUTF8; Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; var Item: PTypeInfo absolute Info; ItemType: TJSONCustomParserRTTIType; ItemTypeName: RawUTF8; ndx: integer; begin if Item=nil then // no RTTI -> stored as hexa string result := TJSONCustomParserCustomSimple.CreateFixedArray(PropertyName,ItemSize) else begin ItemType := TypeNameToSimpleRTTIType(PUTF8Char(@Item.NameLen)+1,Item.NameLen,ItemTypeName); if ItemType=ptCustom then ItemType := TypeInfoToSimpleRTTIType(Info,ItemSize); if ItemType=ptCustom then if Item^.kind in [tkEnumeration,tkArray,tkDynArray,tkSet] then result := TJSONCustomParserCustomSimple.Create( PropertyName,ItemTypeName,Item) else begin ndx := GlobalJSONCustomParsers.RecordSearch(Item); if ndx<0 then ndx := GlobalJSONCustomParsers.RecordSearch(ItemTypeName); if ndx<0 then raise ESynException.CreateUTF8('%.CreateFromRTTI("%") unsupported %', [self,ItemTypeName,ToText(Item^.kind)^]); result := TJSONCustomParserCustomRecord.Create(PropertyName,ndx); end else result := TJSONCustomParserRTTI.Create(PropertyName,ItemType); end; if ItemSize<>0 then result.fDataSize := ItemSize; end; class function TJSONCustomParserRTTI.CreateFromTypeName( const aPropertyName, aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; var ndx: integer; simple: ^TJSONSerializerFromTextSimple; begin simple := GlobalCustomJSONSerializerFromTextSimpleType.FindValue(aCustomRecordTypeName); if simple<>nil then if simple^.BinaryFieldSize<>0 then result := TJSONCustomParserCustomSimple.CreateBinary( aPropertyName,simple^.BinaryDataSize,simple^.BinaryFieldSize) else result := TJSONCustomParserCustomSimple.Create( aPropertyName,aCustomRecordTypeName,simple^.TypeInfo) else begin ndx := GlobalJSONCustomParsers.RecordSearch(aCustomRecordTypeName); if ndx<0 then result := nil else result := TJSONCustomParserCustomRecord.Create(aPropertyName,ndx); end; end; procedure TJSONCustomParserRTTI.ComputeFullPropertyName; var i: PtrInt; begin for i := 0 to high(NestedProperty) do begin NestedProperty[i].ComputeFullPropertyName; if fFullPropertyName<>'' then NestedProperty[i].fFullPropertyName := fFullPropertyName+'.'+NestedProperty[i].fPropertyName; end; end; procedure TJSONCustomParserRTTI.ComputeNestedDataSize; var i: PtrInt; begin assert(fNestedDataSize=0); fNestedDataSize := 0; for i := 0 to high(NestedProperty) do begin NestedProperty[i].ComputeDataSizeAfterAdd; inc(fNestedDataSize,NestedProperty[i].fDataSize); if fFullPropertyName<>'' then NestedProperty[i].fFullPropertyName := fFullPropertyName+'.'+NestedProperty[i].fPropertyName; end; end; procedure TJSONCustomParserRTTI.ComputeDataSizeAfterAdd; const // binary size (in bytes) of each kind of property - 0 for ptRecord/ptCustom JSONRTTI_SIZE: array[TJSONCustomParserRTTIType] of byte = ( SizeOf(PtrUInt),SizeOf(Boolean),SizeOf(Byte),SizeOf(Cardinal),SizeOf(Currency), SizeOf(Double),SizeOf(Extended),SizeOf(Int64),SizeOf(Integer),SizeOf(QWord), SizeOf(RawByteString),SizeOf(RawJSON),SizeOf(RawUTF8),0,SizeOf(Single), SizeOf(String),SizeOf(SynUnicode),SizeOf(TDateTime),SizeOf(TDateTimeMS), SizeOf(TGUID),SizeOf(Int64),SizeOf(TTimeLog), {$ifndef NOVARIANTS}SizeOf(Variant),{$endif} SizeOf(WideString),SizeOf(Word),0); var i: PtrInt; begin if fFullPropertyName='' then begin fFullPropertyName := fPropertyName; ComputeFullPropertyName; end; if fDataSize=0 then begin ComputeNestedDataSize; case PropertyType of ptRecord: for i := 0 to high(NestedProperty) do inc(fDataSize,NestedProperty[i].fDataSize); //ptCustom: fDataSize already set in TJSONCustomParserCustom.Create() else fDataSize := JSONRTTI_SIZE[PropertyType]; end; {$ifdef ALIGNCUSTOMREC} inc(fDataSize,fDataSize and 7); {$endif} end; end; procedure TJSONCustomParserRTTI.FinalizeNestedRecord(var Data: PByte); var j: PtrInt; begin for j := 0 to length(NestedProperty)-1 do begin case NestedProperty[j].PropertyType of ptRawByteString, ptRawJSON, ptRawUTF8: {$ifdef FPC}Finalize(PRawByteString(Data)^){$else}PRawByteString(Data)^ := ''{$endif}; ptString: PString(Data)^ := ''; ptSynUnicode: PSynUnicode(Data)^ := ''; ptWideString: PWideString(Data)^ := ''; ptArray: NestedProperty[j].FinalizeNestedArray(PPtrUInt(Data)^); {$ifndef NOVARIANTS} ptVariant: VarClear(PVariant(Data)^); {$endif} ptRecord: begin NestedProperty[j].FinalizeNestedRecord(Data); continue; end; ptCustom: TJSONCustomParserCustom(NestedProperty[j]).FinalizeItem(Data); end; inc(Data,NestedProperty[j].fDataSize); end; end; procedure TJSONCustomParserRTTI.FinalizeNestedArray(var Data: PtrUInt); var i: integer; Rec: PDynArrayRec; ItemData: PByte; begin if Data=0 then exit; ItemData := pointer(Data); Rec := pointer(Data); dec(PtrUInt(Rec),SizeOf(TDynArrayRec)); Data := 0; if Rec^.refCnt>1 then begin InterlockedDecrement(PInteger(@Rec^.refCnt)^); // FPC has refCnt: PtrInt exit; end; for i := 1 to Rec.length do FinalizeNestedRecord(ItemData); FreeMem(Rec); end; procedure TJSONCustomParserRTTI.AllocateNestedArray(var Data: PtrUInt; NewLength: integer); begin FinalizeNestedArray(Data); if NewLength<=0 then exit; pointer(Data) := AllocMem(SizeOf(TDynArrayRec)+fNestedDataSize*NewLength); PDynArrayRec(Data)^.refCnt := 1; PDynArrayRec(Data)^.length := NewLength; inc(Data,SizeOf(TDynArrayRec)); end; procedure TJSONCustomParserRTTI.ReAllocateNestedArray(var Data: PtrUInt; NewLength: integer); var OldLength: integer; begin if Data=0 then raise ESynException.CreateUTF8('%.ReAllocateNestedArray(nil)',[self]); dec(Data,SizeOf(TDynArrayRec)); ReAllocMem(pointer(Data),SizeOf(TDynArrayRec)+fNestedDataSize*NewLength); OldLength := PDynArrayRec(Data)^.length; if NewLength>OldLength then {$ifdef FPC}FillChar{$else}FillCharFast{$endif}( PByteArray(Data)[SizeOf(TDynArrayRec)+fNestedDataSize*OldLength], fNestedDataSize*(NewLength-OldLength),0); PDynArrayRec(Data)^.length := NewLength; inc(Data,SizeOf(TDynArrayRec)); end; function TJSONCustomParserRTTI.ReadOneLevel(var P: PUTF8Char; var Data: PByte; Options: TJSONCustomParserSerializationOptions): boolean; var EndOfObject: AnsiChar; function ProcessValue(const Prop: TJSONCustomParserRTTI; var P: PUTF8Char; var Data: PByte): boolean; var DynArray: PByte; ArrayLen, ArrayCapacity, n, PropValueLen: integer; wasString: boolean; PropValue, ptr: PUTF8Char; label Error; begin result := false; P := GotoNextNotSpace(P); case Prop.PropertyType of ptRecord: begin if not Prop.ReadOneLevel(P,Data,Options) then exit; EndOfObject := P^; if P^ in [',','}'] then inc(P); result := true; exit; end; ptArray: if (PInteger(P)^=NULL_LOW) and (P[4] in EndOfJSONValueField) then begin P := GotoNextNotSpace(P+4); EndOfObject := P^; if P^<>#0 then //if P^=',' then inc(P); Prop.FinalizeNestedArray(PPtrUInt(Data)^); // null -> void array end else begin if P^<>'[' then exit; // we expect a true array here repeat inc(P) until P^<>' '; // try to allocate nested array at once (if not too slow) ArrayLen := JSONArrayCount(P,P+131072); // parse up to 128 KB here if ArrayLen<0 then // mostly JSONArrayCount()=nil due to PMax -> 512 ArrayCapacity := 512 else ArrayCapacity := ArrayLen; Prop.AllocateNestedArray(PPtrUInt(Data)^,ArrayCapacity); // read array content if ArrayLen=0 then begin if not NextNotSpaceCharIs(P,']') then exit; end else begin n := 0; DynArray := PPointer(Data)^; repeat inc(n); if (ArrayLen<0) and (n>ArrayCapacity) then begin ArrayCapacity := NextGrow(ArrayCapacity); Prop.ReAllocateNestedArray(PPtrUInt(Data)^,ArrayCapacity); DynArray := PPointer(Data)^; inc(DynArray,pred(n)*Prop.fNestedDataSize); end; if Prop.NestedProperty[0].PropertyName='' then begin // array of simple type ptr := P; if not ProcessValue(Prop.NestedProperty[0],ptr,DynArray) or (ptr=nil) then goto Error; P := ptr; end else begin // array of record ptr := P; if not Prop.ReadOneLevel(ptr,DynArray,Options) or (ptr=nil) then goto Error; P := GotoNextNotSpace(ptr); EndOfObject := P^; if not(P^ in [',',']']) then goto Error; inc(P); end; case EndOfObject of ',': continue; ']': begin if ArrayLen<0 then Prop.ReAllocateNestedArray(PPtrUInt(Data)^,n) else if n<>ArrayLen then goto Error; break; // we reached end of array end; else begin Error: Prop.FinalizeNestedArray(PPtrUInt(Data)^); exit; end; end; until false; end; if P=nil then exit; P := GotoNextNotSpace(P); EndOfObject := P^; if P^<>#0 then //if P^=',' then inc(P); end; ptCustom: begin ptr := TJSONCustomParserCustom(Prop).CustomReader(P,Data^,EndOfObject); if ptr=nil then exit; P := ptr; end; {$ifndef NOVARIANTS} ptVariant: P := VariantLoadJSON(PVariant(Data)^,P,@EndOfObject, @JSON_OPTIONS[soCustomVariantCopiedByReference in Options]); {$endif} ptRawByteString: begin PropValue := GetJSONField(P,ptr,@wasString,@EndOfObject,@PropValueLen); if PropValue=nil then // null -> Blob='' PRawByteString(Data)^ := '' else if not Base64MagicCheckAndDecode(PropValue,PropValueLen,PRawByteString(Data)^) then exit; P := ptr; end; ptRawJSON: GetJSONItemAsRawJSON(P,PRawJSON(Data)^,@EndOfObject); else begin PropValue := GetJSONField(P,ptr,@wasString,@EndOfObject,@PropValueLen); if (PropValue<>nil) and // PropValue=nil for null (wasString<>(Prop.PropertyType in [ptRawUTF8,ptString, ptSynUnicode,ptDateTime,ptDateTimeMS,ptGUID,ptWideString])) then exit; P := ptr; case Prop.PropertyType of ptBoolean: PBoolean(Data)^ := GetBoolean(PropValue); ptByte: PByte(Data)^ := GetCardinal(PropValue); ptCardinal: PCardinal(Data)^ := GetCardinal(PropValue); ptCurrency: PInt64(Data)^ := StrToCurr64(PropValue); ptDouble: PDouble(Data)^ := GetExtended(PropValue); ptExtended: PExtended(Data)^ := GetExtended(PropValue); ptInt64,ptID,ptTimeLog: SetInt64(PropValue,PInt64(Data)^); ptQWord: SetQWord(PropValue,PQWord(Data)^); ptInteger: PInteger(Data)^ := GetInteger(PropValue); ptSingle: PSingle(Data)^ := GetExtended(PropValue); ptRawUTF8: FastSetString(PRawUTF8(Data)^,PropValue,PropValueLen); ptString: UTF8DecodeToString(PropValue,PropValueLen,PString(Data)^); ptSynUnicode:UTF8ToSynUnicode(PropValue,PropValueLen,PSynUnicode(Data)^); ptDateTime, ptDateTimeMS: Iso8601ToDateTimePUTF8CharVar( PropValue,PropValueLen,PDateTime(Data)^); ptWideString:UTF8ToWideString(PropValue,PropValueLen,PWideString(Data)^); ptWord: PWord(Data)^ := GetCardinal(PropValue); ptGUID: TextToGUID(PropValue,pointer(Data)); end; end; end; inc(Data,Prop.fDataSize); result := true; end; var i,j: integer; PropName: shortstring; ptr: PUTF8Char; Values: array of PUTF8Char; begin result := false; if P=nil then exit; P := GotoNextNotSpace(P); if (PInteger(P)^=NULL_LOW) and (P[4] in EndOfJSONValueField) then begin P := GotoNextNotSpace(P+4); // a record stored as null inc(Data,fDataSize); result := true; exit; end; EndOfObject := #0; if not (PropertyType in [ptRecord,ptArray]) then begin ptr := P; result := ProcessValue(Self,P,Data); exit; end; if P^<>'{' then exit; // we expect a true object here repeat inc(P) until (P^>' ') or (P^=#0); if P^='}' then begin inc(Data,fDataSize); EndOfObject := '}'; inc(P); end else for i := 0 to length(NestedProperty)-1 do begin ptr := P; GetJSONPropName(ptr,PropName); if PropName='' then exit; // invalid JSON content P := ptr; if IdemPropNameU(NestedProperty[i].PropertyName,@PropName[1],ord(PropName[0])) then begin // O(1) optimistic search if not ProcessValue(NestedProperty[i],P,Data) then exit; if EndOfObject='}' then begin // ignore missing properties for j := i+1 to length(NestedProperty)-1 do inc(Data,NestedProperty[j].fDataSize); break; end; end else begin SetLength(Values,length(NestedProperty)); // pessimistic check through all properties repeat for j := i to length(NestedProperty)-1 do if (Values[j]=nil) and IdemPropNameU(NestedProperty[j].PropertyName,@PropName[1],ord(PropName[0])) then begin Values[j] := P; PropName := ''; break; end; if (PropName<>'') and not(soReadIgnoreUnknownFields in Options) then exit; // unexpected property ptr := GotoNextJSONItem(P,1,@EndOfObject); if ptr=nil then exit; P := ptr; if EndOfObject='}' then break; GetJSONPropName(ptr,PropName); // next name if PropName='' then exit; // invalid JSON content P := ptr; until false; for j := i to length(NestedProperty)-1 do if Values[j]=nil then // ignore missing properties inc(Data,NestedProperty[j].fDataSize) else if not ProcessValue(NestedProperty[j],Values[j],Data) then exit; EndOfObject := '}'; // ProcessValue() did update EndOfObject break; end; end; if (P<>nil) and (EndOfObject=',') and (soReadIgnoreUnknownFields in Options) then begin ptr := GotoNextJSONObjectOrArray(P,'}'); if ptr=nil then exit; P := ptr; end else if EndOfObject<>'}' then exit; if P<>nil then P := GotoNextNotSpace(P); result := true; end; procedure JSONBoolean(value: boolean; var result: RawUTF8); begin // defined as a function and not an array[boolean] of RawUTF8 for FPC if value then result := 'true' else result := 'false'; end; function Plural(const itemname: shortstring; itemcount: cardinal): shortstring; var len: integer; begin len := (AppendUInt32ToBuffer(@result[1],itemcount)-PUTF8Char(@result[1]))+1; result[len] := ' '; if ord(itemname[0])<240 then begin // avoid buffer overflow {$ifdef FPC}Move{$else}MoveFast{$endif}(itemname[1],result[len+1],ord(itemname[0])); inc(len,ord(itemname[0])); if itemcount>1 then begin inc(len); result[len] := 's'; end; end; result[0] := AnsiChar(len); end; function TJSONCustomParserRTTI.IfDefaultSkipped(var Value: PByte): boolean; begin case PropertyType of ptBoolean: result := not PBoolean(Value)^; ptByte: result := PByte(Value)^=0; ptWord: result := PWord(Value)^=0; ptInteger,ptCardinal,ptSingle: result := PInteger(Value)^=0; ptCurrency,ptDouble,ptInt64,ptQWord,ptID,ptTimeLog,ptDateTime,ptDateTimeMS: result := PInt64(Value)^=0; ptExtended: result := PExtended(Value)^=0; {$ifndef NOVARIANTS} ptVariant: result := PVarData(Value)^.VType<=varNull; {$endif} ptRawJSON,ptRawByteString,ptRawUTF8,ptString,ptSynUnicode,ptWideString,ptArray: result := PPointer(Value)^=nil; ptGUID: result := IsNullGUID(PGUID(Value)^); ptRecord: result := IsZero(Value,fDataSize); else result := false; end; if result then inc(Value,fDataSize); end; procedure TJSONCustomParserRTTI.WriteOneSimpleValue(aWriter: TTextWriter; var Value: PByte; Options: TJSONCustomParserSerializationOptions); var DynArray: PByte; j: integer; begin case PropertyType of ptBoolean: aWriter.Add(PBoolean(Value)^); ptByte: aWriter.AddU(PByte(Value)^); ptCardinal: aWriter.AddU(PCardinal(Value)^); ptCurrency: aWriter.AddCurr64(PInt64(Value)^); ptDouble: aWriter.AddDouble(unaligned(PDouble(Value)^)); ptExtended: aWriter.Add(PExtended(Value)^,EXTENDED_PRECISION); ptInt64,ptID,ptTimeLog: aWriter.Add(PInt64(Value)^); ptQWord: aWriter.AddQ(PQWord(Value)^); ptInteger: aWriter.Add(PInteger(Value)^); ptSingle: aWriter.AddSingle(PSingle(Value)^); ptWord: aWriter.AddU(PWord(Value)^); {$ifndef NOVARIANTS} ptVariant: aWriter.AddVariant(PVariant(Value)^,twJSONEscape); {$endif} ptRawJSON: aWriter.AddRawJSON(PRawJSON(Value)^); ptRawByteString: aWriter.WrBase64(PPointer(Value)^,length(PRawByteString(Value)^),{withMagic=}true); ptRawUTF8, ptString, ptSynUnicode, ptDateTime, ptDateTimeMS, ptGUID, ptWideString: begin aWriter.Add('"'); case PropertyType of ptRawUTF8: aWriter.AddJSONEscape(PPointer(Value)^); ptString: aWriter.AddJSONEscapeString(PString(Value)^); ptSynUnicode, ptWideString: aWriter.AddJSONEscapeW(PPointer(Value)^); ptDateTime: aWriter.AddDateTime(unaligned(PDateTime(Value)^),false); ptDateTimeMS: aWriter.AddDateTime(unaligned(PDateTime(Value)^),true); ptGUID: aWriter.Add(PGUID(Value)^); end; aWriter.Add('"'); end; ptArray: begin aWriter.Add('['); inc(aWriter.fHumanReadableLevel); DynArray := PPointer(Value)^; if DynArray<>nil then for j := 1 to DynArrayLength(DynArray) do begin if soWriteHumanReadable in Options then aWriter.AddCRAndIndent; if NestedProperty[0].PropertyName='' then // array of simple NestedProperty[0].WriteOneSimpleValue(aWriter,DynArray,Options) else WriteOneLevel(aWriter,DynArray,Options); // array of record aWriter.Add(','); {$ifdef ALIGNCUSTOMREC} if PtrUInt(DynArray)and 7<>0 then inc(DynArray,8-(PtrUInt(DynArray)and 7)); {$endif} end; aWriter.CancelLastComma; aWriter.Add(']'); dec(aWriter.fHumanReadableLevel); end; ptRecord: begin WriteOneLevel(aWriter,Value,Options); exit; end; ptCustom: TJSONCustomParserCustom(self).CustomWriter(aWriter,Value^); end; inc(Value,fDataSize); end; procedure TJSONCustomParserRTTI.WriteOneLevel(aWriter: TTextWriter; var P: PByte; Options: TJSONCustomParserSerializationOptions); var i: integer; SubProp: TJSONCustomParserRTTI; begin if P=nil then begin aWriter.AddShort('null'); exit; end; if not (PropertyType in [ptRecord,ptArray]) then begin WriteOneSimpleValue(aWriter,P,Options); exit; end; aWriter.Add('{'); Inc(aWriter.fHumanReadableLevel); for i := 0 to length(NestedProperty)-1 do begin SubProp := NestedProperty[i]; if soWriteIgnoreDefault in Options then if SubProp.IfDefaultSkipped(P) then continue; if soWriteHumanReadable in Options then aWriter.AddCRAndIndent; aWriter.AddFieldName(SubProp.PropertyName); if soWriteHumanReadable in Options then aWriter.Add(' '); SubProp.WriteOneSimpleValue(aWriter,P,Options); aWriter.Add(','); end; aWriter.CancelLastComma; dec(aWriter.fHumanReadableLevel); if soWriteHumanReadable in Options then aWriter.AddCRAndIndent; aWriter.Add('}'); end; { TJSONRecordAbstract } constructor TJSONRecordAbstract.Create; begin fItems := TObjectList.Create; end; function TJSONRecordAbstract.AddItem(const aPropertyName: RawUTF8; aPropertyType: TJSONCustomParserRTTIType; const aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; begin if aPropertyType=ptCustom then begin result := TJSONCustomParserRTTI.CreateFromTypeName( aPropertyName,aCustomRecordTypeName); if result=nil then raise ESynException.CreateUTF8('Unregistered ptCustom for %.AddItem(%: %)', [self,aPropertyName,aCustomRecordTypeName]); end else result := TJSONCustomParserRTTI.Create(aPropertyName,aPropertyType); fItems.Add(result); end; function TJSONRecordAbstract.CustomReader(P: PUTF8Char; var aValue; out aValid: Boolean): PUTF8Char; var Data: PByte; EndOfObject: AnsiChar; begin if Root.PropertyType=ptCustom then begin result := TJSONCustomParserCustom(Root).CustomReader(P,aValue,EndOfObject); aValid := result<>nil; if (EndOfObject<>#0) and aValid then begin dec(result); result^ := EndOfObject; // emulates simple read end; exit; end; Data := @aValue; aValid := Root.ReadOneLevel(P,Data,Options); result := P; end; procedure TJSONRecordAbstract.CustomWriter(const aWriter: TTextWriter; const aValue); var P: PByte; o: TJSONCustomParserSerializationOptions; begin P := @aValue; o := Options; if twoIgnoreDefaultInRecord in aWriter.CustomOptions then include(o,soWriteIgnoreDefault); Root.WriteOneLevel(aWriter,P,o); end; destructor TJSONRecordAbstract.Destroy; begin FreeAndNil(fItems); inherited; end; { TJSONRecordTextDefinition } var JSONCustomParserCache: TRawUTF8ListHashed; class function TJSONRecordTextDefinition.FromCache(aTypeInfo: pointer; const aDefinition: RawUTF8): TJSONRecordTextDefinition; var i: integer; added: boolean; begin if JSONCustomParserCache=nil then GarbageCollectorFreeAndNil(JSONCustomParserCache,TRawUTF8ListHashed.Create(True)); i := JSONCustomParserCache.AddObjectIfNotExisting(aDefinition,nil,@added); if not added then begin result := TJSONRecordTextDefinition(JSONCustomParserCache.fObjects[i]); exit; end; result := TJSONRecordTextDefinition.Create(aTypeInfo,aDefinition); JSONCustomParserCache.fObjects[i] := result; end; constructor TJSONRecordTextDefinition.Create(aRecordTypeInfo: pointer; const aDefinition: RawUTF8); var P: PUTF8Char; recordInfoSize: integer; begin inherited Create; fDefinition := aDefinition; fRoot := TJSONCustomParserRTTI.Create('',ptRecord); TypeInfoToName(aRecordTypeInfo,fRoot.fCustomTypeName); fItems.Add(fRoot); P := pointer(aDefinition); Parse(fRoot,P,eeNothing); fRoot.ComputeDataSizeAfterAdd; recordInfoSize := RecordTypeInfoSize(aRecordTypeInfo); if (recordInfoSize<>0) and (fRoot.fDataSize<>recordInfoSize) then raise ESynException.CreateUTF8('%.Create: % text definition is not accurate,'+ ' or the type has not been defined as PACKED record: RTTI size is %'+ ' bytes but text definition covers % bytes', [self,fRoot.fCustomTypeName,recordInfoSize,fRoot.fDataSize]); end; function DynArrayItemTypeLen(const aDynArrayTypeName: RawUTF8): integer; begin result := length(aDynArrayTypeName); if (result>12) and IdemPropName('DynArray',@PByteArray(aDynArrayTypeName)[result-8],8) then dec(result,8) else if (result>3) and (NormToUpperAnsi7[aDynArrayTypeName[result]]='S') then dec(result) else result := 0; end; procedure TJSONRecordTextDefinition.Parse(Props: TJSONCustomParserRTTI; var P: PUTF8Char; PEnd: TJSONCustomParserRTTIExpectedEnd); function GetNextFieldType(var P: PUTF8Char; var TypIdent: RawUTF8): TJSONCustomParserRTTIType; begin if GetNextFieldProp(P,TypIdent) then result := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( pointer(TypIdent),length(TypIdent),TypIdent) else raise ESynException.CreateUTF8('%.Parse: missing field type',[self]); end; var PropsName: TRawUTF8DynArray; PropsMax, ndx, len, firstNdx: cardinal; Typ, ArrayTyp: TJSONCustomParserRTTIType; TypIdent, ArrayTypIdent: RawUTF8; Item: TJSONCustomParserRTTI; ExpectedEnd: TJSONCustomParserRTTIExpectedEnd; begin SetLength(PropsName,16); PropsMax := 0; while (P<>nil) and (P^<>#0) do begin // fill Props[] if not GetNextFieldProp(P,PropsName[PropsMax]) then break; case P^ of ',': begin inc(P); inc(PropsMax); if PropsMax=cardinal(length(PropsName)) then SetLength(PropsName,PropsMax+16); continue; // several properties defined with the same type end; ':': P := GotoNextNotSpace(P+1); end; // identify type ArrayTyp := ptRecord; if P^='{' then begin Typ := ptRecord; ExpectedEnd := eeCurly; repeat inc(P) until (P^>' ') or (P^=#0); end else if P^='[' then begin Typ := ptArray; ExpectedEnd := eeSquare; repeat inc(P) until (P^>' ') or (P^=#0); end else begin Typ := GetNextFieldType(P,TypIdent); case Typ of ptArray: begin if IdemPChar(P,'OF') then begin P := GotoNextNotSpace(P+2); ArrayTyp := GetNextFieldType(P,ArrayTypIdent); if ArrayTyp=ptArray then P := nil; end else P := nil; if P=nil then raise ESynException.CreateUTF8('%.Parse: expected syntax is '+ '"array of record" or "array of SimpleType"',[self]); if ArrayTyp=ptRecord then ExpectedEnd := eeEndKeyWord else ExpectedEnd := eeNothing; end; ptRecord: ExpectedEnd := eeEndKeyWord; ptCustom: begin len := DynArrayItemTypeLen(TypIdent); if len>0 then begin ArrayTyp := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( @PByteArray(TypIdent)[1],len-1,ArrayTypIdent); // TByteDynArray -> byte if ArrayTyp=ptCustom then begin // TMyTypeDynArray/TMyTypes -> TMyType FastSetString(ArrayTypIdent,pointer(TypIdent),len); if GlobalCustomJSONSerializerFromTextSimpleType.Find(ArrayTypIdent)>=0 then Typ := ptArray; end else Typ := ptArray; end; ExpectedEnd := eeNothing; end; else ExpectedEnd := eeNothing; end; end; // add elements firstNdx := length(Props.fNestedProperty); SetLength(Props.fNestedProperty,firstNdx+PropsMax+1); for ndx := 0 to PropsMax do begin Item := AddItem(PropsName[ndx],Typ,TypIdent); Props.fNestedProperty[firstNdx+ndx] := Item; if (Typ=ptArray) and (ArrayTyp<>ptRecord) then begin SetLength(Item.fNestedProperty,1); Item.fNestedProperty[0] := AddItem('',ArrayTyp,ArrayTypIdent); end else if Typ in [ptArray,ptRecord] then if ndx=0 then // only parse once multiple fields nested type Parse(Item,P,ExpectedEnd) else Item.fNestedProperty := Props.fNestedProperty[firstNdx].fNestedProperty; Item.ComputeDataSizeAfterAdd; end; // validate expected end while P^ in [#1..' ',';'] do inc(P); case PEnd of eeEndKeyWord: if IdemPChar(P,'END') then begin inc(P,3); while P^ in [#1..' ',';'] do inc(P); break; end; eeSquare: if P^=']' then begin inc(P); break; end; eeCurly: if P^='}' then begin inc(P); break; end; end; PropsMax := 0; end; end; { TJSONRecordRTTI } constructor TJSONRecordRTTI.Create(aRecordTypeInfo: pointer; aRoot: TJSONCustomParserRTTI); begin inherited Create; fRecordTypeInfo := aRecordTypeInfo; fRoot := aRoot; if fRoot=nil then begin {$ifdef ISDELPHI2010} fRoot := TJSONCustomParserRTTI.Create('',ptRecord); FromEnhancedRTTI(fRoot,aRecordTypeInfo); if fRoot.fNestedDataSize<>RecordTypeInfoSize(aRecordTypeInfo) then raise ESynException.CreateUTF8( '%.Create: error when retrieving enhanced RTTI for %', [self,fRoot.CustomTypeName]); {$else} raise ESynException.CreateUTF8('%.Create with no enhanced RTTI for %', [self,PShortString(@PTypeInfo(aRecordTypeInfo).NameLen)^]); {$endif} end; fItems.Add(fRoot); GarbageCollector.Add(self); end; function TJSONRecordRTTI.AddItemFromRTTI( const PropertyName: RawUTF8; Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; begin result := TJSONCustomParserRTTI.CreateFromRTTI(PropertyName,Info,ItemSize); fItems.Add(result); end; {$ifdef ISDELPHI2010} procedure TJSONRecordRTTI.FromEnhancedRTTI( Props: TJSONCustomParserRTTI; Info: pointer); var FieldTable: PTypeInfo; i: integer; FieldSize: cardinal; RecField: PEnhancedFieldInfo; ItemFields: array of PEnhancedFieldInfo; ItemField: PTypeInfo; ItemFieldName: RawUTF8; ItemFieldSize: cardinal; Item, ItemArray: TJSONCustomParserRTTI; begin // only tkRecord is needed here FieldTable := GetTypeInfo(Info,tkRecord); if FieldTable=nil then raise ESynException.CreateUTF8('%.FromEnhancedRTTI(%=record?)',[self,Info]); FieldSize := FieldTable^.recSize; inc(PByte(FieldTable),FieldTable^.ManagedCount*SizeOf(TFieldInfo)-SizeOf(TFieldInfo)); inc(PByte(FieldTable),FieldTable^.NumOps*SizeOf(pointer)); // jump RecOps[] if FieldTable^.AllCount=0 then exit; // not enough RTTI -> will raise an error in Create() TypeInfoToName(Info,Props.fCustomTypeName); RecField := @FieldTable^.AllFields[0]; SetLength(ItemFields,FieldTable^.AllCount); for i := 0 to FieldTable^.AllCount-1 do begin ItemFields[i] := RecField; inc(PByte(RecField),RecField^.NameLen); // Delphi: no AlignPtr() needed inc(RecField); inc(PByte(RecField),PWord(RecField)^); end; SetLength(Props.fNestedProperty,FieldTable^.AllCount); for i := 0 to FieldTable^.AllCount-1 do begin if i=FieldTable^.AllCount-1 then ItemFieldSize := FieldSize-ItemFields[i].Offset else ItemFieldSize := ItemFields[i+1].Offset-ItemFields[i].Offset; ItemField := Deref(ItemFields[i]^.TypeInfo); FastSetString(ItemFieldName,PAnsiChar(@ItemFields[i]^.NameLen)+1,ItemFields[i]^.NameLen); Item := AddItemFromRTTI(ItemFieldName,ItemField,ItemFieldSize); Props.fNestedProperty[i] := Item; case Item.PropertyType of ptArray: begin inc(PByte(ItemField),ItemField^.NameLen); ItemArray := AddItemFromRTTI('',Deref(ItemField^.elType2), ItemField^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}); if (ItemArray.PropertyType=ptCustom) and (ItemArray.ClassType=TJSONCustomParserRTTI) then FromEnhancedRTTI(Item,Deref(ItemField^.elType2)) else begin SetLength(Item.fNestedProperty,1); Item.fNestedProperty[0] := ItemArray; Item.ComputeNestedDataSize; end; end; ptCustom: if (ItemField<>nil) and (Item.ClassType=TJSONCustomParserRTTI) then FromEnhancedRTTI(Item,ItemField); end; end; Props.ComputeNestedDataSize; end; {$endif ISDELPHI2010} { ************ variant-based process, including JSON/BSON document content } function SetVariantUnRefSimpleValue(const Source: variant; var Dest: TVarData): boolean; var typ: word; begin if TVarData(Source).VType and varByRef<>0 then begin typ := TVarData(Source).VType and not varByRef; case typ of varVariant: if PVarData(TVarData(Source).VPointer)^.VType in [varEmpty..varDate,varBoolean,varShortInt..varWord64] then begin Dest := PVarData(TVarData(Source).VPointer)^; result := true; end else result := false; varEmpty..varDate,varBoolean,varShortInt..varWord64: begin Dest.VType := typ; Dest.VInt64 := PInt64(TVarData(Source).VAny)^; result := true; end; else result := false; end; end else result := false; end; {$ifndef LVCL} procedure RawByteStringToVariant(Data: PByte; DataLen: Integer; var Value: variant); begin with TVarData(Value) do begin {$ifndef FPC}if VType and VTYPE_STATIC<>0 then{$endif} VarClear(Value); if (Data=nil) or (DataLen<=0) then VType := varNull else begin VType := varString; VAny := nil; // avoid GPF below when assigning a string variable to VAny SetString(RawByteString(VAny),PAnsiChar(Data),DataLen); end; end; end; procedure RawByteStringToVariant(const Data: RawByteString; var Value: variant); begin with TVarData(Value) do begin {$ifndef FPC}if VType and VTYPE_STATIC<>0 then{$endif} VarClear(Value); if Data='' then VType := varNull else begin VType := varString; VAny := nil; // avoid GPF below when assigning a string variable to VAny RawByteString(VAny) := Data; end; end; end; procedure VariantToRawByteString(const Value: variant; var Dest: RawByteString); begin case TVarData(Value).VType of varEmpty, varNull: Dest := ''; varString: Dest := RawByteString(TVarData(Value).VAny); else // not from RawByteStringToVariant() -> conversion to string Dest := {$ifdef UNICODE}RawByteString{$else}string{$endif}(Value); end; end; procedure SetVariantNull(var Value: variant); begin // slightly faster than Value := Null VarClear(Value); TVarData(Value).VType := varNull; end; {$endif LVCL} function VarIsEmptyOrNull(const V: Variant): Boolean; begin result := VarDataIsEmptyOrNull(@V); end; function VarDataIsEmptyOrNull(VarData: pointer): Boolean; begin repeat if PVarData(VarData)^.VType<>varVariant or varByRef then break; VarData := PVarData(VarData)^.VPointer; if VarData=nil then begin result := true; exit; end; until false; result := (PVarData(VarData)^.VType<=varNull) or (PVarData(VarData)^.VType=varNull or varByRef); end; function VarIs(const V: Variant; const VTypes: TVarDataTypes): Boolean; var VD: PVarData; begin VD := @V; repeat if VD^.VType<>varVariant or varByRef then break; VD := VD^.VPointer; if VD=nil then begin result := false; exit; end; until false; result := VD^.VType in VTypes; end; function VarIsVoid(const V: Variant): boolean; begin with TVarData(V) do case VType of varEmpty,varNull: result := true; varBoolean: result := not VBoolean; varString,varOleStr{$ifdef HASVARUSTRING},varUString{$endif}: result := VAny=nil; varDate: result := VInt64=0; else if VType=varVariant or varByRef then result := VarIsVoid(PVariant(VPointer)^) else if (VType=varByRef or varString) or (VType=varByRef or varOleStr) {$ifdef HASVARUSTRING} or (VType=varByRef or varUString) {$endif} then result := PPointer(VAny)^=nil else {$ifndef NOVARIANTS} if VType=word(DocVariantVType) then result := TDocVariantData(V).Count=0 else {$endif} result := false; end; end; {$ifndef NOVARIANTS} /// internal method used by VariantLoadJSON(), GetVariantFromJSON() and // TDocVariantData.InitJSONInPlace() procedure GetJSONToAnyVariant(var Value: variant; var JSON: PUTF8Char; EndOfObject: PUTF8Char; Options: PDocVariantOptions; AllowDouble: boolean); forward; procedure SetVariantByRef(const Source: Variant; var Dest: Variant); begin {$ifndef FPC}if TVarData(Dest).VType and VTYPE_STATIC<>0 then{$endif} VarClear(Dest); if (TVarData(Source).VType=varVariant or varByRef) or (TVarData(Source).VType in // already byref or simple [varEmpty..varDate,varBoolean,varShortInt..varWord64]) then TVarData(Dest) := TVarData(Source) else if not SetVariantUnRefSimpleValue(Source,TVarData(Dest)) then begin TVarData(Dest).VType := varVariant or varByRef; TVarData(Dest).VPointer := @Source; end; end; procedure SetVariantByValue(const Source: Variant; var Dest: Variant); var s: TVarData absolute Source; d: TVarData absolute Dest; begin {$ifndef FPC}if d.VType and VTYPE_STATIC<>0 then{$endif} VarClear(Dest); case s.VType of varEmpty..varDate,varBoolean,varShortInt..varWord64: begin d.VType := s.VType; d.VInt64 := s.VInt64; end; varString: begin d.VType := varString; d.VAny := nil; RawByteString(d.VAny) := RawByteString(s.VAny); end; varVariant or varByRef: Dest := PVariant(s.VPointer)^; varByRef or varString: begin d.VType := varString; d.VAny := nil; RawByteString(d.VAny) := PRawByteString(s.VAny)^; end; {$ifdef HASVARUSTRING} varUString, varByRef or varUString, {$endif} varOleStr, varByRef or varOleStr: begin d.VType := varString; d.VAny := nil; VariantToUTF8(Source,RawUTF8(d.VAny)); // store a RawUTF8 instance end; else if not SetVariantUnRefSimpleValue(Source,d) then Dest := Source; end; end; procedure ZeroFill(Value: PVarData); begin // slightly faster than FillChar(Value,SizeOf(Value),0); PInt64Array(Value)^[0] := 0; PInt64Array(Value)^[1] := 0; {$ifdef CPU64} //assert(SizeOf(TVarData)=24); PInt64Array(Value)^[2] := 0; {$endif} end; procedure FillZero(var value: variant); overload; begin with TVarData(Value) do case VType of varString: FillZero(RawByteString(VAny)); end; VarClear(Value); end; procedure RawUTF8ToVariant(Txt: PUTF8Char; TxtLen: integer; var Value: variant); begin with TVarData(Value) do begin if VType<>varString then begin // in-place replacement of a RawUTF8 value {$ifndef FPC}if VType and VTYPE_STATIC<>0 then{$endif} VarClear(Value); VType := varString; VAny := nil; // avoid GPF below when assigning a string variable to VAny end; FastSetString(RawUTF8(VString),Txt,TxtLen); end; end; procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: variant); begin with TVarData(Value) do begin if VType<>varString then begin // in-place replacement of a RawUTF8 value {$ifndef FPC}if VType and VTYPE_STATIC<>0 then{$endif} VarClear(Value); VType := varString; VAny := nil; // avoid GPF below when assigning a string variable to VAny if Txt='' then exit; end; RawByteString(VAny) := Txt; {$ifdef HASCODEPAGE} if (Txt<>'') and (StringCodePage(Txt)=CP_RAWBYTESTRING) then SetCodePage(RawByteString(VAny),CP_UTF8,false); // force explicit UTF-8 {$endif} end; end; procedure FormatUTF8ToVariant(const Fmt: RawUTF8; const Args: array of const; var Value: variant); begin RawUTF8ToVariant(FormatUTF8(Fmt,Args),Value); end; function RawUTF8ToVariant(const Txt: RawUTF8): variant; begin RawUTF8ToVariant(Txt,result); end; procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: TVarData; ExpectedValueType: word); begin {$ifndef FPC}if Value.VType and VTYPE_STATIC<>0 then{$endif} VarClear(variant(Value)); Value.VType := ExpectedValueType; Value.VAny := nil; // avoid GPF below if Txt<>'' then case ExpectedValueType of varString: begin RawByteString(Value.VAny) := Txt; {$ifdef HASCODEPAGE} if (Txt<>'') and (StringCodePage(Txt)=CP_RAWBYTESTRING) then SetCodePage(RawByteString(Value.VAny),CP_UTF8,false); // force explicit UTF-8 {$endif} end; varOleStr: UTF8ToWideString(Txt,WideString(Value.VAny)); {$ifdef HASVARUSTRING} varUString: UTF8DecodeToUnicodeString(pointer(Txt),length(Txt),UnicodeString(Value.VAny)); {$endif} else raise ESynException.CreateUTF8('RawUTF8ToVariant(ExpectedValueType=%)', [ExpectedValueType]); end; end; function VariantSave(const Value: variant; Dest: PAnsiChar): PAnsiChar; procedure ComplexType; begin try Dest := pointer(ToVarString(VariantSaveJSON(Value),PByte(Dest))); except on Exception do Dest := nil; // notify invalid/unhandled variant content end; end; var LenBytes: integer; tmp: TVarData; begin with TVarData(Value) do if VType and varByRef<>0 then if VType=varVariant or varByRef then begin result := VariantSave(PVariant(VPointer)^,Dest); exit; end else if SetVariantUnRefSimpleValue(Value,tmp) then begin result := VariantSave(variant(tmp),Dest-SizeOf(VType)); exit; end; with TVarData(Value) do begin PWord(Dest)^ := VType; inc(Dest,SizeOf(VType)); case VType of varNull, varEmpty: ; varShortInt, varByte: begin Dest^ := AnsiChar(VByte); inc(Dest); end; varSmallint, varWord, varBoolean: begin PWord(Dest)^ := VWord; inc(Dest,SizeOf(VWord)); end; varSingle, varLongWord, varInteger: begin PInteger(Dest)^ := VInteger; inc(Dest,SizeOf(VInteger)); end; varInt64, varWord64, varDouble, varDate, varCurrency:begin PInt64(Dest)^ := VInt64; inc(Dest,SizeOf(VInt64)); end; varString, varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin if PtrUInt(VAny)=0 then LenBytes := 0 else begin LenBytes := PStrRec(Pointer(PtrUInt(VAny)-STRRECSIZE))^.length; {$ifdef HASVARUSTRING} if VType=varUString then LenBytes := LenBytes*2; // stored length is in bytes, not (wide)chars {$endif} end; Dest := pointer(ToVarUInt32(LenBytes,pointer(Dest))); if LenBytes>0 then begin // direct raw copy {$ifdef FPC}Move{$else}MoveFast{$endif}(PPtrUInt(VAny)^,Dest^,LenBytes); inc(Dest,LenBytes); end; end; else ComplexType; // complex types are stored as JSON end; end; result := Dest; end; function VariantSaveLength(const Value: variant): integer; var tmp: TVarData; begin // match VariantSave() storage with TVarData(Value) do if VType and varByRef<>0 then if VType=varVariant or varByRef then begin result := VariantSaveLength(PVariant(VPointer)^); exit; end else if SetVariantUnRefSimpleValue(Value,tmp) then begin result := VariantSaveLength(variant(tmp)); exit; end; with TVarData(Value) do case VType of varEmpty, varNull: result := SizeOf(VType); varShortInt, varByte: result := SizeOf(VByte)+SizeOf(VType); varSmallint, varWord, varBoolean: result := SizeOf(VSmallint)+SizeOf(VType); varSingle, varLongWord, varInteger: result := SizeOf(VInteger)+SizeOf(VType); varInt64, varWord64, varDouble, varDate, varCurrency: result := SizeOf(VInt64)+SizeOf(VType); varString, varOleStr: if PtrUInt(VAny)=0 then result := 1+SizeOf(VType) else result := ToVarUInt32LengthWithData(PStrRec(Pointer(PtrUInt(VAny)-STRRECSIZE))^.length) +SizeOf(VType); {$ifdef HASVARUSTRING} varUString: if PtrUInt(VAny)=0 then // stored length is in bytes, not (wide)chars result := 1+SizeOf(VType) else result := ToVarUInt32LengthWithData(PStrRec(Pointer(PtrUInt(VAny)-STRRECSIZE))^.length*2) +SizeOf(VType); {$endif} else try // complex types will be stored as JSON result := ToVarUInt32LengthWithData(VariantSaveJSONLength(Value))+SizeOf(VType); except on Exception do result := 0; // notify invalid/unhandled variant content end; end; end; function VariantSave(const Value: variant): RawByteString; var P: PAnsiChar; begin SetString(result,nil,VariantSaveLength(Value)); P := VariantSave(Value,pointer(result)); if P-pointer(result)<>length(result) then raise ESynException.Create('VariantSave length'); end; function VariantLoad(const Bin: RawByteString; CustomVariantOptions: PDocVariantOptions): variant; begin if VariantLoad(result,Pointer(Bin),CustomVariantOptions)=nil then VarClear(result); end; function VariantLoad(var Value: variant; Source: PAnsiChar; CustomVariantOptions: PDocVariantOptions): PAnsiChar; var JSON: PUTF8Char; tmp: TSynTempBuffer; // GetJSON*() does in-place unescape -> private copy begin with TVarData(Value) do begin {$ifndef FPC}if VType and VTYPE_STATIC<>0 then{$endif} VarClear(Value); VType := PWord(Source)^; inc(Source,SizeOf(VType)); case VType of varNull, varEmpty: ; varShortInt, varByte: begin VByte := byte(Source^); inc(Source); end; varSmallint, varWord, varBoolean: begin VWord := PWord(Source)^; inc(Source,SizeOf(VWord)); end; varSingle, varLongWord, varInteger: begin VInteger := PInteger(Source)^; inc(Source,SizeOf(VInteger)); end; varInt64, varWord64, varDouble, varDate, varCurrency: begin VInt64 := PInt64(Source)^; inc(Source,SizeOf(VInt64)); end; varString, varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin VAny := nil; // avoid GPF below when assigning a string variable to VAny tmp.Len := FromVarUInt32(PByte(Source)); case VType of varString: FastSetString(RawUTF8(VString),Source,tmp.Len); // explicit RawUTF8 varOleStr: SetString(WideString(VAny),PWideChar(Source),tmp.Len shr 1); {$ifdef HASVARUSTRING} varUString: SetString(UnicodeString(VAny),PWideChar(Source),tmp.Len shr 1); {$endif} end; inc(Source,tmp.Len); end; else if CustomVariantOptions<>nil then begin try // expected format for complex type is JSON (VType may differ) FromVarString(PByte(Source),tmp); try JSON := tmp.buf; VType := varEmpty; // avoid GPF below GetJSONToAnyVariant(Value,JSON,nil,CustomVariantOptions,false); finally tmp.Done; end; except on Exception do Source := nil; // notify invalid/unhandled variant content end; end else Source := nil; // notify unhandled type end; end; result := Source; end; procedure FromVarVariant(var Source: PByte; var Value: variant; CustomVariantOptions: PDocVariantOptions); begin Source := PByte(VariantLoad(Value,PAnsiChar(Source),CustomVariantOptions)); end; function VariantLoadJSON(var Value: variant; JSON: PUTF8Char; EndOfObject: PUTF8Char; TryCustomVariants: PDocVariantOptions; AllowDouble: boolean): PUTF8Char; var wasString: boolean; Val: PUTF8Char; begin result := JSON; if JSON=nil then exit; if TryCustomVariants<>nil then begin if dvoJSONObjectParseWithinString in TryCustomVariants^ then begin JSON := GotoNextNotSpace(JSON); if JSON^='"' then begin Val := GetJSONField(result,result,@wasString,EndOfObject); GetJSONToAnyVariant(Value,Val,EndOfObject,TryCustomVariants,AllowDouble); end else GetJSONToAnyVariant(Value,result,EndOfObject,TryCustomVariants,AllowDouble); end else GetJSONToAnyVariant(Value,result,EndOfObject,TryCustomVariants,AllowDouble); end else begin Val := GetJSONField(result,result,@wasString,EndOfObject); GetVariantFromJSON(Val,wasString,Value,nil,AllowDouble); end; if result=nil then result := @NULCHAR; // reached end, but not invalid input end; procedure VariantLoadJSON(var Value: Variant; const JSON: RawUTF8; TryCustomVariants: PDocVariantOptions; AllowDouble: boolean); var tmp: TSynTempBuffer; begin tmp.Init(JSON); try VariantLoadJSON(Value,tmp.buf,nil,TryCustomVariants,AllowDouble); finally tmp.Done; end; end; function VariantLoadJSON(const JSON: RawUTF8; TryCustomVariants: PDocVariantOptions; AllowDouble: boolean): variant; var tmp: TSynTempBuffer; begin tmp.Init(JSON); try VariantLoadJSON(result,tmp.buf,nil,TryCustomVariants,AllowDouble); finally tmp.Done; end; end; function VariantSaveJSON(const Value: variant; Escape: TTextWriterKind): RawUTF8; begin VariantSaveJSON(Value,Escape,result); end; procedure VariantSaveJSON(const Value: variant; Escape: TTextWriterKind; var result: RawUTF8); var temp: TTextWriterStackBuffer; begin // not very optimized, but fast enough in practice, and creates valid JSON with DefaultTextWriterJSONClass.CreateOwnedStream(temp) do try AddVariant(Value,Escape); SetText(result); finally Free; end; end; function VariantSaveJSONLength(const Value: variant; Escape: TTextWriterKind): integer; var Fake: TFakeWriterStream; temp: TTextWriterStackBuffer; begin // will avoid most memory allocations Fake := TFakeWriterStream.Create; try with DefaultTextWriterJSONClass.Create(Fake,@temp,SizeOf(temp)) do try AddVariant(Value,Escape); FlushFinal; result := fTotalFileSize; finally Free; end; finally Fake.Free; end; end; procedure VariantToVarRec(const V: variant; var result: TVarRec); begin result.VType := vtVariant; if TVarData(V).VType=varByRef or varVariant then result.VVariant := TVarData(V).VPointer else result.VVariant := @V; end; function VarRecToVariant(const V: TVarRec): variant; begin VarRecToVariant(V,result); end; procedure VarRecToVariant(const V: TVarRec; var result: variant); begin {$ifndef FPC}if TVarData(result).VType and VTYPE_STATIC=0 then TVarData(result).VType := varEmpty else{$endif} VarClear(result); with TVarData(result) do case V.VType of vtPointer: VType := varNull; vtBoolean: begin VType := varBoolean; VBoolean := V.VBoolean; end; vtInteger: begin VType := varInteger; VInteger := V.VInteger; end; vtInt64: begin VType := varInt64; VInt64 := V.VInt64^; end; {$ifdef FPC} vtQWord: begin VType := varQWord; VQWord := V.VQWord^; end; {$endif} vtCurrency: begin VType := varCurrency; VCurrency := V.VCurrency^; end; vtExtended: begin VType := varDouble; VDouble := V.VExtended^; end; vtVariant: result := V.VVariant^; vtAnsiString: begin VType := varString; VAny := nil; RawByteString(VAny) := RawByteString(V.VAnsiString); end; vtString, {$ifdef HASVARUSTRING}vtUnicodeString,{$endif} vtPChar, vtChar, vtWideChar, vtWideString, vtClass: begin VType := varString; VString := nil; // avoid GPF on next line VarRecToUTF8(V,RawUTF8(VString)); // convert to a new RawUTF8 instance end; vtObject: // class instance will be serialized as a TDocVariant ObjectToVariant(V.VObject,result,[woDontStoreDefault]); else raise ESynException.CreateUTF8('Unhandled TVarRec.VType=%',[V.VType]); end; end; { TSynInvokeableVariantType } procedure TSynInvokeableVariantType.Lookup(var Dest: TVarData; const V: TVarData; FullName: PUTF8Char); var itemName: RawUTF8; Handler: TSynInvokeableVariantType; DestVar,LookupVar: TVarData; docv: word; begin Dest.VType := varEmpty; // left to Unassigned if not found DestVar := V; while DestVar.VType=varByRef or varVariant do DestVar := PVarData(DestVar.VPointer)^; docv := DocVariantVType; repeat GetNextItem(FullName,'.',itemName); if itemName='' then exit; if DestVar.VType=docv then begin if not TDocVariantData(DestVar).GetVarData(itemName,DestVar) then exit; end else if FindCustomVariantType(DestVar.VType,TCustomVariantType(Handler)) and Handler.InheritsFrom(TSynInvokeableVariantType) then try // handle any kind of document storage: TSynTableVariant,TBSONVariant... LookupVar.VType := varEmpty; Handler.IntGet(LookupVar,DestVar,pointer(itemName)); if LookupVar.VType<=varNull then exit; // assume varNull means not found DestVar := LookupVar; except on Exception do begin DestVar.VType := varEmpty; exit; end; end else exit; while DestVar.VType=varByRef or varVariant do DestVar := PVarData(DestVar.VPointer)^; if (DestVar.VType=docv) and (TDocVariantData(DestVar).VCount=0) then DestVar.VType := varNull; // recognize void TDocVariant as null if FullName=nil then begin // found full name scope Dest := DestVar; exit; end; // if we reached here, we should try for the next scope within Dest if DestVar.VType=VarType then // most likely to be of the same exact type continue; if FindCustomVariantType(DestVar.VType,TCustomVariantType(Handler)) and Handler.InheritsFrom(TSynInvokeableVariantType) then Handler.Lookup(Dest,DestVar,FullName); break; until false; end; function TSynInvokeableVariantType.IterateCount(const V: TVarData): integer; begin result := -1; // this is not an array end; procedure TSynInvokeableVariantType.Iterate(var Dest: TVarData; const V: TVarData; Index: integer); begin // do nothing end; {$ifndef FPC} {$ifndef DELPHI6OROLDER} function TSynInvokeableVariantType.FixupIdent(const AText: string): string; begin result := AText; // NO uppercased identifier for our custom types! end; {$endif DELPHI6OROLDER} {$endif FPC} function TSynInvokeableVariantType.GetProperty(var Dest: TVarData; const V: TVarData; const Name: String): Boolean; {$ifdef UNICODE} var Buf: array[byte] of AnsiChar; // to avoid heap allocation {$endif} begin {$ifdef UNICODE} RawUnicodeToUtf8(Buf,SizeOf(Buf),pointer(Name),length(Name),[]); IntGet(Dest,V,Buf); {$else} IntGet(Dest,V,pointer(Name)); {$endif} result := True; end; {$ifdef FPC_VARIANTSETVAR} // see http://mantis.freepascal.org/view.php?id=26773 function TSynInvokeableVariantType.SetProperty(var V: TVarData; const Name: string; const Value: TVarData): Boolean; {$else} function TSynInvokeableVariantType.SetProperty(const V: TVarData; const Name: string; const Value: TVarData): Boolean; {$endif} var ValueSet: TVarData; PropName: PAnsiChar; {$ifdef UNICODE} Buf: array[byte] of AnsiChar; // to avoid heap allocation {$endif} begin {$ifdef UNICODE} RawUnicodeToUtf8(Buf,SizeOf(Buf),pointer(Name),length(Name),[]); PropName := @Buf[0]; {$else} PropName := pointer(Name); {$endif} ValueSet.VString := nil; // to avoid GPF in RawUTF8(ValueSet.VString) below if Value.VType=varByRef or varOleStr then RawUnicodeToUtf8(PPointer(Value.VAny)^,length(PWideString(Value.VAny)^), RawUTF8(ValueSet.VString)) else if Value.VType=varOleStr then RawUnicodeToUtf8(Value.VAny,length(WideString(Value.VAny)), RawUTF8(ValueSet.VString)) else {$ifdef HASVARUSTRING} if Value.VType=varByRef or varUString then RawUnicodeToUtf8(PPointer(Value.VAny)^,length(PUnicodeString(Value.VAny)^), RawUTF8(ValueSet.VString)) else if Value.VType=varUString then RawUnicodeToUtf8(Value.VAny,length(UnicodeString(Value.VAny)), RawUTF8(ValueSet.VString)) else {$endif} if SetVariantUnRefSimpleValue(variant(Value),ValueSet) then begin IntSet(V,ValueSet,PropName); result := true; exit; end else begin IntSet(V,Value,PropName); result := true; exit; end; try // unpatched RTL does not like Unicode values :( -> transmit a RawUTF8 ValueSet.VType := varString; IntSet(V,ValueSet,PropName); finally RawUTF8(ValueSet.VString) := ''; // avoid memory leak end; result := True; end; procedure TSynInvokeableVariantType.Clear(var V: TVarData); begin ZeroFill(@V); // will set V.VType := varEmpty end; procedure TSynInvokeableVariantType.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); begin if Indirect then SimplisticCopy(Dest,Source,true) else begin {$ifndef FPC}if Dest.VType and VTYPE_STATIC<>0 then{$endif} VarClear(variant(Dest)); // Dest may be a complex type Dest := Source; end; end; procedure TSynInvokeableVariantType.CopyByValue(var Dest: TVarData; const Source: TVarData); begin Copy(Dest,Source,false); end; function TSynInvokeableVariantType.TryJSONToVariant(var JSON: PUTF8Char; var Value: variant; EndOfObject: PUTF8Char): boolean; begin result := false; end; procedure TSynInvokeableVariantType.ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind); begin raise ESynException.CreateUTF8('%.ToJSON: unimplemented variant type',[self]); end; function TSynInvokeableVariantType.IsOfType(const V: variant): boolean; begin if self=nil then result := false else if TVarData(V).VType=varByRef or varVariant then result := IsOfType(PVariant(TVarData(V).VPointer)^) else result := TVarData(V).VType=VarType; end; var SynVariantTypes: TObjectList = nil; function FindSynVariantType(aVarType: Word; out CustomType: TSynInvokeableVariantType): boolean; var i: integer; begin if SynVariantTypes<>nil then begin for i := 0 to SynVariantTypes.Count-1 do if TSynInvokeableVariantType(SynVariantTypes.List[i]).VarType=aVarType then begin CustomType := TSynInvokeableVariantType(SynVariantTypes.List[i]); result := true; exit; end; end; result := false; end; procedure GetJSONToAnyVariant(var Value: variant; var JSON: PUTF8Char; EndOfObject: PUTF8Char; Options: PDocVariantOptions; AllowDouble: boolean); // internal method used by VariantLoadJSON(), GetVariantFromJSON() and // TDocVariantData.InitJSON() var wasString: boolean; procedure ProcessSimple(Val: PUTF8Char); {$ifdef FPC}inline;{$endif} begin GetVariantFromJSON(Val,wasString,Value,nil,AllowDouble); if JSON=nil then JSON := @NULCHAR; end; var i: integer; VariantType: ^TSynInvokeableVariantType; ToBeParsed: PUTF8Char; wasParsedWithinString: boolean; begin {$ifndef FPC}if TVarData(Value).VType and VTYPE_STATIC<>0 then{$endif} VarClear(Value); if (Options<>nil) and (dvoAllowDoubleValue in Options^) then AllowDouble := true; // for ProcessSimple() above if EndOfObject<>nil then EndOfObject^ := ' '; if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']); if (Options=nil) or (JSON^ in ['-','1'..'9']) then begin // obvious simple type ProcessSimple(GetJSONField(JSON,JSON,@wasString,EndOfObject)); exit; end; if JSON^='"' then if dvoJSONObjectParseWithinString in Options^ then begin ToBeParsed := GetJSONField(JSON,JSON,@wasString,EndOfObject); EndOfObject := nil; // already set just above wasParsedWithinString := true; end else begin ProcessSimple(GetJSONField(JSON,JSON,@wasString,EndOfObject)); exit; end else begin ToBeParsed := JSON; wasParsedWithinString := false; end; if (SynVariantTypes<>nil) and not (dvoJSONParseDoNotTryCustomVariants in Options^) then begin VariantType := pointer(SynVariantTypes.List); for i := 1 to SynVariantTypes.Count do if VariantType^.TryJSONToVariant(ToBeParsed,Value,EndOfObject) then begin if not wasParsedWithinString then JSON := ToBeParsed; exit; end else inc(VariantType); end; if ToBeParsed^ in ['[','{'] then begin // default JSON parsing and conversion to TDocVariant instance ToBeParsed := TDocVariantData(Value).InitJSONInPlace(ToBeParsed,Options^,EndOfObject); if not wasParsedWithinString then JSON := ToBeParsed; end else // process to simple variant types if wasParsedWithinString then ProcessSimple(ToBeParsed) else ProcessSimple(GetJSONField(JSON,JSON,@wasString,EndOfObject)); end; function TextToVariantNumberTypeNoDouble(JSON: PUTF8Char): word; var start: PUTF8Char; begin start := json; if (json[0] in ['1'..'9']) or // is first char numeric? ((json[0]='0') and not (json[1] in ['0'..'9'])) or // '012' is invalid JSON ((json[0]='-') and (json[1] in ['0'..'9'])) then begin inc(json); repeat case json^ of '0'..'9': inc(json); '.': if (json[1] in ['0'..'9']) and (json[2] in [#0,'e','E','0'..'9']) then if (json[2]=#0) or (json[3]=#0) or ((json[3] in ['0'..'9']) and (json[4]=#0) or ((json[4] in ['0'..'9']) and (json[5]=#0))) then begin result := varCurrency; // currency ###.1234 number exit; end else break else // we expect exact digit representation break; #0: if json-start<=19 then begin // signed Int64 precision result := varInt64; exit; end else break; else break; end; until false; end; result := varString; end; function TextToVariantNumberType(json: PUTF8Char): word; var start: PUTF8Char; exp,err: integer; label exponent; begin start := json; if (json[0] in ['1'..'9']) or // is first char numeric? ((json[0]='0') and not (json[1] in ['0'..'9'])) or // '012' is invalid JSON ((json[0]='-') and (json[1] in ['0'..'9'])) then begin inc(json); repeat case json^ of '0'..'9': inc(json); '.': if (json[1] in ['0'..'9']) and (json[2] in [#0,'e','E','0'..'9']) then if (json[2]=#0) or (json[3]=#0) or ((json[3] in ['0'..'9']) and (json[4]=#0) or ((json[4] in ['0'..'9']) and (json[5]=#0))) then begin result := varCurrency; // currency ###.1234 number exit; end else begin repeat // more than 4 decimals inc(json) until not (json^ in ['0'..'9']); case json^ of #0: begin result := varDouble; exit; end; 'e','E': begin exponent: exp := GetInteger(json+1,err); if (err=0) and (exp>-324) and (exp<308) then begin result := varDouble; // 5.0 x 10^-324 .. 1.7 x 10^308 exit; end; end; end; break; end else break; 'e','E': goto exponent; #0: if json-start<=19 then begin // signed Int64 precision result := varInt64; exit; end else begin result := varDouble; // we may lost precision, but it is a number exit; end; else break; end; until false; end; result := varString; end; function GetNumericVariantFromJSON(JSON: PUTF8Char; var Value: TVarData; AllowVarDouble: boolean): boolean; var err: integer; typ: word; label dbl; begin if JSON<>nil then begin if AllowVarDouble then typ := TextToVariantNumberType(JSON) else typ := TextToVariantNumberTypeNoDouble(JSON); with Value do case typ of varInt64: begin VInt64 := GetInt64(JSON,err); if err<>0 then // overflow (>$7FFFFFFFFFFFFFFF) -> try floating point if AllowVarDouble then goto dbl else begin result:= false; exit; end; if (VInt64<=high(integer)) and (VInt64>=low(integer)) then VType := varInteger else VType := varInt64; result := true; exit; end; varCurrency: begin VInt64 := StrToCurr64(JSON); VType := varCurrency; result := true; exit; end; varDouble: begin dbl: VDouble := GetExtended(JSON,err); if err=0 then begin VType := varDouble; result := true; exit; end; end; end; end; result := false; end; procedure TextToVariant(const aValue: RawUTF8; AllowVarDouble: boolean; out aDest: variant); begin if not GetNumericVariantFromJSON(pointer(aValue),TVarData(aDest),AllowVarDouble) then RawUTF8ToVariant(aValue,aDest); end; function GetNextItemToVariant(var P: PUTF8Char; out Value: Variant; Sep: AnsiChar; AllowDouble: boolean): boolean; var temp: RawUTF8; begin if P=nil then result := false else begin GetNextItem(P,Sep,temp); if not GetNumericVariantFromJSON(pointer(temp),TVarData(Value),AllowDouble) then RawUTF8ToVariant(temp,Value); result := true; end; end; function GetVariantFromNotStringJSON(JSON: PUTF8Char; var Value: TVarData; AllowDouble: boolean): boolean; begin if (JSON<>nil) and (JSON^ in [#1..' ']) then repeat inc(JSON) until not(JSON^ in [#1..' ']); if (JSON=nil) or ((PInteger(JSON)^=NULL_LOW) and (JSON[4] in EndOfJSONValueField)) then Value.VType := varNull else if (PInteger(JSON)^=FALSE_LOW) and (JSON[4]='e') and (JSON[5] in EndOfJSONValueField) then begin Value.VType := varBoolean; Value.VBoolean := false; end else if (PInteger(JSON)^=TRUE_LOW) and (JSON[4] in EndOfJSONValueField) then begin Value.VType := varBoolean; Value.VBoolean := true; end else if not GetNumericVariantFromJSON(JSON,Value,AllowDouble) then begin result := false; exit; end; result := true; end; procedure GetVariantFromJSON(JSON: PUTF8Char; wasString: Boolean; var Value: variant; TryCustomVariants: PDocVariantOptions; AllowDouble: boolean); begin // first handle any strict-JSON syntax objects or arrays into custom variants // (e.g. when called directly from TSQLPropInfoRTTIVariant.SetValue) if (TryCustomVariants<>nil) and (JSON<>nil) then if (GotoNextNotSpace(JSON)^ in ['{','[']) and not wasString then begin GetJSONToAnyVariant(Value,JSON,nil,TryCustomVariants,AllowDouble); exit; end else AllowDouble := dvoAllowDoubleValue in TryCustomVariants^; // handle simple text or numerical values with TVarData(Value) do begin {$ifndef FPC}if VType and VTYPE_STATIC=0 then VType := varEmpty else{$endif} VarClear(Value); if not wasString and GetVariantFromNotStringJSON(JSON,TVarData(Value),AllowDouble) then exit; // found no numerical value -> return a string in the expected format VType := varString; VString := nil; // avoid GPF below when assigning a string variable to VAny FastSetString(RawUTF8(VString),JSON,StrLen(JSON)); end; end; {$ifndef FPC} // better not try it with FPC - rely on the current implementation function ParseParamPointer(P: pointer; aType: cardinal; var Value: TVarData): pointer; var Size: Cardinal; ByRef: Boolean; V: Variant absolute Value; const TYPE_BYREF = 128; TYPE_BYREF_MASK = TYPE_BYREF-1; begin // this code should copy parameters without any reference count handling ZeroFill(@Value); // TVarData is expected to be bulk stack: no VarClear needed ByRef := (aType and TYPE_BYREF)<>0; Size := SizeOf(pointer); case aType and TYPE_BYREF_MASK of varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord, varSingle: begin if ByRef then P := pointer(P^); Value.VType := aType and TYPE_BYREF_MASK; Value.VInteger := PInteger(P)^; {$ifdef CPU64} if not ByRef then Size := SizeOf(Integer); {$endif} end; varDouble, varCurrency, varDate, varInt64, varWord64, varOleStr: begin if ByRef then P := pointer(P^); Value.VType := aType and TYPE_BYREF_MASK; Value.VInt64 := PInt64(P)^; {$ifndef CPU64} if not ByRef then Size := SizeOf(Int64); {$endif} end; varStrArg: begin if ByRef then P := pointer(P^); Value.VType := varString; Value.VString := PPointer(P)^; end; {$ifdef HASVARUSTRARG} varUStrArg: begin if ByRef then P := pointer(P^); Value.VType := varUString; Value.VUString := PPointer(P)^; end; {$endif} varBoolean: if ByRef then V := PWordBool(pointer(P^))^ else V := PWordBool(P)^; varVariant: {$ifdef CPU64} // circumvent Delphi x64 compiler oddiness Value := PVarData(pointer(P^))^ {$else} if ByRef then Value := PVarData(pointer(P^))^ else begin Value := PVarData(P)^; Size := SizeOf(Value); end; {$endif} else raise EInvalidCast.CreateFmt('ParseParamPointer: Invalid VarType=%d', [aType and TYPE_BYREF_MASK]); end; result := PAnsiChar(P)+Size; end; var LastDispInvokeType: TSynInvokeableVariantType; procedure SynVarDispProc(Result: PVarData; const Instance: TVarData; CallDesc: PCallDesc; Params: Pointer); cdecl; const DO_PROP = 1; GET_PROP = 2; SET_PROP = 4; var Value: TVarData; Handler: TSynInvokeableVariantType; CacheDispInvokeType: TSynInvokeableVariantType; // to be thread-safe begin if Instance.VType=varByRef or varVariant then // handle By Ref variants SynVarDispProc(Result,PVarData(Instance.VPointer)^,CallDesc,Params) else begin if Result<>nil then VarClear(Variant(Result^)); case Instance.VType of varDispatch, varDispatch or varByRef, varUnknown, varUnknown or varByRef, varAny: // process Ole Automation variants if Assigned(VarDispProc) then VarDispProc(pointer(Result),Variant(Instance),CallDesc,@Params); else begin // first we check for our own TSynInvokeableVariantType types if SynVariantTypes<>nil then begin // simple cache for the latest type: most gets are grouped CacheDispInvokeType := LastDispInvokeType; if (CacheDispInvokeType<>nil) and (CacheDispInvokeType.VarType=TVarData(Instance).VType) and (CallDesc^.CallType in [GET_PROP, DO_PROP]) and (Result<>nil) and (CallDesc^.ArgCount=0) then begin CacheDispInvokeType.IntGet(Result^,Instance,@CallDesc^.ArgTypes[0]); exit; end; end; // handle any custom variant type if FindCustomVariantType(Instance.VType,TCustomVariantType(Handler)) then begin if Handler.InheritsFrom(TSynInvokeableVariantType) then case CallDesc^.CallType of GET_PROP, DO_PROP: // fast direct call of our IntGet() virtual method if (Result<>nil) and (CallDesc^.ArgCount=0) then begin Handler.IntGet(Result^,Instance,@CallDesc^.ArgTypes[0]); LastDispInvokeType := Handler; // speed up in loop exit; end; SET_PROP: // fast direct call of our IntSet() virtual method if (Result=nil) and (CallDesc^.ArgCount=1) then begin ParseParamPointer(@Params,CallDesc^.ArgTypes[0],Value); Handler.IntSet(Instance,Value,@CallDesc^.ArgTypes[1]); exit; end; end; // here we call the default code handling custom types Handler.DispInvoke({$ifdef DELPHI6OROLDER}Result^{$else}Result{$endif}, Instance,CallDesc,@Params) end else raise EInvalidOp.CreateFmt('Invalid variant type %d invoke',[Instance.VType]); end; end; end; end; function VariantsDispInvokeAddress: pointer; asm {$ifdef CPU64} mov rax,offset Variants.@DispInvoke {$else} mov eax,offset Variants.@DispInvoke {$endif} end; {$ifdef DOPATCHTRTL} {$define DOPATCHDISPINVOKE} // much faster late-binding process for our types {$endif} {$ifdef CPU64} {$define DOPATCHDISPINVOKE} // we NEED our patched DispInvoke to circumvent some Delphi bugs on Win64 {$endif} {$ifdef DELPHI6OROLDER} {$define DOPATCHDISPINVOKE} // to circumvent LIdent := Uppercase() in TInvokeableVariantType.DispInvoke() {$endif} {$endif FPC} function SynRegisterCustomVariantType(aClass: TSynInvokeableVariantTypeClass): TSynInvokeableVariantType; var i: integer; {$ifdef DOPATCHDISPINVOKE} {$ifdef NOVARCOPYPROC} VarMgr: TVariantManager; {$endif} {$endif} begin if SynVariantTypes=nil then begin {$ifndef FPC} {$ifdef DOPATCHDISPINVOKE} {$ifndef CPU64} // we NEED our patched RTL on Win64 if DebugHook=0 then // patch VCL/RTL only outside debugging {$endif} begin {$ifdef NOVARCOPYPROC} GetVariantManager(VarMgr); VarMgr.DispInvoke := @SynVarDispProc; SetVariantManager(VarMgr); {$else} RedirectCode(VariantsDispInvokeAddress,@SynVarDispProc); {$endif NOVARCOPYPROC} end; {$endif DOPATCHDISPINVOKE} {$endif FPC} GarbageCollectorFreeAndNil(SynVariantTypes,TObjectList.Create); end else for i := 0 to SynVariantTypes.Count-1 do if PPointer(SynVariantTypes.List[i])^=pointer(aClass) then begin result := SynVariantTypes.List[i]; // returns already registered instance exit; end; result := aClass.Create; // register variant type SynVariantTypes.Add(result); end; function VariantDynArrayToJSON(const V: TVariantDynArray): RawUTF8; var tmp: TDocVariantData; begin tmp.InitArrayFromVariants(V); result := tmp.ToJSON; end; function JSONToVariantDynArray(const JSON: RawUTF8): TVariantDynArray; var tmp: TDocVariantData; begin tmp.InitJSON(JSON,JSON_OPTIONS_FAST); result := tmp.VValue; end; function ValuesToVariantDynArray(const items: array of const): TVariantDynArray; var tmp: TDocVariantData; begin tmp.InitArray(items,JSON_OPTIONS_FAST); result := tmp.VValue; end; { TDocVariantData } function DocVariantData(const DocVariant: variant): PDocVariantData; begin with TVarData(DocVariant) do if VType=word(DocVariantVType) then result := @DocVariant else if VType=varByRef or varVariant then result := DocVariantData(PVariant(VPointer)^) else raise EDocVariant.CreateUTF8('DocVariantType.Data(%<>TDocVariant)',[VType]); end; function _Safe(const DocVariant: variant): PDocVariantData; {$ifdef FPC_OR_PUREPASCAL} var docv: word; begin result := @DocVariant; docv := DocVariantVType; if result.VType<>docv then if (result.VType=varByRef or varVariant) and (PVarData(PVarData(result)^.VPointer).VType=docv) then result := pointer(PVarData(result)^.VPointer) else result := @DocVariantDataFake; end; {$else} asm mov ecx,DocVariantVType movzx edx,word ptr [eax].TVarData.VType cmp edx,ecx jne @by ret @ptr: mov eax,[eax].TVarData.VPointer movzx edx,word ptr [eax].TVarData.VType cmp edx,ecx je @ok @by: cmp edx,varByRef or varVariant je @ptr lea eax,[DocVariantDataFake] @ok: end; {$endif} function _Safe(const DocVariant: variant; ExpectedKind: TDocVariantKind): PDocVariantData; begin result := _Safe(DocVariant); if result^.Kind<>ExpectedKind then raise EDocVariant.CreateUTF8('_Safe(%)<>%',[ToText(result^.Kind)^,ToText(ExpectedKind)^]); end; function _CSV(const DocVariantOrString: variant): RawUTF8; begin with _Safe(DocVariantOrString)^ do if dvoIsArray in VOptions then result := ToCSV else if (dvoIsObject in VOptions) or (TDocVariantData(DocVariantOrString).VType<=varNull) or not VariantToUTF8(DocVariantOrString,result) then result := ''; // VariantToUTF8() returns 'null' for empty/null end; function TDocVariantData.GetKind: TDocVariantKind; begin if dvoIsArray in VOptions then result := dvArray else if dvoIsObject in VOptions then result := dvObject else result := dvUndefined; end; procedure TDocVariantData.SetOptions(const opt: TDocVariantOptions); begin VOptions := (opt-[dvoIsArray,dvoIsObject])+(VOptions*[dvoIsArray,dvoIsObject]); end; procedure TDocVariantData.Init(aOptions: TDocVariantOptions; aKind: TDocVariantKind); begin ZeroFill(@self); VType := DocVariantVType; VOptions := aOptions-[dvoIsArray,dvoIsObject]; case aKind of dvArray: include(VOptions,dvoIsArray); dvObject: include(VOptions,dvoIsObject); end; end; procedure TDocVariantData.InitFast; begin ZeroFill(@self); VType := DocVariantVType; VOptions := JSON_OPTIONS_FAST; end; procedure TDocVariantData.InitFast(InitialCapacity: integer; aKind: TDocVariantKind); begin InitFast; case aKind of dvArray: include(VOptions,dvoIsArray); dvObject: include(VOptions,dvoIsObject); end; if aKind=dvObject then SetLength(VName,InitialCapacity); SetLength(VValue,InitialCapacity); end; procedure TDocVariantData.InitObject(const NameValuePairs: array of const; aOptions: TDocVariantOptions=[]); begin Init(aOptions,dvObject); AddNameValuesToObject(NameValuePairs); end; procedure TDocVariantData.AddNameValuesToObject(const NameValuePairs: array of const); var n,arg: integer; tmp: variant; begin n := length(NameValuePairs) shr 1; if (n=0) or (dvoIsArray in VOptions) then exit; // nothing to add include(VOptions,dvoIsObject); if length(VValue)=0 then begin VCount := length(Items); SetLength(VValue,VCount); if dvoValueCopiedByReference in aOptions then for arg := 0 to high(Items) do VarRecToVariant(Items[arg],VValue[arg]) else for arg := 0 to high(Items) do begin VarRecToVariant(Items[arg],tmp); SetVariantByValue(tmp,VValue[arg]); end; end; end; procedure TDocVariantData.InitArrayFromVariants(const Items: TVariantDynArray; aOptions: TDocVariantOptions; ItemsCopiedByReference: boolean); begin if Items=nil then VType := varNull else begin Init(aOptions,dvArray); VCount := length(Items); VValue := Items; // fast by-reference copy of VValue[] if not ItemsCopiedByReference then InitCopy(variant(self),aOptions); end; end; procedure TDocVariantData.InitArrayFromObjArray(const ObjArray; aOptions: TDocVariantOptions; aWriterOptions: TTextWriterWriteObjectOptions); var ndx: integer; Items: TObjectDynArray absolute ObjArray; begin if Items=nil then VType := varNull else begin Init(aOptions,dvArray); VCount := length(Items); SetLength(VValue,VCount); for ndx := 0 to VCount-1 do ObjectToVariant(Items[ndx],VValue[ndx],aWriterOptions); end; end; procedure TDocVariantData.InitArrayFrom(const Items: TRawUTF8DynArray; aOptions: TDocVariantOptions); var ndx: integer; begin if Items=nil then VType := varNull else begin Init(aOptions,dvArray); VCount := length(Items); SetLength(VValue,VCount); for ndx := 0 to VCount-1 do RawUTF8ToVariant(Items[ndx],VValue[ndx]); end; end; procedure TDocVariantData.InitArrayFrom(const Items: TIntegerDynArray; aOptions: TDocVariantOptions); var ndx: integer; begin if Items=nil then VType := varNull else begin Init(aOptions,dvArray); VCount := length(Items); SetLength(VValue,VCount); for ndx := 0 to VCount-1 do VValue[ndx] := Items[ndx]; end; end; procedure TDocVariantData.InitArrayFrom(const Items: TInt64DynArray; aOptions: TDocVariantOptions); var ndx: integer; begin if Items=nil then VType := varNull else begin Init(aOptions,dvArray); VCount := length(Items); SetLength(VValue,VCount); for ndx := 0 to VCount-1 do VValue[ndx] := Items[ndx]; end; end; procedure TDocVariantData.InitFromTypeInfo(const aValue; aTypeInfo: pointer; aEnumSetsAsText: boolean; aOptions: TDocVariantOptions); var tmp: RawUTF8; begin tmp := SaveJSON(aValue,aTypeInfo,aEnumSetsAsText); InitJSONInPlace(pointer(tmp),aOptions); end; procedure TDocVariantData.InitObjectFromVariants(const aNames: TRawUTF8DynArray; const aValues: TVariantDynArray; aOptions: TDocVariantOptions=[]); begin if (aNames=nil) or (aValues=nil) or (length(aNames)<>length(aValues)) then VType := varNull else begin Init(aOptions,dvObject); VCount := length(aNames); VName := aNames; // fast by-reference copy of VName[] and VValue[] VValue := aValues; end; end; procedure TDocVariantData.InitObjectFromPath(const aPath: RawUTF8; const aValue: variant; aOptions: TDocVariantOptions=[]); var right: RawUTF8; begin if aPath='' then VType := varNull else begin Init(aOptions,dvObject); VCount := 1; SetLength(VName,1); SetLength(VValue,1); split(aPath,'.',VName[0],right); if right='' then VValue[0] := aValue else PDocVariantData(@VValue[0])^.InitObjectFromPath(right,aValue,aOptions); end; end; function TDocVariantData.InitJSONInPlace(JSON: PUTF8Char; aOptions: TDocVariantOptions; aEndOfObject: PUTF8Char): PUTF8Char; var EndOfObject: AnsiChar; Name: PUTF8Char; NameLen, n: integer; intnames, intvalues: TRawUTF8Interning; begin Init(aOptions); result := nil; if JSON=nil then exit; if dvoInternValues in VOptions then intvalues := DocVariantType.InternValues else intvalues := nil; if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']); case JSON^ of '[': begin repeat inc(JSON) until not(JSON^ in [#1..' ']); n := JSONArrayCount(JSON); // may be slow if JSON is huge (not very common) if n<0 then exit; // invalid content include(VOptions,dvoIsArray); if n>0 then begin SetLength(VValue,n); repeat if VCount>=n then exit; // unexpected array size means invalid JSON GetJSONToAnyVariant(VValue[VCount],JSON,@EndOfObject,@VOptions,false); if JSON=nil then if EndOfObject=']' then // valid end input JSON := @NULCHAR else exit; // invalid input if intvalues<>nil then intvalues.UniqueVariant(VValue[VCount]); inc(VCount); until EndOfObject=']'; end else if JSON^=']' then // n=0 repeat inc(JSON) until not(JSON^ in [#1..' ']) else exit; end; '{': begin repeat inc(JSON) until not(JSON^ in [#1..' ']); n := JSONObjectPropCount(JSON); // may be slow if JSON is huge (not very common) if n<0 then exit; // invalid content include(VOptions,dvoIsObject); if dvoInternNames in VOptions then intnames := DocVariantType.InternNames else intnames := nil; if n>0 then begin SetLength(VValue,n); SetLength(VName,n); repeat if VCount>=n then exit; // unexpected object size means invalid JSON // see http://docs.mongodb.org/manual/reference/mongodb-extended-json Name := GetJSONPropName(JSON,@NameLen); if Name=nil then exit; FastSetString(VName[VCount],Name,NameLen); if intnames<>nil then intnames.UniqueText(VName[VCount]); GetJSONToAnyVariant(VValue[VCount],JSON,@EndOfObject,@VOptions,false); if JSON=nil then if EndOfObject=']' then // valid end input JSON := @NULCHAR else exit; // invalid input if intvalues<>nil then intvalues.UniqueVariant(VValue[VCount]); inc(VCount); until EndOfObject='}'; end else if JSON^='}' then // n=0 repeat inc(JSON) until not(JSON^ in [#1..' ']) else exit; end; 'n','N': begin if IdemPChar(JSON+1,'ULL') then begin include(VOptions,dvoIsObject); result := GotoNextNotSpace(JSON+4); end; exit; end; else exit; end; if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']); if aEndOfObject<>nil then aEndOfObject^ := JSON^; if JSON^<>#0 then repeat inc(JSON) until not(JSON^ in [#1..' ']); result := JSON; // indicates successfully parsed end; function TDocVariantData.InitJSON(const JSON: RawUTF8; aOptions: TDocVariantOptions): boolean; var tmp: TSynTempBuffer; begin if JSON='' then result := false else begin tmp.Init(JSON); try result := InitJSONInPlace(tmp.buf,aOptions)<>nil; finally tmp.Done; end; end; end; function TDocVariantData.InitJSONFromFile(const JsonFile: TFileName; aOptions: TDocVariantOptions; RemoveComments: boolean): boolean; var content: RawUTF8; begin content := AnyTextFileToRawUTF8(JsonFile,true); if RemoveComments then RemoveCommentsFromJSON(pointer(content)); result := InitJSONInPlace(pointer(content),aOptions)<>nil; end; procedure TDocVariantData.InitCSV(CSV: PUTF8Char; aOptions: TDocVariantOptions; NameValueSep, ItemSep: AnsiChar; DoTrim: boolean); var n,v: RawUTF8; val: variant; begin Init(aOptions,dvObject); while CSV<>nil do begin GetNextItem(CSV,NameValueSep,n); if ItemSep=#10 then GetNextItemTrimedCRLF(CSV,v) else GetNextItem(CSV,ItemSep,v); if DoTrim then v := trim(v); if n='' then break; RawUTF8ToVariant(v,val); AddValue(n,val); end; end; procedure TDocVariantData.InitCSV(const CSV: RawUTF8; aOptions: TDocVariantOptions; NameValueSep, ItemSep: AnsiChar; DoTrim: boolean); begin InitCSV(pointer(CSV),aOptions,NameValueSep,ItemSep,DoTrim); end; procedure TDocVariantData.InitCopy(const SourceDocVariant: variant; aOptions: TDocVariantOptions); var ndx: integer; Source: PDocVariantData; SourceVValue: TVariantDynArray; Handler: TCustomVariantType; t: word; v: PVarData; begin with TVarData(SourceDocVariant) do if VType=varByRef or varVariant then Source := VPointer else Source := @SourceDocVariant; if Source^.VType<>DocVariantVType then raise ESynException.CreateUTF8('No TDocVariant for InitCopy(%)',[Source.VType]); SourceVValue := Source^.VValue; // local fast per-reference copy if Source<>@self then begin VType := Source^.VType; VCount := Source^.VCount; pointer(VName) := nil; // avoid GPF pointer(VValue) := nil; VOptions := aOptions-[dvoIsArray,dvoIsObject]; // may not be same as Source if dvoIsArray in Source^.VOptions then include(VOptions,dvoIsArray) else if dvoIsObject in Source^.VOptions then begin include(VOptions,dvoIsObject); SetLength(VName,VCount); for ndx := 0 to VCount-1 do VName[ndx] := Source^.VName[ndx]; // manual copy is needed if dvoInternNames in VOptions then with DocVariantType.InternNames do for ndx := 0 to VCount-1 do UniqueText(VName[ndx]); end; end else begin SetOptions(aOptions); VariantDynArrayClear(VValue); // force re-create full copy of all values end; if VCount>0 then begin SetLength(VValue,VCount); for ndx := 0 to VCount-1 do begin v := @SourceVValue[ndx]; while v^.VType=varByRef or varVariant do v := v^.VPointer; t := v^.VType; if t<=varNativeString then // simple string/number types copy VValue[ndx] := variant(v^) else if t=VType then // direct recursive copy for TDocVariant TDocVariantData(VValue[ndx]).InitCopy(variant(v^),aOptions) else if FindCustomVariantType(t,Handler) then if Handler.InheritsFrom(TSynInvokeableVariantType) then TSynInvokeableVariantType(Handler).CopyByValue( TVarData(VValue[ndx]),v^) else Handler.Copy(TVarData(VValue[ndx]),v^,false) else VValue[ndx] := variant(v^); // default copy end; if dvoInternValues in VOptions then with DocVariantType.InternValues do for ndx := 0 to VCount-1 do UniqueVariant(VValue[ndx]); end; VariantDynArrayClear(SourceVValue); // faster alternative end; procedure TDocVariantData.Clear; begin if VType=DocVariantVType then begin PInteger(@VType)^ := 0; VName := nil; VariantDynArrayClear(VValue); VCount := 0; end else VarClear(variant(self)); end; procedure TDocVariantData.Reset; var backup: TDocVariantOptions; begin if VCount=0 then exit; backup := VOptions-[dvoIsArray,dvoIsObject]; DocVariantType.Clear(TVarData(self)); VType := DocVariantVType; VOptions := backup; end; procedure TDocVariantData.FillZero; var ndx: integer; begin for ndx := 0 to VCount-1 do SynCommons.FillZero(VValue[ndx]); Reset; end; procedure TDocVariantData.SetCount(aCount: integer); begin VCount := aCount; end; function TDocVariantData.InternalAdd(const aName: RawUTF8): integer; var len: integer; begin if aName<>'' then begin if dvoIsArray in VOptions then raise EDocVariant.CreateUTF8('Unexpected "%" property name in an array',[aName]); if not(dvoIsObject in VOptions) then begin VType := DocVariantVType; // may not be set yet include(VOptions,dvoIsObject); end; end else begin if dvoIsObject in VOptions then raise EDocVariant.Create('Unexpected array item added to an object'); if not(dvoIsArray in VOptions) then begin VType := DocVariantVType; // may not be set yet include(VOptions,dvoIsArray); end; end; len := length(VValue); if VCount>=len then begin len := NextGrow(VCount); SetLength(VValue,len); end; if aName<>'' then begin if Length(VName)<>len then SetLength(VName,len); if dvoInternNames in VOptions then begin // inlined InternNames method if DocVariantType.fInternNames=nil then DocVariantType.fInternNames := TRawUTF8Interning.Create; DocVariantType.fInternNames.Unique(VName[VCount],aName); end else VName[VCount] := aName; end; result := VCount; inc(VCount); end; procedure TDocVariantData.SetCapacity(aValue: integer); begin if dvoIsObject in VOptions then SetLength(VName,aValue); SetLength(VValue,aValue); end; function TDocVariantData.GetCapacity: integer; begin result := length(VValue); end; function TDocVariantData.AddValue(const aName: RawUTF8; const aValue: variant): integer; begin if dvoCheckForDuplicatedNames in VOptions then begin result := GetValueIndex(aName); if result>=0 then raise EDocVariant.CreateUTF8('Duplicated "%" name',[aName]); end; result := InternalAdd(aName); // FPC does not allow VValue[InternalAdd(aName)] SetVariantByValue(aValue,VValue[result]); if dvoInternValues in VOptions then DocVariantType.InternValues.UniqueVariant(VValue[result]); end; function TDocVariantData.AddValue(aName: PUTF8Char; aNameLen: integer; const aValue: variant): integer; var tmp: RawUTF8; begin FastSetString(tmp,aName,aNameLen); result := AddValue(tmp,aValue); end; function TDocVariantData.AddValueFromText(const aName,aValue: RawUTF8; Update, AllowVarDouble: boolean): integer; begin if aName='' then begin result := -1; exit; end; result := GetValueIndex(aName); if not Update and (dvoCheckForDuplicatedNames in VOptions) and (result>=0) then raise EDocVariant.CreateUTF8('Duplicated "%" name',[aName]); if result<0 then result := InternalAdd(aName); VarClear(VValue[result]); if not GetNumericVariantFromJSON(pointer(aValue),TVarData(VValue[result]),AllowVarDouble) then if dvoInternValues in VOptions then DocVariantType.InternValues.UniqueVariant(VValue[result],aValue) else RawUTF8ToVariant(aValue,VValue[result]); end; procedure TDocVariantData.AddByPath(const aSource: TDocVariantData; const aPaths: array of RawUTF8); var p,added: integer; v: TVarData; begin if (aSource.Count=0) or not(dvoIsObject in aSource.VOptions) or (dvoIsArray in VOptions) then exit; for p := 0 to High(aPaths) do begin DocVariantType.Lookup(v,TVarData(aSource),pointer(aPaths[p])); if v.VType=0) and VariantEquals(VValue[result],aPropValue,aPropValueCaseSensitive) then exit; end else if dvoIsArray in VOptions then for result := 0 to VCount-1 do with _Safe(VValue[result])^ do if dvoIsObject in VOptions then begin ndx := GetValueIndex(aPropName); if (ndx>=0) and VariantEquals(VValue[ndx],aPropValue,aPropValueCaseSensitive) then exit; end; result := -1; end; function TDocVariantData.SearchItemByProp(const aPropNameFmt: RawUTF8; const aPropNameArgs: array of const; const aPropValue: RawUTF8; aPropValueCaseSensitive: boolean): integer; var name: RawUTF8; begin FormatUTF8(aPropNameFmt,aPropNameArgs,name); result := SearchItemByProp(name,aPropValue,aPropValueCaseSensitive); end; function TDocVariantData.SearchItemByValue(const aValue: Variant; CaseInsensitive: boolean; StartIndex: integer): integer; begin for result := StartIndex to VCount-1 do if SortDynArrayVariantComp(TVarData(VValue[result]),TVarData(aValue),CaseInsensitive)=0 then exit; result := -1; end; procedure QuickSortDocVariant(names: PPointerArray; values: PVariantArray; L, R: PtrInt; Compare: TUTF8Compare); var I, J, P: PtrInt; pivot, tempname: pointer; tempvalue: TVarData; vi, vj: PVarData; begin if L0 do Dec(J); if I <= J then begin if I <> J then begin tempname := names[J]; names[J] := names[I]; names[I] := tempname; vi := @values[I]; vj := @values[J]; tempvalue := vj^; vj^ := vi^; vi^ := tempvalue; end; if P = I then P := J else if P = J then P := I; inc(I); dec(J); end; until I > J; if J - L < R - I then begin // use recursion only for smaller range if L < J then QuickSortDocVariant(names, values, L, J, Compare); L := I; end else begin if I < R then QuickSortDocVariant(names, values, I, R, Compare); R := J; end; until L >= R; end; procedure TDocVariantData.SortByName(Compare: TUTF8Compare=nil); begin if not(dvoIsObject in VOptions) or (VCount=0) then exit; if not Assigned(Compare) then Compare := @StrIComp; QuickSortDocVariant(pointer(VName),pointer(VValue),0,VCount-1,Compare); end; procedure ExchgValues(v1,v2: PVarData); var v: TVarData; begin v := v2^; v2^ := v1^; v1^ := v; end; procedure ExchgNames(n1,n2: PPointer); {$ifdef HASINLINE}inline;{$endif} var n: pointer; begin n := n2^; n2^ := n1^; n1^ := n; end; procedure QuickSortDocVariantValues(var Doc: TDocVariantData; L, R: PtrInt; Compare: TVariantCompare); var I, J, P: PtrInt; pivot: PVariant; begin if L0 do Dec(J); if I <= J then begin if I <> J then begin if Doc.VName<>nil then ExchgNames(@Doc.VName[I],@Doc.VName[J]); ExchgValues(@Doc.VValue[I],@Doc.VValue[J]); end; if P = I then P := J else if P = J then P := I; inc(I); dec(J); end; until I > J; if J - L < R - I then begin // use recursion only for smaller range if L < J then QuickSortDocVariantValues(Doc, L, J, Compare); L := I; end else begin if I < R then QuickSortDocVariantValues(Doc, I, R, Compare); R := J; end; until L >= R; end; procedure TDocVariantData.SortByValue(Compare: TVariantCompare); begin if VCount<=0 then exit; if not Assigned(Compare) then Compare := VariantCompare; QuickSortDocVariantValues(self,0,VCount-1,Compare); end; type {$ifdef FPC_OR_UNICODE}TQuickSortDocVariantValuesByField = record {$else}TQuickSortDocVariantValuesByField = object{$endif} Lookup: array of PVariant; Compare: TVariantCompare; Doc: PDocVariantData; Reverse: boolean; procedure Sort(L, R: PtrInt); end; procedure TQuickSortDocVariantValuesByField.Sort(L, R: PtrInt); var I, J, P: PtrInt; pivot: PVariant; begin if L0 do Dec(J); end else begin while Compare(Lookup[I]^,pivot^)>0 do Inc(I); while Compare(Lookup[J]^,pivot^)<0 do Dec(J); end; if I <= J then begin if I <> J then begin if Doc.VName<>nil then ExchgNames(@Doc.VName[I],@Doc.VName[J]); ExchgValues(@Doc.VValue[I],@Doc.VValue[J]); pivot := Lookup[I]; Lookup[I] := Lookup[J]; Lookup[J] := pivot; end; if P = I then P := J else if P = J then P := I; inc(I); dec(J); end; until I > J; if J - L < R - I then begin // use recursion only for smaller range if L < J then Sort(L,J); L := I; end else begin if I < R then Sort(I,R); R := J; end; until L >= R; end; procedure TDocVariantData.SortArrayByField(const aItemPropName: RawUTF8; aValueCompare: TVariantCompare; aValueCompareReverse: boolean; aNameSortedCompare: TUTF8Compare); var QS: TQuickSortDocVariantValuesByField; p: pointer; row: PtrInt; begin if (VCount<=0) or (aItemPropName='') or not (dvoIsArray in VOptions) then exit; if not Assigned(aValueCompare) then QS.Compare := VariantCompare else QS.Compare := aValueCompare; QS.Reverse := aValueCompareReverse; SetLength(QS.Lookup,VCount); for row := 0 to VCount-1 do begin // resolve GetPVariantByName(aIdemPropName) once p := _Safe(VValue[row])^.GetVarData(aItemPropName,aNameSortedCompare); if p = nil then p := @NullVarData; QS.Lookup[row] := p; end; QS.Doc := @self; QS.Sort(0,VCount-1); end; procedure TDocVariantData.Reverse; var arr: TDynArray; begin if VCount=0 then exit; if VName<>nil then begin SetLength(VName,VCount); arr.Init(TypeInfo(TRawUTF8DynArray),VName); arr.Reverse; end; if VValue<>nil then begin SetLength(VValue,VCount); arr.Init(TypeInfo(TVariantDynArray),VValue); arr.Reverse; end; end; function TDocVariantData.Reduce(const aPropNames: array of RawUTF8; aCaseSensitive,aDoNotAddVoidProp: boolean): variant; begin VarClear(result); Reduce(aPropNames,aCaseSensitive,PDocVariantData(@result)^,aDoNotAddVoidProp); end; procedure TDocVariantData.Reduce(const aPropNames: array of RawUTF8; aCaseSensitive: boolean; out result: TDocVariantData; aDoNotAddVoidProp: boolean); var ndx,j: integer; reduced: TDocVariantData; begin result.InitFast; if (VCount=0) or (high(aPropNames)<0) then exit; if dvoIsObject in VOptions then begin if aCaseSensitive then begin for j := 0 to high(aPropNames) do for ndx := 0 to VCount-1 do if VName[ndx]=aPropNames[j] then begin if not aDoNotAddVoidProp or not VarIsVoid(VValue[ndx]) then result.AddValue(VName[ndx],VValue[ndx]); break; end; end else for j := 0 to high(aPropNames) do for ndx := 0 to VCount-1 do if IdemPropNameU(VName[ndx],aPropNames[j]) then begin if not aDoNotAddVoidProp or not VarIsVoid(VValue[ndx]) then result.AddValue(VName[ndx],VValue[ndx]); break; end; end else if dvoIsArray in VOptions then for ndx := 0 to VCount-1 do begin _Safe(VValue[ndx])^.Reduce(aPropNames,aCaseSensitive,reduced,aDoNotAddVoidProp); if dvoIsObject in reduced.VOptions then result.AddItem(variant(reduced)); end; end; function TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; OnReduce: TOnReducePerItem): variant; begin VarClear(result); ReduceAsArray(aPropName,PDocVariantData(@result)^,OnReduce); end; procedure TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; out result: TDocVariantData; OnReduce: TOnReducePerItem); var ndx,j: integer; item: PDocVariantData; begin result.InitFast; if (VCount=0) or (aPropName='') or not(dvoIsArray in VOptions) then exit; for ndx := 0 to VCount-1 do begin item := _Safe(VValue[ndx]); j := item^.GetValueIndex(aPropName); if j>=0 then if not Assigned(OnReduce) or OnReduce(item) then result.AddItem(item^.VValue[j]); end; end; function TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; OnReduce: TOnReducePerValue): variant; begin VarClear(result); ReduceAsArray(aPropName,PDocVariantData(@result)^,OnReduce); end; procedure TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; out result: TDocVariantData; OnReduce: TOnReducePerValue); var ndx,j: integer; item: PDocVariantData; v: PVariant; begin result.InitFast; if (VCount=0) or (aPropName='') or not(dvoIsArray in VOptions) then exit; for ndx := 0 to VCount-1 do begin item := _Safe(VValue[ndx]); j := item^.GetValueIndex(aPropName); if j>=0 then begin v := @item^.VValue[j]; if not Assigned(OnReduce) or OnReduce(v^) then result.AddItem(v^); end; end; end; function TDocVariantData.Rename(const aFromPropName, aToPropName: TRawUTF8DynArray): integer; var n, p, ndx: integer; begin result := 0; n := length(aFromPropName); if length(aToPropName)=n then for p := 0 to n-1 do begin ndx := GetValueIndex(aFromPropName[p]); if ndx>=0 then begin VName[ndx] := aToPropName[p]; inc(result); end; end; end; function TDocVariantData.FlattenAsNestedObject(const aObjectPropName: RawUTF8): boolean; var ndx,len: integer; Up: array[byte] of AnsiChar; nested: TDocVariantData; begin // {"p.a1":5,"p.a2":"dfasdfa"} -> {"p":{"a1":5,"a2":"dfasdfa"}} result := false; if (VCount=0) or (aObjectPropName='') or not(dvoIsObject in VOptions) then exit; PWord(UpperCopy255(Up,aObjectPropName))^ := ord('.'); // e.g. 'P.' for ndx := 0 to Count-1 do if not IdemPChar(pointer(VName[ndx]),Up) then exit; // all fields should match "p.####" len := length(aObjectPropName)+1; for ndx := 0 to Count-1 do system.delete(VName[ndx],1,len); nested := self; Clear; InitObject([aObjectPropName,variant(nested)]); result := true; end; function TDocVariantData.Delete(Index: integer): boolean; begin if cardinal(Index)>=cardinal(VCount) then result := false else begin dec(VCount); if VName<>nil then VName[Index] := ''; VarClear(VValue[Index]); if Indexnil then begin {$ifdef FPC}Move{$else}MoveFast{$endif}( VName[Index+1],VName[Index],(VCount-Index)*SizeOf(pointer)); PtrUInt(VName[VCount]) := 0; // avoid GPF end; {$ifdef FPC}Move{$else}MoveFast{$endif}( VValue[Index+1],VValue[Index],(VCount-Index)*SizeOf(variant)); TVarData(VValue[VCount]).VType := varEmpty; // avoid GPF end; result := true; end; end; function TDocVariantData.Delete(const aName: RawUTF8): boolean; begin result := Delete(GetValueIndex(aName)); end; function TDocVariantData.DeleteByProp(const aPropName,aPropValue: RawUTF8; aPropValueCaseSensitive: boolean): boolean; var ndx: integer; begin ndx := SearchItemByProp(aPropName,aPropValue,aPropValueCaseSensitive); if ndx<0 then result := false else result := Delete(ndx); end; function TDocVariantData.DeleteByValue(const aValue: Variant; CaseInsensitive: boolean): integer; var ndx: integer; begin result := 0; if VarIsEmptyOrNull(aValue) then begin for ndx := VCount-1 downto 0 do if VarDataIsEmptyOrNull(@VValue[ndx]) then begin Delete(ndx); inc(result); end; end else for ndx := VCount-1 downto 0 do if SortDynArrayVariantComp(TVarData(VValue[ndx]),TVarData(aValue),CaseInsensitive)=0 then begin Delete(ndx); inc(result); end; end; function TDocVariantData.DeleteByStartName(aStartName: PUTF8Char; aStartNameLen: integer): integer; var ndx: integer; upname: array[byte] of AnsiChar; begin result := 0; if aStartNameLen=0 then aStartNameLen := StrLen(aStartName); if (VCount=0) or not(dvoIsObject in VOptions) or (aStartNameLen=0) then exit; UpperCopy255Buf(upname,aStartName,aStartNameLen)^ := #0; for ndx := Count-1 downto 0 do if IdemPChar(pointer(names[ndx]),upname) then begin Delete(ndx); inc(result); end; end; function TDocVariantData.GetValueIndex(aName: PUTF8Char; aNameLen: PtrInt; aCaseSensitive: boolean): integer; var err: integer; n: PRawUTF8; begin if (VType=DocVariantVType) and (VCount>0) then begin if dvoIsArray in VOptions then begin result := GetInteger(aName,err); if err<>0 then raise EDocVariant.CreateUTF8('Impossible to find "%" property in an array',[aName]); if cardinal(result)>=cardinal(VCount) then raise EDocVariant.CreateUTF8('Out of range [%] property in an array',[aName]); exit; end; // O(n) lookup for object names -> huge count may take some time n := pointer(VName); if aCaseSensitive then begin for result := 0 to VCount-1 do if (length(n^)=aNameLen) and CompareMem(pointer(n^),aName,aNameLen) then exit else inc(n); end else for result := 0 to VCount-1 do if (length(n^)=aNameLen) and IdemPropNameUSameLen(pointer(n^),aName,aNameLen) then exit else inc(n); end; result := -1; end; function TDocVariantData.GetValueIndex(const aName: RawUTF8): integer; begin {$ifndef HASINLINE} if not(dvoNameCaseSensitive in VOptions) and (dvoIsObject in VOptions) and (VType=DocVariantVType) then begin for result := 0 to VCount-1 do if IdemPropNameU(VName[result],aName) then exit; result := -1; end else {$endif} result := GetValueIndex(Pointer(aName),Length(aName),dvoNameCaseSensitive in VOptions); end; function TDocVariantData.GetValueOrRaiseException(const aName: RawUTF8): variant; begin RetrieveValueOrRaiseException(pointer(aName),length(aName), dvoNameCaseSensitive in VOptions,result,false); end; function TDocVariantData.GetValueOrDefault(const aName: RawUTF8; const aDefault: variant): variant; var ndx: integer; begin if (VType<>DocVariantVType) or not(dvoIsObject in VOptions) then result := aDefault else begin ndx := GetValueIndex(aName); if ndx>=0 then result := VValue[ndx] else result := aDefault; end; end; function TDocVariantData.GetValueOrNull(const aName: RawUTF8): variant; var ndx: integer; begin if (VType<>DocVariantVType) or not(dvoIsObject in VOptions) then SetVariantNull(result) else begin ndx := GetValueIndex(aName); if ndx>=0 then result := VValue[ndx] else SetVariantNull(result); end; end; function TDocVariantData.GetValueOrEmpty(const aName: RawUTF8): variant; var ndx: integer; begin VarClear(result); if (VType=DocVariantVType) and (dvoIsObject in VOptions) then begin ndx := GetValueIndex(aName); if ndx>=0 then result := VValue[ndx]; end; end; function TDocVariantData.GetAsBoolean(const aName: RawUTF8; out aValue: boolean; aSortedCompare: TUTF8Compare): Boolean; var found: PVarData; begin found := GetVarData(aName,aSortedCompare); if found=nil then result := false else result := VariantToBoolean(PVariant(found)^,aValue) end; function TDocVariantData.GetAsInteger(const aName: RawUTF8; out aValue: integer; aSortedCompare: TUTF8Compare): Boolean; var found: PVarData; begin found := GetVarData(aName,aSortedCompare); if found=nil then result := false else result := VariantToInteger(PVariant(found)^,aValue); end; function TDocVariantData.GetAsInt64(const aName: RawUTF8; out aValue: Int64; aSortedCompare: TUTF8Compare): Boolean; var found: PVarData; begin found := GetVarData(aName,aSortedCompare); if found=nil then result := false else result := VariantToInt64(PVariant(found)^,aValue) end; function TDocVariantData.GetAsDouble(const aName: RawUTF8; out aValue: double; aSortedCompare: TUTF8Compare): Boolean; var found: PVarData; begin found := GetVarData(aName,aSortedCompare); if found=nil then result := false else result := VariantToDouble(PVariant(found)^,aValue); end; function TDocVariantData.GetAsRawUTF8(const aName: RawUTF8; out aValue: RawUTF8; aSortedCompare: TUTF8Compare): Boolean; var found: PVarData; wasString: boolean; begin found := GetVarData(aName,aSortedCompare); if found=nil then result := false else begin if found^.VType>varNull then // default VariantToUTF8(null)='null' VariantToUTF8(PVariant(found)^,aValue,wasString); result := true; end; end; function TDocVariantData.GetValueEnumerate(const aName: RawUTF8; aTypeInfo: pointer; out aValue; aDeleteFoundEntry: boolean): boolean; var text: RawUTF8; ndx, ord: integer; begin result := false; ndx := GetValueIndex(aName); if ndx<0 then exit; VariantToUTF8(Values[ndx],text); ord := GetEnumNameValue(aTypeInfo,text,true); if ord<0 then exit; byte(aValue) := ord; if aDeleteFoundEntry then Delete(ndx); result := true; end; function TDocVariantData.GetAsDocVariant(const aName: RawUTF8; out aValue: PDocVariantData; aSortedCompare: TUTF8Compare=nil): boolean; var found: PVarData; begin found := GetVarData(aName,aSortedCompare); if found=nil then result := false else begin aValue := _Safe(PVariant(found)^); result := aValue<>@DocVariantDataFake; end; end; function TDocVariantData.GetAsDocVariantSafe(const aName: RawUTF8; aSortedCompare: TUTF8Compare): PDocVariantData; var found: PVarData; begin found := GetVarData(aName,aSortedCompare); if found=nil then result := @DocVariantDataFake else result := _Safe(PVariant(found)^); end; function TDocVariantData.GetAsPVariant(const aName: RawUTF8; out aValue: PVariant; aSortedCompare: TUTF8Compare=nil): boolean; begin aValue := pointer(GetVarData(aName,aSortedCompare)); result := aValue<>nil; end; function TDocVariantData.GetVarData(const aName: RawUTF8; var aValue: TVarData; aSortedCompare: TUTF8Compare): boolean; var found: PVarData; begin found := GetVarData(aName,aSortedCompare); if found=nil then result := false else begin aValue := found^; result := true; end; end; function TDocVariantData.GetVarData(const aName: RawUTF8; aSortedCompare: TUTF8Compare): PVarData; var ndx: Integer; begin if (VType<>DocVariantVType) or not(dvoIsObject in VOptions) or (VCount=0) then result := nil else begin if Assigned(aSortedCompare) then ndx := FastFindPUTF8CharSorted(pointer(VName),VCount-1,pointer(aName),aSortedCompare) else ndx := FindRawUTF8(VName,VCount,aName,not(dvoNameCaseSensitive in VOptions)); if ndx>=0 then result := @VValue[ndx] else result := nil; end; end; function TDocVariantData.GetValueByPath(const aPath: RawUTF8): variant; var Dest: TVarData; begin VarClear(result); if (VType<>DocVariantVType) or not(dvoIsObject in VOptions) then exit; DocVariantType.Lookup(Dest,TVarData(self),pointer(aPath)); if Dest.VType>=varNull then result := variant(Dest); // copy end; function TDocVariantData.GetValueByPath(const aPath: RawUTF8; out aValue: variant): boolean; var Dest: TVarData; begin result := false; if (VType<>DocVariantVType) or not(dvoIsObject in VOptions) then exit; DocVariantType.Lookup(Dest,TVarData(self),pointer(aPath)); if Dest.VType=varEmpty then exit; aValue := variant(Dest); // copy result := true; end; function TDocVariantData.GetPVariantByPath(const aPath: RawUTF8): PVariant; var p: PUTF8Char; item: RawUTF8; par: PVariant; begin result := nil; if (VType<>DocVariantVType) or (aPath='') or not(dvoIsObject in VOptions) or (Count=0) then exit; par := @self; P := pointer(aPath); repeat GetNextItem(P,'.',item); if _Safe(par^).GetAsPVariant(item,result) then par := result else begin result := nil; exit; end; until P=nil; // if we reached here, we have par=result=found item end; function TDocVariantData.GetDocVariantByPath(const aPath: RawUTF8; out aValue: PDocVariantData): boolean; var v: PVariant; begin v := GetPVariantByPath(aPath); if v<>nil then begin aValue := _Safe(v^); result := aValue^.VType>varNull; end else result := false; end; function TDocVariantData.GetValueByPath(const aDocVariantPath: array of RawUTF8): variant; var found,res: PVarData; P: integer; begin VarClear(result); if (VType<>DocVariantVType) or not(dvoIsObject in VOptions) or (high(aDocVariantPath)<0) then exit; found := @self; P := 0; repeat found := PDocVariantData(found).GetVarData(aDocVariantPath[P]); if found=nil then exit; if P=high(aDocVariantPath) then break; // we found the item! inc(P); // if we reached here, we should try for the next scope within Dest while found^.VType=varByRef or varVariant do found := found^.VPointer; if found^.VType=VType then continue; exit; until false; res := found; while res^.VType=varByRef or varVariant do res := res^.VPointer; if (res^.VType=VType) and (PDocVariantData(res)^.VCount=0) then // return void TDocVariant as null TVarData(result).VType := varNull else // copy found value result := PVariant(found)^; end; function TDocVariantData.GetItemByProp(const aPropName,aPropValue: RawUTF8; aPropValueCaseSensitive: boolean; var Dest: variant; DestByRef: boolean): boolean; var ndx: integer; begin result := false; if not(dvoIsArray in VOptions) then exit; ndx := SearchItemByProp(aPropName,aPropValue,aPropValueCaseSensitive); if ndx<0 then exit; RetrieveValueOrRaiseException(ndx,Dest,DestByRef); result := true; end; function TDocVariantData.GetDocVariantByProp(const aPropName,aPropValue: RawUTF8; aPropValueCaseSensitive: boolean; out Dest: PDocVariantData): boolean; var ndx: integer; begin result := false; if not(dvoIsArray in VOptions) then exit; ndx := SearchItemByProp(aPropName,aPropValue,aPropValueCaseSensitive); if ndx<0 then exit; Dest := _Safe(VValue[ndx]); result := Dest^.VType>varNull; end; function TDocVariantData.GetJsonByStartName(const aStartName: RawUTF8): RawUTF8; var Up: array[byte] of AnsiChar; temp: TTextWriterStackBuffer; ndx: integer; W: TTextWriter; begin if not(dvoIsObject in VOptions) or (VCount=0) then begin result := NULL_STR_VAR; exit; end; UpperCopy255(Up,aStartName)^ := #0; W := DefaultTextWriterJSONClass.CreateOwnedStream(temp); try W.Add('{'); for ndx := 0 to VCount-1 do if IdemPChar(Pointer(VName[ndx]),Up) then begin if (dvoSerializeAsExtendedJson in VOptions) and JsonPropNameValid(pointer(VName[ndx])) then begin W.AddNoJSONEscape(pointer(VName[ndx]),Length(VName[ndx])); end else begin W.Add('"'); W.AddJSONEscape(pointer(VName[ndx]),Length(VName[ndx])); W.Add('"'); end; W.Add(':'); W.AddVariant(VValue[ndx],twJSONEscape); W.Add(','); end; W.CancelLastComma; W.Add('}'); W.SetText(result); finally W.Free; end; end; function TDocVariantData.GetValuesByStartName(const aStartName: RawUTF8; TrimLeftStartName: boolean): variant; var Up: array[byte] of AnsiChar; ndx: integer; name: RawUTF8; begin if aStartName='' then begin result := Variant(self); exit; end; if not(dvoIsObject in VOptions) or (VCount=0) then begin SetVariantNull(result); exit; end; TDocVariant.NewFast(result); UpperCopy255(Up,aStartName)^ := #0; for ndx := 0 to VCount-1 do if IdemPChar(Pointer(VName[ndx]),Up) then begin name := VName[ndx]; if TrimLeftStartName then system.delete(name, 1, length(aStartName)); TDocVariantData(result).AddValue(name,VValue[ndx]); end; end; procedure TDocVariantData.SetValueOrRaiseException(Index: integer; const NewValue: variant); begin if cardinal(Index)>=cardinal(VCount) then raise EDocVariant.CreateUTF8('Out of range Values[%] (count=%)',[Index,VCount]) else VValue[Index] := NewValue; end; procedure TDocVariantData.RetrieveNameOrRaiseException(Index: integer; var Dest: RawUTF8); begin if (cardinal(Index)>=cardinal(VCount)) or (VName=nil) then if dvoReturnNullForUnknownProperty in VOptions then Dest := '' else raise EDocVariant.CreateUTF8('Out of range Names[%] (count=%)',[Index,VCount]) else Dest := VName[Index]; end; procedure TDocVariantData.RetrieveValueOrRaiseException(Index: integer; var Dest: variant; DestByRef: boolean); var Source: PVariant; begin if cardinal(Index)>=cardinal(VCount) then if dvoReturnNullForUnknownProperty in VOptions then SetVariantNull(Dest) else raise EDocVariant.CreateUTF8('Out of range Values[%] (count=%)',[Index,VCount]) else if DestByRef then SetVariantByRef(VValue[Index],Dest) else begin Source := @VValue[Index]; while PVarData(Source)^.VType=varVariant or varByRef do Source := PVarData(Source)^.VPointer; Dest := Source^; end; end; procedure TDocVariantData.RetrieveValueOrRaiseException( aName: PUTF8Char; aNameLen: integer; aCaseSensitive: boolean; var Dest: variant; DestByRef: boolean); var ndx: Integer; begin ndx := GetValueIndex(aName,aNameLen,aCaseSensitive); if ndx<0 then if dvoReturnNullForUnknownProperty in VOptions then SetVariantNull(Dest) else raise EDocVariant.CreateUTF8('Unexpected "%" property',[aName]) else RetrieveValueOrRaiseException(ndx,Dest,DestByRef); end; function TDocVariantData.GetValueOrItem(const aNameOrIndex: variant): variant; var wasString: boolean; Name: RawUTF8; begin if dvoIsArray in VOptions then // fast index lookup e.g. for Value[1] RetrieveValueOrRaiseException(VariantToIntegerDef(aNameOrIndex,-1),result,true) else begin VariantToUTF8(aNameOrIndex,Name,wasString); // by name lookup e.g. for Value['abc'] if wasString then RetrieveValueOrRaiseException(pointer(Name),length(Name), dvoNameCaseSensitive in VOptions,result,true) else RetrieveValueOrRaiseException(GetIntegerDef(pointer(Name),-1),result,true); end; end; procedure TDocVariantData.SetValueOrItem(const aNameOrIndex, aValue: variant); var wasString: boolean; ndx: integer; Name: RawUTF8; begin if dvoIsArray in VOptions then // fast index lookup e.g. for Value[1] SetValueOrRaiseException(VariantToIntegerDef(aNameOrIndex,-1),aValue) else begin VariantToUTF8(aNameOrIndex,Name,wasString); // by name lookup e.g. for Value['abc'] if wasString then begin ndx := GetValueIndex(Name); if ndx<0 then ndx := InternalAdd(Name); SetVariantByValue(aValue,VValue[ndx]); if dvoInternValues in VOptions then DocVariantType.InternValues.UniqueVariant(VValue[ndx]); end else SetValueOrRaiseException(VariantToIntegerDef(aNameOrIndex,-1),aValue); end; end; function TDocVariantData.AddOrUpdateValue(const aName: RawUTF8; const aValue: variant; wasAdded: PBoolean; OnlyAddMissing: boolean): integer; begin if dvoIsArray in VOptions then raise EDocVariant.CreateUTF8('AddOrUpdateValue("%") on an array',[aName]); result := GetValueIndex(aName); if result<0 then begin result := InternalAdd(aName); if wasAdded<>nil then wasAdded^ := true; end else begin if wasAdded<>nil then wasAdded^ := false; if OnlyAddMissing then exit; end; SetVariantByValue(aValue,VValue[result]); if dvoInternValues in VOptions then DocVariantType.InternValues.UniqueVariant(VValue[result]); end; function TDocVariantData.ToJSON(const Prefix, Suffix: RawUTF8; Format: TTextWriterJSONFormat): RawUTF8; var W: TTextWriter; temp: TTextWriterStackBuffer; begin if (VType<>DocVariantVType) and (VType>varNull) then begin result := ''; // null -> 'null' exit; end; W := DefaultTextWriterJSONClass.CreateOwnedStream(temp); try W.AddString(Prefix); DocVariantType.ToJSON(W,variant(self),twJSONEscape); W.AddString(Suffix); W.SetText(result, Format); finally W.Free; end; end; function TDocVariantData.ToNonExpandedJSON: RawUTF8; var fields: TRawUTF8DynArray; fieldsCount: integer; W: TTextWriter; r,f: integer; row: PDocVariantData; temp: TTextWriterStackBuffer; begin fields := nil; // to please Kylix fieldsCount := 0; if not(dvoIsArray in VOptions) then begin result := ''; exit; end; if VCount=0 then begin result := '[]'; exit; end; with _Safe(VValue[0])^ do if dvoIsObject in VOptions then begin fields := VName; fieldsCount := VCount; end; if fieldsCount=0 then raise EDocVariant.Create('ToNonExpandedJSON: Value[0] is not an object'); W := DefaultTextWriterJSONClass.CreateOwnedStream(temp); try W.Add('{"fieldCount":%,"rowCount":%,"values":[',[fieldsCount,VCount]); for f := 0 to fieldsCount-1 do begin W.Add('"'); W.AddJSONEscape(pointer(fields[f])); W.Add('"',','); end; for r := 0 to VCount-1 do begin row := _Safe(VValue[r]); if (r>0) and (not(dvoIsObject in row^.VOptions) or (row^.VCount<>fieldsCount)) then raise EDocVariant.CreateUTF8('ToNonExpandedJSON: Value[%] not expected object',[r]); for f := 0 to fieldsCount-1 do if (r>0) and not IdemPropNameU(row^.VName[f],fields[f]) then raise EDocVariant.CreateUTF8('ToNonExpandedJSON: Value[%] field=% expected=%', [r,row^.VName[f],fields[f]]) else begin W.AddVariant(row^.VValue[f],twJSONEscape); W.Add(','); end; end; W.CancelLastComma; W.Add(']','}'); W.SetText(result); finally W.Free; end; end; procedure TDocVariantData.ToRawUTF8DynArray(out Result: TRawUTF8DynArray); var ndx: integer; wasString: boolean; begin if dvoIsObject in VOptions then raise EDocVariant.Create('ToRawUTF8DynArray expects a dvArray'); if dvoIsArray in VOptions then begin SetLength(Result,VCount); for ndx := 0 to VCount-1 do VariantToUTF8(VValue[ndx],Result[ndx],wasString); end; end; function TDocVariantData.ToRawUTF8DynArray: TRawUTF8DynArray; begin ToRawUTF8DynArray(result); end; function TDocVariantData.ToCSV(const Separator: RawUTF8): RawUTF8; var tmp: TRawUTF8DynArray; // fast enough in practice begin ToRawUTF8DynArray(tmp); result := RawUTF8ArrayToCSV(tmp,Separator); end; procedure TDocVariantData.ToTextPairsVar(out result: RawUTF8; const NameValueSep, ItemSep: RawUTF8; escape: TTextWriterKind); var ndx: integer; temp: TTextWriterStackBuffer; begin if dvoIsArray in VOptions then raise EDocVariant.Create('ToTextPairs expects a dvObject'); if (VCount>0) and (dvoIsObject in VOptions) then with DefaultTextWriterJSONClass.CreateOwnedStream(temp) do try ndx := 0; repeat AddString(VName[ndx]); AddString(NameValueSep); AddVariant(VValue[ndx],escape); inc(ndx); if ndx=VCount then break; AddString(ItemSep); until false; SetText(result); finally Free; end; end; function TDocVariantData.ToTextPairs(const NameValueSep: RawUTF8; const ItemSep: RawUTF8; Escape: TTextWriterKind): RawUTF8; begin ToTextPairsVar(result,NameValueSep,ItemSep,escape); end; procedure TDocVariantData.ToArrayOfConst(out Result: TTVarRecDynArray); var ndx: integer; begin if dvoIsObject in VOptions then raise EDocVariant.Create('ToArrayOfConst expects a dvArray'); if dvoIsArray in VOptions then begin SetLength(Result,VCount); for ndx := 0 to VCount-1 do begin Result[ndx].VType := vtVariant; Result[ndx].VVariant := @VValue[ndx]; end; end; end; function TDocVariantData.ToArrayOfConst: TTVarRecDynArray; begin ToArrayOfConst(result); end; function TDocVariantData.ToUrlEncode(const UriRoot: RawUTF8): RawUTF8; var json: RawUTF8; begin VariantSaveJSON(variant(self),twJSONEscape,json); result := UrlEncodeJsonObject(UriRoot,Pointer(json),[]); end; function TDocVariantData.GetOrAddIndexByName(const aName: RawUTF8): integer; begin result := GetValueIndex(aName); if result<0 then result := InternalAdd(aName); end; function TDocVariantData.GetOrAddPVariantByName(const aName: RawUTF8): PVariant; var ndx: integer; begin ndx := GetValueIndex(aName); if ndx<0 then ndx := InternalAdd(aName); result := @VValue[ndx]; end; function TDocVariantData.GetPVariantByName(const aName: RawUTF8): PVariant; var ndx: Integer; begin ndx := GetValueIndex(aName); if ndx<0 then if dvoReturnNullForUnknownProperty in VOptions then result := @DocVariantDataFake else raise EDocVariant.CreateUTF8('Unexpected "%" property',[aName]) else result := @VValue[ndx]; end; function TDocVariantData.GetInt64ByName(const aName: RawUTF8): Int64; begin if not VariantToInt64(GetPVariantByName(aName)^,result) then result := 0; end; function TDocVariantData.GetRawUTF8ByName(const aName: RawUTF8): RawUTF8; var wasString: boolean; v: PVariant; begin v := GetPVariantByName(aName); if PVarData(v)^.VType<=varNull then // default VariantToUTF8(null)='null' result := '' else VariantToUTF8(v^,result,wasString); end; function TDocVariantData.GetStringByName(const aName: RawUTF8): string; begin result := VariantToString(GetPVariantByName(aName)^); end; procedure TDocVariantData.SetInt64ByName(const aName: RawUTF8; const aValue: Int64); begin GetOrAddPVariantByName(aName)^ := aValue; end; procedure TDocVariantData.SetRawUTF8ByName(const aName, aValue: RawUTF8); begin RawUTF8ToVariant(aValue,GetOrAddPVariantByName(aName)^); end; procedure TDocVariantData.SetStringByName(const aName: RawUTF8; const aValue: string); begin RawUTF8ToVariant(StringToUTF8(aValue),GetOrAddPVariantByName(aName)^); end; function TDocVariantData.GetBooleanByName(const aName: RawUTF8): Boolean; begin if not VariantToBoolean(GetPVariantByName(aName)^,result) then result := false; end; procedure TDocVariantData.SetBooleanByName(const aName: RawUTF8; aValue: Boolean); begin GetOrAddPVariantByName(aName)^ := aValue; end; function TDocVariantData.GetDoubleByName(const aName: RawUTF8): Double; begin if not VariantToDouble(GetPVariantByName(aName)^,result) then result := 0; end; procedure TDocVariantData.SetDoubleByName(const aName: RawUTF8; const aValue: Double); begin GetOrAddPVariantByName(aName)^ := aValue; end; function TDocVariantData.GetDocVariantExistingByName(const aName: RawUTF8; aNotMatchingKind: TDocVariantKind): PDocVariantData; begin result := GetAsDocVariantSafe(aName); if result^.Kind=aNotMatchingKind then result := @DocVariantDataFake; end; function TDocVariantData.GetDocVariantOrAddByName(const aName: RawUTF8; aKind: TDocVariantKind): PDocVariantData; var ndx: integer; begin ndx := GetOrAddIndexByName(aName); result := _Safe(VValue[ndx]); if result^.Kind<>aKind then begin result := @VValue[ndx]; VarClear(PVariant(result)^); result^.Init(JSON_OPTIONS_FAST,aKind); end; end; function TDocVariantData.GetObjectExistingByName(const aName: RawUTF8): PDocVariantData; begin result := GetDocVariantExistingByName(aName,dvArray); end; function TDocVariantData.GetObjectOrAddByName(const aName: RawUTF8): PDocVariantData; begin result := GetDocVariantOrAddByName(aName,dvObject); end; function TDocVariantData.GetArrayExistingByName(const aName: RawUTF8): PDocVariantData; begin result := GetDocVariantExistingByName(aName,dvObject); end; function TDocVariantData.GetArrayOrAddByName(const aName: RawUTF8): PDocVariantData; begin result := GetDocVariantOrAddByName(aName,dvArray); end; function TDocVariantData.GetAsDocVariantByIndex(aIndex: integer): PDocVariantData; begin if cardinal(aIndex)4) and (Name[0]='_') then begin ndx := IdemPCharArray(@Name[1],['COUNT','KIND','JSON']); if ndx>=0 then begin Execute(ndx,TDocVariantData(V),variant(Dest)); exit; end; end; // 2. case-insensitive search for aVariant.Name TDocVariantData(V).RetrieveValueOrRaiseException( PUTF8Char(Name),NameLen,false,variant(Dest),true); end; procedure TDocVariant.IntSet(const V, Value: TVarData; Name: PAnsiChar); var ndx: Integer; aName: RawUTF8; Data: TDocVariantData absolute V; begin if (dvoIsArray in Data.VOptions) and (PWord(Name)^=ord('_')) then begin ndx := Data.InternalAdd(''); // FPC does not allow VValue[InternalAdd(aName)] SetVariantByValue(variant(Value),Data.VValue[ndx]); if dvoInternValues in Data.VOptions then DocVariantType.InternValues.UniqueVariant(Data.VValue[ndx]); exit; end; FastSetString(aName,Name,StrLen(PUTF8Char(Name))); ndx := Data.GetValueIndex(aName); if ndx<0 then ndx := Data.InternalAdd(aName); SetVariantByValue(variant(Value),Data.VValue[ndx]); if dvoInternValues in Data.VOptions then DocVariantType.InternValues.UniqueVariant(Data.VValue[ndx]); end; function TDocVariant.IterateCount(const V: TVarData): integer; var Data: TDocVariantData absolute V; begin if dvoIsArray in Data.VOptions then result := Data.VCount else result := -1; end; procedure TDocVariant.Iterate(var Dest: TVarData; const V: TVarData; Index: integer); var Data: TDocVariantData absolute V; begin if (dvoIsArray in Data.VOptions) and (cardinal(Index)=0; exit; end else if SameText(Name,'NameIndex') then begin SetTempFromFirstArgument; variant(Dest) := Data^.GetValueIndex(temp); exit; end else if VariantToInteger(variant(Arguments[0]),ndx) then begin if (Name='_') or SameText(Name,'Value') then begin Data^.RetrieveValueOrRaiseException(ndx,variant(Dest),true); exit; end else if SameText(Name,'Name') then begin Data^.RetrieveNameOrRaiseException(ndx,temp); RawUTF8ToVariant(temp,variant(Dest)); exit; end; end else if (Name='_') or SameText(Name,'Value') then begin SetTempFromFirstArgument; Data^.RetrieveValueOrRaiseException(pointer(temp),length(temp), dvoNameCaseSensitive in Data^.VOptions,variant(Dest),true); exit; end; 2:if SameText(Name,'Add') then begin SetTempFromFirstArgument; ndx := Data^.InternalAdd(temp); // FPC does not allow VValue[InternalAdd(aName)] SetVariantByValue(variant(Arguments[1]),Data^.VValue[ndx]); if dvoInternValues in Data^.VOptions then DocVariantType.InternValues.UniqueVariant(Data^.VValue[ndx]); exit; end; end; result := false; end; procedure TDocVariant.ToJSON(W: TTextWriter; const Value: variant; escape: TTextWriterKind); var ndx: integer; backup: TTextWriterOptions; checkExtendedPropName: boolean; begin with TDocVariantData(Value) do if integer(VType)>varNull then if integer(VType)=DocVariantVType then if [dvoIsArray,dvoIsObject]*VOptions=[] then W.AddShort('null') else begin backup := W.fCustomOptions; if [twoForceJSONExtended,twoForceJSONStandard]*backup=[] then if dvoSerializeAsExtendedJson in VOptions then include(W.fCustomOptions,twoForceJSONExtended) else include(W.fCustomOptions,twoForceJSONStandard); if dvoIsObject in VOptions then begin checkExtendedPropName := twoForceJSONExtended in W.CustomOptions; W.Add('{'); for ndx := 0 to VCount-1 do begin if checkExtendedPropName and JsonPropNameValid(pointer(VName[ndx])) then begin W.AddNoJSONEscape(pointer(VName[ndx]),Length(VName[ndx])); end else begin W.Add('"'); W.AddJSONEscape(pointer(VName[ndx]),Length(VName[ndx])); W.Add('"'); end; W.Add(':'); W.AddVariant(VValue[ndx],twJSONEscape); W.Add(','); end; W.CancelLastComma; W.Add('}'); end else begin W.Add('['); for ndx := 0 to VCount-1 do begin W.AddVariant(VValue[ndx],twJSONEscape); W.Add(','); end; W.CancelLastComma; W.Add(']'); end; W.fCustomOptions := backup; end else raise ESynException.CreateUTF8('Unexpected variant type %',[VType]) else W.AddShort('null'); end; procedure TDocVariant.Clear(var V: TVarData); begin //Assert(V.VType=DocVariantVType); VariantDynArrayClear(TDocVariantData(V).VValue); TDocVariantData(V).VName := nil; ZeroFill(@V); // will set V.VType := varEmpty and VCount=0 end; procedure TDocVariant.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); begin //Assert(Source.VType=DocVariantVType); if Indirect then SimplisticCopy(Dest,Source,true) else if dvoValueCopiedByReference in TDocVariantData(Source).Options then begin {$ifndef FPC}if Dest.VType and VTYPE_STATIC<>0 then{$endif} VarClear(variant(Dest)); // Dest may be a complex type pointer(TDocVariantData(Dest).VName) := nil; // avoid GPF pointer(TDocVariantData(Dest).VValue) := nil; TDocVariantData(Dest) := TDocVariantData(Source); // copy whole record end else CopyByValue(Dest,Source); end; procedure TDocVariant.CopyByValue(var Dest: TVarData; const Source: TVarData); var S: TDocVariantData absolute Source; D: TDocVariantData absolute Dest; i: integer; begin //Assert(Source.VType=DocVariantVType); {$ifndef FPC}if Dest.VType and VTYPE_STATIC<>0 then{$endif} VarClear(variant(Dest)); // Dest may be a complex type D.VType := S.VType; D.VOptions := S.VOptions; // copies also Kind D.VCount := S.VCount; pointer(D.VName) := nil; // avoid GPF pointer(D.VValue) := nil; if S.VCount=0 then exit; // no data to copy D.VName := S.VName; // names can always be safely copied // slower but safe by-value copy SetLength(D.VValue,S.VCount); for i := 0 to S.VCount-1 do D.VValue[i] := S.VValue[i]; end; procedure TDocVariant.Cast(var Dest: TVarData; const Source: TVarData); begin CastTo(Dest,Source,VarType); end; procedure TDocVariant.CastTo(var Dest: TVarData; const Source: TVarData; const AVarType: TVarType); var Tmp: RawUTF8; wasString: boolean; begin if AVarType=VarType then begin VariantToUTF8(Variant(Source),Tmp,wasString); if wasString then begin {$ifndef FPC}if Dest.VType and VTYPE_STATIC<>0 then{$endif} VarClear(variant(Dest)); variant(Dest) := _JSONFast(Tmp); // convert from JSON text exit; end; RaiseCastError; end else begin if Source.VType<>VarType then RaiseCastError; VariantSaveJSON(variant(Source),twJSONEscape,tmp); RawUTF8ToVariant(Tmp,Dest,AVarType); // convert to JSON text end; end; procedure TDocVariant.Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult); var res: integer; LeftU,RightU: RawUTF8; begin VariantSaveJSON(variant(Left),twJSONEscape,LeftU); VariantSaveJSON(variant(Right),twJSONEscape,RightU); if LeftU=RightU then Relationship := crEqual else begin res := StrComp(pointer(LeftU),pointer(RightU)); if res<0 then Relationship := crLessThan else if res>0 then Relationship := crGreaterThan else Relationship := crEqual; end; end; class procedure TDocVariant.New(out aValue: variant; aOptions: TDocVariantOptions); begin TDocVariantData(aValue).Init(aOptions); end; class procedure TDocVariant.NewFast(out aValue: variant); begin TDocVariantData(aValue).InitFast; end; class procedure TDocVariant.IsOfTypeOrNewFast(var aValue: variant); begin if DocVariantType.IsOfType(aValue) then exit; VarClear(aValue); TDocVariantData(aValue).InitFast; end; class procedure TDocVariant.NewFast(const aValues: array of PDocVariantData); var i: integer; begin for i := 0 to high(aValues) do aValues[i]^.InitFast; end; class function TDocVariant.New(Options: TDocVariantOptions): Variant; begin {$ifndef FPC}if TVarData(result).VType and VTYPE_STATIC<>0 then{$endif} VarClear(result); TDocVariantData(result).Init(Options); end; class function TDocVariant.NewObject(const NameValuePairs: array of const; Options: TDocVariantOptions=[]): variant; begin {$ifndef FPC}if TVarData(result).VType and VTYPE_STATIC<>0 then{$endif} VarClear(result); TDocVariantData(result).InitObject(NameValuePairs,Options); end; class function TDocVariant.NewArray(const Items: array of const; Options: TDocVariantOptions=[]): variant; begin {$ifndef FPC}if TVarData(result).VType and VTYPE_STATIC<>0 then{$endif} VarClear(result); TDocVariantData(result).InitArray(Items,Options); end; class function TDocVariant.NewArray(const Items: TVariantDynArray; Options: TDocVariantOptions=[]): variant; begin {$ifndef FPC}if TVarData(result).VType and VTYPE_STATIC<>0 then{$endif} VarClear(result); TDocVariantData(result).InitArrayFromVariants(Items,Options); end; class function TDocVariant.NewJSON(const JSON: RawUTF8; Options: TDocVariantOptions): variant; begin _Json(JSON,result,Options); end; class function TDocVariant.NewUnique(const SourceDocVariant: variant; Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; begin {$ifndef FPC}if TVarData(result).VType and VTYPE_STATIC<>0 then{$endif} VarClear(result); TDocVariantData(result).InitCopy(SourceDocVariant,Options); end; class procedure TDocVariant.GetSingleOrDefault(const docVariantArray, default: variant; var result: variant); begin if TVarData(DocVariantArray).VType=varByRef or varVariant then GetSingleOrDefault(PVariant(TVarData(DocVariantArray).VPointer)^,default,result) else if (TVarData(DocVariantArray).VType<>DocVariantVType) or (TDocVariantData(DocVariantArray).Count<>1) or not(dvoIsArray in TDocVariantData(DocVariantArray).VOptions) then result := default else result := TDocVariantData(DocVariantArray).Values[0]; end; function ToText(kind: TDocVariantKind): PShortString; begin result := GetEnumName(TypeInfo(TDocVariantKind),ord(kind)); end; function _Obj(const NameValuePairs: array of const; Options: TDocVariantOptions=[]): variant; begin {$ifndef FPC}if TVarData(result).VType and VTYPE_STATIC<>0 then{$endif} VarClear(result); TDocVariantData(result).InitObject(NameValuePairs,Options); end; function _Arr(const Items: array of const; Options: TDocVariantOptions=[]): variant; begin {$ifndef FPC}if TVarData(result).VType and VTYPE_STATIC<>0 then{$endif} VarClear(result); TDocVariantData(result).InitArray(Items,Options); end; procedure _ObjAddProps(const NameValuePairs: array of const; var Obj: variant); var o: PDocVariantData; begin o := _Safe(Obj); if not(dvoIsObject in o^.VOptions) then begin // create new object {$ifndef FPC}if TVarData(Obj).VType and VTYPE_STATIC<>0 then{$endif} VarClear(Obj); TDocVariantData(Obj).InitObject(NameValuePairs,JSON_OPTIONS_FAST); end else begin // append new names/values to existing object TVarData(Obj) := PVarData(o)^; // ensure not stored by reference o^.AddNameValuesToObject(NameValuePairs); end; end; procedure _ObjAddProps(const Document: variant; var Obj: variant); var ndx: integer; d,o: PDocVariantData; begin d := _Safe(Document); o := _Safe(Obj); if dvoIsObject in d.VOptions then if not(dvoIsObject in o.VOptions) then Obj := Document else for ndx := 0 to d^.VCount-1 do o^.AddOrUpdateValue(d^.VName[ndx],d^.VValue[ndx]); end; function _ObjFast(const NameValuePairs: array of const): variant; begin {$ifndef FPC}if TVarData(result).VType and VTYPE_STATIC<>0 then{$endif} VarClear(result); TDocVariantData(result).InitObject(NameValuePairs,JSON_OPTIONS_FAST); end; function _ObjFast(aObject: TObject; aOptions: TTextWriterWriteObjectOptions): variant; begin {$ifndef FPC}if TVarData(result).VType and VTYPE_STATIC<>0 then{$endif} VarClear(result); if TDocVariantData(result).InitJSONInPlace( pointer(ObjectToJson(aObject,aOptions)),JSON_OPTIONS_FAST)=nil then VarClear(result); end; function _ArrFast(const Items: array of const): variant; begin {$ifndef FPC}if TVarData(result).VType and VTYPE_STATIC<>0 then{$endif} VarClear(result); TDocVariantData(result).InitArray(Items,JSON_OPTIONS_FAST); end; function _Json(const JSON: RawUTF8; Options: TDocVariantOptions): variant; begin _Json(JSON,result,Options); end; function _JsonFast(const JSON: RawUTF8): variant; begin _Json(JSON,result,JSON_OPTIONS_FAST); end; function _JsonFastExt(const JSON: RawUTF8): variant; begin _Json(JSON,result,JSON_OPTIONS_FAST_EXTENDED); end; function _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; Options: TDocVariantOptions): variant; begin _JsonFmt(Format,Args,Params,Options,result); end; procedure _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; Options: TDocVariantOptions; out result: variant); var temp: RawUTF8; begin temp := FormatUTF8(Format,Args,Params,true); if TDocVariantData(result).InitJSONInPlace(pointer(temp),Options)=nil then TDocVariantData(result).Clear; end; function _JsonFastFmt(const Format: RawUTF8; const Args,Params: array of const): variant; begin _JsonFmt(Format,Args,Params,JSON_OPTIONS_FAST,result); end; function _Json(const JSON: RawUTF8; var Value: variant; Options: TDocVariantOptions): boolean; begin {$ifndef FPC}if TVarData(Value).VType and VTYPE_STATIC<>0 then{$endif} VarClear(Value); if not TDocVariantData(Value).InitJSON(JSON,Options) then begin VarClear(Value); result := false; end else result := true; end; procedure _Unique(var DocVariant: variant); begin // TDocVariantData(DocVariant): InitCopy() will check the DocVariant type TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[false]); end; procedure _UniqueFast(var DocVariant: variant); begin // TDocVariantData(DocVariant): InitCopy() will check the DocVariant type TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS_FAST); end; function _Copy(const DocVariant: variant): variant; begin result := TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[false]); end; function _CopyFast(const DocVariant: variant): variant; begin result := TDocVariant.NewUnique(DocVariant,JSON_OPTIONS_FAST); end; function _ByRef(const DocVariant: variant; Options: TDocVariantOptions): variant; begin {$ifndef FPC}if TVarData(result).VType and VTYPE_STATIC<>0 then{$endif} VarClear(result); TDocVariantData(result) := _Safe(DocVariant)^; // fast byref copy TDocVariantData(result).SetOptions(Options); end; procedure _ByRef(const DocVariant: variant; out Dest: variant; Options: TDocVariantOptions); begin TDocVariantData(Dest) := _Safe(DocVariant)^; // fast byref copy TDocVariantData(Dest).SetOptions(Options); end; function ObjectToVariant(Value: TObject; EnumSetsAsText: boolean): variant; const OPTIONS: array[boolean] of TTextWriterWriteObjectOptions = ( [woDontStoreDefault],[woDontStoreDefault,woEnumSetsAsText]); begin VarClear(result); ObjectToVariant(Value,result,OPTIONS[EnumSetsAsText]); end; procedure ObjectToVariant(Value: TObject; out Dest: variant); begin ObjectToVariant(Value,Dest,[woDontStoreDefault]); end; procedure ObjectToVariant(Value: TObject; var result: variant; Options: TTextWriterWriteObjectOptions); var json: RawUTF8; begin json := ObjectToJSON(Value,Options); PDocVariantData(@result)^.InitJSONInPlace(pointer(json),JSON_OPTIONS_FAST); end; {$endif NOVARIANTS} { ****************** TDynArray wrapper } {$ifndef DELPHI5OROLDER} // do not know why Delphi 5 compiler does not like CopyFrom() procedure DynArrayCopy(var Dest; const Source; SourceMaxElem: integer; TypeInfo: pointer); var DestDynArray: TDynArray; begin DestDynArray.Init(TypeInfo,Dest); DestDynArray.CopyFrom(Source,SourceMaxElem); end; {$endif DELPHI5OROLDER} function DynArrayLoad(var Value; Source: PAnsiChar; TypeInfo: pointer): PAnsiChar; var DynArray: TDynArray; begin DynArray.Init(TypeInfo,Value); result := DynArray.LoadFrom(Source); end; function DynArraySave(var Value; TypeInfo: pointer): RawByteString; var DynArray: TDynArray; begin DynArray.Init(TypeInfo,Value); result := DynArray.SaveTo; end; function DynArrayLoadJSON(var Value; JSON: PUTF8Char; TypeInfo: pointer; EndOfObject: PUTF8Char=nil): PUTF8Char; var DynArray: TDynArray; begin DynArray.Init(TypeInfo,Value); result := DynArray.LoadFromJSON(JSON,EndOfObject); end; function DynArraySaveJSON(const Value; TypeInfo: pointer; EnumSetsAsText: boolean): RawUTF8; begin result := SaveJSON(Value,TypeInfo,EnumSetsAsText); end; {$ifndef DELPHI5OROLDER} function DynArrayEquals(TypeInfo: pointer; var Array1, Array2; Array1Count, Array2Count: PInteger): boolean; var DA1, DA2: TDynArray; begin DA1.Init(TypeInfo,Array1,Array1Count); DA2.Init(TypeInfo,Array2,Array2Count); result := DA1.Equals(DA2); end; {$endif DELPHI5OROLDER} function DynArrayBlobSaveJSON(TypeInfo, BlobValue: pointer): RawUTF8; var DynArray: TDynArray; Value: pointer; // store the temporary dynamic array temp: TTextWriterStackBuffer; begin Value := nil; DynArray.Init(TypeInfo,Value); try if DynArray.LoadFrom(BlobValue)=nil then result := '' else begin with DefaultTextWriterJSONClass.CreateOwnedStream(temp) do try AddDynArrayJSON(TypeInfo,Value); SetText(result); finally Free; end; end; finally DynArray.Clear; end; end; function DynArrayElementTypeName(TypeInfo: pointer; ElemTypeInfo: PPointer; ExactType: boolean): RawUTF8; var DynArray: TDynArray; VoidArray: pointer; const KNOWNTYPE_ITEMNAME: array[TDynArrayKind] of RawUTF8 = ('', 'boolean','byte','word','integer','cardinal','single','Int64','QWord', 'double','currency','TTimeLog','TDateTime','TDateTimeMS', 'RawUTF8','WinAnsiString','string','RawByteString','WideString','SynUnicode', 'THash128','THash256','THash512','IInterface',{$ifndef NOVARIANTS}'variant',{$endif}''); begin VoidArray := nil; DynArray.Init(TypeInfo,VoidArray); result := ''; if ElemTypeInfo<>nil then ElemTypeInfo^ := DynArray.ElemType; if DynArray.ElemType<>nil then TypeInfoToName(ElemTypeInfo,result) else result := KNOWNTYPE_ITEMNAME[DynArray.ToKnownType(ExactType)]; end; function SortDynArrayBoolean(const A,B): integer; begin if boolean(A)=boolean(B) then result := 0 else if boolean(A) then result := 1 else result := -1; end; function SortDynArrayByte(const A,B): integer; begin result := byte(A)-byte(B); end; function SortDynArraySmallint(const A,B): integer; begin result := smallint(A)-smallint(B); end; function SortDynArrayShortint(const A,B): integer; begin result := shortint(A)-shortint(B); end; function SortDynArrayWord(const A,B): integer; begin result := word(A)-word(B); end; function SortDynArrayCardinal(const A,B): integer; begin if cardinal(A)cardinal(B) then result := 1 else result := 0; end; function SortDynArrayPointer(const A,B): integer; begin {$ifdef CPU64} if PtrInt(A)PtrInt(B) then result := 1 else result := 0; {$else} result := PtrInt(A)-PtrInt(B); {$endif} end; function SortDynArraySingle(const A,B): integer; begin if Single(A)Single(B) then result := 1 else result := 0; end; function SortDynArrayDouble(const A,B): integer; begin if Double(A)Double(B) then result := 1 else result := 0; end; function SortDynArrayPUTF8CharI(const A,B): integer; begin result := StrIComp(PUTF8Char(A),PUTF8Char(B)); end; function SortDynArrayString(const A,B): integer; begin {$ifdef UNICODE} result := StrCompW(PWideChar(A),PWideChar(B)); {$else} result := StrComp(PUTF8Char(A),PUTF8Char(B)); {$endif} end; function SortDynArrayStringI(const A,B): integer; begin {$ifdef UNICODE} result := AnsiICompW(PWideChar(A),PWideChar(B)); {$else} result := StrIComp(PUTF8Char(A),PUTF8Char(B)); {$endif} end; function SortDynArrayFileName(const A,B): integer; var Aname, Aext, Bname, Bext: TFileName; begin // code below is not very fast, but is correct ;) AName := GetFileNameWithoutExt(string(A),@Aext); BName := GetFileNameWithoutExt(string(B),@Bext); result := AnsiCompareFileName(Aext,Bext); if result=0 then // if both extensions matches, compare by filename result := AnsiCompareFileName(Aname,Bname); end; function SortDynArrayUnicodeString(const A,B): integer; begin result := StrCompW(PWideChar(A),PWideChar(B)); end; function SortDynArrayUnicodeStringI(const A,B): integer; begin result := AnsiICompW(PWideChar(A),PWideChar(B)); end; function SortDynArray128(const A,B): integer; begin if THash128Rec(A).LoTHash128Rec(B).Lo then result := 1 else if THash128Rec(A).HiTHash128Rec(B).Hi then result := 1 else result := 0; end; function SortDynArray256(const A,B): integer; begin result := SortDynArray128(THash256Rec(A).Lo,THash256Rec(B).Lo); if result = 0 then result := SortDynArray128(THash256Rec(A).Hi,THash256Rec(B).Hi); end; function SortDynArray512(const A,B): integer; begin result := SortDynArray128(THash512Rec(A).c0,THash512Rec(B).c0); if result = 0 then begin result := SortDynArray128(THash512Rec(A).c1,THash512Rec(B).c1); if result = 0 then begin result := SortDynArray128(THash512Rec(A).c2,THash512Rec(B).c2); if result = 0 then result := SortDynArray128(THash512Rec(A).c3,THash512Rec(B).c3); end; end; end; {$ifndef NOVARIANTS} function VariantCompare(const V1,V2: variant): PtrInt; begin result := SortDynArrayVariantComp(TVarData(V1), TVarData(V2), false); end; function VariantCompareI(const V1,V2: variant): PtrInt; begin result := SortDynArrayVariantComp(TVarData(V1), TVarData(V2), true); end; function SortDynArrayVariantCompareAsString(const A,B: variant): integer; var UA,UB: RawUTF8; wasString: boolean; begin VariantToUTF8(A,UA,wasString); VariantToUTF8(B,UB,wasString); result := StrComp(pointer(UA),pointer(UB)); end; function SortDynArrayVariantCompareAsStringI(const A,B: variant): integer; var UA,UB: RawUTF8; wasString: boolean; begin VariantToUTF8(A,UA,wasString); VariantToUTF8(B,UB,wasString); result := StrIComp(pointer(UA),pointer(UB)); end; function SortDynArrayZero(const A,B): integer; begin result := 0; end; function SortDynArrayVariantComp(const A,B: TVarData; caseInsensitive: boolean): integer; type TSortDynArrayVariantComp = function(const A,B: variant): integer; const CMP: array[boolean] of TSortDynArrayVariantComp = ( SortDynArrayVariantCompareAsString,SortDynArrayVariantCompareAsStringI); ICMP: array[TVariantRelationship] of integer = (0,-1,1,1); SORT1: array[varEmpty..varDate] of TDynArraySortCompare = ( SortDynArrayZero, SortDynArrayZero, SortDynArraySmallInt, SortDynArrayInteger, SortDynArraySingle, SortDynArrayDouble, SortDynArrayInt64, SortDynArrayDouble); SORT2: array[varShortInt..varWord64] of TDynArraySortCompare = ( SortDynArrayShortInt, SortDynArrayByte, SortDynArrayWord, SortDynArrayCardinal, SortDynArrayInt64, SortDynArrayQWord); begin if A.VType=varVariant or varByRef then result := SortDynArrayVariantComp(PVarData(A.VPointer)^,B,caseInsensitive) else if B.VType=varVariant or varByRef then result := SortDynArrayVariantComp(A,PVarData(B.VPointer)^,caseInsensitive) else if A.VType=B.VType then case A.VType of // optimized value comparison if A and B share the same type low(SORT1)..high(SORT1): result := SORT1[A.VType](A.VAny,B.VAny); low(SORT2)..high(SORT2): result := SORT2[A.VType](A.VAny,B.VAny); varString: // RawUTF8 most of the time (e.g. from TDocVariant) if caseInsensitive then result := StrIComp(A.VAny,B.VAny) else result := StrComp(A.VAny,B.VAny); varBoolean: if A.VBoolean then // normalize if B.VBoolean then result := 0 else result := 1 else if B.VBoolean then result := -1 else result := 0; varOleStr{$ifdef HASVARUSTRING},varUString{$endif}: if caseInsensitive then result := AnsiICompW(A.VAny,B.VAny) else result := StrCompW(A.VAny,B.VAny); else if A.VType and VTYPE_STATIC=0 then result := ICMP[VarCompareValue(variant(A),variant(B))] else result := CMP[caseInsensitive](variant(A),variant(B)); end else if (A.VType<=varNull) or (B.VType<=varNull) then result := ord(A.VType>varNull)-ord(B.VType>varNull) else if (A.VType and VTYPE_STATIC=0) and (B.VType and VTYPE_STATIC=0) then result := ICMP[VarCompareValue(variant(A),variant(B))] else result := CMP[caseInsensitive](variant(A),variant(B)); end; function SortDynArrayVariant(const A,B): integer; begin result := SortDynArrayVariantComp(TVarData(A),TVarData(B),false); end; function SortDynArrayVariantI(const A,B): integer; begin result := SortDynArrayVariantComp(TVarData(A),TVarData(B),true); end; {$endif NOVARIANTS} { TDynArray } function TDynArray.GetCount: integer; var v: PtrUInt; begin v := PtrUInt(fCountP); if v<>0 then begin result := PInteger(v)^; exit; end else begin v := PtrUInt(fValue); if v<>0 then begin v := PPtrUInt(v)^; if v<>0 then begin {$ifdef FPC} result := PDynArrayRec(v-SizeOf(TDynArrayRec))^.high+1; {$else} result := PInteger(v-SizeOf(PtrInt))^; {$endif} exit; end; end; result := 0; // avoid GPF if void exit; end; end; procedure TDynArray.ElemCopy(const A; var B); begin if ElemType=nil then {$ifdef FPC}Move{$else}MoveFast{$endif}(A,B,ElemSize) else begin {$ifdef FPC} {$ifdef FPC_OLDRTTI} FPCFinalize(@B,ElemType); // inlined CopyArray() Move(A,B,ElemSize); FPCRecordAddRef(B,ElemType); {$else} FPCRecordCopy(A,B,ElemType); // works for any kind of ElemTyp {$endif FPC_OLDRTTI} {$else} CopyArray(@B,@A,ElemType,1); {$endif FPC} end; end; function TDynArray.Add(const Elem): PtrInt; var p: PtrUInt; begin result := GetCount; if fValue=nil then exit; // avoid GPF if void SetCount(result+1); p := PtrUInt(fValue^)+PtrUInt(result)*ElemSize; if ElemType=nil then {$ifdef FPC}Move{$else}MoveFast{$endif}(Elem,pointer(p)^,ElemSize) else {$ifdef FPC} FPCRecordCopy(Elem,pointer(p)^,ElemType); {$else} CopyArray(pointer(p),@Elem,ElemType,1); {$endif} end; function TDynArray.New: integer; begin result := GetCount; if fValue=nil then exit; // avoid GPF if void SetCount(result+1); end; function TDynArray.Peek(var Dest): boolean; var index: PtrInt; begin index := GetCount-1; result := index>=0; if result then ElemCopy(pointer(PtrUInt(fValue^)+PtrUInt(index)*ElemSize)^,Dest); end; function TDynArray.Pop(var Dest): boolean; var index: integer; begin index := GetCount-1; result := index>=0; if result then begin ElemMoveTo(index,Dest); SetCount(index); end; end; procedure TDynArray.Insert(Index: PtrInt; const Elem); var n: PtrInt; P: PByteArray; begin if fValue=nil then exit; // avoid GPF if void n := GetCount; SetCount(n+1); if PtrUInt(Index)nil then // avoid GPF in ElemCopy() below {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(P^,ElemSize,0); end else // Index>=Count -> add at the end P := pointer(PtrUInt(fValue^)+PtrUInt(n)*ElemSize); ElemCopy(Elem,P^); end; procedure TDynArray.Clear; begin SetCount(0); end; function TDynArray.ClearSafe: boolean; begin try SetCount(0); result := true; except // weak code, but may be a good idea in a destructor result := false; end; end; function TDynArray.GetIsObjArray: boolean; var o: TDynArrayObjArray; // oaUnknown, oaFalse, oaTrue begin o := fIsObjArray; // oaUnknown, oaFalse, oaTrue if o=oaUnknown then result := ComputeIsObjArray else result := o<>oaFalse; end; procedure TDynArray.Delete(aIndex: PtrInt); var n, len: PtrInt; P: PAnsiChar; begin if fValue=nil then exit; // avoid GPF if void n := GetCount; if PtrUInt(aIndex)>=PtrUInt(n) then exit; // out of range dec(n); P := pointer(PtrUInt(fValue^)+PtrUInt(aIndex)*ElemSize); if ElemType<>nil then {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(P,ElemType) else if (fIsObjArray=oaTrue) or ((fIsObjArray=oaUnknown) and ComputeIsObjArray) then FreeAndNil(PObject(P)^); if n>aIndex then begin len := PtrUInt(n-aIndex)*ElemSize; {$ifdef FPC}Move{$else}MoveFast{$endif}(P[ElemSize],P[0],len); {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(P[len],ElemSize,0); end else {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(P^,ElemSize,0); SetCount(n); end; function TDynArray.ElemPtr(index: PtrInt): pointer; label ok; var c: PtrUInt; begin // very efficient code on FPC and modern Delphi result := pointer(fValue); if result=nil then exit; result := PPointer(result)^; if result=nil then exit; c := PtrUInt(fCountP); if c<>0 then begin if PtrUInt(index)nil then if ElemType=nil then {$ifdef FPC}Move{$else}MoveFast{$endif}(p^,Dest,ElemSize) else {$ifdef FPC} FPCRecordCopy(p^,Dest,ElemType); // works for any kind of ElemTyp {$else} CopyArray(@Dest,p,ElemType,1); {$endif} end; procedure TDynArray.ElemMoveTo(index: PtrInt; var Dest); var p: pointer; begin p := ElemPtr(index); if (p=nil) or (@Dest=nil) then exit; ElemClear(Dest); {$ifdef FPC}Move{$else}MoveFast{$endif}(p^,Dest,ElemSize); {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(p^,ElemSize,0); // ElemType=nil for ObjArray end; procedure TDynArray.ElemCopyFrom(const Source; index: PtrInt; ClearBeforeCopy: boolean); var p: pointer; begin p := ElemPtr(index); if p<>nil then if ElemType=nil then {$ifdef FPC}Move{$else}MoveFast{$endif}(Source,p^,ElemSize) else begin if ClearBeforeCopy then // safer if Source is a copy of p^ {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(p,ElemType); {$ifdef FPC} FPCRecordCopy(Source,p^,ElemType); {$else} CopyArray(p,@Source,ElemType,1); {$endif} end; end; procedure TDynArray.Reverse; var siz, n, tmp: integer; P1, P2: PAnsiChar; c: AnsiChar; i64: Int64; begin n := GetCount-1; if n>0 then begin siz := ElemSize; P1 := fValue^; case siz of 1: begin // optimized version for TByteDynArray and such P2 := P1+n; while P1MemStream.Size then MemStream.Size := PosiEnd; if SaveTo(PAnsiChar(MemStream.Memory)+Posi)-MemStream.Memory<>PosiEnd then raise EStreamError.Create('TDynArray.SaveToStream: SaveTo'); MemStream.Seek(PosiEnd,soBeginning); end else begin tmp := SaveTo; if Stream.Write(pointer(tmp)^,length(tmp))<>length(tmp) then raise EStreamError.Create('TDynArray.SaveToStream: Write error'); end; end; procedure TDynArray.LoadFromStream(Stream: TCustomMemoryStream); var P: PAnsiChar; begin P := PAnsiChar(Stream.Memory)+Stream.Seek(0,soFromCurrent); Stream.Seek(LoadFrom(P)-P,soCurrent); end; function TDynArray.SaveToTypeInfoHash(crc: cardinal): cardinal; begin if ElemType=nil then // hash fElemSize only if no pointer within result := crc32c(crc,@fElemSize,4) else begin result := crc; ManagedTypeSaveRTTIHash(ElemType,result); end; end; function TDynArray.SaveTo(Dest: PAnsiChar): PAnsiChar; var i, n, LenBytes: integer; P: PAnsiChar; begin if fValue=nil then begin result := Dest; exit; // avoid GPF if void end; // first store the element size+type to check for the format (name='' mostly) Dest := PAnsiChar(ToVarUInt32(ElemSize,pointer(Dest))); if ElemType=nil then Dest^ := #0 else {$ifdef FPC} Dest^ := AnsiChar(FPCTODELPHI[PTypeKind(ElemType)^]); {$else} Dest^ := PAnsiChar(ElemType)^; {$endif} inc(Dest); // then store dynamic array count n := GetCount; Dest := PAnsiChar(ToVarUInt32(n,pointer(Dest))); if n=0 then begin result := Dest; exit; end; inc(Dest,SizeOf(Cardinal)); // leave space for Hash32 checksum result := Dest; // store dynamic array elements content P := fValue^; if ElemType=nil then // FPC: nil also if not Kind in tkManagedTypes if GetIsObjArray then raise ESynException.CreateUTF8('TDynArray.SaveTo(%) is a T*ObjArray', [ArrayTypeShort^]) else begin // binary types: store as once n := n*integer(ElemSize); {$ifdef FPC}Move{$else}MoveFast{$endif}(P^,Dest^,n); inc(Dest,n); end else case PTypeKind(ElemType)^ of tkRecord{$ifdef FPC},tkObject{$endif}: for i := 1 to n do begin Dest := RecordSave(P^,Dest,ElemType,LenBytes); inc(P,LenBytes); end; else for i := 1 to n do begin Dest := ManagedTypeSave(P,Dest,ElemType,LenBytes); if Dest=nil then break; inc(P,LenBytes); end; end; // store Hash32 checksum if Dest<>nil then // may be nil if RecordSave/ManagedTypeSave failed PCardinal(result-SizeOf(Cardinal))^ := Hash32(pointer(result),Dest-result); result := Dest; end; function TDynArray.SaveToLength: integer; var i,n,L,size: integer; P: PAnsiChar; begin if fValue=nil then begin result := 0; exit; // avoid GPF if void end; n := GetCount; result := ToVarUInt32Length(ElemSize)+ToVarUInt32Length(n)+1; if n=0 then exit; if ElemType=nil then // FPC: nil also if not Kind in tkManagedTypes if GetIsObjArray then raise ESynException.CreateUTF8('TDynArray.SaveToLength(%) is a T*ObjArray', [ArrayTypeShort^]) else inc(result,integer(ElemSize)*n) else begin P := fValue^; case PTypeKind(ElemType)^ of // inlined the most used kind of items tkLString,tkWString{$ifdef FPC},tkLStringOld{$endif}: for i := 1 to n do begin if PPtrUInt(P)^=0 then inc(result) else inc(result,ToVarUInt32LengthWithData(PStrRec(PPtrUInt(P)^-STRRECSIZE)^.length)); inc(P,SizeOf(pointer)); end; tkRecord{$ifdef FPC},tkObject{$endif}: for i := 1 to n do begin inc(result,RecordSaveLength(P^,ElemType)); inc(P,ElemSize); end; else for i := 1 to n do begin L := ManagedTypeSaveLength(P,ElemType,size); if L=0 then break; // invalid record type (wrong field type) inc(result,L); inc(P,size); end; end; end; inc(result,SizeOf(Cardinal)); // Hash32 checksum end; function TDynArray.SaveTo: RawByteString; var Len: integer; begin Len := SaveToLength; SetString(result,nil,Len); if Len<>0 then if SaveTo(pointer(result))-pointer(result)<>Len then raise ESynException.Create('TDynArray.SaveTo len concern'); end; function TDynArray.SaveToJSON(EnumSetsAsText: boolean; reformat: TTextWriterJSONFormat): RawUTF8; begin SaveToJSON(result,EnumSetsAsText,reformat); end; procedure TDynArray.SaveToJSON(out Result: RawUTF8; EnumSetsAsText: boolean; reformat: TTextWriterJSONFormat); var temp: TTextWriterStackBuffer; begin with DefaultTextWriterJSONClass.CreateOwnedStream(temp) do try if EnumSetsAsText then CustomOptions := CustomOptions+[twoEnumSetsAsTextInRecord]; AddDynArrayJSON(self); SetText(result,reformat); finally Free; end; end; const PTRSIZ = SizeOf(Pointer); KNOWNTYPE_SIZE: array[TDynArrayKind] of byte = ( 0, 1,1, 2, 4,4,4, 8,8,8,8,8,8,8, PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ, 16,32,64, PTRSIZ, {$ifndef NOVARIANTS}SizeOf(Variant),{$endif} 0); DYNARRAY_PARSERUNKNOWN = -2; var KINDTYPE_INFO: array[TDynArrayKind] of pointer; function TDynArray.GetArrayTypeName: RawUTF8; begin TypeInfoToName(fTypeInfo,result); end; function TDynArray.GetArrayTypeShort: PShortString; begin if fTypeInfo=nil then result := @NULCHAR else result := PShortString(@PTypeInfo(fTypeInfo).NameLen); end; function TDynArray.ToKnownType(exactType: boolean): TDynArrayKind; var nested: PTypeInfo; field: PFieldInfo; label Bin, Rec; begin result := fKnownType; if result<>djNone then exit; case ElemSize of 1: if fTypeInfo=TypeInfo(TBooleanDynArray) then result := djBoolean; 4: if fTypeInfo=TypeInfo(TCardinalDynArray) then result := djCardinal else if fTypeInfo=TypeInfo(TSingleDynArray) then result := djSingle {$ifdef CPU64} ; 8: {$else} else {$endif} if fTypeInfo=TypeInfo(TRawUTF8DynArray) then result := djRawUTF8 else if fTypeInfo=TypeInfo(TStringDynArray) then result := djString else if fTypeInfo=TypeInfo(TWinAnsiDynArray) then result := djWinAnsi else if fTypeInfo=TypeInfo(TRawByteStringDynArray) then result := djRawByteString else if fTypeInfo=TypeInfo(TSynUnicodeDynArray) then result := djSynUnicode else if (fTypeInfo=TypeInfo(TClassDynArray)) or (fTypeInfo=TypeInfo(TPointerDynArray)) then result := djPointer else {$ifndef DELPHI5OROLDER} if fTypeInfo=TypeInfo(TInterfaceDynArray) then result := djInterface {$endif DELPHI5OROLDER} {$ifdef CPU64} else {$else} ; 8: {$endif} if fTypeInfo=TypeInfo(TDoubleDynArray) then result := djDouble else if fTypeInfo=TypeInfo(TCurrencyDynArray) then result := djCurrency else if fTypeInfo=TypeInfo(TTimeLogDynArray) then result := djTimeLog else if fTypeInfo=TypeInfo(TDateTimeDynArray) then result := djDateTime else if fTypeInfo=TypeInfo(TDateTimeMSDynArray) then result := djDateTimeMS; end; if result=djNone then begin fKnownSize := 0; if ElemType=nil then Bin: case ElemSize of 1: result := djByte; 2: result := djWord; 4: result := djInteger; 8: result := djInt64; 16: result := djHash128; 32: result := djHash256; 64: result := djHash512; else fKnownSize := ElemSize; end else case PTypeKind(ElemType)^ of tkLString{$ifdef FPC},tkLStringOld{$endif}: result := djRawUTF8; tkWString: result := djWideString; {$ifdef UNICODE} tkUString: result := djString; {$else} {$ifdef FPC_HAS_FEATURE_UNICODESTRINGS} tkUString: result := djSynUnicode; {$endif FPC_HAS_FEATURE_UNICODESTRINGS} {$endif} {$ifndef NOVARIANTS} tkVariant: result := djVariant; {$endif} tkInterface: result := djInterface; tkRecord{$ifdef FPC},tkObject{$endif}: if not exacttype then begin nested := ElemType; // inlined GetTypeInfo() {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} rec: nested := GetFPCAlignPtr(nested); {$else} rec: inc(PByte(nested),nested^.NameLen); {$endif} {$ifdef FPC_OLDRTTI} field := OldRTTIFirstManagedField(nested); if field=nil then {$else FPC_OLDRTTI} if GetManagedFields(nested,field)=0 then // only binary content {$endif FPC_OLDRTTI} goto Bin; case field^.Offset of 0: case DeRef(field^.TypeInfo)^.Kind of tkLString{$ifdef FPC},tkLStringOld{$endif}: result := djRawUTF8; tkWString: result := djWideString; {$ifdef UNICODE} tkUString: result := djString; {$else} {$ifdef FPC_HAS_FEATURE_UNICODESTRINGS} tkUString: result := djSynUnicode; {$endif FPC_HAS_FEATURE_UNICODESTRINGS} {$endif} tkRecord{$ifdef FPC},tkObject{$endif}: begin nested := DeRef(field^.TypeInfo); goto Rec; end; {$ifndef NOVARIANTS} tkVariant: result := djVariant; {$endif} else goto bin; end; 1: result := djByte; 2: result := djWord; 4: result := djInteger; 8: result := djInt64; 16: result := djHash128; 32: result := djHash256; 64: result := djHash512; else fKnownSize := field^.Offset; end; end; end; end; if KNOWNTYPE_SIZE[result]<>0 then fKnownSize := KNOWNTYPE_SIZE[result]; fKnownType := result; end; function TDynArray.ElemCopyFirstField(Source,Dest: Pointer): boolean; begin if fKnownType=djNone then ToKnownType(false); case fKnownType of djBoolean..djDateTimeMS,djHash128..djHash512: // no managed field {$ifdef FPC}Move{$else}MoveFast{$endif}(Source^,Dest^,fKnownSize); djRawUTF8, djWinAnsi, djRawByteString: PRawByteString(Dest)^ := PRawByteString(Source)^; djSynUnicode: PSynUnicode(Dest)^ := PSynUnicode(Source)^; djString: PString(Dest)^ := PString(Source)^; djWideString: PWideString(Dest)^ := PWideString(Source)^; {$ifndef NOVARIANTS}djVariant: PVariant(Dest)^ := PVariant(Source)^;{$endif} else begin // djNone, djInterface, djCustom result := false; exit; end; end; result := true; end; function TDynArray.LoadKnownType(Data,Source: PAnsiChar): boolean; var info: PTypeInfo; begin if fKnownType=djNone then ToKnownType({exacttype=}false); // set fKnownType and fKnownSize if fKnownType in [djBoolean..djDateTimeMS] then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(Source^,Data^,fKnownSize); result := true; end else begin info := KINDTYPE_INFO[fKnownType]; if info=nil then result := false else result := (ManagedTypeLoad(Data,Source,info)<>0) and (Source<>nil); end; end; function TDynArray.LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil): PUTF8Char; var n, i, ValLen: integer; T: TDynArrayKind; wasString, expectedString, isValid: boolean; EndOfObject: AnsiChar; Val: PUTF8Char; V: pointer; CustomReader: TDynArrayJSONCustomReader; NestedDynArray: TDynArray; begin // code below must match TTextWriter.AddDynArrayJSON() result := nil; if (P=nil) or (fValue=nil) then exit; if not NextNotSpaceCharIs(P,'[') then exit; n := JSONArrayCount(P); if n<0 then exit; // invalid array content if n=0 then begin if NextNotSpaceCharIs(P,']') then begin Clear; result := P; end; exit; // handle '[]' array end; if HasCustomJSONParser then CustomReader := GlobalJSONCustomParsers.fParser[fParser].Reader else CustomReader := nil; if Assigned(CustomReader) then T := djCustom else T := ToKnownType({exacttype=}true); if (T=djNone) and (P^='[') and (PTypeKind(ElemType)^=tkDynArray) then begin Count := n; // fast allocation of the whole dynamic array memory at once for i := 0 to n-1 do begin NestedDynArray.Init(ElemType,PPointerArray(fValue^)^[i]); P := NestedDynArray.LoadFromJSON(P,@EndOfObject); if P=nil then exit; EndOfObject := P^; // ',' or ']' for the last item of the array inc(P); end; end else if (T=djNone) or (PCardinal(P)^=JSON_BASE64_MAGIC_QUOTE) then begin if n<>1 then exit; // expect one Base64 encoded string value preceded by \uFFF0 Val := GetJSONField(P,P,@wasString,@EndOfObject); if (Val=nil) or not wasString or (PInteger(Val)^ and $00ffffff<>JSON_BASE64_MAGIC) or (LoadFrom(pointer(Base64ToBin(Val+3)))=nil) then exit; // invalid content end else begin if GetIsObjArray then for i := 0 to Count-1 do // force release any previous instance FreeAndNil(PObjectArray(fValue^)^[i]); SetCount(n); // fast allocation of the whole dynamic array memory at once case T of {$ifndef NOVARIANTS} djVariant: for i := 0 to n-1 do P := VariantLoadJSON(PVariantArray(fValue^)^[i],P,@EndOfObject,@JSON_OPTIONS[true]); {$endif} djCustom: begin Val := fValue^; for i := 1 to n do begin P := CustomReader(P,Val^,isValid); if not isValid then exit; EndOfObject := P^; // ',' or ']' for the last item of the array inc(P); inc(Val,ElemSize); end; end; else begin V := fValue^; expectedString := (T in [djTimeLog..djHash512]); for i := 0 to n-1 do begin Val := GetJSONField(P,P,@wasString,@EndOfObject,@ValLen); if (Val=nil) or (wasString<>expectedString) then exit; case T of djBoolean: PBooleanArray(V)^[i] := GetBoolean(Val); djByte: PByteArray(V)^[i] := GetCardinal(Val); djWord: PWordArray(V)^[i] := GetCardinal(Val); djInteger: PIntegerArray(V)^[i] := GetInteger(Val); djCardinal: PCardinalArray(V)^[i] := GetCardinal(Val); djSingle: PSingleArray(V)^[i] := GetExtended(Val); djInt64: SetInt64(Val,PInt64Array(V)^[i]); djQWord: SetQWord(Val,PQWordArray(V)^[i]); djTimeLog: PInt64Array(V)^[i] := Iso8601ToTimeLogPUTF8Char(Val,ValLen); djDateTime, djDateTimeMS: Iso8601ToDateTimePUTF8CharVar(Val,ValLen,PDateTimeArray(V)^[i]); djDouble: PDoubleArray(V)^[i] := GetExtended(Val); djCurrency: PInt64Array(V)^[i] := StrToCurr64(Val); djRawUTF8: FastSetString(PRawUTF8Array(V)^[i],Val,ValLen); djRawByteString: if not Base64MagicCheckAndDecode(Val,ValLen,PRawByteStringArray(V)^[i]) then FastSetString(PRawUTF8Array(V)^[i],Val,ValLen); djWinAnsi: WinAnsiConvert.UTF8BufferToAnsi(Val,ValLen,PRawByteStringArray(V)^[i]); djString: UTF8DecodeToString(Val,ValLen,string(PPointerArray(V)^[i])); djWideString: UTF8ToWideString(Val,ValLen,WideString(PPointerArray(V)^[i])); djSynUnicode: UTF8ToSynUnicode(Val,ValLen,SynUnicode(PPointerArray(V)^[i])); djHash128: if ValLen<>SizeOf(THash128)*2 then FillZero(PHash128Array(V)^[i]) else HexDisplayToBin(pointer(Val),@PHash128Array(V)^[i],SizeOf(THash128)); djHash256: if ValLen<>SizeOf(THash256)*2 then FillZero(PHash256Array(V)^[i]) else HexDisplayToBin(pointer(Val),@PHash256Array(V)^[i],SizeOf(THash256)); djHash512: if ValLen<>SizeOf(THash512)*2 then FillZero(PHash512Array(V)^[i]) else HexDisplayToBin(pointer(Val),@PHash512Array(V)^[i],SizeOf(THash512)); else raise ESynException.CreateUTF8('% not readable',[ToText(T)^]); end; end; end; end; end; if aEndOfObject<>nil then aEndOfObject^ := EndOfObject; if EndOfObject=']' then if P=nil then result := @NULCHAR else result := P; end; {$ifndef NOVARIANTS} function TDynArray.LoadFromVariant(const DocVariant: variant): boolean; begin with _Safe(DocVariant)^ do if dvoIsArray in Options then result := LoadFromJSON(pointer(_Safe(DocVariant)^.ToJSON))<>nil else result := false; end; {$endif NOVARIANTS} function SimpleDynArrayLoadFrom(Source: PAnsiChar; aTypeInfo: pointer; var Count, ElemSize: integer; NoHash32Check: boolean): pointer; var Hash: PCardinalArray absolute Source; info: PTypeInfo; begin result := nil; info := GetTypeInfo(aTypeInfo,tkDynArray); if info=nil then exit; // invalid type information if (info^.ElType<>nil) or (Source=nil) or (Source[0]<>AnsiChar(info^.elSize)) or (Source[1]<>#0) then exit; // invalid type information or Source content ElemSize := info^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}; inc(Source,2); Count := FromVarUInt32(PByte(Source)); // dynamic array count if (Count<>0) and (NoHash32Check or (Hash32(@Hash[1],Count*ElemSize)=Hash[0])) then result := @Hash[1]; // returns valid Source content end; function IntegerDynArrayLoadFrom(Source: PAnsiChar; var Count: integer; NoHash32Check: boolean): PIntegerArray; var Hash: PCardinalArray absolute Source; begin result := nil; if (Source=nil) or (Source[0]<>#4) or (Source[1]<>#0) then exit; // invalid Source content inc(Source,2); Count := FromVarUInt32(PByte(Source)); // dynamic array count if (Count<>0) and (NoHash32Check or (Hash32(@Hash[1],Count*4)=Hash[0])) then result := @Hash[1]; // returns valid Source content end; function RawUTF8DynArrayLoadFromContains(Source: PAnsiChar; Value: PUTF8Char; ValueLen: integer; CaseSensitive: boolean): integer; var Count, Len: integer; begin if (Value=nil) or (ValueLen=0) or (Source=nil) or (Source[0]<>AnsiChar(SizeOf(PtrInt))) {$ifndef FPC}or (Source[1]<>AnsiChar(tkLString)){$endif} then begin result := -1; exit; // invalid Source or Value content end; inc(Source,2); Count := FromVarUInt32(PByte(Source)); // dynamic array count inc(Source,SizeOf(cardinal)); // ignore Hash32 security checksum for result := 0 to Count-1 do begin Len := FromVarUInt32(PByte(Source)); if CaseSensitive then begin if (Len=ValueLen) and CompareMemFixed(Value,Source,Len) then exit; end else if UTF8ILComp(Value,pointer(Source),ValueLen,Len)=0 then exit; inc(Source,Len); end; result := -1; end; function TDynArrayLoadFrom.Init(ArrayTypeInfo: pointer; Source: PAnsiChar): boolean; var fake: pointer; begin result := false; Position := nil; // force Step() to return false if called aterwards if Source=nil then exit; DynArray.Init(ArrayTypeInfo,fake); // just to retrieve RTTI FromVarUInt32(PByte(Source)); // ignore StoredElemSize to be Win32/64 compatible if DynArray.ElemType=nil then begin if (Source^<>#0) or DynArray.GetIsObjArray then exit; // invalid Source, or unexpected T*ObjArray end else if Source^<>{$ifdef FPC} // cross-FPC/Delphi compatible AnsiChar(FPCTODELPHI[PTypeKind(DynArray.ElemType)^]){$else} PAnsiChar(DynArray.ElemType)^{$endif} then exit; // invalid Source content inc(Source); Count := FromVarUInt32(PByte(Source)); Hash := pointer(Source); Position := Source+SizeOf(cardinal); Current := 0; result := true; end; function TDynArrayLoadFrom.Step(out Elem): boolean; begin result := false; if (Position<>nil) and (Currentnil) and (Currentnil) and (Hash32(@Hash[1],Position-PAnsiChar(@Hash[1]))=Hash[0]); end; function TDynArray.LoadFrom(Source: PAnsiChar; AfterEach: TDynArrayAfterLoadFrom; NoCheckHash: boolean): PAnsiChar; var i, n: integer; P: PAnsiChar; Hash: PCardinalArray; begin // check context result := nil; if Source=nil then begin Clear; exit; end; if fValue=nil then exit; // check stored element size+type FromVarUInt32(PByte(Source)); // ignore StoredElemSize to be Win32/64 compatible if ElemType=nil then begin if Source^<>#0 then exit; end else if Source^<>{$ifdef FPC} // cross-FPC/Delphi compatible AnsiChar(FPCTODELPHI[PTypeKind(ElemType)^]){$else} PAnsiChar(ElemType)^{$endif} then exit; inc(Source); // retrieve dynamic array count n := FromVarUInt32(PByte(Source)); SetCount(n); if n=0 then begin result := Source; exit; end; // retrieve security checksum Hash := pointer(Source); inc(Source,SizeOf(cardinal)); // retrieve dynamic array elements content P := fValue^; if ElemType=nil then // FPC: nil also if not Kind in tkManagedTypes if GetIsObjArray then raise ESynException.CreateUTF8('TDynArray.LoadFrom(%) is a T*ObjArray', [ArrayTypeShort^]) else begin // binary type was stored directly n := n*integer(ElemSize); {$ifdef FPC}Move{$else}MoveFast{$endif}(Source^,P^,n); inc(Source,n); end else case PTypeKind(ElemType)^ of tkRecord{$ifdef FPC},tkObject{$endif}: for i := 1 to n do begin Source := RecordLoad(P^,Source,ElemType); if Assigned(AfterEach) then AfterEach(P^); inc(P,ElemSize); end; else for i := 1 to n do begin ManagedTypeLoad(P,Source,ElemType); if Source=nil then break; if Assigned(AfterEach) then AfterEach(P^); inc(P,ElemSize); end; end; // check security checksum if NoCheckHash or (Source=nil) or (Hash32(@Hash[1],Source-PAnsiChar(@Hash[1]))=Hash[0]) then result := Source; end; function TDynArray.Find(const Elem; const aIndex: TIntegerDynArray; aCompare: TDynArraySortCompare): PtrInt; var n, L: PtrInt; cmp: integer; P: PAnsiChar; begin n := GetCount; if (@aCompare<>nil) and (n>0) then begin dec(n); P := fValue^; if (n>10) and (length(aIndex)>=n) then begin // array should be sorted via aIndex[] -> use fast O(log(n)) binary search L := 0; repeat result := (L+n) shr 1; cmp := aCompare(P[cardinal(aIndex[result])*ElemSize],Elem); if cmp=0 then begin result := aIndex[result]; // returns index in TDynArray exit; end; if cmp<0 then L := result+1 else n := result-1; until L>n; end else // array is not sorted, or aIndex=nil -> use O(n) iterating search for result := 0 to n do if aCompare(P^,Elem)=0 then exit else inc(P,ElemSize); end; result := -1; end; function TDynArray.FindIndex(const Elem; aIndex: PIntegerDynArray; aCompare: TDynArraySortCompare): PtrInt; begin if aIndex<>nil then result := Find(Elem,aIndex^,aCompare) else if Assigned(aCompare) then result := Find(Elem,nil,aCompare) else result := Find(Elem); end; function TDynArray.FindAndFill(var Elem; aIndex: PIntegerDynArray=nil; aCompare: TDynArraySortCompare=nil): integer; begin result := FindIndex(Elem,aIndex,aCompare); if result>=0 then // if found, fill Elem with the matching item ElemCopy(PAnsiChar(fValue^)[cardinal(result)*ElemSize],Elem); end; function TDynArray.FindAndDelete(const Elem; aIndex: PIntegerDynArray=nil; aCompare: TDynArraySortCompare=nil): integer; begin result := FindIndex(Elem,aIndex,aCompare); if result>=0 then Delete(result); end; function TDynArray.FindAndUpdate(const Elem; aIndex: PIntegerDynArray=nil; aCompare: TDynArraySortCompare=nil): integer; begin result := FindIndex(Elem,aIndex,aCompare); if result>=0 then // if found, fill Elem with the matching item ElemCopy(Elem,PAnsiChar(fValue^)[cardinal(result)*ElemSize]); end; function TDynArray.FindAndAddIfNotExisting(const Elem; aIndex: PIntegerDynArray=nil; aCompare: TDynArraySortCompare=nil): integer; begin result := FindIndex(Elem,aIndex,aCompare); if result<0 then Add(Elem); // -1 will mark success end; function TDynArray.Find(const Elem): PtrInt; var n, L: PtrInt; cmp: integer; P: PAnsiChar; begin n := GetCount; if (@fCompare<>nil) and (n>0) then begin dec(n); P := fValue^; if fSorted and (n>10) then begin // array is sorted -> use fast O(log(n)) binary search L := 0; repeat result := (L+n) shr 1; cmp := fCompare(P[cardinal(result)*ElemSize],Elem); if cmp=0 then exit; if cmp<0 then L := result+1 else n := result-1; until L>n; end else begin // array is very small, or not sorted -> use O(n) iterating search if (ElemType=nil) and (@fCompare=@DYNARRAY_SORTFIRSTFIELD[false,fKnownType]) then case fElemSize of // optimized for simple key types (e.g. TSynDictionary) 4: begin result := IntegerScanIndex(pointer(P),n+1,Integer(Elem)); exit; end; 8: begin result := Int64ScanIndex(pointer(P),n+1,Int64(Elem)); exit; end; end; for result := 0 to n do if fCompare(P^,Elem)=0 then exit else inc(P,ElemSize); end; end; result := -1; end; function TDynArray.FindAllSorted(const Elem; out FirstIndex,LastIndex: Integer): boolean; var found,last: integer; P: PAnsiChar; begin result := FastLocateSorted(Elem,found); if not result then exit; FirstIndex := found; P := fValue^; while (FirstIndex>0) and (fCompare(P[cardinal(FirstIndex-1)*ElemSize],Elem)=0) do dec(FirstIndex); last := GetCount-1; LastIndex := found; while (LastIndexnil then if n=0 then // a void array is always sorted Index := 0 else if fSorted then begin P := fValue^; dec(n); cmp := fCompare(Elem,P[cardinal(n)*ElemSize]); if cmp>=0 then begin // greater than last sorted item Index := n; if cmp=0 then result := true else // returns true + index of existing Elem inc(Index); // returns false + insert after last position exit; end; Index := 0; while Index<=n do begin // O(log(n)) binary search of the sorted position i := (Index+n) shr 1; cmp := fCompare(P[cardinal(i)*ElemSize],Elem); if cmp=0 then begin Index := i; // returns true + index of existing Elem result := True; exit; end else if cmp<0 then Index := i+1 else n := i-1; end; // Elem not found: returns false + the index where to insert end else Index := -1 else // not Sorted Index := -1; // no fCompare() end; procedure TDynArray.FastAddSorted(Index: Integer; const Elem); begin Insert(Index,Elem); fSorted := true; // Insert -> SetCount -> fSorted := false end; procedure TDynArray.FastDeleteSorted(Index: Integer); begin Delete(Index); fSorted := true; // Delete -> SetCount -> fSorted := false end; function TDynArray.FastLocateOrAddSorted(const Elem; wasAdded: PBoolean): integer; var toInsert: boolean; begin toInsert := not FastLocateSorted(Elem,result) and (result>=0); if toInsert then begin Insert(result,Elem); fSorted := true; // Insert -> SetCount -> fSorted := false end; if wasAdded<>nil then wasAdded^ := toInsert; end; type // internal structure used to make QuickSort faster & with less stack usage {$ifdef FPC_OR_UNICODE}TDynArrayQuickSort = record{$else}TDynArrayQuickSort = object{$endif} public Compare: TDynArraySortCompare; CompareEvent: TEventDynArraySortCompare; Pivot: pointer; Index: PCardinalArray; ElemSize: cardinal; P: PtrInt; Value: PAnsiChar; IP, JP: PAnsiChar; procedure QuickSort(L, R: PtrInt); procedure QuickSortIndexed(L, R: PtrInt); procedure QuickSortEvent(L, R: PtrInt); procedure QuickSortEventReverse(L, R: PtrInt); end; procedure QuickSortIndexedPUTF8Char(Values: PPUtf8CharArray; Count: Integer; var SortedIndexes: TCardinalDynArray; CaseSensitive: boolean); var QS: TDynArrayQuickSort; begin if CaseSensitive then QS.Compare := SortDynArrayPUTF8Char else QS.Compare := SortDynArrayPUTF8CharI; QS.Value := pointer(Values); QS.ElemSize := SizeOf(PUTF8Char); SetLength(SortedIndexes,Count); FillIncreasing(pointer(SortedIndexes),0,Count); QS.Index := pointer(SortedIndexes); QS.QuickSortIndexed(0,Count-1); end; procedure DynArraySortIndexed(Values: pointer; ElemSize, Count: Integer; out Indexes: TSynTempBuffer; Compare: TDynArraySortCompare); var QS: TDynArrayQuickSort; begin QS.Compare := Compare; QS.Value := Values; QS.ElemSize := ElemSize; QS.Index := pointer(Indexes.InitIncreasing(Count)); QS.QuickSortIndexed(0,Count-1); end; procedure TDynArrayQuickSort.QuickSort(L, R: PtrInt); var I, J: PtrInt; {$ifndef PUREPASCAL}tmp: pointer;{$endif} begin if L0 do begin dec(J); dec(JP,ElemSize); end; if I <= J then begin if I<>J then {$ifndef PUREPASCAL} // inlined Exchg() is just fine if ElemSize=SizeOf(pointer) then begin // optimized version e.g. for TRawUTF8DynArray/TObjectDynArray tmp := PPointer(IP)^; PPointer(IP)^ := PPointer(JP)^; PPointer(JP)^ := tmp; end else {$endif} // generic exchange of row element data Exchg(IP,JP,ElemSize); if P = I then P := J else if P = J then P := I; Inc(I); Dec(J); end; until I > J; if J - L < R - I then begin // use recursion only for smaller range if L < J then QuickSort(L, J); L := I; end else begin if I < R then QuickSort(I, R); R := J; end; until L >= R; end; procedure TDynArrayQuickSort.QuickSortEvent(L, R: PtrInt); var I, J: PtrInt; begin if L0 do begin dec(J); dec(JP,ElemSize); end; if I <= J then begin if I<>J then Exchg(IP,JP,ElemSize); if P = I then P := J else if P = J then P := I; Inc(I); Dec(J); end; until I > J; if J - L < R - I then begin // use recursion only for smaller range if L < J then QuickSortEvent(L, J); L := I; end else begin if I < R then QuickSortEvent(I, R); R := J; end; until L >= R; end; procedure TDynArrayQuickSort.QuickSortEventReverse(L, R: PtrInt); var I, J: PtrInt; begin if L0 do begin inc(I); inc(IP,ElemSize); end; while CompareEvent(JP^,Pivot^)<0 do begin dec(J); dec(JP,ElemSize); end; if I <= J then begin if I<>J then Exchg(IP,JP,ElemSize); if P = I then P := J else if P = J then P := I; Inc(I); Dec(J); end; until I > J; if J - L < R - I then begin // use recursion only for smaller range if L < J then QuickSortEventReverse(L, J); L := I; end else begin if I < R then QuickSortEventReverse(I, R); R := J; end; until L >= R; end; procedure TDynArrayQuickSort.QuickSortIndexed(L, R: PtrInt); var I, J: PtrInt; tmp: integer; begin if L0 do dec(J); if I <= J then begin if I<>J then begin tmp := Index[I]; Index[I] := Index[J]; Index[J] := tmp; end; if P = I then P := J else if P = J then P := I; Inc(I); Dec(J); end; until I > J; if J - L < R - I then begin // use recursion only for smaller range if L < J then QuickSortIndexed(L, J); L := I; end else begin if I < R then QuickSortIndexed(I, R); R := J; end; until L >= R; end; procedure TDynArray.Sort(aCompare: TDynArraySortCompare); begin SortRange(0,Count-1,aCompare); fSorted := true; end; procedure QuickSortPtr(L, R: PtrInt; Compare: TDynArraySortCompare; V: PPointerArray); var I, J, P: PtrInt; tmp: pointer; begin if L0 do dec(J); if I <= J then begin tmp := V[I]; V[I] := V[J]; V[J] := tmp; if P = I then P := J else if P = J then P := I; Inc(I); Dec(J); end; until I > J; if J - L < R - I then begin // use recursion only for smaller range if L < J then QuickSortPtr(L, J, Compare, V); L := I; end else begin if I < R then QuickSortPtr(I, R, Compare, V); R := J; end; until L >= R; end; procedure TDynArray.SortRange(aStart, aStop: integer; aCompare: TDynArraySortCompare); var QuickSort: TDynArrayQuickSort; begin if aStop<=aStart then exit; // nothing to sort if @aCompare=nil then Quicksort.Compare := @fCompare else Quicksort.Compare := aCompare; if (@Quicksort.Compare<>nil) and (fValue<>nil) and (fValue^<>nil) then if ElemSize=SizeOf(pointer) then QuickSortPtr(aStart,aStop,QuickSort.Compare,fValue^) else begin Quicksort.Value := fValue^; Quicksort.ElemSize := ElemSize; Quicksort.QuickSort(aStart,aStop); end; end; procedure TDynArray.Sort(const aCompare: TEventDynArraySortCompare; aReverse: boolean); var QuickSort: TDynArrayQuickSort; R: PtrInt; begin if not Assigned(aCompare) or (fValue = nil) or (fValue^=nil) then exit; // nothing to sort Quicksort.CompareEvent := aCompare; Quicksort.Value := fValue^; Quicksort.ElemSize := ElemSize; R := Count-1; if aReverse then Quicksort.QuickSortEventReverse(0,R) else Quicksort.QuickSortEvent(0,R); end; procedure TDynArray.CreateOrderedIndex(var aIndex: TIntegerDynArray; aCompare: TDynArraySortCompare); var QuickSort: TDynArrayQuickSort; n: integer; begin if @aCompare=nil then Quicksort.Compare := @fCompare else Quicksort.Compare := aCompare; if (@QuickSort.Compare<>nil) and (fValue<>nil) and (fValue^<>nil) then begin n := GetCount; if length(aIndex)nil) and (fValue<>nil) and (fValue^<>nil) then begin n := GetCount; Quicksort.Value := fValue^; Quicksort.ElemSize := ElemSize; Quicksort.Index := PCardinalArray(aIndex.InitIncreasing(n)); Quicksort.QuickSortIndexed(0,n-1); end else aIndex.buf := nil; // avoid GPF in aIndex.Done end; procedure TDynArray.CreateOrderedIndexAfterAdd(var aIndex: TIntegerDynArray; aCompare: TDynArraySortCompare); var ndx: integer; begin ndx := GetCount-1; if ndx<0 then exit; if aIndex<>nil then begin // whole FillIncreasing(aIndex[]) for first time if ndx>=length(aIndex) then SetLength(aIndex,NextGrow(ndx)); // grow aIndex[] if needed aIndex[ndx] := ndx; end; CreateOrderedIndex(aIndex,aCompare); end; function TDynArray.ElemEquals(const A,B): boolean; begin if @fCompare<>nil then result := fCompare(A,B)=0 else if ElemType=nil then case ElemSize of // optimized versions for arrays of common types 1: result := byte(A)=byte(B); 2: result := word(A)=word(B); 4: result := cardinal(A)=cardinal(B); 8: result := Int64(A)=Int64(B); else result := CompareMemFixed(@A,@B,ElemSize); // binary comparison end else if PTypeKind(ElemType)^ in tkRecordTypes then // most likely result := RecordEquals(A,B,ElemType) else result := ManagedTypeCompare(@A,@B,ElemType)>0; // other complex types end; {$ifndef DELPHI5OROLDER} // disabled for Delphi 5 buggy compiler procedure TDynArray.InitFrom(const aAnother: TDynArray; var aValue); begin self := aAnother; fValue := @aValue; fCountP := nil; end; procedure TDynArray.AddDynArray(const aSource: TDynArray; aStartIndex: integer; aCount: integer); var SourceCount: integer; begin if (aSource.fValue<>nil) and (ArrayType=aSource.ArrayType) then begin SourceCount := aSource.Count; if (aCount<0) or (aCount>SourceCount) then aCount := SourceCount; // force use of external Source.Count, if any AddArray(aSource.fValue^,aStartIndex,aCount); end; end; function TDynArray.Equals(const B: TDynArray; ignorecompare: boolean): boolean; var i, n: integer; P1,P2: PAnsiChar; A1: PPointerArray absolute P1; A2: PPointerArray absolute P2; function HandleObjArray: boolean; var tmp1,tmp2: RawUTF8; begin SaveToJSON(tmp1); B.SaveToJSON(tmp2); result := tmp1=tmp2; end; begin result := false; if ArrayType<>B.ArrayType then exit; // array types should match exactly n := GetCount; if n<>B.Count then exit; if GetIsObjArray then begin result := HandleObjArray; exit; end; P1 := fValue^; P2 := B.fValue^; if (@fCompare<>nil) and not ignorecompare then // use customized comparison for i := 1 to n do if fCompare(P1^,P2^)<>0 then exit else begin inc(P1,ElemSize); inc(P2,ElemSize); end else if ElemType=nil then begin // binary type is compared as a whole result := CompareMem(P1,P2,ElemSize*cardinal(n)); exit; end else case PTypeKind(ElemType)^ of // some optimized versions for most used types tkLString{$ifdef FPC},tkLStringOld{$endif}: for i := 0 to n-1 do if AnsiString(A1^[i])<>AnsiString(A2^[i]) then exit; tkWString: for i := 0 to n-1 do if WideString(A1^[i])<>WideString(A2^[i]) then exit; {$ifdef HASVARUSTRING} tkUString: for i := 0 to n-1 do if UnicodeString(A1^[i])<>UnicodeString(A2^[i]) then exit; {$endif} tkRecord{$ifdef FPC},tkObject{$endif}: for i := 1 to n do if not RecordEquals(P1^,P2^,ElemType) then exit else begin inc(P1,ElemSize); inc(P2,ElemSize); end; else // generic TypeInfoCompare() use for i := 1 to n do if ManagedTypeCompare(P1,P2,ElemType)<=0 then exit else begin // A^<>B^ or unexpected type inc(P1,ElemSize); inc(P2,ElemSize); end; end; result := true; end; procedure TDynArray.Copy(const Source: TDynArray; ObjArrayByRef: boolean); var n: Cardinal; begin if (fValue=nil) or (ArrayType<>Source.ArrayType) then exit; if (fCountP<>nil) and (Source.fCountP<>nil) then SetCapacity(Source.Capacity); n := Source.Count; SetCount(n); if n<>0 then if ElemType=nil then if not ObjArrayByRef and GetIsObjArray then LoadFromJSON(pointer(Source.SaveToJSON)) else {$ifdef FPC}Move{$else}MoveFast{$endif}(Source.fValue^^,fValue^^,n*ElemSize) else CopyArray(fValue^,Source.fValue^,ElemType,n); end; procedure TDynArray.CopyFrom(const Source; MaxElem: integer; ObjArrayByRef: boolean); var SourceDynArray: TDynArray; begin SourceDynArray.Init(fTypeInfo,pointer(@Source)^); SourceDynArray.fCountP := @MaxElem; // would set Count=0 at Init() Copy(SourceDynArray,ObjArrayByRef); end; procedure TDynArray.CopyTo(out Dest; ObjArrayByRef: boolean); var DestDynArray: TDynArray; begin DestDynArray.Init(fTypeInfo,Dest); DestDynArray.Copy(self,ObjArrayByRef); end; {$endif DELPHI5OROLDER} function TDynArray.IndexOf(const Elem): PtrInt; var P: pointer; PP: PPointerArray absolute P; max: PtrInt; begin if fValue=nil then begin result := -1; exit; // avoid GPF if void end; max := GetCount-1; P := fValue^; if @Elem<>nil then if ElemType=nil then case ElemSize of // optimized versions for arrays of byte,word,integer,Int64,Currency,Double 1: for result := 0 to max do if PByteArray(P)^[result]=byte(Elem) then exit; 2: for result := 0 to max do if PWordArray(P)^[result]=word(Elem) then exit; 4: for result := 0 to max do // integer,single,32bitPointer if PIntegerArray(P)^[result]=integer(Elem) then exit; 8: for result := 0 to max do // Int64,Currency,Double,64bitPointer if PInt64Array(P)^[result]=Int64(Elem) then exit; else // generic binary comparison (fast with our overloaded CompareMemFixed) for result := 0 to max do if CompareMemFixed(P,@Elem,ElemSize) then exit else inc(PByte(P),ElemSize); end else case PTypeKind(ElemType)^ of tkLString{$ifdef FPC},tkLStringOld{$endif}: for result := 0 to max do if AnsiString(PP^[result])=AnsiString(Elem) then exit; tkWString: for result := 0 to max do if WideString(PP^[result])=WideString(Elem) then exit; {$ifdef HASVARUSTRING} tkUString: for result := 0 to max do if UnicodeString(PP^[result])=UnicodeString(Elem) then exit; {$endif} {$ifndef NOVARIANTS} tkVariant: for result := 0 to max do if SortDynArrayVariantComp(PVarDataStaticArray(P)^[result], TVarData(Elem),false)=0 then exit; {$endif} tkRecord{$ifdef FPC},tkObject{$endif}: // RecordEquals() works with packed records containing binary and string types for result := 0 to max do if RecordEquals(P^,Elem,ElemType) then exit else inc(PByte(P),ElemSize); tkInterface: for result := 0 to max do if PP^[result]=pointer(Elem) then exit; else for result := 0 to max do if ManagedTypeCompare(P,@Elem,ElemType)>0 then exit else inc(PByte(P),ElemSize); end; result := -1; end; procedure TDynArray.Init(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil); begin fValue := @aValue; fTypeInfo := aTypeInfo; if PTypeKind(aTypeInfo)^<>tkDynArray then // inlined GetTypeInfo() raise ESynException.CreateUTF8('TDynArray.Init: % is %, expected tkDynArray', [PShortString(@PTypeInfo(aTypeInfo)^.NameLen)^,ToText(PTypeKind(aTypeInfo)^)^]); {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} aTypeInfo := GetFPCAlignPtr(aTypeInfo); {$else} inc(PByte(aTypeInfo),PTypeInfo(aTypeInfo)^.NameLen); {$endif} fElemSize := PTypeInfo(aTypeInfo)^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}; fElemType := PTypeInfo(aTypeInfo)^.elType; if fElemType<>nil then begin {$ifndef HASDIRECTTYPEINFO} // FPC compatibility: if you have a GPF here at startup, your 3.1 trunk // revision seems older than June 2016 // -> enable HASDIRECTTYPEINFO conditional below $ifdef VER3_1 in Synopse.inc // or in your project's options fElemType := PPointer(fElemType)^; // inlined DeRef() {$endif} {$ifdef FPC} if not (PTypeKind(fElemType)^ in tkManagedTypes) then fElemType := nil; // as with Delphi {$endif} end; fCountP := aCountPointer; if fCountP<>nil then fCountP^ := 0; fCompare := nil; fParser := DYNARRAY_PARSERUNKNOWN; fKnownSize := 0; fSorted := false; fKnownType := djNone; fIsObjArray := oaUnknown; end; procedure TDynArray.InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind; aCountPointer: PInteger; aCaseInsensitive: boolean); var Comp: TDynArraySortCompare; begin Init(aTypeInfo,aValue,aCountPointer); Comp := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,aKind]; if @Comp=nil then raise ESynException.CreateUTF8('TDynArray.InitSpecific(%) wrong aKind=%', [PShortString(@PTypeInfo(aTypeInfo)^.NameLen)^,ToText(aKind)^]); fCompare := Comp; fKnownType := aKind; fKnownSize := KNOWNTYPE_SIZE[aKind]; end; procedure TDynArray.UseExternalCount(var aCountPointer: Integer); begin fCountP := @aCountPointer; end; function TDynArray.HasCustomJSONParser: boolean; begin if fParser=DYNARRAY_PARSERUNKNOWN then fParser := GlobalJSONCustomParsers.DynArraySearch(ArrayType,ElemType); result := cardinal(fParser)nil); if result then fIsObjArray := oaTrue else fIsObjArray := oaFalse; end; procedure TDynArray.SetIsObjArray(aValue: boolean); begin if aValue then fIsObjArray := oaTrue else fIsObjArray := oaFalse; end; procedure TDynArray.InternalSetLength(NewLength: PtrUInt); var p: PDynArrayRec; OldLength, NeededSize, minLength: PtrUInt; pp: pointer; i: integer; begin // this method is faster than default System.DynArraySetLength() function // check that new array length is not just a finalize in disguise if NewLength=0 then begin {$ifndef NOVARIANTS} // faster clear of custom variant uniformous array if ArrayType=TypeInfo(TVariantDynArray) then begin VariantDynArrayClear(TVariantDynArray(fValue^)); exit; end; {$endif} if GetIsObjArray then ObjArrayClear(fValue^); {$ifdef FPC}FPCDynArrayClear{$else}_DynArrayClear{$endif}(fValue^,ArrayType); exit; end; // calculate the needed size of the resulting memory structure on heap NeededSize := NewLength*ElemSize+SizeOf(TDynArrayRec); {$ifndef CPU64} if NeededSize>1024*1024*1024 then // max workable memory block is 1 GB raise ERangeError.CreateFmt('TDynArray SetLength(%s,%d) size concern', [ArrayTypeShort^,NewLength]); {$endif} // if not shared (refCnt=1), resize; if shared, create copy (not thread safe) p := fValue^; if p=nil then begin p := AllocMem(NeededSize); OldLength := NewLength; // no FillcharFast() below end else begin dec(PtrUInt(p),SizeOf(TDynArrayRec)); // p^ = start of heap object OldLength := p^.length; if OldLength=NewLength then exit; // nothing to resize if p^.refCnt=1 then begin if NewLengthnil then // release managed types in trailing items {$ifdef FPC}FPCFinalizeArray{$else}_FinalizeArray{$endif}( PAnsiChar(p)+NeededSize,ElemType,OldLength-NewLength) else if GetIsObjArray then begin // FreeAndNil() of resized objects list for i := NewLength to OldLength-1 do PObjectArray(fValue^)^[i].Free; {$ifdef FPC}FillChar{$else}FillCharFast{$endif}( PAnsiChar(p)[NeededSize],(OldLength-NewLength) shl POINTERSHR,0); end; ReallocMem(p,NeededSize); end else begin // make copy InterlockedDecrement(PInteger(@p^.refCnt)^); // FPC has refCnt: PtrInt GetMem(p,NeededSize); minLength := oldLength; if minLength>newLength then minLength := newLength; pp := PAnsiChar(p)+SizeOf(TDynArrayRec); if ElemType<>nil then begin {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(pp^,minLength*elemSize,0); CopyArray(pp,fValue^,ElemType,minLength); end else {$ifdef FPC}Move{$else}MoveFast{$endif}(fValue^^,pp^,minLength*elemSize); end; end; // set refCnt=1 and new length to the heap memory structure with p^ do begin refCnt := 1; {$ifdef FPC} high := newLength-1; {$else} length := newLength; {$endif} end; inc(PByte(p),SizeOf(p^)); // p^ = start of dynamic aray items fValue^ := p; // reset new allocated elements content to zero if NewLength>OldLength then begin OldLength := OldLength*elemSize; {$ifdef FPC}FillChar{$else}FillCharFast{$endif}( PAnsiChar(p)[OldLength],NewLength*ElemSize-OldLength,0); end; end; procedure TDynArray.SetCount(aCount: integer); const MINIMUM_SIZE = 64; var c, v, capa, delta: PtrInt; begin v := PtrInt(fValue); c := PtrInt(fCountP); fSorted := false; if v=0 then exit; // avoid GPF if void if c<>0 then begin // handle external capacity with separated Count delta := aCount-PInteger(c)^; if delta=0 then exit; PInteger(c)^ := aCount; // store new length v := PPtrInt(v)^; if v=0 then begin // no capa yet if (delta>0) and (aCount0 then begin // size-up -> grow by chunks c := PInteger(c)^; if capa>=c then exit; // no need to grow capa := NextGrow(capa); if capa0) and ((fIsObjArray=oaFalse) or ((fIsObjArray=oaUnknown) and not ComputeIsObjArray)) then // size-down -> only if worth it (for faster Delete) if (capa<=MINIMUM_SIZE) or (capa-aCount realloc InternalSetLength(aCount); end; function TDynArray.GetCapacity: integer; begin // capacity = length(DynArray) if (fValue<>nil) and (PtrUInt(fValue^)<>0) then result := PDynArrayRec(PtrUInt(fValue^)-SizeOf(TDynArrayRec))^.length else result := 0; end; procedure TDynArray.SetCapacity(aCapacity: integer); begin if fValue=nil then exit; // avoid GPF if void if fCountP<>nil then if fCountP^>aCapacity then fCountP^ := aCapacity; InternalSetLength(aCapacity); end; procedure TDynArray.SetCompare(const aCompare: TDynArraySortCompare); begin if @aCompare<>@fCompare then begin @fCompare := @aCompare; fSorted := false; end; end; procedure TDynArray.Slice(var Dest; aCount, aFirstIndex: cardinal); var n: Cardinal; D: PPointer; P: PAnsiChar; begin if fValue=nil then exit; // avoid GPF if void n := GetCount; if aFirstIndex>=n then aCount := 0 else if aCount>=n-aFirstIndex then aCount := n-aFirstIndex; DynArray(ArrayType,Dest).InternalSetLength(aCount); D := @Dest; if aCount>0 then begin P := PAnsiChar(fValue^)+aFirstIndex*ElemSize; if ElemType=nil then {$ifdef FPC}Move{$else}MoveFast{$endif}(P^,D^^,aCount*ElemSize) else CopyArray(D^,P,ElemType,aCount); end; end; function TDynArray.AddArray(const DynArrayVar; aStartIndex, aCount: integer): integer; var c, n: integer; PS,PD: pointer; begin result := 0; if fValue=nil then exit; // avoid GPF if void c := DynArrayLength(pointer(DynArrayVar)); if aStartIndex>=c then exit; // nothing to copy if (aCount<0) or (cardinal(aStartIndex+aCount)>cardinal(c)) then aCount := c-aStartIndex; if aCount<=0 then exit; result := aCount; n := GetCount; SetCount(n+aCount); PS := pointer(PtrUInt(DynArrayVar)+cardinal(aStartIndex)*ElemSize); PD := pointer(PtrUInt(fValue^)+cardinal(n)*ElemSize); if ElemType=nil then {$ifdef FPC}Move{$else}MoveFast{$endif}(PS^,PD^,cardinal(aCount)*ElemSize) else CopyArray(PD,PS,ElemType,aCount); end; procedure TDynArray.ElemClear(var Elem); begin if @Elem=nil then exit; // avoid GPF if ElemType<>nil then {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(@Elem,ElemType) else if (fIsObjArray=oaTrue) or ((fIsObjArray=oaUnknown) and ComputeIsObjArray) then TObject(Elem).Free; {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(Elem,ElemSize,0); // always end; function TDynArray.ElemLoad(Source: PAnsiChar): RawByteString; begin if (Source<>nil) and (ElemType=nil) then SetString(result,Source,ElemSize) else begin SetString(result,nil,ElemSize); {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(pointer(result)^,ElemSize,0); ElemLoad(Source,pointer(result)^); end; end; procedure TDynArray.ElemLoadClear(var ElemTemp: RawByteString); begin ElemClear(pointer(ElemTemp)); ElemTemp := ''; end; procedure TDynArray.ElemLoad(Source: PAnsiChar; var Elem); begin if Source<>nil then // avoid GPF if ElemType=nil then {$ifdef FPC}Move{$else}MoveFast{$endif}(Source^,Elem,ElemSize) else ManagedTypeLoad(@Elem,Source,ElemType); end; function TDynArray.ElemSave(const Elem): RawByteString; var itemsize: integer; begin if ElemType=nil then SetString(result,PAnsiChar(@Elem),ElemSize) else begin SetString(result,nil,ManagedTypeSaveLength(@Elem,ElemType,itemsize)); if result<>'' then ManagedTypeSave(@Elem,pointer(result),ElemType,itemsize); end; end; function TDynArray.ElemLoadFind(Source: PAnsiChar): integer; var tmp: array[0..2047] of byte; data: pointer; begin result := -1; if (Source=nil) or (ElemSize>SizeOf(tmp)) then exit; if ElemType=nil then data := Source else begin {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(tmp,ElemSize,0); ManagedTypeLoad(@tmp,Source,ElemType); if Source=nil then exit; data := @tmp; end; try if @fCompare=nil then result := IndexOf(data^) else result := Find(data^); finally if ElemType<>nil then {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(data,ElemType); end; end; function DynArray(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil): TDynArray; begin result.Init(aTypeInfo,aValue,aCountPointer); end; { TDynArrayHashed } const // marks a void entry in the hash table // -> code below will replace all hash value from 0 (HASH_VOID) // to 1 (HASH_ONVOIDCOLISION) HASH_VOID = 0; // marks a hash colision with a void entry in the hash table HASH_ONVOIDCOLISION = 1; // fHashsCount<=HASH_PO2 is expected to be a power of two (fast binary division) // -> 262,144 TSynHash slots = 2MB, for a TDynArray.Capacity of 131,072 items HASH_PO2 = 1 shl 18; {$ifdef UNDIRECTDYNARRAY} function TDynArrayHashed.GetCount: Integer; begin result := InternalDynArray.GetCount; end; procedure TDynArrayHashed.SetCount(aCount: integer); begin InternalDynArray.SetCount(aCount); end; function TDynArrayHashed.GetCapacity: Integer; begin result := InternalDynArray.Capacity; end; procedure TDynArrayHashed.SetCapacity(aCapacity: Integer); begin InternalDynArray.SetCapacity(aCapacity); end; function TDynArrayHashed.Value: PPointer; begin result := InternalDynArray.Value; end; function TDynArrayHashed.ElemSize: PtrUInt; begin result := InternalDynArray.ElemSize; end; function TDynArrayHashed.ElemType: Pointer; begin result := InternalDynArray.ElemType; end; procedure TDynArrayHashed.ElemCopy(const A; var B); begin InternalDynArray.ElemCopy(A,B); end; function TDynArrayHashed.ElemPtr(index: PtrInt): pointer; begin result := InternalDynArray.ElemPtr(index); end; procedure TDynArrayHashed.ElemCopyAt(index: PtrInt; var Dest); begin InternalDynArray.ElemCopyAt(index,Dest); end; function TDynArrayHashed.KnownType: TDynArrayKind; begin result := InternalDynArray.KnownType; end; procedure TDynArrayHashed.Clear; begin InternalDynArray.Clear; end; function TDynArrayHashed.Add(const Elem): integer; begin result := InternalDynArray.Add(Elem); end; procedure TDynArrayHashed.Delete(aIndex: PtrInt); begin InternalDynArray.Delete(aIndex); end; function TDynArrayHashed.SaveTo: RawByteString; begin result := InternalDynArray.SaveTo; end; function TDynArrayHashed.LoadFrom(Source: PAnsiChar): PAnsiChar; begin result := InternalDynArray.LoadFrom(Source); end; function TDynArrayHashed.SaveTo(Dest: PAnsiChar): PAnsiChar; begin result := InternalDynArray.SaveTo(Dest); end; function TDynArrayHashed.SaveToJSON(EnumSetsAsText: boolean; reformat: TTextWriterJSONFormat): RawUTF8; begin result := InternalDynArray.SaveToJSON(EnumSetsAsText,reformat); end; procedure TDynArrayHashed.Sort(aCompare: TDynArraySortCompare); begin InternalDynArray.Sort(aCompare); end; function TDynArrayHashed.LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil): PUTF8Char; begin result := InternalDynArray.LoadFromJSON(P,aEndOfObject); end; function TDynArrayHashed.SaveToLength: integer; begin result := InternalDynArray.SaveToLength; end; {$endif UNDIRECTDYNARRAY} function TDynArrayHashed.Scan(const Elem): integer; var P: PAnsiChar; n: integer; begin if Assigned(fEventCompare) then begin P := Value^; // Count O(n) is faster than O(1) n := {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}GetCount; for result := 0 to n-1 do if fEventCompare(P^,Elem)=0 then exit else inc(P,ElemSize); result := -1; end else result := {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}Find(Elem); end; function TDynArrayHashed.FindHashed(const Elem; aHashCode: cardinal): integer; begin if (fHashs<>nil) and Assigned(fHashElement) then begin if aHashCode=0 then aHashCode := fHashElement(Elem,fHasher); result := HashFindAndCompare(aHashCode,Elem); if result<0 then result := -1; // for coherency with most methods end else begin // Count=0) and (fHashCountTrigger>0) and ({$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCountP<>nil) and ({$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCountP^>4) then begin inc(fHashFindCount); if fHashFindCount>=fHashCountTrigger*2 then begin fHashCountTrigger := 0; // FindHashed() should use O(1) hash ReHash; end; end; end; end; procedure TDynArrayHashed.HashAdd(const Elem; aHashCode: Cardinal; var result: integer); var n,cap: integer; begin n := {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}GetCount; SetCount(n+1); // reserve space for a void element in array cap := Capacity; if cap*2-cap shr 3>=fHashsCount then {$ifdef UNDIRECTDYNARRAY}with InternalDynArray do{$endif} begin // fHashs[] is too small -> recreate if fCountP<>nil then dec(fCountP^); // ignore latest entry (which is not filled yet) ReHash; if fCountP<>nil then inc(fCountP^); result := HashFind(aHashCode,true); // fHashs[] has changed -> recompute assert(result<0); end; with fHashs[-result-1] do begin // HashFind returned negative index in fHashs[] Hash := aHashCode; Index := n; end; result := n; end; function TDynArrayHashed.FindHashedForAdding(const Elem; out wasAdded: boolean; aHashCode: cardinal): integer; var n: integer; begin n := {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}GetCount; if n for HashAdd() below result := HashFindAndCompare(aHashCode,Elem); if result>=0 then // found matching existing item wasAdded := false else begin // create a void element HashAdd(Elem,aHashCode,result); wasAdded := true; end; end; function TDynArrayHashed.AddAndMakeUniqueName(aName: RawUTF8): pointer; var ndx,j: integer; added: boolean; aName_: RawUTF8; begin if aName='' then aName := '_'; ndx := FindHashedForAdding(aName,added); if not added then begin // force unique column name aName_ := aName+'_'; j := 1; repeat aName := aName_+UInt32ToUTF8(j); ndx := FindHashedForAdding(aName,added); inc(j); until added; end; result := PAnsiChar(Value^)+cardinal(ndx)*ElemSize; PRawUTF8(result)^ := aName; // store unique name at 1st elem position end; function TDynArrayHashed.AddUniqueName(const aName: RawUTF8; const ExceptionMsg: RawUTF8; const ExceptionArgs: array of const): pointer; var ndx: integer; added: boolean; begin ndx := FindHashedForAdding(aName,added); if added then begin result := PAnsiChar(Value^)+cardinal(ndx)*ElemSize; PRawUTF8(result)^ := aName; // store unique name at 1st elem position end else if ExceptionMsg='' then raise ESynException.CreateUTF8('Duplicated "%" name',[aName]) else raise ESynException.CreateUTF8(ExceptionMsg,ExceptionArgs); end; function TDynArrayHashed.FindHashedAndFill(var ElemToFill): integer; begin if fHashs=nil then // Count=0 then ElemCopy((PAnsiChar(Value^)+cardinal(result)*ElemSize)^,ElemToFill); end; function TDynArrayHashed.FindHashedAndUpdate(const Elem; AddIfNotExisting: boolean): integer; var aHashCode: cardinal; label h; begin if fHashs=nil then begin // Count for HashAdd() below result := HashFindAndCompare(aHashCode,Elem); if result<0 then if AddIfNotExisting then begin // not existing -> add as new element HashAdd(Elem,aHashCode,result); // ReHash only if necessary ElemCopy(Elem,(PAnsiChar(Value^)+cardinal(result)*ElemSize)^); end else result := -1 else begin // copy from Elem into dynamic array found entry = Update ElemCopy(Elem,(PAnsiChar(Value^)+cardinal(result)*ElemSize)^); ReHash; // whole hash table should be re-created for next search end; end else result := -1; end; function TDynArrayHashed.FindHashedAndDelete(const Elem): integer; begin if fHashs=nil then begin // Count=0 then Delete(result); end else if Assigned(fHashElement) then begin result := HashFindAndCompare(fHashElement(Elem,fHasher),Elem); if result<0 then result := -1 else begin Delete(result); ReHash; // whole hash table should be re-created for next search end; end else result := -1; end; function HashAnsiString(const Elem; Hasher: THasher): cardinal; begin if PtrUInt(Elem)<>0 then result := Hasher(0,Pointer(PtrUInt(Elem)),{$ifdef FPC}_LStrLenP(pointer(Elem)) {$else}PInteger(PtrUInt(Elem)-SizeOf(integer))^{$endif}) else result := HASH_ONVOIDCOLISION; end; function HashAnsiStringI(const Elem; Hasher: THasher): cardinal; var tmp: array[byte] of AnsiChar; // avoid slow heap allocation begin if PtrUInt(Elem)=0 then result := HASH_ONVOIDCOLISION else result := Hasher(0,tmp,UpperCopy255Buf(tmp,pointer(Elem), {$ifdef FPC}_LStrLenP(pointer(Elem)) {$else}PInteger(PtrUInt(Elem)-SizeOf(integer))^{$endif})-tmp); end; {$ifdef UNICODE} function HashUnicodeString(const Elem; Hasher: THasher): cardinal; begin if PtrUInt(Elem)=0 then result := HASH_ONVOIDCOLISION else result := Hasher(0,Pointer(Elem),length(UnicodeString(Elem))*2); end; function HashUnicodeStringI(const Elem; Hasher: THasher): cardinal; var tmp: array[byte] of AnsiChar; // avoid slow heap allocation begin if PtrUInt(Elem)=0 then result := HASH_ONVOIDCOLISION else result := Hasher(0,tmp,UpperCopy255W(tmp,Pointer(Elem),length(UnicodeString(Elem)))-tmp); end; {$endif UNICODE} function HashSynUnicode(const Elem; Hasher: THasher): cardinal; begin if PtrUInt(Elem)=0 then result := HASH_ONVOIDCOLISION else result := Hasher(0,Pointer(Elem),length(SynUnicode(Elem))*2); end; function HashSynUnicodeI(const Elem; Hasher: THasher): cardinal; var tmp: array[byte] of AnsiChar; // avoid slow heap allocation begin if PtrUInt(Elem)=0 then result := HASH_ONVOIDCOLISION else result := Hasher(0,tmp,UpperCopy255W(tmp,SynUnicode(Elem))-tmp); end; function HashWideString(const Elem; Hasher: THasher): cardinal; begin // WideString internal size is in bytes, not WideChar if PtrUInt(Elem)=0 then result := HASH_ONVOIDCOLISION else result := Hasher(0,Pointer(Elem),Length(WideString(Elem))*2); end; function HashWideStringI(const Elem; Hasher: THasher): cardinal; var tmp: array[byte] of AnsiChar; // avoid slow heap allocation begin if PtrUInt(Elem)=0 then result := HASH_ONVOIDCOLISION else result := Hasher(0,tmp,UpperCopy255W(tmp,pointer(Elem),Length(WideString(Elem)))-tmp); end; function HashPtrUInt(const Elem; Hasher: THasher): cardinal; begin {$ifdef CPU64} result := Hasher(0,@Elem,SizeOf(PtrUInt)); {$else} result := (PtrUInt(Elem) shr 4)+1; // naive but optimal for TDynArrayHashed {$endif} end; function HashPointer(const Elem; Hasher: THasher): cardinal; begin result := Hasher(0,@Elem,SizeOf(pointer)); end; function HashByte(const Elem; Hasher: THasher): cardinal; begin result := Hasher(0,@Elem,SizeOf(byte)); end; function HashWord(const Elem; Hasher: THasher): cardinal; begin result := Hasher(0,@Elem,SizeOf(word)); end; function HashInteger(const Elem; Hasher: THasher): cardinal; begin result := Hasher(0,@Elem,SizeOf(integer)); end; function HashInt64(const Elem; Hasher: THasher): cardinal; begin result := Hasher(0,@Elem,SizeOf(Int64)); end; function Hash128(const Elem; Hasher: THasher): cardinal; begin result := Hasher(0,@Elem,SizeOf(THash128)); end; function Hash256(const Elem; Hasher: THasher): cardinal; begin result := Hasher(0,@Elem,SizeOf(THash256)); end; function Hash512(const Elem; Hasher: THasher): cardinal; begin result := Hasher(0,@Elem,SizeOf(THash512)); end; {$ifndef NOVARIANTS} function VariantHash(const value: variant; CaseInsensitive: boolean; Hasher: THasher): cardinal; var Up: array[byte] of AnsiChar; // avoid heap allocation procedure ComplexType; var tmp: RawUTF8; begin // slow but always working conversion to string VariantSaveJSON(value,twNone,tmp); if CaseInsensitive then result := Hasher(TVarData(value).VType,Up,UpperCopy255(Up,tmp)-Up) else result := Hasher(TVarData(value).VType,pointer(tmp),length(tmp)); end; begin if not Assigned(Hasher) then Hasher := @crc32c; with TVarData(value) do case VType of varNull, varEmpty: result := VType+2; // not 0 (HASH_VOID) nor 1 (HASH_ONVOIDCOLISION) varShortInt, varByte: result := Hasher(VType,@VByte,1); varSmallint, varWord, varBoolean: result := Hasher(VType,@VWord,2); varLongWord, varInteger, varSingle: result := Hasher(VType,@VLongWord,4); varInt64, varDouble, varDate, varCurrency, varWord64: result := Hasher(VType,@VInt64,SizeOf(Int64)); varString: if CaseInsensitive then result := Hasher(0,Up,UpperCopy255Buf(Up,VString,length(RawUTF8(VString)))-Up) else result := Hasher(0,VString,length(RawUTF8(VString))); varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: if CaseInsensitive then result := Hasher(0,Up,UpperCopy255W(Up,VOleStr,StrLenW(VOleStr))-Up) else result := Hasher(0,VAny,StrLenW(VOleStr)*2); else ComplexType; end; end; function HashVariant(const Elem; Hasher: THasher): cardinal; begin result := VariantHash(variant(Elem),false,Hasher); end; function HashVariantI(const Elem; Hasher: THasher): cardinal; begin result := VariantHash(variant(Elem),true,Hasher); end; {$endif NOVARIANTS} procedure TDynArrayHashed.InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind; aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false); var Comp: TDynArraySortCompare; Hasher: TDynArrayHashOne; begin Comp := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,aKind]; Hasher := DYNARRAY_HASHFIRSTFIELD[aCaseInsensitive,aKind]; if (@Hasher=nil) or (@Comp=nil) then raise ESynException.CreateUTF8('TDynArrayHashed.InitSpecific unsupported %', [ToText(aKind)^]); Init(aTypeInfo,aValue,Hasher,Comp,nil,aCountPointer,aCaseInsensitive); {$ifdef UNDIRECTDYNARRAY}with InternalDynArray do{$endif} begin fKnownType := aKind; fKnownSize := KNOWNTYPE_SIZE[aKind]; end; end; procedure TDynArrayHashed.Init(aTypeInfo: pointer; var aValue; aHashElement: TDynArrayHashOne; aCompare: TDynArraySortCompare; aHasher: THasher; aCountPointer: PInteger; aCaseInsensitive: boolean); var aKind: TDynArrayKind; begin {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$else}inherited{$endif} Init(aTypeInfo,aValue,aCountPointer); fEventCompare := nil; fEventHash := nil; if @aHasher=nil then fHasher := DefaultHasher else fHasher := aHasher; if (@aHashElement=nil) or (@aCompare=nil) then begin // it's faster to retrieve now the hashing/compare function than in HashOne aKind := {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}ToKnownType; if @aHashElement=nil then aHashElement := DYNARRAY_HASHFIRSTFIELD[aCaseInsensitive,aKind]; if @aCompare=nil then aCompare := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,aKind]; end; fHashElement := aHashElement; {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare := aCompare; fHashCountTrigger := 32; fHashs := nil; // = HashInvalidate; fHashFindCount := 0; end; procedure TDynArrayHashed.HashInvalidate; begin fHashs := nil; fHashFindCount := 0; end; //var TDynArrayHashedCollisionCount: cardinal; function TDynArrayHashed.HashFind(aHashCode: cardinal; aForAdd: boolean): integer; var first,last: integer; h: cardinal; P: PAnsiChar; begin if fHashs=nil then begin // Count=0 or Count binary div result := (aHashCode-1) and (fHashsCount-1) else result := (aHashCode-1) mod cardinal(fHashsCount); last := fHashsCount; first := result; repeat with fHashs[result] do if (Hash=aHashCode) and not aForAdd then begin result := Index; exit; end else if Hash=HASH_VOID then begin result := -(result+1); exit; // aForAdd or not found -> returns void index in fHashs[] as negative end; inc(result); // try next entry on hash collision if result=last then // reached the end -> search once from fHash[0] to fHash[first-1] if result=first then break else begin result := 0; last := first; end; until false; RaiseFatalCollision('HashFind',aHashCode); end; function TDynArrayHashed.HashFindAndCompare(aHashCode: cardinal; const Elem): integer; var first,last: integer; P: PAnsiChar; begin if fHashs=nil then begin // e.g. Count binary div result := (aHashCode-1) and (fHashsCount-1) else result := (aHashCode-1) mod cardinal(fHashsCount); last := fHashsCount; first := result; repeat with fHashs[result] do if Hash=aHashCode then begin P := PAnsiChar(Value^)+Index*ElemSize; if not Assigned(fEventCompare) then if @{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare<>nil then begin if {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare(P^,Elem)=0 then begin result := Index; exit; // found -> returns index in dynamic array end; end else begin if {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}ElemEquals(P^,Elem) then begin result := Index; exit; // found end; end else if fEventCompare(P^,Elem)=0 then begin result := Index; exit; // found end; end else if Hash=HASH_VOID then begin result := -(result+1); exit; // not found -> returns void index in fHashs[] as negative end; // fHashs[Hash mod fHashsCount].Hash collision -> search next item {$ifdef DYNARRAYHASHCOLLISIONCOUNT} inc(fHashFindCollisions); {$endif} //inc(TDynArrayHashedCollisionCount); inc(result); if result=last then // reached the end -> search once from fHash[0] to fHash[first-1] if result=first then break else begin result := 0; last := first; end; until false; RaiseFatalCollision('HashFindAndCompare',aHashCode); end; procedure TDynArrayHashed.RaiseFatalCollision(const caller: RawUTF8; aHashCode: cardinal); begin {$ifdef UNDIRECTDYNARRAY}with InternalDynArray do{$endif} raise ESynException.CreateUTF8('TDynArrayHashed.% fatal collision: '+ 'aHashCode=% fHashsCount=% Count=% Capacity=% ArrayType=% fKnownType=%', [caller,CardinalToHexShort(aHashCode),fHashsCount,GetCount,GetCapacity, ArrayTypeShort^,ToText(fKnownType)^]); end; function TDynArrayHashed.GetHashFromIndex(aIndex: PtrInt): Cardinal; var P: pointer; begin if (cardinal(aIndex)>=cardinal(Count)) or (not Assigned(fHashElement) and not Assigned(fEventHash)) then result := 0 else begin // it's faster to rehash than to loop in fHashs[].Index values // and it will also work with Count0 then begin ReHash; for i := 0 to fHashsCount-1 do begin h := fHashs[i].Hash; if h=HASH_VOID then continue; result := fHashs[i].Index; for j := 0 to fHashsCount-1 do if (i<>j) and (fHashs[j].Hash=h) then exit; // found duplicate end; end; result := -1; end; function TDynArrayHashed.ReHash(forAdd: boolean): boolean; var i, n, cap, ndx: integer; P: PAnsiChar; aHashCode: cardinal; begin result := false; fHashs := nil; fHashsCount := 0; n := {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}GetCount; if not forAdd and ((n=0) or (nHASH_PO2 then // slightly slower lookup, but much less memory use fHashsCount := cap else begin fHashsCount := 256; // find nearest power of two for fast binary division while fHashsCount=0 means found exact duplicate of P^: shouldn't happen -> ignore with fHashs[-ndx-1] do begin Hash := aHashCode; Index := i; end; inc(P,ElemSize); end; result := true; end; { TObjectDynArrayWrapper } constructor TObjectDynArrayWrapper.Create(var aValue; aOwnObjects: boolean); begin fValue := @aValue; fOwnObjects := aOwnObjects; end; destructor TObjectDynArrayWrapper.Destroy; begin Clear; inherited; end; function TObjectDynArrayWrapper.Find(Instance: TObject): integer; begin for result := 0 to fCount-1 do if TObjectDynArray(fValue^)[result]=Instance then exit; result := -1; end; function TObjectDynArrayWrapper.Add(Instance: TObject): integer; var cap: integer; begin cap := length(TObjectDynArray(fValue^)); if cap<=fCount then SetLength(TObjectDynArray(fValue^),NextGrow(cap)); result := fCount; TObjectDynArray(fValue^)[result] := Instance; inc(fCount); end; procedure TObjectDynArrayWrapper.Delete(Index: integer); begin if cardinal(Index)>=cardinal(fCount) then exit; // avoid Out of range if fOwnObjects then TObjectDynArray(fValue^)[Index].Free; dec(fCount); if fCount>Index then {$ifdef FPC}Move{$else}MoveFast{$endif}( TObjectDynArray(fValue^)[Index+1],TObjectDynArray(fValue^)[Index], (fCount-Index)*SizeOf(pointer)); end; procedure TObjectDynArrayWrapper.Clear; var i: integer; begin if fValue^<>nil then begin if fOwnObjects then for i := fCount-1 downto 0 do try TObjectDynArray(fValue^)[i].Free; except on Exception do; end; TObjectDynArray(fValue^) := nil; // set capacity to 0 fCount := 0; end else if fCount>0 then raise ESynException.Create('You MUST define your IObjectDynArray field '+ 'BEFORE the corresponding dynamic array'); end; procedure TObjectDynArrayWrapper.Slice; begin SetLength(TObjectDynArray(fValue^),fCount); end; function TObjectDynArrayWrapper.Count: integer; begin result := fCount; end; function TObjectDynArrayWrapper.Capacity: integer; begin result := length(TObjectDynArray(fValue^)); end; procedure TObjectDynArrayWrapper.Sort(Compare: TDynArraySortCompare); begin if (@Compare<>nil) and (fCount>0) then QuickSortPtr(0,fCount-1,Compare,fValue^); end; function NewSynLocker: PSynLocker; begin result := AllocMem(SizeOf(result^)); result^.Init; end; function PtrArrayAdd(var aPtrArray; aItem: pointer): integer; var a: TPointerDynArray absolute aPtrArray; begin result := length(a); SetLength(a,result+1); a[result] := aItem; end; function PtrArrayAddOnce(var aPtrArray; aItem: pointer): integer; var a: TPointerDynArray absolute aPtrArray; n: integer; begin n := length(a); result := PtrUIntScanIndex(pointer(a),n,PtrUInt(aItem)); if result>=0 then exit; SetLength(a,n+1); a[n] := aItem; result := n; end; function PtrArrayDelete(var aPtrArray; aItem: pointer): integer; var a: TPointerDynArray absolute aPtrArray; n: integer; begin n := length(a); result := PtrUIntScanIndex(pointer(a),n,PtrUInt(aItem)); if result<0 then exit; dec(n); if n>result then {$ifdef FPC}Move{$else}MoveFast{$endif}( a[result+1],a[result],(n-result)*SizeOf(pointer)); SetLength(a,n); end; function PtrArrayFind(var aPtrArray; aItem: pointer): integer; var a: TPointerDynArray absolute aPtrArray; begin result := PtrUIntScanIndex(pointer(a),length(a),PtrUInt(aItem)); end; { wrapper functions to T*ObjArr types } function ObjArrayAdd(var aObjArray; aItem: TObject): PtrInt; var a: TObjectDynArray absolute aObjArray; begin result := length(a); SetLength(a,result+1); a[result] := aItem; end; function ObjArrayAppend(var aDestObjArray, aSourceObjArray): PtrInt; var n: PtrInt; s: TObjectDynArray absolute aSourceObjArray; d: TObjectDynArray absolute aDestObjArray; begin result := length(d); n := length(s); SetLength(d,result+n); {$ifdef FPC}Move{$else}MoveFast{$endif}(s[0],d[result],n*SizeOf(pointer)); s := nil; // s[] will be owned by d[] inc(result,n); end; function ObjArrayAddCount(var aObjArray; aItem: TObject; var aObjArrayCount: integer): PtrInt; var a: TObjectDynArray absolute aObjArray; begin result := aObjArrayCount; if result=length(a) then SetLength(a,NextGrow(result)); a[result] := aItem; inc(aObjArrayCount); end; procedure ObjArrayAddOnce(var aObjArray; aItem: TObject); var a: TObjectDynArray absolute aObjArray; n: PtrInt; begin n := length(a); if not PtrUIntScanExists(pointer(a),n,PtrUInt(aItem)) then begin SetLength(a,n+1); a[n] := aItem; end; end; procedure ObjArraySetLength(var aObjArray; aLength: integer); begin SetLength(TObjectDynArray(aObjArray),aLength); end; function ObjArrayFind(const aObjArray; aItem: TObject): PtrInt; begin result := PtrUIntScanIndex(pointer(aObjArray), length(TObjectDynArray(aObjArray)),PtrUInt(aItem)); end; function ObjArrayCount(const aObjArray): integer; var i: PtrInt; a: TObjectDynArray absolute aObjArray; begin result := 0; for i := 0 to length(a)-1 do if a[i]<>nil then inc(result); end; procedure ObjArrayDelete(var aObjArray; aItemIndex: PtrInt; aContinueOnException: boolean); var n: PtrInt; a: TObjectDynArray absolute aObjArray; begin n := length(a); if cardinal(aItemIndex)>=cardinal(n) then exit; // out of range if aContinueOnException then try a[aItemIndex].Free; except end else a[aItemIndex].Free; dec(n); if n>aItemIndex then {$ifdef FPC}Move{$else}MoveFast{$endif}( a[aItemIndex+1],a[aItemIndex],(n-aItemIndex)*SizeOf(TObject)); SetLength(a,n); end; function ObjArrayDelete(var aObjArray; aItem: TObject): PtrInt; begin result := ObjArrayFind(aObjArray,aItem); if result>=0 then ObjArrayDelete(aObjArray,result); end; procedure ObjArraySort(var aObjArray; Compare: TDynArraySortCompare); begin if @Compare<>nil then QuickSortPtr(0,length(TObjectDynArray(aObjArray))-1,Compare,pointer(aObjArray)); end; procedure RawObjectsClear(o: PObject; n: integer); var i: integer; begin for i := 1 to n do begin if o^<>nil then // inlined o^.Free o^.Destroy; inc(o); end; end; procedure ObjArrayClear(var aObjArray); var a: TObjectDynArray absolute aObjArray; begin if a=nil then exit; RawObjectsClear(pointer(aObjArray),length(a)); a := nil; end; procedure ObjArrayClear(var aObjArray; aCount: integer); var a: TObjectDynArray absolute aObjArray; n: integer; begin n := length(a); if n=0 then exit; if n>aCount then aCount := n; RawObjectsClear(pointer(aObjArray),aCount); a := nil; end; procedure ObjArrayClear(var aObjArray; aContinueOnException: boolean); var n,i: PtrInt; a: TObjectDynArray absolute aObjArray; begin n := length(a); if n=0 then exit; if aContinueOnException then for i := 0 to n-1 do try a[i].Free; except end else RawObjectsClear(pointer(a),n); a := nil; end; function ObjArrayToJSON(const aObjArray; aOptions: TTextWriterWriteObjectOptions): RawUTF8; var temp: TTextWriterStackBuffer; begin with DefaultTextWriterJSONClass.CreateOwnedStream(temp) do try if woEnumSetsAsText in aOptions then CustomOptions := CustomOptions+[twoEnumSetsAsTextInRecord]; AddObjArrayJSON(aObjArray,aOptions); SetText(result); finally Free; end; end; procedure ObjArrayObjArrayClear(var aObjArray); var i: PtrInt; a: TPointerDynArray absolute aObjArray; begin if a<>nil then begin for i := 0 to length(a)-1 do ObjArrayClear(a[i]); a := nil; end; end; procedure ObjArraysClear(const aObjArray: array of pointer); var i: PtrInt; begin for i := 0 to high(aObjArray) do if aObjArray[i]<>nil then ObjArrayClear(aObjArray[i]^); end; {$ifndef DELPHI5OROLDER} function InterfaceArrayAdd(var aInterfaceArray; const aItem: IUnknown): PtrInt; var a: TInterfaceDynArray absolute aInterfaceArray; begin result := length(a); SetLength(a,result+1); a[result] := aItem; end; procedure InterfaceArrayAddOnce(var aInterfaceArray; const aItem: IUnknown); var a: TInterfaceDynArray absolute aInterfaceArray; n: PtrInt; begin if PtrUIntScanExists(pointer(aInterfaceArray), length(TInterfaceDynArray(aInterfaceArray)),PtrUInt(aItem)) then exit; n := length(a); SetLength(a,n+1); a[n] := aItem; end; function InterfaceArrayFind(const aInterfaceArray; const aItem: IUnknown): PtrInt; begin result := PtrUIntScanIndex(pointer(aInterfaceArray), length(TInterfaceDynArray(aInterfaceArray)),PtrUInt(aItem)); end; procedure InterfaceArrayDelete(var aInterfaceArray; aItemIndex: PtrInt); var n: PtrInt; a: TInterfaceDynArray absolute aInterfaceArray; begin n := length(a); if PtrUInt(aItemIndex)>=PtrUInt(n) then exit; // out of range a[aItemIndex] := nil; dec(n); if n>aItemIndex then {$ifdef FPC}Move{$else}MoveFast{$endif}( a[aItemIndex+1],a[aItemIndex],(n-aItemIndex)*SizeOf(IInterface)); TPointerDynArray(aInterfaceArray)[n] := nil; // avoid GPF in SetLength() SetLength(a,n); end; function InterfaceArrayDelete(var aInterfaceArray; const aItem: IUnknown): PtrInt; begin result := InterfaceArrayFind(aInterfaceArray,aItem); if result>=0 then InterfaceArrayDelete(aInterfaceArray,result); end; {$endif DELPHI5OROLDER} { TObjectHash } const COUNT_TO_START_HASHING = 16; function TObjectHash.Find(Item: TObject): integer; var n: integer; begin n := Count; if n<=COUNT_TO_START_HASHING then result := Scan(Item,n) else result := HashFind(Hash(Item),Item); end; function TObjectHash.Scan(Item: TObject; ListCount: integer): integer; begin for result := 0 to ListCount-1 do if Compare(Get(result),Item) then exit; result := -1; end; function TObjectHash.HashFind(aHashCode: cardinal; Item: TObject): integer; var n, first: integer; looped: boolean; begin looped := false; if fHashs=nil then HashInit(Count); n := length(fHashs); result := (aHashCode-1) and (n-1); // fHashs[] has a power of 2 length first := result; repeat with fHashs[result] do if Hash=aHashCode then begin if Compare(Get(Index),Item) then begin result := Index; exit; // found -> returns index in list end; end else if Hash=0 then begin result := -(result+1); exit; // not found -> returns void index in fHashs[] as negative end; // hash colision -> search next item inc(result); if result=n then // reached the end -> search once from fHash[0] to fHash[first-1] if looped then Break else begin result := 0; n := first; looped := true; end; until false; raise ESynException.CreateUTF8('%.HashFind fatal collision',[self]); end; procedure TObjectHash.HashInit(aCountToHash: integer); var PO2,i,ndx: integer; H: cardinal; O: TObject; begin assert(fHashs=nil); // find nearest power of two for new fHashs[] size PO2 := 256; while PO2=0 then raise ESynException.CreateUTF8('%.HashInit found dup at index %',[self,ndx]); with fHashs[-ndx-1] do begin Hash := H; Index := i; end; end; end; procedure TObjectHash.Invalidate; begin fHashs := nil; // force HashInit call on next Find() end; function TObjectHash.EnsureJustAddedNotDuplicated: boolean; var H: cardinal; lastNdx,ndx: integer; lastObject: TObject; begin lastNdx := Count-1; lastObject := Get(lastNdx); if lastObject=nil then raise ESynException.CreateUTF8('Invalid %.EnsureJustAddedNotDuplicated call',[self]); if lastNdxlength(fHashs) then begin fHashs := nil; HashInit(lastNdx); // re-compute fHashs up to Count-1 if not enough void positions end; H := Hash(lastObject); ndx := HashFind(H,lastObject); if ndx>=0 then begin result := false; // duplicate found exit; end; with fHashs[-ndx-1] do begin Hash := H; Index := lastNdx; end; result := true; // last inserted item is OK end; { TInterfacedObjectWithCustomCreate } constructor TInterfacedObjectWithCustomCreate.Create; begin // nothing to do by default - overridden constructor may add custom code end; procedure TInterfacedObjectWithCustomCreate.RefCountUpdate(Release: boolean); begin if Release then _Release else _AddRef; end; { TAutoLock } type /// used by TAutoLocker.ProtectMethod and TSynLocker.ProtectMethod TAutoLock = class(TInterfacedObject) protected fLock: PSynLocker; public constructor Create(aLock: PSynLocker); destructor Destroy; override; end; constructor TAutoLock.Create(aLock: PSynLocker); begin fLock := aLock; fLock^.Lock; end; destructor TAutoLock.Destroy; begin fLock^.UnLock; end; { TSynLocker } procedure TSynLocker.Init; begin fSectionPadding := 0; InitializeCriticalSection(fSection); PaddingMaxUsedIndex := -1; fLocked := false; fInitialized := true; end; procedure TSynLocker.Done; var i: integer; begin for i := 0 to PaddingMaxUsedIndex do if Padding[i].VType<>varUnknown then VarClear(variant(Padding[i])); DeleteCriticalSection(fSection); fInitialized := false; end; procedure TSynLocker.DoneAndFreeMem; begin Done; FreeMem(@self); end; procedure TSynLocker.Lock; begin EnterCriticalSection(fSection); fLocked := true; end; procedure TSynLocker.UnLock; begin fLocked := false; LeaveCriticalSection(fSection); end; function TSynLocker.TryLock: boolean; begin result := not fLocked and (TryEnterCriticalSection(fSection){$ifdef LINUX}{$ifdef FPC}<>0{$endif}{$endif}); end; function TSynLocker.TryLockMS(retryms: integer): boolean; begin repeat result := TryLock; if result or (retryms <= 0) then break; SleepHiRes(1); dec(retryms); until false; end; function TSynLocker.ProtectMethod: IUnknown; begin result := TAutoLock.Create(@self); end; {$ifndef NOVARIANTS} function TSynLocker.GetVariant(Index: integer): Variant; begin if (Index>=0) and (Index<=PaddingMaxUsedIndex) then // PaddingMaxUsedIndex may be -1 try EnterCriticalSection(fSection); fLocked := true; result := variant(Padding[Index]); finally fLocked := false; LeaveCriticalSection(fSection); end else VarClear(result); end; procedure TSynLocker.SetVariant(Index: integer; const Value: Variant); begin if cardinal(Index)<=high(Padding) then try EnterCriticalSection(fSection); fLocked := true; if Index>PaddingMaxUsedIndex then PaddingMaxUsedIndex := Index; variant(Padding[Index]) := Value; finally fLocked := false; LeaveCriticalSection(fSection); end; end; function TSynLocker.GetInt64(Index: integer): Int64; begin if (Index>=0) and (Index<=PaddingMaxUsedIndex) then try EnterCriticalSection(fSection); fLocked := true; if not VariantToInt64(variant(Padding[index]),result) then result := 0; finally fLocked := false; LeaveCriticalSection(fSection); end else result := 0; end; procedure TSynLocker.SetInt64(Index: integer; const Value: Int64); begin SetVariant(Index,Value); end; function TSynLocker.GetBool(Index: integer): boolean; begin if (Index>=0) and (Index<=PaddingMaxUsedIndex) then try EnterCriticalSection(fSection); fLocked := true; if not VariantToBoolean(variant(Padding[index]),result) then result := false; finally fLocked := false; LeaveCriticalSection(fSection); end else result := false; end; procedure TSynLocker.SetBool(Index: integer; const Value: boolean); begin SetVariant(Index,Value); end; function TSynLocker.GetUnLockedInt64(Index: integer): Int64; begin if (Index<0) or (Index>PaddingMaxUsedIndex) or not VariantToInt64(variant(Padding[index]),result) then result := 0; end; procedure TSynLocker.SetUnlockedInt64(Index: integer; const Value: Int64); begin if cardinal(Index)<=high(Padding) then begin if Index>PaddingMaxUsedIndex then PaddingMaxUsedIndex := Index; variant(Padding[Index]) := Value; end; end; function TSynLocker.GetPointer(Index: integer): Pointer; begin if (Index>=0) and (Index<=PaddingMaxUsedIndex) then try EnterCriticalSection(fSection); fLocked := true; with Padding[index] do if VType=varUnknown then result := VUnknown else result := nil; finally fLocked := false; LeaveCriticalSection(fSection); end else result := nil; end; procedure TSynLocker.SetPointer(Index: integer; const Value: Pointer); begin if cardinal(Index)<=high(Padding) then try EnterCriticalSection(fSection); fLocked := true; if Index>PaddingMaxUsedIndex then PaddingMaxUsedIndex := Index; with Padding[index] do begin if VType<>varUnknown then begin VarClear(PVariant(@VType)^); VType := varUnknown; end; VUnknown := Value; end; finally fLocked := false; LeaveCriticalSection(fSection); end; end; function TSynLocker.GetUTF8(Index: integer): RawUTF8; var wasString: Boolean; begin if (Index>=0) and (Index<=PaddingMaxUsedIndex) then try EnterCriticalSection(fSection); fLocked := true; VariantToUTF8(variant(Padding[Index]),result,wasString); if not wasString then result := ''; finally fLocked := false; LeaveCriticalSection(fSection); end else result := ''; end; procedure TSynLocker.SetUTF8(Index: integer; const Value: RawUTF8); begin if cardinal(Index)<=high(Padding) then try EnterCriticalSection(fSection); fLocked := true; if Index>PaddingMaxUsedIndex then PaddingMaxUsedIndex := Index; RawUTF8ToVariant(Value,Padding[Index],varString); finally fLocked := false; LeaveCriticalSection(fSection); end; end; function TSynLocker.LockedInt64Increment(Index: integer; const Increment: Int64): Int64; begin if cardinal(Index)<=high(Padding) then try EnterCriticalSection(fSection); fLocked := true; result := 0; if Index<=PaddingMaxUsedIndex then VariantToInt64(variant(Padding[index]),result) else PaddingMaxUsedIndex := Index; variant(Padding[Index]) := Int64(result+Increment); finally fLocked := false; LeaveCriticalSection(fSection); end else result := 0; end; function TSynLocker.LockedExchange(Index: integer; const Value: Variant): Variant; begin if cardinal(Index)<=high(Padding) then try EnterCriticalSection(fSection); fLocked := true; with Padding[index] do begin if Index<=PaddingMaxUsedIndex then result := PVariant(@VType)^ else begin PaddingMaxUsedIndex := Index; VarClear(result); end; PVariant(@VType)^ := Value; end; finally fLocked := false; LeaveCriticalSection(fSection); end else VarClear(result); end; function TSynLocker.LockedPointerExchange(Index: integer; Value: pointer): pointer; begin if cardinal(Index)<=high(Padding) then try EnterCriticalSection(fSection); fLocked := true; with Padding[index] do begin if Index<=PaddingMaxUsedIndex then if VType=varUnknown then result := VUnknown else begin VarClear(PVariant(@VType)^); result := nil; end else begin PaddingMaxUsedIndex := Index; result := nil; end; VType := varUnknown; VUnknown := Value; end; finally fLocked := false; LeaveCriticalSection(fSection); end else result := nil; end; {$endif NOVARIANTS} { TInterfacedObjectLocked } constructor TInterfacedObjectLocked.Create; begin inherited Create; fSafe := NewSynLocker; end; destructor TInterfacedObjectLocked.Destroy; begin inherited Destroy; fSafe^.DoneAndFreeMem; end; { TPersistentWithCustomCreate } constructor TPersistentWithCustomCreate.Create; begin // nothing to do by default - overridden constructor may add custom code end; { TSynPersistent } constructor TSynPersistent.Create; begin // nothing to do by default - overridden constructor may add custom code end; procedure TSynPersistent.AssignError(Source: TSynPersistent); var SourceName: string; begin if Source <> nil then SourceName := Source.ClassName else SourceName := 'nil'; raise EConvertError.CreateFmt('Cannot assign a %s to a %s', [SourceName, ClassName]); end; procedure TSynPersistent.AssignTo(Dest: TSynPersistent); begin Dest.AssignError(Self); end; procedure TSynPersistent.Assign(Source: TSynPersistent); begin if Source<>nil then Source.AssignTo(Self) else AssignError(nil); end; {$ifdef FPC_OR_PUREPASCAL} class function TSynPersistent.NewInstance: TObject; begin // bypass vmtIntfTable and vmt^.vInitTable (management operators) result := AllocMem(InstanceSize); // will zero memory PPointer(result)^ := pointer(self); // store VMT end; {$else} class function TSynPersistent.NewInstance: TObject; asm push eax // class mov eax, [eax].vmtInstanceSize push eax // size call System.@GetMem pop edx // size push eax // self mov cl, 0 call dword ptr[FillcharFast] pop eax // self pop edx // class mov [eax], edx // store VMT end; // TSynPersistent has no interface -> bypass vmtIntfTable procedure TSynPersistent.FreeInstance; asm push ebx mov ebx, eax @loop: mov ebx, [ebx] // handle three VMT levels per iteration mov edx, [ebx].vmtInitTable mov ebx, [ebx].vmtParent test edx, edx jnz @clr test ebx, ebx jz @end mov ebx, [ebx] mov edx, [ebx].vmtInitTable mov ebx, [ebx].vmtParent test edx, edx jnz @clr test ebx, ebx jz @end mov ebx, [ebx] mov edx, [ebx].vmtInitTable mov ebx, [ebx].vmtParent test edx, edx jnz @clr test ebx, ebx jnz @loop @end: pop ebx jmp System.@FreeMem // TSynPersistent has no TMonitor -> bypass TMonitor.Destroy(self) // BTW, TMonitor.Destroy is private, so unreachable @clr: push offset @loop // parent has never any vmtInitTable -> @loop jmp RecordClear // eax=self edx=typeinfo end; {$endif FPC_OR_PUREPASCAL} { TSynPersistentLock } constructor TSynPersistentLock.Create; begin inherited Create; fSafe := NewSynLocker; end; destructor TSynPersistentLock.Destroy; begin inherited Destroy; fSafe^.DoneAndFreeMem; end; { TObjectListSorted } destructor TObjectListSorted.Destroy; var i: integer; begin for i := 0 to fCount-1 do fObjArray[i].Free; inherited; end; function TObjectListSorted.FastLocate(const Value; out Index: Integer): boolean; var n, i, cmp: integer; begin result := False; n := Count; if n=0 then // a void array is always sorted Index := 0 else begin dec(n); if Compare(fObjArray[n],Value)<0 then begin // already sorted Index := n+1; // returns false + last position index to insert exit; end; Index := 0; while Index<=n do begin // O(log(n)) binary search of the sorted position i := (Index+n) shr 1; cmp := Compare(fObjArray[i],Value); if cmp=0 then begin Index := i; // index of existing Elem result := True; exit; end else if cmp<0 then Index := i+1 else n := i-1; end; // Elem not found: returns false + the index where to insert end; end; procedure TObjectListSorted.InsertNew(Item: TSynPersistentLock; Index: integer); begin if fCount=length(fObjArray) then SetLength(fObjArray,NextGrow(fCount)); if cardinal(Index)i then {$ifdef FPC}Move{$else}MoveFast{$endif}( fObjArray[i+1],fObjArray[i],(fCount-i)*SizeOf(TObject)); result := true; end; finally fSafe.UnLock; end; end; function TObjectListSorted.FindLocked(const Value): pointer; var i: integer; begin result := nil; fSafe.Lock; try if FastLocate(Value,i) then begin result := fObjArray[i]; TSynPersistentLock(result).Safe.Lock; end; finally fSafe.UnLock; end; end; function TObjectListSorted.FindOrAddLocked(const Value; out added: boolean): pointer; var i: integer; begin added := false; fSafe.Lock; try if not FastLocate(Value,i) then begin InsertNew(NewItem(Value),i); added := true; end; result := fObjArray[i]; TSynPersistentLock(result).Safe.Lock; finally fSafe.UnLock; end; end; { ****************** text buffer and JSON functions and classes ********* } { TTextWriter } procedure TTextWriter.CancelLastChar; begin if B>=fTempBuf then // Add() methods append at B+1 dec(B); end; function TTextWriter.LastChar: AnsiChar; begin if B>=fTempBuf then result := B^ else result := #0; // returns #0 if no char has been written yet end; procedure TTextWriter.CancelLastChar(aCharToCancel: AnsiChar); begin if (B>=fTempBuf) and (B^=aCharToCancel) then dec(B); end; function TTextWriter.PendingBytes: PtrUInt; begin result := B-fTempBuf+1; end; procedure TTextWriter.CancelLastComma; begin if (B>=fTempBuf) and (B^=',') then dec(B); end; procedure TTextWriter.Add(Value: PtrInt); var tmp: array[0..23] of AnsiChar; P: PAnsiChar; Len: integer; begin if BEnd-B<=16 then FlushToStream; if PtrUInt(Value)<=high(SmallUInt32UTF8) then begin P := pointer(SmallUInt32UTF8[Value]); Len := {$ifdef FPC}_LStrLenP(P){$else}PInteger(P-4)^{$endif}; end else begin P := StrInt32(@tmp[23],value); Len := @tmp[23]-P; end; {$ifdef FPC}Move{$else}MoveFast{$endif}(P[0],B[1],Len); inc(B,Len); end; procedure TTextWriter.AddCurr64(const Value: Int64); var tmp: array[0..31] of AnsiChar; P: PAnsiChar; Len: PtrUInt; begin if BEnd-B<=31 then FlushToStream; P := StrCurr64(@tmp[31],Value); Len := @tmp[31]-P; if Len>4 then if P[Len-1]='0' then if P[Len-2]='0' then if P[Len-3]='0' then if P[Len-4]='0' then dec(Len,5) else dec(Len,3) else dec(Len,2) else dec(Len); {$ifdef FPC}Move{$else}MoveFast{$endif}(P[0],B[1],Len); inc(B,Len); end; procedure TTextWriter.AddCurr64(const Value: currency); begin AddCurr64(PInt64(@Value)^); end; procedure TTextWriter.AddTimeLog(Value: PInt64); begin if BEnd-B<=31 then FlushToStream; inc(B,PTimeLogBits(Value)^.Text(B+1,true,'T')); end; procedure TTextWriter.AddUnixTime(Value: PInt64); begin // inlined UnixTimeToDateTime() AddDateTime(Value^/SecsPerDay+UnixDateDelta); end; procedure TTextWriter.AddUnixMSTime(Value: PInt64; WithMS: boolean); begin // inlined UnixMSTimeToDateTime() AddDateTime(Value^/MSecsPerDay+UnixDateDelta,WithMS); end; procedure TTextWriter.AddDateTime(Value: PDateTime; FirstChar: AnsiChar; QuoteChar: AnsiChar; WithMS: boolean); begin if (Value^=0) and (QuoteChar=#0) then exit; if BEnd-B<=25 then FlushToStream; inc(B); if QuoteChar<>#0 then B^ := QuoteChar else dec(B); if Value^<>0 then begin inc(B); if trunc(Value^)<>0 then 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; dec(B); end; if QuoteChar<>#0 then begin inc(B); B^ := QuoteChar; end; end; procedure TTextWriter.AddDateTime(const Value: TDateTime; WithMS: boolean); begin if Value=0 then exit; if BEnd-B<=23 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); end; procedure TTextWriter.AddDateTimeMS(const Value: TDateTime; Expanded: boolean; FirstTimeChar: AnsiChar; const TZD: RawUTF8); var T: TSynSystemTime; begin if Value=0 then exit; T.FromDateTime(Value); Add(DTMS_FMT[Expanded], [UInt4DigitsToShort(T.Year), UInt2DigitsToShortFast(T.Month),UInt2DigitsToShortFast(T.Day),FirstTimeChar, UInt2DigitsToShortFast(T.Hour),UInt2DigitsToShortFast(T.Minute), UInt2DigitsToShortFast(T.Second),UInt3DigitsToShort(T.MilliSecond),TZD]); end; procedure TTextWriter.AddU(Value: cardinal); var tmp: array[0..23] of AnsiChar; P: PAnsiChar; Len: integer; begin if BEnd-B<=24 then FlushToStream; if Value<=high(SmallUInt32UTF8) then begin P := pointer(SmallUInt32UTF8[Value]); Len := {$ifdef FPC}_LStrLenP(P){$else}PInteger(P-4)^{$endif}; end else begin P := StrUInt32(@tmp[23],Value); Len := @tmp[23]-P; end; {$ifdef FPC}Move{$else}MoveFast{$endif}(P[0],B[1],Len); inc(B,Len); end; procedure TTextWriter.AddQ(Value: QWord); var tmp: array[0..23] of AnsiChar; V: Int64Rec absolute Value; P: PAnsiChar; Len: integer; begin if BEnd-B<=32 then FlushToStream; if (V.Hi=0) and (V.Lo<=high(SmallUInt32UTF8)) then begin P := pointer(SmallUInt32UTF8[V.Lo]); Len := {$ifdef FPC}_LStrLenP(P){$else}PInteger(P-4)^{$endif}; end else begin P := StrUInt64(@tmp[23],Value); Len := @tmp[23]-P; end; {$ifdef FPC}Move{$else}MoveFast{$endif}(P[0],B[1],Len); inc(B,Len); end; procedure TTextWriter.AddQHex(Value: QWord); begin AddBinToHexDisplayQuoted(@Value,SizeOf(Value)); end; procedure TTextWriter.Add(Value: Extended; precision: integer; noexp: boolean); var S: ShortString; begin if Value=0 then Add('0') else begin if noexp then S[0] := AnsiChar(ExtendedToStringNoExp(S,Value,precision)) else S[0] := AnsiChar(ExtendedToString(S,Value,precision)); case PInteger(@S)^ and $ffdfdfdf of // inlined ExtendedToStringNan() 3+ord('N')shl 8+ord('A')shl 16+ord('N')shl 24: AddShort(JSON_NAN[seNan]); 3+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24, 4+ord('+')shl 8+ord('I')shl 16+ord('N')shl 24: AddShort(JSON_NAN[seInf]); 4+ord('-')shl 8+ord('I')shl 16+ord('N')shl 24: AddShort(JSON_NAN[seNegInf]); else AddNoJSONEscape(@S[1],ord(S[0])); end; end; end; procedure TTextWriter.AddDouble(Value: double; noexp: boolean); begin if Value=0 then Add('0') else Add(Value,DOUBLE_PRECISION,noexp); end; procedure TTextWriter.AddSingle(Value: single; noexp: boolean); begin if Value=0 then Add('0') else Add(Value,SINGLE_PRECISION,noexp); end; {$ifndef CPU64} // Add(Value: PtrInt) already implemented it procedure TTextWriter.Add(Value: Int64); var tmp: array[0..23] of AnsiChar; P: PAnsiChar; Len: integer; begin if BEnd-B<=24 then FlushToStream; if Value<0 then begin P := StrUInt64(@tmp[23],-Value)-1; P^ := '-'; Len := @tmp[23]-P; end else if Value<=high(SmallUInt32UTF8) then begin P := pointer(SmallUInt32UTF8[Value]); Len := {$ifdef FPC}_LStrLenP(P){$else}PInteger(P-4)^{$endif}; end else begin P := StrUInt64(@tmp[23],Value); Len := @tmp[23]-P; end; {$ifdef FPC}Move{$else}MoveFast{$endif}(P[0],B[1],Len); inc(B,Len); end; {$endif CPU64} procedure TTextWriter.Add(Value: boolean); begin if Value then AddShort('true') else AddShort('false'); end; procedure TTextWriter.AddFloatStr(P: PUTF8Char); var L: cardinal; begin L := StrLen(P); if (L=0) or (L>30) then Add('0') else begin if BEnd-B<=31 then FlushToStream; inc(B); if PWord(P)^=ord('-')+ord('.')shl 8 then begin PWord(B)^ := ord('-')+ord('0')shl 8; // '-.3' -> '-0.3' inc(B,2); inc(P); dec(L); end else if P^='.' then begin B^ := '0'; // '.5' -> '0.5' inc(B); end; {$ifdef FPC}Move{$else}MoveFast{$endif}(P^,B^,L); inc(B,L-1); end; end; procedure TTextWriter.Add(c: AnsiChar); begin if B>=BEnd then FlushToStream; B[1] := c; inc(B); end; procedure TTextWriter.Add(c1, c2: AnsiChar); begin if BEnd-B<=1 then FlushToStream; B[1] := c1; B[2] := c2; inc(B,2); end; procedure TTextWriter.Add({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID); begin if BEnd-B<=36 then FlushToStream; GUIDToText(B+1,@guid); inc(B,36); end; procedure TTextWriter.AddCR; begin if BEnd-B<=1 then FlushToStream; PWord(B+1)^ := 13+10 shl 8; // CR + LF inc(B,2); end; procedure TTextWriter.AddEndOfLine(aLevel: TSynLogInfo=sllNone); var i: integer; begin if BEnd-B<=1 then FlushToStream; if twoEndOfLineCRLF in fCustomOptions then begin PWord(B+1)^ := 13+10 shl 8; // CR + LF inc(B,2); end else begin B[1] := #10; // LF inc(B); end; if fEchos<>nil then begin fEchoStart := EchoFlush; for i := length(fEchos)-1 downto 0 do // for MultiEventRemove() below try fEchos[i](self,aLevel,fEchoBuf); except // remove callback in case of exception during echoing in user code MultiEventRemove(fEchos,i); end; fEchoBuf := ''; end; end; procedure TTextWriter.AddCRAndIndent; var ntabs: cardinal; begin if B^=#9 then exit; // we most probably just added an indentation level ntabs := fHumanReadableLevel; if ntabs>=cardinal(fTempBufSize) then exit; // avoid buffer overflow if BEnd-B<=Integer(ntabs)+1 then FlushToStream; PWord(B+1)^ := 13+10 shl 8; // CR + LF {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(B[3],ntabs,9); // #9=tab inc(B,ntabs+2); end; procedure TTextWriter.AddChars(aChar: AnsiChar; aCount: integer); var n: integer; begin repeat n := BEnd-B; if aCount99 then PCardinal(B+1)^ := $3030+ord(',')shl 16 else // '00,' if overflow PCardinal(B+1)^ := TwoDigitLookupW[Value]+ord(',')shl 16; inc(B,3); end; procedure TTextWriter.Add4(Value: integer); begin if BEnd-B<=5 then FlushToStream; if cardinal(Value)>9999 then PCardinal(B+1)^ := $30303030 else // '0000,' if overflow YearToPChar(Value,B+1); inc(B,5); B^ := ','; end; procedure TTextWriter.AddCurrentLogTime(LocalTime: boolean); var time: TSynSystemTime; begin FromGlobalTime(LocalTime,time); time.AddLogTime(self); end; function Value3Digits(V: PtrUInt; P: PUTF8Char; W: PWordArray): PtrUInt; {$ifdef HASINLINE}inline;{$endif} begin result := V div 100; PWord(P+1)^ := W[V-result*100]; V := result; result := result div 10; P^ := AnsiChar(V-result*10+48); end; procedure TTextWriter.AddMicroSec(MS: cardinal); var W: PWordArray; begin // 00.000.000 if BEnd-B<=17 then FlushToStream; B[3] := '.'; B[7] := '.'; inc(B); W := @TwoDigitLookupW; MS := Value3Digits(Value3Digits(MS,B+7,W),B+3,W); if MS>99 then MS := 99; PWord(B)^:= W[MS]; inc(B,9); end; procedure TTextWriter.Add3(Value: integer); begin if BEnd-B<=4 then FlushToStream; if cardinal(Value)>999 then PCardinal(B+1)^ := $303030 else // '0000,' if overflow PCardinal(B+1)^ := TwoDigitLookupW[Value div 10]+ ord(Value mod 10+48)shl 16; inc(B,4); B^ := ','; end; procedure TTextWriter.AddCSVInteger(const Integers: array of Integer); var i: integer; begin if length(Integers)=0 then exit; for i := 0 to high(Integers) do begin Add(Integers[i]); Add(','); end; CancelLastComma; end; procedure TTextWriter.AddCSVDouble(const Doubles: array of double); var i: integer; begin if length(Doubles)=0 then exit; for i := 0 to high(Doubles) do begin AddDouble(Doubles[i]); Add(','); end; CancelLastComma; end; procedure TTextWriter.AddCSVUTF8(const Values: array of RawUTF8); var i: integer; begin if length(Values)=0 then exit; for i := 0 to high(Values) do begin Add('"'); AddJSONEscape(pointer(Values[i])); Add('"',','); end; CancelLastComma; end; procedure TTextWriter.AddCSVConst(const Values: array of const); var i: integer; begin if length(Values)=0 then exit; for i := 0 to high(Values) do begin AddJSONEscape(Values[i]); Add(','); end; CancelLastComma; end; procedure TTextWriter.Add(const Values: array of const); var i: Integer; begin for i := 0 to high(Values) do AddJSONEscape(Values[i]); end; procedure TTextWriter.WriteObject(Value: TObject; Options: TTextWriterWriteObjectOptions); var i: integer; begin if Value<>nil then if Value.InheritsFrom(Exception) then Add('{"%":"%"}',[Value.ClassType,Exception(Value).Message]) else if Value.InheritsFrom(TRawUTF8List) then with TRawUTF8List(Value) do begin self.Add('['); for i := 0 to Count-1 do begin self.Add('"'); self.AddJSONEscape(pointer(fList[i])); self.Add('"',','); end; self.CancelLastComma; self.Add(']'); exit; end else if Value.InheritsFrom(TStrings) then with TStrings(Value) do begin self.Add('['); for i := 0 to Count-1 do begin self.Add('"'); {$ifdef UNICODE} self.AddJSONEscapeW(pointer(Strings[i]),Length(Strings[i])); {$else} self.AddJSONEscapeAnsiString(Strings[i]); {$endif} self.Add('"',','); end; self.CancelLastComma; self.Add(']'); exit; end else if not(woFullExpand in Options) or not(Value.InheritsFrom(TList) {$ifndef LVCL} or Value.InheritsFrom(TCollection){$endif}) then Value := nil; if Value=nil then begin AddShort('null'); exit; end; Add('{'); AddInstanceName(Value,':'); Add('['); if Value.InheritsFrom(TList) then for i := 0 to TList(Value).Count-1 do AddInstanceName(TList(Value).List[i],',') {$ifndef LVCL} else if Value.InheritsFrom(TCollection) then for i := 0 to TCollection(Value).Count-1 do AddInstanceName(TCollection(Value).Items[i],',') {$endif} ; CancelLastComma; Add(']','}'); end; function TTextWriter.InternalJSONWriter: TTextWriter; begin if fInternalJSONWriter=nil then fInternalJSONWriter := DefaultTextWriterJSONClass.CreateOwnedStream else fInternalJSONWriter.CancelAll; result := fInternalJSONWriter; end; procedure TTextWriter.AddJSONEscape(Source: TTextWriter); begin if Source.fTotalFileSize=0 then AddJSONEscape(Source.fTempBuf,Source.B-Source.fTempBuf+1) else AddJSONEscape(Pointer(Source.Text),0); end; procedure TTextWriter.AddNoJSONEscape(Source: TTextWriter); begin if Source.fTotalFileSize=0 then AddNoJSONEscape(Source.fTempBuf,Source.B-Source.fTempBuf+1) else AddNoJSONEscapeUTF8(Source.Text); end; procedure TTextWriter.AddRawJSON(const json: RawJSON); begin if json='' then AddShort('null') else AddNoJSONEscape(pointer(json),length(json)); end; procedure TTextWriter.WriteObjectAsString(Value: TObject; Options: TTextWriterWriteObjectOptions); begin Add('"'); InternalJSONWriter.WriteObject(Value,Options); AddJSONEscape(fInternalJSONWriter); Add('"'); end; class procedure TTextWriter.RegisterCustomJSONSerializer(aTypeInfo: pointer; aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); begin GlobalJSONCustomParsers.RegisterCallbacks(aTypeInfo,aReader,aWriter); end; class procedure TTextWriter.UnRegisterCustomJSONSerializer(aTypeInfo: pointer); begin GlobalJSONCustomParsers.RegisterCallbacks(aTypeInfo,nil,nil); end; {$ifndef NOVARIANTS} class procedure TTextWriter.RegisterCustomJSONSerializerForVariant( aClass: TCustomVariantType; aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); begin // here we register TCustomVariantTypeClass info instead of TypeInfo() GlobalJSONCustomParsers.RegisterCallbacksVariant(aClass,aReader,aWriter); end; class procedure TTextWriter.RegisterCustomJSONSerializerForVariantByType(aVarType: TVarType; aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); var aClass: TCustomVariantType; begin if FindCustomVariantType(aVarType,aClass) then RegisterCustomJSONSerializerForVariant(aClass,aReader,aWriter); end; {$endif NOVARIANTS} class function TTextWriter.RegisterCustomJSONSerializerFromText(aTypeInfo: pointer; const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; begin result := GlobalJSONCustomParsers.RegisterFromText(aTypeInfo,aRTTIDefinition); end; class procedure TTextWriter.RegisterCustomJSONSerializerFromText( const aTypeInfoTextDefinitionPairs: array of const); var n,i: integer; def: RawUTF8; begin n := length(aTypeInfoTextDefinitionPairs); if (n=0) or (n and 1=1) then exit; n := n shr 1; if n=0 then exit; for i := 0 to n-1 do if (aTypeInfoTextDefinitionPairs[i*2].VType<>vtPointer) or not VarRecToUTF8IsString(aTypeInfoTextDefinitionPairs[i*2+1],def) then raise ESynException.Create('RegisterCustomJSONSerializerFromText[?]') else GlobalJSONCustomParsers.RegisterFromText( aTypeInfoTextDefinitionPairs[i*2].VPointer,def); end; class function TTextWriter.RegisterCustomJSONSerializerSetOptions(aTypeInfo: pointer; aOptions: TJSONCustomParserSerializationOptions; aAddIfNotExisting: boolean): boolean; var ndx: integer; begin result := false; if aTypeInfo=nil then exit; case PTypeKind(aTypeInfo)^ of tkRecord{$ifdef FPC},tkObject{$endif}: ndx := GlobalJSONCustomParsers.RecordSearch(aTypeInfo,aAddIfNotExisting); tkDynArray: ndx := GlobalJSONCustomParsers.DynArraySearch(aTypeInfo,nil,aAddIfNotExisting); else exit; end; if (ndx>=0) and (GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser<>nil) then begin GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser.Options := aOptions; result := true; end; end; class function TTextWriter.RegisterCustomJSONSerializerSetOptions( const aTypeInfo: array of pointer; aOptions: TJSONCustomParserSerializationOptions; aAddIfNotExisting: boolean): boolean; var i: integer; begin result := true; for i := 0 to high(aTypeInfo) do if not RegisterCustomJSONSerializerSetOptions(aTypeInfo[i],aOptions) then result := false; end; class function TTextWriter.RegisterCustomJSONSerializerFindParser( aTypeInfo: pointer; aAddIfNotExisting: boolean=false): TJSONRecordAbstract; var ndx: integer; begin result := nil; if aTypeInfo=nil then exit; case PTypeKind(aTypeInfo)^ of tkRecord{$ifdef FPC},tkObject{$endif}: ndx := GlobalJSONCustomParsers.RecordSearch(aTypeInfo,aAddIfNotExisting); tkDynArray: ndx := GlobalJSONCustomParsers.DynArraySearch(aTypeInfo,nil,aAddIfNotExisting); else exit; end; if ndx>=0 then result := GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser; end; class procedure TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType( aTypeInfo: pointer; const aTypeName: RawUTF8); begin JSONSerializerFromTextSimpleTypeAdd(aTypeName,aTypeInfo,0,0); end; class procedure TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType( const aTypeInfos: array of pointer); var i: integer; begin for i := 0 to high(aTypeInfos) do RegisterCustomJSONSerializerFromTextSimpleType(aTypeInfos[i],''); end; class procedure TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType( aTypeInfo: pointer; aDataSize, aFieldSize: integer); begin JSONSerializerFromTextSimpleTypeAdd('',aTypeInfo,aDataSize,aFieldSize); end; class procedure TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType( const aTypeInfoDataFieldSize: array of const); var n,i: integer; s1,s2: Int64; begin n := length(aTypeInfoDataFieldSize); if n mod 3=0 then for i := 0 to (n div 3)-1 do if (aTypeInfoDataFieldSize[i*3].VType<>vtPointer) or not VarRecToInt64(aTypeInfoDataFieldSize[i*3+1],s1) or not VarRecToInt64(aTypeInfoDataFieldSize[i*3+2],s2) then raise ESynException.CreateUTF8('RegisterCustomJSONSerializerFromTextBinaryType[%]',[i]) else JSONSerializerFromTextSimpleTypeAdd('',aTypeInfoDataFieldSize[i*3].VPointer,s1,s2); end; procedure TTextWriter.AddRecordJSON(const Rec; TypeInfo: pointer); var customWriter: TDynArrayJSONCustomWriter; begin if (self=nil) or (@Rec=nil) or (TypeInfo=nil) or not(PTypeKind(TypeInfo)^ in tkRecordTypes) then raise ESynException.CreateUTF8('Invalid %.AddRecordJSON(%)',[self,TypeInfo]); if GlobalJSONCustomParsers.RecordSearch(TypeInfo,customWriter,nil) then customWriter(self,Rec) else WrRecord(Rec,TypeInfo); end; procedure TTextWriter.AddVoidRecordJSON(TypeInfo: pointer); var tmp: TBytes; info: PTypeInfo; begin info := GetTypeInfo(TypeInfo,tkRecordKinds); if (self=nil) or (info=nil) then raise ESynException.CreateUTF8('Invalid %.AddVoidRecordJSON(%)',[self,TypeInfo]); SetLength(tmp,info^.recSize {$ifdef FPC}and $7FFFFFFF{$endif}); AddRecordJSON(tmp[0],TypeInfo); end; {$ifndef NOVARIANTS} procedure TTextWriter.AddVariant(const Value: variant; Escape: TTextWriterKind); var CustomVariantType: TCustomVariantType; begin with TVarData(Value) do case VType of varEmpty, varNull: AddShort('null'); varSmallint: Add(VSmallint); varShortInt: Add(VShortInt); varByte: AddU(VByte); varWord: AddU(VWord); varLongWord: AddU(VLongWord); varInteger: Add(VInteger); varInt64: Add(VInt64); varWord64: AddQ(VInt64); varSingle: AddSingle(VSingle); varDouble: AddDouble(VDouble); varDate: AddDateTime(@VDate,'T','"'); varCurrency: AddCurr64(VInt64); varBoolean: Add(VBoolean); // 'true'/'false' varVariant: AddVariant(PVariant(VPointer)^,Escape); varString: begin if Escape=twJSONEscape then Add('"'); {$ifdef HASCODEPAGE} AddAnyAnsiString(RawByteString(VString),Escape); {$else} // VString is expected to be a RawUTF8 Add(VString,length(RawUTF8(VString)),Escape); {$endif} if Escape=twJSONEscape then Add('"'); end; varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin if Escape=twJSONEscape then Add('"'); AddW(VAny,0,Escape); if Escape=twJSONEscape then Add('"'); end; else if VType=varVariant or varByRef then AddVariant(PVariant(VPointer)^,Escape) else if VType=varByRef or varString then begin if Escape=twJSONEscape then Add('"'); {$ifdef HASCODEPAGE} AddAnyAnsiString(PRawByteString(VAny)^,Escape); {$else} // VString is expected to be a RawUTF8 Add(PPointer(VAny)^,length(PRawUTF8(VAny)^),Escape); {$endif} if Escape=twJSONEscape then Add('"'); end else if {$ifdef HASVARUSTRING}(VType=varByRef or varUString) or {$endif} (VType=varByRef or varOleStr) then begin if Escape=twJSONEscape then Add('"'); AddW(PPointer(VAny)^,0,Escape); if Escape=twJSONEscape then Add('"'); end else if FindCustomVariantType(VType,CustomVariantType) then if CustomVariantType.InheritsFrom(TSynInvokeableVariantType) then TSynInvokeableVariantType(CustomVariantType).ToJson(self,Value,Escape) else GlobalJSONCustomParsers.VariantWrite(CustomVariantType,self,Value,Escape) else raise ESynException.CreateUTF8('%.AddVariant VType=%',[self,ord(VType)]); end; end; {$endif NOVARIANTS} procedure TTextWriter.AddDynArrayJSON(var aDynArray: TDynArrayHashed); begin AddDynArrayJson(PDynArray(@aDynArray)^); end; procedure TTextWriter.AddDynArrayJSON(aTypeInfo: pointer; const aValue); var DynArray: TDynArray; begin DynArray.Init(aTypeInfo,pointer(@aValue)^); AddDynArrayJSON(DynArray); end; procedure TTextWriter.AddDynArrayJSONAsString(aTypeInfo: pointer; var aValue); begin Add('"'); InternalJSONWriter.AddDynArrayJSON(aTypeInfo,aValue); AddJSONEscape(fInternalJSONWriter); Add('"'); end; procedure TTextWriter.AddObjArrayJSON(const aObjArray; aOptions: TTextWriterWriteObjectOptions); var i: integer; a: TObjectDynArray absolute aObjArray; begin Add('['); for i := 0 to length(a)-1 do begin WriteObject(a[i],aOptions); Add(','); end; CancelLastComma; Add(']'); end; procedure TTextWriter.AddTypedJSON(aTypeInfo: pointer; const aValue); var max, i: Integer; PS: PShortString; customWriter: TDynArrayJSONCustomWriter; DynArray: TDynArray; procedure AddPS; overload; begin Add('"'); if twoTrimLeftEnumSets in fCustomOptions then AddTrimLeftLowerCase(PS) else AddShort(PS^); Add('"'); end; procedure AddPS(bool: boolean); overload; begin AddPS; Add(':'); Add(bool); end; begin case PTypeKind(aTypeInfo)^ of tkClass: WriteObject(TObject(aValue),[woFullExpand]); tkEnumeration: if twoEnumSetsAsBooleanInRecord in fCustomOptions then begin PS := GetEnumName(aTypeInfo,byte(aValue)); AddPS(true); end else if twoEnumSetsAsTextInRecord in fCustomOptions then begin PS := GetEnumName(aTypeInfo,byte(aValue)); AddPS; end else AddU(byte(aValue)); tkSet: if GetSetInfo(aTypeInfo,max,PS) then if twoEnumSetsAsBooleanInRecord in fCustomOptions then begin Add('{'); for i := 0 to max do begin AddPS(GetBitPtr(@aValue,i)); Add(','); inc(PByte(PS),ord(PS^[0])+1); // next short string end; CancelLastComma; Add('}'); end else if twoEnumSetsAsTextInRecord in fCustomOptions then begin Add('['); if (twoFullSetsAsStar in fCustomOptions) and GetAllBits(cardinal(aValue),max+1) then AddShort('"*"') else begin for i := 0 to max do begin if GetBitPtr(@aValue,i) then begin AddPS; Add(','); end; inc(PByte(PS),ord(PS^[0])+1); // next short string end; CancelLastComma; end; Add(']'); end else if max<8 then AddU(byte(aValue)) else if max<16 then AddU(word(aValue)) else if max<32 then AddU(cardinal(aValue)) else Add(Int64(aValue)) else AddShort('null'); tkRecord{$ifdef FPC},tkObject{$endif}: // inlined AddRecordJSON() if GlobalJSONCustomParsers.RecordSearch(aTypeInfo,customWriter,nil) then customWriter(self,aValue) else WrRecord(aValue,aTypeInfo); tkDynArray: begin DynArray.Init(aTypeInfo,(@aValue)^); AddDynArrayJSON(DynArray); end; {$ifndef NOVARIANTS} tkVariant: AddVariant(variant(aValue),twJSONEscape); {$endif} else AddShort('null'); end; end; function TTextWriter.AddJSONReformat(JSON: PUTF8Char; Format: TTextWriterJSONFormat; EndOfObject: PUTF8Char): PUTF8Char; var objEnd: AnsiChar; Name,Value: PUTF8Char; NameLen,ValueLen: integer; begin result := nil; if JSON=nil then exit; if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']); case JSON^ of '[': begin // array repeat inc(JSON) until not(JSON^ in [#1..' ']); if JSON^=']' then begin Add('['); inc(JSON); end else begin if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then AddCRAndIndent; inc(fHumanReadableLevel); Add('['); repeat if JSON=nil then exit; if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then AddCRAndIndent; JSON := AddJSONReformat(JSON,Format,@objEnd); if objEnd=']' then break; Add(objEnd); until false; dec(fHumanReadableLevel); if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then AddCRAndIndent; end; Add(']'); end; '{': begin // object repeat inc(JSON) until not(JSON^ in [#1..' ']); Add('{'); inc(fHumanReadableLevel); if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then AddCRAndIndent; if JSON^='}' then repeat inc(JSON) until not(JSON^ in [#1..' ']) else repeat Name := GetJSONPropName(JSON,@NameLen); if Name=nil then exit; if (Format in [jsonUnquotedPropName,jsonUnquotedPropNameCompact]) and JsonPropNameValid(Name) then AddNoJSONEscape(Name,NameLen) else begin Add('"'); AddJSONEscape(Name); Add('"'); end; if Format in [jsonCompact,jsonUnquotedPropNameCompact] then Add(':') else Add(':',' '); if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']); JSON := AddJSONReformat(JSON,Format,@objEnd); if objEnd='}' then break; Add(objEnd); if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then AddCRAndIndent; until false; dec(fHumanReadableLevel); if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then AddCRAndIndent; Add('}'); end; '"': begin // string Value := JSON; JSON := GotoEndOfJSONString(JSON); if JSON^<>'"' then exit; inc(JSON); AddNoJSONEscape(Value,JSON-Value); end; else begin // numeric or true/false/null Value := GetJSONField(JSON,result,nil,EndOfObject,@ValueLen); // let wasString=nil if Value=nil then AddShort('null') else begin while (ValueLen>0) and (Value[ValueLen-1]<=' ') do dec(ValueLen); AddNoJSONEscape(Value,ValueLen); end; exit; end; end; if JSON<>nil then begin if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']); if EndOfObject<>nil then EndOfObject^ := JSON^; if JSON^<>#0 then repeat inc(JSON) until not(JSON^ in [#1..' ']); end; result := JSON; end; function TTextWriter.AddJSONToXML(JSON: PUTF8Char; ArrayName: PUTF8Char=nil; EndOfObject: PUTF8Char=nil): PUTF8Char; var objEnd: AnsiChar; Name,Value: PUTF8Char; n,c: integer; begin result := nil; if JSON=nil then exit; if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']); case JSON^ of '[': begin repeat inc(JSON) until not(JSON^ in [#1..' ']); if JSON^=']' then JSON := GotoNextNotSpace(JSON+1) else begin n := 0; repeat if JSON=nil then exit; Add('<'); if ArrayName=nil then Add(n) else AddXmlEscape(ArrayName); Add('>'); JSON := AddJSONToXML(JSON,nil,@objEnd); Add('<','/'); if ArrayName=nil then Add(n) else AddXmlEscape(ArrayName); Add('>'); inc(n); until objEnd=']'; end; end; '{': begin repeat inc(JSON) until not(JSON^ in [#1..' ']); if JSON^='}' then repeat inc(JSON) until not(JSON^ in [#1..' ']) else repeat Name := GetJSONPropName(JSON); if Name=nil then exit; if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']); if JSON^='[' then // arrays are written as list of items, without root JSON := AddJSONToXML(JSON,Name,@objEnd) else begin Add('<'); AddXmlEscape(Name); Add('>'); JSON := AddJSONToXML(JSON,Name,@objEnd); Add('<','/'); AddXmlEscape(Name); Add('>'); end; until objEnd='}'; end; else begin Value := GetJSONField(JSON,result,nil,EndOfObject); // let wasString=nil if Value=nil then AddShort('null') else begin c := PInteger(Value)^ and $ffffff; if (c=JSON_BASE64_MAGIC) or (c=JSON_SQLDATE_MAGIC) then inc(Value,3); // just ignore the Magic codepoint encoded as UTF-8 AddXmlEscape(Value); end; exit; end; end; if JSON<>nil then begin if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']); if EndOfObject<>nil then EndOfObject^ := JSON^; if JSON^<>#0 then repeat inc(JSON) until not(JSON^ in [#1..' ']); end; result := JSON; end; procedure TTextWriter.AddDynArrayJSON(var aDynArray: TDynArray); var i,n: integer; P: Pointer; T: TDynArrayKind; tmp: RawByteString; customWriter: TDynArrayJSONCustomWriter; customParser: TJSONRecordAbstract; nested: TDynArray; hr: boolean; begin // code below must match TDynArray.LoadFromJSON n := aDynArray.Count-1; if n<0 then begin Add('[',']'); exit; end; if aDynArray.HasCustomJSONParser then with GlobalJSONCustomParsers.fParser[aDynArray.fParser] do begin customWriter := Writer; customParser := RecordCustomParser; end else begin customWriter := nil; customParser := nil; end; if Assigned(customWriter) then T := djCustom else T := aDynArray.ToKnownType({exacttype=}true); P := aDynArray.fValue^; Add('['); case T of djNone: if (aDynArray.ElemType<>nil) and (PTypeKind(aDynArray.ElemType)^=tkDynArray) then begin for i := 0 to n do begin nested.Init(aDynArray.ElemType,P^); AddDynArrayJSON(nested); Add(','); inc(PByte(P),aDynArray.ElemSize); end; end else begin tmp := aDynArray.SaveTo; WrBase64(pointer(tmp),length(tmp),{withMagic=}true); end; djCustom: begin if customParser=nil then hr := false else hr := soWriteHumanReadable in customParser.Options; if hr then Inc(fHumanReadableLevel); for i := 0 to n do begin customWriter(self,P^); Add(','); inc(PByte(P),aDynArray.ElemSize); end; if hr then begin dec(fHumanReadableLevel); CancelLastComma; AddCRAndIndent; end; end; {$ifndef NOVARIANTS} djVariant: for i := 0 to n do begin AddVariant(PVariantArray(P)^[i],twJSONEscape); Add(','); end; {$endif} djRawByteString: for i := 0 to n do begin WrBase64(PPointerArray(P)^[i],Length(PRawByteStringArray(P)^[i]),{withMagic=}true); Add(','); end; djTimeLog..djString,djWideString..djInterface: // add textual JSON content for i := 0 to n do begin Add('"'); case T of djTimeLog: AddTimeLog(@PInt64Array(P)^[i]); djDateTime: AddDateTime(@PDoubleArray(P)^[i],'T',#0,false); djDateTimeMS: AddDateTime(@PDoubleArray(P)^[i],'T',#0,true); djRawUTF8: AddJSONEscape(PPointerArray(P)^[i]); djWideString, djSynUnicode: AddJSONEscapeW(PPointerArray(P)^[i]); djWinAnsi: AddAnyAnsiString(PRawByteStringArray(P)^[i],twJSONEscape,CODEPAGE_US); djString: {$ifdef UNICODE} AddJSONEscapeW(PPointerArray(P)^[i]); {$else} AddAnyAnsiString(PRawByteStringArray(P)^[i],twJSONEscape,0); {$endif} djHash128: AddBinToHexDisplayLower(@PHash128Array(P)[i],SizeOf(THash128)); djHash256: AddBinToHexDisplayLower(@PHash256Array(P)[i],SizeOf(THash256)); djHash512: AddBinToHexDisplayLower(@PHash512Array(P)[i],SizeOf(THash512)); djInterface: AddPointer(PPtrIntArray(P)^[i]); end; Add('"',','); end; else // numerical JSON for i := 0 to n do begin case T of djBoolean: Add(PBooleanArray(P)^[i]); djByte: AddU(PByteArray(P)^[i]); djWord: AddU(PWordArray(P)^[i]); djInteger: Add(PIntegerArray(P)^[i]); djCardinal: AddU(PCardinalArray(P)^[i]); djSingle: AddSingle(PSingleArray(P)^[i]); djInt64: Add(PInt64Array(P)^[i]); djQWord: AddQ(PQWordArray(P)^[i]); djDouble: AddDouble(PDoubleArray(P)^[i]); djCurrency: AddCurr64(PInt64Array(P)^[i]); else raise ESynException.CreateUTF8('AddDynArrayJSON unsupported %',[ToText(T)^]); end; Add(','); end; end; CancelLastComma; Add(']'); end; procedure TTextWriter.Add(const Format: RawUTF8; const Values: array of const; Escape: TTextWriterKind; WriteObjectOptions: TTextWriterWriteObjectOptions); var ValuesIndex: integer; F: PUTF8Char; label write; begin // we put const char > #127 as #??? -> asiatic MBCS codepage OK if Format='' then exit; if (Format='%') and (high(Values)>=0) then begin Add(Values[0],Escape); exit; end; ValuesIndex := 0; F := pointer(Format); repeat repeat case ord(F^) of 0: exit; ord('%'): break; {$ifdef OLDTEXTWRITERFORMAT} 164: AddCR; // currency sign -> add CR,LF 167: if B^=',' then dec(B); // section sign to ignore next comma ord('|'): begin inc(F); // |% -> % goto write; end; ord('$'),163,181: // dollar, pound, micro sign break; // process command value {$endif} else begin write: if B>=BEnd then FlushToStream; B[1] := F^; inc(B); end; end; inc(F); until false; // add next value as text if ValuesIndex<=high(Values) then // missing value will display nothing case ord(F^) of ord('%'): Add(Values[ValuesIndex],Escape,WriteObjectOptions); {$ifdef OLDTEXTWRITERFORMAT} ord('$'): with Values[ValuesIndex] do if Vtype=vtInteger then Add2(VInteger); 163: with Values[ValuesIndex] do // pound sign if Vtype=vtInteger then Add4(VInteger); 181: with Values[ValuesIndex] do // micro sign if Vtype=vtInteger then Add3(VInteger); {$endif} end; inc(F); inc(ValuesIndex); until false; end; procedure TTextWriter.AddLine(const Text: shortstring); begin if BEnd-B<=ord(Text[0])+2 then FlushToStream; inc(B); {$ifdef FPC}Move{$else}MoveFast{$endif}(Text[1],B[0],ord(Text[0])); inc(B,ord(Text[0])); PWord(B)^ := 13+10 shl 8; // CR + LF inc(B); end; procedure TTextWriter.AddBinToHexDisplay(Bin: pointer; BinBytes: integer); begin if cardinal(BinBytes*2-1)>=cardinal(fTempBufSize) then exit; if BEnd-B<=BinBytes*2 then FlushToStream; BinToHexDisplay(Bin,PAnsiChar(B+1),BinBytes); inc(B,BinBytes*2); end; procedure TTextWriter.AddBinToHexDisplayLower(Bin: pointer; BinBytes: integer); begin if cardinal(BinBytes*2-1)>=cardinal(fTempBufSize) then exit; if BEnd-B<=BinBytes*2 then FlushToStream; BinToHexDisplayLower(Bin,PAnsiChar(B+1),BinBytes); inc(B,BinBytes*2); end; procedure TTextWriter.AddBinToHexDisplayQuoted(Bin: pointer; BinBytes: integer); begin if cardinal(BinBytes*2+2)>=cardinal(fTempBufSize) then exit; if BEnd-B<=BinBytes*2+2 then FlushToStream; B[1] := '"'; BinToHexDisplayLower(Bin,PAnsiChar(B+2),BinBytes); inc(B,BinBytes*2); B[2] := '"'; inc(B,2); end; procedure TTextWriter.AddBinToHexDisplayMinChars(Bin: pointer; BinBytes: PtrInt); begin if (BinBytes<=0) or (cardinal(BinBytes*2-1)>=cardinal(fTempBufSize)) then exit; repeat // append hexa chars up to the last non zero byte dec(BinBytes); until (BinBytes=0) or (PByteArray(Bin)[BinBytes]<>0); inc(BinBytes); if BEnd-B<=BinBytes*2 then FlushToStream; BinToHexDisplayLower(Bin,PAnsiChar(B+1),BinBytes); inc(B,BinBytes*2); end; procedure TTextWriter.AddPointer(P: PtrUInt); begin AddBinToHexDisplayMinChars(@P,SizeOf(P)); end; procedure TTextWriter.AddBinToHex(Bin: Pointer; BinBytes: integer); var ChunkBytes: PtrInt; begin if BinBytes<=0 then exit; if B>=BEnd then FlushToStream; inc(B); repeat // guess biggest size to be added into buf^ at once ChunkBytes := (BEnd-B) shr 1; // div 2, *2 -> two hexa chars per byte if BinBytes special one below: ChunkBytes := B-fTempBuf; fStream.WriteBuffer(fTempBuf^,ChunkBytes); inc(fTotalFileSize,ChunkBytes); B := fTempBuf; until false; dec(B); // allow CancelLastChar end; procedure TTextWriter.AddQuotedStr(Text: PUTF8Char; Quote: AnsiChar; TextMaxLen: integer); var BMax: PUTF8Char; begin BMax := BEnd-3; if B>=BMax then begin FlushToStream; BMax := BEnd-3; end; B[1] := Quote; inc(B); if Text<>nil then repeat if B0 then begin if TextMaxLen=3 then begin B[1] := '.'; // indicates truncated B[2] := '.'; B[3] := '.'; inc(B,3); break; end else dec(TextMaxLen); end; if Text^<>Quote then begin B[1] := Text^; inc(Text); inc(B); end else begin B[1] := Quote; B[2] := Quote; inc(B,2); inc(Text); end; end else begin FlushToStream; BMax := BEnd-2; end; until false; B[1] := Quote; inc(B); end; procedure TTextWriter.AddHtmlEscape(Text: PUTF8Char; Fmt: TTextWriterHTMLFormat); var i,beg: PtrInt; begin if Text=nil then exit; i := 0; repeat beg := i; case Fmt of hfAnyWhere: while true do if Text[i] in [#0,'&','"','<','>'] then break else inc(i); hfOutsideAttributes: while true do if Text[i] in [#0,'&','<','>'] then break else inc(i); hfWithinAttributes: while true do if Text[i] in [#0,'&','"'] then break else inc(i); end; AddNoJSONEscape(Text+beg,i-beg); repeat case Text[i] of #0: exit; '<': AddShort('<'); '>': AddShort('>'); '&': AddShort('&'); '"': AddShort('"'); else break; end; inc(i); until false; until false; end; procedure TTextWriter.AddHtmlEscape(Text: PUTF8Char; TextLen: integer; Fmt: TTextWriterHTMLFormat); var i,beg: PtrInt; begin if (Text=nil) or (TextLen<=0) then exit; i := 0; repeat beg := i; case Fmt of hfAnyWhere: while i'] then break else inc(i); hfOutsideAttributes: while i'] then break else inc(i); hfWithinAttributes: while i': AddShort('>'); '&': AddShort('&'); '"': AddShort('"'); else break; end; inc(i); until false; until false; end; procedure TTextWriter.AddHtmlEscapeString(const Text: string; Fmt: TTextWriterHTMLFormat); begin AddHtmlEscape(pointer(StringToUTF8(Text)),Fmt); end; procedure TTextWriter.AddHtmlEscapeUTF8(const Text: RawUTF8; Fmt: TTextWriterHTMLFormat); begin AddHtmlEscape(pointer(Text),length(Text),Fmt); end; procedure TTextWriter.AddHtmlEscapeWiki(P: PUTF8Char); var B: PUTF8Char; bold,italic: boolean; procedure Toggle(var value: Boolean; HtmlChar: AnsiChar); begin Add('<'); if value then Add('/'); Add(HtmlChar,'>'); value := not value; end; procedure EndOfParagraph; begin if bold then Toggle(bold,'B'); if italic then Toggle(italic,'I'); AddShort('

'); end; begin bold := false; italic := false; AddShort('

'); if P<>nil then repeat B := P; while not (ord(P^) in [0,13,10,ord('*'),ord('+')]) do if (P^='h') and IdemPChar(P+1,'TTP://') then break else inc(P); AddHtmlEscape(B,P-B,hfOutsideAttributes); case ord(P^) of 0: break; 10,13: begin EndOfParagraph; AddShort('

'); while P[1] in [#10,#13] do inc(P); end; ord('*'): Toggle(italic,'I'); ord('+'): Toggle(bold,'B'); ord('h'): begin B := P; while P^>' ' do inc(P); AddShort(''); AddHtmlEscape(B,P-B); AddShort(''); continue; end; end; inc(P); until P^=#0; EndOfParagraph; end; procedure TTextWriter.AddXmlEscape(Text: PUTF8Char); const XML_ESCAPE: TSynByteSet = [0..31,ord('<'),ord('>'),ord('&'),ord('"'),ord('''')]; var i,beg: PtrInt; begin if Text=nil then exit; i := 0; repeat beg := i; if not(ord(Text[i]) in XML_ESCAPE) then begin repeat // it is faster to handle all not-escaped chars at once inc(i); until ord(Text[i]) in XML_ESCAPE; AddNoJSONEscape(Text+beg,i-beg); end; repeat case Text[i] of #0: exit; #1..#8,#11,#12,#14..#31: ; // ignore invalid character - see http://www.w3.org/TR/xml/#NT-Char #9,#10,#13: begin // characters below ' ', #9 e.g. -> // ' ' AddShort('&#x'); AddByteToHex(ord(Text[i])); Add(';'); end; '<': AddShort('<'); '>': AddShort('>'); '&': AddShort('&'); '"': AddShort('"'); '''': AddShort('''); else break; // should match XML_ESCAPE[] constant above end; inc(i); until false; until false; end; procedure TTextWriter.AddReplace(Text: PUTF8Char; Orig,Replaced: AnsiChar); begin if Text<>nil then while Text^<>#0 do begin if Text^=Orig then Add(Replaced) else Add(Text^); inc(Text); end; end; procedure TTextWriter.AddByteToHex(Value: byte); begin if BEnd-B<=1 then FlushToStream; PWord(B+1)^ := TwoDigitsHexWB[Value]; inc(B,2); end; procedure TTextWriter.AddInt18ToChars3(Value: cardinal); begin if BEnd-B<=3 then FlushToStream; PCardinal(B+1)^ := ((Value shr 12) and $3f)+ ((Value shr 6) and $3f)shl 8+ (Value and $3f)shl 16+$202020; //assert(Chars3ToInt18(B+1)=Value); inc(B,3); end; function Int18ToChars3(Value: cardinal): RawUTF8; begin FastSetString(result,nil,3); PCardinal(result)^ := ((Value shr 12) and $3f)+ ((Value shr 6) and $3f)shl 8+ (Value and $3f)shl 16+$202020; end; procedure Int18ToChars3(Value: cardinal; var result: RawUTF8); begin FastSetString(result,nil,3); PCardinal(result)^ := ((Value shr 12) and $3f)+ ((Value shr 6) and $3f)shl 8+ (Value and $3f)shl 16+$202020; end; function Chars3ToInt18(P: pointer): cardinal; begin result := PCardinal(P)^-$202020; result := ((result shr 16)and $3f)+ ((result shr 8) and $3f)shl 6+ (result and $3f)shl 12; end; procedure TTextWriter.AddNoJSONEscape(P: Pointer); begin AddNoJSONEscape(P,StrLen(PUTF8Char(P))); end; procedure TTextWriter.AddNoJSONEscape(P: Pointer; Len: PtrInt); var i: PtrInt; begin if (P<>nil) and (Len>0) then begin inc(B); // allow CancelLastChar repeat i := BEnd-B+1; // guess biggest size to be added into buf^ at once if Len special one below: i := B-fTempBuf; fStream.WriteBuffer(fTempBuf^,i); inc(fTotalFileSize,i); B := fTempBuf; until false; dec(B); // allow CancelLastChar end; end; procedure TTextWriter.AddNoJSONEscapeUTF8(const text: RawByteString); begin AddNoJSONEscape(pointer(text),length(text)); end; procedure TTextWriter.AddNoJSONEscapeW(WideChar: PWord; WideCharCount: integer); var PEnd: PtrUInt; BMax: PUTF8Char; begin if WideChar=nil then exit; BMax := BEnd-7; // ensure enough space for biggest Unicode glyph as UTF-8 if WideCharCount=0 then repeat if B>=BMax then begin FlushToStream; BMax := BEnd-7; // B may have been resized -> recompute BMax end; if WideChar^=0 then break; if WideChar^<=126 then begin B[1] := AnsiChar(ord(WideChar^)); inc(WideChar); inc(B); end else inc(B,UTF16CharToUtf8(B+1,WideChar)); until false else begin PEnd := PtrUInt(WideChar)+PtrUInt(WideCharCount)*SizeOf(WideChar^); repeat if B>=BMax then begin FlushToStream; BMax := BEnd-7; end; if WideChar^=0 then break; if WideChar^<=126 then begin B[1] := AnsiChar(ord(WideChar^)); inc(WideChar); inc(B); if PtrUInt(WideChar)nil then case Escape of twNone: AddNoJSONEscape(P,StrLen(P)); twJSONEscape: AddJSONEscape(P); twOnSameLine: AddOnSameLine(P); end; end; procedure TTextWriter.Add(P: PUTF8Char; Len: PtrInt; Escape: TTextWriterKind); begin if P<>nil then case Escape of twNone: AddNoJSONEscape(P,Len); twJSONEscape: AddJSONEscape(P,Len); twOnSameLine: AddOnSameLine(P,Len); end; end; procedure TTextWriter.AddW(P: PWord; Len: PtrInt; Escape: TTextWriterKind); begin if P<>nil then case Escape of twNone: AddNoJSONEscapeW(P,Len); twJSONEscape: AddJSONEScapeW(P,Len); twOnSameLine: AddOnSameLineW(P,Len); end; end; procedure TTextWriter.AddAnsiString(const s: AnsiString; Escape: TTextWriterKind); begin AddAnyAnsiBuffer(pointer(s),length(s),Escape,0); end; procedure TTextWriter.AddAnyAnsiString(const s: RawByteString; Escape: TTextWriterKind; CodePage: Integer); var L: integer; begin L := length(s); if L=0 then exit; if (L>2) and (PInteger(s)^ and $ffffff=JSON_BASE64_MAGIC) then begin AddNoJSONEscape(pointer(s),L); // identified as a BLOB content exit; end; if CodePage<0 then {$ifdef HASCODEPAGE} CodePage := StringCodePage(s); {$else} CodePage := 0; // TSynAnsiConvert.Engine(0)=CurrentAnsiConvert {$endif} AddAnyAnsiBuffer(pointer(s),L,Escape,CodePage); end; procedure TTextWriter.AddAnyAnsiBuffer(P: PAnsiChar; Len: integer; Escape: TTextWriterKind; CodePage: Integer); var B: PUTF8Char; begin if Len>0 then case CodePage of CP_UTF8, CP_RAWBYTESTRING: Add(PUTF8Char(P),Len,Escape); // direct write of RawUTF8/RawByteString content CP_UTF16: AddW(PWord(P),0,Escape); // direct write of UTF-16 content CP_SQLRAWBLOB: begin AddNoJSONEscape(@PByteArray(@JSON_BASE64_MAGIC_QUOTE_VAR)[1],3); WrBase64(P,Len,{withMagic=}false); end; else begin // first handle trailing 7 bit ASCII chars, by quad B := pointer(P); if Len>=4 then repeat if PCardinal(P)^ and $80808080<>0 then break; // break on first non ASCII quad inc(P,4); dec(Len,4); until Len<4; if (Len>0) and (P^<#128) then repeat inc(P); dec(Len); until (Len=0) or (P^>=#127); if P<>pointer(B) then Add(B,P-B,Escape); if Len=0 then exit; // rely on explicit conversion for all remaining ASCII characters TSynAnsiConvert.Engine(CodePage).InternalAppendUTF8(P,Len,self,Escape); end; end; end; const {$ifdef OPT4AMD} // circumvent Delphi 5 and Delphi 6 compilation issues :( JSON_ESCAPE: TSynByteSet = [0..31,ord('\'),ord('"')]; {$else} // see http://www.ietf.org/rfc/rfc4627.txt JSON_ESCAPE = [0..31,ord('\'),ord('"')]; // "set of byte" uses BT[mem] opcode which is actually slower than three SUB {$endif} var JSON_ESCAPE_BYTE: TSynByteBoolean; function NeedsJsonEscape(const Text: RawUTF8): boolean; var tab: ^TSynByteBoolean; P: PByteArray; i: PtrInt; begin result := true; tab := @JSON_ESCAPE_BYTE; P := pointer(Text); for i := 0 to length(Text)-1 do if tab[P^[i]] then exit; result := false; end; procedure TTextWriter.InternalAddFixedAnsi(Source: PAnsiChar; SourceChars: Cardinal; const AnsiToWide: TWordDynArray; Escape: TTextWriterKind); var c: cardinal; begin while SourceChars>0 do begin c := byte(Source^); if c<=$7F then begin if B>=BEnd then FlushToStream; case Escape of twNone: begin inc(B); B^ := AnsiChar(c); end; twJSONEscape: if c in JSON_ESCAPE then AddJsonEscape(Source,1) else begin inc(B); B^ := AnsiChar(c); end; twOnSameLine: begin inc(B); if c<32 then B^ := ' ' else B^ := AnsiChar(c); end; end end else begin // no surrogate is expected in TSynAnsiFixedWidth charsets if BEnd-B<=3 then FlushToStream; c := AnsiToWide[c]; // convert FixedAnsi char into Unicode char if c>$7ff then begin B[1] := AnsiChar($E0 or (c shr 12)); B[2] := AnsiChar($80 or ((c shr 6) and $3F)); B[3] := AnsiChar($80 or (c and $3F)); inc(B,3); end else begin B[1] := AnsiChar($C0 or (c shr 6)); B[2] := AnsiChar($80 or (c and $3F)); inc(B,2); end; end; dec(SourceChars); inc(Source); end; end; procedure TTextWriter.AddOnSameLine(P: PUTF8Char); begin if P<>nil then while P^<>#0 do begin if B>=BEnd then FlushToStream; if P^<' ' then B[1] := ' ' else B[1] := P^; inc(P); inc(B); end; end; procedure TTextWriter.AddOnSameLine(P: PUTF8Char; Len: PtrInt); var i: PtrInt; begin if P<>nil then for i := 0 to Len-1 do begin if B>=BEnd then FlushToStream; if P[i]<' ' then B[1] := ' ' else B[1] := P[i]; inc(B); end; end; procedure TTextWriter.AddOnSameLineW(P: PWord; Len: PtrInt); var PEnd: PtrUInt; begin if P=nil then exit; if Len=0 then PEnd := 0 else PEnd := PtrUInt(P)+PtrUInt(Len)*SizeOf(WideChar); while (Len=0) or (PtrUInt(P) UTF-8 encode inc(B,UTF16CharToUtf8(B+1,P)); end; end; end; procedure TTextWriter.AddJSONEscape(P: Pointer; Len: PtrInt); var i,c: PtrInt; {$ifndef CPUX86NOTPIC}tab: ^TSynByteBoolean;{$endif} label noesc; begin if P=nil then exit; if Len=0 then Len := MaxInt; i := 0; {$ifdef CPUX86NOTPIC} repeat if not(PByteArray(P)[i] in JSON_ESCAPE) then begin noesc:c := i; repeat inc(i); until (i>=Len) or (PByteArray(P)[i] in JSON_ESCAPE); {$else} tab := @JSON_ESCAPE_BYTE; repeat if not tab^[PByteArray(P)[i]] then begin noesc:c := i; repeat inc(i); until (i>=Len) or tab^[PByteArray(P)[i]]; {$endif CPUX86NOTPIC} inc(PByte(P),c); dec(i,c); dec(Len,c); if BEnd-B<=i then AddNoJSONEscape(P,i) else begin {$ifdef FPC}Move{$else}MoveFast{$endif}(P^,B[1],i); inc(B,i); end; if i>=Len then exit; end; repeat c := PByteArray(P)[i]; case c of 0: exit; 8: c := ord('\')+ord('b')shl 8; 9: c := ord('\')+ord('t')shl 8; 10: c := ord('\')+ord('n')shl 8; 12: c := ord('\')+ord('f')shl 8; 13: c := ord('\')+ord('r')shl 8; ord('\'): c := ord('\')+ord('\')shl 8; ord('"'): c := ord('\')+ord('"')shl 8; 1..7,11,14..31: begin // characters below ' ', #7 e.g. -> // 'u0007' AddShort('\u00'); c := TwoDigitsHexWB[c]; end; else goto noesc; end; if BEnd-B<=1 then FlushToStream; inc(i); PWord(B+1)^ := c; inc(B,2); if i>=Len then exit; until false; until i>=Len; end; procedure TTextWriter.AddJSONEscapeW(P: PWord; Len: PtrInt); var i,c: PtrInt; begin if P=nil then exit; if Len=0 then Len := MaxInt; i := 0; while i=Len) or (PWordArray(P)[i] in JSON_ESCAPE); AddNoJSONEscapeW(@PWordArray(P)[c],i-c); end; while i // 'u0007' AddShort('\u00'); AddByteToHex(c); end; else break; end; inc(i); end; end; end; procedure TTextWriter.AddJSONEscape(const V: TVarRec); begin with V do case VType of vtPointer: AddShort('null'); vtString, vtAnsiString,{$ifdef HASVARUSTRING}vtUnicodeString,{$endif} vtPChar, vtChar, vtWideChar, vtWideString, vtClass: begin Add('"'); case VType of vtString: if VString^[0]<>#0 then AddJSONEscape(@VString^[1],ord(VString^[0])); vtAnsiString: AddJSONEscape(pointer(RawUTF8(VAnsiString))); {$ifdef HASVARUSTRING} vtUnicodeString: AddJSONEscapeW( pointer(UnicodeString(VUnicodeString)),length(UnicodeString(VUnicodeString))); {$endif} vtPChar: AddJSONEscape(VPChar); vtChar: AddJSONEscape(@VChar,1); vtWideChar: AddJSONEscapeW(@VWideChar,1); vtWideString: AddJSONEscapeW(VWideString); vtClass: AddClassName(VClass); end; Add('"'); end; vtBoolean: Add(VBoolean); // 'true'/'false' vtInteger: Add(VInteger); vtInt64: Add(VInt64^); {$ifdef FPC} vtQWord: AddQ(V.VQWord^); {$endif} vtExtended: Add(VExtended^,DOUBLE_PRECISION); vtCurrency: AddCurr64(VInt64^); vtObject: WriteObject(VObject); {$ifndef NOVARIANTS} vtVariant: AddVariant(VVariant^,twJSONEscape); {$endif} end; end; procedure TTextWriter.AddJSONString(const Text: RawUTF8); begin Add('"'); AddJSONEscape(pointer(Text)); Add('"'); end; procedure TTextWriter.Add(const V: TVarRec; Escape: TTextWriterKind; WriteObjectOptions: TTextWriterWriteObjectOptions); begin with V do case Vtype of vtInteger: Add(VInteger); vtBoolean: if VBoolean then Add('1') else Add('0'); // normalize vtChar: Add(@VChar,1,Escape); vtExtended: Add(VExtended^,DOUBLE_PRECISION); vtCurrency: AddCurr64(VInt64^); vtInt64: Add(VInt64^); {$ifdef FPC} vtQWord: AddQ(VQWord^); {$endif} {$ifndef NOVARIANTS} vtVariant: AddVariant(VVariant^,Escape); {$endif} vtString: if VString^[0]<>#0 then Add(@VString^[1],ord(VString^[0]),Escape); vtInterface, vtPointer: AddBinToHexDisplayMinChars(@VPointer,SizeOf(VPointer)); vtPChar: Add(PUTF8Char(VPChar),Escape); vtObject: WriteObject(VObject,WriteObjectOptions); vtClass: AddClassName(VClass); vtWideChar: AddW(@VWideChar,1,Escape); vtPWideChar: AddW(pointer(VPWideChar),StrLenW(VPWideChar),Escape); vtAnsiString: if VAnsiString<>nil then Add(VAnsiString,length(RawUTF8(VAnsiString)),Escape); // expect RawUTF8 vtWideString: if VWideString<>nil then AddW(VWideString,length(WideString(VWideString)),Escape); {$ifdef HASVARUSTRING} vtUnicodeString: if VUnicodeString<>nil then // convert to UTF-8 AddW(VUnicodeString,length(UnicodeString(VUnicodeString)),Escape); {$endif} end; end; {$ifndef NOVARIANTS} procedure TTextWriter.AddJSON(const Format: RawUTF8; const Args,Params: array of const); var temp: variant; begin _JsonFmt(Format,Args,Params,JSON_OPTIONS_FAST,temp); AddVariant(temp,twJSONEscape); end; {$endif} procedure TTextWriter.AddJSONArraysAsJSONObject(keys,values: PUTF8Char); var k,v: PUTF8Char; begin if (keys=nil) or (keys^<>'[') or (values=nil) or (values^<>'[') then begin AddShort('null'); exit; end; inc(keys); // jump initial [ inc(values); Add('{'); repeat k := GotoEndJSONItem(keys); v := GotoEndJSONItem(values); if (k=nil) or (v=nil) then break; // invalid JSON input AddNoJSONEscape(keys,k-keys); Add(':'); AddNoJSONEscape(values,v-values); Add(','); if (k^<>',') or (v^<>',') then break; // reached the end of the input JSON arrays keys := k+1; values := v+1; until false; CancelLastComma; Add('}'); end; procedure TTextWriter.AddJSONEscape(const NameValuePairs: array of const); var a: integer; procedure WriteValue; begin case VarRecAsChar(NameValuePairs[a]) of ord('['): begin Add('['); while a'' then {$ifdef UNICODE} AddNoJSONEscapeW(pointer(s),0); {$else} AddAnsiString(s,twNone); {$endif} end; procedure TTextWriter.AddJSONEscapeString(const s: string); begin if s<>'' then {$ifdef UNICODE} AddJSONEscapeW(pointer(s),Length(s)); {$else} AddAnyAnsiString(s,twJSONEscape,0); {$endif} end; procedure TTextWriter.AddJSONEscapeAnsiString(const s: AnsiString); begin AddAnyAnsiString(s,twJSONEscape,0); end; procedure TTextWriter.AddPropName(const PropName: ShortString); begin if ord(PropName[0])=0 then exit; if BEnd-B<=ord(PropName[0])+3 then FlushToStream; if twoForceJSONExtended in CustomOptions then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(PropName[1],B[1],ord(PropName[0])); inc(B,ord(PropName[0])+1); B^ := ':'; end else begin B[1] := '"'; {$ifdef FPC}Move{$else}MoveFast{$endif}(PropName[1],B[2],ord(PropName[0])); inc(B,ord(PropName[0])+2); PWord(B)^ := ord('"')+ord(':')shl 8; inc(B); end; end; procedure TTextWriter.AddPropJSONString(const PropName: shortstring; const Text: RawUTF8); begin AddPropName(PropName); AddJSONString(Text); Add(','); end; procedure TTextWriter.AddPropJSONInt64(const PropName: shortstring; Value: Int64); begin AddPropName(PropName); Add(Value); Add(','); end; procedure TTextWriter.AddFieldName(const FieldName: RawUTF8); begin AddFieldName(Pointer(FieldName),length(FieldName)); end; procedure TTextWriter.AddFieldName(FieldName: PUTF8Char; FieldNameLen: integer); begin if BEnd-B<=FieldNameLen+3 then FlushToStream; B[1] := '"'; {$ifdef FPC}Move{$else}MoveFast{$endif}(FieldName^,B[2],FieldNameLen); inc(B,FieldNameLen+2); PWord(B)^ := ord('"')+ord(':')shl 8; inc(B); end; procedure TTextWriter.AddClassName(aClass: TClass); begin if aClass<>nil then AddShort(PShortString(PPointer(PtrInt(PtrUInt(aClass))+vmtClassName)^)^); end; procedure TTextWriter.AddInstanceName(Instance: TObject; SepChar: AnsiChar); begin Add('"'); if Instance=nil then AddShort('void') else AddShort(PShortString(PPointer(PPtrInt(Instance)^+vmtClassName)^)^); Add('('); AddBinToHexDisplayMinChars(@Instance,SizeOf(Instance)); Add(')','"'); if SepChar<>#0 then Add(SepChar); end; procedure TTextWriter.AddInstancePointer(Instance: TObject; SepChar: AnsiChar; IncludeUnitName, IncludePointer: boolean); begin AddShort(PShortString(PPointer(PPtrInt(Instance)^+vmtClassName)^)^); if IncludePointer then begin Add('('); AddBinToHexDisplayMinChars(@Instance,SizeOf(Instance)); Add(')'); end; if SepChar<>#0 then Add(SepChar); end; procedure TTextWriter.AddShort(const Text: ShortString); begin if ord(Text[0])=0 then exit; if BEnd-B<=ord(Text[0]) then FlushToStream; {$ifdef FPC}Move{$else}MoveFast{$endif}(Text[1],B[1],ord(Text[0])); inc(B,ord(Text[0])); end; procedure TTextWriter.AddQuotedStringAsJSON(const QuotedString: RawUTF8); var L: integer; P,B: PUTF8Char; quote: AnsiChar; begin L := length(QuotedString); if L>0 then begin quote := QuotedString[1]; if (quote in ['''','"']) and (QuotedString[L]=quote) then begin Add('"'); P := pointer(QuotedString); inc(P); repeat B := P; while P[0]<>quote do inc(P); if P[1]<>quote then break; // end quote inc(P); AddJSONEscape(B,P-B); inc(P); // ignore double quote until false; if P-B<>0 then AddJSONEscape(B,P-B); Add('"'); end else AddNoJSONEscape(pointer(QuotedString),length(QuotedString)); end; end; procedure TTextWriter.AddTrimLeftLowerCase(Text: PShortString); var P: PAnsiChar; L: integer; begin L := length(Text^); P := @Text^[1]; while (L>0) and (P^ in ['a'..'z']) do begin inc(P); dec(L); end; if L=0 then AddShort(Text^) else AddNoJSONEscape(P,L); end; procedure TTextWriter.AddString(const Text: RawUTF8); var L: integer; begin if PtrInt(Text)=0 then exit; L := {$ifdef FPC}_LStrLen(Text){$else}PInteger(PtrInt(Text)-SizeOf(integer))^{$endif}; if L0 then begin if lenfTempBufSize then for i := 1 to count do AddString(Text) else begin if BEnd-B<=L*count then FlushToStream; for i := 1 to count do begin {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(Text)^,B[1],L); inc(B,L); end; end; end; procedure TTextWriter.CancelAll; begin if self=nil then exit; // avoid GPF if fTotalFileSize<>0 then fTotalFileSize := fStream.Seek(fInitialStreamPosition,soBeginning); B := fTempBuf-1; end; procedure TTextWriter.SetBuffer(aBuf: pointer; aBufSize: integer); begin if aBufSize<=16 then raise ESynException.CreateUTF8('%.SetBuffer(size=%)',[self,aBufSize]); if aBuf=nil then GetMem(fTempBuf,aBufSize) else begin fTempBuf := aBuf; Include(fCustomOptions,twoBufferIsExternal); end; fTempBufSize := aBufSize; B := fTempBuf-1; // Add() methods will append at B+1 BEnd := fTempBuf+fTempBufSize-16; // -16 to avoid buffer overwrite/overread if DefaultTextWriterTrimEnum then Include(fCustomOptions,twoTrimLeftEnumSets); end; constructor TTextWriter.Create(aStream: TStream; aBufSize: integer); begin SetStream(aStream); if aBufSize<256 then aBufSize := 256; SetBuffer(nil,aBufSize); end; constructor TTextWriter.Create(aStream: TStream; aBuf: pointer; aBufSize: integer); begin SetStream(aStream); SetBuffer(aBuf,aBufSize); end; constructor TTextWriter.CreateOwnedStream(aBufSize: integer); begin Create(TRawByteStringStream.Create,aBufSize); Include(fCustomOptions,twoStreamIsOwned); end; constructor TTextWriter.CreateOwnedStream(aBuf: pointer; aBufSize: integer); begin SetStream(TRawByteStringStream.Create); SetBuffer(aBuf,aBufSize); Include(fCustomOptions,twoStreamIsOwned); end; constructor TTextWriter.CreateOwnedStream(var aStackBuf: TTextWriterStackBuffer; aBufSize: integer); begin if aBufSize>SizeOf(aStackBuf) then // too small -> allocate on heap CreateOwnedStream(aBufSize) else CreateOwnedStream(@aStackBuf,SizeOf(aStackBuf)); end; constructor TTextWriter.CreateOwnedFileStream(const aFileName: TFileName; aBufSize: integer); begin DeleteFile(aFileName); Create(TFileStream.Create(aFileName,fmCreate or fmShareDenyWrite),aBufSize); Include(fCustomOptions,twoStreamIsOwned); end; destructor TTextWriter.Destroy; begin if twoStreamIsOwned in fCustomOptions then fStream.Free; if not (twoBufferIsExternal in fCustomOptions) then FreeMem(fTempBuf); fInternalJSONWriter.Free; inherited; end; class procedure TTextWriter.SetDefaultJSONClass(aClass: TTextWriterClass); begin DefaultTextWriterJSONClass := aClass; end; class function TTextWriter.GetDefaultJSONClass: TTextWriterClass; begin result := DefaultTextWriterJSONClass; end; class procedure TTextWriter.SetDefaultEnumTrim(aShouldTrimEnumsAsText: boolean); begin DefaultTextWriterTrimEnum := aShouldTrimEnumsAsText; end; procedure TTextWriter.SetStream(aStream: TStream); begin if fStream<>nil then if twoStreamIsOwned in fCustomOptions then begin FreeAndNil(fStream); Exclude(fCustomOptions,twoStreamIsOwned); end; if aStream<>nil then begin fStream := aStream; fInitialStreamPosition := fStream.Seek(0,soFromCurrent); fTotalFileSize := fInitialStreamPosition; end; end; procedure TTextWriter.FlushToStream; var i: PtrInt; written: PtrUInt; begin if fEchos<>nil then begin EchoFlush; fEchoStart := 0; end; i := B-fTempBuf+1; if i<=0 then exit; fStream.WriteBuffer(fTempBuf^,i); inc(fTotalFileSize,i); if not (twoFlushToStreamNoAutoResize in fCustomOptions) and not (twoBufferIsExternal in fCustomOptions) then begin written := fTotalFileSize-fInitialStreamPosition; if (fTempBufSize<49152) and (written>1 shl 18) then // 256KB -> 64KB buffer written := 65536 else if (fTempBufSize<1 shl 20) and (written>40 shl 20) then // 40MB -> 1MB buffer written := 1 shl 20 else written := 0; if written>0 then begin fTempBufSize := written; FreeMem(fTempBuf); // with big content comes bigger buffer GetMem(fTempBuf,fTempBufSize); BEnd := fTempBuf+(fTempBufSize-2); end; end; B := fTempBuf-1; end; function TTextWriter.GetEndOfLineCRLF: boolean; begin result := twoEndOfLineCRLF in fCustomOptions; end; procedure TTextWriter.SetEndOfLineCRLF(aEndOfLineCRLF: boolean); begin if aEndOfLineCRLF then include(fCustomOptions,twoEndOfLineCRLF) else exclude(fCustomOptions,twoEndOfLineCRLF); end; function TTextWriter.GetTextLength: PtrUInt; begin if self=nil then result := 0 else result := PtrUInt(B-fTempBuf+1)+fTotalFileSize-fInitialStreamPosition; end; function TTextWriter.Text: RawUTF8; begin SetText(result); end; procedure TTextWriter.ForceContent(const text: RawUTF8); begin CancelAll; if (fInitialStreamPosition=0) and fStream.InheritsFrom(TRawByteStringStream) then TRawByteStringStream(fStream).fDataString := text else fStream.WriteBuffer(pointer(text)^,length(text)); fTotalFileSize := fInitialStreamPosition+cardinal(length(text)); end; procedure TTextWriter.FlushFinal; begin Include(fCustomOptions,twoFlushToStreamNoAutoResize); FlushToStream; end; procedure TTextWriter.SetText(var result: RawUTF8; reformat: TTextWriterJSONFormat); var Len: cardinal; begin FlushFinal; Len := fTotalFileSize-fInitialStreamPosition; if Len=0 then result := '' else if fStream.InheritsFrom(TRawByteStringStream) then with TRawByteStringStream(fStream) do if fInitialStreamPosition=0 then begin {$ifdef HASCODEPAGE} // FPC expects this SetCodePage(fDataString,CP_UTF8,false); {$endif} result := fDataString; fDataString := ''; end else FastSetString(result,PAnsiChar(pointer(DataString))+fInitialStreamPosition,Len) else if fStream.InheritsFrom(TCustomMemoryStream) then with TCustomMemoryStream(fStream) do FastSetString(result,PAnsiChar(Memory)+fInitialStreamPosition,Len) else begin FastSetString(result,nil,Len); fStream.Seek(fInitialStreamPosition,soBeginning); fStream.Read(pointer(result)^,Len); end; if reformat <> jsonCompact then begin // reformat using the very same instance CancelAll; AddJSONReformat(pointer(result),reformat,nil); SetText(result); end; end; procedure TTextWriter.WrRecord(const Rec; TypeInfo: pointer); var L: integer; tmp: RawByteString; begin L := RecordSaveLength(Rec,TypeInfo); SetString(tmp,nil,L); if L<>0 then RecordSave(Rec,pointer(tmp),TypeInfo); WrBase64(pointer(tmp),L,{withMagic=}true); end; procedure TTextWriter.WrBase64(P: PAnsiChar; Len: cardinal; withMagic: boolean); var trailing, main, n: cardinal; begin if withMagic then if len<=0 then begin AddShort('null'); // JSON null is better than "" for BLOBs exit; end else AddNoJSONEscape(@JSON_BASE64_MAGIC_QUOTE_VAR,4); if len>0 then begin n := Len div 3; trailing := Len-n*3; dec(Len,trailing); if BEnd-B>integer(n+1) shl 2 then begin // will fit in available space in Buf -> fast in-buffer Base64 encoding n := Base64EncodeMain(@B[1],P,Len); inc(B,n*4); inc(P,n*3); end else begin // bigger than available space in Buf -> do it per chunk FlushToStream; while Len>0 do begin // length(buf) const -> so is ((length(buf)-4)shr2 )*3 n := ((fTempBufSize-4)shr 2)*3; if Len0 then begin Base64EncodeTrailing(@B[1],P,trailing); inc(B,4); end; end; if withMagic then Add('"'); end; procedure TTextWriter.EchoAdd(const aEcho: TOnTextWriterEcho); begin if self<>nil then if MultiEventAdd(fEchos,TMethod(aEcho)) then if fEchos<>nil then fEchoStart := B-fTempBuf+1; // ignore any previous buffer end; procedure TTextWriter.EchoRemove(const aEcho: TOnTextWriterEcho); begin if self<>nil then MultiEventRemove(fEchos,TMethod(aEcho)); end; function TTextWriter.EchoFlush: PtrInt; var L,LI: PtrInt; P: PByteArray; begin result := B-fTempBuf+1; L := result-fEchoStart; P := @PByteArray(fTempBuf)[fEchoStart]; while (L>0) and (P[L-1] in [10,13]) do // trim right CR/LF chars dec(L); LI := length(fEchoBuf); // fast append to fEchoBuf SetLength(fEchoBuf,LI+L); {$ifdef FPC}Move{$else}MoveFast{$endif}(P^,PByteArray(fEchoBuf)[LI],L); end; procedure TTextWriter.EchoReset; begin fEchoBuf := ''; end; function JSONEncode(const NameValuePairs: array of const): RawUTF8; var temp: TTextWriterStackBuffer; begin if high(NameValuePairs)<1 then result := '{}' else // return void JSON object on error with DefaultTextWriterJSONClass.CreateOwnedStream(temp) do try AddJSONEscape(NameValuePairs); SetText(result); finally Free end; end; {$ifndef NOVARIANTS} function JSONEncode(const Format: RawUTF8; const Args,Params: array of const): RawUTF8; var temp: TTextWriterStackBuffer; begin with DefaultTextWriterJSONClass.CreateOwnedStream(temp) do try AddJSON(Format,Args,Params); SetText(result); finally Free end; end; {$endif} function JSONEncodeArrayDouble(const Values: array of double): RawUTF8; var W: TTextWriter; temp: TTextWriterStackBuffer; begin W := DefaultTextWriterJSONClass.CreateOwnedStream(temp); try W.Add('['); W.AddCSVDouble(Values); W.Add(']'); W.SetText(result); finally W.Free end; end; function JSONEncodeArrayUTF8(const Values: array of RawUTF8): RawUTF8; var W: TTextWriter; temp: TTextWriterStackBuffer; begin W := DefaultTextWriterJSONClass.CreateOwnedStream(temp); try W.Add('['); W.AddCSVUTF8(Values); W.Add(']'); W.SetText(result); finally W.Free end; end; function JSONEncodeArrayInteger(const Values: array of integer): RawUTF8; var W: TTextWriter; temp: TTextWriterStackBuffer; begin W := DefaultTextWriterJSONClass.CreateOwnedStream(temp); try W.Add('['); W.AddCSVInteger(Values); W.Add(']'); W.SetText(result); finally W.Free end; end; function JSONEncodeArrayOfConst(const Values: array of const; WithoutBraces: boolean): RawUTF8; begin JSONEncodeArrayOfConst(Values,WithoutBraces,result); end; procedure JSONEncodeArrayOfConst(const Values: array of const; WithoutBraces: boolean; var result: RawUTF8); var temp: TTextWriterStackBuffer; begin if length(Values)=0 then if WithoutBraces then result := '' else result := '[]' else with DefaultTextWriterJSONClass.CreateOwnedStream(temp) do try if not WithoutBraces then Add('['); AddCSVConst(Values); if not WithoutBraces then Add(']'); SetText(result); finally Free end; end; procedure JSONEncodeNameSQLValue(const Name,SQLValue: RawUTF8; var result: RawUTF8); var temp: TTextWriterStackBuffer; begin if (SQLValue<>'') and (SQLValue[1] in ['''','"']) then // unescape SQL quoted string value into a valid JSON string with DefaultTextWriterJSONClass.CreateOwnedStream(temp) do try Add('{','"'); AddNoJSONEscapeUTF8(Name); Add('"',':'); AddQuotedStringAsJSON(SQLValue); Add('}'); SetText(result); finally Free; end else // Value is a number or null/true/false result := '{"'+Name+'":'+SQLValue+'}'; end; procedure TValuePUTF8Char.ToUTF8(var Text: RawUTF8); begin FastSetString(Text,Value,ValueLen); end; function TValuePUTF8Char.ToUTF8: RawUTF8; begin FastSetString(result,Value,ValueLen); end; function TValuePUTF8Char.ToString: string; begin UTF8DecodeToString(Value,ValueLen,result); end; function TValuePUTF8Char.ToInteger: PtrInt; begin result := GetInteger(Value); end; function TValuePUTF8Char.ToCardinal: PtrUInt; begin result := GetCardinal(Value); end; function TValuePUTF8Char.Idem(const Text: RawUTF8): boolean; begin if length(Text)=ValueLen then result := IdemPropNameUSameLen(pointer(Text),Value,ValueLen) else result := false; end; procedure JSONDecode(var JSON: RawUTF8; const Names: array of RawUTF8; Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean); begin JSONDecode(UniqueRawUTF8(JSON),Names,Values,HandleValuesAsObjectOrArray); end; procedure JSONDecode(var JSON: RawJSON; const Names: array of RawUTF8; Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean); begin JSONDecode(UniqueRawUTF8(RawUTF8(JSON)),Names,Values,HandleValuesAsObjectOrArray); end; function JSONDecode(P: PUTF8Char; const Names: array of RawUTF8; Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean): PUTF8Char; var n, i: PtrInt; namelen, valuelen: integer; name, value: PUTF8Char; EndOfObject: AnsiChar; begin result := nil; if Values=nil then exit; // avoid GPF n := length(Names); {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(Values[0],n*SizeOf(Values[0]),0); dec(n); if P=nil then exit; while P^<>'{' do if P^=#0 then exit else inc(P); inc(P); // jump { repeat name := GetJSONPropName(P,@namelen); if name=nil then exit; // invalid JSON content value := GetJSONFieldOrObjectOrArray(P,nil,@EndOfObject,HandleValuesAsObjectOrArray,true,@valuelen); if not(EndOfObject in [',','}']) then exit; // invalid item separator for i := 0 to n do if (Values[i].Value=nil) and IdemPropNameU(Names[i],name,namelen) then begin Values[i].Value := value; Values[i].ValueLen := valuelen; break; end; until (P=nil) or (EndOfObject='}'); if P=nil then // result=nil indicates failure -> points to #0 for end of text result := @NULCHAR else result := P; end; function JSONDecode(var JSON: RawUTF8; const aName: RawUTF8; wasString: PBoolean; HandleValuesAsObjectOrArray: Boolean): RawUTF8; var P, Name, Value: PUTF8Char; NameLen, ValueLen: integer; EndOfObject: AnsiChar; begin result := ''; P := pointer(JSON); if P=nil then exit; while P^<>'{' do if P^=#0 then exit else inc(P); inc(P); // jump { repeat Name := GetJSONPropName(P,@NameLen); if Name=nil then exit; // invalid JSON content Value := GetJSONFieldOrObjectOrArray( P,wasString,@EndOfObject,HandleValuesAsObjectOrArray,true,@ValueLen); if not(EndOfObject in [',','}']) then exit; // invalid item separator if IdemPropNameU(aName,Name,NameLen) then begin FastSetString(result,Value,ValueLen); exit; end; until (P=nil) or (EndOfObject='}'); end; function JSONDecode(P: PUTF8Char; out Values: TNameValuePUTF8CharDynArray; HandleValuesAsObjectOrArray: Boolean): PUTF8Char; var n: PtrInt; field: TNameValuePUTF8Char; EndOfObject: AnsiChar; begin {$ifdef FPC} Values := nil; {$endif} result := nil; n := 0; if P<>nil then begin while P^<>'{' do if P^=#0 then exit else inc(P); inc(P); // jump { repeat field.Name := GetJSONPropName(P,@field.NameLen); if field.Name=nil then exit; // invalid JSON content field.Value := GetJSONFieldOrObjectOrArray(P,nil,@EndOfObject, HandleValuesAsObjectOrArray,true,@field.ValueLen); if not(EndOfObject in [',','}']) then exit; // invalid item separator if n=length(Values) then SetLength(Values,n+32); Values[n] := field; inc(n); until (P=nil) or (EndOfObject='}'); end; SetLength(Values,n); if P=nil then // result=nil indicates failure -> points to #0 for end of text result := @NULCHAR else result := P; end; function JSONRetrieveStringField(P: PUTF8Char; out Field: PUTF8Char; out FieldLen: integer; ExpectNameField: boolean): PUTF8Char; begin result := nil; // retrieve string field if P=nil then exit; while (P^<=' ') and (P^<>#0) do inc(P); if P^<>'"' then exit; Field := P+1; P := GotoEndOfJSONString(P); if P^<>'"' then exit; // here P^ should be '"' FieldLen := P-Field; // check valid JSON delimiter repeat inc(P) until (P^>' ') or (P^=#0); if ExpectNameField then begin if P^<>':' then exit; // invalid name field end else if not (P^ in ['}',',']) then exit; // invalid value field result := P; // return either ':' for name field, either '}',',' for value end; /// decode a JSON field into an UTF-8 encoded buffer, stored inplace of JSON data function GetJSONField(P: PUTF8Char; out PDest: PUTF8Char; wasString: PBoolean; EndOfObject: PUTF8Char; Len: PInteger): PUTF8Char; var D: PUTF8Char; b,c4,surrogate,j: integer; tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; label slash,num; begin if wasString<>nil then wasString^ := false; // not a string by default PDest := nil; // PDest=nil indicates error or unexpected end (#0) result := nil; if P=nil then exit; if P^<=' ' then repeat inc(P); if P^=#0 then exit; until P^>' '; case P^ of 'n': if (PInteger(P)^=NULL_LOW) and (P[4] in EndOfJSONValueField) then begin result := nil; // null -> returns nil and wasString=false if Len<>nil then Len^ := 0; // when result is converted to string inc(P,4); end else exit; // PDest=nil to indicate error 'f': if (PInteger(P+1)^=ord('a')+ord('l')shl 8+ord('s')shl 16+ord('e')shl 24) and (P[5] in EndOfJSONValueField) then begin result := P; // false -> returns 'false' and wasString=false if Len<>nil then Len^ := 5; inc(P,5); end else exit; // PDest=nil to indicate error 't': if (PInteger(P)^=TRUE_LOW) and (P[4] in EndOfJSONValueField) then begin result := P; // true -> returns 'true' and wasString=false if Len<>nil then Len^ := 4; inc(P,4); end else exit; // PDest=nil to indicate error '"': begin // '"string \"\\field"' -> 'string "\field' if wasString<>nil then wasString^ := true; inc(P); result := P; D := P; repeat // unescape P^ into U^ (cf. http://www.ietf.org/rfc/rfc4627.txt) case P^ of #0: exit; // leave PDest=nil for unexpected end '"': break; // end of string '\': goto slash; else begin D^ := P^; // 3 stages pipelined process of unescaped chars inc(P); inc(D); case P^ of #0: exit; '"': break; '\': goto slash; else begin D^ := P^; inc(P); inc(D); case P^ of #0: exit; '"': break; '\': goto slash; else begin D^ := P^; inc(P); inc(D); continue; end; end; end; end; end; end; slash:inc(P); case P^ of // unescape JSON string #0: exit; // to avoid potential buffer overflow issue for \#0 'b': D^ := #08; 't': D^ := #09; 'n': D^ := #$0a; 'f': D^ := #$0c; 'r': D^ := #$0d; 'u': begin // inlined decoding of '\u0123' UTF-16 codepoint into UTF-8 {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 c4 := tab[ord(P[1])]; if c4<=15 then begin b := tab[ord(P[2])]; if b<=15 then begin c4 := c4 shl 4+b; b := tab[ord(P[3])]; if b<=15 then begin c4 := c4 shl 4+b; b := tab[ord(P[4])]; if b<=15 then begin c4 := c4 shl 4+b; case c4 of 0: begin D^ := '?'; // \u0000 is an invalid value inc(D); end; 1..$7f: begin D^ := AnsiChar(c4); inc(D); end; $80..$7ff: begin D[0] := AnsiChar($C0 or (c4 shr 6)); D[1] := AnsiChar($80 or (c4 and $3F)); inc(D,2); end; UTF16_HISURROGATE_MIN..UTF16_LOSURROGATE_MAX: if PWord(P+5)^=ord('\')+ord('u') shl 8 then begin inc(P,6); surrogate := (tab[ord(P[1])] shl 12)+ (tab[ord(P[2])] shl 8)+ (tab[ord(P[3])] shl 4)+ tab[ord(P[4])]; // optimistic approach case c4 of // inlined UTF16CharToUtf8() UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX: c4 := ((c4-$D7C0)shl 10)+(surrogate xor UTF16_LOSURROGATE_MIN); UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX: c4 := ((surrogate-$D7C0)shl 10)+(c4 xor UTF16_LOSURROGATE_MIN); end; case c4 of 0..$7ff: b := 2; $800..$ffff: b := 3; $10000..$1FFFFF: b := 4; $200000..$3FFFFFF: b := 5; else b := 6; end; for j := b-1 downto 1 do begin D[j] := AnsiChar((c4 and $3f)+$80); c4 := c4 shr 6; end; D^ := AnsiChar(Byte(c4) or UTF8_FIRSTBYTE[b]); inc(D,b); end else begin D^ := '?'; // unexpected surrogate without its pair inc(D); end; else begin D[0] := AnsiChar($E0 or (c4 shr 12)); D[1] := AnsiChar($80 or ((c4 shr 6) and $3F)); D[2] := AnsiChar($80 or (c4 and $3F)); inc(D,3); end; end; inc(P,5); continue; end; end; end; end; D^ := '?'; // bad formated hexa number -> '?0123' end; else D^ := P^; // litterals: '\"' -> '"' end; inc(P); inc(D); until false; // here P^='"' D^ := #0; // make zero-terminated if Len<>nil then Len^ := D-result; inc(P); if P^=#0 then exit; end; '0': if P[1] in ['0'..'9'] then // 0123 excluded by JSON! exit else // leave PDest=nil for unexpected end goto num; // may be 0.123 '-','1'..'9': begin // numerical field: all chars before end of field num:result := P; repeat if not (P^ in DigitFloatChars) then break; inc(P); until false; if P^=#0 then exit; if Len<>nil then Len^ := P-result; if P^<=' ' then begin P^ := #0; // force numerical field with no trailing ' ' inc(P); end; end; else exit; // PDest=nil to indicate error end; while not (P^ in EndOfJSONField) do begin if P^=#0 then exit; // leave PDest=nil for unexpected end inc(P); end; if EndOfObject<>nil then EndOfObject^ := P^; P^ := #0; // make zero-terminated PDest := @P[1]; if P[1]=#0 then PDest := nil; end; function GetJSONPropName(var P: PUTF8Char; Len: PInteger): PUTF8Char; var Name: PUTF8Char; wasString: boolean; EndOfObject: AnsiChar; begin // should match GotoNextJSONObjectOrArray() and JsonPropNameValid() result := nil; if P=nil then exit; while (P^<=' ') and (P^<>#0) do inc(P); Name := P; // put here to please some versions of Delphi compiler case P^ of '_','A'..'Z','a'..'z','0'..'9','$': begin // e.g. '{age:{$gt:18}}' repeat inc(P); until not (ord(P[0]) in IsJsonIdentifier); if Len<>nil then Len^ := P-Name; if (P^<=' ') and (P^<>#0) then begin P^ := #0; inc(P); end; while (P^<=' ') and (P^<>#0) do inc(P); if not (P^ in [':','=']) then // allow both age:18 and age=18 pairs exit; P^ := #0; inc(P); end; '''': begin // single quotes won't handle nested quote character inc(P); Name := P; while P^<>'''' do if P^<' ' then exit else inc(P); if Len<>nil then Len^ := P-Name; P^ := #0; repeat inc(P) until (P^>' ') or (P^=#0); if P^<>':' then exit; inc(P); end; '"': begin Name := GetJSONField(P,P,@wasString,@EndOfObject,Len); if (Name=nil) or not wasString or (EndOfObject<>':') then exit; end else exit; end; result := Name; end; procedure GetJSONPropName(var P: PUTF8Char; out PropName: shortstring); var Name: PAnsiChar; begin // match GotoNextJSONObjectOrArray() and overloaded GetJSONPropName() PropName[0] := #0; if P=nil then exit; while (P^<=' ') and (P^<>#0) do inc(P); Name := pointer(P); case P^ of '_','A'..'Z','a'..'z','0'..'9','$': begin // e.g. '{age:{$gt:18}}' repeat inc(P); until not (ord(P^) in IsJsonIdentifier); SetString(PropName,Name,P-Name); while (P^<=' ') and (P^<>#0) do inc(P); if not (P^ in [':','=']) then begin // allow both age:18 and age=18 pairs PropName[0] := #0; exit; end; inc(P); end; '''': begin // single quotes won't handle nested quote character inc(P); inc(Name); while P^<>'''' do if P^<' ' then exit else inc(P); SetString(PropName,Name,P-Name); repeat inc(P) until (P^>' ') or (P^=#0); if P^<>':' then begin PropName[0] := #0; exit; end; inc(P); end; '"': begin inc(Name); P := GotoEndOfJSONString(P); // won't unescape JSON strings if P^<>'"' then exit; SetString(PropName,Name,P-Name); repeat inc(P) until (P^>' ') or (P^=#0); if P^<>':' then begin PropName[0] := #0; exit; end; inc(P); end else exit; end; end; function GotoNextJSONPropName(P: PUTF8Char): PUTF8Char; label s; begin // should match GotoNextJSONObjectOrArray() while (P^<=' ') and (P^<>#0) do inc(P); result := nil; if P=nil then exit; case P^ of '_','A'..'Z','a'..'z','0'..'9','$': begin // e.g. '{age:{$gt:18}}' repeat inc(P); until not (ord(P^) in IsJsonIdentifier); if (P^<=' ') and (P^<>#0) then inc(P); while (P^<=' ') and (P^<>#0) do inc(P); if not (P^ in [':','=']) then // allow both age:18 and age=18 pairs exit; end; '''': begin // single quotes won't handle nested quote character inc(P); while P^<>'''' do if P^<' ' then exit else inc(P); goto s; end; '"': begin P := GotoEndOfJSONString(P); if P^<>'"' then exit; s: repeat inc(P) until (P^>' ') or (P^=#0); if P^<>':' then exit; end else exit; end; repeat inc(P) until (P^>' ') or (P^=#0); result := P; end; function GetJSONFieldOrObjectOrArray(var P: PUTF8Char; wasString: PBoolean; EndOfObject: PUTF8Char; HandleValuesAsObjectOrArray: Boolean; NormalizeBoolean: Boolean; Len: PInteger): PUTF8Char; var Value: PUTF8Char; wStr: boolean; begin result := nil; if P=nil then exit; while ord(P^) in [1..32] do inc(P); if HandleValuesAsObjectOrArray and (P^ in ['{','[']) then begin Value := P; P := GotoNextJSONObjectOrArray(P); if P=nil then exit; // invalid content if Len<>nil then Len^ := P-Value; if wasString<>nil then wasString^ := false; // was object or array while ord(P^) in [1..32] do inc(P); if EndOfObject<>nil then EndOfObject^ := P^; P^ := #0; // make zero-terminated if P[1]=#0 then P := nil else inc(P); result := Value; end else begin result := GetJSONField(P,P,@wStr,EndOfObject,Len); if wasString<>nil then wasString^ := wStr; if not wStr and NormalizeBoolean and (result<>nil) then begin if PInteger(result)^=TRUE_LOW then result := '1' else // normalize true -> 1 if PInteger(result)^=FALSE_LOW then result := '0' else // normalize false -> 0 exit; if Len<>nil then Len^ := 1; end; end; end; function IsString(P: PUTF8Char): boolean; // test if P^ is a "string" value begin if P=nil then begin result := false; exit; end; while (P^<=' ') and (P^<>#0) do inc(P); if (P[0] in ['0'..'9']) or // is first char numeric? ((P[0] in ['-','+']) and (P[1] in ['0'..'9'])) then begin // check if P^ is a true numerical value repeat inc(P) until not (P^ in ['0'..'9']); // check digits if P^='.' then repeat inc(P) until not (P^ in ['0'..'9']); // check fractional digits if (P^ in ['e','E']) and (P[1] in DigitChars) then begin inc(P); if P^='+' then inc(P) else if P^='-' then inc(P); while P^ in ['0'..'9'] do inc(P); end; while (P^<=' ') and (P^<>#0) do inc(P); result := (P^<>#0); exit; end else result := true; // don't begin with a numerical value -> must be a string end; function IsStringJSON(P: PUTF8Char): boolean; // test if P^ is a "string" value var c4: integer; begin if P=nil then begin result := false; exit; end; while (P^<=' ') and (P^<>#0) do inc(P); c4 := PInteger(P)^; if (((c4=NULL_LOW)or(c4=TRUE_LOW)) and (P[4] in EndOfJSONValueField)) or ((c4=FALSE_LOW) and (P[4]='e') and (P[5] in EndOfJSONValueField)) then begin result := false; // constants are no string exit; end else if (P[0] in ['1'..'9']) or // is first char numeric? ((P[0]='0') and not (P[1] in ['0'..'9'])) or // '012' excluded by JSON ((P[0]='-') and (P[1] in ['0'..'9'])) then begin // check if P^ is a true numerical value repeat inc(P) until not (P^ in ['0'..'9']); // check digits if P^='.' then repeat inc(P) until not (P^ in ['0'..'9']); // check fractional digits if (P^ in ['e','E']) and (P[1] in DigitChars) then begin inc(P); if P^='+' then inc(P) else if P^='-' then inc(P); while P^ in ['0'..'9'] do inc(P); end; while (P^<=' ') and (P^<>#0) do inc(P); result := (P^<>#0); exit; end else result := true; // don't begin with a numerical value -> must be a string end; function GotoEndJSONItem(P: PUTF8Char): PUTF8Char; begin result := nil; // to notify unexpected end if P=nil then exit; while (P^<=' ') and (P^<>#0) do inc(P); // get a field case P^ of #0: exit; '"': begin P := GotoEndOfJSONString(P); if P^<>'"' then exit; // P^ should be '"' here -> execute repeat.. below end; '[','{': begin P := GotoNextJSONObjectOrArray(P); if P=nil then exit; while (P^<=' ') and (P^<>#0) do inc(P); if P^<>#0 then result := P; exit; end; end; repeat // numeric or true/false/null or MongoDB extended {age:{$gt:18}} inc(P); if P^=#0 then exit; // unexpected end until P^ in [':',',',']','}']; if P^=#0 then exit; result := P; end; procedure GetJSONItemAsRawJSON(var P: PUTF8Char; var result: RawJSON; EndOfObject: PAnsiChar); var B: PUTF8Char; begin result := ''; if P=nil then exit; B := P; P := GotoEndJSONItem(B); if P=nil then exit; FastSetString(RawUTF8(result),B,P-B); while (P^<=' ') and (P^<>#0) do inc(P); if EndOfObject<>nil then EndOfObject^ := P^; if P^<>#0 then //if P^=',' then repeat inc(P) until (P^>' ') or (P^=#0); end; function GetJSONItemAsRawUTF8(var P: PUTF8Char; var output: RawUTF8; wasString: PBoolean; EndOfObject: PUTF8Char): boolean; var V: PUTF8Char; VLen: integer; begin V := GetJSONFieldOrObjectOrArray(P,wasstring,EndOfObject,true,true,@VLen); if V=nil then // parsing error result := false else begin FastSetString(output,V,VLen); result := true; end; end; function GotoNextJSONItem(P: PUTF8Char; NumberOfItemsToJump: cardinal; EndOfObject: PAnsiChar): PUTF8Char; label next; begin result := nil; // to notify unexpected end while NumberOfItemsToJump>0 do begin while (P^<=' ') and (P^<>#0) do inc(P); // get a field case P^ of #0: exit; '"': begin P := GotoEndOfJSONString(P); if P^<>'"' then exit; // P^ should be '"' here end; '[','{': begin P := GotoNextJSONObjectOrArray(P); if P=nil then exit; while (P^<=' ') and (P^<>#0) do inc(P); goto next; end; end; repeat // numeric or true/false/null or MongoDB extended {age:{$gt:18}} inc(P); if P^=#0 then exit; // unexpected end until P^ in [':',',',']','}']; next: if P^=#0 then exit; if EndOfObject<>nil then EndOfObject^ := P^; inc(P); dec(NumberOfItemsToJump); end; result := P; end; function GotoNextJSONObjectOrArrayInternal(P,PMax: PUTF8Char; EndChar: AnsiChar): PUTF8Char; label Prop; begin // should match GetJSONPropName() result := nil; repeat case P^ of '{','[': begin if PMax=nil then P := GotoNextJSONObjectOrArray(P) else P := GotoNextJSONObjectOrArrayMax(P,PMax); if P=nil then exit; end; ':': if EndChar<>'}' then exit else inc(P); // syntax for JSON object only ',': inc(P); // comma appears in both JSON objects and arrays '}': if EndChar='}' then break else exit; ']': if EndChar=']' then break else exit; '"': begin P := GotoEndOfJSONString(P); if P^<>'"' then exit; inc(P); end; '-','+','0'..'9': // '0123' excluded by JSON, but not here repeat inc(P); until not (P^ in DigitFloatChars); 't': if PInteger(P)^=TRUE_LOW then inc(P,4) else goto Prop; 'f': if PInteger(P)^=FALSE_LOW then inc(P,5) else goto Prop; 'n': if PInteger(P)^=NULL_LOW then inc(P,4) else goto Prop; '''': begin repeat inc(P); if P^<=' ' then exit; until P^=''''; repeat inc(P) until (P^>' ') or (P^=#0); if P^<>':' then exit; end; '/': begin repeat // allow extended /regex/ syntax inc(P); if P^=#0 then exit; until P^='/'; repeat inc(P) until (P^>' ') or (P^=#0); end; else begin Prop: if not (ord(P^) in IsJsonIdentifierFirstChar) then exit; // expect e.g. '{age:{$gt:18}}' repeat inc(P); until not (ord(P^) in IsJsonIdentifier); while (P^<=' ') and (P^<>#0) do inc(P); if P^='(' then begin // handle e.g. "born":isodate("1969-12-31") inc(P); while (P^<=' ') and (P^<>#0) do inc(P); if P^='"' then begin P := GotoEndOfJSONString(P); if P^<>'"' then exit; end; inc(P); while (P^<=' ') and (P^<>#0) do inc(P); if P^<>')' then exit; inc(P); end else if P^<>':' then exit; end; end; while (P^<=' ') and (P^<>#0) do inc(P); if (PMax<>nil) and (P>=PMax) then exit; until P^=EndChar; result := P+1; end; function GotoNextJSONObjectOrArray(P: PUTF8Char): PUTF8Char; var EndChar: AnsiChar; begin // should match GetJSONPropName() result := nil; // mark error or unexpected end (#0) while (P^<=' ') and (P^<>#0) do inc(P); case P^ of '[': EndChar := ']'; '{': EndChar := '}'; else exit; end; repeat inc(P) until (P^>' ') or (P^=#0); result := GotoNextJSONObjectOrArrayInternal(P,nil,EndChar); end; function GotoNextJSONObjectOrArray(P: PUTF8Char; EndChar: AnsiChar): PUTF8Char; begin // should match GetJSONPropName() while (P^<=' ') and (P^<>#0) do inc(P); result := GotoNextJSONObjectOrArrayInternal(P,nil,EndChar); end; function GotoNextJSONObjectOrArrayMax(P,PMax: PUTF8Char): PUTF8Char; var EndChar: AnsiChar; begin // should match GetJSONPropName() result := nil; // mark error or unexpected end (#0) while (P^<=' ') and (P^<>#0) do inc(P); case P^ of '[': EndChar := ']'; '{': EndChar := '}'; else exit; end; repeat inc(P) until (P^>' ') or (P^=#0); result := GotoNextJSONObjectOrArrayInternal(P,PMax,EndChar); end; function JSONArrayCount(P: PUTF8Char): integer; var n: integer; begin result := -1; n := 0; P := GotoNextNotSpace(P); if P^<>']' then repeat case P^ of '"': begin P := GotoEndOfJSONString(P); if P^<>'"' then exit; inc(P); end; '{','[': begin P := GotoNextJSONObjectOrArray(P); if P=nil then exit; // invalid content end; end; while not (P^ in [#0,',',']']) do inc(P); inc(n); if P^<>',' then break; repeat inc(P) until (P^>' ') or (P^=#0); until false; if P^=']' then result := n; end; function JSONArrayDecode(P: PUTF8Char; out Values: TPUTF8CharDynArray): boolean; var n,max: integer; begin result := false; max := 0; n := 0; P := GotoNextNotSpace(P); if P^<>']' then repeat if max=n then begin max := NextGrow(max); SetLength(Values,max); end; Values[n] := P; case P^ of '"': begin P := GotoEndOfJSONString(P); if P^<>'"' then exit; inc(P); end; '{','[': begin P := GotoNextJSONObjectOrArray(P); if P=nil then exit; // invalid content end; end; while not (P^ in [#0,',',']']) do inc(P); inc(n); if P^<>',' then break; repeat inc(P) until (P^>' ') or (P^=#0); until false; if P^=']' then begin SetLength(Values,n); result := true; end else Values := nil; end; function JSONArrayItem(P: PUTF8Char; Index: integer): PUTF8Char; begin if P<>nil then begin P := GotoNextNotSpace(P); if P^='[' then begin P := GotoNextNotSpace(P+1); if P^<>']' then repeat if Index<=0 then begin result := P; exit; end; case P^ of '"': begin P := GotoEndOfJSONString(P); if P^<>'"' then break; // invalid content inc(P); end; '{','[': begin P := GotoNextJSONObjectOrArray(P); if P=nil then break; // invalid content end; end; while not (P^ in [#0,',',']']) do inc(P); if P^<>',' then break; repeat inc(P) until (P^>' ') or (P^=#0); dec(Index); until false; end; end; result := nil; end; function JSONArrayCount(P,PMax: PUTF8Char): integer; var n: integer; begin result := -1; n := 0; P := GotoNextNotSpace(P); if P^<>']' then while P'"' then exit; inc(P); end; '{','[': begin P := GotoNextJSONObjectOrArrayMax(P,PMax); if P=nil then exit; // invalid content or PMax reached end; end; while not (P^ in [#0,',',']']) do inc(P); inc(n); if P^<>',' then break; repeat inc(P) until (P^>' ') or (P^=#0); end; if P^=']' then result := n; end; function JSONObjectPropCount(P: PUTF8Char): integer; var n: integer; begin result := -1; n := 0; P := GotoNextNotSpace(P); if P^<>'}' then repeat P := GotoNextJSONPropName(P); if P=nil then exit; case P^ of '"': begin P := GotoEndOfJSONString(P); if P^<>'"' then exit; inc(P); end; '{','[': begin P := GotoNextJSONObjectOrArray(P); if P=nil then exit; // invalid content end; end; while not (P^ in [#0,',','}']) do inc(P); inc(n); if P^<>',' then break; repeat inc(P) until (P^>' ') or (P^=#0); until false; if P^='}' then result := n; end; function JsonObjectItem(P: PUTF8Char; const PropName: RawUTF8; PropNameFound: PRawUTF8): PUTF8Char; var name: shortstring; // no memory allocation nor P^ modification PropNameLen: integer; PropNameUpper: array[byte] of AnsiChar; begin if P<>nil then begin P := GotoNextNotSpace(P); PropNameLen := length(PropName); if PropNameLen<>0 then begin if PropName[PropNameLen]='*' then begin UpperCopy255Buf(PropNameUpper,pointer(PropName),PropNameLen-1)^ := #0; PropNameLen := 0; end; if P^='{' then P := GotoNextNotSpace(P+1); if P^<>'}' then repeat GetJSONPropName(P,name); if (name[0]=#0) or (name[0]>#200) then break; while (P^<=' ') and (P^<>#0) do inc(P); if PropNameLen=0 then begin name[ord(name[0])+1] := #0; // make ASCIIZ if IdemPChar(@name[1],PropNameUpper) then begin if PropNameFound<>nil then FastSetString(PropNameFound^,@name[1],ord(name[0])); result := P; exit; end; end else if IdemPropName(name,pointer(PropName),PropNameLen) then begin result := P; exit; end; case P^ of '"': begin P := GotoEndOfJSONString(P); if P^<>'"' then break; // invalid content inc(P); end; '{','[': begin P := GotoNextJSONObjectOrArray(P); if P=nil then break; // invalid content end; end; while not (P^ in [#0,',','}']) do inc(P); if P^<>',' then break; repeat inc(P) until (P^>' ') or (P^=#0); until false; end; end; result := nil; end; function JsonObjectByPath(JsonObject,PropPath: PUTF8Char): PUTF8Char; var objName: RawUTF8; begin result := nil; if (JsonObject=nil) or (PropPath=nil) then exit; repeat GetNextItem(PropPath,'.',objName); if objName='' then exit; JsonObject := JsonObjectItem(JsonObject,objName); if JsonObject=nil then exit; until PropPath=nil; // found full name scope result := JsonObject; end; function JsonObjectsByPath(JsonObject,PropPath: PUTF8Char): RawUTF8; var itemName,objName,propNameFound,objPath: RawUTF8; start,ending,obj: PUTF8Char; WR: TTextWriter; temp: TTextWriterStackBuffer; procedure AddFromStart(const name: RaWUTF8); begin start := GotoNextNotSpace(start); ending := GotoEndJSONItem(start); if ending=nil then exit; if WR=nil then begin WR := TTextWriter.CreateOwnedStream(temp); WR.Add('{'); end else WR.Add(','); WR.AddFieldName(name); while (ending>start) and (ending[-1]<=' ') do dec(ending); // trim right WR.AddNoJSONEscape(start,ending-start); end; begin result := ''; if (JsonObject=nil) or (PropPath=nil) then exit; WR := nil; try repeat GetNextItem(PropPath,',',itemName); if itemName='' then break; if itemName[length(itemName)]<>'*' then begin start := JsonObjectByPath(JsonObject,pointer(itemName)); if start<>nil then AddFromStart(itemName); end else begin objPath := ''; obj := pointer(itemName); repeat GetNextItem(obj,'.',objName); if objName='' then exit; propNameFound := ''; JsonObject := JsonObjectItem(JsonObject,objName,@propNameFound); if JsonObject=nil then exit; if obj=nil then begin // found full name scope start := JsonObject; repeat AddFromStart(objPath+propNameFound); ending := GotoNextNotSpace(ending); if ending^<>',' then break; propNameFound := ''; start := JsonObjectItem(GotoNextNotSpace(ending+1),objName,@propNameFound); until start=nil; break; end else objPath := objPath+objName+'.'; until false; end; until PropPath=nil; if WR<>nil then begin WR.Add('}'); WR.SetText(result); end; finally WR.Free; end; end; function JSONObjectAsJSONArrays(JSON: PUTF8Char; out keys,values: RawUTF8): boolean; var wk,wv: TTextWriter; kb,ke,vb,ve: PUTF8Char; temp1,temp2: TTextWriterStackBuffer; begin result := false; if (JSON=nil) or (JSON^<>'{') then exit; wk := TTextWriter.CreateOwnedStream(temp1); wv := TTextWriter.CreateOwnedStream(temp2); try wk.Add('['); wv.Add('['); kb := JSON+1; repeat ke := GotoEndJSONItem(kb); if (ke=nil) or (ke^<>':') then exit; // invalid input content vb := ke+1; ve := GotoEndJSONItem(vb); if (ve=nil) or not(ve^ in [',','}']) then exit; wk.AddNoJSONEscape(kb,ke-kb); wk.Add(','); wv.AddNoJSONEscape(vb,ve-vb); wv.Add(','); kb := ve+1; until ve^='}'; wk.CancelLastComma; wk.Add(']'); wk.SetText(keys); wv.CancelLastComma; wv.Add(']'); wv.SetText(values); result := true; finally wv.Free; wk.Free; end; end; procedure RemoveCommentsFromJSON(P: PUTF8Char); begin // replace comments by ' ' characters which will be ignored by parser if P<>nil then while P^<>#0 do begin case P^ of '"': begin P := GotoEndOfJSONString(P); if P^<>'"' then exit; 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; end; end; inc(P); end; end; procedure JSONBufferToXML(P: PUTF8Char; const Header,NameSpace: RawUTF8; out result: RawUTF8); var i,j,L: integer; temp: TTextWriterStackBuffer; begin if P=nil then result := Header else with TTextWriter.CreateOwnedStream(temp) do try AddNoJSONEscape(pointer(Header),length(Header)); L := length(NameSpace); if L<>0 then AddNoJSONEscape(pointer(NameSpace),L); AddJSONToXML(P); if L<>0 then for i := 1 to L do if NameSpace[i]='<' then begin for j := i+1 to L do if NameSpace[j] in [' ','>'] then begin Add('<','/'); AddStringCopy(NameSpace,i+1,j-i-1); Add('>'); break; end; break; end; SetText(result); finally Free; end; end; function JSONToXML(const JSON: RawUTF8; const Header: RawUTF8; const NameSpace: RawUTF8): RawUTF8; var tmp: TSynTempBuffer; begin tmp.Init(JSON); try JSONBufferToXML(tmp.buf,Header,NameSpace,result); finally tmp.Done; end; end; procedure JSONBufferReformat(P: PUTF8Char; out result: RawUTF8; Format: TTextWriterJSONFormat); var temp: array[word] of byte; // 64KB buffer begin if P<>nil then with TTextWriter.CreateOwnedStream(@temp,SizeOf(temp)) do try AddJSONReformat(P,Format,nil); SetText(result); finally Free; end; end; function JSONReformat(const JSON: RawUTF8; Format: TTextWriterJSONFormat): RawUTF8; var tempIn: TSynTempBuffer; tempOut: TTextWriterStackBuffer; begin tempIn.Init(JSON); with TTextWriter.CreateOwnedStream(tempOut) do try AddJSONReformat(tempIn.buf,Format,nil); SetText(result); finally Free; tempIn.Done; end; end; function JSONBufferReformatToFile(P: PUTF8Char; const Dest: TFileName; Format: TTextWriterJSONFormat=jsonHumanReadable): boolean; var F: TFileStream; temp: array[word] of word; // 128KB begin try F := TFileStream.Create(Dest,fmCreate); try with TTextWriter.Create(F,@temp,SizeOf(temp)) do try AddJSONReformat(P,Format,nil); FlushFinal; finally Free; end; result := true; finally F.Free; end; except on Exception do result := false; end; end; function JSONReformatToFile(const JSON: RawUTF8; const Dest: TFileName; Format: TTextWriterJSONFormat=jsonHumanReadable): boolean; var tmp: TSynTempBuffer; begin tmp.Init(JSON); try result := JSONBufferReformatToFile(tmp.buf,Dest,Format); finally tmp.Done; end; end; { ************ some console functions } var TextAttr: integer = ord(ccDarkGray); {$ifdef MSWINDOWS} procedure InitConsole; begin if StdOut=0 then begin StdOut := GetStdHandle(STD_OUTPUT_HANDLE); if StdOut=INVALID_HANDLE_VALUE then StdOut := 0; end; end; procedure TextColor(Color: TConsoleColor); var oldAttr: integer; begin InitConsole; oldAttr := TextAttr; TextAttr := (TextAttr and $F0) or ord(Color); if TextAttr<>oldAttr then SetConsoleTextAttribute(StdOut,TextAttr); end; procedure TextBackground(Color: TConsoleColor); var oldAttr: integer; begin InitConsole; oldAttr := TextAttr; TextAttr := (TextAttr and $0F) or (ord(Color) shl 4); if TextAttr<>oldAttr then SetConsoleTextAttribute(StdOut,TextAttr); end; function ConsoleKeyPressed(ExpectedKey: Word): Boolean; var lpNumberOfEvents: DWORD; lpBuffer: TInputRecord; lpNumberOfEventsRead : DWORD; nStdHandle: THandle; begin result := false; nStdHandle := GetStdHandle(STD_INPUT_HANDLE); lpNumberOfEvents := 0; GetNumberOfConsoleInputEvents(nStdHandle,lpNumberOfEvents); if lpNumberOfEvents<>0 then begin PeekConsoleInput(nStdHandle,lpBuffer,1,lpNumberOfEventsRead); if lpNumberOfEventsRead<>0 then if lpBuffer.EventType=KEY_EVENT then if lpBuffer.Event.KeyEvent.bKeyDown and ((ExpectedKey=0) or (lpBuffer.Event.KeyEvent.wVirtualKeyCode=ExpectedKey)) then result := true else FlushConsoleInputBuffer(nStdHandle) else FlushConsoleInputBuffer(nStdHandle); end; end; procedure ConsoleWaitForEnterKey; {$ifdef DELPHI5OROLDER} begin readln; end; {$else} var msg: TMsg; begin while not ConsoleKeyPressed(VK_RETURN) do begin {$ifndef LVCL} if GetCurrentThreadID=MainThreadID then CheckSynchronize{$ifdef WITHUXTHEME}(1000){$endif} else {$endif} WaitMessage; while PeekMessage(msg,0,0,0,PM_REMOVE) do if Msg.Message=WM_QUIT then exit else begin TranslateMessage(Msg); DispatchMessage(Msg); end; end; end; {$endif DELPHI5OROLDER} {$else MSWINDOWS} // we by-pass crt.pp since this unit cancels the SIGINT signal {$I-} procedure TextColor(Color: TConsoleColor); const AnsiTbl : string[8]='04261537'; begin {$ifdef FPC}{$ifdef Linux} if not stdoutIsTTY then exit; {$endif}{$endif} if ord(color)=TextAttr then exit; TextAttr := ord(color); if ord(color)>=8 then write(#27'[1;3',AnsiTbl[(ord(color) and 7)+1],'m') else write(#27'[0;3',AnsiTbl[(ord(color) and 7)+1],'m'); ioresult; end; {$I+} procedure TextBackground(Color: TConsoleColor); begin // not implemented yet - but not needed either end; procedure ConsoleWaitForEnterKey; begin Readln; end; {$endif MSWINDOWS} function Utf8ToConsole(const S: RawUTF8): RawByteString; begin {$ifdef MSWINDOWS} result := TSynAnsiConvert.Engine(CP_OEMCP).UTF8ToAnsi(S); {$else} result := S; // expect a UTF-8 console under Linux {$endif} end; function StringToConsole(const S: string): RawByteString; begin result := Utf8ToConsole(StringToUTF8(S)); end; {$I-} procedure ConsoleShowFatalException(E: Exception; WaitForEnterKey: boolean); begin ioresult; TextColor(ccLightRed); write(#13#10'Fatal exception '); TextColor(ccWhite); write(E.ClassName); TextColor(ccLightRed); Writeln(' raised with message:'); TextColor(ccLightMagenta); Writeln(' ',StringToConsole(E.Message)); TextColor(ccLightGray); if WaitForEnterKey then begin writeln(#13#10'Program will now abort'); {$ifndef LINUX} writeln('Press [Enter] to quit'); if ioresult=0 then Readln; {$endif} end; ioresult; end; {$I+} {$ifndef NOVARIANTS} { TCommandLine } constructor TCommandLine.Create; var i: integer; p, sw: RawUTF8; begin inherited Create; fValues.InitFast(ParamCount shr 1,dvObject); for i := 1 to ParamCount do begin p := StringToUTF8(ParamStr(i)); if p<>'' then if p[1] in ['-','/'] then begin if sw<>'' then fValues.AddValue(sw,true); // -flag -switch value -> flag=true sw := LowerCase(copy(p,2,100)); if sw='noprompt' then begin fNoPrompt := true; sw := ''; end; end else if sw<>'' then begin fValues.AddValueFromText(sw,p,true); sw := ''; end; end; if sw<>'' then fValues.AddValue(sw,true); // trailing -flag end; constructor TCommandLine.Create(const switches: variant; aNoConsole: boolean); begin inherited Create; fValues.InitCopy(switches,JSON_OPTIONS_FAST); fNoPrompt := true; fNoConsole := aNoConsole; end; constructor TCommandLine.Create(const NameValuePairs: array of const; aNoConsole: boolean); begin inherited Create; fValues.InitObject(NameValuePairs,JSON_OPTIONS_FAST); fNoPrompt := true; fNoConsole := aNoConsole; end; constructor TCommandLine.CreateAsArray(firstParam: integer); var i: integer; begin inherited Create; fValues.InitFast(ParamCount,dvArray); for i := firstParam to ParamCount do fValues.AddItem(ParamStr(i)); end; function TCommandLine.NoPrompt: boolean; begin result := fNoPrompt; end; function TCommandLine.ConsoleText(const LineFeed: RawUTF8): RawUTF8; begin result := RawUTF8ArrayToCSV(fLines,LineFeed); end; procedure TCommandLine.SetNoConsole(value: boolean); begin if value=fNoConsole then exit; if value then fNoPrompt := true; fNoConsole := false; end; procedure TCommandLine.TextColor(Color: TConsoleColor); begin if not fNoPrompt then SynCommons.TextColor(Color); end; procedure TCommandLine.Text(const Fmt: RawUTF8; const Args: array of const; Color: TConsoleColor); var msg: RawUTF8; begin FormatUTF8(Fmt,Args,msg); {$I-} if msg<>'' then begin TextColor(Color); AddRawUTF8(fLines,msg); if not fNoConsole then write(Utf8ToConsole(msg)); end; if not fNoConsole then begin writeln; ioresult; end; {$I+} end; function TCommandLine.AsUTF8(const Switch, Default: RawUTF8; const Prompt: string): RawUTF8; var i: integer; begin i := fValues.GetValueIndex(Switch); if i>=0 then begin // found VariantToUTF8(fValues.Values[i],result); fValues.Delete(i); exit; end; result := Default; if fNoPrompt or (Prompt='') then exit; TextColor(ccLightGray); {$I-} writeln(Prompt); if ioresult<>0 then exit; // no console -> no prompt TextColor(ccCyan); write(Switch); if Default<>'' then write(' [',Default,'] '); write(': '); TextColor(ccWhite); readln(result); writeln; ioresult; {$I+} TextColor(ccLightGray); result := trim(result); if result='' then result := Default; end; function TCommandLine.AsInt(const Switch: RawUTF8; Default: Int64; const Prompt: string): Int64; var res: RawUTF8; begin res := AsUTF8(Switch, Int64ToUtf8(Default), Prompt); result := GetInt64Def(pointer(res),Default); end; function TCommandLine.AsDate(const Switch: RawUTF8; Default: TDateTime; const Prompt: string): TDateTime; var res: RawUTF8; begin res := AsUTF8(Switch, DateTimeToIso8601Text(Default), Prompt); if res='0' then begin result := 0; exit; end; result := Iso8601ToDateTime(res); if result=0 then result := Default; end; function TCommandLine.AsEnum(const Switch, Default: RawUTF8; TypeInfo: pointer; const Prompt: string): integer; var res: RawUTF8; begin res := AsUTF8(Switch, Default, Prompt); if not ToInteger(res,result) then result := GetEnumNameValue(TypeInfo,pointer(res),length(res),true); end; function TCommandLine.AsArray: TRawUTF8DynArray; begin fValues.ToRawUTF8DynArray(result); end; function TCommandLine.AsJSON(Format: TTextWriterJSONFormat): RawUTF8; begin result := fValues.ToJSON('','',Format); end; function TCommandLine.AsString(const Switch: RawUTF8; const Default, Prompt: string): string; begin result := UTF8ToString(AsUTF8(Switch,StringToUTF8(Default),Prompt)); end; {$endif NOVARIANTS} { ************ Unit-Testing classes and functions } procedure KB(bytes: Int64; out result: TShort16; nospace: boolean); type TUnits = (kb,mb,gb,tb,pb,eb,b); const TXT: array[boolean,TUnits] of RawUTF8 = ((' KB',' MB',' GB',' TB',' PB',' EB','% B'), ('KB','MB','GB','TB','PB','EB','%B')); var hi,rem: cardinal; u: TUnits; begin if bytes<1 shl 10-(1 shl 10) div 10 then begin FormatShort16(TXT[nospace,b],[integer(bytes)],result); exit; end; if bytes<1 shl 20-(1 shl 20) div 10 then begin u := kb; rem := bytes; hi := bytes shr 10; end else if bytes<1 shl 30-(1 shl 30) div 10 then begin u := mb; rem := bytes shr 10; hi := bytes shr 20; end else if bytes0 then rem := rem div 102; if rem=10 then begin rem := 0; inc(hi); // round up as expected by (most) human beings end; if rem<>0 then FormatShort16('%.%%',[hi,rem,TXT[nospace,u]],result) else FormatShort16('%%',[hi,TXT[nospace,u]],result); end; function KB(bytes: Int64): TShort16; begin KB(bytes,result,{nospace=}false); end; function KBNoSpace(bytes: Int64): TShort16; begin KB(bytes,result,{nospace=}true); end; function KB(bytes: Int64; nospace: boolean): TShort16; begin KB(bytes,result,nospace); end; function KB(const buffer: RawByteString): TShort16; begin KB(length(buffer),result,{nospace=}false); end; procedure KBU(bytes: Int64; var result: RawUTF8); var tmp: TShort16; begin KB(bytes,tmp,{nospace=}false); FastSetString(result,@tmp[1],ord(tmp[0])); end; function IntToThousandString(Value: integer; const ThousandSep: TShort4): shortstring; var i,L,Len: cardinal; begin str(Value,result); L := length(result); Len := L+1; if Value<0 then dec(L,2) else // ignore '-' sign dec(L); for i := 1 to L div 3 do insert(ThousandSep,result,Len-i*3); end; function MicroSecToString(Micro: QWord): TShort16; begin MicroSecToString(Micro,result); end; procedure MicroSecToString(Micro: QWord; out result: TShort16); procedure TwoDigitToString(value: cardinal; const u: shortstring; var result: TShort16); var d100: TDiv100Rec; begin if value<100 then FormatShort16('0.%%',[UInt2DigitsToShortFast(value),u],result) else begin Div100(value,d100); if d100.m=0 then FormatShort16('%%',[d100.d,u],result) else FormatShort16('%.%%',[d100.d,UInt2DigitsToShortFast(d100.m),u],result); end; end; procedure TimeToString(value: cardinal; const u: shortstring; var result: TShort16); var d: cardinal; begin d := value div 60; FormatShort16('%%%',[d,u,UInt2DigitsToShortFast(value-(d*60))],result); end; begin if Int64(Micro)<=0 then result := '0us' else if Micro<1000 then FormatShort16('%us',[Micro],result) else if Micro<1000000 then TwoDigitToString({$ifdef CPU32}PCardinal(@Micro)^{$else}Micro{$endif} div 10,'ms',result) else if Micro<60000000 then TwoDigitToString({$ifdef CPU32}PCardinal(@Micro)^{$else}Micro{$endif} div 10000,'s',result) else if Micro 0; end; procedure TPrecisionTimer.ComputeTime; begin {$ifdef LINUX} QueryPerformanceMicroSeconds(fStop); fTime := fStop-fStart; fLastTime := fStop-fLast; {$else} QueryPerformanceCounter(fStop); if fWinFreq=0 then begin QueryPerformanceFrequency(fWinFreq); if fWinFreq=0 then begin fTime := 0; fLastTime := 0; exit; end; end; {$ifdef DELPHI5OROLDER} // circumvent C1093 Error fTime := ((fStop-fStart)*1000000) div fWinFreq; if fLast=fStart then fLastTime := fTime else fLastTime := ((fStop-fLast)*1000000) div fWinFreq; {$else} fTime := (QWord(fStop-fStart)*QWord(1000000)) div QWord(fWinFreq); if fLast=fStart then fLastTime := fTime else fLastTime := (QWord(fStop-fLast)*QWord(1000000)) div QWord(fWinFreq); {$endif DELPHI5OROLDER} {$endif LINUX} end; procedure TPrecisionTimer.FromExternalMicroSeconds(const MicroSeconds: QWord); begin fLastTime := MicroSeconds; inc(fTime,MicroSeconds); end; function TPrecisionTimer.FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; begin // mimics ComputeTime from already known elapsed time {$ifdef LINUX} FromExternalMicroSeconds(CounterDiff); {$else} if fWinFreq=0 then begin fTime := 0; fLastTime := 0; QueryPerformanceFrequency(fWinFreq); end; if fWinFreq<>0 then FromExternalMicroSeconds((CounterDiff*1000000)div PQWord(@fWinFreq)^); {$endif LINUX} result := fLastTime; end; function TPrecisionTimer.Stop: TShort16; begin ComputeTime; MicroSecToString(fTime,result); end; procedure TPrecisionTimer.Pause; begin {$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(fResume); dec(fResume,fStart); inc(fPauseCount); end; procedure TPrecisionTimer.Resume; begin {$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(fStart); fLast := fStart; dec(fStart,fResume); fResume := 0; end; function TPrecisionTimer.Time: TShort16; begin MicroSecToString(fTime,result); end; function TPrecisionTimer.LastTime: TShort16; begin MicroSecToString(fLastTime,result); end; type /// a class used internaly by TPrecisionTimer.ProfileMethod TPrecisionTimerProfiler = class(TInterfacedObject) protected fTimer: PPrecisionTimer; public constructor Create(aTimer: PPrecisionTimer); destructor Destroy; override; end; constructor TPrecisionTimerProfiler.Create(aTimer: PPrecisionTimer); begin fTimer := aTimer; end; destructor TPrecisionTimerProfiler.Destroy; begin if fTimer<>nil then fTimer^.Pause; inherited; end; function TPrecisionTimer.ProfileCurrentMethod: IUnknown; begin if fStart=0 then Start else Resume; result := TPrecisionTimerProfiler.Create(@self); end; { TLocalPrecisionTimer } function TLocalPrecisionTimer.ByCount(Count: cardinal): RawUTF8; begin result := fTimer.ByCount(Count); end; procedure TLocalPrecisionTimer.Pause; begin fTimer.Pause; end; function TLocalPrecisionTimer.PerSec(Count: cardinal): cardinal; begin result := fTimer.PerSec(Count); end; procedure TLocalPrecisionTimer.Resume; begin fTimer.Resume; end; procedure TLocalPrecisionTimer.Start; begin fTimer.Start; end; function TLocalPrecisionTimer.Stop: TShort16; begin result := fTimer.Stop; end; constructor TLocalPrecisionTimer.CreateAndStart; begin inherited; fTimer.Start; end; { TSynMonitorTime } function TSynMonitorTime.GetAsText: TShort16; begin MicroSecToString(fMicroSeconds,result); end; function TSynMonitorTime.PerSecond(const Count: QWord): QWord; begin if {$ifdef FPC}Int64(fMicroSeconds){$else}PInt64(@fMicroSeconds)^{$endif}<=0 then result := 0 else // avoid negative or div per 0 result := (Count*1000000) div fMicroSeconds; end; { TSynMonitorOneTime } function TSynMonitorOneTime.GetAsText: TShort16; begin MicroSecToString(fMicroSeconds,result); end; function TSynMonitorOneTime.PerSecond(const Count: QWord): QWord; begin if {$ifdef FPC}Int64(fMicroSeconds){$else}PInt64(@fMicroSeconds)^{$endif}<=0 then result := 0 else result := (Count*QWord(1000000)) div fMicroSeconds; end; { TSynMonitorSizeParent } constructor TSynMonitorSizeParent.Create(aTextNoSpace: boolean); begin inherited Create; fTextNoSpace := aTextNoSpace; end; { TSynMonitorSize } function TSynMonitorSize.GetAsText: TShort16; begin KB(fBytes,result,fTextNoSpace); end; { TSynMonitorOneSize } function TSynMonitorOneSize.GetAsText: TShort16; begin KB(fBytes,result,fTextNoSpace); end; { TSynMonitorThroughput } function TSynMonitorThroughput.GetAsText: TShort16; begin FormatShort16('%/s',[KB(fBytesPerSec,fTextNoSpace)],result); end; { TSynMonitor } constructor TSynMonitor.Create; begin inherited Create; fTotalTime := TSynMonitorTime.Create; fLastTime := TSynMonitorOneTime.Create; fMinimalTime := TSynMonitorOneTime.Create; fAverageTime := TSynMonitorOneTime.Create; fMaximalTime := TSynMonitorOneTime.Create; end; constructor TSynMonitor.Create(const aName: RawUTF8); begin Create; fName := aName; end; destructor TSynMonitor.Destroy; begin fMaximalTime.Free; fAverageTime.Free; fMinimalTime.Free; fLastTime.Free; fTotalTime.Free; inherited Destroy; end; procedure TSynMonitor.Lock; begin fSafe^.Lock; end; procedure TSynMonitor.UnLock; begin fSafe^.UnLock; end; procedure TSynMonitor.Changed; begin // do nothing by default - overriden classes may track modified changes end; procedure TSynMonitor.ProcessStart; begin if fProcessing then raise ESynException.CreateUTF8('Reentrant %.ProcessStart',[self]); fSafe^.Lock; try InternalTimer.Resume; fTaskStatus := taskNotStarted; fProcessing := true; finally fSafe^.UnLock; end; end; procedure TSynMonitor.ProcessDoTask; begin fSafe^.Lock; try inc(fTaskCount); fTaskStatus := taskStarted; Changed; finally fSafe^.UnLock; end; end; procedure TSynMonitor.ProcessStartTask; begin if fProcessing then raise ESynException.CreateUTF8('Reentrant %.ProcessStart',[self]); fSafe^.Lock; try InternalTimer.Resume; fProcessing := true; inc(fTaskCount); fTaskStatus := taskStarted; Changed; finally fSafe^.UnLock; end; end; procedure TSynMonitor.ProcessEnd; begin fSafe^.Lock; try InternalTimer.Pause; InternalTimer.ComputeTime; LockedFromProcessTimer; finally fSafe^.UnLock; end; end; procedure TSynMonitor.LockedFromProcessTimer; begin fTotalTime.MicroSec := InternalTimer.TimeInMicroSec; if fTaskStatus=taskStarted then begin fLastTime.MicroSec := InternalTimer.LastTimeInMicroSec; if (fMinimalTime.MicroSec=0) or (InternalTimer.LastTimeInMicroSecfMaximalTime.MicroSec then fMaximalTime.MicroSec := InternalTimer.LastTimeInMicroSec; fTaskStatus := taskNotStarted; end; LockedPerSecProperties; fProcessing := false; Changed; end; function TSynMonitor.FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; begin fSafe^.Lock; try // thread-safe ProcessStart+ProcessDoTask+ProcessEnd inc(fTaskCount); fTaskStatus := taskStarted; result := InternalTimer.FromExternalQueryPerformanceCounters(CounterDiff); LockedFromProcessTimer; finally fSafe^.UnLock; end; end; procedure TSynMonitor.FromExternalMicroSeconds(const MicroSecondsElapsed: QWord); begin fSafe^.Lock; try // thread-safe ProcessStart+ProcessDoTask+ProcessEnd inc(fTaskCount); fTaskStatus := taskStarted; InternalTimer.FromExternalMicroSeconds(MicroSecondsElapsed); LockedFromProcessTimer; finally fSafe^.UnLock; end; end; class procedure TSynMonitor.InitializeObjArray(var ObjArr; Count: integer); var i: integer; begin ObjArrayClear(ObjArr); SetLength(TPointerDynArray(ObjArr),Count); for i := 0 to Count-1 do TPointerDynArray(ObjArr)[i] := Create; end; procedure TSynMonitor.ProcessError(const info: variant); begin fSafe^.Lock; try if not VarIsEmptyOrNull(info) then inc(fInternalErrors); fLastInternalError := info; Changed; finally fSafe^.UnLock; end; end; procedure TSynMonitor.ProcessErrorFmt(const Fmt: RawUTF8; const Args: array of const); begin ProcessError({$ifndef NOVARIANTS}RawUTF8ToVariant{$endif}(FormatUTF8(Fmt,Args))); end; procedure TSynMonitor.ProcessErrorRaised(E: Exception); begin {$ifndef NOVARIANTS}if E.InheritsFrom(ESynException) then ProcessError(_ObjFast([E,ObjectToVariant(E,true)])) else{$endif} ProcessErrorFmt('%: %', [E,E.Message]); end; procedure TSynMonitor.ProcessErrorNumber(info: integer); begin ProcessError(info); end; procedure TSynMonitor.LockedPerSecProperties; begin if fTaskCount=0 then exit; // avoid division per zero fPerSec := fTotalTime.PerSecond(fTaskCount); fAverageTime.MicroSec := fTotalTime.MicroSec div fTaskCount; end; procedure TSynMonitor.Sum(another: TSynMonitor); begin if (self=nil) or (another=nil) then exit; fSafe^.Lock; another.fSafe^.Lock; try LockedSum(another); finally another.fSafe^.UnLock; fSafe^.UnLock; end; end; procedure TSynMonitor.LockedSum(another: TSynMonitor); begin fTotalTime.MicroSec := fTotalTime.MicroSec+another.fTotalTime.MicroSec; if (fMinimalTime.MicroSec=0) or (another.fMinimalTime.MicroSecfMaximalTime.MicroSec then fMaximalTime.MicroSec := another.fMaximalTime.MicroSec; inc(fTaskCount,another.fTaskCount); if another.Processing then fProcessing := true; // if any thread is active, whole daemon is active inc(fInternalErrors,another.Errors); end; procedure TSynMonitor.WriteDetailsTo(W: TTextWriter); begin fSafe^.Lock; try W.WriteObject(self); finally fSafe^.UnLock; end; end; procedure TSynMonitor.ComputeDetailsTo(W: TTextWriter); begin fSafe^.Lock; try LockedPerSecProperties; // may not have been calculated after Sum() WriteDetailsTo(W); finally fSafe^.UnLock; end; end; function TSynMonitor.ComputeDetailsJSON: RawUTF8; var W: TTextWriter; temp: TTextWriterStackBuffer; begin W := DefaultTextWriterJSONClass.CreateOwnedStream(temp); try ComputeDetailsTo(W); W.SetText(result); finally W.Free; end; end; {$ifndef NOVARIANTS} function TSynMonitor.ComputeDetails: variant; begin _Json(ComputeDetailsJSON,result,JSON_OPTIONS_FAST); end; {$endif} { TSynMonitorWithSize} constructor TSynMonitorWithSize.Create; begin inherited Create; fSize := TSynMonitorSize.Create({nospace=}false); fThroughput := TSynMonitorThroughput.Create({nospace=}false); end; destructor TSynMonitorWithSize.Destroy; begin inherited Destroy; fThroughput.Free; fSize.Free; end; procedure TSynMonitorWithSize.LockedPerSecProperties; begin inherited LockedPerSecProperties; fThroughput.BytesPerSec := fTotalTime.PerSecond(fSize.Bytes); end; procedure TSynMonitorWithSize.AddSize(const Bytes: QWord); begin fSafe^.Lock; try fSize.Bytes := fSize.Bytes+Bytes; finally fSafe^.UnLock; end; end; procedure TSynMonitorWithSize.LockedSum(another: TSynMonitor); begin inherited LockedSum(another); if another.InheritsFrom(TSynMonitorWithSize) then AddSize(TSynMonitorWithSize(another).Size.Bytes); end; { TSynMonitorInputOutput } constructor TSynMonitorInputOutput.Create; begin inherited Create; fInput := TSynMonitorSize.Create({nospace=}false); fOutput := TSynMonitorSize.Create({nospace=}false); fInputThroughput := TSynMonitorThroughput.Create({nospace=}false); fOutputThroughput := TSynMonitorThroughput.Create({nospace=}false); end; destructor TSynMonitorInputOutput.Destroy; begin fOutputThroughput.Free; fOutput.Free; fInputThroughput.Free; fInput.Free; inherited Destroy; end; procedure TSynMonitorInputOutput.LockedPerSecProperties; begin inherited LockedPerSecProperties; fInputThroughput.BytesPerSec := fTotalTime.PerSecond(fInput.Bytes); fOutputThroughput.BytesPerSec := fTotalTime.PerSecond(fOutput.Bytes); end; procedure TSynMonitorInputOutput.AddSize(const Incoming, Outgoing: QWord); begin fSafe^.Lock; try fInput.Bytes := fInput.Bytes+Incoming; fOutput.Bytes := fOutput.Bytes+Outgoing; finally fSafe^.UnLock; end; end; procedure TSynMonitorInputOutput.LockedSum(another: TSynMonitor); begin inherited LockedSum(another); if another.InheritsFrom(TSynMonitorInputOutput) then begin fInput.Bytes := fInput.Bytes+TSynMonitorInputOutput(another).Input.Bytes; fOutput.Bytes := fOutput.Bytes+TSynMonitorInputOutput(another).Output.Bytes; end; end; { TSynMonitorServer } procedure TSynMonitorServer.ClientConnect; begin if self=nil then exit; fSafe^.Lock; try inc(fClientsCurrent); if fClientsCurrent>fClientsMax then fClientsMax := fClientsCurrent; Changed; finally fSafe^.UnLock; end; end; procedure TSynMonitorServer.ClientDisconnect; begin if self=nil then exit; fSafe^.Lock; try if fClientsCurrent>0 then dec(fClientsCurrent); Changed; finally fSafe^.UnLock; end; end; procedure TSynMonitorServer.ClientDisconnectAll; begin if self=nil then exit; fSafe^.Lock; try fClientsCurrent := 0; Changed; finally fSafe^.UnLock; end; end; function TSynMonitorServer.GetClientsCurrent: TSynMonitorOneCount; begin if self=nil then begin result := 0; exit; end; fSafe^.Lock; try result := fClientsCurrent; finally fSafe^.UnLock; end; end; function TSynMonitorServer.AddCurrentRequestCount(diff: integer): integer; begin if self=nil then begin result := 0; exit; end; fSafe^.Lock; try inc(fCurrentRequestCount,diff); result := fCurrentRequestCount; finally fSafe^.UnLock; end; end; { ******************* cross-cutting classes and functions ***************** } { TSynInterfacedObject } function TSynInterfacedObject._AddRef: {$ifdef FPC}longint{$else}integer{$endif}; begin result := VirtualAddRef; end; function TSynInterfacedObject._Release: {$ifdef FPC}longint{$else}integer{$endif}; begin result := VirtualRelease; end; {$ifdef FPC} function TSynInterfacedObject.QueryInterface( {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; {$else} function TSynInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult; {$endif} begin result := VirtualQueryInterface(IID,Obj); end; function TSynInterfacedObject.VirtualQueryInterface(const IID: TGUID; out Obj): HResult; begin result := E_NOINTERFACE; end; {$ifdef CPUINTEL} {$ifndef DELPHI5OROLDER} { TSynFPUException } function TSynFPUException.VirtualAddRef: integer; begin if fRefCount=0 then begin {$ifndef CPU64} fSaved8087 := Get8087CW; Set8087CW(fExpected8087); // set FPU exceptions mask {$else} fSavedMXCSR := GetMXCSR; SetMXCSR(fExpectedMXCSR); // set FPU exceptions mask {$endif} end; inc(fRefCount); result := 1; // should never be 0 (mark release of TSynFPUException instance) end; function TSynFPUException.VirtualRelease: integer; begin dec(fRefCount); if fRefCount=0 then {$ifndef CPU64} Set8087CW(fSaved8087); {$else} SetMXCSR(fSavedMXCSR); {$endif} result := 1; // should never be 0 (mark release of TSynFPUException instance) end; threadvar GlobalSynFPUExceptionDelphi, GlobalSynFPUExceptionLibrary: TSynFPUException; {$ifndef CPU64} constructor TSynFPUException.Create(Expected8087Flag: word); begin // $1372=Delphi $137F=library (mask all exceptions) inherited Create; fExpected8087 := Expected8087Flag; end; {$else} constructor TSynFPUException.Create(ExpectedMXCSR: word); begin // $1920=Delphi $1FA0=library (mask all exceptions) inherited Create; fExpectedMXCSR := ExpectedMXCSR; end; {$endif} class function TSynFPUException.ForLibraryCode: IUnknown; var obj: TSynFPUException; begin result := GlobalSynFPUExceptionLibrary; if result<>nil then exit; {$ifndef CPU64} obj := TSynFPUException.Create($137F); {$else} obj := TSynFPUException.Create($1FA0); {$endif} GarbageCollector.Add(obj); GlobalSynFPUExceptionLibrary := obj; result := obj; end; class function TSynFPUException.ForDelphiCode: IUnknown; var obj: TSynFPUException; begin result := GlobalSynFPUExceptionDelphi; if result<>nil then exit; {$ifndef CPU64} obj := TSynFPUException.Create($1372); {$else} obj := TSynFPUException.Create($1920); {$endif} GarbageCollector.Add(obj); GlobalSynFPUExceptionDelphi := obj; result := obj; end; {$endif DELPHI5OROLDER} {$endif CPUINTEL} { TAutoFree } constructor TAutoFree.Create(var localVariable; obj: TObject); begin fObject := obj; TObject(localVariable) := obj; end; class function TAutoFree.One(var localVariable; obj: TObject): IAutoFree; begin result := Create(localVariable,obj); end; class function TAutoFree.Several(const varObjPairs: array of pointer): IAutoFree; begin result := Create(varObjPairs); end; constructor TAutoFree.Create(const varObjPairs: array of pointer); var n,i: integer; begin n := length(varObjPairs); if (n=0) or (n and 1=1) then exit; n := n shr 1; if n=0 then exit; SetLength(fObjectList,n); for i := 0 to n-1 do begin fObjectList[i] := varObjPairs[i*2+1]; PPointer(varObjPairs[i*2])^ := fObjectList[i]; end; end; procedure TAutoFree.Another(var localVariable; obj: TObject); var n: integer; begin n := length(fObjectList); SetLength(fObjectList,n+1); fObjectList[n] := obj; TObject(localVariable) := obj; end; destructor TAutoFree.Destroy; var i: integer; begin if fObjectList<>nil then for i := high(fObjectList) downto 0 do // release FILO fObjectList[i].Free; fObject.Free; inherited; end; { TAutoLocker } constructor TAutoLocker.Create; begin fSafe.Init; end; destructor TAutoLocker.Destroy; begin fSafe.Done; inherited; end; function TAutoLocker.ProtectMethod: IUnknown; begin result := TAutoLock.Create(@fSafe); end; procedure TAutoLocker.Enter; begin EnterCriticalSection(fSafe.fSection); end; procedure TAutoLocker.Leave; begin LeaveCriticalSection(fSafe.fSection); end; function TAutoLocker.Safe: PSynLocker; begin result := @fSafe; end; {$ifndef DELPHI5OROLDER} // internal error C3517 under Delphi 5 :( {$ifndef NOVARIANTS} { TLockedDocVariant } constructor TLockedDocVariant.Create; begin Create(JSON_OPTIONS_FAST); end; constructor TLockedDocVariant.Create(FastStorage: boolean); begin Create(JSON_OPTIONS[FastStorage]); end; constructor TLockedDocVariant.Create(options: TDocVariantOptions); begin fLock := TAutoLocker.Create; fValue.Init(options); end; destructor TLockedDocVariant.Destroy; begin inherited; fLock.Free; end; function TLockedDocVariant.Exists(const Name: RawUTF8; out Value: Variant): boolean; var i: integer; begin fLock.Enter; try i := fValue.GetValueIndex(Name); if i<0 then result := false else begin Value := fValue.Values[i]; result := true; end; finally fLock.Leave; end; end; function TLockedDocVariant.ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean; var i: integer; begin result := true; fLock.Enter; try i := fValue.GetValueIndex(Name); if i<0 then result := false else Value := fValue.Values[i]; finally if result then fLock.Leave; end; end; procedure TLockedDocVariant.ReplaceAndUnlock( const Name: RawUTF8; const Value: Variant; out LocalValue: Variant); begin try SetValue(Name,Value); LocalValue := Value; finally fLock.Leave; end; end; function TLockedDocVariant.AddExistingPropOrLock(const Name: RawUTF8; var Obj: variant): boolean; var i: integer; begin result := true; fLock.Enter; try i := fValue.GetValueIndex(Name); if i<0 then result := false else _ObjAddProps([Name,fValue.Values[i]],Obj); finally if result then fLock.Leave; end; end; procedure TLockedDocVariant.AddNewPropAndUnlock(const Name: RawUTF8; const Value: variant; var Obj: variant); begin try SetValue(Name,Value); _ObjAddProps([Name,Value],Obj); finally fLock.Leave; end; end; function TLockedDocVariant.AddExistingProp(const Name: RawUTF8; var Obj: variant): boolean; var i: integer; begin result := true; fLock.Enter; try i := fValue.GetValueIndex(Name); if i<0 then result := false else _ObjAddProps([Name,fValue.Values[i]],Obj); finally fLock.Leave; end; end; procedure TLockedDocVariant.AddNewProp(const Name: RawUTF8; const Value: variant; var Obj: variant); begin fLock.Enter; try SetValue(Name,Value); _ObjAddProps([Name,Value],Obj); finally fLock.Leave; end; end; function TLockedDocVariant.GetValue(const Name: RawUTF8): Variant; begin fLock.Enter; try fValue.RetrieveValueOrRaiseException(pointer(Name),length(Name), dvoNameCaseSensitive in fValue.Options,result,false); finally fLock.Leave; end; end; procedure TLockedDocVariant.SetValue(const Name: RawUTF8; const Value: Variant); begin fLock.Enter; try fValue.AddOrUpdateValue(Name,Value); finally fLock.Leave; end; end; procedure TLockedDocVariant.AddItem(const Value: variant); begin fLock.Enter; try fValue.AddItem(Value); finally fLock.Leave; end; end; function TLockedDocVariant.Copy: variant; begin VarClear(result); fLock.Enter; try TDocVariantData(result).InitCopy(variant(fValue),JSON_OPTIONS_FAST); finally fLock.Leave; end; end; procedure TLockedDocVariant.Clear; var opt: TDocVariantOptions; begin fLock.Enter; try opt := fValue.Options; fValue.Clear; fValue.Init(opt); finally fLock.Leave; end; end; function TLockedDocVariant.ToJSON(HumanReadable: boolean): RawUTF8; var tmp: RawUTF8; begin fLock.Enter; try VariantSaveJSON(variant(fValue),twJSONEscape,tmp); finally fLock.Leave; end; if HumanReadable then JSONBufferReformat(pointer(tmp),result) else result := tmp; end; {$endif NOVARIANTS} {$endif DELPHI5OROLDER} function GetDelphiCompilerVersion: RawUTF8; begin result := {$ifdef FPC} 'Free Pascal' {$ifdef VER2_6_4}+' 2.6.4'{$endif} {$ifdef VER3_0_0}+' 3.0.0'{$endif} {$ifdef VER3_0_1}+' 3.0.1'{$endif} {$ifdef VER3_0_2}+' 3.0.2'{$endif} {$ifdef VER3_1_1}+' 3.1.1'{$endif} {$ifdef VER3_2} +' 3.2' {$endif} {$ifdef VER3_3_1}+' 3.3.1'{$endif} {$else} {$ifdef VER130} 'Delphi 5'{$endif} {$ifdef CONDITIONALEXPRESSIONS} // Delphi 6 or newer {$if defined(KYLIX3)}'Kylix 3' {$elseif defined(VER140)}'Delphi 6' {$elseif defined(VER150)}'Delphi 7' {$elseif defined(VER160)}'Delphi 8' {$elseif defined(VER170)}'Delphi 2005' {$elseif defined(VER185)}'Delphi 2007' {$elseif defined(VER180)}'Delphi 2006' {$elseif defined(VER200)}'Delphi 2009' {$elseif defined(VER210)}'Delphi 2010' {$elseif defined(VER220)}'Delphi XE' {$elseif defined(VER230)}'Delphi XE2' {$elseif defined(VER240)}'Delphi XE3' {$elseif defined(VER250)}'Delphi XE4' {$elseif defined(VER260)}'Delphi XE5' {$elseif defined(VER265)}'AppMethod 1' {$elseif defined(VER270)}'Delphi XE6' {$elseif defined(VER280)}'Delphi XE7' {$elseif defined(VER290)}'Delphi XE8' {$elseif defined(VER300)}'Delphi 10 Seattle' {$elseif defined(VER310)}'Delphi 10.1 Berlin' {$elseif defined(VER320)}'Delphi 10.2 Tokyo' {$elseif defined(VER330)}'Delphi 10.3 Rio' {$elseif defined(VER340)}'Delphi 10.4 Next' {$ifend} {$endif CONDITIONALEXPRESSIONS} {$endif FPC} {$ifdef CPU64} +' 64 bit' {$else} +' 32 bit' {$endif} end; { TSynCache } constructor TSynCache.Create(aMaxCacheRamUsed: cardinal; aCaseSensitive: boolean; aTimeoutSeconds: cardinal); begin inherited Create; fNameValue.Init(aCaseSensitive); fNameValue.fDynArray.Capacity := 200; // some space for future cached entries fMaxRamUsed := aMaxCacheRamUsed; fFindLastAddedIndex := -1; fTimeoutSeconds := aTimeoutSeconds; end; procedure TSynCache.ResetIfNeeded; var tix: cardinal; begin if fRamUsed>fMaxRamUsed then Reset; if fTimeoutSeconds>0 then begin tix := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10; if fTimeoutTix>tix then Reset; fTimeoutTix := tix+fTimeoutSeconds; end; end; procedure TSynCache.Add(const aValue: RawUTF8; aTag: PtrInt); begin if (self=nil) or (fFindLastAddedIndex<0) or (fFindLastKey='') then // fFindLastAddedIndex should have been set by a previous call to Find() exit; ResetIfNeeded; inc(fRamUsed,length(aValue)); if fFindLastAddedIndex<0 then // Reset occurred in ResetIfNeeded fNameValue.Add(fFindLastKey,aValue,aTag) else with fNameValue.List[fFindLastAddedIndex] do begin // at Find() position Name := fFindLastKey; Value := aValue; Tag := aTag; fFindLastAddedIndex := -1; fFindLastKey := ''; end; end; function TSynCache.Find(const aKey: RawUTF8; aResultTag: PPtrInt): RawUTF8; var added: boolean; begin result := ''; if self=nil then exit; if aKey='' then fFindLastAddedIndex := -1 else begin fFindLastAddedIndex := fNameValue.fDynArray.FindHashedForAdding(aKey,added); if added then // expect a further call to Add() fFindLastKey := aKey else // match key found with fNameValue.List[fFindLastAddedIndex] do begin result := Value; if aResultTag<>nil then aResultTag^ := Tag; fFindLastAddedIndex := -1; end; end; end; function TSynCache.AddOrUpdate(const aKey, aValue: RawUTF8; aTag: PtrInt): boolean; var ndx: integer; begin result := false; if self=nil then exit; // avoid GPF fSafe.Lock; try ResetIfNeeded; ndx := fNameValue.fDynArray.FindHashedForAdding(aKey,result); with fNameValue.List[ndx] do begin Name := aKey; dec(fRamUsed,length(Value)); Value := aValue; inc(fRamUsed,length(Value)); Tag := aTag; end; finally fSafe.Unlock; end; end; function TSynCache.Reset: boolean; begin result := false; if self=nil then exit; // avoid GPF fSafe.Lock; try if Count<>0 then begin if fRamUsed<131072 then // no capacity change for small cache content fNameValue.Count := 0 else with fNameValue.fDynArray{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do begin Capacity := 0; // force free all fNameValue.List[] key/value pairs Capacity := 200; // then reserve some space for future cached entries end; fNameValue.fDynArray.HashInvalidate; result := true; // mark something was flushed end; fFindLastAddedIndex := -1; // fFindLastKey should remain untouched for Add() fRamUsed := 0; fTimeoutTix := 0; finally fSafe.Unlock; end; end; function TSynCache.Count: integer; begin if self=nil then begin result := 0; exit; end; fSafe.Lock; try result := fNameValue.Count; finally fSafe.Unlock; end; end; { TRawUTF8List } function TRawUTF8List.Add(const aText: RawUTF8): PtrInt; var capacity: PtrInt; begin if self=nil then result := -1 else if fObjects=nil then begin capacity := length(fList); result := fCount; if result>=capacity then SetLength(fList,NextGrow(capacity)); fList[result] := aText; inc(fCount); Changed; end else result := AddObject(aText,nil); end; function TRawUTF8List.AddIfNotExisting(const aText: RawUTF8; wasAdded: PBoolean): PtrInt; begin result := IndexOf(aText); if result<0 then begin result := Add(aText); if wasAdded<>nil then wasAdded^ := true; end else if wasAdded<>nil then wasAdded^ := false; end; function TRawUTF8List.AddObjectIfNotExisting(const aText: RawUTF8; aObject: TObject; wasAdded: PBoolean): PtrInt; begin result := IndexOf(aText); if result<0 then begin result := AddObject(aText,aObject); if wasAdded<>nil then wasAdded^ := true; end else if wasAdded<>nil then wasAdded^ := false; end; function TRawUTF8List.AddObject(const aText: RawUTF8; aObject: TObject): PtrInt; var capacity: PtrInt; begin if self=nil then begin result := -1; exit; end; capacity := length(fList); result := fCount; if result>=capacity then begin capacity := NextGrow(capacity); SetLength(fList,capacity); if (fObjects<>nil) or (aObject<>nil) then SetLength(fObjects,capacity); end else if (aObject<>nil) and (fObjects=nil) then SetLength(fObjects,capacity); // first time we got aObject<>nil fList[result] := aText; if aObject<>nil then fObjects[result] := aObject; inc(fCount); Changed; end; procedure TRawUTF8List.AddRawUTF8List(List: TRawUTF8List); var i: PtrInt; begin if List<>nil then begin BeginUpdate; if List.fObjects=nil then for i := 0 to List.fCount-1 do Add(List.fList[i]) else for i := 0 to List.fCount-1 do AddObject(List.fList[i],List.fObjects[i]); EndUpdate; end; end; procedure TRawUTF8List.BeginUpdate; begin inc(fOnChangeLevel); if fOnChangeLevel>1 then exit; fOnChangeHidden := fOnChange; fOnChange := OnChangeHidden; fOnChangeTrigerred := false; end; procedure TRawUTF8List.Changed; begin if (self<>nil) and Assigned(fOnChange) then fOnChange(self); end; procedure TRawUTF8List.Clear; begin Capacity := 0; Changed; end; constructor TRawUTF8List.Create(aOwnObjects: boolean); begin fNameValueSep := '='; fObjectsOwned := aOwnObjects; fCaseSensitive := true; end; destructor TRawUTF8List.Destroy; begin Capacity := 0; inherited; end; procedure TRawUTF8List.Delete(Index: PtrInt); begin if (self=nil) or (PtrUInt(Index)>=PtrUInt(fCount)) then exit; // release string/object instances fList[Index] := ''; if (fObjects<>nil) and fObjectsOwned then FreeAndNil(fObjects[Index]); // swap the string/object arrays dec(fCount); if Indexnil then begin {$ifdef FPC}Move{$else}MoveFast{$endif}( fObjects[Index+1],fObjects[Index],(fCount-Index)*SizeOf(fObjects[0])); fObjects[fCount] := nil; // avoid GPF if fObjectsOwned is set end; end; Changed; end; function TRawUTF8List.Delete(const aText: RawUTF8): PtrInt; begin Result := IndexOf(aText); if Result>=0 then Delete(Result); end; function TRawUTF8List.DeleteFromName(const Name: RawUTF8): PtrInt; begin Result := IndexOfName(Name); if Result>=0 then Delete(Result); end; procedure TRawUTF8List.EndUpdate; begin if fOnChangeLevel<=0 then exit; dec(fOnChangeLevel); if fOnChangeLevel>0 then exit; // allows nested BeginUpdate..EndUpdate calls fOnChange := fOnChangeHidden; if fOnChangeTrigerred and Assigned(fOnChange) then fOnChange(self); fOnChangeTrigerred := false; end; function TRawUTF8List.Get(Index: PtrInt): RawUTF8; begin if (self=nil) or (PtrUInt(Index)>=PtrUInt(fCount)) then result := '' else result := fList[Index]; end; function TRawUTF8List.GetCapacity: PtrInt; begin if self=nil then result := 0 else result := length(fList); end; function TRawUTF8List.GetCount: PtrInt; begin if self=nil then result := 0 else result := fCount; end; function TRawUTF8List.GetListPtr: PPUtf8CharArray; begin if self=nil then result := nil else result := pointer(fList); end; function TRawUTF8List.GetObjectPtr: PPointerArray; begin if self=nil then result := nil else result := pointer(fObjects); end; function TRawUTF8List.GetName(Index: PtrInt): RawUTF8; begin result := Get(Index); if result='' then exit; Index := PosExChar(NameValueSep,result); if Index=0 then result := '' else SetLength(result,Index-1); end; function TRawUTF8List.GetObject(Index: PtrInt): TObject; begin if (self<>nil) and (PtrUInt(Index)nil) then result := fObjects[Index] else result := nil; end; function TRawUTF8List.GetObjectByName(const Name: RawUTF8): TObject; var ndx: PtrUInt; begin if (self<>nil) and (fObjects<>nil) then begin ndx := IndexOf(Name); if ndx0 then begin {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(fList[i])^,P^,Len); inc(P,Len); end; inc(i); if i>=fCount then Break; {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(Delimiter)^,P^,DelimLen); inc(P,DelimLen); until false; end; procedure TRawUTF8List.SaveToStream(Dest: TStream; const Delimiter: RawUTF8); var W: TTextWriter; i: integer; temp: TTextWriterStackBuffer; begin if (self=nil) or (fCount=0) then exit; W := TTextWriter.Create(Dest,@temp,SizeOf(temp)); try i := 0; repeat W.AddString(fList[i]); inc(i); if i>=fCount then Break; W.AddString(Delimiter); until false; W.FlushFinal; finally W.Free; end; end; procedure TRawUTF8List.SaveToFile(const FileName: TFileName; const Delimiter: RawUTF8); var FS: TFileStream; begin FS := TFileStream.Create(FileName,fmCreate); try SaveToStream(FS,Delimiter); finally FS.Free; end; end; function TRawUTF8List.GetTextCRLF: RawUTF8; begin result := GetText; end; function TRawUTF8List.GetValue(const Name: RawUTF8): RawUTF8; begin Result := GetValueAt(IndexOfName(Name)); end; function TRawUTF8List.GetValueAt(Index: PtrInt): RawUTF8; begin if (self=nil) or (PtrUInt(Index)>=PtrUInt(fCount)) then result := '' else result := Get(Index); if result='' then exit; Index := PosExChar(NameValueSep,result); if Index=0 then result := '' else result := copy(result,Index+1,maxInt); end; function TRawUTF8List.IndexOf(const aText: RawUTF8): PtrInt; begin if self<>nil then if fCaseSensitive then begin for result := 0 to fCount-1 do if fList[result]=aText then exit; end else for result := 0 to fCount-1 do if UTF8IComp(pointer(fList[result]),pointer(aText))=0 then exit; result := -1; end; function TRawUTF8List.IndexOfName(const Name: RawUTF8): PtrInt; var UpperName: array[byte] of AnsiChar; begin if self<>nil then begin PWord(UpperCopy255(UpperName,Name))^ := ord(NameValueSep); for result := 0 to fCount-1 do if IdemPChar(Pointer(fList[result]),UpperName) then exit; end; result := -1; end; function TRawUTF8List.IndexOfObject(aObject: TObject): PtrInt; begin if (self<>nil) and (fObjects<>nil) then result := PtrUIntScanIndex(pointer(fObjects),fCount,PtrUInt(aObject)) else result := -1; end; procedure TRawUTF8List.OnChangeHidden(Sender: TObject); begin if self<>nil then fOnChangeTrigerred := true; end; procedure TRawUTF8List.Put(Index: PtrInt; const Value: RawUTF8); begin if (self<>nil) and (PtrUInt(Index)nil) and (PtrUInt(Index)nil then begin if Value<=0 then begin fList := nil; if fObjects<>nil then begin if fObjectsOwned then for i := 0 to fCount-1 do fObjects[i].Free; fObjects := nil; end; fCount := 0; end else begin if Valuenil) and fObjectsOwned then for i := Value to fCount-1 do FreeAndNil(fObjects[i]); fCount := Value; end; if Value>length(fList) then begin // increase capacity SetLength(fList,Value); if pointer(fObjects)<>nil then SetLength(fObjects,Value); end; end; end; end; procedure TRawUTF8List.SetText(const aText, Delimiter: RawUTF8); begin SetTextPtr(pointer(aText),PUTF8Char(pointer(aText))+length(aText),Delimiter); end; procedure TRawUTF8List.LoadFromFile(const FileName: TFileName); var Map: TMemoryMap; P: PUTF8Char; begin if Map.Map(FileName) then try if Map.Size<>0 then begin if TextFileKind(Map)=isUTF8 then begin // ignore UTF-8 BOM P := pointer(Map.Buffer+3); SetTextPtr(P,P+Map.Size-3,#13#10); end else begin P := pointer(Map.Buffer); SetTextPtr(P,P+Map.Size,#13#10); end; end; finally Map.UnMap; end; end; procedure TRawUTF8List.SetTextPtr(P,PEnd: PUTF8Char; const Delimiter: RawUTF8); var DelimLen: PtrInt; DelimFirst: AnsiChar; PBeg, DelimNext: PUTF8Char; Line: RawUTF8; begin DelimLen := length(Delimiter); BeginUpdate; Clear; if (P<>nil) and (DelimLen>0) and (P=PEnd then break; inc(P,DelimLen); until P>=PEnd; end; EndUpdate; end; procedure TRawUTF8List.SetTextCRLF(const Value: RawUTF8); begin SetText(Value,#13#10); end; procedure TRawUTF8List.SetValue(const Name, Value: RawUTF8); var i: PtrInt; begin i := IndexOfName(Name); if i<0 then Add(Name+RawUTF8(NameValueSep)+Value) else fList[i] := Name+RawUTF8(NameValueSep)+Value; end; procedure TRawUTF8List.SetCaseSensitive(Value: boolean); begin fCaseSensitive := Value; end; procedure TRawUTF8List.UpdateValue(const Name: RawUTF8; var Value: RawUTF8; ThenDelete: boolean); var i: PtrInt; begin i := IndexOfName(Name); if i>=0 then begin Value := GetValueAt(i); // update value if ThenDelete then Delete(i); // optionally delete end; end; function TRawUTF8List.PopFirst(out aText: RawUTF8; aObject: PObject=nil): boolean; begin result := fCount>0; if not result then exit; aText := fList[0]; if aObject<>nil then if fObjects<>nil then aObject^ := fObjects[0] else aObject^ := nil; Delete(0); end; function TRawUTF8List.PopLast(out aText: RawUTF8; aObject: PObject=nil): boolean; var ndx: integer; begin result := fCount>0; if not result then exit; ndx := fCount-1; aText := fList[ndx]; if aObject<>nil then if fObjects<>nil then aObject^ := fObjects[ndx] else aObject^ := nil; Delete(ndx); end; { TRawUTF8ListLocked } constructor TRawUTF8ListLocked.Create(aOwnObjects: boolean); begin inherited Create(aOwnObjects); fSafe.Init; end; destructor TRawUTF8ListLocked.Destroy; begin inherited; fSafe.Done; end; procedure TRawUTF8ListLocked.SafePush(const aValue: RawUTF8); begin if self=nil then exit; fSafe.Lock; try Add(aValue); finally fSafe.UnLock; end; end; function TRawUTF8ListLocked.SafePop(out aValue: RawUTF8): boolean; begin result := false; if (self=nil) or (fCount=0) then exit; fSafe.Lock; try if fCount=0 then exit; aValue := fList[0]; Delete(0); result := true; finally fSafe.UnLock; end; end; procedure TRawUTF8ListLocked.SafeClear; begin if self=nil then exit; fSafe.Lock; try Clear; finally fSafe.UnLock; end; end; { TObjectListHashedAbstract} constructor TObjectListHashedAbstract.Create(aFreeItems: boolean); begin inherited Create; fFreeItems := aFreeItems; fHash.Init(TypeInfo(TObjectDynArray),fList,@HashPtrUInt,@SortDynArrayPointer,nil,@fCount); end; destructor TObjectListHashedAbstract.Destroy; var i: integer; begin if fFreeItems then for i := 0 to fCount-1 do List[i].Free; inherited; end; procedure TObjectListHashedAbstract.Delete(aIndex: integer); begin if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) then exit; if fFreeItems then FreeAndNil(List[aIndex]); fHash.Delete(aIndex); fHash.HashInvalidate; end; procedure TObjectListHashedAbstract.Delete(aObject: TObject); begin Delete(IndexOf(aObject)); end; { TObjectListHashed } function TObjectListHashed.Add(aObject: TObject; out wasAdded: boolean): integer; begin wasAdded := false; if self<>nil then begin result := fHash.FindHashedForAdding(aObject,wasAdded); if wasAdded then fList[result] := aObject; end else result := -1; end; function TObjectListHashed.IndexOf(aObject: TObject): integer; begin if (self<>nil) and (fCount>0) then result := fHash.FindHashed(aObject) else result := -1; end; { TObjectListPropertyHashed } constructor TObjectListPropertyHashed.Create( aSubPropAccess: TObjectListPropertyHashedAccessProp; aHashElement: TDynArrayHashOne; aCompare: TDynArraySortCompare; aFreeItems: boolean); begin inherited Create(aFreeItems); fSubPropAccess := aSubPropAccess; if Assigned(aHashElement) then fHash.fHashElement := aHashElement; if Assigned(aCompare) then fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare := aCompare; fHash.EventCompare := IntComp; fHash.EventHash := IntHash; end; function TObjectListPropertyHashed.IntHash(const Elem): cardinal; var O: TObject; begin O := fSubPropAccess(TObject(Elem)); result := fHash.fHashElement(O,fHash.fHasher); end; function TObjectListPropertyHashed.IntComp(const A,B): integer; var O: TObject; begin O := fSubPropAccess(TObject(A)); result := fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare(O,B); end; function TObjectListPropertyHashed.Add(aObject: TObject; out wasAdded: boolean): integer; begin wasAdded := false; if self<>nil then begin result := fHash.FindHashedForAdding(aObject,wasAdded, fHash.fHashElement(aObject,fHash.fHasher)); if wasAdded then fList[result] := aObject; end else result := -1; end; function TObjectListPropertyHashed.IndexOf(aObject: TObject): integer; begin if fCount>0 then begin result := fHash.FindHashed(aObject,fHash.fHashElement(aObject,fHash.fHasher)); if result>=0 then exit else // found result := -1; // for consistency end else result := -1; end; { TPointerClassHashed } constructor TPointerClassHashed.Create(aInfo: pointer); begin fInfo := aInfo; end; { TPointerClassHash } function PointerClassHashProcess(aObject: TPointerClassHashed): pointer; begin if aObject=nil then // may happen for Rehash after SetCount(n+1) result := nil else result := aObject.Info; end; constructor TPointerClassHash.Create; begin inherited Create(@PointerClassHashProcess); end; function TPointerClassHash.TryAdd(aInfo: pointer): PPointerClassHashed; var wasAdded: boolean; i: integer; begin i := inherited Add(aInfo,wasAdded); if wasAdded then result := @List[i] else result := nil; end; function TPointerClassHash.Find(aInfo: pointer): TPointerClassHashed; var i: integer; begin if self<>nil then begin i := IndexOf(aInfo); if i>=0 then result := TPointerClassHashed(List[i]) else result := nil; end else result := nil; end; { TPointerClassHashLocked } constructor TPointerClassHashLocked.Create; begin inherited Create; fSafe.Init; end; destructor TPointerClassHashLocked.Destroy; begin fSafe.Done; inherited Destroy; end; function TPointerClassHashLocked.FindLocked(aInfo: pointer): TPointerClassHashed; begin if self=nil then result := nil else begin fSafe.Lock; try result := inherited Find(aInfo); finally fSafe.UnLock; end; end; end; function TPointerClassHashLocked.TryAddLocked(aInfo: pointer; out aNewEntry: PPointerClassHashed): boolean; var wasAdded: boolean; i: integer; begin fSafe.Lock; i := inherited Add(aInfo,wasAdded); if wasAdded then begin aNewEntry := @List[i]; result := true; // caller should call Unlock end else begin fSafe.UnLock; result := false; end; end; procedure TPointerClassHashLocked.Unlock; begin fSafe.UnLock; end; { TObjectListLocked } constructor TObjectListLocked.Create(AOwnsObjects: Boolean=true); begin inherited Create(AOwnsObjects); fSafe.Init; end; destructor TObjectListLocked.Destroy; begin inherited Destroy; fSafe.Done; end; function TObjectListLocked.SafeAdd(AObject: TObject): integer; begin Safe.Lock; try result := Add(AObject); finally Safe.UnLock; end; end; function TObjectListLocked.SafeRemove(AObject: TObject): integer; begin Safe.Lock; try result := Remove(AObject); finally Safe.UnLock; end; end; function TObjectListLocked.SafeExists(AObject: TObject): boolean; begin Safe.Lock; try result := IndexOf(AObject)>=0; finally Safe.UnLock; end; end; function TObjectListLocked.SafeCount: integer; begin Safe.Lock; try result := Count; finally Safe.UnLock; end; end; procedure TObjectListLocked.SafeClear; begin Safe.Lock; try Clear; finally Safe.UnLock; end; end; { TRawUTF8ListHashed } {$ifdef PUREPASCAL} function SortDynArrayAnsiStringHashOnly(const A,B): integer; begin if RawByteString(A)=RawByteString(B) then // faster than StrCmp result := 0 else result := 1; // fake comparison, but fHash only use equality end; {$endif} var DYNARRAY_SORTFIRSTFIELDHASHONLY: array[boolean] of TDynArraySortCompare = ( SortDynArrayAnsiStringI, {$ifdef PUREPASCAL}SortDynArrayAnsiStringHashOnly {$else}SortDynArrayAnsiString{$endif}); constructor TRawUTF8ListHashed.Create(aOwnObjects: boolean); begin inherited Create(aOwnObjects); fHash.Init(TypeInfo(TRawUTF8DynArray),fList,@HashAnsiString, DYNARRAY_SORTFIRSTFIELDHASHONLY[true],nil,@fCount); end; procedure TRawUTF8ListHashed.Changed; begin fChanged := true; inherited; end; procedure TRawUTF8ListHashed.SetCaseSensitive(Value: boolean); begin if fCaseSensitive=Value then exit; inherited; fHash.fHashElement := DYNARRAY_HASHFIRSTFIELD[not Value,djRawUTF8]; fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare := DYNARRAY_SORTFIRSTFIELDHASHONLY[Value]; if not fChanged then fChanged := Count>0; // force re-hash next IndexOf() call end; function TRawUTF8ListHashed.IndexOf(const aText: RawUTF8): PtrInt; begin if fChanged then fChanged := not fHash.ReHash; // rough, but working implementation result := fHash.FindHashed(aText); end; function TRawUTF8ListHashed.AddIfNotExisting(const aText: RawUTF8; wasAdded: PBoolean): PtrInt; var added: boolean; begin if fChanged then fChanged := not fHash.ReHash; // rough, but working implementation result := fHash.FindHashedForAdding(aText,added); if added then begin fList[result] := aText; if (fObjects<>nil) and (length(fObjects)<>length(fList)) then SetLength(fObjects,length(fList)); end; if wasAdded<>nil then wasAdded^ := added; end; function TRawUTF8ListHashed.AddObjectIfNotExisting( const aText: RawUTF8; aObject: TObject; wasAdded: PBoolean): PtrInt; var added: boolean; begin if fChanged then fChanged := not fHash.ReHash; // rough, but working implementation result := fHash.FindHashedForAdding(aText,added); if added then begin fList[result] := aText; if length(fObjects)<>length(fList) then SetLength(fObjects,length(fList)); fObjects[result] := aObject; end; if wasAdded<>nil then wasAdded^ := added; end; function TRawUTF8ListHashed.HashFind(aHashCode: cardinal): integer; begin result := fHash.HashFind(aHashCode,false); end; function TRawUTF8ListHashed.ReHash(aForceRehash: boolean): boolean; begin if fChanged or aForceRehash then fChanged := not fHash.ReHash(aForceRehash); result := not fChanged; end; { TRawUTF8ListHashedLocked } constructor TRawUTF8ListHashedLocked.Create(aOwnObjects: boolean); begin inherited Create(aOwnObjects); fSafe.Init; end; destructor TRawUTF8ListHashedLocked.Destroy; begin fSafe.Done; inherited; end; function TRawUTF8ListHashedLocked.LockedAdd(const aText: RawUTF8): PtrInt; begin fSafe.Lock; try result := inherited Add(aText); finally fSafe.UnLock; end; end; function TRawUTF8ListHashedLocked.IndexOf(const aText: RawUTF8): PtrInt; begin fSafe.Lock; try result := inherited IndexOf(aText); finally fSafe.UnLock; end; end; function TRawUTF8ListHashedLocked.LockedGetObjectByName(const aText: RawUTF8): TObject; begin fSafe.Lock; try result := inherited GetObjectByName(aText); finally fSafe.UnLock; end; end; function TRawUTF8ListHashedLocked.AddIfNotExisting(const aText: RawUTF8; wasAdded: PBoolean): PtrInt; begin fSafe.Lock; try result := inherited AddIfNotExisting(aText,wasAdded); finally fSafe.UnLock; end; end; function TRawUTF8ListHashedLocked.AddObjectIfNotExisting(const aText: RawUTF8; aObject: TObject; wasAdded: PBoolean): PtrInt; begin fSafe.Lock; try result := inherited AddObjectIfNotExisting(aText,aObject,wasAdded); finally fSafe.UnLock; end; end; function TRawUTF8ListHashedLocked.Delete(const aText: RawUTF8): PtrInt; begin fSafe.Lock; try result := inherited IndexOf(aText); if result>=0 then inherited Delete(result); finally fSafe.UnLock; end; end; function TRawUTF8ListHashedLocked.DeleteFromName(const Name: RawUTF8): PtrInt; begin fSafe.Lock; try result := inherited IndexOfName(Name); if result>=0 then inherited Delete(result); finally fSafe.UnLock; end; end; function TRawUTF8ListHashedLocked.PopFirst(out aText: RawUTF8; aObject: PObject=nil): boolean; begin fSafe.Lock; try result := inherited PopFirst(aText,aObject); finally fSafe.UnLock; end; end; function TRawUTF8ListHashedLocked.PopLast(out aText: RawUTF8; aObject: PObject=nil): boolean; begin fSafe.Lock; try result := inherited PopLast(aText,aObject); finally fSafe.UnLock; end; end; procedure TRawUTF8ListHashedLocked.Clear; begin fSafe.Lock; try inherited Clear; finally fSafe.UnLock; end; end; function TRawUTF8ListHashedLocked.ReHash(aForceRehash: boolean): boolean; begin fSafe.Lock; try result := inherited Rehash(aForceRehash); finally fSafe.UnLock; end; end; { TRawUTF8MethodList } function TRawUTF8MethodList.AddEvent(const aName: RawUTF8; const aEvent: TMethod): PtrInt; begin result := Add(aName); if result>=length(fEvents) then SetLength(fEvents,result+256); fEvents[result] := aEvent; end; procedure TRawUTF8MethodList.Clear; begin inherited Clear; fEvents := nil; end; procedure TRawUTF8MethodList.Delete(Index: PtrInt); begin inherited Delete(Index); if Index=0) and (i0 then exit; end; result := 0; end; constructor TSynDictionary.Create(aKeyTypeInfo,aValueTypeInfo: pointer; aKeyCaseInsensitive: boolean; aTimeoutSeconds: cardinal; aCompressAlgo: TAlgoCompress); begin inherited Create; fSafe.Padding[DIC_KEYCOUNT].VType := varInteger; fSafe.Padding[DIC_KEY].VType := varUnknown; fSafe.Padding[DIC_VALUECOUNT].VType := varInteger; fSafe.Padding[DIC_VALUE].VType := varUnknown; fSafe.Padding[DIC_TIMECOUNT].VType := varInteger; fSafe.Padding[DIC_TIMESEC].VType := varInteger; fSafe.Padding[DIC_TIMETIX].VType := varInteger; fSafe.PaddingMaxUsedIndex := DIC_TIMETIX; fKeys.Init(aKeyTypeInfo,fSafe.Padding[DIC_KEY].VAny,nil,nil,nil, @fSafe.Padding[DIC_KEYCOUNT].VInteger,aKeyCaseInsensitive); if not Assigned(fKeys.fHashElement) then fKeys.fEventHash := KeyFullHash; if not Assigned(fKeys.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare) then fKeys.fEventCompare := KeyFullCompare; fValues.Init(aValueTypeInfo,fSafe.Padding[DIC_VALUE].VAny, @fSafe.Padding[DIC_VALUECOUNT].VInteger); fTimeouts.Init(TypeInfo(TIntegerDynArray),fTimeOut,@fSafe.Padding[DIC_TIMECOUNT].VInteger); if aCompressAlgo=nil then aCompressAlgo := AlgoSynLZ; fCompressAlgo := aCompressAlgo; fSafe.Padding[DIC_TIMESEC].VInteger := aTimeoutSeconds; end; function TSynDictionary.ComputeNextTimeOut: cardinal; begin result := fSafe.Padding[DIC_TIMESEC].VInteger; if result<>0 then result := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+result; end; function TSynDictionary.GetCapacity: integer; begin fSafe.Lock; result := fKeys.Capacity; fSafe.UnLock; end; procedure TSynDictionary.SetCapacity(const Value: integer); begin fSafe.Lock; fKeys.Capacity := Value; fValues.Capacity := Value; if fSafe.Padding[DIC_TIMESEC].VInteger>0 then fTimeOuts.Capacity := Value; fSafe.UnLock; end; function TSynDictionary.GetTimeOutSeconds: cardinal; begin result := fSafe.Padding[DIC_TIMESEC].VInteger; end; procedure TSynDictionary.SetTimeouts; var i: PtrInt; timeout: cardinal; begin if fSafe.Padding[DIC_TIMESEC].VInteger=0 then exit; fTimeOuts.SetCount(fSafe.Padding[DIC_KEYCOUNT].VInteger); timeout := ComputeNextTimeOut; for i := 0 to fSafe.Padding[DIC_TIMECOUNT].VInteger-1 do fTimeOut[i] := timeout; end; function TSynDictionary.DeleteDeprecated: integer; var i: PtrInt; now: cardinal; begin result := 0; if (self=nil) or (fSafe.Padding[DIC_TIMECOUNT].VInteger=0) or // no entry (fSafe.Padding[DIC_TIMESEC].VInteger=0) then // nothing in fTimeOut[] exit; now := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10; if fSafe.Padding[DIC_TIMETIX].VInteger=integer(now) then exit; // no need to search more often than every second fSafe.Lock; try fSafe.Padding[DIC_TIMETIX].VInteger := now; for i := fSafe.Padding[DIC_TIMECOUNT].VInteger-1 downto 0 do if (now>fTimeOut[i]) and (fTimeOut[i]<>0) and (not Assigned(fOnCanDelete) or fOnCanDelete(fKeys.ElemPtr(i)^,fValues.ElemPtr(i)^,i)) then begin fKeys.Delete(i); fValues.Delete(i); fTimeOuts.Delete(i); inc(result); end; if result>0 then fKeys.Rehash; // mandatory after fKeys.Delete(i) finally fSafe.UnLock; end; end; procedure TSynDictionary.DeleteAll; begin if self=nil then exit; fSafe.Lock; try fKeys.Clear; fKeys.ReHash; // mandatory to avoid GPF fValues.Clear; if fSafe.Padding[DIC_TIMESEC].VInteger>0 then fTimeOuts.Clear; finally fSafe.UnLock; end; end; destructor TSynDictionary.Destroy; begin fKeys.Clear; fValues.Clear; inherited Destroy; end; function TSynDictionary.Add(const aKey, aValue): integer; var added: boolean; tim: cardinal; begin fSafe.Lock; try result := fKeys.FindHashedForAdding(aKey,added); if added then begin with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do ElemCopyFrom(aKey,result); // fKey[result] := aKey; if fValues.Add(aValue)<>result then raise ESynException.CreateUTF8('%.Add fValues.Add',[self]); tim := ComputeNextTimeOut; if tim>0 then fTimeOuts.Add(tim); end else result := -1; finally fSafe.UnLock; end; end; function TSynDictionary.AddOrUpdate(const aKey, aValue): integer; var added: boolean; tim: cardinal; begin fSafe.Lock; try tim := ComputeNextTimeOut; result := fKeys.FindHashedForAdding(aKey,added); if added then begin with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do ElemCopyFrom(aKey,result); // fKey[result] := aKey if fValues.Add(aValue)<>result then raise ESynException.CreateUTF8('%.AddOrUpdate fValues.Add',[self]); if tim<>0 then fTimeOuts.Add(tim); end else begin fValues.ElemCopyFrom(aValue,result,{ClearBeforeCopy=}true); if tim<>0 then fTimeOut[result] := tim; end; finally fSafe.UnLock; end; end; function TSynDictionary.Clear(const aKey): integer; begin fSafe.Lock; try result := fKeys.FindHashed(aKey); if result>=0 then begin fValues.ElemClear(fValues.ElemPtr(result)^); if fSafe.Padding[DIC_TIMESEC].VInteger>0 then fTimeOut[result] := 0; end; finally fSafe.UnLock; end; end; function TSynDictionary.Delete(const aKey): integer; begin fSafe.Lock; try result := fKeys.FindHashedAndDelete(aKey); if result>=0 then begin fValues.Delete(result); if fSafe.Padding[DIC_TIMESEC].VInteger>0 then fTimeOuts.Delete(result); end; finally fSafe.UnLock; end; end; function TSynDictionary.DeleteAt(aIndex: integer): boolean; begin if cardinal(aIndex)0 then fTimeOuts.Delete(aIndex); result := true; end else result := false; end; function TSynDictionary.InArray(const aKey, aArrayValue; aAction: TSynDictionaryInArray): boolean; var nested: TDynArray; ndx: integer; begin result := false; if (fValues.ElemType=nil) or (PTypeKind(fValues.ElemType)^<>tkDynArray) then raise ESynException.CreateUTF8('%.Values: % items are not dynamic arrays', [self,fValues.ArrayTypeShort^]); fSafe.Lock; try ndx := fKeys.FindHashed(aKey); if ndx<0 then exit; nested.Init(fValues.ElemType,fValues.ElemPtr(ndx)^); case aAction of iaFind: result := nested.Find(aArrayValue)>=0; iaFindAndDelete: result := nested.FindAndDelete(aArrayValue)>=0; iaFindAndUpdate: result := nested.FindAndUpdate(aArrayValue)>=0; iaFindAndAddIfNotExisting: result := nested.FindAndAddIfNotExisting(aArrayValue)>=0; iaAdd: result := nested.Add(aArrayValue)>=0; end; finally fSafe.UnLock; end; end; function TSynDictionary.FindInArray(const aKey, aArrayValue): boolean; begin result := InArray(aKey,aArrayValue,iaFind); end; function TSynDictionary.FindKeyFromValue(const aValue; out aKey; aUpdateTimeOut: boolean): boolean; var ndx: integer; begin fSafe.Lock; try ndx := fValues.IndexOf(aValue); result := ndx>=0; if result then begin fKeys.ElemCopyAt(ndx,aKey); if aUpdateTimeOut then SetTimeoutAtIndex(ndx); end; finally fSafe.UnLock; end; end; function TSynDictionary.DeleteInArray(const aKey, aArrayValue): boolean; begin result := InArray(aKey,aArrayValue,iaFindAndDelete); end; function TSynDictionary.UpdateInArray(const aKey, aArrayValue): boolean; begin result := InArray(aKey,aArrayValue,iaFindAndUpdate); end; function TSynDictionary.AddInArray(const aKey, aArrayValue): boolean; begin result := InArray(aKey,aArrayValue,iaAdd); end; function TSynDictionary.AddOnceInArray(const aKey, aArrayValue): boolean; begin result := InArray(aKey,aArrayValue,iaFindAndAddIfNotExisting); end; function TSynDictionary.Find(const aKey; aUpdateTimeOut: boolean): integer; var tim: cardinal; begin // caller is expected to call fSafe.Lock/Unlock if self=nil then result := -1 else result := fKeys.FindHashed(aKey); if aUpdateTimeOut and (result>=0) then begin tim := fSafe.Padding[DIC_TIMESEC].VInteger; if tim>0 then // inlined fTimeout[result] := GetTimeout fTimeout[result] := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim; end; end; function TSynDictionary.FindValue(const aKey; aUpdateTimeOut: boolean; aIndex: PInteger): pointer; var ndx: PtrInt; begin ndx := Find(aKey,aUpdateTimeOut); if aIndex<>nil then aIndex^ := ndx; if ndx<0 then result := nil else result := pointer(PtrUInt(fValues.fValue^)+PtrUInt(ndx)*fValues.ElemSize); end; function TSynDictionary.FindValueOrAdd(const aKey; var added: boolean; aIndex: PInteger): pointer; var ndx: integer; tim: cardinal; begin tim := fSafe.Padding[DIC_TIMESEC].VInteger; // inlined tim := GetTimeout if tim<>0 then tim := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim; ndx := fKeys.FindHashedForAdding(aKey,added); if added then begin with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do ElemCopyFrom(aKey,ndx); // fKey[i] := aKey fValues.SetCount(ndx+1); // reserve new place for associated value if tim>0 then fTimeOuts.Add(tim); end else if tim>0 then fTimeOut[ndx] := tim; if aIndex<>nil then aIndex^ := ndx; result := fValues.ElemPtr(ndx); end; function TSynDictionary.FindAndCopy(const aKey; out aValue; aUpdateTimeOut: boolean): boolean; var ndx: integer; begin fSafe.Lock; try ndx := Find(aKey, aUpdateTimeOut); if ndx>=0 then begin fValues.ElemCopyAt(ndx,aValue); result := true; end else result := false; finally fSafe.UnLock; end; end; function TSynDictionary.FindAndExtract(const aKey; out aValue): boolean; var ndx: integer; begin fSafe.Lock; try ndx := fKeys.FindHashedAndDelete(aKey); if ndx>=0 then begin fValues.ElemCopyAt(ndx,aValue); fValues.Delete(ndx); if fSafe.Padding[DIC_TIMESEC].VInteger>0 then fTimeOuts.Delete(ndx); result := true; end else result := false; finally fSafe.UnLock; end; end; function TSynDictionary.Exists(const aKey): boolean; begin fSafe.Lock; try result := fKeys.FindHashed(aKey)>=0; finally fSafe.UnLock; end; end; {$ifndef DELPHI5OROLDER} procedure TSynDictionary.CopyValues(out Dest; ObjArrayByRef: boolean); begin fSafe.Lock; try fValues.CopyTo(Dest,ObjArrayByRef); finally fSafe.UnLock; end; end; {$endif DELPHI5OROLDER} function TSynDictionary.ForEach(const OnEach: TSynDictionaryEvent; Opaque: pointer): integer; var k,v: PAnsiChar; i,n,ks,vs: integer; begin result := 0; fSafe.Lock; try n := fSafe.Padding[DIC_KEYCOUNT].VInteger; if (n=0) or not Assigned(OnEach) then exit; k := fKeys.Value^; ks := fKeys.ElemSize; v := fValues.Value^; vs := fValues.ElemSize; for i := 0 to n-1 do begin inc(result); if not OnEach(k^,v^,i,n,Opaque) then break; inc(k,ks); inc(v,vs); end; finally fSafe.UnLock; end; end; function TSynDictionary.ForEach(const OnMatch: TSynDictionaryEvent; KeyCompare,ValueCompare: TDynArraySortCompare; const aKey,aValue; Opaque: pointer): integer; var k,v: PAnsiChar; i,n,ks,vs: integer; begin fSafe.Lock; try result := 0; if not Assigned(OnMatch) or (not Assigned(KeyCompare) and not Assigned(ValueCompare)) then exit; n := fSafe.Padding[DIC_KEYCOUNT].VInteger; k := fKeys.Value^; ks := fKeys.ElemSize; v := fValues.Value^; vs := fValues.ElemSize; for i := 0 to n-1 do begin if (Assigned(KeyCompare) and (KeyCompare(k^,aKey)=0)) or (Assigned(ValueCompare) and (ValueCompare(v^,aValue)=0)) then begin inc(result); if not OnMatch(k^,v^,i,n,Opaque) then break; end; inc(k,ks); inc(v,vs); end; finally fSafe.UnLock; end; end; procedure TSynDictionary.SetTimeoutAtIndex(aIndex: integer); var tim: cardinal; begin if cardinal(aIndex) >= cardinal(fSafe.Padding[DIC_KEYCOUNT].VInteger) then exit; tim := fSafe.Padding[DIC_TIMESEC].VInteger; if tim > 0 then fTimeOut[aIndex] := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim; end; function TSynDictionary.Count: integer; begin {$ifdef NOVARIANTS} result := RawCount; {$else} result := fSafe.LockedInt64[DIC_KEYCOUNT]; {$endif} end; function TSynDictionary.RawCount: integer; begin result := fSafe.Padding[DIC_KEYCOUNT].VInteger; end; procedure TSynDictionary.SaveToJSON(W: TTextWriter; EnumSetsAsText: boolean); var k,v: RawUTF8; begin fSafe.Lock; try fKeys.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}SaveToJSON(k,EnumSetsAsText); fValues.SaveToJSON(v,EnumSetsAsText); finally fSafe.UnLock; end; W.AddJSONArraysAsJSONObject(pointer(k),pointer(v)); end; function TSynDictionary.SaveToJSON(EnumSetsAsText: boolean): RawUTF8; var W: TTextWriter; temp: TTextWriterStackBuffer; begin W := TTextWriter.CreateOwnedStream(temp); try SaveToJSON(W,EnumSetsAsText); W.SetText(result); finally W.Free; end; end; function TSynDictionary.SaveValuesToJSON(EnumSetsAsText: boolean): RawUTF8; begin fSafe.Lock; try fValues.SaveToJSON(result,EnumSetsAsText); finally fSafe.UnLock; end; end; function TSynDictionary.LoadFromJSON(const JSON: RawUTF8; EnsureNoKeyCollision: boolean): boolean; begin result := LoadFromJSON(pointer(JSON),EnsureNoKeyCollision); end; function TSynDictionary.LoadFromJSON(JSON: PUTF8Char; EnsureNoKeyCollision: boolean): boolean; var k,v: RawUTF8; begin result := false; if not JSONObjectAsJSONArrays(JSON,k,v) then exit; fSafe.Lock; try if fKeys.LoadFromJSON(pointer(k))<>nil then if fValues.LoadFromJSON(pointer(v))<>nil then if fKeys.Count=fValues.Count then begin SetTimeouts; if EnsureNoKeyCollision then // fKeys.Rehash is not enough, since input JSON may be invalid result := fKeys.IsHashElementWithoutCollision<0 else begin // optimistic approach fKeys.Rehash; result := true; end; end; finally fSafe.UnLock; end; end; function TSynDictionary.LoadFromBinary(const binary: RawByteString): boolean; var P: PAnsiChar; begin result := false; P := pointer(fCompressAlgo.Decompress(binary)); if P=nil then exit; fSafe.Lock; try P := fKeys.LoadFrom(P); if P<>nil then P := fValues.LoadFrom(P); if (P<>nil) and (fKeys.Count=fValues.Count) then begin SetTimeouts; // set ComputeNextTimeOut for all items fKeys.ReHash; // optimistic: input from safe TSynDictionary.SaveToBinary result := true; end; finally fSafe.UnLock; end; end; class function TSynDictionary.OnCanDeleteSynPersistentLock(const aKey, aValue; aIndex: integer): boolean; begin result := not TSynPersistentLock(aValue).Safe^.IsLocked; end; class function TSynDictionary.OnCanDeleteSynPersistentLocked(const aKey, aValue; aIndex: integer): boolean; begin result := not TSynPersistentLock(aValue).Safe.IsLocked; end; function TSynDictionary.SaveToBinary(NoCompression: boolean): RawByteString; var tmp: TSynTempBuffer; trigger: integer; begin fSafe.Lock; try result := ''; if fSafe.Padding[DIC_KEYCOUNT].VInteger = 0 then exit; tmp.Init(fKeys.SaveToLength+fValues.SaveToLength); if fValues.SaveTo(fKeys.SaveTo(tmp.buf))-tmp.buf=tmp.len then begin if NoCompression then trigger := maxInt else trigger := 128; result := fCompressAlgo.Compress(tmp.buf,tmp.len,trigger); end; tmp.Done; finally fSafe.UnLock; end; end; { TSynQueue } constructor TSynQueue.Create(aTypeInfo: pointer); begin inherited Create; fFirst := -1; fLast := -2; fValues.Init(aTypeInfo,fValueVar,@fCount); end; destructor TSynQueue.Destroy; begin WaitPopFinalize; fValues.Clear; inherited Destroy; end; procedure TSynQueue.Clear; begin fSafe.Lock; try fValues.Clear; fFirst := -1; fLast := -2; finally fSafe.UnLock; end; end; function TSynQueue.Count: Integer; begin if self=nil then result := 0 else begin fSafe.Lock; try if fFirst<0 then result := 0 else if fFirst<=fLast then result := fLast-fFirst+1 else result := fCount-fFirst+fLast+1; finally fSafe.UnLock; end; end; end; function TSynQueue.Capacity: integer; begin if self=nil then result := 0 else begin fSafe.Lock; try result := fValues.Capacity; finally fSafe.UnLock; end; end; end; function TSynQueue.Pending: boolean; begin // allow some false positive: fSafe.Lock not used here result := (self<>nil) and (fFirst>=0); end; procedure TSynQueue.Push(const aValue); begin fSafe.Lock; try if fFirst<0 then begin fFirst := 0; // start from the bottom of the void queue fLast := 0; if fCount=0 then fValues.Count := 64; end else if fFirst<=fLast then begin // stored in-order inc(fLast); if fLast=fCount then InternalGrow; end else begin inc(fLast); if fLast=fFirst then begin // collision -> arrange fValues.AddArray(fValueVar,0,fLast); // move 0..fLast to the end fLast := fCount; InternalGrow; end; end; fValues.ElemCopyFrom(aValue,fLast); finally fSafe.UnLock; end; end; procedure TSynQueue.InternalGrow; var cap: integer; begin cap := fValues.Capacity; if fFirst>cap-fCount then // use leading space if worth it fLast := 0 else // append at the end if fCount=cap then // reallocation needed fValues.Count := cap+cap shr 3+64 else fCount := cap; // fill trailing memory as much as possible end; function TSynQueue.Peek(out aValue): boolean; begin fSafe.Lock; try result := fFirst>=0; if result then fValues.ElemCopyAt(fFirst,aValue); finally fSafe.UnLock; end; end; function TSynQueue.Pop(out aValue): boolean; begin fSafe.Lock; try result := fFirst>=0; if result then begin fValues.ElemMoveTo(fFirst,aValue); if fFirst=fLast then begin fFirst := -1; // reset whole store (keeping current capacity) fLast := -2; end else begin inc(fFirst); if fFirst=fCount then fFirst := 0; // will retrieve from leading items end; end; finally fSafe.UnLock; end; end; function TSynQueue.InternalDestroying(incPopCounter: integer): boolean; begin fSafe.Lock; try result := wpfDestroying in fWaitPopFlags; inc(fWaitPopCounter, incPopCounter); finally fSafe.UnLock; end; end; function TSynQueue.InternalWaitDone(endtix: Int64; const idle: TThreadMethod): boolean; begin Sleep(1); if Assigned(idle) then idle; // e.g. Application.ProcessMessages result := InternalDestroying(0) or (GetTickCount64>endtix); end; function TSynQueue.WaitPop(aTimeoutMS: integer; const aWhenIdle: TThreadMethod; out aValue): boolean; var endtix: Int64; begin result := false; if not InternalDestroying(+1) then try endtix := GetTickCount64+aTimeoutMS; repeat result := Pop(aValue); until result or InternalWaitDone(endtix,aWhenIdle); finally InternalDestroying(-1); end; end; function TSynQueue.WaitPeekLocked(aTimeoutMS: integer; const aWhenIdle: TThreadMethod): pointer; var endtix: Int64; begin result := nil; if not InternalDestroying(+1) then try endtix := GetTickCount64+aTimeoutMS; repeat fSafe.Lock; try if fFirst>=0 then result := fValues.ElemPtr(fFirst); finally if result=nil then fSafe.UnLock; // caller should always Unlock once done end; until (result<>nil) or InternalWaitDone(endtix,aWhenIdle); finally InternalDestroying(-1); end; end; procedure TSynQueue.WaitPopFinalize; var endtix: Int64; // never wait forever begin fSafe.Lock; try include(fWaitPopFlags,wpfDestroying); if fWaitPopCounter = 0 then exit; finally fSafe.UnLock; end; endtix := GetTickCount64 + 100; repeat Sleep(1); // ensure WaitPos() is actually finished until (fWaitPopCounter=0) or (GetTickCount64>endtix); end; procedure TSynQueue.Save(out aDynArrayValues; aDynArray: PDynArray); var n: integer; DA: TDynArray; begin DA.Init(fValues.ArrayType,aDynArrayValues,@n); fSafe.Lock; try DA.Capacity := Count; // pre-allocate whole array, and set its length if fFirst>=0 then if fFirst<=fLast then DA.AddArray(fValueVar,fFirst,fLast-fFirst+1) else begin DA.AddArray(fValueVar,fFirst,fCount-fFirst); DA.AddArray(fValueVar,0,fLast+1); end; finally fSafe.UnLock; end; if aDynArray<>nil then aDynArray^.Init(fValues.ArrayType,aDynArrayValues); end; { TMemoryMap } function TMemoryMap.Map(aFile: THandle; aCustomSize: PtrUInt; aCustomOffset: Int64): boolean; var Available: Int64; begin fBuf := nil; fBufSize := 0; {$ifdef MSWINDOWS} fMap := 0; {$endif} fFileLocal := false; fFile := aFile; fFileSize := FileSeek64(fFile,0,soFromEnd); if fFileSize=0 then begin result := true; // handle 0 byte file without error (but no memory map) exit; end; result := false; if (fFileSize<=0) {$ifdef CPU32}or (fFileSize>maxInt){$endif} then /// maxInt = $7FFFFFFF = 1.999 GB (2GB would induce PtrInt errors) exit; if aCustomSize=0 then fBufSize := fFileSize else begin Available := fFileSize-aCustomOffset; if Available<0 then exit; if aCustomSize>Available then fBufSize := Available; fBufSize := aCustomSize; end; {$ifdef MSWINDOWS} with PInt64Rec(@fFileSize)^ do fMap := CreateFileMapping(fFile,nil,PAGE_READONLY,Hi,Lo,nil); if fMap=0 then raise ESynException.Create('TMemoryMap.Map: CreateFileMapping()=0'); with PInt64Rec(@aCustomOffset)^ do fBuf := MapViewOfFile(fMap,FILE_MAP_READ,Hi,Lo,fBufSize); if fBuf=nil then begin // Windows failed to find a contiguous VA space -> fall back on direct read CloseHandle(fMap); fMap := 0; {$else} if aCustomOffset<>0 then if aCustomOffset and (SystemInfo.dwPageSize-1)<>0 then raise ESynException.CreateUTF8('fpmmap(aCustomOffset=%) with SystemInfo.dwPageSize=%', [aCustomOffset,SystemInfo.dwPageSize]) else aCustomOffset := aCustomOffset div SystemInfo.dwPageSize; fBuf := {$ifdef KYLIX3}mmap{$else}fpmmap{$endif}( nil,fBufSize,PROT_READ,MAP_SHARED,fFile,aCustomOffset); if fBuf=MAP_FAILED then begin fBuf := nil; {$endif} end else result := true; end; procedure TMemoryMap.Map(aBuffer: pointer; aBufferSize: PtrUInt); begin fBuf := aBuffer; fFileSize := aBufferSize; fBufSize := aBufferSize; {$ifdef MSWINDOWS} fMap := 0; {$endif} fFile := 0; fFileLocal := false; end; function TMemoryMap.Map(const aFileName: TFileName): boolean; var F: THandle; begin result := false; // Memory-mapped file access does not go through the cache manager so // using FileOpenSequentialRead() is pointless here F := FileOpen(aFileName,fmOpenRead or fmShareDenyNone); if PtrInt(F)<0 then exit; if Map(F) then result := true else FileClose(F); fFileLocal := result; end; procedure TMemoryMap.UnMap; begin {$ifdef MSWINDOWS} if fMap<>0 then begin UnmapViewOfFile(fBuf); CloseHandle(fMap); fMap := 0; end; {$else} if (fBuf<>nil) and (fBufSize>0) then {$ifdef KYLIX3}munmap{$else}fpmunmap{$endif}(fBuf,fBufSize); {$endif} fBuf := nil; fBufSize := 0; if fFile<>0 then begin if fFileLocal then FileClose(fFile); fFile := 0; end; end; { TSynMemoryStream } constructor TSynMemoryStream.Create(const aText: RawByteString); begin inherited Create; SetPointer(pointer(aText),length(aText)); end; constructor TSynMemoryStream.Create(Data: pointer; DataLen: PtrInt); begin inherited Create; SetPointer(Data,DataLen); end; function TSynMemoryStream.Write(const Buffer; Count: Integer): Longint; begin {$ifdef FPC} result := 0; // makes FPC compiler happy {$endif} raise EStreamError.CreateFmt('Unexpected %s.Write',[ClassNameShort(self)^]); end; { TSynMemoryStreamMapped } constructor TSynMemoryStreamMapped.Create(const aFileName: TFileName; aCustomSize: PtrUInt; aCustomOffset: Int64); begin fFileName := aFileName; // Memory-mapped file access does not go through the cache manager so // using FileOpenSequentialRead() is pointless here fFileStream := TFileStream.Create(aFileName,fmOpenRead or fmShareDenyNone); Create(fFileStream.Handle,aCustomSize,aCustomOffset); end; constructor TSynMemoryStreamMapped.Create(aFile: THandle; aCustomSize: PtrUInt; aCustomOffset: Int64); begin if not fMap.Map(aFile,aCustomSize,aCustomOffset) then raise ESynException.CreateUTF8('%.Create(%) mapping error',[self,fFileName]); inherited Create(fMap.fBuf,fMap.fBufSize); end; destructor TSynMemoryStreamMapped.Destroy; begin fMap.UnMap; fFileStream.Free; inherited; end; function FileSeek64(Handle: THandle; const Offset: Int64; Origin: DWORD): Int64; {$ifdef MSWINDOWS} var R64: packed record Lo, Hi: integer; end absolute Result; begin Result := Offset; R64.Lo := integer(SetFilePointer(Handle,R64.Lo,@R64.Hi,Origin)); if (R64.Lo=-1) and (GetLastError<>0) then R64.Hi := -1; // so result=-1 end; {$else} begin {$ifdef FPC} result := FPLSeek(Handle,Offset,Origin); {$else} {$ifdef KYLIX3} result := LibC.lseek64(Handle,Offset,Origin); {$else} // warning: this won't handle file size > 2 GB :( result := FileSeek(Handle,Offset,Origin); {$endif} {$endif} end; {$endif} { TFileBufferWriter } constructor TFileBufferWriter.Create(aFile: THandle; BufLen: integer); begin Create(THandleStream.Create(aFile),BufLen); fInternalStream := true; end; constructor TFileBufferWriter.Create(const aFileName: TFileName; BufLen: integer; Append: boolean); var s: TStream; begin if Append and FileExists(aFileName) then begin s := TFileStream.Create(aFileName,fmOpenWrite); s.Seek(0,soFromEnd); end else s := TFileStream.Create(aFileName,fmCreate); Create(s,BufLen); fInternalStream := true; end; constructor TFileBufferWriter.Create(aStream: TStream; BufLen: integer); begin if BufLen>1 shl 22 then fBufLen := 1 shl 22 else // 4 MB sounds right enough if BufLen<32 then fBufLen := 32; fBufLen := BufLen; fStream := aStream; SetLength(fBufInternal,fBufLen); fBuffer := pointer(fBufInternal); end; constructor TFileBufferWriter.Create(aClass: TStreamClass; BufLen: integer); begin Create(aClass.Create,BufLen); fInternalStream := true; end; constructor TFileBufferWriter.Create(aStream: TStream; aTempBuf: pointer; aTempLen: integer); begin fBufLen := aTempLen; fBuffer := aTempBuf; fStream := aStream; end; constructor TFileBufferWriter.Create(aClass: TStreamClass; aTempBuf: pointer; aTempLen: integer); begin Create(aClass.Create,aTempBuf,aTempLen); fInternalStream := true; end; destructor TFileBufferWriter.Destroy; begin if fInternalStream then fStream.Free; inherited; end; function TFileBufferWriter.Flush: Int64; begin if fPos>0 then begin fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; end; result := fTotalWritten; fTotalWritten := 0; end; procedure TFileBufferWriter.CancelAll; begin fTotalWritten := 0; fPos := 0; if fStream.ClassType = TRawByteStringStream then TRawByteStringStream(fStream).Size := 0 else fStream.Seek(0,soBeginning); end; procedure TFileBufferWriter.Write(Data: pointer; DataLen: integer); begin if (DataLen<=0) or (Data=nil) then exit; inc(fTotalWritten,DataLen); if fPos+DataLen>fBufLen then begin if fPos>0 then begin fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; end; if DataLen>fBufLen then begin fStream.WriteBuffer(Data^,DataLen); exit; end; end; {$ifdef FPC}Move{$else}MoveFast{$endif}(Data^,fBuffer^[fPos],DataLen); inc(fPos,DataLen); end; procedure TFileBufferWriter.WriteN(Data: Byte; Count: integer); var len: integer; begin inc(fTotalWritten,Count); while Count>0 do begin if Count>fBufLen then len := fBufLen else len := Count; if fPos+len>fBufLen then begin fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; end; {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(fBuffer^[fPos],len,Data); inc(fPos,len); dec(Count,len); end; end; procedure TFileBufferWriter.Write1(Data: byte); begin if fPos+1>fBufLen then begin fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; end; fBuffer^[fPos] := Data; inc(fPos); inc(fTotalWritten); end; procedure TFileBufferWriter.Write2(Data: word); begin if fPos+2>fBufLen then begin fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; end; PWord(@fBuffer^[fPos])^ := Data; inc(fPos,SizeOf(Word)); inc(fTotalWritten,SizeOf(Word)); end; procedure TFileBufferWriter.Write4(Data: integer); begin if fPos+SizeOf(integer)>fBufLen then begin fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; end; PInteger(@fBuffer^[fPos])^ := Data; inc(fPos,SizeOf(integer)); inc(fTotalWritten,SizeOf(integer)); end; procedure TFileBufferWriter.Write4BigEndian(Data: integer); begin Write4({$ifdef FPC}SwapEndian{$else}bswap32{$endif}(Data)); end; procedure TFileBufferWriter.Write8(const Data8Bytes); begin if fPos+SizeOf(Int64)>fBufLen then begin fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; end; PInt64(@fBuffer^[fPos])^ := Int64(Data8Bytes); inc(fPos,SizeOf(Int64)); inc(fTotalWritten,SizeOf(Int64)); end; procedure TFileBufferWriter.Write(const Text: RawByteString); var L: integer; begin L := length(Text); if L=0 then Write1(0) else begin WriteVarUInt32(L); Write(pointer(Text),L); end; end; procedure TFileBufferWriter.WriteShort(const Text: ShortString); var L: integer; begin L := ord(Text[0]); if L<$80 then Write(@Text[0],L+1) else begin WriteVarUInt32(L); Write(@Text[1],L); end; end; procedure TFileBufferWriter.WriteBinary(const Data: RawByteString); begin Write(pointer(Data),Length(Data)); end; procedure TFileBufferWriter.WriteDynArray(const DA: TDynArray); var len: integer; tmp: RawByteString; P: PAnsiChar; begin len := DA.SaveToLength; if (len<=fBufLen) and (fPos+len>fBufLen) then begin fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; end; if fPos+len>fBufLen then begin SetLength(tmp,len); P := pointer(tmp); end else P := @fBuffer^[fPos]; // write directly into the buffer if DA.SaveTo(P)-P<>len then raise ESynException.CreateUTF8('%.WriteDynArray DA.SaveTo?',[self]); if tmp='' then begin inc(fPos,len); inc(fTotalWritten,len); end else Write(pointer(tmp),len); end; {$ifndef NOVARIANTS} procedure TFileBufferWriter.Write(const Value: variant); procedure CustomType; // same code as VariantSave/VariantSaveLen begin Write(@TVarData(Value).VType,SizeOf(TVarData(Value).VType)); Write(VariantSaveJSON(Value)); end; var tmp,buf: PAnsiChar; len: integer; begin if TVarData(Value).VType>varAny then begin CustomType; // faster process without calling VariantSaveLength() for JSON exit; end; tmp := nil; len := VariantSaveLength(Value); if len=0 then raise ESynException.CreateUTF8('%.Write(VType=%) VariantSaveLength=0', [self,TVarData(Value).VType]); if fPos+len>fBufLen then begin fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; if len>fBufLen then begin GetMem(tmp,len); buf := tmp; end else buf := pointer(fBuffer); end else buf := @fBuffer^[fPos]; if VariantSave(Value,buf)=nil then raise ESynException.CreateUTF8('%.Write(VType=%) VariantSave=nil', [self,TVarData(Value).VType]); inc(fTotalWritten,len); if tmp=nil then inc(fPos,len) else begin fStream.WriteBuffer(tmp^,len); FreeMem(tmp); end; end; procedure TFileBufferWriter.WriteDocVariantData(const Value: variant); begin with _Safe(Value)^ do if Count=0 then Write1(0) else Write(ToJSON); end; {$endif NOVARIANTS} procedure TFileBufferWriter.WriteXor(New,Old: PAnsiChar; Len: integer; crc: PCardinal); var L: integer; Dest: PAnsiChar; begin if (New=nil) or (Old=nil) then exit; inc(fTotalWritten,Len); while Len>0 do begin Dest := pointer(fBuffer); if fPos+Len>fBufLen then begin fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; end else inc(Dest,fPos); if Len>fBufLen then L := fBufLen else L := Len; XorMemory(pointer(Dest),pointer(New),pointer(Old),L); if crc<>nil then crc^ := crc32c(crc^,Dest,L); inc(Old,L); inc(New,L); dec(Len,L); inc(fPos,L); end; end; procedure TFileBufferWriter.WriteRawUTF8DynArray(const Values: TRawUTF8DynArray; ValuesCount: integer); var PI: PPtrUIntArray; n, i: integer; fixedsize, len: PtrUInt; P, PEnd: PByte; PBeg: PAnsiChar; begin WriteVarUInt32(ValuesCount); PI := pointer(Values); if ValuesCount=0 then exit; fixedsize := length(Values[0]); if fixedsize>0 then for i := 1 to ValuesCount-1 do if (PI^[i]=0) or ({$ifdef FPC}PtrUInt(_LStrLenP(pointer(PI^[i]))){$else} PCardinal(PI^[i]-SizeOf(integer))^{$endif}<>fixedsize) then begin fixedsize := 0; break; end; WriteVarUInt32(fixedsize); repeat P := @fBuffer^[fPos]; PEnd := @fBuffer^[fBufLen-8]; if PtrUInt(P)=PtrUInt(PEnd) then begin n := i+1; break; // avoid buffer overflow end; end else begin len := {$ifdef FPC}_LStrLenP(pointer(PI^[i])){$else}PInteger(PI^[i]-SizeOf(integer))^{$endif}; if PtrUInt(PEnd)-PtrUInt(P)<=len then begin n := i; break; // avoid buffer overflow end; P := ToVarUInt32(len,P); {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(PI^[i])^,P^,len); inc(P,len); end else // fixed size strings case for i := 0 to ValuesCount-1 do begin if PtrUInt(PEnd)-PtrUInt(P)<=fixedsize then begin n := i; break; // avoid buffer overflow end; {$ifdef FPC}Move{$else}MoveFast{$endif}(pointer(PI^[i])^,P^,fixedsize); inc(P,fixedsize); end; len := PAnsiChar(P)-PBeg; // format: Isize+varUInt32s*strings PInteger(PBeg)^ := len-4; inc(fTotalWritten,len); inc(fPos,len); inc(PByte(PI),n*SizeOf(PtrInt)); dec(ValuesCount,n); if ValuesCount=0 then break; end; fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; until false; end; procedure TFileBufferWriter.WriteRawUTF8List(List: TRawUTF8List; StoreObjectsAsVarUInt32: Boolean); var i: integer; begin if List=nil then WriteVarUInt32(0) else begin WriteRawUTF8DynArray(List.fList,List.Count); if List.fObjects=nil then StoreObjectsAsVarUInt32 := false; // no Objects[] values Write(@StoreObjectsAsVarUInt32,1); if StoreObjectsAsVarUInt32 then for i := 0 to List.fCount-1 do WriteVarUInt32(PtrUInt(List.fObjects[i])); end; end; procedure TFileBufferWriter.WriteStream(aStream: TCustomMemoryStream; aStreamSize: Integer); begin if aStreamSize<0 then if aStream=nil then aStreamSize := 0 else aStreamSize := aStream.Size; WriteVarUInt32(aStreamSize); if aStreamSize>0 then Write(aStream.Memory,aStreamSize); end; procedure TFileBufferWriter.WriteVarInt32(Value: PtrInt); begin if Value<=0 then // 0->0, -1->2, -2->4.. Value := (-Value) shl 1 else // 1->1, 2->3.. Value := (Value shl 1)-1; WriteVarUInt32(Value); end; procedure TFileBufferWriter.WriteVarUInt32(Value: PtrUInt); var pos: integer; begin if fPos+16>fBufLen then begin fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; end; pos := fPos; fPos := PtrUInt(ToVarUInt32(Value,@fBuffer^[fPos]))-PtrUInt(fBuffer); inc(fTotalWritten,PtrUInt(fPos-Pos)); end; procedure TFileBufferWriter.WriteVarInt64(Value: Int64); var pos: integer; begin if fPos+48>fBufLen then begin fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; end; pos := fPos; fPos := PtrUInt(ToVarInt64(Value,@fBuffer^[fPos]))-PtrUInt(fBuffer); inc(fTotalWritten,PtrUInt(fPos-Pos)); end; procedure TFileBufferWriter.WriteVarUInt64(Value: QWord); var pos: integer; begin if fPos+48>fBufLen then begin fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; end; pos := fPos; fPos := PtrUInt(ToVarUInt64(Value,@fBuffer^[fPos]))-PtrUInt(fBuffer); inc(fTotalWritten,PtrUInt(fPos-Pos)); end; function CleverStoreInteger(p: PInteger; V, VEnd: PAnsiChar; pCount: integer; var StoredCount: integer): PAnsiChar; // Clever = store Values[i+1]-Values[i] (with special diff=1 count) // format: Integer: firstValue, then: // B:0 W:difference with previous // B:1..253 = difference with previous // B:254 W:byOne // B:255 B:byOne var i, d, byOne: integer; begin StoredCount := pCount; if pCount<=0 then begin result := V; exit; end; i := p^; PInteger(V)^ := p^; inc(V,4); dec(pCount); inc(p); byOne := 0; if pCount>0 then repeat d := p^-i; i := p^; inc(p); if d=1 then begin dec(pCount); inc(byOne); if pCount>0 then continue; end else if d<0 then begin result:= nil; exit; end; if byOne<>0 then begin case byOne of 1: begin V^ := #1; inc(V); end; // B:1..253 = difference with previous 2: begin PWord(V)^ := $0101; inc(V,2); end; // B:1..253 = difference else if byOne>255 then begin while byOne>65535 do begin PInteger(V)^ := $fffffe; inc(V,3); // store as many len=$ffff as necessary dec(byOne,$ffff); end; PInteger(V)^ := byOne shl 8+$fe; inc(V,3); // B:254 W:byOne end else begin PWord(V)^ := byOne shl 8+$ff; inc(V,2); // B:255 B:byOne end; end; // case byOne of if pCount=0 then break; byOne := 0; end; if (d=0) or (d>253) then begin while cardinal(d)>65535 do begin PInteger(V)^ := $ffff00; inc(V,3); // store as many len=$ffff as necessary dec(cardinal(d),$ffff); end; dec(pCount); PInteger(V)^ := d shl 8; inc(V,3); // B:0 W:difference with previous if (V0) then continue else break; end else begin dec(pCount); V^ := AnsiChar(d); inc(V); // B:1..253 = difference with previous if (V0) then continue else break; end; if V>=VEnd then break; // avoid GPF until false; dec(StoredCount,pCount); result := V; end; procedure TFileBufferWriter.WriteVarUInt32Array(const Values: TIntegerDynArray; ValuesCount: integer; DataLayout: TFileBufferWriterKind); begin WriteVarUInt32Values(pointer(Values),ValuesCount,DataLayout); end; procedure TFileBufferWriter.WriteVarUInt32Values(Values: PIntegerArray; ValuesCount: integer; DataLayout: TFileBufferWriterKind); var n, i, pos, diff: integer; P: PByte; PBeg, PEnd: PAnsiChar; begin WriteVarUInt32(ValuesCount); if ValuesCount=0 then exit; fBuffer^[fPos] := ord(DataLayout); inc(fPos); inc(fTotalWritten); if DataLayout in [wkOffsetU, wkOffsetI] then begin pos := fPos; fPos := PtrUInt(ToVarUInt32(Values^[0],@fBuffer^[fPos]))-PtrUInt(fBuffer); diff := Values^[1]-Values^[0]; inc(PInteger(Values)); dec(ValuesCount); if ValuesCount=0 then begin inc(fTotalWritten,PtrUInt(fPos-pos)); exit; end; if diff>0 then begin for i := 1 to ValuesCount-1 do if Values^[i]-Values^[i-1]<>diff then begin diff := 0; // not always the same offset break; end; end else diff := 0; fPos := PtrUInt(ToVarUInt32(diff,@fBuffer^[fPos]))-PtrUInt(fBuffer); inc(fTotalWritten,PtrUInt(fPos-pos)); if diff<>0 then exit; // same offset for all items (fixed sized records) -> quit now end; repeat P := @fBuffer^[fPos]; PEnd := @fBuffer^[fBufLen-32]; if PtrUInt(P)=PtrUInt(PEnd) then begin n := i+1; break; // avoid buffer overflow end; end; wkVarUInt32: for i := 0 to ValuesCount-1 do begin P := ToVarUInt32(Values^[i],P); if PtrUInt(P)>=PtrUInt(PEnd) then begin n := i+1; break; // avoid buffer overflow end; end; wkOffsetU: for i := 0 to ValuesCount-1 do begin P := ToVarUInt32(Values^[i]-Values^[i-1],P); if PtrUInt(P)>=PtrUInt(PEnd) then begin n := i+1; break; // avoid buffer overflow end; end; wkOffsetI: for i := 0 to ValuesCount-1 do begin P := ToVarInt32(Values^[i]-Values^[i-1],P); if PtrUInt(P)>=PtrUInt(PEnd) then begin n := i+1; break; // avoid buffer overflow end; end; end; PInteger(PBeg)^ := PAnsiChar(P)-PBeg-4; // format: Isize+varUInt32s end; wkSorted: begin PBeg := PAnsiChar(P)+4; // leave space for chunk size P := PByte(CleverStoreInteger(pointer(Values),PBeg,PEnd,ValuesCount,n)); if P=nil then raise ESynException.CreateUTF8('%.WriteVarUInt32Array: data not sorted',[self]); PInteger(PBeg-4)^ := PAnsiChar(P)-PBeg; // format: Isize+cleverStorage end; end; inc(PByte(Values),n*4); fPos := PtrUInt(P)-PtrUInt(fBuffer); inc(fTotalWritten,PtrUInt(fPos-pos)); dec(ValuesCount,n); if ValuesCount=0 then break; end; fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; until false; end; procedure TFileBufferWriter.WriteVarUInt64DynArray( const Values: TInt64DynArray; ValuesCount: integer; Offset: Boolean); var n, i, pos: integer; diff: Int64; P, PEnd: PByte; PI: PInt64Array; PBeg: PAnsiChar; begin WriteVarUInt32(ValuesCount); if ValuesCount=0 then exit; PI := pointer(Values); pos := fPos; if Offset then begin fBuffer^[fPos] := 1; fPos := PtrUInt(ToVarUInt64(PI^[0],@fBuffer^[fPos+1]))-PtrUInt(fBuffer); diff := PI^[1]-PI^[0]; inc(PByte(PI),8); dec(ValuesCount); if ValuesCount=0 then begin inc(fTotalWritten,PtrUInt(fPos-pos)); exit; end; if (diff>0) and (diffdiff then begin diff := 0; // not always the same offset break; end; end else diff := 0; fPos := PtrUInt(ToVarUInt32(diff,@fBuffer^[fPos]))-PtrUInt(fBuffer); if diff<>0 then begin inc(fTotalWritten,PtrUInt(fPos-Pos)); exit; // same offset for all items (fixed sized records) -> quit now end; end else begin fBuffer^[fPos] := 0; inc(fPos); end; inc(fTotalWritten,PtrUInt(fPos-Pos)); repeat P := @fBuffer^[fPos]; PEnd := @fBuffer^[fBufLen-32]; if PtrUInt(P)=PtrUInt(PEnd) then begin n := i+1; break; // avoid buffer overflow end; end else for i := 0 to ValuesCount-1 do begin P := ToVarUInt64(PI^[i],P); if PtrUInt(P)>=PtrUInt(PEnd) then begin n := i+1; break; // avoid buffer overflow end; end; PInteger(PBeg)^ := PAnsiChar(P)-PBeg-4; // format: Isize+varUInt32/64s inc(PByte(PI),n*8); fPos := PtrUInt(P)-PtrUInt(fBuffer); inc(fTotalWritten,PtrUInt(fPos-Pos)); dec(ValuesCount,n); if ValuesCount=0 then break; end; fStream.WriteBuffer(fBuffer^,fPos); fPos := 0; until false; end; function TFileBufferWriter.FlushAndCompress(nocompression: boolean; algo: TAlgoCompress; BufferOffset: integer): RawByteString; var trig: integer; begin if algo=nil then algo := AlgoSynLZ; trig := SYNLZTRIG[nocompression]; if fStream.Position=0 then // direct compression from internal buffer result := algo.Compress(PAnsiChar(fBuffer),fPos,trig,false,BufferOffset) else begin Flush; result := algo.Compress((fStream as TRawByteStringStream).DataString,trig,false,BufferOffset); end; end; function TFileBufferWriter.WriteDirectStart(maxSize: integer; const TooBigMessage: RawUTF8): PByte; begin inc(maxSize,fPos); if maxSize>fBufLen then begin fTotalWritten := Flush; if maxSize>fBufLen then begin if maxSize>100 shl 20 then raise ESynException.CreateUTF8('%.WriteDirectStart: too big % - '+ 'we allow up to 100 MB block',[self,TooBigMessage]); if fBufInternal='' then raise ESynException.CreateUTF8('%.WriteDirectStart: no internal buffer', [self]); fBufLen := maxSize+1024; SetString(fBufInternal,nil,fBufLen); fBuffer := pointer(fBufInternal); end; end; result := @fBuffer^[fPos]; end; procedure TFileBufferWriter.WriteDirectEnd(realSize: integer); begin if fPos+realSize>fBufLen then raise ESynException.CreateUTF8( '%.WriteDirectEnd: too big %',[self,realSize]); inc(fPos,realSize); inc(fTotalWritten,realSize); end; { TFileBufferReader } procedure TFileBufferReader.Close; begin fMap.UnMap; end; procedure TFileBufferReader.ErrorInvalidContent; begin raise ESynException.Create('TFileBufferReader: invalid content'); end; procedure TFileBufferReader.OpenFrom(aBuffer: pointer; aBufferSize: PtrUInt); begin fCurrentPos := 0; fMap.Map(aBuffer,aBufferSize); end; procedure TFileBufferReader.OpenFrom(const aBuffer: RawByteString); begin OpenFrom(pointer(aBuffer),length(aBuffer)); end; function TFileBufferReader.OpenFrom(Stream: TStream): boolean; begin result := false; if Stream=nil then exit; if Stream.InheritsFrom(TFileStream) then Open(TFileStream(Stream).Handle) else if Stream.InheritsFrom(TCustomMemoryStream) then with TCustomMemoryStream(Stream) do OpenFrom(Memory,Size) else exit; result := true end; procedure TFileBufferReader.Open(aFile: THandle); begin fCurrentPos := 0; fMap.Map(aFile) // if Windows failed to find a contiguous VA space -> fall back on direct read end; function TFileBufferReader.Read(Data: pointer; DataLen: integer): integer; var len: integer; begin if DataLen>0 then if fMap.fBuf<>nil then begin // file up to 2 GB: use fast memory map len := fMap.fBufSize-fCurrentPos; if len>DataLen then len := DataLen; if Data<>nil then {$ifdef FPC}Move{$else}MoveFast{$endif}(fMap.fBuf[fCurrentPos],Data^,len); inc(fCurrentPos,len); result := len; end else // file bigger than 2 GB: slower but accurate reading from file if Data=nil then begin FileSeek(fMap.fFile,soFromCurrent,DataLen); result := DataLen; end else result := FileRead(fMap.fFile,Data^,DataLen) else // DataLen=0 result := 0; end; function TFileBufferReader.Read(out Text: RawByteString): integer; begin result := ReadVarUInt32; if result=0 then exit; SetLength(Text,result); if Read(pointer(Text),result)<>result then ErrorInvalidContent; end; function TFileBufferReader.Read(out Text: RawUTF8): integer; begin result := ReadVarUInt32; if result=0 then exit; SetLength(Text,result); if Read(pointer(Text),result)<>result then ErrorInvalidContent; end; function TFileBufferReader.ReadRawUTF8: RawUTF8; begin Read(result); end; procedure TFileBufferReader.ReadChunk(out P, PEnd: PByte; var BufTemp: RawByteString); var len: integer; begin // read Isize + buffer in P,PEnd if (Read(@len,4)<>4) or (len<0) then ErrorInvalidContent; P := ReadPointer(len,BufTemp); if P=nil then ErrorInvalidContent; PEnd := pointer(PtrUInt(P)+PtrUInt(len)); end; function TFileBufferReader.CurrentMemory(DataLen: PtrUInt): pointer; begin if (fMap.fBuf=nil) or (fCurrentPos+DataLen>=fMap.fBufSize) then result := nil else begin result := @fMap.fBuf[fCurrentPos]; inc(fCurrentPos,DataLen); end; end; function TFileBufferReader.CurrentPosition: integer; begin if (fMap.fBuf=nil) or (fCurrentPos>=fMap.fBufSize) then result := -1 else result := fCurrentPos; end; function TFileBufferReader.ReadPointer(DataLen: PtrUInt; var aTempData: RawByteString): pointer; begin if fMap.fBuf=nil then begin // read from file if DataLen>PtrUInt(Length(aTempData)) then begin aTempData := ''; // so no move() call in SetLength() below SetLength(aTempData,DataLen); end; if PtrUInt(FileRead(fMap.fFile,pointer(aTempData)^,DataLen))<>DataLen then result := nil else // invalid content result := pointer(aTempData); end else if DataLen+fCurrentPos>fMap.fBufSize then // invalid request result := nil else begin // get pointer to data from current memory map (no data copy) result := @fMap.fBuf[fCurrentPos]; inc(fCurrentPos,DataLen); end; end; function TFileBufferReader.ReadStream(DataLen: PtrInt): TCustomMemoryStream; var FileCurrentPos: Int64; begin if DataLen<0 then DataLen := ReadVarUInt32; if DataLen<>0 then if fMap.fBuf=nil then begin FileCurrentPos := FileSeek64(fMap.fFile,0,soFromCurrent); if FileCurrentPos+DataLen>fMap.fFileSize then // invalid content result := nil else begin // create a temporary memory map buffer stream result := TSynMemoryStreamMapped.Create(fMap.fFile,DataLen,FileCurrentPos); FileSeek64(fMap.fFile,DataLen,soFromCurrent); end; end else if PtrUInt(DataLen)+fCurrentPos>fMap.fBufSize then // invalid content result := nil else begin // get pointer to data from current memory map (no data copy) result := TSynMemoryStream.Create(@fMap.fBuf[fCurrentPos],DataLen); inc(fCurrentPos,DataLen); end else // DataLen=0 -> invalid content result := nil; end; function TFileBufferReader.ReadByte: PtrUInt; begin if fMap.fBuf<>nil then if fCurrentPos>=fMap.fBufSize then // invalid request result := 0 else begin // read one byte from current memory map result := ord(fMap.fBuf[fCurrentPos]); inc(fCurrentPos); end else begin // read from file if >= 2 GB (slow, but works) result := 0; if FileRead(fMap.fFile,result,1)<>1 then result := 0; end; end; function TFileBufferReader.ReadCardinal: cardinal; begin if fMap.fBuf<>nil then if fCurrentPos+3>=fMap.fBufSize then // invalid request result := 0 else begin // read one byte from current memory map result := PCardinal(fMap.fBuf+fCurrentPos)^; inc(fCurrentPos,4); end else begin // read from file if >= 2 GB (slow, but works) result := 0; if FileRead(fMap.fFile,result,4)<>4 then result := 0; end; end; function TFileBufferReader.ReadVarUInt32: PtrUInt; var c, n: PtrUInt; begin result := ReadByte; if result>$7f then begin n := 0; result := result and $7F; repeat c := ReadByte; inc(n,7); if c<=$7f then break; result := result or ((c and $7f) shl n); until false; result := result or (c shl n); end; end; function TFileBufferReader.ReadVarInt32: PtrInt; begin result := ReadVarUInt32; if result and 1<>0 then // 1->1, 3->2.. result := result shr 1+1 else // 0->0, 2->-1, 4->-2.. result := -(result shr 1); end; function TFileBufferReader.ReadVarUInt64: QWord; var c, n: PtrUInt; begin result := ReadByte; if result>$7f then begin n := 0; result := result and $7F; repeat c := ReadByte; inc(n,7); if c<=$7f then break; result := result or (QWord(c and $7f) shl n); until false; result := result or (QWord(c) shl n); end; end; function TFileBufferReader.ReadVarInt64: Int64; begin result := ReadVarUInt64; if result<>0 then if result and 1<>0 then // 1->1, 3->2.. result := result shr 1+1 else // 0->0, 2->-1, 4->-2.. result := -(result shr 1); end; function CleverReadInteger(p, pEnd: PAnsiChar; V: PInteger): PtrUInt; // Clever = decode Values[i+1]-Values[i] storage (with special diff=1 count) var i, n: PtrUInt; begin result := PtrUInt(V); i := PInteger(p)^; inc(p,4); // Integer: firstValue V^ := i; inc(V); if PtrUInt(p)length(Values) then // only set length is not big enough SetLength(Values,count); PI := pointer(Values); if DataLayout in [wkOffsetU, wkOffsetI] then begin PI^ := ReadVarUInt32; dec(count); if count=0 then exit; diff := ReadVarUInt32; if diff<>0 then begin for i := 0 to count-1 do PIA^[i+1] := PIA^[i]+diff; exit; end; end; if DataLayout=wkUInt32 then Read(@Values[0],count*4) else begin repeat ReadChunk(P,PEnd,BufTemp); // raise ErrorInvalidContent on error case DataLayout of wkVarInt32: while (count>0) and (PtrUInt(P)0) and (PtrUInt(P)0) and (PtrUInt(P)0) and (PtrUInt(P)@Values[result] then ErrorInvalidContent; end; end; function TFileBufferReader.ReadVarUInt64Array(var Values: TInt64DynArray): PtrInt; var count, diff, i: integer; Offset: boolean; P, PEnd: PByte; PI: PInt64; PIA: PInt64Array absolute PI; BufTemp: RawByteString; label delphi5bug; // circumvent internal error C3517 on Delphi 5 begin result := ReadVarUInt32; if result=0 then exit; count := result; if count>length(Values) then // only set length is not big enough SetLength(Values,count); Offset := boolean(ReadByte); PI := pointer(Values); if Offset then begin PI^ := ReadVarUInt64; // read first value dec(count); diff := ReadVarUInt32; if diff=0 then begin // read all offsets, and compute (not fixed sized records) repeat ReadChunk(P,PEnd,BufTemp); // raise ErrorInvalidContent on error while (count>0) and (PtrUInt(P)nil) and (List<>nil) then with List do begin BeginUpdate; try Capacity := 0; // finalize both fObjects[] and fList[] fCount := ReadVarRawUTF8DynArray(List.fList); result := true; if fCount=0 then exit; Read(@StoreObjectsAsVarUInt32,1); if StoreObjectsAsVarUInt32 then begin fObjectsOwned := false; // Int32 here, not instances SetLength(fObjects,Capacity); for i := 0 to fCount-1 do fObjects[i] := TObject(ReadVarUInt32); end; finally EndUpdate; end; end else result := false; end; function TFileBufferReader.ReadVarRawUTF8DynArray(var Values: TRawUTF8DynArray): PtrInt; var count, len, fixedsize: integer; P, PEnd: PByte; PI: PRawUTF8; BufTemp: RawByteString; begin result := ReadVarUInt32; if result=0 then exit; count := result; if count>length(Values) then // only set length is not big enough SetLength(Values,count); PI := pointer(Values); fixedsize := ReadVarUInt32; repeat ReadChunk(P,PEnd,BufTemp); // raise ErrorInvalidContent on error if fixedsize=0 then while (count>0) and (PtrUInt(P)0 then begin FastSetString(PI^,P,len); inc(P,len); end else if PI^<>'' then PI^ := ''; dec(count); inc(PI); end else // fixed size strings case while (count>0) and (PtrUInt(P)@Values[result] then ErrorInvalidContent; end; {$ifndef CPU64} function TFileBufferReader.Seek(Offset: Int64): boolean; begin if (Offset<0) or (Offset>fMap.fFileSize) then result := False else if fMap.fBuf=nil then result := FileSeek64(fMap.fFile,Offset,soFromBeginning)=Offset else begin fCurrentPos := PCardinal(@Offset)^; result := true; end; end; {$endif CPU64} function TFileBufferReader.Seek(Offset: PtrInt): boolean; begin // we don't need to handle fMap=0 here if fMap.fBuf=nil then Result := FileSeek(fMap.fFile,Offset,0)=Offset else if (fMap.fBuf<>nil) and (PtrUInt(Offset)#0 do if not (ord(P^) in IsIdentifier) then exit else // following chars can be alphanumerical inc(P); result := true; end; function PropNamesValid(const Values: array of RawUTF8): boolean; var i,j: integer; begin result := false; for i := 0 to high(Values) do for j := 1 to length(Values[i]) do if not (ord(Values[i][j]) in IsIdentifier) then exit; result := true; end; function JsonPropNameValid(P: PUTF8Char): boolean; {$ifdef HASINLINENOTX86} begin if (P<>nil) and (ord(P^) in IsJsonIdentifierFirstChar) then begin repeat inc(P); until not(ord(P^) in IsJsonIdentifier); if P^=#0 then begin result := true; exit; end else begin result := false; exit; end; end else result := false; end; {$else} asm test eax, eax jz @z movzx edx, byte ptr[eax] bt [offset @first], edx mov ecx, offset @chars jb @2 @z: xor eax, eax ret @first: dd 0, $03FF0010, $87FFFFFE, $07FFFFFE, 0, 0, 0, 0 // IsJsonIdentifierFirstChar @chars: dd 0, $03FF4000, $AFFFFFFE, $07FFFFFE, 0, 0, 0, 0 // IsJsonIdentifier @s: mov dl, [eax] bt [ecx], edx jnb @1 @2: mov dl, [eax + 1] bt [ecx], edx jnb @1 mov dl, [eax + 2] bt [ecx], edx jnb @1 mov dl, [eax + 3] add eax, 4 bt [ecx], edx jb @s @1: test dl, dl setz al end; {$endif HASINLINENOTX86} function StrCompL(P1,P2: PUTF8Char; L, Default: Integer): PtrInt; var i: PtrInt; begin i := 0; repeat result := PtrInt(P1[i])-PtrInt(P2[i]); if result=0 then begin inc(i); if inil then begin f := PInt64(FieldName)^; result := (f and $ffdfdf=(ord('I')+ord('D')shl 8)) or (f and $ffdfdfdfdfdf= (ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24+Int64(ord('D')) shl 32)) end {$else} begin if FieldName<>nil then result := (PInteger(FieldName)^ and $ffdfdf=ord('I')+ord('D')shl 8) or ((PIntegerArray(FieldName)^[0] and $dfdfdfdf= ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24) and (PIntegerArray(FieldName)^[1] and $ffdf=ord('D'))) {$endif} else result := false; end; function IsRowID(FieldName: PUTF8Char; FieldLen: integer): boolean; begin case FieldLen of 2: result := PWord(FieldName)^ and $dfdf=ord('I')+ord('D')shl 8; 5: result := (PInteger(FieldName)^ and $dfdfdfdf= ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24) and (ord(FieldName[4]) and $df=ord('D')); else result := false; end; end; function IsRowIDShort(const FieldName: shortstring): boolean; begin result := (PInteger(@FieldName)^ and $DFDFFF= 2+ord('I')shl 8+ord('D')shl 16) or ((PIntegerArray(@FieldName)^[0] and $dfdfdfff= 5+ord('R')shl 8+ord('O')shl 16+ord('W')shl 24) and (PIntegerArray(@FieldName)^[1] and $dfdf= ord('I')+ord('D')shl 8)); end; function GetNextFieldProp(var P: PUTF8Char; var Prop: RawUTF8): boolean; var B: PUTF8Char; begin while P^ in [#1..' ',';'] do inc(P); B := P; while ord(P^) in IsIdentifier do inc(P); // go to end of field name FastSetString(Prop,B,P-B); while P^ in [#1..' ',';'] do inc(P); result := Prop<>''; end; type TSynLZHead = packed record Magic: cardinal; CompressedSize: integer; HashCompressed: cardinal; UnCompressedSize: integer; HashUncompressed: cardinal; end; PSynLZHead = ^TSynLZHead; TSynLZTrailer = packed record HeaderRelativeOffset: cardinal; Magic: cardinal; end; PSynLZTrailer = ^TSynLZTrailer; function StreamSynLZComputeLen(P: PAnsiChar; Len, aMagic: cardinal): integer; begin if (P=nil) or (Len<=SizeOf(TSynLZTrailer)) then result := 0 else with PSynLZTrailer(P+Len-SizeOf(TSynLZTrailer))^ do if (Magic=aMagic) and (HeaderRelativeOffset0 then // '' is compressed and uncompressed to '' if Compress then begin len := SynLZcompressdestlen(DataLen)+8; SetString(result,nil,len); P := pointer(result); PCardinal(P)^ := Hash32(pointer(Data),DataLen); len := SynLZcompress1(pointer(Data),DataLen,P+8); PCardinal(P+4)^ := Hash32(pointer(P+8),len); SetString(Data,P,len+8); end else begin result := ''; P := pointer(Data); if (DataLen<=8) or (Hash32(pointer(P+8),DataLen-8)<>PCardinal(P+4)^) then exit; len := SynLZdecompressdestlen(P+8); SetLength(result,len); if (len<>0) and ((SynLZDecompress1(P+8,DataLen-8,pointer(result))<>len) or (Hash32(pointer(result),len)<>PCardinal(P)^)) then begin result := ''; exit; end else SetString(Data,PAnsiChar(pointer(result)),len); end; result := 'synlz'; end; function StreamSynLZ(Source: TCustomMemoryStream; Dest: TStream; Magic: cardinal): integer; var DataLen: integer; S,D: pointer; Head: TSynLZHead; Trailer: TSynLZTrailer; tmp: TSynTempBuffer; begin if Dest=nil then begin result := 0; exit; end; if Source<>nil then begin S := Source.Memory; DataLen := Source.Size; end else begin S := nil; DataLen := 0; end; tmp.Init(SynLZcompressdestlen(DataLen)); try Head.Magic := Magic; Head.UnCompressedSize := DataLen; Head.HashUncompressed := Hash32(S,DataLen); result := SynLZcompress1(S,DataLen,tmp.buf); if result>tmp.len then raise ESynException.Create('StreamLZ: SynLZ compression overflow'); if result>DataLen then begin result := DataLen; // compression not worth it D := S; end else D := tmp.buf; Head.CompressedSize := result; Head.HashCompressed := Hash32(D,result); Dest.WriteBuffer(Head,SizeOf(Head)); Dest.WriteBuffer(D^,Head.CompressedSize); Trailer.HeaderRelativeOffset := result+(SizeOf(Head)+SizeOf(Trailer)); Trailer.Magic := Magic; Dest.WriteBuffer(Trailer,SizeOf(Trailer)); result := Head.CompressedSize+(SizeOf(Head)+SizeOf(Trailer)); finally tmp.Done; end; end; function StreamSynLZ(Source: TCustomMemoryStream; const DestFile: TFileName; Magic: cardinal): integer; var F: TFileStream; begin F := TFileStream.Create(DestFile,fmCreate); try result := StreamSynLZ(Source,F,Magic); finally F.Free; end; end; const /// 128 MB default buffer FILESYNLZ_BLOCKSIZE = 128*1024*1024; function FileSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; var src,dst: RawByteString; S,D: TFileStream; Head: TSynLZHead; Count: Int64; begin result := false; if FileExists(Source) then try S := FileStreamSequentialRead(Source); try DeleteFile(Dest); D := TFileStream.Create(Dest,fmCreate); try Head.Magic := Magic; Count := S.Size; while Count>0 do begin if Count>FILESYNLZ_BLOCKSIZE then Head.UnCompressedSize := FILESYNLZ_BLOCKSIZE else Head.UnCompressedSize := Count; if src='' then SetString(src,nil,Head.UnCompressedSize); if dst='' then SetString(dst,nil,SynLZcompressdestlen(Head.UnCompressedSize)); S.Read(pointer(src)^,Head.UnCompressedSize); Head.HashUncompressed := Hash32(pointer(src),Head.UnCompressedSize); Head.CompressedSize := SynLZcompress1(pointer(src),Head.UnCompressedSize,pointer(dst)); Head.HashCompressed := Hash32(pointer(dst),Head.CompressedSize); if (D.Write(Head,SizeOf(Head))<>SizeOf(Head)) or (D.Write(pointer(dst)^,Head.CompressedSize)<>Head.CompressedSize) then exit; dec(Count,Head.UnCompressedSize); end; finally D.Free; end; result := FileSetDateFrom(Dest,S.Handle); finally S.Free; end; except on Exception do result := false; end; end; function FileUnSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; var src,dst: RawByteString; S,D: TFileStream; Count: Int64; Head: TSynLZHead; begin result := false; if FileExists(Source) then try S := FileStreamSequentialRead(Source); try DeleteFile(Dest); D := TFileStream.Create(Dest,fmCreate); try Count := S.Size; while Count>0 do begin if S.Read(Head,SizeOf(Head))<>SizeOf(Head) then exit; dec(Count,SizeOf(Head)); if (Head.Magic<>Magic) or (Head.CompressedSize>Count) then exit; if Head.CompressedSize>length(src) then SetString(src,nil,Head.CompressedSize); if S.Read(pointer(src)^,Head.CompressedSize)<>Head.CompressedSize then exit; dec(Count,Head.CompressedSize); if (Hash32(pointer(src),Head.CompressedSize)<>Head.HashCompressed) or (SynLZdecompressdestlen(pointer(src))<>Head.UnCompressedSize) then exit; if Head.UnCompressedSize>length(dst) then SetString(dst,nil,Head.UnCompressedSize); if (SynLZDecompress1(pointer(src),Head.CompressedSize,pointer(dst))<>Head.UnCompressedSize) or (Hash32(pointer(dst),Head.UnCompressedSize)<>Head.HashUncompressed) then exit; if D.Write(pointer(dst)^,Head.UncompressedSize)<>Head.UncompressedSize then exit; end; finally D.Free; end; result := FileSetDateFrom(Dest,S.Handle); finally S.Free; end; except on Exception do result := false; end; end; function FileIsSynLZ(const Name: TFileName; Magic: Cardinal): boolean; var S: TFileStream; Head: TSynLZHead; begin result := false; if FileExists(Name) then try S := TFileStream.Create(Name,fmOpenRead or fmShareDenyNone); try if S.Read(Head,SizeOf(Head))=SizeOf(Head) then if Head.Magic=Magic then result := true; // only check magic, since there may be several chunks finally S.Free; end; except on Exception do result := false; end; end; function StreamUnSynLZ(const Source: TFileName; Magic: cardinal): TMemoryStream; var S: TStream; begin try S := TSynMemoryStreamMapped.Create(Source); try result := StreamUnSynLZ(S,Magic); finally S.Free; end; except on E: Exception do result := nil; end; end; function StreamUnSynLZ(Source: TStream; Magic: cardinal): TMemoryStream; var S,D: PAnsiChar; sourcePosition,resultSize,sourceSize: Int64; Head: TSynLZHead; Trailer: TSynLZTrailer; buf: RawByteString; stored: boolean; begin result := nil; if Source=nil then exit; sourceSize := Source.Size; {$ifndef CPU64} if sourceSize>maxInt then exit; // result TMemoryStream should stay in memory! {$endif} sourcePosition := Source.Position; if sourceSize-sourcePositionSizeOf(Head)) or (Head.Magic<>Magic) then begin // Source not positioned as expected -> try from the end Source.Position := sourceSize-SizeOf(Trailer); if (Source.Read(Trailer,SizeOf(Trailer))<>SizeOf(Trailer)) or (Trailer.Magic<>Magic) then exit; sourcePosition := sourceSize-Trailer.HeaderRelativeOffset; Source.Position := sourcePosition; if (Source.Read(Head,SizeOf(Head))<>SizeOf(Head)) or (Head.Magic<>Magic) then exit; end; inc(sourcePosition,SizeOf(Head)); if sourcePosition+Head.CompressedSize>sourceSize then exit; if Source.InheritsFrom(TCustomMemoryStream) then begin S := PAnsiChar(TCustomMemoryStream(Source).Memory)+PtrUInt(sourcePosition); Source.Seek(Head.CompressedSize,soFromCurrent); end else begin if Head.CompressedSize>length(Buf) then SetString(Buf,nil,Head.CompressedSize); S := pointer(Buf); Source.Read(S^,Head.CompressedSize); end; inc(sourcePosition,Head.CompressedSize); if (Source.Read(Trailer,SizeOf(Trailer))<>SizeOf(Trailer)) or (Trailer.Magic<>Magic) then // trailer not available in old .synlz layout, or in FileSynLZ multiblocks Source.Position := sourcePosition else sourceSize := 0; // should be monoblock // Source stream will now point after all data stored := (Head.CompressedSize=Head.UnCompressedSize) and (Head.HashCompressed=Head.HashUncompressed); if not stored then if SynLZdecompressdestlen(S)<>Head.UnCompressedSize then exit; if Hash32(pointer(S),Head.CompressedSize)<>Head.HashCompressed then exit; if result=nil then result := THeapMemoryStream.Create else begin {$ifndef CPU64} if resultSize+Head.UnCompressedSize>maxInt then begin FreeAndNil(result); // result TMemoryStream should stay in memory! break; end; {$endif CPU64} end; result.Size := resultSize+Head.UnCompressedSize; D := PAnsiChar(result.Memory)+resultSize; inc(resultSize,Head.UnCompressedSize); if stored then {$ifdef FPC}Move{$else}MoveFast{$endif}(S^,D^,Head.CompressedSize) else if SynLZDecompress1(S,Head.CompressedSize,D)<>Head.UnCompressedSize then FreeAndNil(result) else if Hash32(pointer(D),Head.UnCompressedSize)<>Head.HashUncompressed then FreeAndNil(result); until (result=nil) or (sourcePosition>=sourceSize); end; { TAlgoCompress } const COMPRESS_STORED = #0; COMPRESS_SYNLZ = 1; var SynCompressAlgos: TObjectList; constructor TAlgoCompress.Create; var existing: TAlgoCompress; begin inherited Create; if SynCompressAlgos=nil then GarbageCollectorFreeAndNil(SynCompressAlgos,TObjectList.Create(true)) else begin existing := Algo(AlgoID); if existing<>nil then raise ESynException.CreateUTF8('%.Create: AlgoID=% already registered by %', [self,AlgoID,existing.ClassType]); end; SynCompressAlgos.Add(self); end; class function TAlgoCompress.Algo(const Comp: RawByteString): TAlgoCompress; begin result := Algo(Pointer(Comp),Length(Comp)); end; class function TAlgoCompress.Algo(const Comp: TByteDynArray): TAlgoCompress; begin result := Algo(Pointer(Comp),Length(Comp)); end; class function TAlgoCompress.Algo(Comp: PAnsiChar; CompLen: integer): TAlgoCompress; begin if (Comp<>nil) and (CompLen>9) then if ord(Comp[4])<=1 then // inline-friendly Comp[4]<=COMPRESS_SYNLZ result := AlgoSynLZ else // COMPRESS_STORED is also handled as SynLZ result := Algo(ord(Comp[4])) else result := nil; end; class function TAlgoCompress.Algo(Comp: PAnsiChar; CompLen: integer; out IsStored: boolean): TAlgoCompress; begin if (Comp<>nil) and (CompLen>9) then begin IsStored := Comp[4]=COMPRESS_STORED; result := Algo(ord(Comp[4])); end else begin IsStored := false; result := nil; end; end; class function TAlgoCompress.Algo(AlgoID: byte): TAlgoCompress; var i: integer; ptr: ^TAlgoCompress; begin if AlgoID<=COMPRESS_SYNLZ then // COMPRESS_STORED is handled as SynLZ result := AlgoSynLZ else begin if SynCompressAlgos<>nil then begin ptr := @SynCompressAlgos.List[1]; // ignore List[0] = AlgoSynLZ for i := 2 to SynCompressAlgos.Count do if ptr^.AlgoID=AlgoID then begin result := ptr^; exit; end else inc(ptr); end; result := nil; end; end; class function TAlgoCompress.UncompressedSize(const Comp: RawByteString): integer; begin result := Algo(Comp).DecompressHeader(pointer(Comp),length(Comp)); end; function TAlgoCompress.AlgoName: TShort16; var s: PShortString; i: integer; begin if self=nil then result := 'none' else begin s := ClassNameShort(self); if IdemPChar(@s^[1],'TALGO') then begin result[0] := AnsiChar(ord(s^[0])-5); inc(PtrUInt(s),5); end else result[0] := s^[0]; if result[0]>#16 then result[0] := #16; for i := 1 to ord(result[0]) do result[i] := NormToLower[s^[i]]; end; end; function TAlgoCompress.AlgoHash(Previous: cardinal; Data: pointer; DataLen: integer): cardinal; begin result := crc32c(Previous,Data,DataLen); end; function TAlgoCompress.Compress(const Plain: RawByteString; CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean; BufferOffset: integer): RawByteString; begin result := Compress(pointer(Plain),Length(Plain),CompressionSizeTrigger, CheckMagicForCompressed,BufferOffset); end; function TAlgoCompress.Compress(Plain: PAnsiChar; PlainLen: integer; CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean; BufferOffset: integer): RawByteString; var len: integer; R: PAnsiChar; crc: cardinal; tmp: array[0..16383] of AnsiChar; // big enough to resize Result in-place begin if (self=nil) or (PlainLen=0) or (Plain=nil) then begin result := ''; exit; end; crc := AlgoHash(0,Plain,PlainLen); if (PlainLenSizeOf(tmp) then begin SetString(result,nil,len); R := pointer(result); end else R := @tmp; inc(R,BufferOffset); PCardinal(R)^ := crc; len := AlgoCompress(Plain,PlainLen,R+9); if len+64>=PlainLen then begin // store if compression was not worth it R[4] := COMPRESS_STORED; PCardinal(R+5)^ := crc; {$ifdef FPC}Move{$else}MoveFast{$endif}(Plain^,R[9],PlainLen); len := PlainLen; end else begin R[4] := AnsiChar(AlgoID); PCardinal(R+5)^ := AlgoHash(0,R+9,len); end; if R=@tmp[BufferOffset] then SetString(result,tmp,len+BufferOffset+9) else SetLength(result,len+BufferOffset+9); // MM may not move the data end; end; function TAlgoCompress.Compress(Plain, Comp: PAnsiChar; PlainLen, CompLen: integer; CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): integer; var len: integer; begin result := 0; if (self=nil) or (PlainLen=0) or (CompLen=CompressionSizeTrigger) and not(CheckMagicForCompressed and IsContentCompressed(Plain,PlainLen)) then begin len := CompressDestLen(PlainLen); if CompLen=PlainLen then begin // store if compression not worth it R[4] := COMPRESS_STORED; PCardinal(R+5)^ := crc; {$ifdef FPC}Move{$else}MoveFast{$endif}(Plain^,R[9],PlainLen); len := PlainLen; end else begin R[4] := AnsiChar(AlgoID); PCardinal(R+5)^ := AlgoHash(0,R+9,len); end; SetLength(result,len+9); end; end; function TAlgoCompress.CompressToBytes(const Plain: RawByteString; CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): TByteDynArray; begin result := CompressToBytes(pointer(Plain),Length(Plain), CompressionSizeTrigger,CheckMagicForCompressed); end; function TAlgoCompress.Decompress(const Comp: TByteDynArray): RawByteString; begin Decompress(pointer(Comp),length(Comp),result); end; procedure TAlgoCompress.Decompress(Comp: PAnsiChar; CompLen: integer; out Result: RawByteString; Load: TAlgoCompressLoad; BufferOffset: integer); var len: integer; dec: PAnsiChar; begin len := DecompressHeader(Comp,CompLen,Load); if len=0 then exit; SetString(result,nil,len+BufferOffset); dec := pointer(result); if not DecompressBody(Comp,dec+BufferOffset,CompLen,len,Load) then result := ''; end; function TAlgoCompress.Decompress(const Comp: RawByteString; Load: TAlgoCompressLoad; BufferOffset: integer): RawByteString; begin Decompress(pointer(Comp),length(Comp),result,Load,BufferOffset); end; function TAlgoCompress.TryDecompress(const Comp: RawByteString; out Dest: RawByteString; Load: TAlgoCompressLoad): boolean; var len: integer; begin result := Comp=''; if result then exit; len := DecompressHeader(pointer(Comp),length(Comp),Load); if len=0 then exit; // invalid crc32c SetString(Dest,nil,len); if DecompressBody(pointer(Comp),pointer(Dest),length(Comp),len,Load) then result := true else Dest := ''; end; function TAlgoCompress.Decompress(const Comp: RawByteString; out PlainLen: integer; var tmp: RawByteString; Load: TAlgoCompressLoad): pointer; begin result := Decompress(pointer(Comp),length(Comp),PlainLen,tmp,Load); end; function TAlgoCompress.Decompress(Comp: PAnsiChar; CompLen: integer; out PlainLen: integer; var tmp: RawByteString; Load: TAlgoCompressLoad): pointer; begin result := nil; PlainLen := DecompressHeader(Comp,CompLen,Load); if PlainLen=0 then exit; if Comp[4]=COMPRESS_STORED then result := Comp+9 else begin if PlainLen > length(tmp) then SetString(tmp,nil,PlainLen); if DecompressBody(Comp,pointer(tmp),CompLen,PlainLen,Load) then result := pointer(tmp); end; end; function TAlgoCompress.DecompressPartial(Comp, Partial: PAnsiChar; CompLen, PartialLen, PartialLenMax: integer): integer; var BodyLen: integer; begin result := 0; if (self=nil) or (CompLen<=9) or (Comp=nil) or (PartialLenMaxBodyLen then PartialLen := BodyLen; if Comp[4]=COMPRESS_STORED then {$ifdef FPC}Move{$else}MoveFast{$endif}(Comp[9],Partial[0],PartialLen) else if AlgoDecompressPartial(Comp+9,CompLen-9,Partial,PartialLen,PartialLenMax)aclNoCrcFast) and (AlgoHash(0,Comp+9,CompLen-9)<>PCardinal(Comp+5)^)) then exit; if Comp[4]=COMPRESS_STORED then begin if PCardinal(Comp)^=PCardinal(Comp+5)^ then result := CompLen-9; end else if Comp[4]=AnsiChar(AlgoID) then result := AlgoDecompressDestLen(Comp+9); end; function TAlgoCompress.DecompressBody(Comp, Plain: PAnsiChar; CompLen, PlainLen: integer; Load: TAlgoCompressLoad): boolean; begin result := false; if (self=nil) or (PlainLen<=0) then exit; if Comp[4]=COMPRESS_STORED then {$ifdef FPC}Move{$else}MoveFast{$endif}(Comp[9],Plain[0],PlainLen) else if Comp[4]=AnsiChar(AlgoID) then case Load of aclNormal: if (AlgoDecompress(Comp+9,CompLen-9,Plain)<>PlainLen) or (AlgoHash(0,Plain,PlainLen)<>PCardinal(Comp)^) then exit; aclSafeSlow: if (AlgoDecompressPartial(Comp+9,CompLen-9,Plain,PlainLen,PlainLen)<>PlainLen) or (AlgoHash(0,Plain,PlainLen)<>PCardinal(Comp)^) then exit; aclNoCrcFast: if (AlgoDecompress(Comp+9,CompLen-9,Plain)<>PlainLen) then exit; end; result := true; end; { TAlgoSynLZ } function TAlgoSynLZ.AlgoID: byte; begin result := COMPRESS_SYNLZ; // =1 end; function TAlgoSynLZ.AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; begin result := SynLZcompress1(Plain,PlainLen,Comp); end; function TAlgoSynLZ.AlgoCompressDestLen(PlainLen: integer): integer; begin result := SynLZcompressdestlen(PlainLen); end; function TAlgoSynLZ.AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; begin result := SynLZdecompress1(Comp,CompLen,Plain); end; function TAlgoSynLZ.AlgoDecompressDestLen(Comp: pointer): integer; begin result := SynLZdecompressdestlen(Comp); end; function TAlgoSynLZ.AlgoDecompressPartial(Comp: pointer; CompLen: integer; Partial: pointer; PartialLen, PartialLenMax: integer): integer; begin result := SynLZdecompress1partial(Comp,CompLen,Partial,PartialLen); end; // deprecated wrapper methods - use SynLZ global variable instead function SynLZCompress(const Data: RawByteString; CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): RawByteString; begin result := AlgoSynLZ.Compress(pointer(Data),length(Data),CompressionSizeTrigger, CheckMagicForCompressed); end; procedure SynLZCompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean); begin result := AlgoSynLZ.Compress(P,PLen,CompressionSizeTrigger,CheckMagicForCompressed); end; function SynLZCompress(P, Dest: PAnsiChar; PLen, DestLen: integer; CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): integer; begin result := AlgoSynLZ.Compress(P,Dest,PLen,DestLen,CompressionSizeTrigger,CheckMagicForCompressed); end; function SynLZDecompress(const Data: RawByteString): RawByteString; begin AlgoSynLZ.Decompress(pointer(Data),Length(Data),result); end; function SynLZDecompressHeader(P: PAnsiChar; PLen: integer): integer; begin result := AlgoSynLZ.DecompressHeader(P,PLen); end; function SynLZDecompressBody(P,Body: PAnsiChar; PLen,BodyLen: integer; SafeDecompression: boolean): boolean; begin result := AlgoSynLZ.DecompressBody(P,Body,PLen,BodyLen,ALGO_SAFE[SafeDecompression]); end; function SynLZDecompressPartial(P,Partial: PAnsiChar; PLen,PartialLen: integer): integer; begin result := AlgoSynLZ.DecompressPartial(P,Partial,PLen,PartialLen,PartialLen); end; procedure SynLZDecompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; SafeDecompression: boolean); begin AlgoSynLZ.Decompress(P,PLen,Result); end; function SynLZDecompress(const Data: RawByteString; out Len: integer; var tmp: RawByteString): pointer; begin result := AlgoSynLZ.Decompress(pointer(Data),length(Data),Len,tmp); end; function SynLZDecompress(P: PAnsiChar; PLen: integer; out Len: integer; var tmp: RawByteString): pointer; begin result := AlgoSynLZ.Decompress(P,PLen,Len,tmp); end; function SynLZCompressToBytes(const Data: RawByteString; CompressionSizeTrigger: integer): TByteDynArray; begin result := AlgoSynLZ.CompressToBytes(pointer(Data),length(Data),CompressionSizeTrigger); end; function SynLZCompressToBytes(P: PAnsiChar; PLen,CompressionSizeTrigger: integer): TByteDynArray; begin result := AlgoSynLZ.CompressToBytes(P,PLen,CompressionSizeTrigger); end; function SynLZDecompress(const Data: TByteDynArray): RawByteString; begin AlgoSynLZ.Decompress(pointer(Data),length(Data),result); end; { TAlgoCompressWithNoDestLen } function TAlgoCompressWithNoDestLen.AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; begin Comp := ToVarUInt32(PlainLen,Comp); // deflate don't store PlainLen result := RawProcess(Plain,Comp,PlainLen,AlgoCompressDestLen(PlainLen),0,doCompress); if result>0 then inc(result,ToVarUInt32Length(PlainLen)); end; function TAlgoCompressWithNoDestLen.AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; var start: PAnsiChar; begin start := Comp; result := FromVarUInt32(PByte(Comp)); if RawProcess(Comp,Plain,CompLen+(Start-Comp),result,0,doUnCompress)<>result then result := 0; end; function TAlgoCompressWithNoDestLen.AlgoDecompressDestLen(Comp: pointer): integer; begin if Comp=nil then result := 0 else result := FromVarUInt32(PByte(Comp)); end; function TAlgoCompressWithNoDestLen.AlgoDecompressPartial(Comp: pointer; CompLen: integer; Partial: pointer; PartialLen, PartialLenMax: integer): integer; var start: PAnsiChar; begin start := Comp; result := FromVarUInt32(PByte(Comp)); if PartialLenMax>result then PartialLenMax := result; result := RawProcess(Comp,Partial,CompLen+(Start-Comp),PartialLen,PartialLenMax,doUncompressPartial); end; { ESynException } constructor ESynException.CreateUTF8(const Format: RawUTF8; const Args: array of const); var msg: string; begin FormatString(Format,Args,msg); inherited Create(msg); end; constructor ESynException.CreateLastOSError(const Format: RawUTF8; const Args: array of const); var tmp: RawUTF8; error: integer; begin error := GetLastError; FormatUTF8(Format,Args,tmp); CreateUTF8('OSError % [%] %',[error,SysErrorMessage(error),tmp]); end; {$ifndef NOEXCEPTIONINTERCEPT} function ESynException.CustomLog(WR: TTextWriter; const Context: TSynLogExceptionContext): boolean; begin if Assigned(TSynLogExceptionToStrCustom) then result := TSynLogExceptionToStrCustom(WR,Context) else if Assigned(DefaultSynLogExceptionToStr) then result := DefaultSynLogExceptionToStr(WR,Context) else result := false; end; {$endif} { TMemoryMapText } constructor TMemoryMapText.Create; begin end; constructor TMemoryMapText.Create(aFileContent: PUTF8Char; aFileSize: integer); begin Create; fMap.Map(aFileContent,aFileSize); LoadFromMap; end; constructor TMemoryMapText.Create(const aFileName: TFileName); begin Create; fFileName := aFileName; if fMap.Map(aFileName) then LoadFromMap; end; // invalid file or unable to memory map its content -> Count := 0 destructor TMemoryMapText.Destroy; begin Freemem(fLines); fMap.UnMap; inherited; end; procedure TMemoryMapText.SaveToStream(Dest: TStream; const Header: RawUTF8); var i: integer; W: TTextWriter; temp: TTextWriterStackBuffer; begin i := length(Header); if i>0 then Dest.WriteBuffer(pointer(Header)^,i); if fMap.Size>0 then Dest.WriteBuffer(fMap.Buffer^,fMap.Size); if fAppendedLinesCount=0 then exit; W := TTextWriter.Create(Dest,@temp,SizeOf(temp)); try if (fMap.Size>0) and (fMap.Buffer[fMap.Size-1]>=' ') then W.Add(#10); for i := 0 to fAppendedLinesCount-1 do begin W.AddString(fAppendedLines[i]); W.Add(#10); end; W.FlushFinal; finally W.Free; end; end; procedure TMemoryMapText.SaveToFile(FileName: TFileName; const Header: RawUTF8); var FS: TFileStream; begin FS := TFileStream.Create(FileName,fmCreate); try SaveToStream(FS,Header); finally FS.Free; end; end; function TMemoryMapText.GetLine(aIndex: integer): RawUTF8; begin if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) then result := '' else FastSetString(result,fLines[aIndex],GetLineSize(fLines[aIndex],fMapEnd)); end; function TMemoryMapText.GetString(aIndex: integer): string; begin if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) then result := '' else UTF8DecodeToString(fLines[aIndex],GetLineSize(fLines[aIndex],fMapEnd),result); end; function GetLineContains(p,pEnd, up: PUTF8Char): boolean; var i: PtrInt; label Fnd; begin if (p<>nil) and (up<>nil) then if pEnd=nil then repeat i := ord(p^); if not (AnsiChar(i) in ANSICHARNOT01310) then break; inc(p); if (NormToUpperAnsi7Byte[i]=ord(up^)) and IdemPChar(p,@up[1]) then begin result := true; exit; end; until false else repeat // fast unrolled search if p>=pEnd then break; i := ord(p^); if i in [10,13] then break; if NormToUpperAnsi7Byte[i]=ord(up^) then goto Fnd; inc(p); if p>=pEnd then break; i := ord(p^); if i in [10,13] then break; if NormToUpperAnsi7Byte[i]=ord(up^) then goto Fnd; inc(p); if p>=pEnd then break; i := ord(p^); if i in [10,13] then break; if NormToUpperAnsi7Byte[i]=ord(up^) then goto Fnd; inc(p); if p>=pEnd then break; i := ord(p^); if i in [10,13] then break; if NormToUpperAnsi7Byte[i]<>ord(up^) then begin inc(p); continue; end; Fnd:i := 0; repeat inc(i); if up[i]=#0 then begin result := true; // found exit; end; until NormToUpperAnsi7[p[i]]<>up[i]; inc(p); until false; result := false; end; function TMemoryMapText.LineContains(const aUpperSearch: RawUTF8; aIndex: Integer): Boolean; begin if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) or (aUpperSearch='') then result := false else result := GetLineContains(fLines[aIndex],fMapEnd,pointer(aUpperSearch)); end; function TMemoryMapText.LineSize(aIndex: integer): integer; begin result := GetLineSize(fLines[aIndex],fMapEnd); end; function GetLineSizeSmallerThan(P,PEnd: PUTF8Char; aMinimalCount: integer): boolean; begin if P<>nil then while (P#13) and (P^<>#10) do inc(P); ProcessOneLine(PBeg,P); if P+1>=PEnd then break; if P[0]=#13 then if P[1]=#10 then inc(P,2) else // ignore #13#10 inc(P) else // ignore #13 inc(P); // ignore #10 end; end; var P: PUTF8Char; begin fLinesMax := fMap.fFileSize div AverageLineLength+8; GetMem(fLines,fLinesMax*SizeOf(pointer)); P := pointer(fMap.Buffer); fMapEnd := P+fMap.Size; if TextFileKind(Map)=isUTF8 then inc(PByte(P),3); // ignore UTF-8 BOM ParseLines(P,fMapEnd); if fLinesMax>fCount+16384 then Reallocmem(fLines,fCount*SizeOf(pointer)); // size down only if worth it end; procedure TMemoryMapText.AddInMemoryLine(const aNewLine: RawUTF8); var P: PUTF8Char; begin if aNewLine='' then exit; AddRawUTF8(fAppendedLines,fAppendedLinesCount,aNewLine); P := pointer(fAppendedLines[fAppendedLinesCount-1]); ProcessOneLine(P,P+StrLen(P)); end; procedure TMemoryMapText.AddInMemoryLinesClear; begin dec(fCount,fAppendedLinesCount); fAppendedLinesCount := 0; fAppendedLines := nil; end; { TRawByteStringStream } constructor TRawByteStringStream.Create(const aString: RawByteString); begin fDataString := aString; end; function TRawByteStringStream.Read(var Buffer; Count: Integer): Longint; begin if Count<=0 then Result := 0 else begin Result := Length(fDataString)-fPosition; if Result>Count then Result := Count; {$ifdef FPC}Move{$else}MoveFast{$endif}(PByteArray(fDataString)[fPosition],Buffer,Result); inc(fPosition, Result); end; end; function TRawByteStringStream.Seek(Offset: Integer; Origin: Word): Longint; begin case Origin of soFromBeginning: fPosition := Offset; soFromCurrent: fPosition := fPosition+Offset; soFromEnd: fPosition := Length(fDataString)-Offset; end; if fPosition>Length(fDataString) then fPosition := Length(fDataString) else if fPosition<0 then fPosition := 0; result := fPosition; end; procedure TRawByteStringStream.SetSize(NewSize: Integer); begin SetLength(fDataString, NewSize); if fPosition>NewSize then fPosition := NewSize; end; function TRawByteStringStream.Write(const Buffer; Count: Integer): Longint; begin if Count<=0 then Result := 0 else begin Result := Count; SetLength(fDataString,fPosition+Result); {$ifdef FPC}Move{$else}MoveFast{$endif}(Buffer,PByteArray(fDataString)[fPosition],Result); inc(FPosition,Result); end; end; { TFakeWriterStream } function TFakeWriterStream.Read(var Buffer; Count: Longint): Longint; begin // do nothing result := Count; end; function TFakeWriterStream.Write(const Buffer; Count: Longint): Longint; begin // do nothing result := Count; end; function TFakeWriterStream.Seek(Offset: Longint; Origin: Word): Longint; begin result := Offset; end; { TSynNameValue } procedure TSynNameValue.Add(const aName, aValue: RawUTF8; aTag: PtrInt); var added: boolean; i: Integer; begin i := fDynArray.FindHashedForAdding(aName,added); with List[i] do begin if added then Name := aName; Value := aValue; Tag := aTag; end; if Assigned(fOnAdd) then fOnAdd(List[i],i); end; procedure TSynNameValue.InitFromIniSection(Section: PUTF8Char; OnTheFlyConvert: TConvertRawUTF8; OnAdd: TSynNameValueNotify); var s: RawUTF8; i: integer; begin Init(false); fOnAdd := OnAdd; while (Section<>nil) and (Section^<>'[') do begin s := GetNextLine(Section,Section); i := PosExChar('=',s); if (i>1) and not(s[1] in [';','[']) then if Assigned(OnTheFlyConvert) then Add(copy(s,1,i-1),OnTheFlyConvert(copy(s,i+1,1000))) else Add(copy(s,1,i-1),copy(s,i+1,1000)); end; end; procedure TSynNameValue.InitFromCSV(CSV: PUTF8Char; NameValueSep,ItemSep: AnsiChar); var n,v: RawUTF8; begin Init(false); while CSV<>nil do begin GetNextItem(CSV,NameValueSep,n); if ItemSep=#10 then GetNextItemTrimedCRLF(CSV,v) else GetNextItem(CSV,ItemSep,v); if n='' then break; Add(n,v); end; end; procedure TSynNameValue.InitFromNamesValues(const Names, Values: array of RawUTF8); var i: integer; begin Init(false); if high(Names)<>high(Values) then exit; fDynArray.SetCapacity(length(Names)); for i := 0 to high(Names) do Add(Names[i],Values[i]); end; function TSynNameValue.InitFromJSON(JSON: PUTF8Char; aCaseSensitive: boolean): boolean; var N,V: PUTF8Char; nam,val: RawUTF8; Nlen, Vlen, c: integer; EndOfObject: AnsiChar; begin result := false; Init(aCaseSensitive); if JSON=nil then exit; if JSON^ in [#1..' '] then repeat inc(JSON) until not(JSON^ in [#1..' ']); if JSON^<>'{' then exit; repeat inc(JSON) until not(JSON^ in [#1..' ']); c := JSONObjectPropCount(JSON); if c<=0 then exit; fDynArray.SetCapacity(c); repeat N := GetJSONPropName(JSON,@Nlen); if N=nil then exit; V := GetJSONFieldOrObjectOrArray(JSON,nil,@EndOfObject,true,true,@Vlen); if V=nil then exit; FastSetString(nam,N,Nlen); FastSetString(val,V,Vlen); Add(nam,val); until EndOfObject='}'; result := true; end; procedure TSynNameValue.Init(aCaseSensitive: boolean); begin // release dynamic arrays memory before FillcharFast() List := nil; fDynArray.HashInvalidate; // initialize hashed storage {$ifdef FPC}FillChar{$else}FillCharFast{$endif}(self,SizeOf(self),0); fDynArray.InitSpecific(TypeInfo(TSynNameValueItemDynArray),List, djRawUTF8,@Count,not aCaseSensitive); end; function TSynNameValue.Find(const aName: RawUTF8): integer; begin result := fDynArray.FindHashed(aName); end; function TSynNameValue.FindStart(const aUpperName: RawUTF8): integer; begin for result := 0 to Count-1 do if IdemPChar(pointer(List[result].Name),pointer(aUpperName)) then exit; result := -1; end; function TSynNameValue.FindByValue(const aValue: RawUTF8): integer; begin for result := 0 to Count-1 do if List[result].Value=aValue then exit; result := -1; end; function TSynNameValue.Delete(const aName: RawUTF8): boolean; var ndx: integer; begin ndx := fDynArray.FindHashed(aName); if ndx>=0 then begin fDynArray.Delete(ndx); fDynArray.ReHash; result := true; end else result := false; end; function TSynNameValue.DeleteByValue(const aValue: RawUTF8; Limit: integer): integer; var ndx: integer; begin result := 0; if Limit<1 then exit; for ndx := Count-1 downto 0 do if List[ndx].Value=aValue then begin fDynArray.Delete(ndx); inc(result); if result>=Limit then break; end; if result>0 then fDynArray.ReHash; end; function TSynNameValue.Value(const aName: RawUTF8; const aDefaultValue: RawUTF8): RawUTF8; var i: integer; begin if @self=nil then i := -1 else i := fDynArray.FindHashed(aName); if i<0 then result := aDefaultValue else result := List[i].Value; end; function TSynNameValue.ValueInt(const aName: RawUTF8; const aDefaultValue: Int64): Int64; var i,err: integer; begin i := fDynArray.FindHashed(aName); if i<0 then result := aDefaultValue else begin result := GetInt64(pointer(List[i].Value),err); if err<>0 then result := aDefaultValue; end; end; function TSynNameValue.ValueBool(const aName: RawUTF8): Boolean; begin result := Value(aName)='1'; end; function TSynNameValue.ValueEnum(const aName: RawUTF8; aEnumTypeInfo: pointer; out aEnum; aEnumDefault: byte): boolean; var v: RawUTF8; err,i: integer; begin result := false; byte(aEnum) := aEnumDefault; v := trim(Value(aName,'')); if v='' then exit; i := GetInteger(pointer(v),err); if (err<>0) or (i<0) then i := GetEnumNameValue(aEnumTypeInfo,v,true); if i>=0 then begin byte(aEnum) := i; result := true; end; end; function TSynNameValue.Initialized: boolean; begin result := fDynArray.Value=@List; end; function TSynNameValue.GetBlobData: RawByteString; begin result := fDynArray.SaveTo; end; procedure TSynNameValue.SetBlobDataPtr(aValue: pointer); begin fDynArray.LoadFrom(aValue); fDynArray.ReHash; end; procedure TSynNameValue.SetBlobData(const aValue: RawByteString); begin SetBlobDataPtr(pointer(aValue)); end; function TSynNameValue.GetStr(const aName: RawUTF8): RawUTF8; begin result := Value(aName,''); end; function TSynNameValue.GetInt(const aName: RawUTF8): Int64; begin result := ValueInt(aName,0); end; function TSynNameValue.GetBool(const aName: RawUTF8): Boolean; begin result := Value(aName)='1'; end; function TSynNameValue.AsCSV(const KeySeparator,ValueSeparator,IgnoreKey: RawUTF8): RawUTF8; var i: integer; temp: TTextWriterStackBuffer; begin with TTextWriter.CreateOwnedStream(temp) do try for i := 0 to Count-1 do if (IgnoreKey='') or (List[i].Name<>IgnoreKey) then begin AddNoJSONEscapeUTF8(List[i].Name); AddNoJSONEscapeUTF8(KeySeparator); AddNoJSONEscapeUTF8(List[i].Value); AddNoJSONEscapeUTF8(ValueSeparator); end; SetText(result); finally Free; end; end; function TSynNameValue.AsJSON: RawUTF8; var i: integer; temp: TTextWriterStackBuffer; begin with TTextWriter.CreateOwnedStream(temp) do try Add('{'); for i := 0 to Count-1 do with List[i] do begin AddFieldName(pointer(Name),length(Name)); Add('"'); AddJSONEscape(pointer(Value),length(Value)); Add('"',','); end; CancelLastComma; Add('}'); SetText(result); finally Free; end; end; procedure TSynNameValue.AsNameValues(out Names,Values: TRawUTF8DynArray); var i: integer; begin SetLength(Names,Count); SetLength(Values,Count); for i := 0 to Count-1 do begin Names[i] := List[i].Name; Values[i] := List[i].Value; end; end; {$ifndef NOVARIANTS} function TSynNameValue.ValueVariantOrNull(const aName: RawUTF8): variant; var i: integer; begin i := Find(aName); if i<0 then SetVariantNull(result) else RawUTF8ToVariant(List[i].Value,result); end; procedure TSynNameValue.AsDocVariant(out DocVariant: variant; ExtendedJson,ValueAsString,AllowVarDouble: boolean); var ndx: integer; begin if Count>0 then with TDocVariantData(DocVariant) do begin Init(JSON_OPTIONS_NAMEVALUE[ExtendedJson],dvObject); VCount := self.Count; SetLength(VName,VCount); SetLength(VValue,VCount); for ndx := 0 to VCount-1 do begin VName[ndx] := List[ndx].Name; if ValueAsString or not GetNumericVariantFromJSON(pointer(List[ndx].Value), TVarData(VValue[ndx]),AllowVarDouble) then RawUTF8ToVariant(List[ndx].Value,VValue[ndx]); end; end else TVarData(DocVariant).VType := varNull; end; function TSynNameValue.AsDocVariant(ExtendedJson,ValueAsString: boolean): variant; begin AsDocVariant(result,ExtendedJson,ValueAsString); end; function TSynNameValue.MergeDocVariant(var DocVariant: variant; ValueAsString: boolean; ChangedProps: PVariant; ExtendedJson,AllowVarDouble: Boolean): integer; var DV: TDocVariantData absolute DocVariant; i,ndx: integer; v: variant; intvalues: TRawUTF8Interning; begin if DV.VType<>DocVariantVType then TDocVariant.New(DocVariant,JSON_OPTIONS_NAMEVALUE[ExtendedJson]); if ChangedProps<>nil then TDocVariant.New(ChangedProps^,DV.Options); if dvoInternValues in DV.Options then intvalues := DocVariantType.InternValues else intvalues := nil; result := 0; // returns number of changed values for i := 0 to Count-1 do if List[i].Name<>'' then begin VarClear(v); if ValueAsString or not GetNumericVariantFromJSON(pointer(List[i].Value), TVarData(v),AllowVarDouble) then RawUTF8ToVariant(List[i].Value,v); ndx := DV.GetValueIndex(List[i].Name); if ndx<0 then ndx := DV.InternalAdd(List[i].Name) else if SortDynArrayVariantComp(TVarData(v),TVarData(DV.Values[ndx]),false)=0 then continue; // value not changed -> skip if ChangedProps<>nil then PDocVariantData(ChangedProps)^.AddValue(List[i].Name,v); SetVariantByValue(v,DV.VValue[ndx]); if intvalues<>nil then intvalues.UniqueVariant(DV.VValue[ndx]); inc(result); end; end; {$endif NOVARIANTS} {$ifdef MSWINDOWS} function IsDebuggerPresent: BOOL; stdcall; external kernel32; // since XP {$endif} procedure SetCurrentThreadName(const Format: RawUTF8; const Args: array of const); begin SetThreadName(GetCurrentThreadId,Format,Args); end; procedure SetThreadName(ThreadID: TThreadID; const Format: RawUTF8; const Args: array of const); var name: RawUTF8; begin FormatUTF8(Format,Args,name); SetThreadNameInternal(ThreadID,name); end; procedure SetThreadNameDefault(ThreadID: TThreadID; const Name: RawUTF8); {$ifdef FPC} begin {$ifdef LINUX} if ThreadID<>MainThreadID then // don't change the main process name SetUnixThreadName(ThreadID, Name); // call pthread_setname_np() {$endif} {$else} {$ifndef NOSETTHREADNAME} var s: RawByteString; {$ifndef ISDELPHIXE2} {$ifdef MSWINDOWS} info: record FType: LongWord; // must be 0x1000 FName: PAnsiChar; // pointer to name (in user address space) FThreadID: LongWord; // thread ID (-1 indicates caller thread) FFlags: LongWord; // reserved for future use, must be zero end; {$endif} {$endif} begin {$ifdef MSWINDOWS} if not IsDebuggerPresent then exit; {$endif MSWINDOWS} s := CurrentAnsiConvert.UTF8ToAnsi(Name); {$ifdef ISDELPHIXE2} TThread.NameThreadForDebugging(s,ThreadID); {$else} {$ifdef MSWINDOWS} info.FType := $1000; info.FName := pointer(s); info.FThreadID := ThreadID; info.FFlags := 0; try RaiseException($406D1388,0,SizeOf(info) div SizeOf(LongWord),@info); except {ignore} end; {$endif MSWINDOWS} {$endif ISDELPHIXE2} {$else} begin {$endif NOSETTHREADNAME} {$endif FPC} end; { MultiEvent* functions } function MultiEventFind(const EventList; const Event: TMethod): integer; var Events: TMethodDynArray absolute EventList; begin if Event.Code<>nil then // callback assigned for result := 0 to length(Events)-1 do if (Events[result].Code=Event.Code) and (Events[result].Data=Event.Data) then exit; result := -1; end; function MultiEventAdd(var EventList; const Event: TMethod): boolean; var Events: TMethodDynArray absolute EventList; n: integer; begin result := false; n := MultiEventFind(EventList,Event); if n>=0 then exit; // already registered result := true; n := length(Events); SetLength(Events,n+1); Events[n] := Event; end; procedure MultiEventRemove(var EventList; const Event: TMethod); begin MultiEventRemove(EventList,MultiEventFind(EventList,Event)); end; procedure MultiEventRemove(var EventList; Index: Integer); var Events: TMethodDynArray absolute EventList; max: integer; begin max := length(Events); if cardinal(index)nil then FreeAndNil(PObject(GarbageCollectorFreeAndNilList.List[i])^); except on E: Exception do ; // just ignore exceptions in client code destructors end; FreeAndNil(GarbageCollectorFreeAndNilList); end; procedure GarbageCollectorFreeAndNil(var InstanceVariable; Instance: TObject); begin TObject(InstanceVariable) := Instance; GarbageCollectorFreeAndNilList.Add(@InstanceVariable); end; var GlobalCriticalSection: TRTLCriticalSection; procedure GlobalLock; begin EnterCriticalSection(GlobalCriticalSection); end; procedure GlobalUnLock; begin LeaveCriticalSection(GlobalCriticalSection); end; {$ifdef CPUINTEL} procedure TestIntelCpuFeatures; var regs: TRegisters; begin regs.edx := 0; regs.ecx := 0; GetCPUID(1,regs); PIntegerArray(@CpuFeatures)^[0] := regs.edx; PIntegerArray(@CpuFeatures)^[1] := regs.ecx; GetCPUID(7,regs); PIntegerArray(@CpuFeatures)^[2] := regs.ebx; PIntegerArray(@CpuFeatures)^[3] := regs.ecx; PByte(@PIntegerArray(@CpuFeatures)^[4])^ := regs.edx; {$ifdef DISABLE_SSE42} // may be needed on Darwin x64 (as reported by alf) Exclude(CpuFeatures, cfSSE42); Exclude(CpuFeatures, cfAESNI); {$endif} end; {$endif CPUINTEL} procedure InitSynCommonsConversionTables; var i,n: integer; v: byte; crc: cardinal; tmp: array[0..15] of AnsiChar; P: PAnsiChar; {$ifdef OWNNORMTOUPPER} d: integer; const n2u: array[138..255] of byte = (83,139,140,141,90,143,144,145,146,147,148,149,150,151,152,153,83,155,140, 157,90,89,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175, 176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,65,65,65, 65,65,65,198,67,69,69,69,69,73,73,73,73,68,78,79,79,79,79,79,215,79,85,85, 85,85,89,222,223,65,65,65,65,65,65,198,67,69,69,69,69,73,73,73,73,68,78,79, 79,79,79,79,247,79,85,85,85,85,89,222,89); {$endif OWNNORMTOUPPER} const HexChars: array[0..15] of AnsiChar = '0123456789ABCDEF'; HexCharsLower: array[0..15] of AnsiChar = '0123456789abcdef'; begin JSON_CONTENT_TYPE_VAR := JSON_CONTENT_TYPE; JSON_CONTENT_TYPE_HEADER_VAR := JSON_CONTENT_TYPE_HEADER; NULL_STR_VAR := 'null'; {$ifdef FPC} {$ifdef ISFPC27} {$ifndef MSWINDOWS} GetACP := GetSystemCodePage; {$endif MSWINDOWS} SetMultiByteConversionCodePage(CP_UTF8); SetMultiByteRTLFileSystemCodePage(CP_UTF8); {$endif ISFPC27} {$endif FPC} {$ifdef KYLIX3} // if default locale is set to *.UTF-8, which is the case in most modern // linux default configuration, unicode decode will fail in SysUtils.CheckLocale setlocale(LC_CTYPE,'en_US'); // force locale for a UTF-8 server {$endif} {$ifndef EXTENDEDTOSTRING_USESTR} {$ifdef ISDELPHIXE} SettingsUS := TFormatSettings.Create($0409); {$else} GetLocaleFormatSettings($0409,SettingsUS); {$endif} SettingsUS.DecimalSeparator := '.'; // value may have been overriden :( {$endif} for i := 0 to 255 do NormToNormByte[i] := i; NormToUpperAnsi7Byte := NormToNormByte; for i := ord('a') to ord('z') do dec(NormToUpperAnsi7Byte[i],32); {$ifdef OWNNORMTOUPPER} // initialize custom NormToUpper[] and NormToLower[] arrays MoveFast(NormToUpperAnsi7,NormToUpper,138); MoveFast(n2u,NormToUpperByte[138],SizeOf(n2u)); for i := 0 to 255 do begin d := NormToUpperByte[i]; if d in [ord('A')..ord('Z')] then inc(d,32); NormToLowerByte[i] := d; end; {$endif OWNNORMTOUPPER} // code below is 55 bytes long, therefore shorter than a const array FillcharFast(ConvertHexToBin[0],SizeOf(ConvertHexToBin),255); // all to 255 v := 0; for i := ord('0') to ord('9') do begin ConvertHexToBin[i] := v; inc(v); end; for i := ord('A') to ord('F') do begin ConvertHexToBin[i] := v; ConvertHexToBin[i+(ord('a')-ord('A'))] := v; inc(v); end; for i := 0 to 255 do begin TwoDigitsHex[i][1] := HexChars[i shr 4]; TwoDigitsHex[i][2] := HexChars[i and $f]; end; for i := 0 to 255 do begin TwoDigitsHexLower[i][1] := HexCharsLower[i shr 4]; TwoDigitsHexLower[i][2] := HexCharsLower[i and $f]; end; FillcharFast(ConvertBase64ToBin,256,255); // invalid value set to -1 for i := 0 to high(b64enc) do ConvertBase64ToBin[b64enc[i]] := i; ConvertBase64ToBin['='] := -2; // special value for '=' for i := 0 to high(b64urienc) do ConvertBase64uriToBin[b64urienc[i]] := i; for i := high(Baudot2Char) downto 0 do if Baudot2Char[i]<#128 then Char2Baudot[Baudot2Char[i]] := i; for i := ord('a') to ord('z') do Char2Baudot[AnsiChar(i-32)] := Char2Baudot[AnsiChar(i)]; // A-Z -> a-z for i := 0 to 127 do if i in JSON_ESCAPE then JSON_ESCAPE_BYTE[i] := true; // initialize our internaly used TSynAnsiConvert engines TSynAnsiConvert.Engine(0); // initialize tables for crc32cfast() and SymmetricEncrypt/FillRandom for i := 0 to 255 do begin crc := i; for n := 1 to 8 do if (crc and 1)<>0 then // polynom is not the same as with zlib's crc32() crc := (crc shr 1) xor $82f63b78 else crc := crc shr 1; crc32ctab[0,i] := crc; end; for i := 0 to 255 do begin crc := crc32ctab[0,i]; for n := 1 to high(crc32ctab) do begin crc := (crc shr 8) xor crc32ctab[0,ToByte(crc)]; crc32ctab[n,i] := crc; end; end; for i := 0 to high(SmallUInt32UTF8) do begin P := StrUInt32(@tmp[15],i); FastSetString(SmallUInt32UTF8[i],P,@tmp[15]-P); end; UpperCopy255Buf := @UpperCopy255BufPas; DefaultHasher := @xxHash32; // faster than crc32cfast for small content {$ifndef ABSOLUTEPASCAL} {$ifdef CPUINTEL} {$ifdef FPC} // done in InitRedirectCode for Delphi {$ifdef CPUX86} if cfSSE2 in CpuFeatures then {$endif} StrLen := @StrLenSSE2; {$endif FPC} if cfSSE42 in CpuFeatures then begin crc32c := @crc32csse42; // seems safe on all targets crc32cby4 := @crc32cby4sse42; crcblock := @crcblockSSE42; {$ifdef FORCE_STRSSE42} // disabled by default: may trigger random GPF strspn := @strspnSSE42; strcspn := @strcspnSSE42; {$ifdef CPU64} {$ifdef FPC} // done in InitRedirectCode for Delphi {$ifdef HASAESNI} StrLen := @StrLenSSE42; StrComp := @StrCompSSE42; {$endif HASAESNI} {$endif FPC} {$endif CPU64} {$ifndef PUREPASCAL} {$ifndef DELPHI5OROLDER} UpperCopy255Buf := @UpperCopy255BufSSE42; {$endif DELPHI5OROLDER} {$endif PUREPASCAL} {$ifndef PUREPASCAL} StrComp := @StrCompSSE42; DYNARRAY_SORTFIRSTFIELD[false,djRawUTF8] := @SortDynArrayAnsiStringSSE42; DYNARRAY_SORTFIRSTFIELD[false,djWinAnsi] := @SortDynArrayAnsiStringSSE42; {$ifndef UNICODE} DYNARRAY_SORTFIRSTFIELD[false,djString] := @SortDynArrayAnsiStringSSE42; {$endif} DYNARRAY_SORTFIRSTFIELDHASHONLY[true] := @SortDynArrayAnsiStringSSE42; {$endif PUREPASCAL} {$endif FORCE_STRSSE42} DefaultHasher := crc32c; end; {$endif CPUINTEL} {$endif ABSOLUTEPASCAL} InterningHasher := DefaultHasher; KINDTYPE_INFO[djRawUTF8] := TypeInfo(RawUTF8); // for TDynArray.LoadKnownType KINDTYPE_INFO[djWinAnsi] := TypeInfo(WinAnsiString); KINDTYPE_INFO[djString] := TypeInfo(String); KINDTYPE_INFO[djRawByteString] := TypeInfo(RawByteString); KINDTYPE_INFO[djWideString] := TypeInfo(WideString); KINDTYPE_INFO[djSynUnicode] := TypeInfo(SynUnicode); {$ifndef NOVARIANTS}KINDTYPE_INFO[djVariant] := TypeInfo(variant);{$endif} GarbageCollectorFreeAndNil(GlobalCustomJSONSerializerFromTextSimpleType, TSynDictionary.Create(TypeInfo(TRawUTF8DynArray), TypeInfo(TJSONSerializerFromTextSimpleDynArray),true)); JSONSerializerFromTextSimpleTypeAdd( 'TGUID',{$ifdef ISDELPHI2010}TypeInfo(TGUID){$else}nil{$endif},0,0); end; initialization // initialization of global variables GarbageCollectorFreeAndNilList := TList.Create; GarbageCollectorFreeAndNil(GarbageCollector,TObjectList.Create); InitializeCriticalSection(GlobalCriticalSection); {$ifndef MSWINDOWS} // should be set ASAP (RetrieveSystemInfo is too late) SystemInfo.dwPageSize := getpagesize; // use libc for this value if SystemInfo.dwPageSize = 0 then SystemInfo.dwPageSize := 4096; {$endif MSWINDOWS} {$ifdef CPUINTEL} TestIntelCpuFeatures; {$endif} {$ifdef PUREPASCAL} {$ifndef HASINLINE} PosEx := @PosExPas; {$endif} {$endif} crc32c := @crc32cfast; // now to circumvent Internal Error C11715 for Delphi 5 crc32cBy4 := @crc32cBy4fast; MoveFast := @System.Move; {$ifdef FPC} FillCharFast := @System.FillChar; // FPC cross-platform RTL is optimized enough {$ifdef Linux} stdoutIsTTY := IsATTY(StdOutputHandle)=1; {$endif} {$else} {$ifdef CPUARM} FillCharFast := @System.FillChar; {$else} Pointer(@FillCharFast) := SystemFillCharAddress; {$ifndef USEPACKAGES} InitRedirectCode; {$endif USEPACKAGES} {$endif CPUARM} {$endif FPC} InitSynCommonsConversionTables; RetrieveSystemInfo; SetExecutableVersion(0,0,0,0); AlgoSynLZ := TAlgoSynLZ.Create; TTextWriter.RegisterCustomJSONSerializerFromText([ TypeInfo(TFindFilesDynArray), 'Name:string Attr:Integer Size:Int64 Timestamp:TDateTime']); // some type definition assertions {$ifndef NOVARIANTS} Assert(SizeOf(TDocVariantData)=SizeOf(TVarData)); DocVariantType := TDocVariant(SynRegisterCustomVariantType(TDocVariant)); DocVariantVType := DocVariantType.VarType; {$endif NOVARIANTS} {$ifndef FPC}{$warnings OFF}{$endif} Assert((MAX_SQLFIELDS>=64)and(MAX_SQLFIELDS<=256)); {$ifndef FPC}{$warnings ON}{$endif} Assert(SizeOf(THash128Rec)=SizeOf(THash128)); Assert(SizeOf(THash256Rec)=SizeOf(THash256)); Assert(SizeOf(TBlock128)=SizeOf(THash128)); assert(SizeOf(TSynSystemTime)=SizeOf(TSystemTime)); assert(SizeOf(TSynSystemTime)=SizeOf(THash128)); Assert(SizeOf(TOperatingSystemVersion)=SizeOf(integer)); {$ifdef MSWINDOWS} {$ifndef CPU64} Assert(SizeOf(TFileTime)=SizeOf(Int64)); // see e.g. FileTimeToInt64 {$endif} {$endif} finalization GarbageCollectorFree; DeleteCriticalSection(GlobalCriticalSection); //writeln('TDynArrayHashedCollisionCount=',TDynArrayHashedCollisionCount); readln; end.