From d743333741e1fa7ec93e1139ec0759ddfcd233c1 Mon Sep 17 00:00:00 2001 From: Daniele Teti Date: Mon, 29 Apr 2024 15:40:45 +0200 Subject: [PATCH] Updated dmustache to version 2 --- lib/dmustache/.gitattributes | 22 - lib/dmustache/.gitignore | 88 - lib/dmustache/README.md | 201 - lib/dmustache/SynCommons.pas | 63348 ---------------- lib/dmustache/SynDoubleToText.inc | 950 - lib/dmustache/SynFPCLinux.pas | 1201 - lib/dmustache/SynFPCTypInfo.pas | 200 - lib/dmustache/SynLZ.pas | 1474 - lib/dmustache/SynMustache.pas | 1488 - lib/dmustache/SynTable.pas | 18530 ----- lib/dmustache/Synopse.inc | 736 - lib/dmustache/SynopseCommit.inc | 1 - lib/dmustache/mormot.commit.inc | 1 + lib/dmustache/mormot.core.base.asmx64.inc | 2939 + lib/dmustache/mormot.core.base.asmx86.inc | 2602 + lib/dmustache/mormot.core.base.pas | 12238 +++ lib/dmustache/mormot.core.buffers.pas | 11414 +++ lib/dmustache/mormot.core.data.pas | 11523 +++ lib/dmustache/mormot.core.datetime.pas | 3652 + lib/dmustache/mormot.core.json.pas | 11904 +++ lib/dmustache/mormot.core.mustache.pas | 2563 + lib/dmustache/mormot.core.os.pas | 10857 +++ lib/dmustache/mormot.core.os.posix.inc | 4311 ++ lib/dmustache/mormot.core.os.windows.inc | 5614 ++ lib/dmustache/mormot.core.rtti.delphi.inc | 788 + lib/dmustache/mormot.core.rtti.pas | 9888 +++ lib/dmustache/mormot.core.search.pas | 6328 ++ lib/dmustache/mormot.core.text.pas | 10325 +++ lib/dmustache/mormot.core.unicode.pas | 10431 +++ lib/dmustache/mormot.core.variants.pas | 12030 +++ lib/dmustache/mormot.defines.inc | 790 + samples/htmx/HTMX_Sample.dproj | 18 +- samples/htmx_mustache/htmx_mustache.dpr | 16 - samples/htmx_mustache/htmx_mustache.dproj | 15 +- .../CustomMustacheHelpersU.pas | 2 +- .../ServerSideViewsMustache.dpr | 4 +- .../ServerSideViewsMustache.dproj | 5 + .../serversideviews_mustache/WebModuleU.pas | 3 +- sources/MVCFramework.ActiveRecord.pas | 2 +- sources/MVCFramework.Middleware.JWT.pas | 8 +- .../MVCFramework.View.Renderers.Mustache.pas | 13 +- 41 files changed, 130238 insertions(+), 88285 deletions(-) delete mode 100644 lib/dmustache/.gitattributes delete mode 100644 lib/dmustache/.gitignore delete mode 100644 lib/dmustache/README.md delete mode 100644 lib/dmustache/SynCommons.pas delete mode 100644 lib/dmustache/SynDoubleToText.inc delete mode 100644 lib/dmustache/SynFPCLinux.pas delete mode 100644 lib/dmustache/SynFPCTypInfo.pas delete mode 100644 lib/dmustache/SynLZ.pas delete mode 100644 lib/dmustache/SynMustache.pas delete mode 100644 lib/dmustache/SynTable.pas delete mode 100644 lib/dmustache/Synopse.inc delete mode 100644 lib/dmustache/SynopseCommit.inc create mode 100644 lib/dmustache/mormot.commit.inc create mode 100644 lib/dmustache/mormot.core.base.asmx64.inc create mode 100644 lib/dmustache/mormot.core.base.asmx86.inc create mode 100644 lib/dmustache/mormot.core.base.pas create mode 100644 lib/dmustache/mormot.core.buffers.pas create mode 100644 lib/dmustache/mormot.core.data.pas create mode 100644 lib/dmustache/mormot.core.datetime.pas create mode 100644 lib/dmustache/mormot.core.json.pas create mode 100644 lib/dmustache/mormot.core.mustache.pas create mode 100644 lib/dmustache/mormot.core.os.pas create mode 100644 lib/dmustache/mormot.core.os.posix.inc create mode 100644 lib/dmustache/mormot.core.os.windows.inc create mode 100644 lib/dmustache/mormot.core.rtti.delphi.inc create mode 100644 lib/dmustache/mormot.core.rtti.pas create mode 100644 lib/dmustache/mormot.core.search.pas create mode 100644 lib/dmustache/mormot.core.text.pas create mode 100644 lib/dmustache/mormot.core.unicode.pas create mode 100644 lib/dmustache/mormot.core.variants.pas create mode 100644 lib/dmustache/mormot.defines.inc diff --git a/lib/dmustache/.gitattributes b/lib/dmustache/.gitattributes deleted file mode 100644 index 5b74ab7d..00000000 --- a/lib/dmustache/.gitattributes +++ /dev/null @@ -1,22 +0,0 @@ -# Auto detect text files and perform no LF normalization -* binary - -# Custom for Visual Studio -*.cs diff=csharp -*.sln merge=union -*.csproj merge=union -*.vbproj merge=union -*.fsproj merge=union -*.dbproj merge=union - -# Standard to msysgit -*.doc diff=astextplain -*.DOC diff=astextplain -*.docx diff=astextplain -*.DOCX diff=astextplain -*.dot diff=astextplain -*.DOT diff=astextplain -*.pdf diff=astextplain -*.PDF diff=astextplain -*.rtf diff=astextplain -*.RTF diff=astextplain diff --git a/lib/dmustache/.gitignore b/lib/dmustache/.gitignore deleted file mode 100644 index 8ff327c9..00000000 --- a/lib/dmustache/.gitignore +++ /dev/null @@ -1,88 +0,0 @@ -# Uncomment these types if you want even more clean repository. But be careful. -# It can make harm to an existing project source. Read explanations below. -# -# Resource files are binaries containing manifest, project icon and version info. -# They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. -#*.res -# -# Type library file (binary). In old Delphi versions it should be stored. -# Since Delphi 2009 it is produced from .ridl file and can safely be ignored. -#*.tlb -# -# Diagram Portfolio file. Used by the diagram editor up to Delphi 7. -# Uncomment this if you are not using diagrams or use newer Delphi version. -*.ddp -*.dof -# -# Visual LiveBindings file. Added in Delphi XE2. -# Uncomment this if you are not using LiveBindings Designer. -#*.vlb -# -# Deployment Manager configuration file for your project. Added in Delphi XE2. -# Uncomment this if it is not mobile development and you do not use remote debug feature. -#*.deployproj -# -# C++ object files produced when C/C++ Output file generation is configured. -# Uncomment this if you are not using external objects (zlib library for example). -#*.obj -# - -# Delphi compiler-generated binaries (safe to delete) -*.exe -*.dll -*.bpl -*.bpi -*.dcp -*.so -*.apk -*.drc -*.map -*.dres -*.rsm -*.tds -*.dcu -*.lib -*.a -*.o -*.ocx - -# FreePascal compiler -*.com -*.class -*.ppu -*.compiled -*.rsj -*.or -*.lps -*.db -fpc/ - -# Delphi autogenerated files (duplicated info) -*.cfg -*.hpp -*Resource.rc - -# Delphi local files (user-specific info) -*.local -*.identcache -*.projdata -*.tvsconfig -*.dsk - -# Delphi history and backups -__history/ -__recovery/ -*.~* -*.bak - -# Castalia statistics file (since XE7 Castalia is distributed with Delphi) -*.stat - -#other VCS -_FOSSIL_ -.svn/ -# SourceCodeRep artifact -*.txt - -backup/ -.idea/ diff --git a/lib/dmustache/README.md b/lib/dmustache/README.md deleted file mode 100644 index c83670d3..00000000 --- a/lib/dmustache/README.md +++ /dev/null @@ -1,201 +0,0 @@ -`SynMustache` is a Delphi/FPC implementation of the [Mustache template language](http://mustache.github.io/). - - -Presentation -============ - - * SynMustache is the first Delphi implementation of Mustache, supporting Delphi 6 up to latest Delphi, and FPC/Lazarus; - * It has a separate parser and renderer (so you can compile your templates ahead of time); - * The parser features a shared cache of compiled templates; - * It [passes all official Mustache specification tests](https://github.com/mustache/spec) - including all weird whitespace process; - * External partials can be supplied as `TSynMustachePartials` dictionaries; - * `{{.}}`, `{{-index}}` and `{{"some text}}` pseudo-variables were added to the standard Mustache syntax; - * `{{#-first}}`, `{{#-last}}` and `{{#-odd}}` pseudo-sections were added to the standard Mustache syntax; - * `{{helperName value}}` *Expression Helpers* were added to the standard Mustache syntax; - * `{{if value<=>value}}` *Expression Helper* for conditional sections; - * Internal partials can be defined via `{{partial}}'#$A'3'); - html := mustache.RenderJSON('{}',TSynMustachePartials.CreateOwned(['partial','1'#$A'2'])); - // now html='1'#$A'23','external partials' - -Here `TSynMustachePartials.CreateOwned()` expects the partials to be supplied as name/value pairs. - -Internal partials (one of the SynMustache extensions), can be defined directly in the main template: - - mustache := TSynMustache.Parse('{{partial}}4'); - html := mustache.RenderJSON('{name:3}'); - // now html='1'#$A'234','internal partials' - -Internationalization --------------------- - -You can define `{{"some text}}` pseudo-variables in your templates, which text will be supplied to a callback, ready to be transformed on the fly: it may be convenient for i18n of web applications. - -By default, the text will be written directly to the output buffer, but you can define a callback which may be used e.g. for text translation: - - procedure TTestLowLevelTypes.MustacheTranslate(var English: string); - begin - if English='Hello' then - English := 'Bonjour' else - if English='You have just won' then - English := 'Vous venez de gagner'; - end; - -Of course, in a real application, you may assign one `TLanguageFile.Translate(var English: string)` method, as defined in the `mORMoti18n.pas` unit. - -Then, you will be able to define your template as such: - - mustache := TSynMustache.Parse( - '{{"Hello}} {{name}}'#13#10'{{"You have just won}} {{value}} {{"dollars}}!'); - html := mustache.RenderJSON('{name:?,value:?}',[],['Chris',10000],nil,MustacheTranslate); - // now html='Bonjour Chris'#$D#$A'Vous venez de gagner 10000 dollars!' - -All text has indeed been translated as expected. - - -Some Links -========== - -We wrote a series of blog articles, about Mustache in general, and `SynMustache` unit in particular: - - * [Mustache Logic-less templates for Delphi - part 1: general presentation of Mustache](https://blog.synopse.info/?post/2014/04/28/Mustache-Logic-less-templates-for-Delphi-part-1); - * [Mustache Logic-less templates for Delphi - part 2: the Mustache syntax](https://blog.synopse.info/?post/2014/04/28/Mustache-Logic-less-templates-for-Delphi-part-2); - * [Mustache Logic-less templates for Delphi - part 3: SynMustache implementation](https://blog.synopse.info/?post/2014/04/28/Mustache-Logic-less-templates-for-Delphi-part-3). - -You can use also [Synopse forums](http://synopse.info/forum/viewtopic.php?id=1720) to obtain direct support from the developpers, or send your feedback. - -The documentation is [available as a single pdf file](http://blog.synopse.info/public/Documents/SynMustache.pdf), if needed. Note that this `pdf` can be outdated, so you should better consult the "Mustache" part of the *mORMot* SAD pdf, which should be more accurate. - - -*The Synopse team* diff --git a/lib/dmustache/SynCommons.pas b/lib/dmustache/SynCommons.pas deleted file mode 100644 index c1b039ef..00000000 --- a/lib/dmustache/SynCommons.pas +++ /dev/null @@ -1,63348 +0,0 @@ -/// 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) 2022 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) 2022 - the Initial Developer. All Rights Reserved. - - Contributor(s): - - Alan Chate - - Aleksandr (sha) - - Alfred Glaenzer (alf) - - ASiwon - - Chaa - - BigStar - - Eugene Ilyin - - f-vicente - - itSDS - - Johan Bontes - - kevinday - - Kevin Chen - - Maciej Izak (hnb) - - Marius Maximus (mariuszekpl) - - mazinsw - - mingda - - PBa - - RalfS - - Sanyin - - Pavel Mashlyakovskii (mpv) - - Wloochacz - - zed - - Alternatively, the contents of this file may be used under the terms of - either the GNU General Public License Version 2 or later (the "GPL"), or - the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), - in which case the provisions of the GPL or the LGPL are applicable instead - of those above. If you wish to allow use of your version of this file only - under the terms of either the GPL or the LGPL, and not to allow others to - use your version of this file under the terms of the MPL, indicate your - decision by deleting the provisions above and replace them with the notice - and other provisions required by the GPL or the LGPL. If you do not delete - the provisions above, a recipient may use your version of this file under - the terms of any one of the MPL, the GPL or the LGPL. - - ***** END LICENSE BLOCK ***** - -*) - - -{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER - -interface - -uses -{$ifdef MSWINDOWS} - Windows, - Messages, -{$else MSWINDOWS} - {$ifdef KYLIX3} - Types, - LibC, - SynKylix, - {$endif KYLIX3} - {$ifdef FPC} - BaseUnix, - {$endif FPC} -{$endif MSWINDOWS} - Classes, -{$ifndef LVCL} - SyncObjs, // for TEvent and TCriticalSection - Contnrs, // for TObjectList - {$ifdef HASINLINE} - Types, - {$endif HASINLINE} -{$endif LVCL} -{$ifndef NOVARIANTS} - Variants, -{$endif NOVARIANTS} - SynLZ, // needed for TSynMapFile .mab format - SysUtils; - - -const - /// the corresponding version of the freeware Synopse framework - // - includes a commit increasing number (generated by SourceCodeRep tool) - // - a similar constant shall be defined in SynCrtSock.pas - SYNOPSE_FRAMEWORK_VERSION = {$I SynopseCommit.inc}; - - /// a text including the version and the main active conditional options - // - usefull for low-level debugging purpose - SYNOPSE_FRAMEWORK_FULLVERSION = SYNOPSE_FRAMEWORK_VERSION - {$ifdef FPC} - {$ifdef FPC_X64MM}+' x64MM'{$ifdef FPCMM_BOOST}+'b'{$endif} - {$ifdef FPCMM_SERVER}+'s'{$endif}{$else} - {$ifdef FPC_FASTMM4}+' FMM4'{$else} - {$ifdef FPC_SYNTBB}+' TBB'{$else} - {$ifdef FPC_SYNJEMALLOC}+' JM'{$else} - {$ifdef FPC_SYNCMEM}+' CM'{$else} - {$ifdef FPC_CMEM}+' cM'{$endif}{$endif}{$endif}{$endif}{$endif}{$endif} - {$else} - {$ifdef LVCL}+' LVCL'{$else} - {$ifdef ENHANCEDRTL}+' ERTL'{$endif}{$endif} - {$ifdef FullDebugMode}+' FDM'{$endif} - {$endif FPC} - {$ifdef DOPATCHTRTL}+' PRTL'{$endif}; - - -{ ************ common types used for compatibility between compilers and CPU } - -const - /// internal Code Page for UTF-16 Unicode encoding - // - used e.g. for Delphi 2009+ UnicodeString=String type - CP_UTF16 = 1200; - - /// fake code page used to recognize TSQLRawBlob - // - as returned e.g. by TTypeInfo.AnsiStringCodePage from mORMot.pas - CP_SQLRAWBLOB = 65534; - - /// internal Code Page for RawByteString undefined string - CP_RAWBYTESTRING = 65535; - - /// US English Windows Code Page, i.e. WinAnsi standard character encoding - CODEPAGE_US = 1252; - - /// Latin-1 ISO/IEC 8859-1 Code Page - CODEPAGE_LATIN1 = 819; - -{$ifndef MSWINDOWS} - /// internal Code Page for UTF-8 Unicode encoding - CP_UTF8 = 65001; -var - /// contains the curent system code page (default WinAnsi) - GetACP: integer = CODEPAGE_US; -{$endif} - -{$ifdef FPC} { make cross-compiler and cross-CPU types available to Delphi } - -type - PBoolean = ^Boolean; - -{$else FPC} - -type - {$ifdef CPU64} // Delphi XE2 seems stable about those types (not Delphi 2009) - PtrInt = NativeInt; - PtrUInt = NativeUInt; - {$else} - /// a CPU-dependent signed integer type cast of a pointer / register - // - used for 64-bit compatibility, native under Free Pascal Compiler - PtrInt = integer; - /// a CPU-dependent unsigned integer type cast of a pointer / register - // - used for 64-bit compatibility, native under Free Pascal Compiler - PtrUInt = cardinal; - {$endif} - /// a CPU-dependent unsigned integer type cast of a pointer of pointer - // - used for 64-bit compatibility, native under Free Pascal Compiler - PPtrUInt = ^PtrUInt; - /// a CPU-dependent signed integer type cast of a pointer of pointer - // - used for 64-bit compatibility, native under Free Pascal Compiler - PPtrInt = ^PtrInt; - - /// unsigned Int64 doesn't exist under older Delphi, but is defined in FPC - // - and UInt64 is buggy as hell under Delphi 2007 when inlining functions: - // older compilers will fallback to signed Int64 values - // - anyway, consider using SortDynArrayQWord() to compare QWord values - // in a safe and efficient way, under a CPUX86 - // - you may use UInt64 explicitly in your computation (like in SynEcc.pas), - // if you are sure that Delphi 6-2007 compiler handles your code as expected, - // but mORMot code will expect to use QWord for its internal process - // (e.g. ORM/SOA serialization) - {$ifdef UNICODE} - QWord = UInt64; - {$else} - QWord = {$ifndef DELPHI5OROLDER}type{$endif} Int64; - {$endif} - /// points to an unsigned Int64 - PQWord = ^QWord; - - {$ifndef ISDELPHIXE2} - /// used to store the handle of a system Thread - TThreadID = cardinal; - {$endif} - -{$endif FPC} - -{$ifdef DELPHI6OROLDER} - -// some definitions not available prior to Delphi 7 -type - UInt64 = Int64; - -{$endif} - -{$ifdef DELPHI5OROLDER} - // Delphi 5 doesn't have those basic types defined :( -const - varShortInt = $0010; - varInt64 = $0014; { vt_i8 } - soBeginning = soFromBeginning; - soCurrent = soFromCurrent; - reInvalidPtr = 2; - PathDelim = '\'; - sLineBreak = #13#10; - -type - PPointer = ^Pointer; - PPAnsiChar = ^PAnsiChar; - PInteger = ^Integer; - PCardinal = ^Cardinal; - PByte = ^Byte; - PWord = ^Word; - PBoolean = ^Boolean; - PDouble = ^Double; - PComp = ^Comp; - THandle = LongWord; - PVarData = ^TVarData; - TVarData = packed record - // mostly used for varNull, varInt64, varDouble, varString and varAny - VType: word; - case Integer of - 0: (Reserved1: Word; - case Integer of - 0: (Reserved2, Reserved3: Word; - case Integer of - varSmallInt: (VSmallInt: SmallInt); - varInteger: (VInteger: Integer); - varSingle: (VSingle: Single); - varDouble: (VDouble: Double); // DOUBLE - varCurrency: (VCurrency: Currency); - varDate: (VDate: TDateTime); - varOleStr: (VOleStr: PWideChar); - varDispatch: (VDispatch: Pointer); - varError: (VError: HRESULT); - varBoolean: (VBoolean: WordBool); - varUnknown: (VUnknown: Pointer); - varByte: (VByte: Byte); - varInt64: (VInt64: Int64); // INTEGER - varString: (VString: Pointer); // TEXT - varAny: (VAny: Pointer); - varArray: (VArray: PVarArray); - varByRef: (VPointer: Pointer); - ); - 1: (VLongs: array[0..2] of LongInt); ); - end; -{$else} -{$ifndef FPC} -type - // redefined here to not use the wrong definitions from Windows.pas - PWord = System.PWord; - PSingle = System.PSingle; -{$endif FPC} -{$endif DELPHI5OROLDER} - -type - /// RawUnicode is an Unicode String stored in an AnsiString - // - faster than WideString, which are allocated in Global heap (for COM) - // - an AnsiChar(#0) is added at the end, for having a true WideChar(#0) at ending - // - length(RawUnicode) returns memory bytes count: use (length(RawUnicode) shr 1) - // for WideChar count (that's why the definition of this type since Delphi 2009 - // is AnsiString(1200) and not UnicodeString) - // - pointer(RawUnicode) is compatible with Win32 'Wide' API call - // - mimic Delphi 2009 UnicodeString, without the WideString or Ansi conversion overhead - // - all conversion to/from AnsiString or RawUTF8 must be explicit: the - // compiler is not able to make valid implicit conversion on CP_UTF16 - {$ifdef HASCODEPAGE} - RawUnicode = type AnsiString(CP_UTF16); // Codepage for an UnicodeString - {$else} - RawUnicode = type AnsiString; - {$endif} - - /// RawUTF8 is an UTF-8 String stored in an AnsiString - // - use this type instead of System.UTF8String, which behavior changed - // between Delphi 2009 compiler and previous versions: our implementation - // is consistent and compatible with all versions of Delphi compiler - // - mimic Delphi 2009 UTF8String, without the charset conversion overhead - // - all conversion to/from AnsiString or RawUnicode must be explicit - {$ifdef HASCODEPAGE} - RawUTF8 = type AnsiString(CP_UTF8); // Codepage for an UTF8 string - {$else} - RawUTF8 = type AnsiString; - {$endif} - - /// WinAnsiString is a WinAnsi-encoded AnsiString (code page 1252) - // - use this type instead of System.String, which behavior changed - // between Delphi 2009 compiler and previous versions: our implementation - // is consistent and compatible with all versions of Delphi compiler - // - all conversion to/from RawUTF8 or RawUnicode must be explicit - {$ifdef HASCODEPAGE} - WinAnsiString = type AnsiString(CODEPAGE_US); // WinAnsi Codepage - {$else} - WinAnsiString = type AnsiString; - {$endif} - - {$ifdef HASCODEPAGE} - {$ifdef FPC} - // missing declaration - PRawByteString = ^RawByteString; - {$endif} - {$else} - /// define RawByteString, as it does exist in Delphi 2009+ - // - to be used for byte storage into an AnsiString - // - use this type if you don't want the Delphi compiler not to do any - // code page conversions when you assign a typed AnsiString to a RawByteString, - // i.e. a RawUTF8 or a WinAnsiString - RawByteString = type AnsiString; - /// pointer to a RawByteString - PRawByteString = ^RawByteString; - {$endif} - - /// RawJSON will indicate that this variable content would stay in raw JSON - // - i.e. won't be serialized into values - // - could be any JSON content: number, string, object or array - // - e.g. interface-based service will use it for efficient and AJAX-ready - // transmission of TSQLTableJSON result - RawJSON = type RawUTF8; - - /// SynUnicode is the fastest available Unicode native string type, depending - // on the compiler used - // - this type is native to the compiler, so you can use Length() Copy() and - // such functions with it (this is not possible with RawUnicodeString type) - // - before Delphi 2009+, it uses slow OLE compatible WideString - // (with our Enhanced RTL, WideString allocation can be made faster by using - // an internal caching mechanism of allocation buffers - WideString allocation - // has been made much faster since Windows Vista/Seven) - // - starting with Delphi 2009, it uses fastest UnicodeString type, which - // allow Copy On Write, Reference Counting and fast heap memory allocation - {$ifdef HASVARUSTRING} - SynUnicode = UnicodeString; - {$else} - SynUnicode = WideString; - {$endif HASVARUSTRING} - - PRawUnicode = ^RawUnicode; - PRawJSON = ^RawJSON; - PRawUTF8 = ^RawUTF8; - PWinAnsiString = ^WinAnsiString; - PWinAnsiChar = type PAnsiChar; - PSynUnicode = ^SynUnicode; - - /// a simple wrapper to UTF-8 encoded zero-terminated PAnsiChar - // - PAnsiChar is used only for Win-Ansi encoded text - // - the Synopse mORMot framework uses mostly this PUTF8Char type, - // because all data is internaly stored and expected to be UTF-8 encoded - PUTF8Char = type PAnsiChar; - PPUTF8Char = ^PUTF8Char; - - /// a Row/Col array of PUTF8Char, for containing sqlite3_get_table() result - TPUtf8CharArray = array[0..MaxInt div SizeOf(PUTF8Char)-1] of PUTF8Char; - PPUtf8CharArray = ^TPUtf8CharArray; - - /// a dynamic array of PUTF8Char pointers - TPUTF8CharDynArray = array of PUTF8Char; - - /// a dynamic array of UTF-8 encoded strings - TRawUTF8DynArray = array of RawUTF8; - PRawUTF8DynArray = ^TRawUTF8DynArray; - TRawUTF8DynArrayDynArray = array of TRawUTF8DynArray; - - /// a dynamic array of TVarRec, i.e. could match an "array of const" parameter - TTVarRecDynArray = array of TVarRec; - - {$ifndef NOVARIANTS} - /// a TVarData values array - // - is not called TVarDataArray to avoid confusion with the corresponding - // type already defined in Variants.pas, and used for custom late-binding - TVarDataStaticArray = array[0..MaxInt div SizeOf(TVarData)-1] of TVarData; - PVarDataStaticArray = ^TVarDataStaticArray; - TVariantArray = array[0..MaxInt div SizeOf(Variant)-1] of Variant; - PVariantArray = ^TVariantArray; - TVariantDynArray = array of variant; - PPVariant = ^PVariant; - {$endif} - - PIntegerDynArray = ^TIntegerDynArray; - TIntegerDynArray = array of integer; - TIntegerDynArrayDynArray = array of TIntegerDynArray; - PCardinalDynArray = ^TCardinalDynArray; - TCardinalDynArray = array of cardinal; - PSingleDynArray = ^TSingleDynArray; - TSingleDynArray = array of Single; - PInt64DynArray = ^TInt64DynArray; - TInt64DynArray = array of Int64; - PQwordDynArray = ^TQwordDynArray; - TQwordDynArray = array of Qword; - TPtrUIntDynArray = array of PtrUInt; - PDoubleDynArray = ^TDoubleDynArray; - TDoubleDynArray = array of double; - PCurrencyDynArray = ^TCurrencyDynArray; - TCurrencyDynArray = array of Currency; - TWordDynArray = array of word; - PWordDynArray = ^TWordDynArray; - TByteDynArray = array of byte; - PByteDynArray = ^TByteDynArray; - {$ifndef ISDELPHI2007ANDUP} - TBytes = array of byte; - {$endif} - TObjectDynArray = array of TObject; - PObjectDynArray = ^TObjectDynArray; - TPersistentDynArray = array of TPersistent; - PPersistentDynArray = ^TPersistentDynArray; - TPointerDynArray = array of pointer; - PPointerDynArray = ^TPointerDynArray; - TPPointerDynArray = array of PPointer; - PPPointerDynArray = ^TPPointerDynArray; - TMethodDynArray = array of TMethod; - PMethodDynArray = ^TMethodDynArray; - TObjectListDynArray = array of TObjectList; - PObjectListDynArray = ^TObjectListDynArray; - TFileNameDynArray = array of TFileName; - PFileNameDynArray = ^TFileNameDynArray; - TBooleanDynArray = array of boolean; - PBooleanDynArray = ^TBooleanDynArray; - TClassDynArray = array of TClass; - TWinAnsiDynArray = array of WinAnsiString; - PWinAnsiDynArray = ^TWinAnsiDynArray; - TRawByteStringDynArray = array of RawByteString; - TStringDynArray = array of string; - PStringDynArray = ^TStringDynArray; - PShortStringDynArray = array of PShortString; - PPShortStringArray = ^PShortStringArray; - TShortStringDynArray = array of ShortString; - TDateTimeDynArray = array of TDateTime; - PDateTimeDynArray = ^TDateTimeDynArray; - {$ifndef FPC_OR_UNICODE} - TDate = type TDateTime; - TTime = type TDateTime; - {$endif FPC_OR_UNICODE} - TDateDynArray = array of TDate; - PDateDynArray = ^TDateDynArray; - TTimeDynArray = array of TTime; - PTimeDynArray = ^TTimeDynArray; - TWideStringDynArray = array of WideString; - PWideStringDynArray = ^TWideStringDynArray; - TSynUnicodeDynArray = array of SynUnicode; - PSynUnicodeDynArray = ^TSynUnicodeDynArray; - TGUIDDynArray = array of TGUID; - - PObject = ^TObject; - PClass = ^TClass; - PByteArray = ^TByteArray; - TByteArray = array[0..MaxInt-1] of Byte; // redefine here with {$R-} - PBooleanArray = ^TBooleanArray; - TBooleanArray = array[0..MaxInt-1] of Boolean; - TWordArray = array[0..MaxInt div SizeOf(word)-1] of word; - PWordArray = ^TWordArray; - TIntegerArray = array[0..MaxInt div SizeOf(integer)-1] of integer; - PIntegerArray = ^TIntegerArray; - PIntegerArrayDynArray = array of PIntegerArray; - TPIntegerArray = array[0..MaxInt div SizeOf(PIntegerArray)-1] of PInteger; - PPIntegerArray = ^TPIntegerArray; - TCardinalArray = array[0..MaxInt div SizeOf(cardinal)-1] of cardinal; - PCardinalArray = ^TCardinalArray; - TInt64Array = array[0..MaxInt div SizeOf(Int64)-1] of Int64; - PInt64Array = ^TInt64Array; - TQWordArray = array[0..MaxInt div SizeOf(QWord)-1] of QWord; - PQWordArray = ^TQWordArray; - TPtrUIntArray = array[0..MaxInt div SizeOf(PtrUInt)-1] of PtrUInt; - PPtrUIntArray = ^TPtrUIntArray; - TSmallIntArray = array[0..MaxInt div SizeOf(SmallInt)-1] of SmallInt; - PSmallIntArray = ^TSmallIntArray; - TSingleArray = array[0..MaxInt div SizeOf(Single)-1] of Single; - PSingleArray = ^TSingleArray; - TDoubleArray = array[0..MaxInt div SizeOf(Double)-1] of Double; - PDoubleArray = ^TDoubleArray; - TDateTimeArray = array[0..MaxInt div SizeOf(TDateTime)-1] of TDateTime; - PDateTimeArray = ^TDateTimeArray; - TPAnsiCharArray = array[0..MaxInt div SizeOf(PAnsiChar)-1] of PAnsiChar; - PPAnsiCharArray = ^TPAnsiCharArray; - TRawUTF8Array = array[0..MaxInt div SizeOf(RawUTF8)-1] of RawUTF8; - PRawUTF8Array = ^TRawUTF8Array; - TRawByteStringArray = array[0..MaxInt div SizeOf(RawByteString)-1] of RawByteString; - PRawByteStringArray = ^TRawByteStringArray; - PShortStringArray = array[0..MaxInt div SizeOf(pointer)-1] of PShortString; - PointerArray = array [0..MaxInt div SizeOf(Pointer)-1] of Pointer; - PPointerArray = ^PointerArray; - TObjectArray = array [0..MaxInt div SizeOf(TObject)-1] of TObject; - PObjectArray = ^TObjectArray; - TPtrIntArray = array[0..MaxInt div SizeOf(PtrInt)-1] of PtrInt; - PPtrIntArray = ^TPtrIntArray; - PInt64Rec = ^Int64Rec; - PPShortString = ^PShortString; - - {$ifndef DELPHI5OROLDER} - PIInterface = ^IInterface; - TInterfaceDynArray = array of IInterface; - PInterfaceDynArray = ^TInterfaceDynArray; - {$endif} - - {$ifndef LVCL} - TCollectionClass = class of TCollection; - TCollectionItemClass = class of TCollectionItem; - {$endif} - - /// class-reference type (metaclass) of a TStream - TStreamClass = class of TStream; - - /// class-reference type (metaclass) of a TInterfacedObject - TInterfacedObjectClass = class of TInterfacedObject; - - -{ ************ fast UTF-8 / Unicode / Ansi types and conversion routines **** } - -// some constants used for UTF-8 conversion, including surrogates -const - UTF16_HISURROGATE_MIN = $d800; - UTF16_HISURROGATE_MAX = $dbff; - UTF16_LOSURROGATE_MIN = $dc00; - UTF16_LOSURROGATE_MAX = $dfff; - UTF8_EXTRABYTES: array[$80..$ff] of byte = ( - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, - 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,0,0); - UTF8_EXTRA: array[0..6] of record - offset, minimum: cardinal; - end = ( // http://floodyberry.wordpress.com/2007/04/14/utf-8-conversion-tricks - (offset: $00000000; minimum: $00010000), - (offset: $00003080; minimum: $00000080), - (offset: $000e2080; minimum: $00000800), - (offset: $03c82080; minimum: $00010000), - (offset: $fa082080; minimum: $00200000), - (offset: $82082080; minimum: $04000000), - (offset: $00000000; minimum: $04000000)); - UTF8_EXTRA_SURROGATE = 3; - UTF8_FIRSTBYTE: array[2..6] of byte = ($c0,$e0,$f0,$f8,$fc); - -type - /// kind of adding in a TTextWriter - TTextWriterKind = (twNone, twJSONEscape, twOnSameLine); - - /// an abstract class to handle Ansi to/from Unicode translation - // - implementations of this class will handle efficiently all Code Pages - // - this default implementation will use the Operating System APIs - // - you should not create your own class instance by yourself, but should - // better retrieve an instance using TSynAnsiConvert.Engine(), which will - // initialize either a TSynAnsiFixedWidth or a TSynAnsiConvert instance on need - TSynAnsiConvert = class - protected - fCodePage: cardinal; - fAnsiCharShift: byte; - {$ifdef KYLIX3} - fIConvCodeName: RawUTF8; - {$endif} - procedure InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; - DestTextWriter: TObject; Escape: TTextWriterKind); virtual; - public - /// initialize the internal conversion engine - constructor Create(aCodePage: cardinal); reintroduce; virtual; - /// returns the engine corresponding to a given code page - // - a global list of TSynAnsiConvert instances is handled by the unit - - // therefore, caller should not release the returned instance - // - will return nil in case of unhandled code page - // - is aCodePage is 0, will return CurrentAnsiConvert value - class function Engine(aCodePage: cardinal): TSynAnsiConvert; - /// direct conversion of a PAnsiChar buffer into an Unicode buffer - // - Dest^ buffer must be reserved with at least SourceChars*2 bytes - // - this default implementation will use the Operating System APIs - // - will append a trailing #0 to the returned PWideChar, unless - // NoTrailingZero is set - function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; overload; virtual; - /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - // - will append a trailing #0 to the returned PUTF8Char, unless - // NoTrailingZero is set - // - this default implementation will use the Operating System APIs - function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; overload; virtual; - /// convert any Ansi Text into an UTF-16 Unicode String - // - returns a value using our RawUnicode kind of string - function AnsiToRawUnicode(const AnsiText: RawByteString): RawUnicode; overload; - /// convert any Ansi buffer into an Unicode String - // - returns a value using our RawUnicode kind of string - function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; overload; virtual; - /// convert any Ansi buffer into an Unicode String - // - returns a SynUnicode, i.e. Delphi 2009+ UnicodeString or a WideString - function AnsiToUnicodeString(Source: PAnsiChar; SourceChars: Cardinal): SynUnicode; overload; - /// convert any Ansi buffer into an Unicode String - // - returns a SynUnicode, i.e. Delphi 2009+ UnicodeString or a WideString - function AnsiToUnicodeString(const Source: RawByteString): SynUnicode; overload; - /// convert any Ansi Text into an UTF-8 encoded String - // - internaly calls AnsiBufferToUTF8 virtual method - function AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; virtual; - /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded string - // - will call AnsiBufferToUnicode() overloaded virtual method - function AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; overload; virtual; - /// direct conversion of an Unicode buffer into a PAnsiChar buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - // - this default implementation will rely on the Operating System for - // all non ASCII-7 chars - function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; overload; virtual; - /// direct conversion of an Unicode buffer into an Ansi Text - function UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString; overload; virtual; - /// convert any Unicode-encoded String into Ansi Text - // - internaly calls UnicodeBufferToAnsi virtual method - function RawUnicodeToAnsi(const Source: RawUnicode): RawByteString; - /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar buffer - // - Dest^ buffer must be reserved with at least SourceChars bytes - // - no trailing #0 is appended to the buffer - function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; - SourceChars: Cardinal): PAnsiChar; overload; virtual; - /// convert any UTF-8 encoded buffer into Ansi Text - // - internaly calls UTF8BufferToAnsi virtual method - function UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - /// convert any UTF-8 encoded buffer into Ansi Text - // - internaly calls UTF8BufferToAnsi virtual method - procedure UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal; - var result: RawByteString); overload; virtual; - /// convert any UTF-8 encoded String into Ansi Text - // - internaly calls UTF8BufferToAnsi virtual method - function UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; virtual; - /// direct conversion of a UTF-8 encoded string into a WinAnsi buffer - // - will truncate the destination string to DestSize bytes (including the - // trailing #0), with a maximum handled size of 2048 bytes - // - returns the number of bytes stored in Dest^ (i.e. the position of #0) - function Utf8ToAnsiBuffer(const S: RawUTF8; Dest: PAnsiChar; DestSize: integer): integer; - /// convert any Ansi Text (providing a From converted) into Ansi Text - function AnsiToAnsi(From: TSynAnsiConvert; const Source: RawByteString): RawByteString; overload; - /// convert any Ansi buffer (providing a From converted) into Ansi Text - function AnsiToAnsi(From: TSynAnsiConvert; Source: PAnsiChar; SourceChars: cardinal): RawByteString; overload; - /// corresponding code page - property CodePage: Cardinal read fCodePage; - end; - - /// a class to handle Ansi to/from Unicode translation of fixed width encoding - // (i.e. non MBCS) - // - this class will handle efficiently all Code Page availables without MBCS - // encoding - like WinAnsi (1252) or Russian (1251) - // - it will use internal fast look-up tables for such encodings - // - this class could take some time to generate, and will consume more than - // 64 KB of memory: you should not create your own class instance by yourself, - // but should better retrieve an instance using TSynAnsiConvert.Engine(), which - // will initialize either a TSynAnsiFixedWidth or a TSynAnsiConvert instance - // on need - // - this class has some additional methods (e.g. IsValid*) which take - // advantage of the internal lookup tables to provide some fast process - TSynAnsiFixedWidth = class(TSynAnsiConvert) - protected - fAnsiToWide: TWordDynArray; - fWideToAnsi: TByteDynArray; - procedure InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; - DestTextWriter: TObject; Escape: TTextWriterKind); override; - public - /// initialize the internal conversion engine - constructor Create(aCodePage: cardinal); override; - /// direct conversion of a PAnsiChar buffer into an Unicode buffer - // - Dest^ buffer must be reserved with at least SourceChars*2 bytes - // - will append a trailing #0 to the returned PWideChar, unless - // NoTrailingZero is set - function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; override; - /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - // - will append a trailing #0 to the returned PUTF8Char, unless - // NoTrailingZero is set - function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; override; - /// convert any Ansi buffer into an Unicode String - // - returns a value using our RawUnicode kind of string - function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; override; - /// direct conversion of an Unicode buffer into a PAnsiChar buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - // - this overridden version will use internal lookup tables for fast process - function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; override; - /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar buffer - // - Dest^ buffer must be reserved with at least SourceChars bytes - // - no trailing #0 is appended to the buffer - function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; - SourceChars: Cardinal): PAnsiChar; override; - /// conversion of a wide char into the corresponding Ansi character - // - return -1 for an unknown WideChar in the current code page - function WideCharToAnsiChar(wc: cardinal): integer; - /// return TRUE if the supplied unicode buffer only contains characters of - // the corresponding Ansi code page - // - i.e. if the text can be displayed using this code page - function IsValidAnsi(WideText: PWideChar; Length: PtrInt): boolean; overload; - /// return TRUE if the supplied unicode buffer only contains characters of - // the corresponding Ansi code page - // - i.e. if the text can be displayed using this code page - function IsValidAnsi(WideText: PWideChar): boolean; overload; - /// return TRUE if the supplied UTF-8 buffer only contains characters of - // the corresponding Ansi code page - // - i.e. if the text can be displayed using this code page - function IsValidAnsiU(UTF8Text: PUTF8Char): boolean; - /// return TRUE if the supplied UTF-8 buffer only contains 8 bits characters - // of the corresponding Ansi code page - // - i.e. if the text can be displayed with only 8 bit unicode characters - // (e.g. no "tm" or such) within this code page - function IsValidAnsiU8Bit(UTF8Text: PUTF8Char): boolean; - /// direct access to the Ansi-To-Unicode lookup table - // - use this array like AnsiToWide: array[byte] of word - property AnsiToWide: TWordDynArray read fAnsiToWide; - /// direct access to the Unicode-To-Ansi lookup table - // - use this array like WideToAnsi: array[word] of byte - // - any unhandled WideChar will return ord('?') - property WideToAnsi: TByteDynArray read fWideToAnsi; - end; - - /// a class to handle UTF-8 to/from Unicode translation - // - match the TSynAnsiConvert signature, for code page CP_UTF8 - // - this class is mostly a non-operation for conversion to/from UTF-8 - TSynAnsiUTF8 = class(TSynAnsiConvert) - private - function UnicodeBufferToUTF8(Dest: PAnsiChar; DestChars: Cardinal; - Source: PWideChar; SourceChars: Cardinal): PAnsiChar; - protected - procedure InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; - DestTextWriter: TObject; Escape: TTextWriterKind); override; - public - /// initialize the internal conversion engine - constructor Create(aCodePage: cardinal); override; - /// direct conversion of a PAnsiChar UTF-8 buffer into an Unicode buffer - // - Dest^ buffer must be reserved with at least SourceChars*2 bytes - // - will append a trailing #0 to the returned PWideChar, unless - // NoTrailingZero is set - function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; override; - /// direct conversion of a PAnsiChar UTF-8 buffer into a UTF-8 encoded buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - // - will append a trailing #0 to the returned PUTF8Char, unless - // NoTrailingZero is set - function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; override; - /// convert any UTF-8 Ansi buffer into an Unicode String - // - returns a value using our RawUnicode kind of string - function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; override; - /// direct conversion of an Unicode buffer into a PAnsiChar UTF-8 buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; override; - /// direct conversion of an Unicode buffer into an Ansi Text - function UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString; override; - /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar UTF-8 buffer - // - Dest^ buffer must be reserved with at least SourceChars bytes - // - no trailing #0 is appended to the buffer - function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; - SourceChars: Cardinal): PAnsiChar; override; - /// convert any UTF-8 encoded buffer into Ansi Text - procedure UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal; - var result: RawByteString); override; - /// convert any UTF-8 encoded String into Ansi Text - // - directly assign the input as result, since no conversion is needed - function UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; override; - /// convert any Ansi Text into an UTF-8 encoded String - // - directly assign the input as result, since no conversion is needed - function AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; override; - /// direct conversion of a PAnsiChar buffer into a UTF-8 encoded string - function AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; override; - end; - - /// a class to handle UTF-16 to/from Unicode translation - // - match the TSynAnsiConvert signature, for code page CP_UTF16 - // - even if UTF-16 is not an Ansi format, code page CP_UTF16 may have been - // used to store UTF-16 encoded binary content - // - this class is mostly a non-operation for conversion to/from Unicode - TSynAnsiUTF16 = class(TSynAnsiConvert) - public - /// initialize the internal conversion engine - constructor Create(aCodePage: cardinal); override; - /// direct conversion of a PAnsiChar UTF-16 buffer into an Unicode buffer - // - Dest^ buffer must be reserved with at least SourceChars*2 bytes - // - will append a trailing #0 to the returned PWideChar, unless - // NoTrailingZero is set - function AnsiBufferToUnicode(Dest: PWideChar; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PWideChar; override; - /// direct conversion of a PAnsiChar UTF-16 buffer into a UTF-8 encoded buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - // - will append a trailing #0 to the returned PUTF8Char, unless - // NoTrailingZero is set - function AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean=false): PUTF8Char; override; - /// convert any UTF-16 Ansi buffer into an Unicode String - // - returns a value using our RawUnicode kind of string - function AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; override; - /// direct conversion of an Unicode buffer into a PAnsiChar UTF-16 buffer - // - Dest^ buffer must be reserved with at least SourceChars*3 bytes - function UnicodeBufferToAnsi(Dest: PAnsiChar; Source: PWideChar; SourceChars: Cardinal): PAnsiChar; override; - /// direct conversion of an UTF-8 encoded buffer into a PAnsiChar UTF-16 buffer - // - Dest^ buffer must be reserved with at least SourceChars bytes - // - no trailing #0 is appended to the buffer - function UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; - SourceChars: Cardinal): PAnsiChar; override; - end; - - - /// implements a stack-based storage of some (UTF-8 or binary) text - // - avoid temporary memory allocation via the heap for up to 4KB of data - // - could be used e.g. to make a temporary copy when JSON is parsed in-place - // - call one of the Init() overloaded methods, then Done to release its memory - // - all Init() methods will allocate 16 more bytes, for a trailing #0 and - // to ensure our fast JSON parsing won't trigger any GPF (since it may read - // up to 4 bytes ahead via its PInteger() trick) or any SSE4.2 function - {$ifdef USERECORDWITHMETHODS}TSynTempBuffer = record - {$else}TSynTempBuffer = object{$endif} - public - /// the text/binary length, in bytes, excluding the trailing #0 - len: PtrInt; - /// where the text/binary is available (and any Source has been copied) - // - equals nil if len=0 - buf: pointer; - /// initialize a temporary copy of the content supplied as RawByteString - // - will also allocate and copy the ending #0 (even for binary) - procedure Init(const Source: RawByteString); overload; - /// initialize a temporary copy of the supplied text buffer, ending with #0 - function Init(Source: PUTF8Char): PUTF8Char; overload; - /// initialize a temporary copy of the supplied text buffer - procedure Init(Source: pointer; SourceLen: PtrInt); overload; - /// initialize a new temporary buffer of a given number of bytes - function Init(SourceLen: PtrInt): pointer; overload; - /// initialize a temporary buffer with the length of the internal stack - function InitOnStack: pointer; - /// initialize the buffer returning the internal buffer size (4095 bytes) - // - could be used e.g. for an API call, first trying with plain temp.Init - // and using temp.buf and temp.len safely in the call, only calling - // temp.Init(expectedsize) if the API returned an error about an insufficient - // buffer space - function Init: integer; overload; {$ifdef HASINLINE}inline;{$endif} - /// initialize a new temporary buffer of a given number of random bytes - // - will fill the buffer via FillRandom() calls - // - forcegsl is true by default, since Lecuyer's generator has no HW bug - function InitRandom(RandomLen: integer; forcegsl: boolean=true): pointer; - /// initialize a new temporary buffer filled with 32-bit integer increasing values - function InitIncreasing(Count: PtrInt; Start: PtrInt=0): PIntegerArray; - /// initialize a new temporary buffer of a given number of zero bytes - function InitZero(ZeroLen: PtrInt): pointer; - /// finalize the temporary storage - procedure Done; overload; {$ifdef HASINLINE}inline;{$endif} - /// finalize the temporary storage, and create a RawUTF8 string from it - procedure Done(EndBuf: pointer; var Dest: RawUTF8); overload; - private - // default 4KB buffer allocated on stack - after the len/buf main fields - tmp: array[0..4095] of AnsiChar; - end; - - /// function prototype to be used for hashing of an element - // - it must return a cardinal hash, with as less collision as possible - // - TDynArrayHashed.Init will use crc32c() if no custom function is supplied, - // which will run either as software or SSE4.2 hardware, with good colision - // for most used kind of data - THasher = function(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; - -var - /// global TSynAnsiConvert instance to handle WinAnsi encoding (code page 1252) - // - this instance is global and instantied during the whole program life time - // - it will be created from hard-coded values, and not using the system API, - // since it appeared that some systems (e.g. in Russia) did tweak the registry - // so that 1252 code page maps 1251 code page - WinAnsiConvert: TSynAnsiFixedWidth; - - /// global TSynAnsiConvert instance to handle current system encoding - // - this is the encoding as used by the AnsiString Delphi, so will be used - // before Delphi 2009 to speed-up VCL string handling (especially for UTF-8) - // - this instance is global and instantied during the whole program life time - CurrentAnsiConvert: TSynAnsiConvert; - - /// global TSynAnsiConvert instance to handle UTF-8 encoding (code page CP_UTF8) - // - this instance is global and instantied during the whole program life time - UTF8AnsiConvert: TSynAnsiUTF8; - -/// check if a codepage should be handled by a TSynAnsiFixedWidth page -function IsFixedWidthCodePage(aCodePage: cardinal): boolean; - {$ifdef HASINLINE}inline;{$endif} - -const - /// HTTP header name for the content type, as defined in the corresponding RFC - HEADER_CONTENT_TYPE = 'Content-Type: '; - - /// HTTP header name for the content type, in upper case - // - as defined in the corresponding RFC - // - could be used e.g. with IdemPChar() to retrieve the Content-Type value - HEADER_CONTENT_TYPE_UPPER = 'CONTENT-TYPE: '; - - /// HTTP header name for the client IP, in upper case - // - as defined in our HTTP server classes - // - could be used e.g. with IdemPChar() to retrieve the remote IP address - HEADER_REMOTEIP_UPPER = 'REMOTEIP: '; - - /// HTTP header name for the authorization token, in upper case - // - could be used e.g. with IdemPChar() to retrieve a JWT value - // - will detect header computed e.g. by SynCrtSock.AuthorizationBearer() - HEADER_BEARER_UPPER = 'AUTHORIZATION: BEARER '; - - /// MIME content type used for JSON communication (as used by the Microsoft - // WCF framework and the YUI framework) - JSON_CONTENT_TYPE = 'application/json; charset=UTF-8'; - - /// HTTP header for MIME content type used for plain JSON - JSON_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+JSON_CONTENT_TYPE; - - /// MIME content type used for plain JSON, in upper case - // - could be used e.g. with IdemPChar() to retrieve the Content-Type value - JSON_CONTENT_TYPE_UPPER = 'APPLICATION/JSON'; - - /// HTTP header for MIME content type used for plain JSON, in upper case - // - could be used e.g. with IdemPChar() to retrieve the Content-Type value - JSON_CONTENT_TYPE_HEADER_UPPER = HEADER_CONTENT_TYPE_UPPER+JSON_CONTENT_TYPE_UPPER; - - /// MIME content type used for plain UTF-8 text - TEXT_CONTENT_TYPE = 'text/plain; charset=UTF-8'; - - /// HTTP header for MIME content type used for plain UTF-8 text - TEXT_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+TEXT_CONTENT_TYPE; - - /// MIME content type used for UTF-8 encoded HTML - HTML_CONTENT_TYPE = 'text/html; charset=UTF-8'; - - /// HTTP header for MIME content type used for UTF-8 encoded HTML - HTML_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+HTML_CONTENT_TYPE; - - /// MIME content type used for UTF-8 encoded XML - XML_CONTENT_TYPE = 'text/xml; charset=UTF-8'; - - /// HTTP header for MIME content type used for UTF-8 encoded XML - XML_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+XML_CONTENT_TYPE; - - /// MIME content type used for raw binary data - BINARY_CONTENT_TYPE = 'application/octet-stream'; - - /// MIME content type used for raw binary data, in upper case - BINARY_CONTENT_TYPE_UPPER = 'APPLICATION/OCTET-STREAM'; - - /// HTTP header for MIME content type used for raw binary data - BINARY_CONTENT_TYPE_HEADER = HEADER_CONTENT_TYPE+BINARY_CONTENT_TYPE; - - /// MIME content type used for a JPEG picture - JPEG_CONTENT_TYPE = 'image/jpeg'; - -var - /// MIME content type used for JSON communication - // - i.e. 'application/json; charset=UTF-8' - // - this global will be initialized with JSON_CONTENT_TYPE constant, to - // avoid a memory allocation each time it is assigned to a variable - JSON_CONTENT_TYPE_VAR: RawUTF8; - - /// HTTP header for MIME content type used for plain JSON - // - this global will be initialized with JSON_CONTENT_TYPE_HEADER constant, - // to avoid a memory allocation each time it is assigned to a variable - JSON_CONTENT_TYPE_HEADER_VAR: RawUTF8; - - /// can be used to avoid a memory allocation for res := 'null' - NULL_STR_VAR: RawUTF8; - -/// compute the new capacity when expanding an array of items -// - handle tiny, small, medium, large and huge sizes properly to reduce -// memory usage and maximize performance -function NextGrow(capacity: integer): integer; - -/// equivalence to SetString(s,nil,len) function -// - faster especially under FPC -procedure FastSetString(var s: RawUTF8; p: pointer; len: PtrInt); - {$ifndef HASCODEPAGE}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// equivalence to SetString(s,nil,len) function with a specific code page -// - faster especially under FPC -procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt); - {$ifndef HASCODEPAGE}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// initialize a RawByteString, ensuring returned "aligned" pointer is 16-bytes aligned -// - to be used e.g. for proper SSE process -procedure GetMemAligned(var s: RawByteString; p: pointer; len: PtrInt; - out aligned: pointer); - -/// equivalence to @UTF8[1] expression to ensure a RawUTF8 variable is unique -// - will ensure that the string refcount is 1, and return a pointer to the text -// - under FPC, @UTF8[1] does not call UniqueString() as it does with Delphi -// - if UTF8 is a constant (refcount=-1), will create a temporary copy in heap -function UniqueRawUTF8(var UTF8: RawUTF8): pointer; - {$ifdef HASINLINE}inline;{$endif} - -/// will fast replace all #0 chars as ~ -// - could be used after UniqueRawUTF8() on a in-placed modified JSON buffer, -// in which all values have been ended with #0 -// - you can optionally specify a maximum size, in bytes (this won't reallocate -// the string, but just add a #0 at some point in the UTF8 buffer) -// - could allow logging of parsed input e.g. after an exception -procedure UniqueRawUTF8ZeroToTilde(var UTF8: RawUTF8; MaxSize: integer=maxInt); - -/// conversion of a wide char into a WinAnsi (CodePage 1252) char -// - return '?' for an unknown WideChar in code page 1252 -function WideCharToWinAnsiChar(wc: cardinal): AnsiChar; - {$ifdef HASINLINE}inline;{$endif} - -/// conversion of a wide char into a WinAnsi (CodePage 1252) char index -// - return -1 for an unknown WideChar in code page 1252 -function WideCharToWinAnsi(wc: cardinal): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// return TRUE if the supplied buffer only contains 7-bits Ansi characters -function IsAnsiCompatible(PC: PAnsiChar): boolean; overload; - -/// return TRUE if the supplied UTF-16 buffer only contains 7-bits Ansi characters -function IsAnsiCompatibleW(PW: PWideChar): boolean; overload; - -/// return TRUE if the supplied buffer only contains 7-bits Ansi characters -function IsAnsiCompatible(PC: PAnsiChar; Len: PtrUInt): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return TRUE if the supplied text only contains 7-bits Ansi characters -function IsAnsiCompatible(const Text: RawByteString): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return TRUE if the supplied UTF-16 buffer only contains 7-bits Ansi characters -function IsAnsiCompatibleW(PW: PWideChar; Len: PtrInt): boolean; overload; - -/// return TRUE if the supplied unicode buffer only contains WinAnsi characters -// - i.e. if the text can be displayed using ANSI_CHARSET -function IsWinAnsi(WideText: PWideChar): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return TRUE if the supplied unicode buffer only contains WinAnsi characters -// - i.e. if the text can be displayed using ANSI_CHARSET -function IsWinAnsi(WideText: PWideChar; Length: integer): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return TRUE if the supplied UTF-8 buffer only contains WinAnsi characters -// - i.e. if the text can be displayed using ANSI_CHARSET -function IsWinAnsiU(UTF8Text: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// return TRUE if the supplied UTF-8 buffer only contains WinAnsi 8 bit characters -// - i.e. if the text can be displayed using ANSI_CHARSET with only 8 bit unicode -// characters (e.g. no "tm" or such) -function IsWinAnsiU8Bit(UTF8Text: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// UTF-8 encode one UTF-16 character into Dest -// - return the number of bytes written into Dest (i.e. 1,2 or 3) -// - this method does NOT handle UTF-16 surrogate pairs -function WideCharToUtf8(Dest: PUTF8Char; aWideChar: PtrUInt): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// UTF-8 encode one UTF-16 encoded UCS4 character into Dest -// - return the number of bytes written into Dest (i.e. from 1 up to 6) -// - Source will contain the next UTF-16 character -// - this method DOES handle UTF-16 surrogate pairs -function UTF16CharToUtf8(Dest: PUTF8Char; var Source: PWord): integer; - -/// UTF-8 encode one UCS4 character into Dest -// - return the number of bytes written into Dest (i.e. from 1 up to 6) -// - this method DOES handle UTF-16 surrogate pairs -function UCS4ToUTF8(ucs4: cardinal; Dest: PUTF8Char): integer; - -/// direct conversion of an AnsiString with an unknown code page into an -// UTF-8 encoded String -// - will assume CurrentAnsiConvert.CodePage prior to Delphi 2009 -// - newer UNICODE versions of Delphi will retrieve the code page from string -procedure AnyAnsiToUTF8(const s: RawByteString; var result: RawUTF8); overload; - -/// direct conversion of an AnsiString with an unknown code page into an -// UTF-8 encoded String -// - will assume CurrentAnsiConvert.CodePage prior to Delphi 2009 -// - newer UNICODE versions of Delphi will retrieve the code page from string -function AnyAnsiToUTF8(const s: RawByteString): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a WinAnsi (CodePage 1252) string into a UTF-8 encoded String -// - faster than SysUtils: don't use Utf8Encode(WideString) -> no Windows.Global(), -// and use a fixed pre-calculated array for individual chars conversion -function WinAnsiToUtf8(const S: WinAnsiString): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a WinAnsi (CodePage 1252) string into a UTF-8 encoded String -// - faster than SysUtils: don't use Utf8Encode(WideString) -> no Windows.Global(), -// and use a fixed pre-calculated array for individual chars conversion -function WinAnsiToUtf8(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a WinAnsi PAnsiChar buffer into a UTF-8 encoded buffer -// - Dest^ buffer must be reserved with at least SourceChars*3 -// - call internally WinAnsiConvert fast conversion class -function WinAnsiBufferToUtf8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a WinAnsi shortstring into a UTF-8 text -// - call internally WinAnsiConvert fast conversion class -function ShortStringToUTF8(const source: ShortString): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a WinAnsi (CodePage 1252) string into a Unicode encoded String -// - very fast, by using a fixed pre-calculated array for individual chars conversion -function WinAnsiToRawUnicode(const S: WinAnsiString): RawUnicode; - -/// direct conversion of a WinAnsi (CodePage 1252) string into a Unicode buffer -// - very fast, by using a fixed pre-calculated array for individual chars conversion -// - text will be truncated if necessary to avoid buffer overflow in Dest[] -procedure WinAnsiToUnicodeBuffer(const S: WinAnsiString; Dest: PWordArray; DestLen: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a UTF-8 encoded string into a WinAnsi String -function Utf8ToWinAnsi(const S: RawUTF8): WinAnsiString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a UTF-8 encoded zero terminated buffer into a WinAnsi String -function Utf8ToWinAnsi(P: PUTF8Char): WinAnsiString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a UTF-8 encoded zero terminated buffer into a RawUTF8 String -procedure Utf8ToRawUTF8(P: PUTF8Char; var result: RawUTF8); - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a UTF-8 encoded buffer into a WinAnsi PAnsiChar buffer -function UTF8ToWinPChar(dest: PAnsiChar; source: PUTF8Char; count: integer): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a UTF-8 encoded buffer into a WinAnsi shortstring buffer -procedure UTF8ToShortString(var dest: shortstring; source: PUTF8Char); - -/// direct conversion of an ANSI-7 shortstring into an AnsiString -// - can be used e.g. for names retrieved from RTTI to convert them into RawUTF8 -function ShortStringToAnsi7String(const source: shortstring): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of an ANSI-7 shortstring into an AnsiString -// - can be used e.g. for names retrieved from RTTI to convert them into RawUTF8 -procedure ShortStringToAnsi7String(const source: shortstring; var result: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an UTF-8 encoded text into a WideChar (UTF-16) buffer -// - faster than System.UTF8ToUnicode -// - sourceBytes can by 0, therefore length is computed from zero terminated source -// - enough place must be available in dest buffer (guess is sourceBytes*3+2) -// - a WideChar(#0) is added at the end (if something is written) unless -// NoTrailingZero is TRUE -// - returns the BYTE count written in dest, excluding the ending WideChar(#0) -function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; sourceBytes: PtrInt=0; - NoTrailingZero: boolean=false): PtrInt; overload; - -/// convert an UTF-8 encoded text into a WideChar (UTF-16) buffer -// - faster than System.UTF8ToUnicode -// - this overloaded function expect a MaxDestChars parameter -// - sourceBytes can not be 0 for this function -// - enough place must be available in dest buffer (guess is sourceBytes*3+2) -// - a WideChar(#0) is added at the end (if something is written) unless -// NoTrailingZero is TRUE -// - returns the BYTE COUNT (not WideChar count) written in dest, excluding the -// ending WideChar(#0) -function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; - MaxDestChars, sourceBytes: PtrInt; NoTrailingZero: boolean=false): PtrInt; overload; - -/// calculate the UTF-16 Unicode characters count, UTF-8 encoded in source^ -// - count may not match the UCS4 glyphs number, in case of UTF-16 surrogates -// - faster than System.UTF8ToUnicode with dest=nil -function Utf8ToUnicodeLength(source: PUTF8Char): PtrUInt; - -/// returns TRUE if the supplied buffer has valid UTF-8 encoding with no #1..#31 -// control characters -// - supplied input is a pointer to a #0 ended text buffer -function IsValidUTF8WithoutControlChars(source: PUTF8Char): Boolean; overload; - -/// returns TRUE if the supplied buffer has valid UTF-8 encoding with no #0..#31 -// control characters -// - supplied input is a RawUTF8 variable -function IsValidUTF8WithoutControlChars(const source: RawUTF8): Boolean; overload; - -/// will truncate the supplied UTF-8 value if its length exceeds the specified -// UTF-16 Unicode characters count -// - count may not match the UCS4 glyphs number, in case of UTF-16 surrogates -// - returns FALSE if text was not truncated, TRUE otherwise -function Utf8TruncateToUnicodeLength(var text: RawUTF8; maxUtf16: integer): boolean; - -/// will truncate the supplied UTF-8 value if its length exceeds the specified -// bytes count -// - this function will ensure that the returned content will contain only valid -// UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence -// - returns FALSE if text was not truncated, TRUE otherwise -function Utf8TruncateToLength(var text: RawUTF8; maxBytes: PtrUInt): boolean; - -/// compute the truncated length of the supplied UTF-8 value if it exceeds the -// specified bytes count -// - this function will ensure that the returned content will contain only valid -// UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence -// - returns maxUTF8 if text was not truncated, or the number of fitting bytes -function Utf8TruncatedLength(const text: RawUTF8; maxBytes: PtrUInt): PtrInt; overload; - -/// compute the truncated length of the supplied UTF-8 value if it exceeds the -// specified bytes count -// - this function will ensure that the returned content will contain only valid -// UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence -// - returns maxUTF8 if text was not truncated, or the number of fitting bytes -function Utf8TruncatedLength(text: PAnsiChar; textlen,maxBytes: PtrUInt): PtrInt; overload; - -/// calculate the UTF-16 Unicode characters count of the UTF-8 encoded first line -// - count may not match the UCS4 glyphs number, in case of UTF-16 surrogates -// - end the parsing at first #13 or #10 character -function Utf8FirstLineToUnicodeLength(source: PUTF8Char): PtrInt; - -/// convert a UTF-8 encoded buffer into a RawUnicode string -// - if L is 0, L is computed from zero terminated P buffer -// - RawUnicode is ended by a WideChar(#0) -// - faster than System.Utf8Decode() which uses slow widestrings -function Utf8DecodeToRawUnicode(P: PUTF8Char; L: integer): RawUnicode; overload; - -/// convert a UTF-8 string into a RawUnicode string -function Utf8DecodeToRawUnicode(const S: RawUTF8): RawUnicode; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a UTF-8 string into a RawUnicode string -// - this version doesn't resize the length of the result RawUnicode -// and is therefore useful before a Win32 Unicode API call (with nCount=-1) -// - if DestLen is not nil, the resulting length (in bytes) will be stored within -function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; DestLen: PInteger=nil): RawUnicode; overload; - -/// convert a UTF-8 string into a RawUnicode string -// - returns the resulting length (in bytes) will be stored within Dest -function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; var Dest: RawUnicode): integer; overload; - -type - /// option set for RawUnicodeToUtf8() conversion - TCharConversionFlags = set of ( - ccfNoTrailingZero, ccfReplacementCharacterForUnmatchedSurrogate); - -/// convert a RawUnicode PWideChar into a UTF-8 string -procedure RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; - var result: RawUTF8; Flags: TCharConversionFlags = [ccfNoTrailingZero]); overload; - -/// convert a RawUnicode PWideChar into a UTF-8 string -function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; - Flags: TCharConversionFlags = [ccfNoTrailingZero]): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a RawUnicode UTF-16 PWideChar into a UTF-8 buffer -// - replace system.UnicodeToUtf8 implementation, which is rather slow -// since Delphi 2009+ -// - append a trailing #0 to the ending PUTF8Char, unless ccfNoTrailingZero is set -// - if ccfReplacementCharacterForUnmatchedSurrogate is set, this function will identify -// unmatched surrogate pairs and replace them with EF BF BD / FFFD Unicode -// Replacement character - see https://en.wikipedia.org/wiki/Specials_(Unicode_block) -function RawUnicodeToUtf8(Dest: PUTF8Char; DestLen: PtrInt; - Source: PWideChar; SourceLen: PtrInt; Flags: TCharConversionFlags): PtrInt; overload; - -/// convert a RawUnicode PWideChar into a UTF-8 string -// - this version doesn't resize the resulting RawUTF8 string, but return -// the new resulting RawUTF8 byte count into UTF8Length -function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer; - out UTF8Length: integer): RawUTF8; overload; - -/// convert a RawUnicode string into a UTF-8 string -function RawUnicodeToUtf8(const Unicode: RawUnicode): RawUTF8; overload; - -/// convert a SynUnicode string into a UTF-8 string -function SynUnicodeToUtf8(const Unicode: SynUnicode): RawUTF8; - -/// convert a WideString into a UTF-8 string -function WideStringToUTF8(const aText: WideString): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -/// direct conversion of a Unicode encoded buffer into a WinAnsi PAnsiChar buffer -procedure RawUnicodeToWinPChar(dest: PAnsiChar; source: PWideChar; WideCharCount: integer); - {$ifdef HASINLINE}inline;{$endif} - -/// convert a RawUnicode PWideChar into a WinAnsi (code page 1252) string -function RawUnicodeToWinAnsi(WideChar: PWideChar; WideCharCount: integer): WinAnsiString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a RawUnicode string into a WinAnsi (code page 1252) string -function RawUnicodeToWinAnsi(const Unicode: RawUnicode): WinAnsiString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a WideString into a WinAnsi (code page 1252) string -function WideStringToWinAnsi(const Wide: WideString): WinAnsiString; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an AnsiChar buffer (of a given code page) into a UTF-8 string -procedure AnsiCharToUTF8(P: PAnsiChar; L: Integer; var result: RawUTF8; ACP: integer); - -/// convert any Raw Unicode encoded String into a generic SynUnicode Text -function RawUnicodeToSynUnicode(const Unicode: RawUnicode): SynUnicode; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any Raw Unicode encoded String into a generic SynUnicode Text -function RawUnicodeToSynUnicode(WideChar: PWideChar; WideCharCount: integer): SynUnicode; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an Unicode buffer into a WinAnsi (code page 1252) string -procedure UnicodeBufferToWinAnsi(source: PWideChar; out Dest: WinAnsiString); - -/// convert an Unicode buffer into a generic VCL string -function UnicodeBufferToString(source: PWideChar): string; - -{$ifdef HASVARUSTRING} - -/// convert a Delphi 2009+ or FPC Unicode string into our UTF-8 string -function UnicodeStringToUtf8(const S: UnicodeString): RawUTF8; inline; - -// this function is the same as direct RawUTF8=AnsiString(CP_UTF8) assignment -// but is faster, since it uses no Win32 API call -function UTF8DecodeToUnicodeString(const S: RawUTF8): UnicodeString; overload; inline; - -/// convert our UTF-8 encoded buffer into a Delphi 2009+ Unicode string -// - this function is the same as direct assignment, since RawUTF8=AnsiString(CP_UTF8), -// but is faster, since use no Win32 API call -procedure UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer; var result: UnicodeString); overload; - -/// convert a Delphi 2009+ Unicode string into a WinAnsi (code page 1252) string -function UnicodeStringToWinAnsi(const S: UnicodeString): WinAnsiString; inline; - -/// convert our UTF-8 encoded buffer into a Delphi 2009+ Unicode string -// - this function is the same as direct assignment, since RawUTF8=AnsiString(CP_UTF8), -// but is faster, since use no Win32 API call -function UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer): UnicodeString; overload; inline; - -/// convert a Win-Ansi encoded buffer into a Delphi 2009+ Unicode string -// - this function is faster than default RTL, since use no Win32 API call -function WinAnsiToUnicodeString(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): UnicodeString; overload; - -/// convert a Win-Ansi string into a Delphi 2009+ Unicode string -// - this function is faster than default RTL, since use no Win32 API call -function WinAnsiToUnicodeString(const WinAnsi: WinAnsiString): UnicodeString; inline; overload; - -{$endif HASVARUSTRING} - -/// convert any generic VCL Text into an UTF-8 encoded String -// - in the VCL context, it's prefered to use TLanguageFile.StringToUTF8() -// method from mORMoti18n, which will handle full i18n of your application -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -function StringToUTF8(const Text: string): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any generic VCL Text buffer into an UTF-8 encoded String -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -procedure StringToUTF8(Text: PChar; TextLen: PtrInt; var result: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any generic VCL Text into an UTF-8 encoded String -// - this overloaded function use a faster by-reference parameter for the result -procedure StringToUTF8(const Text: string; var result: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any generic VCL Text into an UTF-8 encoded String -function ToUTF8(const Text: string): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any UTF-8 encoded shortstring Text into an UTF-8 encoded String -// - expects the supplied content to be already ASCII-7 or UTF-8 encoded, e.g. -// a RTTI type or property name: it won't work with Ansi-encoded strings -function ToUTF8(const Ansi7Text: ShortString): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a TGUID into UTF-8 encoded text -// - will return e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without the {}) -// - if you need the embracing { }, use GUIDToRawUTF8() function instead -function ToUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; overload; - -{$ifndef NOVARIANTS} - -type - /// function prototype used internally for variant comparison - // - used in mORMot.pas unit e.g. by TDocVariantData.SortByValue - TVariantCompare = function(const V1,V2: variant): PtrInt; - -/// TVariantCompare-compatible case-sensitive comparison function -// - just a wrapper around SortDynArrayVariantComp(caseInsensitive=false) -function VariantCompare(const V1,V2: variant): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// TVariantCompare-compatible case-insensitive comparison function -// - just a wrapper around SortDynArrayVariantComp(caseInsensitive=true) -function VariantCompareI(const V1,V2: variant): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any Variant into UTF-8 encoded String -// - use VariantSaveJSON() instead if you need a conversion to JSON with -// custom parameters -// - note: null will be returned as 'null' -function VariantToUTF8(const V: Variant): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any Variant into UTF-8 encoded String -// - use VariantSaveJSON() instead if you need a conversion to JSON with -// custom parameters -// - note: null will be returned as 'null' -function ToUTF8(const V: Variant): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any Variant into UTF-8 encoded String -// - use VariantSaveJSON() instead if you need a conversion to JSON with -// custom parameters -// - wasString is set if the V value was a text -// - empty and null variants will be stored as 'null' text - as expected by JSON -// - custom variant types (e.g. TDocVariant) will be stored as JSON -procedure VariantToUTF8(const V: Variant; var result: RawUTF8; - var wasString: boolean); overload; - -/// convert any Variant into UTF-8 encoded String -// - use VariantSaveJSON() instead if you need a conversion to JSON with -// custom parameters -// - returns TRUE if the V value was a text, FALSE if was not (e.g. a number) -// - empty and null variants will be stored as 'null' text - as expected by JSON -// - custom variant types (e.g. TDocVariant) will be stored as JSON -function VariantToUTF8(const V: Variant; var Text: RawUTF8): boolean; overload; - -/// convert any date/time Variant into a TDateTime value -// - would handle varDate kind of variant, or use a string conversion and -// ISO-8601 parsing if possible -function VariantToDateTime(const V: Variant; var Value: TDateTime): boolean; - -/// fast conversion from hexa chars, supplied as a variant string, into a binary buffer -function VariantHexDisplayToBin(const Hex: variant; Bin: PByte; BinBytes: integer): boolean; - -/// fast conversion of a binary buffer into hexa chars, as a variant string -function BinToHexDisplayLowerVariant(Bin: pointer; BinBytes: integer): variant; - {$ifdef HASINLINE}inline;{$endif} - -/// fast comparison of a Variant and UTF-8 encoded String (or number) -// - slightly faster than plain V=Str, which computes a temporary variant -// - here Str='' equals unassigned, null or false -// - if CaseSensitive is false, will use IdemPropNameU() for comparison -function VariantEquals(const V: Variant; const Str: RawUTF8; - CaseSensitive: boolean=true): boolean; overload; - -/// convert any Variant into a VCL string type -// - expects any varString value to be stored as a RawUTF8 -// - prior to Delphi 2009, use VariantToString(aVariant) instead of -// string(aVariant) to safely retrieve a string=AnsiString value from a variant -// generated by our framework units - otherwise, you may loose encoded characters -// - for Unicode versions of Delphi, there won't be any potential data loss, -// but this version may be slightly faster than a string(aVariant) -function VariantToString(const V: Variant): string; - -/// convert any Variant into a value encoded as with :(..:) inlined parameters -// in FormatUTF8(Format,Args,Params) -procedure VariantToInlineValue(const V: Variant; var result: RawUTF8); - -/// convert any Variant into another Variant storing an RawUTF8 of the value -// - e.g. VariantToVariantUTF8('toto')='toto' and VariantToVariantUTF8(12)='12' -function VariantToVariantUTF8(const V: Variant): variant; - -/// faster alternative to Finalize(aVariantDynArray) -// - this function will take account and optimize the release of a dynamic -// array of custom variant types values -// - for instance, an array of TDocVariant will be optimized for speed -procedure VariantDynArrayClear(var Value: TVariantDynArray); - {$ifdef HASINLINE}inline;{$endif} - -/// crc32c-based hash of a variant value -// - complex string types will make up to 255 uppercase characters conversion -// if CaseInsensitive is true -// - you can specify your own hashing function if crc32c is not what you expect -function VariantHash(const value: variant; CaseInsensitive: boolean; - Hasher: THasher=nil): cardinal; - -{$endif NOVARIANTS} - -{ note: those VariantToInteger*() functions are expected to be there } - -/// convert any numerical Variant into a 32-bit integer -// - it will expect true numerical Variant and won't convert any string nor -// floating-pointer Variant, which will return FALSE and won't change the -// Value variable content -function VariantToInteger(const V: Variant; var Value: integer): boolean; - -/// convert any numerical Variant into a 64-bit integer -// - it will expect true numerical Variant and won't convert any string nor -// floating-pointer Variant, which will return FALSE and won't change the -// Value variable content -function VariantToInt64(const V: Variant; var Value: Int64): boolean; - -/// convert any numerical Variant into a 64-bit integer -// - it will expect true numerical Variant and won't convert any string nor -// floating-pointer Variant, which will return the supplied DefaultValue -function VariantToInt64Def(const V: Variant; DefaultValue: Int64): Int64; - -/// convert any numerical Variant into a floating point value -function VariantToDouble(const V: Variant; var Value: double): boolean; - -/// convert any numerical Variant into a floating point value -function VariantToDoubleDef(const V: Variant; const default: double=0): double; - -/// convert any numerical Variant into a fixed decimals floating point value -function VariantToCurrency(const V: Variant; var Value: currency): boolean; - -/// convert any numerical Variant into a boolean value -// - text content will return true after case-insensitive 'true' comparison -function VariantToBoolean(const V: Variant; var Value: Boolean): boolean; - -/// convert any numerical Variant into an integer -// - it will expect true numerical Variant and won't convert any string nor -// floating-pointer Variant, which will return the supplied DefaultValue -function VariantToIntegerDef(const V: Variant; DefaultValue: integer): integer; overload; - -/// convert any generic VCL Text buffer into an UTF-8 encoded buffer -// - Dest must be able to receive at least SourceChars*3 bytes -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -function StringBufferToUtf8(Dest: PUTF8Char; Source: PChar; SourceChars: PtrInt): PUTF8Char; overload; - -/// convert any generic VCL 0-terminated Text buffer into an UTF-8 string -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -procedure StringBufferToUtf8(Source: PChar; out result: RawUTF8); overload; - -/// convert any generic VCL Text into a Raw Unicode encoded String -// - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n, -// which will handle full i18n of your application -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -function StringToRawUnicode(const S: string): RawUnicode; overload; - -/// convert any generic VCL Text into a SynUnicode encoded String -// - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n, -// which will handle full i18n of your application -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -function StringToSynUnicode(const S: string): SynUnicode; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any generic VCL Text into a SynUnicode encoded String -// - overloaded to avoid a copy to a temporary result string of a function -procedure StringToSynUnicode(const S: string; var result: SynUnicode); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any generic VCL Text into a Raw Unicode encoded String -// - it's prefered to use TLanguageFile.StringToUTF8() method in mORMoti18n, -// which will handle full i18n of your application -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -function StringToRawUnicode(P: PChar; L: integer): RawUnicode; overload; - -/// convert any Raw Unicode encoded string into a generic VCL Text -// - uses StrLenW() and not length(U) to handle case when was used as buffer -function RawUnicodeToString(const U: RawUnicode): string; overload; - -/// convert any Raw Unicode encoded buffer into a generic VCL Text -function RawUnicodeToString(P: PWideChar; L: integer): string; overload; - -/// convert any Raw Unicode encoded buffer into a generic VCL Text -procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); overload; - -/// convert any SynUnicode encoded string into a generic VCL Text -function SynUnicodeToString(const U: SynUnicode): string; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any UTF-8 encoded String into a generic VCL Text -// - it's prefered to use TLanguageFile.UTF8ToString() in mORMoti18n, -// which will handle full i18n of your application -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -function UTF8ToString(const Text: RawUTF8): string; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any UTF-8 encoded buffer into a generic VCL Text -// - it's prefered to use TLanguageFile.UTF8ToString() in mORMoti18n, -// which will handle full i18n of your application -// - it will work as is with Delphi 2009+ (direct unicode conversion) -// - under older version of Delphi (no unicode), it will use the -// current RTL codepage, as with WideString conversion (but without slow -// WideString usage) -function UTF8DecodeToString(P: PUTF8Char; L: integer): string; overload; - {$ifdef UNICODE}inline;{$endif} - -/// convert any UTF-8 encoded buffer into a generic VCL Text -procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string); overload; - -/// convert any UTF-8 encoded String into a generic WideString Text -function UTF8ToWideString(const Text: RawUTF8): WideString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any UTF-8 encoded String into a generic WideString Text -procedure UTF8ToWideString(const Text: RawUTF8; var result: WideString); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any UTF-8 encoded String into a generic WideString Text -procedure UTF8ToWideString(Text: PUTF8Char; Len: PtrInt; var result: WideString); overload; - -/// convert any UTF-8 encoded String into a generic SynUnicode Text -function UTF8ToSynUnicode(const Text: RawUTF8): SynUnicode; overload; - -/// convert any UTF-8 encoded String into a generic SynUnicode Text -procedure UTF8ToSynUnicode(const Text: RawUTF8; var result: SynUnicode); overload; - -/// convert any UTF-8 encoded buffer into a generic SynUnicode Text -procedure UTF8ToSynUnicode(Text: PUTF8Char; Len: PtrInt; var result: SynUnicode); overload; - -/// convert any Ansi 7 bit encoded String into a generic VCL Text -// - the Text content must contain only 7 bit pure ASCII characters -function Ansi7ToString(const Text: RawByteString): string; overload; - {$ifndef UNICODE}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// convert any Ansi 7 bit encoded String into a generic VCL Text -// - the Text content must contain only 7 bit pure ASCII characters -function Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt): string; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert any Ansi 7 bit encoded String into a generic VCL Text -// - the Text content must contain only 7 bit pure ASCII characters -procedure Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt; var result: string); overload; - -/// convert any generic VCL Text into Ansi 7 bit encoded String -// - the Text content must contain only 7 bit pure ASCII characters -function StringToAnsi7(const Text: string): RawByteString; - -/// convert any generic VCL Text into WinAnsi (Win-1252) 8 bit encoded String -function StringToWinAnsi(const Text: string): WinAnsiString; - {$ifdef UNICODE}inline;{$endif} - -/// fast Format() function replacement, optimized for RawUTF8 -// - only supported token is %, which will be written in the resulting string -// according to each Args[] supplied items - so you will never get any exception -// as with the SysUtils.Format() when a specifier is incorrect -// - resulting string has no length limit and uses fast concatenation -// - there is no escape char, so to output a '%' character, you need to use '%' -// as place-holder, and specify '%' as value in the Args array -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -// - any supplied TObject instance will be written as their class name -function FormatUTF8(const Format: RawUTF8; const Args: array of const): RawUTF8; overload; - -/// fast Format() function replacement, optimized for RawUTF8 -// - overloaded function, which avoid a temporary RawUTF8 instance on stack -procedure FormatUTF8(const Format: RawUTF8; const Args: array of const; - out result: RawUTF8); overload; - -/// fast Format() function replacement, tuned for direct memory buffer write -// - use the same single token % (and implementation) than FormatUTF8() -// - returns the number of UTF-8 bytes appended to Dest^ -function FormatBuffer(const Format: RawUTF8; const Args: array of const; - Dest: pointer; DestLen: PtrInt): PtrInt; - -/// fast Format() function replacement, for UTF-8 content stored in shortstring -// - use the same single token % (and implementation) than FormatUTF8() -// - shortstring allows fast stack allocation, so is perfect for small content -// - truncate result if the text size exceeds 255 bytes -procedure FormatShort(const Format: RawUTF8; const Args: array of const; - var result: shortstring); - -/// fast Format() function replacement, for UTF-8 content stored in shortstring -function FormatToShort(const Format: RawUTF8; const Args: array of const): shortstring; - -/// fast Format() function replacement, tuned for small content -// - use the same single token % (and implementation) than FormatUTF8() -procedure FormatString(const Format: RawUTF8; const Args: array of const; - out result: string); overload; - -/// fast Format() function replacement, tuned for small content -// - use the same single token % (and implementation) than FormatUTF8() -function FormatString(const Format: RawUTF8; const Args: array of const): string; overload; - {$ifdef FPC}inline;{$endif} - -type - /// used e.g. by PointerToHexShort/CardinalToHexShort/Int64ToHexShort/FormatShort16 - // - such result type would avoid a string allocation on heap, so are highly - // recommended e.g. when logging small pieces of information - TShort16 = string[16]; - PShort16 = ^TShort16; - -/// fast Format() function replacement, for UTF-8 content stored in TShort16 -// - truncate result if the text size exceeds 16 bytes -procedure FormatShort16(const Format: RawUTF8; const Args: array of const; - var result: TShort16); - -/// fast Format() function replacement, handling % and ? parameters -// - will include Args[] for every % in Format -// - will inline Params[] for every ? in Format, handling special "inlined" -// parameters, as exected by mORMot.pas unit, i.e. :(1234): for numerical -// values, and :('quoted '' string'): for textual values -// - if optional JSONFormat parameter is TRUE, ? parameters will be written -// as JSON quoted strings, without :(...): tokens, e.g. "quoted "" string" -// - resulting string has no length limit and uses fast concatenation -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -// - any supplied TObject instance will be written as their class name -function FormatUTF8(const Format: RawUTF8; const Args, Params: array of const; - JSONFormat: boolean=false): RawUTF8; overload; - -/// read and store text into values[] according to fmt specifiers -// - %d as PInteger, %D as PInt64, %u as PCardinal, %U as PQWord, %f as PDouble, -// %F as PCurrency, %x as 8 hexa chars to PInteger, %X as 16 hexa chars to PInt64, -// %s as PShortString (UTF-8 encoded), %S as PRawUTF8, %L as PRawUTF8 (getting -// all text until the end of the line) -// - optionally, specifiers and any whitespace separated identifiers may be -// extracted and stored into the ident[] array, e.g. '%dFirstInt %s %DOneInt64' -// will store ['dFirstInt','s','DOneInt64'] into ident -function ScanUTF8(const text, fmt: RawUTF8; const values: array of pointer; - ident: PRawUTF8DynArray=nil): integer; overload; - -/// read text from P/PLen and store it into values[] according to fmt specifiers -function ScanUTF8(P: PUTF8Char; PLen: PtrInt; const fmt: RawUTF8; - const values: array of pointer; ident: PRawUTF8DynArray): integer; overload; - -/// convert an open array (const Args: array of const) argument to an UTF-8 -// encoded text -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -// - any supplied TObject instance will be written as their class name -procedure VarRecToUTF8(const V: TVarRec; var result: RawUTF8; - wasString: PBoolean=nil); - -type - /// a memory structure which avoids a temporary RawUTF8 allocation - // - used by VarRecToTempUTF8() and FormatUTF8()/FormatShort() - TTempUTF8 = record - Len: PtrInt; - Text: PUTF8Char; - TempRawUTF8: pointer; - Temp: array[0..23] of AnsiChar; - end; - PTempUTF8 = ^TTempUTF8; - -/// convert an open array (const Args: array of const) argument to an UTF-8 -// encoded text, using a specified temporary buffer -// - this function would allocate a RawUTF8 in TempRawUTF8 only if needed, -// but use the supplied Res.Temp[] buffer for numbers to text conversion - -// caller should ensure to make RawUTF8(TempRawUTF8) := '' on the entry -// - it would return the number of UTF-8 bytes, i.e. Res.Len -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -// - any supplied TObject instance will be written as their class name -function VarRecToTempUTF8(const V: TVarRec; var Res: TTempUTF8): integer; - -/// convert an open array (const Args: array of const) argument to an UTF-8 -// encoded text, returning FALSE if the argument was not a string value -function VarRecToUTF8IsString(const V: TVarRec; var value: RawUTF8): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an open array (const Args: array of const) argument to an Int64 -// - returns TRUE and set Value if the supplied argument is a vtInteger, vtInt64 -// or vtBoolean -// - returns FALSE if the argument is not an integer -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -function VarRecToInt64(const V: TVarRec; out value: Int64): boolean; - -/// convert an open array (const Args: array of const) argument to a floating -// point value -// - returns TRUE and set Value if the supplied argument is a number (e.g. -// vtInteger, vtInt64, vtCurrency or vtExtended) -// - returns FALSE if the argument is not a number -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -function VarRecToDouble(const V: TVarRec; out value: double): boolean; - -/// convert an open array (const Args: array of const) argument to a value -// encoded as with :(...): inlined parameters in FormatUTF8(Format,Args,Params) -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -// - any supplied TObject instance will be written as their class name -procedure VarRecToInlineValue(const V: TVarRec; var result: RawUTF8); - -/// get an open array (const Args: array of const) character argument -// - only handle varChar and varWideChar kind of arguments -function VarRecAsChar(const V: TVarRec): integer; - {$ifdef HASINLINE}inline;{$endif} - -type - /// function prototype used internally for UTF-8 buffer comparison - // - used in mORMot.pas unit during TSQLTable rows sort and by TSQLQuery - TUTF8Compare = function(P1,P2: PUTF8Char): PtrInt; - -/// convert the endianness of a given unsigned 32-bit integer into BigEndian -function bswap32(a: cardinal): cardinal; - {$ifndef CPUINTEL}inline;{$endif} - -/// convert the endianness of a given unsigned 64-bit integer into BigEndian -function bswap64({$ifdef FPC_X86}constref{$else}const{$endif} a: QWord): QWord; - {$ifndef CPUINTEL}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 -// - in the middle of VCL code, consider using TrimU() which won't have name -// collision ambiguity as with SysUtils' homonymous function -function Trim(const S: RawUTF8): RawUTF8; - -/// fast dedicated RawUTF8 version of Trim() -// - could be used if overloaded Trim() from SysUtils.pas is ambiguous -function TrimU(const S: RawUTF8): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -{$define OWNNORMTOUPPER} { NormToUpper[] exists only in our enhanced RTL } - -{$endif ENHANCEDRTL} - -/// our fast version of CompareMem() with optimized asm for x86 and tune pascal -function CompareMem(P1, P2: Pointer; Length: PtrInt): Boolean; - -{$ifdef HASINLINE} -function CompareMemFixed(P1, P2: Pointer; Length: PtrInt): Boolean; inline; -{$else} -/// a CompareMem()-like function designed for small and fixed-sized content -// - here, Length is expected to be a constant value - typically from sizeof() - -// so that inlining has better performance than calling the CompareMem() function -var CompareMemFixed: function(P1, P2: Pointer; Length: PtrInt): Boolean = CompareMem; -{$endif HASINLINE} - -/// a CompareMem()-like function designed for small (a few bytes) content -function CompareMemSmall(P1, P2: Pointer; Length: PtrUInt): Boolean; {$ifdef HASINLINE}inline;{$endif} - -/// convert some ASCII-7 text into binary, using Emile Baudot code -// - as used in telegraphs, covering #10 #13 #32 a-z 0-9 - ' , ! : ( + ) $ ? @ . / ; -// charset, following a custom static-huffman-like encoding with 5-bit masks -// - any upper case char will be converted into lowercase during encoding -// - other characters (e.g. UTF-8 accents, or controls chars) will be ignored -// - resulting binary will consume 5 (or 10) bits per character -// - reverse of the BaudotToAscii() function -// - the "baud" symbol rate measurement comes from Emile's name ;) -function AsciiToBaudot(P: PAnsiChar; len: PtrInt): RawByteString; overload; - -/// convert some ASCII-7 text into binary, using Emile Baudot code -// - as used in telegraphs, covering #10 #13 #32 a-z 0-9 - ' , ! : ( + ) $ ? @ . / ; -// charset, following a custom static-huffman-like encoding with 5-bit masks -// - any upper case char will be converted into lowercase during encoding -// - other characters (e.g. UTF-8 accents, or controls chars) will be ignored -// - resulting binary will consume 5 (or 10) bits per character -// - reverse of the BaudotToAscii() function -// - the "baud" symbol rate measurement comes from Emile's name ;) -function AsciiToBaudot(const Text: RawUTF8): RawByteString; overload; - -/// convert some Baudot code binary, into ASCII-7 text -// - reverse of the AsciiToBaudot() function -// - any uppercase character would be decoded as lowercase - and some characters -// may have disapeared -// - the "baud" symbol rate measurement comes from Emile's name ;) -function BaudotToAscii(Baudot: PByteArray; len: PtrInt): RawUTF8; overload; - -/// convert some Baudot code binary, into ASCII-7 text -// - reverse of the AsciiToBaudot() function -// - any uppercase character would be decoded as lowercase - and some characters -// may have disapeared -// - the "baud" symbol rate measurement comes from Emile's name ;) -function BaudotToAscii(const Baudot: RawByteString): RawUTF8; overload; - -{$ifdef UNICODE} -/// our fast RawUTF8 version of Pos(), for Unicode only compiler -// - this Pos() is seldom used, but this RawUTF8 specific version is needed -// by Delphi 2009+, to avoid two unnecessary conversions into UnicodeString -// - just a wrapper around PosEx(substr,str,1) -function Pos(const substr, str: RawUTF8): Integer; overload; inline; -{$endif UNICODE} - -/// use our fast RawUTF8 version of IntToStr() -// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 -// - only useful if our Enhanced Runtime (or LVCL) library is not installed -function Int64ToUtf8(Value: Int64): RawUTF8; overload; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// fast RawUTF8 version of IntToStr(), with proper QWord conversion -procedure UInt64ToUtf8(Value: QWord; var result: RawUTF8); - -/// use our fast RawUTF8 version of IntToStr() -// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 -// - only useful if our Enhanced Runtime (or LVCL) library is not installed -function Int32ToUtf8(Value: PtrInt): RawUTF8; overload; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// use our fast RawUTF8 version of IntToStr() -// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 -// - result as var parameter saves a local assignment and a try..finally -procedure Int32ToUTF8(Value: PtrInt; var result: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// use our fast RawUTF8 version of IntToStr() -// - without any slow UnicodeString=String->AnsiString conversion for Delphi 2009 -// - result as var parameter saves a local assignment and a try..finally -procedure Int64ToUtf8(Value: Int64; var result: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// use our fast RawUTF8 version of IntToStr() -function ToUTF8(Value: PtrInt): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -{$ifndef CPU64} -/// use our fast RawUTF8 version of IntToStr() -function ToUTF8(Value: Int64): RawUTF8; overload; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} -{$endif} - -/// optimized conversion of a cardinal into RawUTF8 -function UInt32ToUtf8(Value: PtrUInt): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// optimized conversion of a cardinal into RawUTF8 -procedure UInt32ToUtf8(Value: PtrUInt; var result: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// faster version than default SysUtils.IntToStr implementation -function IntToString(Value: integer): string; overload; - -/// faster version than default SysUtils.IntToStr implementation -function IntToString(Value: cardinal): string; overload; - -/// faster version than default SysUtils.IntToStr implementation -function IntToString(Value: Int64): string; overload; - -/// convert a floating-point value to its numerical text equivalency -function DoubleToString(Value: Double): string; - -/// convert a currency value from its Int64 binary representation into -// its numerical text equivalency -// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) -function Curr64ToString(Value: Int64): string; - -type - /// used to store a set of 8-bit encoded characters - TSynAnsicharSet = set of AnsiChar; - /// used to store a set of 8-bit unsigned integers - TSynByteSet = set of Byte; - -/// check all character within text are spaces or control chars -// - i.e. a faster alternative to trim(text)='' -function IsVoid(const text: RawUTF8): boolean; - -/// returns the supplied text content, without any control char -// - a control char has an ASCII code #0 .. #32, i.e. text[]<=' ' -// - you can specify a custom char set to be excluded, if needed -function TrimControlChars(const text: RawUTF8; const controls: TSynAnsicharSet=[#0..' ']): RawUTF8; - -var - /// best possible precision when rendering a "single" kind of float - // - can be used as parameter for ExtendedToShort/ExtendedToStr - // - is defined as a var, so that you may be able to override the default - // settings, for the whole process - SINGLE_PRECISION: integer = 8; - /// best possible precision when rendering a "double" kind of float - // - can be used as parameter for ExtendedToShort/ExtendedToStr - // - is defined as a var, so that you may be able to override the default - // settings, for the whole process - DOUBLE_PRECISION: integer = 15; - /// best possible precision when rendering a "extended" kind of float - // - can be used as parameter for ExtendedToShort/ExtendedToStr - // - is defined as a var, so that you may be able to override the default - // settings, for the whole process - EXTENDED_PRECISION: integer = 18; - -const - /// a typical error allowed when working with double floating-point values - // - 1E-12 is too small, and triggers sometimes some unexpected errors; - // FPC RTL uses 1E-4 so we are paranoid enough - DOUBLE_SAME = 1E-11; - -type - {$ifdef TSYNEXTENDED80} - /// the floating-point type to be used for best precision and speed - // - will allow to fallback to double e.g. on x64 and ARM CPUs - TSynExtended = extended; - {$else} - /// ARM/Delphi 64-bit does not support 80bit extended -> double is enough - TSynExtended = double; - {$endif TSYNEXTENDED80} - - /// the non-number values potentially stored in an IEEE floating point - TFloatNan = (fnNumber, fnNan, fnInf, fnNegInf); - {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} - /// will actually change anything only on FPC ARM/Aarch64 plaforms - unaligned = Double; - {$endif} - - -const - /// the JavaScript-like values of non-number IEEE constants - // - as recognized by FloatToShortNan, and used by TTextWriter.Add() - // when serializing such single/double/extended floating-point values - JSON_NAN: array[TFloatNan] of string[11] = ( - '0', '"NaN"', '"Infinity"', '"-Infinity"'); - -type - /// small structure used as convenient result to Div100() procedure - TDiv100Rec = packed record - /// contains V div 100 after Div100(V) - D: cardinal; - /// contains V mod 100 after Div100(V) - M: cardinal; - end; - -/// simple wrapper to efficiently compute both division and modulo per 100 -// - compute result.D = Y div 100 and result.M = Y mod 100 -// - under FPC, will use fast multiplication by reciprocal so can be inlined -// - under Delphi, we use our own optimized asm version (which can't be inlined) -procedure Div100(Y: cardinal; var res: TDiv100Rec); - {$ifdef FPC} inline; {$endif} - -/// compare to floating point values, with IEEE 754 double precision -// - use this function instead of raw = operator -// - the precision is calculated from the A and B value range -// - faster equivalent than SameValue() in Math unit -// - if you know the precision range of A and B, it's faster to check abs(A-B)QWord(B) is wrong on older versions of Delphi, so you -// should better use this function or SortDynArrayQWord() to properly compare -// two QWord values over CPUX86 -function CompareQWord(A, B: QWord): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// compute the sum of values, using a running compensation for lost low-order bits -// - a naive "Sum := Sum + Data" will be restricted to 53 bits of resolution, -// so will eventually result in an incorrect number -// - Kahan algorithm keeps track of the accumulated error in integer operations, -// to achieve a precision of more than 100 bits -// - see https://en.wikipedia.org/wiki/Kahan_summation_algorithm -procedure KahanSum(const Data: double; var Sum, Carry: double); - {$ifdef HASINLINE}inline;{$endif} - -/// convert a floating-point value to its numerical text equivalency -// - on Delphi Win32, calls FloatToText() in ffGeneral mode; on FPC uses str() -// - DOUBLE_PRECISION will redirect to DoubleToShort() and its faster Fabian -// Loitsch's Grisu algorithm if available -// - returns the count of chars stored into S, i.e. length(S) -function ExtendedToShort(var S: ShortString; Value: TSynExtended; Precision: integer): integer; - -/// convert a floating-point value to its numerical text equivalency without -// scientification notation -// - DOUBLE_PRECISION will redirect to DoubleToShortNoExp() and its faster Fabian -// Loitsch's Grisu algorithm if available - or calls str(Value:0:precision,S) -// - returns the count of chars stored into S, i.e. length(S) -function ExtendedToShortNoExp(var S: ShortString; Value: TSynExtended; - Precision: integer): integer; - -/// check if the supplied text is NAN/INF/+INF/-INF, i.e. not a number -// - as returned by ExtendedToShort/DoubleToShort textual conversion -// - such values do appear as IEEE floating points, but are not defined in JSON -function FloatToShortNan(const s: shortstring): TFloatNan; - {$ifdef HASINLINE}inline;{$endif} - -/// check if the supplied text is NAN/INF/+INF/-INF, i.e. not a number -// - as returned e.g. by ExtendedToStr/DoubleToStr textual conversion -// - such values do appear as IEEE floating points, but are not defined in JSON -function FloatToStrNan(const s: RawUTF8): TFloatNan; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a floating-point value to its numerical text equivalency -function ExtendedToStr(Value: TSynExtended; Precision: integer): RawUTF8; overload; - -/// convert a floating-point value to its numerical text equivalency -procedure ExtendedToStr(Value: TSynExtended; Precision: integer; var result: RawUTF8); overload; - -/// recognize if the supplied text is NAN/INF/+INF/-INF, i.e. not a number -// - returns the number as text (stored into tmp variable), or "Infinity", -// "-Infinity", and "NaN" for corresponding IEEE special values -// - result is a PShortString either over tmp, or JSON_NAN[] -function FloatToJSONNan(const s: ShortString): PShortString; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a floating-point value to its JSON text equivalency -// - depending on the platform, it may either call str() or FloatToText() -// in ffGeneral mode (the shortest possible decimal string using fixed or -// scientific format) -// - returns the number as text (stored into tmp variable), or "Infinity", -// "-Infinity", and "NaN" for corresponding IEEE special values -// - result is a PShortString either over tmp, or JSON_NAN[] -function ExtendedToJSON(var tmp: ShortString; Value: TSynExtended; - Precision: integer; NoExp: boolean): PShortString; - -/// convert a 64-bit floating-point value to its numerical text equivalency -// - on Delphi Win32, calls FloatToText() in ffGeneral mode -// - on other platforms, i.e. Delphi Win64 and all FPC targets, will use our own -// faster Fabian Loitsch's Grisu algorithm implementation -// - returns the count of chars stored into S, i.e. length(S) -function DoubleToShort(var S: ShortString; const Value: double): integer; - {$ifdef FPC}inline;{$endif} - -/// convert a 64-bit floating-point value to its numerical text equivalency -// without scientific notation -// - on Delphi Win32, calls FloatToText() in ffGeneral mode -// - on other platforms, i.e. Delphi Win64 and all FPC targets, will use our own -// faster Fabian Loitsch's Grisu algorithm implementation -// - returns the count of chars stored into S, i.e. length(S) -function DoubleToShortNoExp(var S: ShortString; const Value: double): integer; - {$ifdef FPC}inline;{$endif} - -{$ifdef DOUBLETOSHORT_USEGRISU} -const - // special text returned if the double is not a number - C_STR_INF: string[3] = 'Inf'; - C_STR_QNAN: string[3] = 'Nan'; - - // min_width parameter special value, as used internally by FPC for str(d,s) - // - DoubleToAscii() only accept C_NO_MIN_WIDTH or 0 for min_width: space - // trailing has been removed in this cut-down version - C_NO_MIN_WIDTH = -32767; - -/// raw function to convert a 64-bit double into a shortstring, stored in str -// - implements Fabian Loitsch's Grisu algorithm dedicated to double values -// - currently, SynCommnons only set min_width=0 (for DoubleToShortNoExp to avoid -// any scientific notation ) or min_width=C_NO_MIN_WIDTH (for DoubleToShort to -// force the scientific notation when the double cannot be represented as -// a simple fractinal number) -procedure DoubleToAscii(min_width, frac_digits: integer; const v: double; str: PAnsiChar); -{$endif DOUBLETOSHORT_USEGRISU} - -/// convert a 64-bit floating-point value to its JSON text equivalency -// - on Delphi Win32, calls FloatToText() in ffGeneral mode -// - on other platforms, i.e. Delphi Win64 and all FPC targets, will use our own -// faster Fabian Loitsch's Grisu algorithm -// - returns the number as text (stored into tmp variable), or "Infinity", -// "-Infinity", and "NaN" for corresponding IEEE special values -// - result is a PShortString either over tmp, or JSON_NAN[] -function DoubleToJSON(var tmp: ShortString; Value: double; NoExp: boolean): PShortString; - -/// convert a 64-bit floating-point value to its numerical text equivalency -function DoubleToStr(Value: Double): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a 64-bit floating-point value to its numerical text equivalency -procedure DoubleToStr(Value: Double; var result: RawUTF8); overload; - -/// fast retrieve the position of a given character -function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// fast retrieve the position of any value of a given set of characters -// - see also strspn() function which is likely to be faster -function PosCharAny(Str: PUTF8Char; Characters: PAnsiChar): PUTF8Char; - -/// a non case-sensitive RawUTF8 version of Pos() -// - uppersubstr is expected to be already in upper case -// - this version handle only 7 bit ASCII (no accentuated characters) -function PosI(uppersubstr: PUTF8Char; const str: RawUTF8): PtrInt; - -/// a non case-sensitive version of Pos() -// - uppersubstr is expected to be already in upper case -// - this version handle only 7 bit ASCII (no accentuated characters) -function StrPosI(uppersubstr,str: PUTF8Char): PUTF8Char; - -/// a non case-sensitive RawUTF8 version of Pos() -// - substr is expected to be already in upper case -// - this version will decode the UTF-8 content before using NormToUpper[] -function PosIU(substr: PUTF8Char; const str: RawUTF8): Integer; - -/// internal fast integer val to text conversion -// - expect the last available temporary char position in P -// - return the last written char position (write in reverse order in P^) -// - typical use: -// !function Int32ToUTF8(Value: PtrInt): RawUTF8; -// !var tmp: array[0..23] of AnsiChar; -// ! P: PAnsiChar; -// !begin -// ! P := StrInt32(@tmp[23],Value); -// ! SetString(result,P,@tmp[23]-P); -// !end; -// - convert the input value as PtrInt, so as Int64 on 64-bit CPUs -// - not to be called directly: use IntToStr() or Int32ToUTF8() instead -function StrInt32(P: PAnsiChar; val: PtrInt): PAnsiChar; - -/// internal fast unsigned integer val to text conversion -// - expect the last available temporary char position in P -// - return the last written char position (write in reverse order in P^) -// - convert the input value as PtrUInt, so as QWord on 64-bit CPUs -function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar; - -/// internal fast Int64 val to text conversion -// - same calling convention as with StrInt32() above -function StrInt64(P: PAnsiChar; const val: Int64): PAnsiChar; - {$ifdef HASINLINE}inline;{$endif} - -/// internal fast unsigned Int64 val to text conversion -// - same calling convention as with StrInt32() above -function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar; - {$ifdef CPU64}inline;{$endif} - -/// fast add some characters to a RawUTF8 string -// - faster than SetString(tmp,Buffer,BufferLen); Text := Text+tmp; -procedure AppendBufferToRawUTF8(var Text: RawUTF8; Buffer: pointer; BufferLen: PtrInt); - -/// fast add one character to a RawUTF8 string -// - faster than Text := Text + ch; -procedure AppendCharToRawUTF8(var Text: RawUTF8; Ch: AnsiChar); - -/// fast add some characters to a RawUTF8 string -// - faster than Text := Text+RawUTF8(Buffers[0])+RawUTF8(Buffers[0])+... -procedure AppendBuffersToRawUTF8(var Text: RawUTF8; const Buffers: array of PUTF8Char); - -/// fast add some characters from a RawUTF8 string into a given buffer -// - warning: the Buffer should contain enough space to store the Text, otherwise -// you may encounter buffer overflows and random memory errors -function AppendRawUTF8ToBuffer(Buffer: PUTF8Char; const Text: RawUTF8): PUTF8Char; - -/// fast add text conversion of a 32-bit unsigned integer value into a given buffer -// - warning: the Buffer should contain enough space to store the text, otherwise -// you may encounter buffer overflows and random memory errors -function AppendUInt32ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char; - -/// fast add text conversion of 0-999 integer value into a given buffer -// - warning: it won't check that Value is in 0-999 range -// - up to 4 bytes may be written to the buffer (including trailing #0) -function Append999ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// buffer-safe version of StrComp(), to be used with PUTF8Char/PAnsiChar -// - pure pascal StrComp() won't access the memory beyond the string, but this -// function is defined for compatibility with SSE 4.2 expectations -function StrCompFast(Str1, Str2: pointer): PtrInt; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// fastest available version of StrComp(), to be used with PUTF8Char/PAnsiChar -// - won't use SSE4.2 instructions on supported CPUs by default, which may read -// some bytes beyond the s string, so should be avoided e.g. over memory mapped -// files - call explicitely StrCompSSE42() if you are confident on your input -var StrComp: function (Str1, Str2: pointer): PtrInt = StrCompFast; - -/// pure pascal version of strspn(), to be used with PUTF8Char/PAnsiChar -// - please note that this optimized version may read up to 3 bytes beyond -// accept but never after s end, so is safe e.g. over memory mapped files -function strspnpas(s,accept: pointer): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// pure pascal version of strcspn(), to be used with PUTF8Char/PAnsiChar -// - please note that this optimized version may read up to 3 bytes beyond -// reject but never after s end, so is safe e.g. over memory mapped files -function strcspnpas(s,reject: pointer): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// fastest available version of strspn(), to be used with PUTF8Char/PAnsiChar -// - returns size of initial segment of s which appears in accept chars, e.g. -// ! strspn('abcdef','debca')=5 -// - won't use SSE4.2 instructions on supported CPUs by default, which may read -// some bytes beyond the s string, so should be avoided e.g. over memory mapped -// files - call explicitely strspnsse42() if you are confident on your input -var strspn: function (s,accept: pointer): integer = strspnpas; - -/// fastest available version of strcspn(), to be used with PUTF8Char/PAnsiChar -// - returns size of initial segment of s which doesn't appears in reject chars, e.g. -// ! strcspn('1234,6789',',')=4 -// - won't use SSE4.2 instructions on supported CPUs by default, which may read -// some bytes beyond the s string, so should be avoided e.g. over memory mapped -// files - call explicitely strcspnsse42() if you are confident on your input -var strcspn: function (s,reject: pointer): integer = strcspnpas; - -{$ifdef CPUINTEL} -{$ifndef ABSOLUTEPASCAL} -{$ifdef HASAESNI} -/// SSE 4.2 version of StrComp(), to be used with PUTF8Char/PAnsiChar -// - please note that this optimized version may read up to 15 bytes -// beyond the string; this is rarely a problem but it may generate protection -// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system -// - could be used instead of StrComp() when you are confident about your -// Str1/Str2 input buffers, checking if cfSSE42 in CpuFeatures -function StrCompSSE42(Str1, Str2: pointer): PtrInt; - -// - please note that this optimized version may read up to 15 bytes -// beyond the string; this is rarely a problem but it may generate protection -// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system -// - could be used instead of StrLen() when you are confident about your -// S input buffers, checking if cfSSE42 in CpuFeatures -function StrLenSSE42(S: pointer): PtrInt; -{$endif HASAESNI} - -/// SSE 4.2 version of strspn(), to be used with PUTF8Char/PAnsiChar -// - please note that this optimized version may read up to 15 bytes -// beyond the string; this is rarely a problem but it may generate protection -// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system -// - could be used instead of strspn() when you are confident about your -// s/accept input buffers, checking if cfSSE42 in CpuFeatures -function strspnsse42(s,accept: pointer): integer; - -/// SSE 4.2 version of strcspn(), to be used with PUTF8Char/PAnsiChar -// - please note that this optimized version may read up to 15 bytes -// beyond the string; this is rarely a problem but it may generate protection -// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system -// - could be used instead of strcspn() when you are confident about your -// s/reject input buffers, checking if cfSSE42 in CpuFeatures -function strcspnsse42(s,reject: pointer): integer; - -/// SSE 4.2 version of GetBitsCountPtrInt() -// - defined just for regression tests - call GetBitsCountPtrInt() instead -function GetBitsCountSSE42(value: PtrInt): PtrInt; -{$endif ABSOLUTEPASCAL} -{$endif CPUINTEL} - -/// use our fast version of StrIComp(), to be used with PUTF8Char/PAnsiChar -function StrIComp(Str1, Str2: pointer): PtrInt; - {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} - -/// slower version of StrLen(), but which will never read beyond the string -// - this version won't access the memory beyond the string, so may be -// preferred to StrLen(), when using e.g. memory mapped files or any memory -// protected buffer -function StrLenPas(S: pointer): PtrInt; - -/// our fast version of StrLen(), to be used with PUTF8Char/PAnsiChar -// - if available, a fast SSE2 asm will be used on Intel/AMD CPUs -// - won't use SSE4.2 instructions on supported CPUs by default, which may read -// some bytes beyond the string, so should be avoided e.g. over memory mapped -// files - call explicitely StrLenSSE42() if you are confident on your input -var StrLen: function(S: pointer): PtrInt = StrLenPas; - -{$ifdef ABSOLUTEPASCAL} -var FillcharFast: procedure(var Dest; count: PtrInt; Value: byte) = system.FillChar; -var MoveFast: procedure(const Source; var Dest; Count: PtrInt) = system.Move; -{$else} -{$ifdef CPUX64} // will define its own self-dispatched SSE2/AVX functions -type - /// cpuERMS is slightly slower than cpuAVX so is not available by default - TX64CpuFeatures = set of(cpuAVX, cpuAVX2 {$ifdef WITH_ERMS}, cpuERMS{$endif}); -var - /// internal flags used by FillCharFast - easier from asm that CpuFeatures - CPUIDX64: TX64CpuFeatures; -procedure FillcharFast(var dst; cnt: PtrInt; value: byte); -procedure MoveFast(const src; var dst; cnt: PtrInt); -{$else} - -/// our fast version of FillChar() -// - on Intel i386/x86_64, will use fast SSE2/ERMS instructions (if available), -// or optimized X87 assembly implementation for older CPUs -// - on non-Intel CPUs, it will fallback to the default RTL FillChar() -// - note: Delphi x86_64 is far from efficient: even ERMS was wrongly -// introduced in latest updates -var FillcharFast: procedure(var Dest; count: PtrInt; Value: byte); - -/// our fast version of move() -// - on Delphi Intel i386/x86_64, will use fast SSE2 instructions (if available), -// or optimized X87 assembly implementation for older CPUs -// - on non-Intel CPUs, it will fallback to the default RTL Move() -var MoveFast: procedure(const Source; var Dest; Count: PtrInt); - -{$endif CPUX64} -{$endif ABSOLUTEPASCAL} - -/// an alternative Move() function tuned for small unaligned counts -// - warning: expects Count>0 and Source/Dest not nil -// - warning: doesn't support buffers overlapping -procedure MoveSmall(Source, Dest: Pointer; Count: PtrUInt); - {$ifdef HASINLINE}inline;{$endif} - -/// our fast version of StrLen(), to be used with PWideChar -function StrLenW(S: PWideChar): PtrInt; - -/// use our fast version of StrComp(), to be used with PWideChar -function StrCompW(Str1, Str2: PWideChar): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// use our fast version of StrCompL(), to be used with PUTF8Char -function StrCompL(P1,P2: PUTF8Char; L, Default: Integer): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// use our fast version of StrCompIL(), to be used with PUTF8Char -function StrCompIL(P1,P2: PUTF8Char; L: Integer; Default: Integer=0): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -{$ifdef USENORMTOUPPER} -{$ifdef OWNNORMTOUPPER} -type - TNormTable = packed array[AnsiChar] of AnsiChar; - PNormTable = ^TNormTable; - TNormTableByte = packed array[byte] of byte; - PNormTableByte = ^TNormTableByte; - -var - /// the NormToUpper[] array is defined in our Enhanced RTL: define it now - // if it was not installed - // - handle 8 bit upper chars as in WinAnsi / code page 1252 (e.g. accents) - NormToUpper: TNormTable; - NormToUpperByte: TNormTableByte absolute NormToUpper; - - /// the NormToLower[] array is defined in our Enhanced RTL: define it now - // if it was not installed - // - handle 8 bit upper chars as in WinAnsi / code page 1252 (e.g. accents) - NormToLower: TNormTable; - NormToLowerByte: TNormTableByte absolute NormToLower; -{$endif} -{$else} -{$undef OWNNORMTOUPPER} -{$endif} - -var - /// this table will convert 'a'..'z' into 'A'..'Z' - // - so it will work with UTF-8 without decoding, whereas NormToUpper[] expects - // WinAnsi encoding - NormToUpperAnsi7: TNormTable; - NormToUpperAnsi7Byte: TNormTableByte absolute NormToUpperAnsi7; - /// case sensitive NormToUpper[]/NormToLower[]-like table - // - i.e. NormToNorm[c] = c - NormToNorm: TNormTable; - NormToNormByte: TNormTableByte absolute NormToNorm; - - -/// get the signed 32-bit integer value stored in P^ -// - we use the PtrInt result type, even if expected to be 32-bit, to use -// native CPU register size (don't want any 32-bit overflow here) -// - will end parsing when P^ does not contain any number (e.g. it reaches any -// ending #0 char) -function GetInteger(P: PUTF8Char): PtrInt; overload; - -/// get the signed 32-bit integer value stored in P^..PEnd^ -// - will end parsing when P^ does not contain any number (e.g. it reaches any -// ending #0 char), or when P reached PEnd (avoiding any buffer overflow) -function GetInteger(P,PEnd: PUTF8Char): PtrInt; overload; - -/// get the signed 32-bit integer value stored in P^ -// - if P if nil or not start with a valid numerical value, returns Default -function GetIntegerDef(P: PUTF8Char; Default: PtrInt): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// get the signed 32-bit integer value stored in P^ -// - this version return 0 in err if no error occured, and 1 if an invalid -// character was found, not its exact index as for the val() function -function GetInteger(P: PUTF8Char; var err: integer): PtrInt; overload; - -/// get the unsigned 32-bit integer value stored in P^ -// - we use the PtrUInt result type, even if expected to be 32-bit, to use -// native CPU register size (don't want any 32-bit overflow here) -function GetCardinal(P: PUTF8Char): PtrUInt; - -/// get the unsigned 32-bit integer value stored in P^ -// - if P if nil or not start with a valid numerical value, returns Default -function GetCardinalDef(P: PUTF8Char; Default: PtrUInt): PtrUInt; - -/// get the unsigned 32-bit integer value stored as Unicode string in P^ -function GetCardinalW(P: PWideChar): PtrUInt; - -/// get a boolean value stored as true/false text in P^ -// - would also recognize any non 0 integer as true -function GetBoolean(P: PUTF8Char): boolean; - -/// get the 64-bit integer value stored in P^ -function GetInt64(P: PUTF8Char): Int64; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// get the 64-bit integer value stored in P^ -// - if P if nil or not start with a valid numerical value, returns Default -function GetInt64Def(P: PUTF8Char; const Default: Int64): Int64; - -/// get the 64-bit signed integer value stored in P^ -procedure SetInt64(P: PUTF8Char; var result: Int64); - {$ifdef CPU64}inline;{$endif} - -/// get the 64-bit unsigned integer value stored in P^ -procedure SetQWord(P: PUTF8Char; var result: QWord); - {$ifdef CPU64}inline;{$endif} - -/// get the 64-bit signed integer value stored in P^ -// - set the err content to the index of any faulty character, 0 if conversion -// was successful (same as the standard val function) -function GetInt64(P: PUTF8Char; var err: integer): Int64; overload; - {$ifdef CPU64}inline;{$endif} - -/// get the 64-bit unsigned integer value stored in P^ -// - set the err content to the index of any faulty character, 0 if conversion -// was successful (same as the standard val function) -function GetQWord(P: PUTF8Char; var err: integer): QWord; - -/// get the extended floating point value stored in P^ -// - set the err content to the index of any faulty character, 0 if conversion -// was successful (same as the standard val function) -function GetExtended(P: PUTF8Char; out err: integer): TSynExtended; overload; - -/// get the extended floating point value stored in P^ -// - this overloaded version returns 0 as a result if the content of P is invalid -function GetExtended(P: PUTF8Char): TSynExtended; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// copy a floating-point text buffer with proper correction and validation -// - will correct on the fly '.5' -> '0.5' and '-.5' -> '-0.5' -// - will end not only on #0 but on any char not matching 1[.2[e[-]3]] pattern -// - is used when the input comes from a third-party source with no regular -// output, e.g. a database driver, via TTextWriter.AddFloatStr -function FloatStrCopy(s, d: PUTF8Char): PUTF8Char; - -/// get the WideChar stored in P^ (decode UTF-8 if necessary) -// - any surrogate (UCS4>$ffff) will be returned as '?' -function GetUTF8Char(P: PUTF8Char): cardinal; - {$ifdef HASINLINE}inline;{$endif} - -/// get the UCS4 char stored in P^ (decode UTF-8 if necessary) -function NextUTF8UCS4(var P: PUTF8Char): cardinal; - {$ifdef HASINLINE}inline;{$endif} - -/// get the signed 32-bit integer value stored in a RawUTF8 string -// - we use the PtrInt result type, even if expected to be 32-bit, to use -// native CPU register size (don't want any 32-bit overflow here) -function UTF8ToInteger(const value: RawUTF8; Default: PtrInt=0): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// get and check range of a signed 32-bit integer stored in a RawUTF8 string -// - we use the PtrInt result type, even if expected to be 32-bit, to use -// native CPU register size (don't want any 32-bit overflow here) -function UTF8ToInteger(const value: RawUTF8; Min,max: PtrInt; Default: PtrInt=0): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// get the signed 32-bit integer value stored in a RawUTF8 string -// - returns TRUE if the supplied text was successfully converted into an integer -function ToInteger(const text: RawUTF8; out value: integer): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// get the unsigned 32-bit cardinal value stored in a RawUTF8 string -// - returns TRUE if the supplied text was successfully converted into a cardinal -function ToCardinal(const text: RawUTF8; out value: cardinal; minimal: cardinal=0): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// get the signed 64-bit integer value stored in a RawUTF8 string -// - returns TRUE if the supplied text was successfully converted into an Int64 -function ToInt64(const text: RawUTF8; out value: Int64): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// get a 64-bit floating-point value stored in a RawUTF8 string -// - returns TRUE if the supplied text was successfully converted into a double -function ToDouble(const text: RawUTF8; out value: double): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// get the signed 64-bit integer value stored in a RawUTF8 string -// - returns the default value if the supplied text was not successfully -// converted into an Int64 -function UTF8ToInt64(const text: RawUTF8; const default: Int64=0): Int64; - -/// encode a string to be compatible with URI encoding -function UrlEncode(const svar: RawUTF8): RawUTF8; overload; - -/// encode a string to be compatible with URI encoding -function UrlEncode(Text: PUTF8Char): RawUTF8; overload; - -/// encode supplied parameters to be compatible with URI encoding -// - parameters must be supplied two by two, as Name,Value pairs, e.g. -// ! url := UrlEncode(['select','*','where','ID=12','offset',23,'object',aObject]); -// - parameters names should be plain ASCII-7 RFC compatible identifiers -// (0..9a..zA..Z_.~), otherwise their values are skipped -// - parameters values can be either textual, integer or extended, or any TObject -// - TObject serialization into UTF-8 will be processed by the ObjectToJSON() -// function -function UrlEncode(const NameValuePairs: array of const): RawUTF8; overload; - -/// encode a JSON object UTF-8 buffer into URI parameters -// - you can specify property names to ignore during the object decoding -// - you can omit the leading query delimiter ('?') by setting IncludeQueryDelimiter=false -// - warning: the ParametersJSON input buffer will be modified in-place -function UrlEncodeJsonObject(const URIName: RawUTF8; ParametersJSON: PUTF8Char; - const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean=true): RawUTF8; overload; - -/// encode a JSON object UTF-8 buffer into URI parameters -// - you can specify property names to ignore during the object decoding -// - you can omit the leading query delimiter ('?') by setting IncludeQueryDelimiter=false -// - overloaded function which will make a copy of the input JSON before parsing -function UrlEncodeJsonObject(const URIName, ParametersJSON: RawUTF8; - const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean=true): RawUTF8; overload; - -/// decode a string compatible with URI encoding into its original value -// - you can specify the decoding range (as in copy(s,i,len) function) -function UrlDecode(const s: RawUTF8; i: PtrInt=1; len: PtrInt=-1): RawUTF8; overload; - -/// decode a string compatible with URI encoding into its original value -function UrlDecode(U: PUTF8Char): RawUTF8; overload; - -/// decode a specified parameter compatible with URI encoding into its original -// textual value -// - UrlDecodeValue('select=%2A&where=LastName%3D%27M%C3%B4net%27','SELECT=',V,@Next) -// will return Next^='where=...' and V='*' -// - if Upper is not found, Value is not modified, and result is FALSE -// - if Upper is found, Value is modified with the supplied content, and result is TRUE -function UrlDecodeValue(U: PUTF8Char; const Upper: RawUTF8; var Value: RawUTF8; - Next: PPUTF8Char=nil): boolean; - -/// decode a specified parameter compatible with URI encoding into its original -// integer numerical value -// - UrlDecodeInteger('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) -// will return Next^='where=...' and O=20 -// - if Upper is not found, Value is not modified, and result is FALSE -// - if Upper is found, Value is modified with the supplied content, and result is TRUE -function UrlDecodeInteger(U: PUTF8Char; const Upper: RawUTF8; var Value: integer; - Next: PPUTF8Char=nil): boolean; - -/// decode a specified parameter compatible with URI encoding into its original -// cardinal numerical value -// - UrlDecodeCardinal('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) -// will return Next^='where=...' and O=20 -// - if Upper is not found, Value is not modified, and result is FALSE -// - if Upper is found, Value is modified with the supplied content, and result is TRUE -function UrlDecodeCardinal(U: PUTF8Char; const Upper: RawUTF8; var Value: Cardinal; - Next: PPUTF8Char=nil): boolean; - -/// decode a specified parameter compatible with URI encoding into its original -// Int64 numerical value -// - UrlDecodeInt64('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) -// will return Next^='where=...' and O=20 -// - if Upper is not found, Value is not modified, and result is FALSE -// - if Upper is found, Value is modified with the supplied content, and result is TRUE -function UrlDecodeInt64(U: PUTF8Char; const Upper: RawUTF8; var Value: Int64; - Next: PPUTF8Char=nil): boolean; - -/// decode a specified parameter compatible with URI encoding into its original -// floating-point value -// - UrlDecodeExtended('price=20.45&where=LastName%3D%27M%C3%B4net%27','PRICE=',P,@Next) -// will return Next^='where=...' and P=20.45 -// - if Upper is not found, Value is not modified, and result is FALSE -// - if Upper is found, Value is modified with the supplied content, and result is TRUE -function UrlDecodeExtended(U: PUTF8Char; const Upper: RawUTF8; var Value: TSynExtended; - Next: PPUTF8Char=nil): boolean; - -/// decode a specified parameter compatible with URI encoding into its original -// floating-point value -// - UrlDecodeDouble('price=20.45&where=LastName%3D%27M%C3%B4net%27','PRICE=',P,@Next) -// will return Next^='where=...' and P=20.45 -// - if Upper is not found, Value is not modified, and result is FALSE -// - if Upper is found, Value is modified with the supplied content, and result is TRUE -function UrlDecodeDouble(U: PUTF8Char; const Upper: RawUTF8; var Value: double; - Next: PPUTF8Char=nil): boolean; - -/// returns TRUE if all supplied parameters do exist in the URI encoded text -// - CSVNames parameter shall provide as a CSV list of names -// - e.g. UrlDecodeNeedParameters('price=20.45&where=LastName%3D','price,where') -// will return TRUE -function UrlDecodeNeedParameters(U, CSVNames: PUTF8Char): boolean; - -/// decode the next Name=Value&.... pair from input URI -// - Name is returned directly (should be plain ASCII 7 bit text) -// - Value is returned after URI decoding (from %.. patterns) -// - if a pair is decoded, return a PUTF8Char pointer to the next pair in -// the input buffer, or points to #0 if all content has been processed -// - if a pair is not decoded, return nil -function UrlDecodeNextNameValue(U: PUTF8Char; var Name,Value: RawUTF8): PUTF8Char; - -/// decode a URI-encoded Value from an input buffer -// - decoded value is set in Value out variable -// - returns a pointer just after the decoded value (may points e.g. to -// #0 or '&') - it is up to the caller to continue the process or not -function UrlDecodeNextValue(U: PUTF8Char; out Value: RawUTF8): PUTF8Char; - -/// decode a URI-encoded Name from an input buffer -// - decoded value is set in Name out variable -// - returns a pointer just after the decoded name, after the '=' -// - returns nil if there was no name=... pattern in U -function UrlDecodeNextName(U: PUTF8Char; out Name: RawUTF8): PUTF8Char; - -/// checks if the supplied UTF-8 text don't need URI encoding -// - returns TRUE if all its chars are non-void plain ASCII-7 RFC compatible -// identifiers (0..9a..zA..Z-_.~) -function IsUrlValid(P: PUTF8Char): boolean; - -/// checks if the supplied UTF-8 text values don't need URI encoding -// - returns TRUE if all its chars of all strings are non-void plain ASCII-7 RFC -// compatible identifiers (0..9a..zA..Z-_.~) -function AreUrlValid(const Url: array of RawUTF8): boolean; - -/// ensure the supplied URI contains a trailing '/' charater -function IncludeTrailingURIDelimiter(const URI: RawByteString): RawByteString; - -/// encode name/value pairs into CSV/INI raw format -function CSVEncode(const NameValuePairs: array of const; - const KeySeparator: RawUTF8='='; const ValueSeparator: RawUTF8=#13#10): RawUTF8; - -/// find a given name in name/value pairs, and returns the value as RawUTF8 -function ArrayOfConstValueAsText(const NameValuePairs: array of const; - const aName: RawUTF8): RawUTF8; - -/// returns TRUE if the given text buffer contains a..z,A..Z,0..9,_ characters -// - should match most usual property names values or other identifier names -// in the business logic source code -// - i.e. can be tested via IdemPropName*() functions, and the MongoDB-like -// extended JSON syntax as generated by dvoSerializeAsExtendedJson -// - first char must be alphabetical or '_', following chars can be -// alphanumerical or '_' -function PropNameValid(P: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if the given text buffers contains A..Z,0..9,_ characters -// - use it with property names values (i.e. only including A..Z,0..9,_ chars) -// - this function won't check the first char the same way than PropNameValid() -function PropNamesValid(const Values: array of RawUTF8): boolean; - -type - /// kind of character used from JSON_CHARS[] for efficient JSON parsing - TJsonChar = set of (jcJsonIdentifierFirstChar, jcJsonIdentifier, - jcEndOfJSONField, jcEndOfJSONFieldOr0, jcEndOfJSONValueField, - jcDigitChar, jcDigitFirstChar, jcDigitFloatChar); - /// defines a branch-less table used for JSON parsing - TJsonCharSet = array[AnsiChar] of TJsonChar; - PJsonCharSet = ^TJsonCharSet; -var - /// branch-less table used for JSON parsing - JSON_CHARS: TJsonCharSet; - -/// returns TRUE if the given text buffer contains simple characters as -// recognized by JSON extended syntax -// - follow GetJSONPropName and GotoNextJSONObjectOrArray expectations -function JsonPropNameValid(P: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if the given text buffers would be escaped when written as JSON -// - e.g. if contains " or \ characters, as defined by -// http://www.ietf.org/rfc/rfc4627.txt -function NeedsJsonEscape(const Text: RawUTF8): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if the given text buffers would be escaped when written as JSON -// - e.g. if contains " or \ characters, as defined by -// http://www.ietf.org/rfc/rfc4627.txt -function NeedsJsonEscape(P: PUTF8Char): boolean; overload; - -/// returns TRUE if the given text buffers would be escaped when written as JSON -// - e.g. if contains " or \ characters, as defined by -// http://www.ietf.org/rfc/rfc4627.txt -function NeedsJsonEscape(P: PUTF8Char; PLen: integer): boolean; overload; - -/// case insensitive comparison of ASCII identifiers -// - use it with property names values (i.e. only including A..Z,0..9,_ chars) -function IdemPropName(const P1,P2: shortstring): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// case insensitive comparison of ASCII identifiers -// - use it with property names values (i.e. only including A..Z,0..9,_ chars) -// - this version expects P2 to be a PAnsiChar with a specified length -function IdemPropName(const P1: shortstring; P2: PUTF8Char; P2Len: PtrInt): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// case insensitive comparison of ASCII identifiers -// - use it with property names values (i.e. only including A..Z,0..9,_ chars) -// - this version expects P1 and P2 to be a PAnsiChar with specified lengths -function IdemPropName(P1,P2: PUTF8Char; P1Len,P2Len: PtrInt): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// case insensitive comparison of ASCII identifiers -// - use it with property names values (i.e. only including A..Z,0..9,_ chars) -// - this version expects P2 to be a PAnsiChar with specified length -function IdemPropNameU(const P1: RawUTF8; P2: PUTF8Char; P2Len: PtrInt): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// case insensitive comparison of ASCII identifiers of same length -// - use it with property names values (i.e. only including A..Z,0..9,_ chars) -// - this version expects P1 and P2 to be a PAnsiChar with an already checked -// identical length, so may be used for a faster process, e.g. in a loop -// - if P1 and P2 are RawUTF8, you should better call overloaded function -// IdemPropNameU(const P1,P2: RawUTF8), which would be slightly faster by -// using the length stored before the actual text buffer of each RawUTF8 -function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: PtrInt): boolean; - {$ifndef ANDROID}{$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif}{$endif} - -/// case insensitive comparison of ASCII identifiers -// - use it with property names values (i.e. only including A..Z,0..9,_ chars) -function IdemPropNameU(const P1,P2: RawUTF8): boolean; overload; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// returns true if the beginning of p^ is the same as up^ -// - ignore case - up^ must be already Upper -// - chars are compared as 7 bit Ansi only (no accentuated characters): but when -// you only need to search for field names e.g. IdemPChar() is prefered, because -// it'll be faster than IdemPCharU(), if UTF-8 decoding is not mandatory -// - if p is nil, will return FALSE -// - if up is nil, will return TRUE -function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// returns true if the beginning of p^ is the same as up^, ignoring white spaces -// - ignore case - up^ must be already Upper -// - any white space in the input p^ buffer is just ignored -// - chars are compared as 7 bit Ansi only (no accentuated characters): but when -// you only need to search for field names e.g. IdemPChar() is prefered, because -// it'll be faster than IdemPCharU(), if UTF-8 decoding is not mandatory -// - if p is nil, will return FALSE -// - if up is nil, will return TRUE -function IdemPCharWithoutWhiteSpace(p: PUTF8Char; up: PAnsiChar): boolean; - -/// returns the index of a matching beginning of p^ in upArray[] -// - returns -1 if no item matched -// - ignore case - upArray^ must be already Upper -// - chars are compared as 7 bit Ansi only (no accentuated characters) -// - warning: this function expects upArray[] items to have AT LEAST TWO -// CHARS (it will use a fast comparison of initial 2 bytes) -function IdemPCharArray(p: PUTF8Char; const upArray: array of PAnsiChar): integer; overload; - -/// returns the index of a matching beginning of p^ in upArray two characters -// - returns -1 if no item matched -// - ignore case - upArray^ must be already Upper -// - chars are compared as 7 bit Ansi only (no accentuated characters) -function IdemPCharArray(p: PUTF8Char; const upArrayBy2Chars: RawUTF8): integer; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns true if the beginning of p^ is the same as up^ -// - ignore case - up^ must be already Upper -// - this version will decode the UTF-8 content before using NormToUpper[], so -// it will be slower than the IdemPChar() function above, but will handle -// WinAnsi accentuated characters (e.g. 'e' acute will be matched as 'E') -function IdemPCharU(p, up: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// returns true if the beginning of p^ is same as up^ -// - ignore case - up^ must be already Upper -// - this version expects p^ to point to an Unicode char array -function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; - -/// check matching ending of p^ in upText -// - returns true if the item matched -// - ignore case - upText^ must be already Upper -// - chars are compared as 7 bit Ansi only (no accentuated characters) -function EndWith(const text, upText: RawUTF8): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// returns the index of a matching ending of p^ in upArray[] -// - returns -1 if no item matched -// - ignore case - upArray^ must be already Upper -// - chars are compared as 7 bit Ansi only (no accentuated characters) -function EndWithArray(const text: RawUTF8; const upArray: array of RawUTF8): integer; - -/// returns true if the file name extension contained in p^ is the same same as extup^ -// - ignore case - extup^ must be already Upper -// - chars are compared as WinAnsi (codepage 1252), not as UTF-8 -// - could be used e.g. like IdemFileExt(aFileName,'.JP'); -function IdemFileExt(p: PUTF8Char; extup: PAnsiChar; sepChar: AnsiChar='.'): Boolean; - -/// returns matching file name extension index as extup^ -// - ignore case - extup[] must be already Upper -// - chars are compared as WinAnsi (codepage 1252), not as UTF-8 -// - could be used e.g. like IdemFileExts(aFileName,['.PAS','.INC']); -function IdemFileExts(p: PUTF8Char; const extup: array of PAnsiChar; - sepChar: AnsiChar='.'): integer; - -/// internal function, used to retrieve a UCS4 char (>127) from UTF-8 -// - not to be called directly, but from inlined higher-level functions -// - here U^ shall be always >= #80 -// - typical use is as such: -// ! ch := ord(P^); -// ! if ch and $80=0 then -// ! inc(P) else -// ! ch := GetHighUTF8UCS4(P); -function GetHighUTF8UCS4(var U: PUTF8Char): PtrUInt; - -/// retrieve the next UCS4 value stored in U, then update the U pointer -// - this function will decode the UTF-8 content before using NormToUpper[] -// - will return '?' if the UCS4 value is higher than #255: so use this function -// only if you need to deal with ASCII characters (e.g. it's used for Soundex -// and for ContainsUTF8 function) -function GetNextUTF8Upper(var U: PUTF8Char): PtrUInt; - {$ifdef HASINLINE}inline;{$endif} - -/// points to the beginning of the next word stored in U -// - returns nil if reached the end of U (i.e. #0 char) -// - here a "word" is a Win-Ansi word, i.e. '0'..'9', 'A'..'Z' -function FindNextUTF8WordBegin(U: PUTF8Char): PUTF8Char; - -/// return true if up^ is contained inside the UTF-8 buffer p^ -// - search up^ at the beginning of every UTF-8 word (aka in Soundex) -// - here a "word" is a Win-Ansi word, i.e. '0'..'9', 'A'..'Z' -// - up^ must be already Upper -function ContainsUTF8(p, up: PUTF8Char): boolean; - -/// returns TRUE if the supplied uppercased text is contained in the text buffer -function GetLineContains(p,pEnd, up: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// copy source into a 256 chars dest^ buffer with 7 bits upper case conversion -// - used internally for short keys match or case-insensitive hash -// - returns final dest pointer -// - will copy up to 255 AnsiChar (expect the dest buffer to be defined e.g. as -// array[byte] of AnsiChar on the caller stack) -function UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// copy source^ into a 256 chars dest^ buffer with 7 bits upper case conversion -// - used internally for short keys match or case-insensitive hash -// - returns final dest pointer -// - will copy up to 255 AnsiChar (expect the dest buffer to be defined e.g. as -// array[byte] of AnsiChar on the caller stack) -// - won't use SSE4.2 instructions on supported CPUs by default, which may read -// some bytes beyond the s string, so should be avoided e.g. over memory mapped -// files - call explicitely UpperCopy255BufSSE42() if you are confident on your input -var UpperCopy255Buf: function(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; - -/// copy source^ into a 256 chars dest^ buffer with 7 bits upper case conversion -// - used internally for short keys match or case-insensitive hash -// - this version is written in optimized pascal -// - you should not have to call this function, but rely on UpperCopy255Buf() -// - returns final dest pointer -// - will copy up to 255 AnsiChar (expect the dest buffer to be defined e.g. as -// array[byte] of AnsiChar on the caller stack) -function UpperCopy255BufPas(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; - -{$ifndef PUREPASCAL} -{$ifndef DELPHI5OROLDER} -/// SSE 4.2 version of UpperCopy255Buf() -// - copy source^ into a 256 chars dest^ buffer with 7 bits upper case conversion -// - please note that this optimized version may read up to 15 bytes -// beyond the string; this is rarely a problem but it may generate protection -// violations, which could trigger fatal SIGABRT or SIGSEGV on Posix system -// - could be used instead of UpperCopy255Buf() when you are confident about your -// dest/source input buffers, checking if cfSSE42 in CpuFeatures -function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; -{$endif DELPHI5OROLDER} -{$endif PUREPASCAL} - -/// copy source into dest^ with WinAnsi 8 bits upper case conversion -// - used internally for short keys match or case-insensitive hash -// - returns final dest pointer -// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of -// AnsiChar) -function UpperCopyWin255(dest: PWinAnsiChar; const source: RawUTF8): PWinAnsiChar; - -/// copy WideChar source into dest^ with upper case conversion -// - used internally for short keys match or case-insensitive hash -// - returns final dest pointer -// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of -// AnsiChar) -function UpperCopy255W(dest: PAnsiChar; const source: SynUnicode): PAnsiChar; overload; - -/// copy WideChar source into dest^ with upper case conversion -// - used internally for short keys match or case-insensitive hash -// - returns final dest pointer -// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of -// AnsiChar) -function UpperCopy255W(dest: PAnsiChar; source: PWideChar; L: integer): PAnsiChar; overload; - -/// copy source into dest^ with 7 bits upper case conversion -// - returns final dest pointer -// - will copy up to the source buffer end: so Dest^ should be big enough - -// which will the case e.g. if Dest := pointer(source) -function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; - -/// copy source into dest^ with 7 bits upper case conversion -// - returns final dest pointer -// - this special version expect source to be a shortstring -function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar; - -{$ifdef USENORMTOUPPER} - -/// fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values -// - this version expects u1 and u2 to be zero-terminated -// - this version will decode each UTF-8 glyph before using NormToUpper[] -// - current implementation handles UTF-16 surrogates -function UTF8IComp(u1, u2: PUTF8Char): PtrInt; - -/// copy WideChar source into dest^ with upper case conversion, using the -// NormToUpper[] array for all 8 bits values, encoding the result as UTF-8 -// - returns final dest pointer -// - current implementation handles UTF-16 surrogates -function UTF8UpperCopy(Dest, Source: PUTF8Char; SourceChars: Cardinal): PUTF8Char; - -/// copy WideChar source into dest^ with upper case conversion, using the -// NormToUpper[] array for all 8 bits values, encoding the result as UTF-8 -// - returns final dest pointer -// - will copy up to 255 AnsiChar (expect the dest buffer to be array[byte] of -// AnsiChar), with UTF-8 encoding -function UTF8UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values -// - this version expects u1 and u2 not to be necessary zero-terminated, but -// uses L1 and L2 as length for u1 and u2 respectively -// - use this function for SQLite3 collation (TSQLCollateFunc) -// - this version will decode the UTF-8 content before using NormToUpper[] -// - current implementation handles UTF-16 surrogates -function UTF8ILComp(u1, u2: PUTF8Char; L1,L2: cardinal): PtrInt; - -/// fast case-insensitive Unicode comparison -// - use the NormToUpperAnsi7Byte[] array, i.e. compare 'a'..'z' as 'A'..'Z' -// - this version expects u1 and u2 to be zero-terminated -function AnsiICompW(u1, u2: PWideChar): PtrInt; - -/// SameText() overloaded function with proper UTF-8 decoding -// - fast version using NormToUpper[] array for all Win-Ansi characters -// - this version will decode each UTF-8 glyph before using NormToUpper[] -// - current implementation handles UTF-16 surrogates as UTF8IComp() -function SameTextU(const S1, S2: RawUTF8): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion of the supplied text into 8 bit uppercase -// - this will not only convert 'a'..'z' into 'A'..'Z', but also accentuated -// latin characters ('e' acute into 'E' e.g.), using NormToUpper[] array -// - it will therefore decode the supplied UTF-8 content to handle more than -// 7 bit of ascii characters (so this function is dedicated to WinAnsi code page -// 1252 characters set) -function UpperCaseU(const S: RawUTF8): RawUTF8; - -/// fast conversion of the supplied text into 8 bit lowercase -// - this will not only convert 'A'..'Z' into 'a'..'z', but also accentuated -// latin characters ('E' acute into 'e' e.g.), using NormToLower[] array -// - it will therefore decode the supplied UTF-8 content to handle more than -// 7 bit of ascii characters -function LowerCaseU(const S: RawUTF8): RawUTF8; - -/// fast conversion of the supplied text into 8 bit case sensitivity -// - convert the text in-place, returns the resulting length -// - it will decode the supplied UTF-8 content to handle more than 7 bit -// of ascii characters during the conversion (leaving not WinAnsi characters -// untouched) -// - will not set the last char to #0 (caller must do that if necessary) -function ConvertCaseUTF8(P: PUTF8Char; const Table: TNormTableByte): PtrInt; - -{$endif USENORMTOUPPER} - -/// check if the supplied text has some case-insentitive 'a'..'z','A'..'Z' chars -// - will therefore be correct with true UTF-8 content, but only for 7 bit -function IsCaseSensitive(const S: RawUTF8): boolean; overload; - -/// check if the supplied text has some case-insentitive 'a'..'z','A'..'Z' chars -// - will therefore be correct with true UTF-8 content, but only for 7 bit -function IsCaseSensitive(P: PUTF8Char; PLen: PtrInt): boolean; overload; - -/// fast conversion of the supplied text into uppercase -// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and -// will therefore be correct with true UTF-8 content, but only for 7 bit -function UpperCase(const S: RawUTF8): RawUTF8; - -/// fast conversion of the supplied text into uppercase -// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and -// will therefore be correct with true UTF-8 content, but only for 7 bit -procedure UpperCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8); overload; - -/// fast conversion of the supplied text into uppercase -// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and -// will therefore be correct with true UTF-8 content, but only for 7 bit -procedure UpperCaseCopy(const Source: RawUTF8; var Dest: RawUTF8); overload; - -/// fast in-place conversion of the supplied variable text into uppercase -// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and -// will therefore be correct with true UTF-8 content, but only for 7 bit -procedure UpperCaseSelf(var S: RawUTF8); - -/// fast conversion of the supplied text into lowercase -// - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and -// will therefore be correct with true UTF-8 content -function LowerCase(const S: RawUTF8): RawUTF8; - -/// fast conversion of the supplied text into lowercase -// - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and -// will therefore be correct with true UTF-8 content -procedure LowerCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8); - -/// fast in-place conversion of the supplied variable text into lowercase -// - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and -// will therefore be correct with true UTF-8 content, but only for 7 bit -procedure LowerCaseSelf(var S: RawUTF8); - -/// accurate conversion of the supplied UTF-8 content into the corresponding -// upper-case Unicode characters -// - this version will use the Operating System API, and will therefore be -// much slower than UpperCase/UpperCaseU versions, but will handle all -// kind of unicode characters -function UpperCaseUnicode(const S: RawUTF8): RawUTF8; - -/// accurate conversion of the supplied UTF-8 content into the corresponding -// lower-case Unicode characters -// - this version will use the Operating System API, and will therefore be -// much slower than LowerCase/LowerCaseU versions, but will handle all -// kind of unicode characters -function LowerCaseUnicode(const S: RawUTF8): RawUTF8; - -/// trims leading whitespace characters from the string by removing -// new line, space, and tab characters -function TrimLeft(const S: RawUTF8): RawUTF8; - -/// trims trailing whitespace characters from the string by removing trailing -// newline, space, and tab characters -function TrimRight(const S: RawUTF8): RawUTF8; - -/// single-allocation (therefore faster) alternative to Trim(copy()) -procedure TrimCopy(const S: RawUTF8; start,count: PtrInt; - var result: RawUTF8); - -/// fast WinAnsi comparison using the NormToUpper[] array for all 8 bits values -function AnsiIComp(Str1, Str2: pointer): PtrInt; - {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} - -/// extract a line from source array of chars -// - next will contain the beginning of next line, or nil if source if ended -function GetNextLine(source: PUTF8Char; out next: PUTF8Char; andtrim: boolean=false): RawUTF8; - -{$ifdef UNICODE} -/// extract a line from source array of chars -// - next will contain the beginning of next line, or nil if source if ended -// - this special version expect UnicodeString pointers, and return an UnicodeString -function GetNextLineW(source: PWideChar; out next: PWideChar): string; - -/// find the Value of UpperName in P, till end of current section -// - expect UpperName as 'NAME=' -// - this special version expect UnicodeString pointer, and return a VCL string -function FindIniNameValueW(P: PWideChar; UpperName: PUTF8Char): string; - -/// find a Name= Value in a [Section] of a INI Unicode Content -// - this function scans the Content memory buffer, and is -// therefore very fast (no temporary TMemIniFile is created) -// - if Section equals '', find the Name= value before any [Section] -function FindIniEntryW(const Content: string; const Section, Name: RawUTF8): string; -{$endif UNICODE} - -{$ifdef PUREPASCAL} -{$ifdef HASINLINE} -function PosExPas(pSub, p: PUTF8Char; Offset: PtrUInt): PtrInt; -function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt=1): PtrInt; inline; -{$else} -var PosEx: function(const SubStr, S: RawUTF8; Offset: PtrUInt=1): PtrInt; -{$endif} -{$else} - -/// faster RawUTF8 Equivalent of standard StrUtils.PosEx -function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt=1): integer; - -{$endif PUREPASCAL} - -/// our own PosEx() function dedicated to VCL string process -// - Delphi XE or older don't support Pos() with an Offset -var PosExString: function(const SubStr, S: string; Offset: PtrUInt=1): PtrInt; - -/// optimized version of PosEx() with search text as one AnsiChar -function PosExChar(Chr: AnsiChar; const Str: RawUTF8): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// split a RawUTF8 string into two strings, according to SepStr separator -// - if SepStr is not found, LeftStr=Str and RightStr='' -// - if ToUpperCase is TRUE, then LeftStr and RightStr will be made uppercase -procedure Split(const Str, SepStr: RawUTF8; var LeftStr, RightStr: RawUTF8; ToUpperCase: boolean=false); overload; - -/// split a RawUTF8 string into two strings, according to SepStr separator -// - this overloaded function returns the right string as function result -// - if SepStr is not found, LeftStr=Str and result='' -// - if ToUpperCase is TRUE, then LeftStr and result will be made uppercase -function Split(const Str, SepStr: RawUTF8; var LeftStr: RawUTF8; ToUpperCase: boolean=false): RawUTF8; overload; - -/// returns the left part of a RawUTF8 string, according to SepStr separator -// - if SepStr is found, returns Str first chars until (and excluding) SepStr -// - if SepStr is not found, returns Str -function Split(const Str, SepStr: RawUTF8; StartPos: integer=1): RawUTF8; overload; - -/// split a RawUTF8 string into several strings, according to SepStr separator -// - this overloaded function will fill a DestPtr[] array of PRawUTF8 -// - if any DestPtr[]=nil, the item will be skipped -// - if input Str end before al SepStr[] are found, DestPtr[] is set to '' -// - returns the number of values extracted into DestPtr[] -function Split(const Str: RawUTF8; const SepStr: array of RawUTF8; - const DestPtr: array of PRawUTF8): PtrInt; overload; - -/// returns the last occurence of the given SepChar separated context -// - e.g. SplitRight('01/2/34','/')='34' -// - if SepChar doesn't appear, will return Str, e.g. SplitRight('123','/')='123' -// - if LeftStr is supplied, the RawUTF8 it points to will be filled with -// the left part just before SepChar ('' if SepChar doesn't appear) -function SplitRight(const Str: RawUTF8; SepChar: AnsiChar; LeftStr: PRawUTF8=nil): RawUTF8; - -/// returns the last occurence of the given SepChar separated context -// - e.g. SplitRight('path/one\two/file.ext','/\')='file.ext', i.e. -// SepChars='/\' will be like ExtractFileName() over RawUTF8 string -// - if SepChar doesn't appear, will return Str, e.g. SplitRight('123','/')='123' -function SplitRights(const Str, SepChar: RawUTF8): RawUTF8; - -/// actual replacement function called by StringReplaceAll() on first match -// - not to be called as such, but defined globally for proper inlining -function StringReplaceAllProcess(const S, OldPattern, NewPattern: RawUTF8; - found: integer): RawUTF8; - -/// fast version of StringReplace(S, OldPattern, NewPattern,[rfReplaceAll]); -function StringReplaceAll(const S, OldPattern, NewPattern: RawUTF8): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast version of several cascaded StringReplaceAll() -function StringReplaceAll(const S: RawUTF8; const OldNewPatternPairs: array of RawUTF8): RawUTF8; overload; - -/// fast replace of a specified char by a given string -function StringReplaceChars(const Source: RawUTF8; OldChar, NewChar: AnsiChar): RawUTF8; - -/// fast replace of all #9 chars by a given string -function StringReplaceTabs(const Source,TabText: RawUTF8): RawUTF8; - -/// format a text content with SQL-like quotes -// - UTF-8 version of the function available in SysUtils -// - this function implements what is specified in the official SQLite3 -// documentation: "A string constant is formed by enclosing the string in single -// quotes ('). A single quote within the string can be encoded by putting two -// single quotes in a row - as in Pascal." -function QuotedStr(const S: RawUTF8; Quote: AnsiChar=''''): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// format a text content with SQL-like quotes -// - UTF-8 version of the function available in SysUtils -// - this function implements what is specified in the official SQLite3 -// documentation: "A string constant is formed by enclosing the string in single -// quotes ('). A single quote within the string can be encoded by putting two -// single quotes in a row - as in Pascal." -procedure QuotedStr(const S: RawUTF8; Quote: AnsiChar; var result: RawUTF8); overload; - -/// convert UTF-8 content into a JSON string -// - with proper escaping of the content, and surounding " characters -procedure QuotedStrJSON(const aText: RawUTF8; var result: RawUTF8; - const aPrefix: RawUTF8=''; const aSuffix: RawUTF8=''); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert UTF-8 buffer into a JSON string -// - with proper escaping of the content, and surounding " characters -procedure QuotedStrJSON(P: PUTF8Char; PLen: PtrInt; var result: RawUTF8; - const aPrefix: RawUTF8=''; const aSuffix: RawUTF8=''); overload; - -/// convert UTF-8 content into a JSON string -// - with proper escaping of the content, and surounding " characters -function QuotedStrJSON(const aText: RawUTF8): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// unquote a SQL-compatible string -// - the first character in P^ must be either ' or " then internal double quotes -// are transformed into single quotes -// - 'text '' end' -> text ' end -// - "text "" end" -> text " end -// - returns nil if P doesn't contain a valid SQL string -// - returns a pointer just after the quoted text otherwise -function UnQuoteSQLStringVar(P: PUTF8Char; out Value: RawUTF8): PUTF8Char; - -/// unquote a SQL-compatible string -function UnQuoteSQLString(const Value: RawUTF8): RawUTF8; - -/// unquote a SQL-compatible symbol name -// - e.g. '[symbol]' -> 'symbol' or '"symbol"' -> 'symbol' -function UnQuotedSQLSymbolName(const ExternalDBSymbol: RawUTF8): RawUTF8; - -/// get the next character after a quoted buffer -// - the first character in P^ must be either ', either " -// - it will return the latest quote position, ignoring double quotes within -function GotoEndOfQuotedString(P: PUTF8Char): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// get the next character after a quoted buffer -// - the first character in P^ must be " -// - it will return the latest " position, ignoring \" within -function GotoEndOfJSONString(P: PUTF8Char): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// get the next character not in [#1..' '] -function GotoNextNotSpace(P: PUTF8Char): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// get the next character not in [#9,' '] -function GotoNextNotSpaceSameLine(P: PUTF8Char): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// get the next character in [#1..' '] -function GotoNextSpace(P: PUTF8Char): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// check if the next character not in [#1..' '] matchs a given value -// - first ignore any non space character -// - then returns TRUE if P^=ch, setting P to the character after ch -// - or returns FALSE if P^<>ch, leaving P at the level of the unexpected char -function NextNotSpaceCharIs(var P: PUTF8Char; ch: AnsiChar): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// go to the beginning of the SQL statement, ignoring all blanks and comments -// - used to check the SQL statement command (e.g. is it a SELECT?) -function SQLBegin(P: PUTF8Char): PUTF8Char; - -/// add a condition to a SQL WHERE clause, with an ' and ' if where is not void -procedure SQLAddWhereAnd(var where: RawUTF8; const condition: RawUTF8); - -/// return true if the parameter is void or begin with a 'SELECT' SQL statement -// - used to avoid code injection and to check if the cache must be flushed -// - VACUUM, PRAGMA, or EXPLAIN statements also return true, since they won't -// change the data content -// - WITH recursive statement expect no INSERT/UPDATE/DELETE pattern in the SQL -// - if P^ is a SELECT and SelectClause is set to a variable, it would -// contain the field names, from SELECT ...field names... FROM -function isSelect(P: PUTF8Char; SelectClause: PRawUTF8=nil): boolean; - -/// return true if IdemPChar(source,searchUp), and go to the next line of source -function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean; - -/// return true if IdemPChar(source,searchUp), and retrieve the value item -// - typical use may be: -// ! if IdemPCharAndGetNextItem(P, -// ! 'CONTENT-DISPOSITION: FORM-DATA; NAME="',Name,'"') then ... -function IdemPCharAndGetNextItem(var source: PUTF8Char; const searchUp: RawUTF8; - var Item: RawUTF8; Sep: AnsiChar=#13): boolean; - -/// fast go to next text line, ended by #13 or #13#10 -// - returns the beginning of next line, or nil if source^=#0 was reached -function GotoNextLine(source: PUTF8Char): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// compute the line length from a size-delimited source array of chars -// - will use fast assembly on x86-64 CPU, and expects TextEnd to be not nil -// - is likely to read some bytes after the TextEnd buffer, so GetLineSize() -// may be preferred, e.g. on memory mapped files -function BufferLineLength(Text, TextEnd: PUTF8Char): PtrInt; - {$ifndef CPUX64}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// compute the line length from source array of chars -// - if PEnd = nil, end counting at either #0, #13 or #10 -// - otherwise, end counting at either #13 or #10 -// - just a wrapper around BufferLineLength() checking PEnd=nil case -function GetLineSize(P,PEnd: PUTF8Char): PtrUInt; - {$ifdef HASINLINE}inline;{$endif} - -/// returns true if the line length from source array of chars is not less than -// the specified count -function GetLineSizeSmallerThan(P,PEnd: PUTF8Char; aMinimalCount: integer): boolean; - -/// return next CSV string from P -// - P=nil after call when end of text is reached -function GetNextItem(var P: PUTF8Char; Sep: AnsiChar= ','): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return next CSV string from P -// - P=nil after call when end of text is reached -procedure GetNextItem(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); overload; - -/// return next CSV string (unquoted if needed) from P -// - P=nil after call when end of text is reached -procedure GetNextItem(var P: PUTF8Char; Sep, Quote: AnsiChar; var result: RawUTF8); overload; - -/// return trimmed next CSV string from P -// - P=nil after call when end of text is reached -procedure GetNextItemTrimed(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); - -/// return next CRLF separated value string from P, ending #10 or #13#10 trimmed -// - any kind of line feed (CRLF or LF) will be handled, on all operating systems -// - as used e.g. by TSynNameValue.InitFromCSV and TDocVariantData.InitCSV -// - P=nil after call when end of text is reached -procedure GetNextItemTrimedCRLF(var P: PUTF8Char; var result: RawUTF8); - -/// return next CSV string from P, nil if no more -// - this function returns the generic string type of the compiler, and -// therefore can be used with ready to be displayed text (e.g. for the VCL) -function GetNextItemString(var P: PChar; Sep: Char= ','): string; - -/// return next string delimited with #13#10 from P, nil if no more -// - this function returns a RawUnicode string type -function GetNextStringLineToRawUnicode(var P: PChar): RawUnicode; - -/// append some text lines with the supplied Values[] -// - if any Values[] item is '', no line is added -// - otherwise, appends 'Caption: Value', with Caption taken from CSV -procedure AppendCSVValues(const CSV: string; const Values: array of string; - var Result: string; const AppendBefore: string=#13#10); - -/// return a CSV list of the iterated same value -// - e.g. CSVOfValue('?',3)='?,?,?' -function CSVOfValue(const Value: RawUTF8; Count: cardinal; const Sep: RawUTF8=','): RawUTF8; - - /// retrieve the next CSV separated bit index -// - each bit was stored as BitIndex+1, i.e. 0 to mark end of CSV chunk -// - several bits set to one can be regrouped via 'first-last,' syntax -procedure SetBitCSV(var Bits; BitsCount: integer; var P: PUTF8Char); - -/// convert a set of bit into a CSV content -// - each bit is stored as BitIndex+1, and separated by a ',' -// - several bits set to one can be regrouped via 'first-last,' syntax -// - ',0' is always appended at the end of the CSV chunk to mark its end -function GetBitCSV(const Bits; BitsCount: integer): RawUTF8; - -/// return next CSV string from P, nil if no more -// - output text would be trimmed from any left or right space -procedure GetNextItemShortString(var P: PUTF8Char; out Dest: ShortString; Sep: AnsiChar= ','); - -/// decode next CSV hexadecimal string from P, nil if no more or not matching BinBytes -// - Bin is filled with 0 if the supplied CSV content is invalid -// - if Sep is #0, it will read the hexadecimal chars until a whitespace is reached -function GetNextItemHexDisplayToBin(var P: PUTF8Char; Bin: PByte; BinBytes: integer; - Sep: AnsiChar= ','): boolean; - - -type - /// some stack-allocated zero-terminated character buffer - // - as used by GetNextTChar64 - TChar64 = array[0..63] of AnsiChar; - -/// return next CSV string from P as a #0-ended buffer, false if no more -// - if Sep is #0, will copy all characters until next whitespace char -// - returns the number of bytes stored into Buf[] -function GetNextTChar64(var P: PUTF8Char; Sep: AnsiChar; out Buf: TChar64): PtrInt; - -/// return next CSV string as unsigned integer from P, 0 if no more -// - if Sep is #0, it won't be searched for -function GetNextItemCardinal(var P: PUTF8Char; Sep: AnsiChar=','): PtrUInt; - -/// return next CSV string as signed integer from P, 0 if no more -// - if Sep is #0, it won't be searched for -function GetNextItemInteger(var P: PUTF8Char; Sep: AnsiChar=','): PtrInt; - -/// return next CSV string as 64-bit signed integer from P, 0 if no more -// - if Sep is #0, it won't be searched for -function GetNextItemInt64(var P: PUTF8Char; Sep: AnsiChar=','): Int64; - -/// return next CSV string as 64-bit unsigned integer from P, 0 if no more -// - if Sep is #0, it won't be searched for -function GetNextItemQWord(var P: PUTF8Char; Sep: AnsiChar=','): QWord; - -/// return next CSV hexadecimal string as 64-bit unsigned integer from P -// - returns 0 if no valid hexadecimal text is available in P -// - if Sep is #0, it won't be searched for -// - will first fill the 64-bit value with 0, then decode each two hexadecimal -// characters available in P -// - could be used to decode TTextWriter.AddBinToHexDisplayMinChars() output -function GetNextItemHexa(var P: PUTF8Char; Sep: AnsiChar=','): QWord; - -/// return next CSV string as unsigned integer from P, 0 if no more -// - P^ will point to the first non digit character (the item separator, e.g. -// ',' for CSV) -function GetNextItemCardinalStrict(var P: PUTF8Char): PtrUInt; - -/// return next CSV string as unsigned integer from P, 0 if no more -// - this version expects P^ to point to an Unicode char array -function GetNextItemCardinalW(var P: PWideChar; Sep: WideChar=','): PtrUInt; - -/// return next CSV string as double from P, 0.0 if no more -// - if Sep is #0, will return all characters until next whitespace char -function GetNextItemDouble(var P: PUTF8Char; Sep: AnsiChar=','): double; - -/// return next CSV string as currency from P, 0.0 if no more -// - if Sep is #0, will return all characters until next whitespace char -function GetNextItemCurrency(var P: PUTF8Char; Sep: AnsiChar=','): currency; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return next CSV string as currency from P, 0.0 if no more -// - if Sep is #0, will return all characters until next whitespace char -procedure GetNextItemCurrency(var P: PUTF8Char; out result: currency; Sep: AnsiChar=','); overload; - -/// return n-th indexed CSV string in P, starting at Index=0 for first one -function GetCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar=','): RawUTF8; overload; - -/// return n-th indexed CSV string (unquoted if needed) in P, starting at Index=0 for first one -function GetUnQuoteCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar=','; Quote: AnsiChar=''''): RawUTF8; overload; - -/// return n-th indexed CSV string in P, starting at Index=0 for first one -// - this function return the generic string type of the compiler, and -// therefore can be used with ready to be displayed text (i.e. the VCL) -function GetCSVItemString(P: PChar; Index: PtrUInt; Sep: Char=','): string; - -/// return last CSV string in the supplied UTF-8 content -function GetLastCSVItem(const CSV: RawUTF8; Sep: AnsiChar=','): RawUTF8; - -/// return the index of a Value in a CSV string -// - start at Index=0 for first one -// - return -1 if specified Value was not found in CSV items -function FindCSVIndex(CSV: PUTF8Char; const Value: RawUTF8; Sep: AnsiChar = ','; - CaseSensitive: boolean=true; TrimValue: boolean=false): integer; - -/// add the strings in the specified CSV text into a dynamic array of UTF-8 strings -procedure CSVToRawUTF8DynArray(CSV: PUTF8Char; var Result: TRawUTF8DynArray; - Sep: AnsiChar=','; TrimItems: boolean=false; AddVoidItems: boolean=false); overload; - -/// add the strings in the specified CSV text into a dynamic array of UTF-8 strings -procedure CSVToRawUTF8DynArray(const CSV,Sep,SepEnd: RawUTF8; var Result: TRawUTF8DynArray); overload; - -/// return the corresponding CSV text from a dynamic array of UTF-8 strings -function RawUTF8ArrayToCSV(const Values: array of RawUTF8; const Sep: RawUTF8= ','): RawUTF8; - -/// return the corresponding CSV quoted text from a dynamic array of UTF-8 strings -// - apply QuoteStr() function to each Values[] item -function RawUTF8ArrayToQuotedCSV(const Values: array of RawUTF8; const Sep: RawUTF8=','; - Quote: AnsiChar=''''): RawUTF8; - -/// append some prefix to all CSV values -// ! AddPrefixToCSV('One,Two,Three','Pre')='PreOne,PreTwo,PreThree' -function AddPrefixToCSV(CSV: PUTF8Char; const Prefix: RawUTF8; - Sep: AnsiChar = ','): RawUTF8; - -/// append a Value to a CSV string -procedure AddToCSV(const Value: RawUTF8; var CSV: RawUTF8; const Sep: RawUTF8 = ','); - {$ifdef HASINLINE}inline;{$endif} - -/// change a Value within a CSV string -function RenameInCSV(const OldValue, NewValue: RawUTF8; var CSV: RawUTF8; - const Sep: RawUTF8 = ','): boolean; - -/// quick helper to initialize a dynamic array of RawUTF8 from some constants -// - can be used e.g. as: -// ! MyArray := TRawUTF8DynArrayFrom(['a','b','c']); -function TRawUTF8DynArrayFrom(const Values: array of RawUTF8): TRawUTF8DynArray; - -/// check if the TypeInfo() points to an "array of RawUTF8" -// - e.g. returns true for TypeInfo(TRawUTF8DynArray) or other sub-types -// defined as "type aNewType = type TRawUTF8DynArray" -function IsRawUTF8DynArray(typeinfo: pointer): boolean; - -/// append one or several values to a local "array of const" variable -procedure AddArrayOfConst(var Dest: TTVarRecDynArray; const Values: array of const); - -/// low-level efficient search of Value in Values[] -// - CaseSensitive=false will use StrICmp() for A..Z / a..z equivalence -function FindRawUTF8(Values: PRawUTF8; const Value: RawUTF8; ValuesCount: integer; - CaseSensitive: boolean): integer; overload; - -/// return the index of Value in Values[], -1 if not found -// - CaseSensitive=false will use StrICmp() for A..Z / a..z equivalence -function FindRawUTF8(const Values: TRawUTF8DynArray; const Value: RawUTF8; - CaseSensitive: boolean=true): integer; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return the index of Value in Values[], -1 if not found -// - CaseSensitive=false will use StrICmp() for A..Z / a..z equivalence -function FindRawUTF8(const Values: array of RawUTF8; const Value: RawUTF8; - CaseSensitive: boolean=true): integer; overload; - -/// return the index of Value in Values[], -1 if not found -// - here name search would use fast IdemPropNameU() function -function FindPropName(const Names: array of RawUTF8; const Name: RawUTF8): integer; overload; - -/// return the index of Value in Values[] using IdemPropNameU(), -1 if not found -// - typical use with a dynamic array is like: -// ! index := FindPropName(pointer(aDynArray),length(aDynArray),aValue); -function FindPropName(Values: PRawUTF8; const Value: RawUTF8; - ValuesCount: integer): integer; overload; - -/// true if Value was added successfully in Values[] -function AddRawUTF8(var Values: TRawUTF8DynArray; const Value: RawUTF8; - NoDuplicates: boolean=false; CaseSensitive: boolean=true): boolean; overload; - -/// add the Value to Values[], with an external count variable, for performance -procedure AddRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; - const Value: RawUTF8); overload; - -/// true if both TRawUTF8DynArray are the same -// - comparison is case-sensitive -function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray): boolean; overload; - -/// true if both TRawUTF8DynArray are the same for a given number of items -// - A and B are expected to have at least Count items -// - comparison is case-sensitive -function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray; Count: integer): boolean; overload; - -/// convert the string dynamic array into a dynamic array of UTF-8 strings -procedure StringDynArrayToRawUTF8DynArray(const Source: TStringDynArray; - var Result: TRawUTF8DynArray); - -/// convert the string list into a dynamic array of UTF-8 strings -procedure StringListToRawUTF8DynArray(Source: TStringList; var Result: TRawUTF8DynArray); - -/// search for a value from its uppercased named entry -// - i.e. iterate IdemPChar(source,UpperName) over every line of the source -// - returns the text just after UpperName if it has been found at line beginning -// - returns nil if UpperName was not found was not found at any line beginning -// - could be used as alternative to FindIniNameValue() and FindIniNameValueInteger() -// if there is no section, i.e. if search should not stop at '[' but at source end -function FindNameValue(P: PUTF8Char; UpperName: PAnsiChar): PUTF8Char; overload; - -/// search and returns a value from its uppercased named entry -// - i.e. iterate IdemPChar(source,UpperName) over every line of the source -// - returns true and the trimmed text just after UpperName if it has been found -// at line beginning -// - returns false if UpperName was not found was not found at any line beginning -// - could be used e.g. to efficently extract a value from HTTP headers, whereas -// FindIniNameValue() is tuned for [section]-oriented INI files -function FindNameValue(const NameValuePairs: RawUTF8; UpperName: PAnsiChar; - var Value: RawUTF8): boolean; overload; - -/// find a Name= Value in a [Section] of a INI RawUTF8 Content -// - this function scans the Content memory buffer, and is -// therefore very fast (no temporary TMemIniFile is created) -// - if Section equals '', find the Name= value before any [Section] -function FindIniEntry(const Content, Section,Name: RawUTF8): RawUTF8; - -/// find a Name= Value in a [Section] of a INI WinAnsi Content -// - same as FindIniEntry(), but the value is converted from WinAnsi into UTF-8 -function FindWinAnsiIniEntry(const Content, Section,Name: RawUTF8): RawUTF8; - -/// find a Name= numeric Value in a [Section] of a INI RawUTF8 Content and -// return it as an integer, or 0 if not found -// - this function scans the Content memory buffer, and is -// therefore very fast (no temporary TMemIniFile is created) -// - if Section equals '', find the Name= value before any [Section] -function FindIniEntryInteger(const Content, Section,Name: RawUTF8): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// find a Name= Value in a [Section] of a .INI file -// - if Section equals '', find the Name= value before any [Section] -// - use internaly fast FindIniEntry() function above -function FindIniEntryFile(const FileName: TFileName; const Section,Name: RawUTF8): RawUTF8; - -/// update a Name= Value in a [Section] of a INI RawUTF8 Content -// - this function scans and update the Content memory buffer, and is -// therefore very fast (no temporary TMemIniFile is created) -// - if Section equals '', update the Name= value before any [Section] -procedure UpdateIniEntry(var Content: RawUTF8; const Section,Name,Value: RawUTF8); - -/// update a Name= Value in a [Section] of a .INI file -// - if Section equals '', update the Name= value before any [Section] -// - use internaly fast UpdateIniEntry() function above -procedure UpdateIniEntryFile(const FileName: TFileName; const Section,Name,Value: RawUTF8); - -/// find the position of the [SEARCH] section in source -// - return true if [SEARCH] was found, and store pointer to the line after it in source -function FindSectionFirstLine(var source: PUTF8Char; search: PAnsiChar): boolean; - -/// find the position of the [SEARCH] section in source -// - return true if [SEARCH] was found, and store pointer to the line after it in source -// - this version expects source^ to point to an Unicode char array -function FindSectionFirstLineW(var source: PWideChar; search: PUTF8Char): boolean; - -/// retrieve the whole content of a section as a string -// - SectionFirstLine may have been obtained by FindSectionFirstLine() function above -function GetSectionContent(SectionFirstLine: PUTF8Char): RawUTF8; overload; - -/// retrieve the whole content of a section as a string -// - use SectionFirstLine() then previous GetSectionContent() -function GetSectionContent(const Content, SectionName: RawUTF8): RawUTF8; overload; - -/// delete a whole [Section] -// - if EraseSectionHeader is TRUE (default), then the [Section] line is also -// deleted together with its content lines -// - return TRUE if something was changed in Content -// - return FALSE if [Section] doesn't exist or is already void -function DeleteSection(var Content: RawUTF8; const SectionName: RawUTF8; - EraseSectionHeader: boolean=true): boolean; overload; - -/// delete a whole [Section] -// - if EraseSectionHeader is TRUE (default), then the [Section] line is also -// deleted together with its content lines -// - return TRUE if something was changed in Content -// - return FALSE if [Section] doesn't exist or is already void -// - SectionFirstLine may have been obtained by FindSectionFirstLine() function above -function DeleteSection(SectionFirstLine: PUTF8Char; var Content: RawUTF8; - EraseSectionHeader: boolean=true): boolean; overload; - -/// replace a whole [Section] content by a new content -// - create a new [Section] if none was existing -procedure ReplaceSection(var Content: RawUTF8; const SectionName, - NewSectionContent: RawUTF8); overload; - -/// replace a whole [Section] content by a new content -// - create a new [Section] if none was existing -// - SectionFirstLine may have been obtained by FindSectionFirstLine() function above -procedure ReplaceSection(SectionFirstLine: PUTF8Char; - var Content: RawUTF8; const NewSectionContent: RawUTF8); overload; - -/// return TRUE if Value of UpperName does exist in P, till end of current section -// - expect UpperName as 'NAME=' -function ExistsIniName(P: PUTF8Char; UpperName: PAnsiChar): boolean; - -/// find the Value of UpperName in P, till end of current section -// - expect UpperName as 'NAME=' -function FindIniNameValue(P: PUTF8Char; UpperName: PAnsiChar): RawUTF8; - -/// return TRUE if one of the Value of UpperName exists in P, till end of -// current section -// - expect UpperName e.g. as 'CONTENT-TYPE: ' -// - expect UpperValues to be any upper value with left side matching, e.g. as -// used by IsHTMLContentTypeTextual() function: -// ! result := ExistsIniNameValue(htmlHeaders,HEADER_CONTENT_TYPE_UPPER, -// ! ['TEXT/','APPLICATION/JSON','APPLICATION/XML']); -// - warning: this function calls IdemPCharArray(), so expects UpperValues[] -/// items to have AT LEAST TWO CHARS (it will use fast initial 2 bytes compare) -function ExistsIniNameValue(P: PUTF8Char; const UpperName: RawUTF8; - const UpperValues: array of PAnsiChar): boolean; - -/// find the integer Value of UpperName in P, till end of current section -// - expect UpperName as 'NAME=' -// - return 0 if no NAME= entry was found -function FindIniNameValueInteger(P: PUTF8Char; UpperName: PAnsiChar): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// replace a value from a given set of name=value lines -// - expect UpperName as 'UPPERNAME=', otherwise returns false -// - if no UPPERNAME= entry was found, then Name+NewValue is added to Content -// - a typical use may be: -// ! UpdateIniNameValue(headers,HEADER_CONTENT_TYPE,HEADER_CONTENT_TYPE_UPPER,contenttype); -function UpdateIniNameValue(var Content: RawUTF8; const Name, UpperName, NewValue: RawUTF8): boolean; - -/// read a File content into a String -// - content can be binary or text -// - returns '' if file was not found or any read error occured -// - wil use GetFileSize() API by default, unless HasNoSize is defined, -// and read will be done using a buffer (required e.g. for char files under Linux) -// - uses RawByteString for byte storage, whatever the codepage is -function StringFromFile(const FileName: TFileName; HasNoSize: boolean=false): RawByteString; - -/// create a File from a string content -// - uses RawByteString for byte storage, whatever the codepage is -function FileFromString(const Content: RawByteString; const FileName: TFileName; - FlushOnDisk: boolean=false; FileDate: TDateTime=0): boolean; - -/// get text File contents (even Unicode or UTF8) and convert it into a -// Charset-compatible AnsiString (for Delphi 7) or an UnicodeString (for Delphi -// 2009 and up) according to any BOM marker at the beginning of the file -// - before Delphi 2009, the current string code page is used (i.e. CurrentAnsiConvert) -function AnyTextFileToString(const FileName: TFileName; ForceUTF8: boolean=false): string; - -/// get text file contents (even Unicode or UTF8) and convert it into an -// Unicode string according to any BOM marker at the beginning of the file -// - any file without any BOM marker will be interpreted as plain ASCII: in this -// case, the current string code page is used (i.e. CurrentAnsiConvert class) -function AnyTextFileToSynUnicode(const FileName: TFileName; ForceUTF8: boolean=false): SynUnicode; - -/// get text file contents (even Unicode or UTF8) and convert it into an -// UTF-8 string according to any BOM marker at the beginning of the file -// - if AssumeUTF8IfNoBOM is FALSE, the current string code page is used (i.e. -// CurrentAnsiConvert class) for conversion from ANSI into UTF-8 -// - if AssumeUTF8IfNoBOM is TRUE, any file without any BOM marker will be -// interpreted as UTF-8 -function AnyTextFileToRawUTF8(const FileName: TFileName; AssumeUTF8IfNoBOM: boolean=false): RawUTF8; - -/// read a TStream content into a String -// - it will read binary or text content from the current position until the -// end (using TStream.Size) -// - uses RawByteString for byte storage, whatever the codepage is -function StreamToRawByteString(aStream: TStream): RawByteString; - -/// create a TStream from a string content -// - uses RawByteString for byte storage, whatever the codepage is -// - in fact, the returned TStream is a TRawByteString instance, since this -// function is just a wrapper around: -// ! result := TRawByteStringStream.Create(aString); -function RawByteStringToStream(const aString: RawByteString): TStream; - {$ifdef HASINLINE}inline;{$endif} - -/// read an UTF-8 text from a TStream -// - format is Length(Integer):Text, i.e. the one used by WriteStringToStream -// - will return '' if there is no such text in the stream -// - you can set a MaxAllowedSize value, if you know how long the size should be -// - it will read from the current position in S: so if you just write into S, -// it could be a good idea to rewind it before call, e.g.: -// ! WriteStringToStream(Stream,aUTF8Text); -// ! Stream.Seek(0,soBeginning); -// ! str := ReadStringFromStream(Stream); -function ReadStringFromStream(S: TStream; MaxAllowedSize: integer=255): RawUTF8; - -/// write an UTF-8 text into a TStream -// - format is Length(Integer):Text, i.e. the one used by ReadStringFromStream -function WriteStringToStream(S: TStream; const Text: RawUTF8): boolean; - -/// get a file date and time, from its name -// - returns 0 if file doesn't exist -// - under Windows, will use GetFileAttributesEx fast API -function FileAgeToDateTime(const FileName: TFileName): TDateTime; - -/// get a file size, from its name -// - returns 0 if file doesn't exist -// - under Windows, will use GetFileAttributesEx fast API -function FileSize(const FileName: TFileName): Int64; overload; - -/// get a file size, from its handle -// - returns 0 if file doesn't exist -function FileSize(F: THandle): Int64; overload; - -/// get low-level file information, in a cross-platform way -// - returns true on success -// - here file write/creation time are given as TUnixMSTime values, for better -// cross-platform process - note that FileCreateDateTime may not be supported -// by most Linux file systems, so the oldest timestamp available is returned -// as failover on such systems (probably the latest file metadata writing) -function FileInfoByHandle(aFileHandle: THandle; out FileId, FileSize, - LastWriteAccess, FileCreateDateTime: Int64): Boolean; - -/// get a file date and time, from a FindFirst/FindNext search -// - the returned timestamp is in local time, not UTC -// - this method would use the F.Timestamp field available since Delphi XE2 -function SearchRecToDateTime(const F: TSearchRec): TDateTime; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a FindFirst/FindNext found instance is actually a file -function SearchRecValidFile(const F: TSearchRec): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a FindFirst/FindNext found instance is actually a folder -function SearchRecValidFolder(const F: TSearchRec): boolean; - {$ifdef HASINLINE}inline;{$endif} - -const - /// operating-system dependent wildchar to match all files in a folder - FILES_ALL = {$ifdef MSWINDOWS}'*.*'{$else}'*'{$endif}; - -/// delete the content of a specified directory -// - only one level of file is deleted within the folder: no recursive deletion -// is processed by this function (for safety) -// - if DeleteOnlyFilesNotDirectory is TRUE, it won't remove the folder itself, -// but just the files found in it -function DirectoryDelete(const Directory: TFileName; const Mask: TFileName=FILES_ALL; - DeleteOnlyFilesNotDirectory: Boolean=false; DeletedCount: PInteger=nil): Boolean; - -/// delete the files older than a given age in a specified directory -// - for instance, to delete all files older than one day: -// ! DirectoryDeleteOlderFiles(FolderName, 1); -// - only one level of file is deleted within the folder: no recursive deletion -// is processed by this function, unless Recursive is TRUE -// - if Recursive=true, caller should set TotalSize^=0 to have an accurate value -function DirectoryDeleteOlderFiles(const Directory: TFileName; TimePeriod: TDateTime; - const Mask: TFileName=FILES_ALL; Recursive: Boolean=false; TotalSize: PInt64=nil): Boolean; - -/// creates a directory if not already existing -// - returns the full expanded directory name, including trailing backslash -// - returns '' on error, unless RaiseExceptionOnCreationFailure=true -function EnsureDirectoryExists(const Directory: TFileName; - RaiseExceptionOnCreationFailure: boolean=false): TFileName; - -/// check if the directory is writable for the current user -// - try to write a small file with a random name -function IsDirectoryWritable(const Directory: TFileName): boolean; - -/// compute an unique temporary file name -// - following 'exename_01234567.tmp' pattern, in the system temporary folder -function TemporaryFileName: TFileName; - -type - {$A-} - /// file found result item, as returned by FindFiles() - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}TFindFiles = record - {$else}TFindFiles = object{$endif} - public - /// the matching file name, including its folder name - Name: TFileName; - /// the matching file attributes - Attr: Integer; - /// the matching file size - Size: Int64; - /// the matching file date/time - Timestamp: TDateTime; - /// fill the item properties from a FindFirst/FindNext's TSearchRec - procedure FromSearchRec(const Directory: TFileName; const F: TSearchRec); - /// returns some ready-to-be-loggued text - function ToText: shortstring; - end; - {$A+} - /// result list, as returned by FindFiles() - TFindFilesDynArray = array of TFindFiles; - - /// a pointer to a TFileName variable - PFileName = ^TFileName; - -/// search for matching file names -// - just a wrapper around FindFirst/FindNext -// - you may specify several masks in Mask, e.g. as '*.jpg;*.jpeg' -function FindFiles(const Directory,Mask: TFileName; - const IgnoreFileName: TFileName=''; SortByName: boolean=false; - IncludesDir: boolean=true; SubFolder: Boolean=false): TFindFilesDynArray; - -/// convert a result list, as returned by FindFiles(), into an array of Files[].Name -function FindFilesDynArrayToFileNames(const Files: TFindFilesDynArray): TFileNameDynArray; - -/// ensure all files in Dest folder(s) do match the one in Reference -// - won't copy all files from Reference folders, but only update files already -// existing in Dest, which did change since last synchronization -// - will also process recursively nested folders if SubFolder is true -// - will use file content instead of file date check if ByContent is true -// - can optionally write the synched file name to the console -// - returns the number of files copied during the process -function SynchFolders(const Reference, Dest: TFileName; SubFolder: boolean=false; - ByContent: boolean=false; WriteFileNameToConsole: boolean=false): integer; - -{$ifdef DELPHI5OROLDER} - -/// DirectoryExists returns a boolean value that indicates whether the -// specified directory exists (and is actually a directory) -function DirectoryExists(const Directory: string): Boolean; - -/// case-insensitive comparison of filenames -function SameFileName(const S1, S2: TFileName): Boolean; - -/// retrieve the corresponding environment variable value -function GetEnvironmentVariable(const Name: string): string; - -/// retrieve the full path name of the given execution module (e.g. library) -function GetModuleName(Module: HMODULE): TFileName; - -/// try to encode a time -function TryEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean; - -/// alias to ExcludeTrailingBackslash() function -function ExcludeTrailingPathDelimiter(const FileName: TFileName): TFileName; - -/// alias to IncludeTrailingBackslash() function -function IncludeTrailingPathDelimiter(const FileName: TFileName): TFileName; - -type - EOSError = class(Exception) - public - ErrorCode: DWORD; - end; - -/// raise an EOSError exception corresponding to the last error reported by Windows -procedure RaiseLastOSError; - -{$endif DELPHI5OROLDER} - -{$ifdef DELPHI6OROLDER} -procedure VarCastError; -{$endif} - -/// compute the file name, including its path if supplied, but without its extension -// - e.g. GetFileNameWithoutExt('/var/toto.ext') = '/var/toto' -// - may optionally return the extracted extension, as '.ext' -function GetFileNameWithoutExt(const FileName: TFileName; - Extension: PFileName=nil): TFileName; - -/// extract a file extension from a file name, then compare with a comma -// separated list of extensions -// - e.g. GetFileNameExtIndex('test.log','exe,log,map')=1 -// - will return -1 if no file extension match -// - will return any matching extension, starting count at 0 -// - extension match is case-insensitive -function GetFileNameExtIndex(const FileName, CSVExt: TFileName): integer; - -/// copy one file to another, similar to the Windows API -function CopyFile(const Source, Target: TFileName; FailIfExists: boolean): boolean; - -/// copy the date of one file to another -function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean; - -/// retrieve a property value in a text-encoded class -// - follows the Delphi serialized text object format, not standard .ini -// - if the property is a string, the simple quotes ' are trimed -function FindObjectEntry(const Content, Name: RawUTF8): RawUTF8; - -/// retrieve a filename property value in a text-encoded class -// - follows the Delphi serialized text object format, not standard .ini -// - if the property is a string, the simple quotes ' are trimed -// - any file path and any extension are trimmed -function FindObjectEntryWithoutExt(const Content, Name: RawUTF8): RawUTF8; - - -/// return true if UpperValue (Ansi) is contained in A^ (Ansi) -// - find UpperValue starting at word beginning, not inside words -function FindAnsi(A, UpperValue: PAnsiChar): boolean; - -/// return true if UpperValue (Ansi) is contained in U^ (UTF-8 encoded) -// - find UpperValue starting at word beginning, not inside words -// - UTF-8 decoding is done on the fly (no temporary decoding buffer is used) -function FindUTF8(U: PUTF8Char; UpperValue: PAnsiChar): boolean; - -/// return true if Upper (Unicode encoded) is contained in U^ (UTF-8 encoded) -// - will use the slow but accurate Operating System API to perform the -// comparison at Unicode-level -function FindUnicode(PW: PWideChar; Upper: PWideChar; UpperLen: PtrInt): boolean; - -/// trim first lowercase chars ('otDone' will return 'Done' e.g.) -// - return a PUTF8Char to avoid any memory allocation -function TrimLeftLowerCase(const V: RawUTF8): PUTF8Char; - -/// trim first lowercase chars ('otDone' will return 'Done' e.g.) -// - return an RawUTF8 string: enumeration names are pure 7bit ANSI with Delphi 7 -// to 2007, and UTF-8 encoded with Delphi 2009+ -function TrimLeftLowerCaseShort(V: PShortString): RawUTF8; - -/// trim first lowercase chars ('otDone' will return 'Done' e.g.) -// - return a shortstring: enumeration names are pure 7bit ANSI with Delphi 7 -// to 2007, and UTF-8 encoded with Delphi 2009+ -function TrimLeftLowerCaseToShort(V: PShortString): ShortString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// trim first lowercase chars ('otDone' will return 'Done' e.g.) -// - return a shortstring: enumeration names are pure 7bit ANSI with Delphi 7 -// to 2007, and UTF-8 encoded with Delphi 2009+ -procedure TrimLeftLowerCaseToShort(V: PShortString; out result: ShortString); overload; - -/// convert a CamelCase string into a space separated one -// - 'OnLine' will return 'On line' e.g., and 'OnMyLINE' will return 'On my LINE' -// - will handle capital words at the beginning, middle or end of the text, e.g. -// 'KLMFlightNumber' will return 'KLM flight number' and 'GoodBBCProgram' will -// return 'Good BBC program' -// - will handle a number at the beginning, middle or end of the text, e.g. -// 'Email12' will return 'Email 12' -// - '_' char is transformed into ' - ' -// - '__' chars are transformed into ': ' -// - return an RawUTF8 string: enumeration names are pure 7bit ANSI with Delphi 7 -// to 2007, and UTF-8 encoded with Delphi 2009+ -function UnCamelCase(const S: RawUTF8): RawUTF8; overload; - -/// convert a CamelCase string into a space separated one -// - 'OnLine' will return 'On line' e.g., and 'OnMyLINE' will return 'On my LINE' -// - will handle capital words at the beginning, middle or end of the text, e.g. -// 'KLMFlightNumber' will return 'KLM flight number' and 'GoodBBCProgram' will -// return 'Good BBC program' -// - will handle a number at the beginning, middle or end of the text, e.g. -// 'Email12' will return 'Email 12' -// - return the char count written into D^ -// - D^ and P^ are expected to be UTF-8 encoded: enumeration and property names -// are pure 7bit ANSI with Delphi 7 to 2007, and UTF-8 encoded with Delphi 2009+ -// - '_' char is transformed into ' - ' -// - '__' chars are transformed into ': ' -function UnCamelCase(D, P: PUTF8Char): integer; overload; - -/// convert a string into an human-friendly CamelCase identifier -// - replacing spaces or punctuations by an uppercase character -// - as such, it is not the reverse function to UnCamelCase() -procedure CamelCase(P: PAnsiChar; len: PtrInt; var s: RawUTF8; - const isWord: TSynByteSet=[ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')]); overload; - -/// convert a string into an human-friendly CamelCase identifier -// - replacing spaces or punctuations by an uppercase character -// - as such, it is not the reverse function to UnCamelCase() -procedure CamelCase(const text: RawUTF8; var s: RawUTF8; - const isWord: TSynByteSet=[ord('0')..ord('9'),ord('a')..ord('z'),ord('A')..ord('Z')]); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// UnCamelCase and translate a char buffer -// - P is expected to be #0 ended -// - return "string" type, i.e. UnicodeString for Delphi 2009+ -procedure GetCaptionFromPCharLen(P: PUTF8Char; out result: string); - -/// will get a class name as UTF-8 -// - will trim 'T', 'TSyn', 'TSQL' or 'TSQLRecord' left side of the class name -// - will encode the class name as UTF-8 (for Unicode Delphi versions) -// - is used e.g. to extract the SQL table name for a TSQLRecord class -function GetDisplayNameFromClass(C: TClass): RawUTF8; - -/// UnCamelCase and translate the class name, triming any left 'T', 'TSyn', -// 'TSQL' or 'TSQLRecord' -// - return generic VCL string type, i.e. UnicodeString for Delphi 2009+ -function GetCaptionFromClass(C: TClass): string; - -/// just a wrapper around vmtClassName to avoid a string conversion -function ClassNameShort(C: TClass): PShortString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// just a wrapper around vmtClassName to avoid a string conversion -function ClassNameShort(Instance: TObject): PShortString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// just a wrapper around vmtParent to avoid a function call -// - slightly faster than TClass.ClassParent thanks to proper inlining -function GetClassParent(C: TClass): TClass; - {$ifdef HASINLINE}inline;{$endif} - -/// just a wrapper around vmtClassName to avoid a string/RawUTF8 conversion -function ToText(C: TClass): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// just a wrapper around vmtClassName to avoid a string/RawUTF8 conversion -procedure ToText(C: TClass; var result: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - -type - /// information about one method, as returned by GetPublishedMethods - TPublishedMethodInfo = record - /// the method name - Name: RawUTF8; - /// a callback to the method, for the given class instance - Method: TMethod; - end; - /// information about all methods, as returned by GetPublishedMethods - TPublishedMethodInfoDynArray = array of TPublishedMethodInfo; - -/// retrieve published methods information about any class instance -// - will optionaly accept a Class, in this case Instance is ignored -// - will work with FPC and Delphi RTTI -function GetPublishedMethods(Instance: TObject; out Methods: TPublishedMethodInfoDynArray; - aClass: TClass = nil): integer; - -{$ifdef LINUX} -const - ANSI_CHARSET = 0; - DEFAULT_CHARSET = 1; - SYMBOL_CHARSET = 2; - SHIFTJIS_CHARSET = $80; - HANGEUL_CHARSET = 129; - GB2312_CHARSET = 134; - CHINESEBIG5_CHARSET = 136; - OEM_CHARSET = 255; - JOHAB_CHARSET = 130; - HEBREW_CHARSET = 177; - ARABIC_CHARSET = 178; - GREEK_CHARSET = 161; - TURKISH_CHARSET = 162; - VIETNAMESE_CHARSET = 163; - THAI_CHARSET = 222; - EASTEUROPE_CHARSET = 238; - RUSSIAN_CHARSET = 204; - BALTIC_CHARSET = 186; -{$else} -{$ifdef FPC} -const - VIETNAMESE_CHARSET = 163; -{$endif} -{$endif} - -/// convert a char set to a code page -function CharSetToCodePage(CharSet: integer): cardinal; - -/// convert a code page to a char set -function CodePageToCharSet(CodePage: Cardinal): Integer; - -/// retrieve the MIME content type from a supplied binary buffer -// - inspect the first bytes, to guess from standard known headers -// - return the MIME type, ready to be appended to a 'Content-Type: ' HTTP header -// - returns DefaultContentType if the binary buffer has an unknown layout -function GetMimeContentTypeFromBuffer(Content: Pointer; Len: PtrInt; - const DefaultContentType: RawUTF8): RawUTF8; - -/// retrieve the MIME content type from its file name or a supplied binary buffer -// - will first check for known file extensions, then inspect the binary content -// - return the MIME type, ready to be appended to a 'Content-Type: ' HTTP header -// - default is 'application/octet-stream' (BINARY_CONTENT_TYPE) or -// 'application/fileextension' if FileName was specified -// - see @http://en.wikipedia.org/wiki/Internet_media_type for most common values -function GetMimeContentType(Content: Pointer; Len: PtrInt; - const FileName: TFileName=''): RawUTF8; - -/// retrieve the HTTP header for MIME content type from a supplied binary buffer -// - just append HEADER_CONTENT_TYPE and GetMimeContentType() result -// - can be used as such: -// ! Call.OutHead := GetMimeContentTypeHeader(Call.OutBody,aFileName); -function GetMimeContentTypeHeader(const Content: RawByteString; - const FileName: TFileName=''): RawUTF8; - -/// retrieve if some content is compressed, from a supplied binary buffer -// - returns TRUE, if the header in binary buffer "may" be compressed (this method -// can trigger false positives), e.g. begin with most common already compressed -// zip/gz/gif/png/jpeg/avi/mp3/mp4 markers (aka "magic numbers") -function IsContentCompressed(Content: Pointer; Len: PtrInt): boolean; - -/// returns TRUE if the supplied HTML Headers contains 'Content-Type: text/...', -// 'Content-Type: application/json' or 'Content-Type: application/xml' -function IsHTMLContentTypeTextual(Headers: PUTF8Char): Boolean; - -/// fast guess of the size, in pixels, of a JPEG memory buffer -// - will only scan for basic JPEG structure, up to the StartOfFrame (SOF) chunk -// - returns TRUE if the buffer is likely to be a JPEG picture, and set the -// Height + Width variable with its dimensions - but there may be false positive -// recognition, and no waranty that the memory buffer holds a valid JPEG picture -// - returns FALSE if the buffer does not have any expected SOI/SOF markers -function GetJpegSize(jpeg: PAnsiChar; len: PtrInt; out Height, Width: integer): boolean; overload; - -/// fast guess of the size, in pixels, of a JPEG file -// - will only scan for basic JPEG structure, up to the StartOfFrame (SOF) chunk -// - returns TRUE if the buffer is likely to be a JPEG picture, and set the -// Height + Width variable with its dimensions - but there may be false positive -// recognition, and no waranty that the file is a valid JPEG picture -// - returns FALSE if the file content does not have any expected SOI/SOF markers -function GetJpegSize(const jpeg: TFileName; out Height, Width: integer): boolean; overload; - -type - /// used by MultiPartFormDataDecode() to return one item of its data - TMultiPart = record - Name: RawUTF8; - FileName: RawUTF8; - ContentType: RawUTF8; - Encoding: RawUTF8; - Content: RawByteString; - end; - /// used by MultiPartFormDataDecode() to return all its data items - TMultiPartDynArray = array of TMultiPart; - -/// decode multipart/form-data POST request content -// - following RFC1867 -function MultiPartFormDataDecode(const MimeType,Body: RawUTF8; - var MultiPart: TMultiPartDynArray): boolean; - -/// encode multipart fields and files -// - only one of them can be used because MultiPartFormDataDecode must implement -// both decodings -// - MultiPart: parts to build the multipart content from, which may be created -// using MultiPartFormDataAddFile/MultiPartFormDataAddField -// - MultiPartContentType: variable returning -// $ Content-Type: multipart/form-data; boundary=xxx -// where xxx is the first generated boundary -// - MultiPartContent: generated multipart content -function MultiPartFormDataEncode(const MultiPart: TMultiPartDynArray; - var MultiPartContentType, MultiPartContent: RawUTF8): boolean; - -/// encode a file in a multipart array -// - FileName: file to encode -// - Multipart: where the part is added -// - Name: name of the part, is empty the name 'File###' is generated -function MultiPartFormDataAddFile(const FileName: TFileName; - var MultiPart: TMultiPartDynArray; const Name: RawUTF8 = ''): boolean; - -/// encode a field in a multipart array -// - FieldName: field name of the part -// - FieldValue: value of the field -// - Multipart: where the part is added -function MultiPartFormDataAddField(const FieldName, FieldValue: RawUTF8; - var MultiPart: TMultiPartDynArray): boolean; - -/// retrieve the index where to insert a PUTF8Char in a sorted PUTF8Char array -// - R is the last index of available entries in P^ (i.e. Count-1) -// - string comparison is case-sensitive StrComp (so will work with any PAnsiChar) -// - returns -1 if the specified Value was found (i.e. adding will duplicate a value) -// - will use fast O(log(n)) binary search algorithm -function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// retrieve the index where to insert a PUTF8Char in a sorted PUTF8Char array -// - this overloaded function accept a custom comparison function for sorting -// - R is the last index of available entries in P^ (i.e. Count-1) -// - string comparison is case-sensitive (so will work with any PAnsiChar) -// - returns -1 if the specified Value was found (i.e. adding will duplicate a value) -// - will use fast O(log(n)) binary search algorithm -function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; - Compare: TUTF8Compare): PtrInt; overload; - -/// retrieve the index where is located a PUTF8Char in a sorted PUTF8Char array -// - R is the last index of available entries in P^ (i.e. Count-1) -// - string comparison is case-sensitive StrComp (so will work with any PAnsiChar) -// - returns -1 if the specified Value was not found -// - will use inlined binary search algorithm with optimized x86_64 branchless asm -// - slightly faster than plain FastFindPUTF8CharSorted(P,R,Value,@StrComp) -function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; overload; - -/// retrieve the index where is located a PUTF8Char in a sorted uppercase PUTF8Char array -// - P[] array is expected to be already uppercased -// - searched Value is converted to uppercase before search via UpperCopy255Buf(), -// so is expected to be short, i.e. length < 250 -// - R is the last index of available entries in P^ (i.e. Count-1) -// - returns -1 if the specified Value was not found -// - will use fast O(log(n)) binary search algorithm -// - slightly faster than plain FastFindPUTF8CharSorted(P,R,Value,@StrIComp) -function FastFindUpperPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; - Value: PUTF8Char; ValueLen: PtrInt): PtrInt; - -/// retrieve the index where is located a PUTF8Char in a sorted PUTF8Char array -// - R is the last index of available entries in P^ (i.e. Count-1) -// - string comparison will use the specified Compare function -// - returns -1 if the specified Value was not found -// - will use fast O(log(n)) binary search algorithm -function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; - Compare: TUTF8Compare): PtrInt; overload; - -/// retrieve the index of a PUTF8Char in a PUTF8Char array via a sort indexed -// - will use fast O(log(n)) binary search algorithm -function FastFindIndexedPUTF8Char(P: PPUTF8CharArray; R: PtrInt; - var SortedIndexes: TCardinalDynArray; Value: PUTF8Char; - ItemComp: TUTF8Compare): PtrInt; - -/// add a RawUTF8 value in an alphaticaly sorted dynamic array of RawUTF8 -// - returns the index where the Value was added successfully in Values[] -// - returns -1 if the specified Value was alredy present in Values[] -// (we must avoid any duplicate for O(log(n)) binary search) -// - if CoValues is set, its content will be moved to allow inserting a new -// value at CoValues[result] position - a typical usage of CoValues is to store -// the corresponding ID to each RawUTF8 item -// - if FastLocatePUTF8CharSorted() has been already called, this index can -// be set to optional ForceIndex parameter -// - by default, exact (case-sensitive) match is used; you can specify a custom -// compare function if needed in Compare optional parameter -function AddSortedRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; - const Value: RawUTF8; CoValues: PIntegerDynArray=nil; ForcedIndex: PtrInt=-1; - Compare: TUTF8Compare=nil): PtrInt; - -/// delete a RawUTF8 item in a dynamic array of RawUTF8 -// - if CoValues is set, the integer item at the same index is also deleted -function DeleteRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; - Index: integer; CoValues: PIntegerDynArray=nil): boolean; overload; - -/// delete a RawUTF8 item in a dynamic array of RawUTF8; -function DeleteRawUTF8(var Values: TRawUTF8DynArray; Index: integer): boolean; overload; - -/// sort a dynamic array of RawUTF8 items -// - if CoValues is set, the integer items are also synchronized -// - by default, exact (case-sensitive) match is used; you can specify a custom -// compare function if needed in Compare optional parameter -procedure QuickSortRawUTF8(var Values: TRawUTF8DynArray; ValuesCount: integer; - CoValues: PIntegerDynArray=nil; Compare: TUTF8Compare=nil); - -/// sort a dynamic array of PUTF8Char items, via an external array of indexes -// - you can use FastFindIndexedPUTF8Char() for fast O(log(n)) binary search -procedure QuickSortIndexedPUTF8Char(Values: PPUtf8CharArray; Count: Integer; - var SortedIndexes: TCardinalDynArray; CaseSensitive: boolean=false); - -/// fast search of an unsigned integer position in an integer array -// - Count is the number of cardinal entries in P^ -// - returns P where P^=Value -// - returns nil if Value was not found -function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal; - -/// fast search of an unsigned integer position in an integer array -// - Count is the number of integer entries in P^ -// - return index of P^[index]=Value -// - return -1 if Value was not found -function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt; - -/// fast search of an integer position in a 64-bit integer array -// - Count is the number of Int64 entries in P^ -// - returns P where P^=Value -// - returns nil if Value was not found -function Int64Scan(P: PInt64Array; Count: PtrInt; const Value: Int64): PInt64; - -/// fast search of an integer position in a signed 64-bit integer array -// - Count is the number of Int64 entries in P^ -// - returns index of P^[index]=Value -// - returns -1 if Value was not found -function Int64ScanIndex(P: PInt64Array; Count: PtrInt; const Value: Int64): PtrInt; - -/// fast search of an integer position in an unsigned 64-bit integer array -// - Count is the number of QWord entries in P^ -// - returns index of P^[index]=Value -// - returns -1 if Value was not found -function QWordScanIndex(P: PQWordArray; Count: PtrInt; const Value: QWord): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// fast search of an unsigned integer in an integer array -// - returns true if P^=Value within Count entries -// - returns false if Value was not found -function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean; - -/// fast search of an integer value in a 64-bit integer array -// - returns true if P^=Value within Count entries -// - returns false if Value was not found -function Int64ScanExists(P: PInt64Array; Count: PtrInt; const Value: Int64): boolean; - -/// fast search of a pointer-sized unsigned integer position -// in an pointer-sized integer array -// - Count is the number of pointer-sized integer entries in P^ -// - return index of P^[index]=Value -// - return -1 if Value was not found -function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// fast search of a pointer-sized unsigned integer in an pointer-sized integer array -// - Count is the number of pointer-sized integer entries in P^ -// - returns true if P^=Value within Count entries -// - returns false if Value was not found -function PtrUIntScan(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): pointer; - {$ifdef HASINLINE}inline;{$endif} - -/// fast search of a pointer-sized unsigned integer position -// in an pointer-sized integer array -// - Count is the number of pointer-sized integer entries in P^ -// - returns true if P^=Value within Count entries -// - returns false if Value was not found -function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// fast search of an unsigned Byte value position in a Byte array -// - Count is the number of Byte entries in P^ -// - return index of P^[index]=Value -// - return -1 if Value was not found -function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: Byte): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// fast search of an unsigned Word value position in a Word array -// - Count is the number of Word entries in P^ -// - return index of P^[index]=Value -// - return -1 if Value was not found -function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// fast search of a binary value position in a fixed-size array -// - Count is the number of entries in P^[] -// - return index of P^[index]=Elem^, comparing ElemSize bytes -// - return -1 if Value was not found -function AnyScanIndex(P,Elem: pointer; Count,ElemSize: PtrInt): PtrInt; - -/// fast search of a binary value position in a fixed-size array -// - Count is the number of entries in P^[] -function AnyScanExists(P,Elem: pointer; Count,ElemSize: PtrInt): boolean; - -/// sort an Integer array, low values first -procedure QuickSortInteger(ID: PIntegerArray; L, R: PtrInt); overload; - -/// sort an Integer array, low values first -procedure QuickSortInteger(ID,CoValues: PIntegerArray; L, R: PtrInt); overload; - -/// sort an Integer array, low values first -procedure QuickSortInteger(var ID: TIntegerDynArray); overload; - -/// sort a 16 bit unsigned Integer array, low values first -procedure QuickSortWord(ID: PWordArray; L, R: PtrInt); - -/// sort a 64-bit signed Integer array, low values first -procedure QuickSortInt64(ID: PInt64Array; L, R: PtrInt); overload; - -/// sort a 64-bit unsigned Integer array, low values first -// - QWord comparison are implemented correctly under FPC or Delphi 2009+ - -// older compilers will use fast and exact SortDynArrayQWord() -procedure QuickSortQWord(ID: PQWordArray; L, R: PtrInt); overload; - -/// sort a 64-bit Integer array, low values first -procedure QuickSortInt64(ID,CoValues: PInt64Array; L, R: PtrInt); overload; - -type - /// event handler called by NotifySortedIntegerChanges() - // - Sender is an opaque const value, maybe a TObject or any pointer - TOnNotifySortedIntegerChange = procedure(const Sender; Value: integer) of object; - -/// compares two 32-bit signed sorted integer arrays, and call event handlers -// to notify the corresponding modifications in an O(n) time -// - items in both old[] and new[] arrays are required to be sorted -procedure NotifySortedIntegerChanges(old, new: PIntegerArray; oldn, newn: PtrInt; - const added, deleted: TOnNotifySortedIntegerChange; const sender); - -/// copy an integer array, then sort it, low values first -procedure CopyAndSortInteger(Values: PIntegerArray; ValuesCount: integer; - var Dest: TIntegerDynArray); - -/// copy an integer array, then sort it, low values first -procedure CopyAndSortInt64(Values: PInt64Array; ValuesCount: integer; - var Dest: TInt64DynArray); - -/// fast O(log(n)) binary search of an integer value in a sorted integer array -// - R is the last index of available integer entries in P^ (i.e. Count-1) -// - return index of P^[result]=Value -// - return -1 if Value was not found -function FastFindIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt; overload; - -/// fast O(log(n)) binary search of an integer value in a sorted integer array -// - return index of Values[result]=Value -// - return -1 if Value was not found -function FastFindIntegerSorted(const Values: TIntegerDynArray; Value: integer): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast O(log(n)) binary search of a 16 bit unsigned integer value in a sorted array -function FastFindWordSorted(P: PWordArray; R: PtrInt; Value: Word): PtrInt; - -/// fast O(log(n)) binary search of a 64-bit signed integer value in a sorted array -// - R is the last index of available integer entries in P^ (i.e. Count-1) -// - return index of P^[result]=Value -// - return -1 if Value was not found -function FastFindInt64Sorted(P: PInt64Array; R: PtrInt; const Value: Int64): PtrInt; overload; - -/// fast O(log(n)) binary search of a 64-bit unsigned integer value in a sorted array -// - R is the last index of available integer entries in P^ (i.e. Count-1) -// - return index of P^[result]=Value -// - return -1 if Value was not found -// - QWord comparison are implemented correctly under FPC or Delphi 2009+ - -// older compilers will fast and exact SortDynArrayQWord() -function FastFindQWordSorted(P: PQWordArray; R: PtrInt; const Value: QWord): PtrInt; overload; - -/// sort a PtrInt array, low values first -procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// fast O(log(n)) binary search of a PtrInt value in a sorted array -function FastFindPtrIntSorted(P: PPtrIntArray; R: PtrInt; Value: PtrInt): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// sort a pointer array, low values first -procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// fast O(log(n)) binary search of a Pointer value in a sorted array -function FastFindPointerSorted(P: PPointerArray; R: PtrInt; Value: Pointer): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// retrieve the index where to insert an integer value in a sorted integer array -// - R is the last index of available integer entries in P^ (i.e. Count-1) -// - returns -1 if the specified Value was found (i.e. adding will duplicate a value) -function FastLocateIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt; - -/// retrieve the index where to insert a word value in a sorted word array -// - R is the last index of available integer entries in P^ (i.e. Count-1) -// - returns -1 if the specified Value was found (i.e. adding will duplicate a value) -function FastLocateWordSorted(P: PWordArray; R: integer; Value: word): PtrInt; - -/// add an integer value in a sorted dynamic array of integers -// - returns the index where the Value was added successfully in Values[] -// - returns -1 if the specified Value was already present in Values[] -// (we must avoid any duplicate for O(log(n)) binary search) -// - if CoValues is set, its content will be moved to allow inserting a new -// value at CoValues[result] position -function AddSortedInteger(var Values: TIntegerDynArray; var ValuesCount: integer; - Value: integer; CoValues: PIntegerDynArray=nil): PtrInt; overload; - -/// add an integer value in a sorted dynamic array of integers -// - overloaded function which do not expect an external Count variable -function AddSortedInteger(var Values: TIntegerDynArray; - Value: integer; CoValues: PIntegerDynArray=nil): PtrInt; overload; - -/// insert an integer value at the specified index position of a dynamic array -// of integers -// - if Index is invalid, the Value is inserted at the end of the array -function InsertInteger(var Values: TIntegerDynArray; var ValuesCount: integer; - Value: Integer; Index: PtrInt; CoValues: PIntegerDynArray=nil): PtrInt; - -/// add an integer value at the end of a dynamic array of integers -// - returns TRUE if Value was added successfully in Values[], in this case -// length(Values) will be increased -function AddInteger(var Values: TIntegerDynArray; Value: integer; - NoDuplicates: boolean=false): boolean; overload; - -/// add an integer value at the end of a dynamic array of integers -// - this overloaded function will use a separate Count variable (faster) -// - it won't search for any existing duplicate -procedure AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; - Value: integer); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// add an integer array at the end of a dynamic array of integer -function AddInteger(var Values: TIntegerDynArray; const Another: TIntegerDynArray): PtrInt; overload; - -/// add an integer value at the end of a dynamic array of integers -// - this overloaded function will use a separate Count variable (faster), -// and would allow to search for duplicates -// - returns TRUE if Value was added successfully in Values[], in this case -// ValuesCount will be increased, but length(Values) would stay fixed most -// of the time (since it stores the Values[] array capacity) -function AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; - Value: integer; NoDuplicates: boolean): boolean; overload; - -/// add a 16-bit integer value at the end of a dynamic array of integers -function AddWord(var Values: TWordDynArray; var ValuesCount: integer; Value: Word): PtrInt; - -/// add a 64-bit integer value at the end of a dynamic array of integers -function AddInt64(var Values: TInt64DynArray; var ValuesCount: integer; Value: Int64): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// add a 64-bit integer value at the end of a dynamic array -function AddInt64(var Values: TInt64DynArray; Value: Int64): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// add a 64-bit integer array at the end of a dynamic array -function AddInt64(var Values: TInt64DynArray; const Another: TInt64DynArray): PtrInt; overload; - -/// if not already existing, add a 64-bit integer value to a dynamic array -function AddInt64Once(var Values: TInt64DynArray; Value: Int64): PtrInt; - -/// if not already existing, add a 64-bit integer value to a sorted dynamic array -procedure AddInt64Sorted(var Values: TInt64DynArray; Value: Int64); - -/// delete any 32-bit integer in Values[] -procedure DeleteInteger(var Values: TIntegerDynArray; Index: PtrInt); overload; - -/// delete any 32-bit integer in Values[] -procedure DeleteInteger(var Values: TIntegerDynArray; var ValuesCount: Integer; Index: PtrInt); overload; - -/// remove some 32-bit integer from Values[] -// - Excluded is declared as var, since it will be sorted in-place during process -// if it contains more than ExcludedSortSize items (i.e. if the sort is worth it) -procedure ExcludeInteger(var Values, Excluded: TIntegerDynArray; - ExcludedSortSize: Integer=32); - -/// ensure some 32-bit integer from Values[] will only contain Included[] -// - Included is declared as var, since it will be sorted in-place during process -// if it contains more than IncludedSortSize items (i.e. if the sort is worth it) -procedure IncludeInteger(var Values, Included: TIntegerDynArray; - IncludedSortSize: Integer=32); - -/// sort and remove any 32-bit duplicated integer from Values[] -procedure DeduplicateInteger(var Values: TIntegerDynArray); overload; - -/// sort and remove any 32-bit duplicated integer from Values[] -// - returns the new Values[] length -function DeduplicateInteger(var Values: TIntegerDynArray; Count: integer): integer; overload; - -/// low-level function called by DeduplicateInteger() -function DeduplicateIntegerSorted(val: PIntegerArray; last: PtrInt): PtrInt; - -/// create a new 32-bit integer dynamic array with the values from another one -procedure CopyInteger(const Source: TIntegerDynArray; out Dest: TIntegerDynArray); - -/// delete any 16-bit integer in Values[] -procedure DeleteWord(var Values: TWordDynArray; Index: PtrInt); - -/// delete any 64-bit integer in Values[] -procedure DeleteInt64(var Values: TInt64DynArray; Index: PtrInt); overload; - -/// delete any 64-bit integer in Values[] -procedure DeleteInt64(var Values: TInt64DynArray; var ValuesCount: Integer; Index: PtrInt); overload; - -/// remove some 64-bit integer from Values[] -// - Excluded is declared as var, since it will be sorted in-place during process -// if it contains more than ExcludedSortSize items (i.e. if the sort is worth it) -procedure ExcludeInt64(var Values, Excluded: TInt64DynArray; - ExcludedSortSize: Integer=32); - -/// ensure some 64-bit integer from Values[] will only contain Included[] -// - Included is declared as var, since it will be sorted in-place during process -// if it contains more than IncludedSortSize items (i.e. if the sort is worth it) -procedure IncludeInt64(var Values, Included: TInt64DynArray; - IncludedSortSize: Integer=32); - -/// sort and remove any 64-bit duplicated integer from Values[] -procedure DeduplicateInt64(var Values: TInt64DynArray); overload; - -/// sort and remove any 64-bit duplicated integer from Values[] -// - returns the new Values[] length -function DeduplicateInt64(var Values: TInt64DynArray; Count: integer): integer; overload; - -/// low-level function called by DeduplicateInt64() -// - warning: caller should ensure that last>0 -function DeduplicateInt64Sorted(val: PInt64Array; last: PtrInt): PtrInt; - -/// create a new 64-bit integer dynamic array with the values from another one -procedure CopyInt64(const Source: TInt64DynArray; out Dest: TInt64DynArray); - -/// find the maximum 32-bit integer in Values[] -function MaxInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt; - MaxStart: integer=-1): Integer; - -/// sum all 32-bit integers in Values[] -function SumInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt): Integer; - -/// fill already allocated Reversed[] so that Reversed[Values[i]]=i -procedure Reverse(const Values: TIntegerDynArray; ValuesCount: PtrInt; - Reversed: PIntegerArray); - -/// fill some values with i,i+1,i+2...i+Count-1 -procedure FillIncreasing(Values: PIntegerArray; StartValue: integer; Count: PtrUInt); - -/// copy some Int64 values into an unsigned integer array -procedure Int64ToUInt32(Values64: PInt64Array; Values32: PCardinalArray; Count: PtrInt); - -/// append the strings in the specified CSV text into a dynamic array of integer -procedure CSVToIntegerDynArray(CSV: PUTF8Char; var Result: TIntegerDynArray; - Sep: AnsiChar= ','); - -/// append the strings in the specified CSV text into a dynamic array of integer -procedure CSVToInt64DynArray(CSV: PUTF8Char; var Result: TInt64DynArray; - Sep: AnsiChar= ','); overload; - -/// convert the strings in the specified CSV text into a dynamic array of integer -function CSVToInt64DynArray(CSV: PUTF8Char; Sep: AnsiChar= ','): TInt64DynArray; overload; - -/// return the corresponding CSV text from a dynamic array of 32-bit integer -// - you can set some custom Prefix and Suffix text -function IntegerDynArrayToCSV(Values: PIntegerArray; ValuesCount: integer; - const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; - -/// return the corresponding CSV text from a dynamic array of 32-bit integer -// - you can set some custom Prefix and Suffix text -function IntegerDynArrayToCSV(const Values: TIntegerDynArray; - const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// return the corresponding CSV text from a dynamic array of 64-bit integers -// - you can set some custom Prefix and Suffix text -function Int64DynArrayToCSV(Values: PInt64Array; ValuesCount: integer; - const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; - -/// return the corresponding CSV text from a dynamic array of 64-bit integers -// - you can set some custom Prefix and Suffix text -function Int64DynArrayToCSV(const Values: TInt64DynArray; - const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; InlinedValue: boolean=false): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// quick helper to initialize a dynamic array of integer from some constants -// - can be used e.g. as: -// ! MyArray := TIntegerDynArrayFrom([1,2,3]); -// - see also FromI32() -function TIntegerDynArrayFrom(const Values: array of integer): TIntegerDynArray; - -/// quick helper to initialize a dynamic array of integer from 64-bit integers -// - will raise a ESynException if any Value[] can not fit into 32-bit, unless -// raiseExceptionOnOverflow is FALSE and the returned array slot is filled -// with maxInt/minInt -function TIntegerDynArrayFrom64(const Values: TInt64DynArray; - raiseExceptionOnOverflow: boolean=true): TIntegerDynArray; - -/// quick helper to initialize a dynamic array of 64-bit integers from 32-bit values -// - see also FromI64() for 64-bit signed integer values input -function TInt64DynArrayFrom(const Values: TIntegerDynArray): TInt64DynArray; - -/// quick helper to initialize a dynamic array of 64-bit integers from 32-bit values -// - see also FromU64() for 64-bit unsigned integer values input -function TQWordDynArrayFrom(const Values: TCardinalDynArray): TQWordDynArray; - -/// initializes a dynamic array from a set of 32-bit integer signed values -function FromI32(const Values: array of integer): TIntegerDynArray; - {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// initializes a dynamic array from a set of 32-bit integer unsigned values -function FromU32(const Values: array of cardinal): TCardinalDynArray; - {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// initializes a dynamic array from a set of 64-bit integer signed values -function FromI64(const Values: array of Int64): TInt64DynArray; - {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// initializes a dynamic array from a set of 64-bit integer unsigned values -function FromU64(const Values: array of QWord): TQWordDynArray; - {$ifdef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} - -type - /// used to store and retrieve Words in a sorted array - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}TSortedWordArray = record - {$else}TSortedWordArray = object{$endif} - public - /// the actual 16-bit word storage - Values: TWordDynArray; - /// how many items are currently in Values[] - Count: PtrInt; - /// add a value into the sorted array - // - return the index of the new inserted value into the Values[] array - // - return -(foundindex+1) if this value is already in the Values[] array - function Add(aValue: Word): PtrInt; - /// return the index if the supplied value in the Values[] array - // - return -1 if not found - function IndexOf(aValue: Word): PtrInt; {$ifdef HASINLINE}inline;{$endif} - end; - PSortedWordArray = ^TSortedWordArray; - - /// used to store and retrieve Integers in a sorted array - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}TSortedIntegerArray = record - {$else}TSortedIntegerArray = object{$endif} - public - /// the actual 32-bit integers storage - Values: TIntegerDynArray; - /// how many items are currently in Values[] - Count: PtrInt; - /// add a value into the sorted array - // - return the index of the new inserted value into the Values[] array - // - return -(foundindex+1) if this value is already in the Values[] array - function Add(aValue: integer): PtrInt; - /// return the index if the supplied value in the Values[] array - // - return -1 if not found - function IndexOf(aValue: integer): PtrInt; {$ifdef HASINLINE}inline;{$endif} - end; - PSortedIntegerArray = ^TSortedIntegerArray; - - /// comparison function as expected by MedianQuickSelect() - // - should return TRUE if Values[IndexA]>Values[IndexB] - TOnValueGreater = function(IndexA,IndexB: PtrInt): boolean of object; - -/// compute the median of an integer serie of values, using "Quickselect" -// - based on the algorithm described in "Numerical recipes in C", Second Edition, -// translated from Nicolas Devillard's C code: http://ndevilla.free.fr/median/median -// - warning: the supplied Integer array is modified in-place during the process, -// and won't be fully sorted on output (this is no QuickSort alternative) -function MedianQuickSelectInteger(Values: PIntegerArray; n: integer): integer; - -/// compute the median of a serie of values, using "Quickselect" -// - based on the algorithm described in "Numerical recipes in C", Second Edition -// - expect the values information to be available from a comparison callback -// - this version will use a temporary index list to exchange items order -// (supplied as a TSynTempBuffer), so won't change the supplied values themself -// - returns the index of the median Value -function MedianQuickSelect(const OnCompare: TOnValueGreater; n: integer; - var TempBuffer: TSynTempBuffer): integer; - -/// compute GCD of two integers using substraction-based Euclidean algorithm -function gcd(a, b: cardinal): cardinal; - -/// performs a QuickSort using a comparison callback -procedure QuickSortCompare(const OnCompare: TOnValueGreater; - Index: PIntegerArray; L,R: PtrInt); - -/// convert a cardinal into a 32-bit variable-length integer buffer -function ToVarUInt32(Value: cardinal; Dest: PByte): PByte; - -/// return the number of bytes necessary to store a 32-bit variable-length integer -// - i.e. the ToVarUInt32() buffer size -function ToVarUInt32Length(Value: PtrUInt): PtrUInt; - {$ifdef HASINLINE}inline;{$endif} - -/// return the number of bytes necessary to store some data with a its -// 32-bit variable-length integer legnth -function ToVarUInt32LengthWithData(Value: PtrUInt): PtrUInt; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an integer into a 32-bit variable-length integer buffer -// - store negative values as cardinal two-complement, i.e. -// 0=0,1=1,2=-1,3=2,4=-2... -function ToVarInt32(Value: PtrInt; Dest: PByte): PByte; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// convert a 32-bit variable-length integer buffer into a cardinal -// - fast inlined process for any number < 128 -// - use overloaded FromVarUInt32() or FromVarUInt32Safe() with a SourceMax -// pointer to avoid any potential buffer overflow -function FromVarUInt32(var Source: PByte): cardinal; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// safely convert a 32-bit variable-length integer buffer into a cardinal -// - slower but safer process checking out of boundaries memory access in Source -// - SourceMax is expected to be not nil, and to point to the first byte -// just after the Source memory buffer -// - returns nil on error, or point to next input data on successful decoding -function FromVarUInt32Safe(Source, SourceMax: PByte; out Value: cardinal): PByte; - -/// convert a 32-bit variable-length integer buffer into a cardinal -// - will call FromVarUInt32() if SourceMax=nil, or FromVarUInt32Safe() if set -// - returns false on error, true if Value has been set properly -function FromVarUInt32(var Source: PByte; SourceMax: PByte; out Value: cardinal): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a 32-bit variable-length integer buffer into a cardinal -// - this version could be called if number is likely to be > $7f, so it -// inlining the first byte won't make any benefit -function FromVarUInt32Big(var Source: PByte): cardinal; - -/// convert a 32-bit variable-length integer buffer into a cardinal -// - used e.g. when inlining FromVarUInt32() -// - this version must be called if Source^ has already been checked to be > $7f -// ! result := Source^; -// ! inc(Source); -// ! if result>$7f then -// ! result := (result and $7F) or FromVarUInt32Up128(Source); -function FromVarUInt32Up128(var Source: PByte): cardinal; - -/// convert a 32-bit variable-length integer buffer into a cardinal -// - this version must be called if Source^ has already been checked to be > $7f -function FromVarUInt32High(var Source: PByte): cardinal; - -/// convert a 32-bit variable-length integer buffer into an integer -// - decode negative values from cardinal two-complement, i.e. -// 0=0,1=1,2=-1,3=2,4=-2... -function FromVarInt32(var Source: PByte): integer; - -/// convert a UInt64 into a 64-bit variable-length integer buffer -function ToVarUInt64(Value: QWord; Dest: PByte): PByte; - -/// convert a 64-bit variable-length integer buffer into a UInt64 -function FromVarUInt64(var Source: PByte): QWord; overload; - -/// safely convert a 64-bit variable-length integer buffer into a UInt64 -// - slower but safer process checking out of boundaries memory access in Source -// - SourceMax is expected to be not nil, and to point to the first byte -// just after the Source memory buffer -// - returns nil on error, or point to next input data on successful decoding -function FromVarUInt64Safe(Source, SourceMax: PByte; out Value: QWord): PByte; - -/// convert a 64-bit variable-length integer buffer into a UInt64 -// - will call FromVarUInt64() if SourceMax=nil, or FromVarUInt64Safe() if set -// - returns false on error, true if Value has been set properly -function FromVarUInt64(var Source: PByte; SourceMax: PByte; out Value: Qword): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a Int64 into a 64-bit variable-length integer buffer -function ToVarInt64(Value: Int64; Dest: PByte): PByte; {$ifdef HASINLINE}inline;{$endif} - -/// convert a 64-bit variable-length integer buffer into a Int64 -function FromVarInt64(var Source: PByte): Int64; - -/// convert a 64-bit variable-length integer buffer into a Int64 -// - this version won't update the Source pointer -function FromVarInt64Value(Source: PByte): Int64; - -/// jump a value in the 32-bit or 64-bit variable-length integer buffer -function GotoNextVarInt(Source: PByte): pointer; {$ifdef HASINLINE}inline;{$endif} - -/// convert a RawUTF8 into an UTF-8 encoded variable-length buffer -function ToVarString(const Value: RawUTF8; Dest: PByte): PByte; - -/// jump a value in variable-length text buffer -function GotoNextVarString(Source: PByte): pointer; {$ifdef HASINLINE}inline;{$endif} - -/// retrieve a variable-length UTF-8 encoded text buffer in a newly allocation RawUTF8 -function FromVarString(var Source: PByte): RawUTF8; overload; - -/// safe retrieve a variable-length UTF-8 encoded text buffer in a newly allocation RawUTF8 -// - supplied SourceMax value will avoid any potential buffer overflow -function FromVarString(var Source: PByte; SourceMax: PByte): RawUTF8; overload; - -/// retrieve a variable-length text buffer -// - this overloaded function will set the supplied code page to the AnsiString -procedure FromVarString(var Source: PByte; var Value: RawByteString; - CodePage: integer); overload; - -/// retrieve a variable-length text buffer -// - this overloaded function will set the supplied code page to the AnsiString -// and will also check for the SourceMax end of buffer -// - returns TRUE on success, or FALSE on any buffer overload detection -function FromVarString(var Source: PByte; SourceMax: PByte; - var Value: RawByteString; CodePage: integer): boolean; overload; - -/// retrieve a variable-length UTF-8 encoded text buffer in a temporary buffer -// - caller should call Value.Done after use of the Value.buf memory -// - this overloaded function would include a trailing #0, so Value.buf could -// be parsed as a valid PUTF8Char buffer (e.g. containing JSON) -procedure FromVarString(var Source: PByte; var Value: TSynTempBuffer); overload; - -/// retrieve a variable-length UTF-8 encoded text buffer in a temporary buffer -// - caller should call Value.Done after use of the Value.buf memory -// - this overloaded function will also check for the SourceMax end of buffer, -// returning TRUE on success, or FALSE on any buffer overload detection -function FromVarString(var Source: PByte; SourceMax: PByte; - var Value: TSynTempBuffer): boolean; overload; - -type - /// kind of result returned by FromVarBlob() function - TValueResult = record - /// start of data value - Ptr: PAnsiChar; - /// value length (in bytes) - Len: PtrInt; - end; - -/// retrieve pointer and length to a variable-length text/blob buffer -function FromVarBlob(Data: PByte): TValueResult; {$ifdef HASINLINE}inline;{$endif} - - - -{ ************ low-level RTTI types and conversion routines ***************** } - -type - /// specify ordinal (tkInteger and tkEnumeration) storage size and sign - // - note: Int64 is stored as its own TTypeKind, not as tkInteger - TOrdType = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong - {$ifdef FPC_NEWRTTI},otSQWord,otUQWord{$endif}); - - /// specify floating point (ftFloat) storage size and precision - // - here ftDouble is renamed ftDoub to avoid confusion with TSQLDBFieldType - TFloatType = (ftSingle,ftDoub,ftExtended,ftComp,ftCurr); - -{$ifdef FPC} - /// available type families for FPC RTTI values - // - values differs from Delphi, and are taken from FPC typinfo.pp unit - // - here below, we defined tkLString instead of tkAString to match Delphi - - // see https://lists.freepascal.org/pipermail/fpc-devel/2013-June/032360.html - // "Compiler uses internally some LongStrings which is not possible to use - // for variable declarations" so tkLStringOld seems never used in practice - TTypeKind = (tkUnknown,tkInteger,tkChar,tkEnumeration,tkFloat, - tkSet,tkMethod,tkSString,tkLStringOld{=tkLString},tkLString{=tkAString}, - tkWString,tkVariant,tkArray,tkRecord,tkInterface, - tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord, - tkDynArray,tkInterfaceRaw,tkProcVar,tkUString,tkUChar, - tkHelper,tkFile,tkClassRef,tkPointer); - -const - /// potentially managed types in TTypeKind RTTI enumerate - // - should match ManagedType*() functions - tkManagedTypes = [tkLStringOld,tkLString,tkWstring,tkUstring,tkArray, - tkObject,tkRecord,tkDynArray,tkInterface,tkVariant]; - /// maps record or object in TTypeKind RTTI enumerate - tkRecordTypes = [tkObject,tkRecord]; - /// maps record or object in TTypeKind RTTI enumerate - tkRecordKinds = [tkObject,tkRecord]; - -type - /// TTypeKind RTTI enumerate as defined in Delphi 6 and up - TDelphiTypeKind = (dkUnknown, dkInteger, dkChar, dkEnumeration, dkFloat, - dkString, dkSet, dkClass, dkMethod, dkWChar, dkLString, dkWString, - dkVariant, dkArray, dkRecord, dkInterface, dkInt64, dkDynArray, - dkUString, dkClassRef, dkPointer, dkProcedure); - -const - /// convert FPC's TTypeKind to Delphi's RTTI enumerate - // - used internally for cross-compiler TDynArray binary serialization - FPCTODELPHI: array[TTypeKind] of TDelphiTypeKind = ( - dkUnknown,dkInteger,dkChar,dkEnumeration,dkFloat, - dkSet,dkMethod,dkString,dkLString,dkLString, - dkWString,dkVariant,dkArray,dkRecord,dkInterface, - dkClass,dkRecord,dkWChar,dkEnumeration,dkInt64,dkInt64, - dkDynArray,dkInterface,dkProcedure,dkUString,dkWChar, - dkPointer,dkPointer,dkClassRef,dkPointer); - - /// convert Delphi's TTypeKind to FPC's RTTI enumerate - DELPHITOFPC: array[TDelphiTypeKind] of TTypeKind = ( - tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, - tkSString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString, - tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray, - tkUString, tkClassRef, tkPointer, tkProcVar); - -{$else} - /// available type families for Delphi 6 and up, similar to typinfo.pas - // - redefined here to be shared between SynCommons.pas and mORMot.pas, - // also leveraging FPC compatibility as much as possible (FPC's typinfo.pp - // is not convenient to share code with Delphi - see e.g. its tkLString) - TTypeKind = (tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, - tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString, - tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray - {$ifdef UNICODE}, tkUString, tkClassRef, tkPointer, tkProcedure{$endif}); - -const - /// maps record or object in TTypeKind RTTI enumerate - tkRecordTypes = [tkRecord]; - /// maps record or object in TTypeKind RTTI enumerate - tkRecordKinds = tkRecord; - -{$endif FPC} - - /// maps long string in TTypeKind RTTI enumerate - tkStringTypes = - [tkLString, {$ifdef FPC}tkLStringOld,{$endif} tkWString - {$ifdef HASVARUSTRING}, tkUString{$endif}]; - /// maps 1, 8, 16, 32 and 64-bit ordinal in TTypeKind RTTI enumerate - tkOrdinalTypes = - [tkInteger, tkChar, tkWChar, tkEnumeration, tkSet, tkInt64 - {$ifdef FPC},tkBool,tkQWord{$endif}]; - /// quick retrieve how many bytes an ordinal consist in - ORDTYPE_SIZE: array[TOrdType] of byte = - (1,1,2,2,4,4{$ifdef FPC_NEWRTTI},8,8{$endif}); - -type - PTypeKind = ^TTypeKind; - TTypeKinds = set of TTypeKind; - POrdType = ^TOrdType; - PFloatType = ^TFloatType; - -function ToText(k: TTypeKind): PShortString; overload; - -type - /// function prototype to be used for TDynArray Sort and Find method - // - common functions exist for base types: see e.g. SortDynArrayBoolean, - // SortDynArrayByte, SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal, - // SortDynArrayInt64, SortDynArrayQWord, SordDynArraySingle, SortDynArrayDouble, - // SortDynArrayAnsiString, SortDynArrayAnsiStringI, SortDynArrayUnicodeString, - // SortDynArrayUnicodeStringI, SortDynArrayString, SortDynArrayStringI - // - any custom type (even records) can be compared then sort by defining - // such a custom function - // - must return 0 if A=B, -1 if AB - TDynArraySortCompare = function(const A,B): integer; - - /// event oriented version of TDynArraySortCompare - TEventDynArraySortCompare = function(const A,B): integer of object; - - /// optional event called by TDynArray.LoadFrom method after each item load - // - could be used e.g. for string interning or some custom initialization process - // - won't be called if the dynamic array has ElemType=nil - TDynArrayAfterLoadFrom = procedure(var A) of object; - - /// internal enumeration used to specify some standard Delphi arrays - // - will be used e.g. to match JSON serialization or TDynArray search - // (see TDynArray and TDynArrayHash InitSpecific method) - // - djBoolean would generate an array of JSON boolean values - // - djByte .. djTimeLog match numerical JSON values - // - djDateTime .. djHash512 match textual JSON values - // - djVariant will match standard variant JSON serialization (including - // TDocVariant or other custom types, if any) - // - djCustom will be used for registered JSON serializer (invalid for - // InitSpecific methods call) - // - see also djPointer and djObject constant aliases for a pointer or - // TObject field hashing / comparison - // - is used also by TDynArray.InitSpecific() to define the main field type - TDynArrayKind = ( - djNone, - djBoolean, djByte, djWord, djInteger, djCardinal, djSingle, - djInt64, djQWord, djDouble, djCurrency, djTimeLog, - djDateTime, djDateTimeMS, djRawUTF8, djWinAnsi, djString, - djRawByteString, djWideString, djSynUnicode, - djHash128, djHash256, djHash512, - djInterface, {$ifndef NOVARIANTS}djVariant,{$endif} - djCustom); - - /// internal set to specify some standard Delphi arrays - TDynArrayKinds = set of TDynArrayKind; - - /// cross-compiler type used for string reference counter - // - FPC and Delphi don't always use the same type - TStrCnt = {$ifdef STRCNT32} longint {$else} SizeInt {$endif}; - /// pointer to cross-compiler type used for string reference counter - PStrCnt = ^TStrCnt; - - /// cross-compiler type used for dynarray reference counter - // - FPC uses PtrInt/SizeInt, Delphi uses longint even on CPU64 - TDACnt = {$ifdef DACNT32} longint {$else} SizeInt {$endif}; - /// pointer to cross-compiler type used for dynarray reference counter - PDACnt = ^TDACnt; - - /// internal integer type used for string header length field - TStrLen = {$ifdef FPC}SizeInt{$else}longint{$endif}; - /// internal pointer integer type used for string header length field - PStrLen = ^TStrLen; - - /// internal pointer integer type used for dynamic array header length field - PDALen = PPtrInt; - -{$ifdef FPC} - /// map the Delphi/FPC dynamic array header (stored before each instance) - // - define globally for proper inlining with FPC - // - match tdynarray type definition in dynarr.inc - TDynArrayRec = {packed} record - /// dynamic array reference count (basic memory management mechanism) - refCnt: TDACnt; - /// equals length-1 - high: tdynarrayindex; - function GetLength: sizeint; inline; - procedure SetLength(len: sizeint); inline; - property length: sizeint read GetLength write SetLength; - end; - PDynArrayRec = ^TDynArrayRec; -{$endif FPC} - -const - /// cross-compiler negative offset to TStrRec.length field - // - to be used inlined e.g. as PStrLen(p-_STRLEN)^ - _STRLEN = SizeOf(TStrLen); - /// cross-compiler negative offset to TStrRec.refCnt field - // - to be used inlined e.g. as PStrCnt(p-_STRREFCNT)^ - _STRREFCNT = Sizeof(TStrCnt)+_STRLEN; - - /// cross-compiler negative offset to TDynArrayRec.high/length field - // - to be used inlined e.g. as PDALen(PtrUInt(Values)-_DALEN)^{$ifdef FPC}+1{$endif} - _DALEN = SizeOf(PtrInt); - /// cross-compiler negative offset to TDynArrayRec.refCnt field - // - to be used inlined e.g. as PDACnt(PtrUInt(Values)-_DAREFCNT)^ - _DAREFCNT = Sizeof(TDACnt)+_DALEN; - -function ToText(k: TDynArrayKind): PShortString; overload; - -{$ifndef NOVARIANTS} - -type - /// possible options for a TDocVariant JSON/BSON document storage - // - dvoIsArray and dvoIsObject will store the "Kind: TDocVariantKind" state - - // you should never have to define these two options directly - // - dvoNameCaseSensitive will be used for every name lookup - here - // case-insensitivity is restricted to a-z A-Z 0-9 and _ characters - // - dvoCheckForDuplicatedNames will be used for method - // TDocVariantData.AddValue(), but not when setting properties at - // variant level: for consistency, "aVariant.AB := aValue" will replace - // any previous value for the name "AB" - // - dvoReturnNullForUnknownProperty will be used when retrieving any value - // from its name (for dvObject kind of instance), or index (for dvArray or - // dvObject kind of instance) - // - by default, internal values will be copied by-value from one variant - // instance to another, to ensure proper safety - but it may be too slow: - // if you set dvoValueCopiedByReference, the internal - // TDocVariantData.VValue/VName instances will be copied by-reference, - // to avoid memory allocations, BUT it may break internal process if you change - // some values in place (since VValue/VName and VCount won't match) - as such, - // if you set this option, ensure that you use the content as read-only - // - any registered custom types may have an extended JSON syntax (e.g. - // TBSONVariant does for MongoDB types), and will be searched during JSON - // parsing, unless dvoJSONParseDoNotTryCustomVariants is set (slightly faster) - // - by default, it will only handle direct JSON [array] of {object}: but if - // you define dvoJSONObjectParseWithinString, it will also try to un-escape - // a JSON string first, i.e. handle "[array]" or "{object}" content (may be - // used e.g. when JSON has been retrieved from a database TEXT column) - is - // used for instance by VariantLoadJSON() - // - JSON serialization will follow the standard layout, unless - // dvoSerializeAsExtendedJson is set so that the property names would not - // be escaped with double quotes, writing '{name:"John",age:123}' instead of - // '{"name":"John","age":123}': this extended json layout is compatible with - // http://docs.mongodb.org/manual/reference/mongodb-extended-json and with - // TDocVariant JSON unserialization, also our SynCrossPlatformJSON unit, but - // NOT recognized by most JSON clients, like AJAX/JavaScript or C#/Java - // - by default, only integer/Int64/currency number values are allowed, unless - // dvoAllowDoubleValue is set and 32-bit floating-point conversion is tried, - // with potential loss of precision during the conversion - // - dvoInternNames and dvoInternValues will use shared TRawUTF8Interning - // instances to maintain a list of RawUTF8 names/values for all TDocVariant, - // so that redundant text content will be allocated only once on heap - TDocVariantOption = - (dvoIsArray, dvoIsObject, - dvoNameCaseSensitive, dvoCheckForDuplicatedNames, - dvoReturnNullForUnknownProperty, - dvoValueCopiedByReference, dvoJSONParseDoNotTryCustomVariants, - dvoJSONObjectParseWithinString, dvoSerializeAsExtendedJson, - dvoAllowDoubleValue, dvoInternNames, dvoInternValues); - - /// set of options for a TDocVariant storage - // - you can use JSON_OPTIONS[true] if you want to create a fast by-reference - // local document as with _ObjFast/_ArrFast/_JsonFast - i.e. - // [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference] - // - when specifying the options, you should not include dvoIsArray nor - // dvoIsObject directly in the set, but explicitly define TDocVariantDataKind - TDocVariantOptions = set of TDocVariantOption; - - /// pointer to a set of options for a TDocVariant storage - // - you may use e.g. @JSON_OPTIONS[true], @JSON_OPTIONS[false], - // @JSON_OPTIONS_FAST_STRICTJSON or @JSON_OPTIONS_FAST_EXTENDED - PDocVariantOptions = ^TDocVariantOptions; - -const - /// some convenient TDocVariant options, as JSON_OPTIONS[CopiedByReference] - // - JSON_OPTIONS[false] is e.g. _Json() and _JsonFmt() functions default - // - JSON_OPTIONS[true] are used e.g. by _JsonFast() and _JsonFastFmt() functions - // - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency - JSON_OPTIONS: array[Boolean] of TDocVariantOptions = ( - [dvoReturnNullForUnknownProperty], - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]); - - /// same as JSON_OPTIONS[true], but can not be used as PDocVariantOptions - // - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency - // - as used by _JsonFast() - JSON_OPTIONS_FAST = - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference]; - - /// same as JSON_OPTIONS_FAST, but including dvoAllowDoubleValue to parse any float - // - as used by _JsonFastFloat() - JSON_OPTIONS_FAST_FLOAT = - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference,dvoAllowDoubleValue]; - - /// TDocVariant options which may be used for plain JSON parsing - // - this won't recognize any extended syntax - JSON_OPTIONS_FAST_STRICTJSON: TDocVariantOptions = - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, - dvoJSONParseDoNotTryCustomVariants]; - - /// TDocVariant options to be used for case-sensitive TSynNameValue-like - // storage, with optional extended JSON syntax serialization - // - consider using JSON_OPTIONS_FAST_EXTENDED for case-insensitive objects - JSON_OPTIONS_NAMEVALUE: array[boolean] of TDocVariantOptions = ( - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, - dvoNameCaseSensitive], - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, - dvoNameCaseSensitive,dvoSerializeAsExtendedJson]); - - /// TDocVariant options to be used for case-sensitive TSynNameValue-like - // storage, RawUTF8 interning and optional extended JSON syntax serialization - // - consider using JSON_OPTIONS_FAST_EXTENDED for case-insensitive objects, - // or JSON_OPTIONS_NAMEVALUE[] if you don't expect names and values interning - JSON_OPTIONS_NAMEVALUEINTERN: array[boolean] of TDocVariantOptions = ( - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, - dvoNameCaseSensitive,dvoInternNames,dvoInternValues], - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, - dvoNameCaseSensitive,dvoInternNames,dvoInternValues, - dvoSerializeAsExtendedJson]); - - /// TDocVariant options to be used so that JSON serialization would - // use the unquoted JSON syntax for field names - // - you could use it e.g. on a TSQLRecord variant published field to - // reduce the JSON escape process during storage in the database, by - // customizing your TSQLModel instance: - // ! (aModel.Props[TSQLMyRecord]['VariantProp'] as TSQLPropInfoRTTIVariant). - // ! DocVariantOptions := JSON_OPTIONS_FAST_EXTENDED; - // or - in a cleaner way - by overriding TSQLRecord.InternalDefineModel(): - // ! class procedure TSQLMyRecord.InternalDefineModel(Props: TSQLRecordProperties); - // ! begin - // ! (Props.Fields.ByName('VariantProp') as TSQLPropInfoRTTIVariant). - // ! DocVariantOptions := JSON_OPTIONS_FAST_EXTENDED; - // ! end; - // or to set all variant fields at once: - // ! class procedure TSQLMyRecord.InternalDefineModel(Props: TSQLRecordProperties); - // ! begin - // ! Props.SetVariantFieldsDocVariantOptions(JSON_OPTIONS_FAST_EXTENDED); - // ! end; - // - consider using JSON_OPTIONS_NAMEVALUE[true] for case-sensitive - // TSynNameValue-like storage, or JSON_OPTIONS_FAST_EXTENDEDINTERN if you - // expect RawUTF8 names and values interning - JSON_OPTIONS_FAST_EXTENDED: TDocVariantOptions = - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, - dvoSerializeAsExtendedJson]; - - /// TDocVariant options for JSON serialization with efficient storage - // - i.e. unquoted JSON syntax for field names and RawUTF8 interning - // - may be used e.g. for efficient persistence of similar data - // - consider using JSON_OPTIONS_FAST_EXTENDED if you don't expect - // RawUTF8 names and values interning, or need BSON variants parsing - JSON_OPTIONS_FAST_EXTENDEDINTERN: TDocVariantOptions = - [dvoReturnNullForUnknownProperty,dvoValueCopiedByReference, - dvoSerializeAsExtendedJson,dvoJSONParseDoNotTryCustomVariants, - dvoInternNames,dvoInternValues]; - -{$endif NOVARIANTS} - -const - /// TDynArrayKind alias for a pointer field hashing / comparison - djPointer = {$ifdef CPU64}djInt64{$else}djCardinal{$endif}; - - /// TDynArrayKind alias for a TObject field hashing / comparison - djObject = djPointer; - -type - /// the available JSON format, for TTextWriter.AddJSONReformat() and its - // JSONBufferReformat() and JSONReformat() wrappers - // - jsonCompact is the default machine-friendly single-line layout - // - jsonHumanReadable will add line feeds and indentation, for a more - // human-friendly result - // - jsonUnquotedPropName will emit the jsonHumanReadable layout, but - // with all property names being quoted only if necessary: this format - // could be used e.g. for configuration files - this format, similar to the - // one used in the MongoDB extended syntax, is not JSON compatible: do not - // use it e.g. with AJAX clients, but is would be handled as expected by all - // our units as valid JSON input, without previous correction - // - jsonUnquotedPropNameCompact will emit single-line layout with unquoted - // property names - TTextWriterJSONFormat = ( - jsonCompact, jsonHumanReadable, - jsonUnquotedPropName, jsonUnquotedPropNameCompact); - - TDynArrayObjArray = (oaUnknown, oaFalse, oaTrue); - - /// a wrapper around a dynamic array with one dimension - // - provide TList-like methods using fast RTTI information - // - can be used to fast save/retrieve all memory content to a TStream - // - note that the "const Elem" is not checked at compile time nor runtime: - // you must ensure that Elem matchs the element type of the dynamic array - // - can use external Count storage to make Add() and Delete() much faster - // (avoid most reallocation of the memory buffer) - // - Note that TDynArray is just a wrapper around an existing dynamic array: - // methods can modify the content of the associated variable but the TDynArray - // doesn't contain any data by itself. It is therefore aimed to initialize - // a TDynArray wrapper on need, to access any existing dynamic array. - // - is defined as an object or as a record, due to a bug - // in Delphi 2009/2010 compiler (at least): this structure is not initialized - // if defined as an object on the stack, but will be as a record :( - {$ifdef UNDIRECTDYNARRAY}TDynArray = record - {$else}TDynArray = object {$endif} - private - fValue: PPointer; - fTypeInfo: pointer; - fElemType{$ifdef DYNARRAYELEMTYPE2}, fElemType2{$endif}: pointer; - fCountP: PInteger; - fCompare: TDynArraySortCompare; - fElemSize: cardinal; - fKnownSize: integer; - fParser: integer; // index to GlobalJSONCustomParsers.fParsers[] - fSorted: boolean; - fKnownType: TDynArrayKind; - fIsObjArray: TDynArrayObjArray; - function GetCount: PtrInt; {$ifdef HASINLINE}inline;{$endif} - procedure SetCount(aCount: PtrInt); - function GetCapacity: PtrInt; {$ifdef HASINLINE}inline;{$endif} - procedure SetCapacity(aCapacity: PtrInt); - procedure SetCompare(const aCompare: TDynArraySortCompare); {$ifdef HASINLINE}inline;{$endif} - function FindIndex(const Elem; aIndex: PIntegerDynArray; - aCompare: TDynArraySortCompare): PtrInt; - function GetArrayTypeName: RawUTF8; - function GetArrayTypeShort: PShortString; - function GetIsObjArray: boolean; {$ifdef HASINLINE}inline;{$endif} - function ComputeIsObjArray: boolean; - procedure SetIsObjArray(aValue: boolean); {$ifdef HASINLINE}inline;{$endif} - function LoadFromHeader(var Source: PByte; SourceMax: PByte): integer; - function LoadKnownType(Data,Source,SourceMax: PAnsiChar): boolean; - /// faster than RTL + handle T*ObjArray + ensure unique - procedure InternalSetLength(OldLength,NewLength: PtrUInt); - public - /// initialize the wrapper with a one-dimension dynamic array - // - the dynamic array must have been defined with its own type - // (e.g. TIntegerDynArray = array of Integer) - // - if aCountPointer is set, it will be used instead of length() to store - // the dynamic array items count - it will be much faster when adding - // elements to the array, because the dynamic array won't need to be - // resized each time - but in this case, you should use the Count property - // instead of length(array) or high(array) when accessing the data: in fact - // length(array) will store the memory size reserved, not the items count - // - if aCountPointer is set, its content will be set to 0, whatever the - // array length is, or the current aCountPointer^ value is - // - a sample usage may be: - // !var DA: TDynArray; - // ! A: TIntegerDynArray; - // !begin - // ! DA.Init(TypeInfo(TIntegerDynArray),A); - // ! (...) - // - a sample usage may be (using a count variable): - // !var DA: TDynArray; - // ! A: TIntegerDynArray; - // ! ACount: integer; - // ! i: integer; - // !begin - // ! DA.Init(TypeInfo(TIntegerDynArray),A,@ACount); - // ! for i := 1 to 100000 do - // ! DA.Add(i); // MUCH faster using the ACount variable - // ! (...) // now you should use DA.Count or Count instead of length(A) - procedure Init(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil); - /// initialize the wrapper with a one-dimension dynamic array - // - this version accepts to specify how comparison should occur, using - // TDynArrayKind kind of first field - // - djNone and djCustom are too vague, and will raise an exception - // - no RTTI check is made over the corresponding array layout: you shall - // ensure that the aKind parameter matches the dynamic array element definition - // - aCaseInsensitive will be used for djRawUTF8..djHash512 text comparison - procedure InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind; - aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false); - /// define the reference to an external count integer variable - // - Init and InitSpecific methods will reset the aCountPointer to 0: you - // can use this method to set the external count variable without overriding - // the current value - procedure UseExternalCount(var aCountPointer: Integer); - {$ifdef HASINLINE}inline;{$endif} - /// low-level computation of KnownType and KnownSize fields from RTTI - // - do nothing if has already been set at initialization, or already computed - function GuessKnownType(exactType: boolean=false): TDynArrayKind; - /// check this dynamic array from the GlobalJSONCustomParsers list - // - returns TRUE if this array has a custom JSON parser - function HasCustomJSONParser: boolean; - /// initialize the wrapper to point to no dynamic array - procedure Void; - /// check if the wrapper points to a dynamic array - function IsVoid: boolean; - /// add an element to the dynamic array - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write Add(i+10) e.g.) - // - returns the index of the added element in the dynamic array - // - note that because of dynamic array internal memory managment, adding - // may reallocate the list every time a record is added, unless an external - // count variable has been specified in Init(...,@Count) method - function Add(const Elem): PtrInt; - /// add an element to the dynamic array - // - this version add a void element to the array, and returns its index - // - note: if you use this method to add a new item with a reference to the - // dynamic array, using a local variable is needed under FPC: - // ! i := DynArray.New; - // ! with Values[i] do begin // otherwise Values is nil -> GPF - // ! Field1 := 1; - // ! ... - function New: integer; - /// add an element to the dynamic array at the position specified by Index - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write Insert(10,i+10) e.g.) - procedure Insert(Index: PtrInt; const Elem); - /// get and remove the last element stored in the dynamic array - // - Add + Pop/Peek will implement a LIFO (Last-In-First-Out) stack - // - warning: Elem must be of the same exact type than the dynamic array - // - returns true if the item was successfully copied and removed - // - use Peek() if you don't want to remove the item - function Pop(var Dest): boolean; - /// get the last element stored in the dynamic array - // - Add + Pop/Peek will implement a LIFO (Last-In-First-Out) stack - // - warning: Elem must be of the same exact type than the dynamic array - // - returns true if the item was successfully copied into Dest - // - use Pop() if you also want to remove the item - function Peek(var Dest): boolean; - /// delete the whole dynamic array content - // - this method will recognize T*ObjArray types and free all instances - procedure Clear; {$ifdef HASINLINE}inline;{$endif} - /// delete the whole dynamic array content, ignoring exceptions - // - returns true if no exception occured when calling Clear, false otherwise - // - you should better not call this method, which will catch and ignore - // all exceptions - but it may somewhat make sense in a destructor - // - this method will recognize T*ObjArray types and free all instances - function ClearSafe: boolean; - /// delete one item inside the dynamic array - // - the deleted element is finalized if necessary - // - this method will recognize T*ObjArray types and free all instances - function Delete(aIndex: PtrInt): boolean; - /// search for an element value inside the dynamic array - // - return the index found (0..Count-1), or -1 if Elem was not found - // - will search for all properties content of the eLement: TList.IndexOf() - // searches by address, this method searches by content using the RTTI - // element description (and not the Compare property function) - // - use the Find() method if you want the search via the Compare property - // function, or e.g. to search only with some part of the element content - // - will work with simple types: binaries (byte, word, integer, Int64, - // Currency, array[0..255] of byte, packed records with no reference-counted - // type within...), string types (e.g. array of string), and packed records - // with binary and string types within (like TFileVersion) - // - won't work with not packed types (like a shorstring, or a record - // with byte or word fields with {$A+}): in this case, the padding data - // (i.e. the bytes between the aligned feeds can be filled as random, and - // there is no way with standard RTTI do know which they are) - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write IndexOf(i+10) e.g.) - function IndexOf(const Elem): PtrInt; - /// search for an element value inside the dynamic array - // - this method will use the Compare property function for the search - // - return the index found (0..Count-1), or -1 if Elem was not found - // - if the array is sorted, it will use fast O(log(n)) binary search - // - if the array is not sorted, it will use slower O(n) iterating search - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write Find(i+10) e.g.) - function Find(const Elem): PtrInt; overload; - /// search for an element value inside the dynamic array, from an external - // indexed lookup table - // - return the index found (0..Count-1), or -1 if Elem was not found - // - this method will use a custom comparison function, with an external - // integer table, as created by the CreateOrderedIndex() method: it allows - // multiple search orders in the same dynamic array content - // - if an indexed lookup is supplied, it must already be sorted: - // this function will then use fast O(log(n)) binary search - // - if an indexed lookup is not supplied (i.e aIndex=nil), - // this function will use slower but accurate O(n) iterating search - // - warning; the lookup index should be synchronized if array content - // is modified (in case of adding or deletion) - function Find(const Elem; const aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare): PtrInt; overload; - /// search for an element value, then fill all properties if match - // - this method will use the Compare property function for the search, - // or the supplied indexed lookup table and its associated compare function - // - if Elem content matches, all Elem fields will be filled with the record - // - can be used e.g. as a simple dictionary: if Compare will match e.g. the - // first string field (i.e. set to SortDynArrayString), you can fill the - // first string field with the searched value (if returned index is >= 0) - // - return the index found (0..Count-1), or -1 if Elem was not found - // - if the array is sorted, it will use fast O(log(n)) binary search - // - if the array is not sorted, it will use slower O(n) iterating search - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write Find(i+10) e.g.) - function FindAndFill(var Elem; aIndex: PIntegerDynArray=nil; - aCompare: TDynArraySortCompare=nil): integer; - /// search for an element value, then delete it if match - // - this method will use the Compare property function for the search, - // or the supplied indexed lookup table and its associated compare function - // - if Elem content matches, this item will be deleted from the array - // - can be used e.g. as a simple dictionary: if Compare will match e.g. the - // first string field (i.e. set to SortDynArrayString), you can fill the - // first string field with the searched value (if returned index is >= 0) - // - return the index deleted (0..Count-1), or -1 if Elem was not found - // - if the array is sorted, it will use fast O(log(n)) binary search - // - if the array is not sorted, it will use slower O(n) iterating search - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write Find(i+10) e.g.) - function FindAndDelete(const Elem; aIndex: PIntegerDynArray=nil; - aCompare: TDynArraySortCompare=nil): integer; - /// search for an element value, then update the item if match - // - this method will use the Compare property function for the search, - // or the supplied indexed lookup table and its associated compare function - // - if Elem content matches, this item will be updated with the supplied value - // - can be used e.g. as a simple dictionary: if Compare will match e.g. the - // first string field (i.e. set to SortDynArrayString), you can fill the - // first string field with the searched value (if returned index is >= 0) - // - return the index found (0..Count-1), or -1 if Elem was not found - // - if the array is sorted, it will use fast O(log(n)) binary search - // - if the array is not sorted, it will use slower O(n) iterating search - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write Find(i+10) e.g.) - function FindAndUpdate(const Elem; aIndex: PIntegerDynArray=nil; - aCompare: TDynArraySortCompare=nil): integer; - /// search for an element value, then add it if none matched - // - this method will use the Compare property function for the search, - // or the supplied indexed lookup table and its associated compare function - // - if no Elem content matches, the item will added to the array - // - can be used e.g. as a simple dictionary: if Compare will match e.g. the - // first string field (i.e. set to SortDynArrayString), you can fill the - // first string field with the searched value (if returned index is >= 0) - // - return the index found (0..Count-1), or -1 if Elem was not found and - // the supplied element has been succesfully added - // - if the array is sorted, it will use fast O(log(n)) binary search - // - if the array is not sorted, it will use slower O(n) iterating search - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write Find(i+10) e.g.) - function FindAndAddIfNotExisting(const Elem; aIndex: PIntegerDynArray=nil; - aCompare: TDynArraySortCompare=nil): integer; - /// sort the dynamic array elements, using the Compare property function - // - it will change the dynamic array content, and exchange all elements - // in order to be sorted in increasing order according to Compare function - procedure Sort(aCompare: TDynArraySortCompare=nil); overload; - /// sort some dynamic array elements, using the Compare property function - // - this method allows to sort only some part of the items - // - it will change the dynamic array content, and exchange all elements - // in order to be sorted in increasing order according to Compare function - procedure SortRange(aStart, aStop: integer; aCompare: TDynArraySortCompare=nil); - /// sort the dynamic array elements, using a Compare method (not function) - // - it will change the dynamic array content, and exchange all elements - // in order to be sorted in increasing order according to Compare function, - // unless aReverse is true - // - it won't mark the array as Sorted, since the comparer is local - procedure Sort(const aCompare: TEventDynArraySortCompare; aReverse: boolean=false); overload; - /// search the elements range which match a given value in a sorted dynamic array - // - this method will use the Compare property function for the search - // - returns TRUE and the matching indexes, or FALSE if none found - // - if the array is not sorted, returns FALSE - function FindAllSorted(const Elem; out FirstIndex,LastIndex: Integer): boolean; - /// search for an element value inside a sorted dynamic array - // - this method will use the Compare property function for the search - // - will be faster than a manual FindAndAddIfNotExisting+Sort process - // - returns TRUE and the index of existing Elem, or FALSE and the index - // where the Elem is to be inserted so that the array remains sorted - // - you should then call FastAddSorted() later with the returned Index - // - if the array is not sorted, returns FALSE and Index=-1 - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (no FastLocateSorted(i+10) e.g.) - function FastLocateSorted(const Elem; out Index: Integer): boolean; - /// insert a sorted element value at the proper place - // - the index should have been computed by FastLocateSorted(): false - // - you may consider using FastLocateOrAddSorted() instead - procedure FastAddSorted(Index: Integer; const Elem); - /// search and add an element value inside a sorted dynamic array - // - this method will use the Compare property function for the search - // - will be faster than a manual FindAndAddIfNotExisting+Sort process - // - returns the index of the existing Elem and wasAdded^=false - // - returns the sorted index of the inserted Elem and wasAdded^=true - // - if the array is not sorted, returns -1 and wasAdded^=false - // - is just a wrapper around FastLocateSorted+FastAddSorted - function FastLocateOrAddSorted(const Elem; wasAdded: PBoolean=nil): integer; - /// delete a sorted element value at the proper place - // - plain Delete(Index) would reset the fSorted flag to FALSE, so use - // this method with a FastLocateSorted/FastAddSorted array - procedure FastDeleteSorted(Index: Integer); - /// will reverse all array elements, in place - procedure Reverse; - /// sort the dynamic array elements using a lookup array of indexes - // - in comparison to the Sort method, this CreateOrderedIndex won't change - // the dynamic array content, but only create (or update) the supplied - // integer lookup array, using the specified comparison function - // - if aCompare is not supplied, the method will use fCompare (if defined) - // - you should provide either a void either a valid lookup table, that is - // a table with one to one lookup (e.g. created with FillIncreasing) - // - if the lookup table has less elements than the main dynamic array, - // its content will be recreated - procedure CreateOrderedIndex(var aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare); overload; - /// sort the dynamic array elements using a lookup array of indexes - // - this overloaded method will use the supplied TSynTempBuffer for - // index storage, so use PIntegerArray(aIndex.buf) to access the values - // - caller should always make aIndex.Done once done - procedure CreateOrderedIndex(out aIndex: TSynTempBuffer; - aCompare: TDynArraySortCompare); overload; - /// sort using a lookup array of indexes, after a Add() - // - will resize aIndex if necessary, and set aIndex[Count-1] := Count-1 - procedure CreateOrderedIndexAfterAdd(var aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare); - /// save the dynamic array content into a (memory) stream - // - will handle array of binaries values (byte, word, integer...), array of - // strings or array of packed records, with binaries and string properties - // - will use a proprietary binary format, with some variable-length encoding - // of the string length - note that if you change the type definition, any - // previously-serialized content will fail, maybe triggering unexpected GPF: - // use SaveToTypeInfoHash if you share this binary data accross executables - // - Stream position will be set just after the added data - // - is optimized for memory streams, but will work with any kind of TStream - procedure SaveToStream(Stream: TStream); - /// load the dynamic array content from a (memory) stream - // - stream content must have been created using SaveToStream method - // - will handle array of binaries values (byte, word, integer...), array of - // strings or array of packed records, with binaries and string properties - // - will use a proprietary binary format, with some variable-length encoding - // of the string length - note that if you change the type definition, any - // previously-serialized content will fail, maybe triggering unexpected GPF: - // use SaveToTypeInfoHash if you share this binary data accross executables - procedure LoadFromStream(Stream: TCustomMemoryStream); - /// save the dynamic array content into an allocated memory buffer - // - Dest buffer must have been allocated to contain at least the number - // of bytes returned by the SaveToLength method - // - return a pointer at the end of the data written in Dest, nil in case - // of an invalid input buffer - // - will use a proprietary binary format, with some variable-length encoding - // of the string length - note that if you change the type definition, any - // previously-serialized content will fail, maybe triggering unexpected GPF: - // use SaveToTypeInfoHash if you share this binary data accross executables - // - this method will raise an ESynException for T*ObjArray types - // - use TDynArray.LoadFrom or TDynArrayLoadFrom to decode the saved buffer - function SaveTo(Dest: PAnsiChar): PAnsiChar; overload; - /// compute the number of bytes needed by SaveTo() to persist a dynamic array - // - will use a proprietary binary format, with some variable-length encoding - // of the string length - note that if you change the type definition, any - // previously-serialized content will fail, maybe triggering unexpected GPF: - // use SaveToTypeInfoHash if you share this binary data accross executables - // - this method will raise an ESynException for T*ObjArray types - function SaveToLength: integer; - /// save the dynamic array content into a RawByteString - // - will use a proprietary binary format, with some variable-length encoding - // of the string length - note that if you change the type definition, any - // previously-serialized content will fail, maybe triggering unexpected GPF: - // use SaveToTypeInfoHash if you share this binary data accross executables - // - this method will raise an ESynException for T*ObjArray types - // - use TDynArray.LoadFrom or TDynArrayLoadFrom to decode the saved buffer - function SaveTo: RawByteString; overload; - /// compute a crc32c-based hash of the RTTI for this dynamic array - // - can be used to ensure that the TDynArray.SaveTo binary layout - // is compatible accross executables - // - won't include the RTTI type kind, as TypeInfoToHash(), but only - // ElemSize or ElemType information, or any previously registered - // TTextWriter.RegisterCustomJSONSerializerFromText definition - function SaveToTypeInfoHash(crc: cardinal=0): cardinal; - /// unserialize dynamic array content from binary written by TDynArray.SaveTo - // - return nil if the Source buffer is incorrect: invalid type, wrong - // checksum, or optional SourceMax overflow - // - return a non nil pointer just after the Source content on success - // - this method will raise an ESynException for T*ObjArray types - // - you can optionally call AfterEach callback for each row loaded - // - if you don't want to allocate all items on memory, but just want to - // iterate over all items stored in a TDynArray.SaveTo memory buffer, - // consider using TDynArrayLoadFrom object - function LoadFrom(Source: PAnsiChar; AfterEach: TDynArrayAfterLoadFrom=nil; - NoCheckHash: boolean=false; SourceMax: PAnsiChar=nil): PAnsiChar; - /// unserialize the dynamic array content from a TDynArray.SaveTo binary string - // - same as LoadFrom, and will check for any buffer overflow since we - // know the actual end of input buffer - function LoadFromBinary(const Buffer: RawByteString; - NoCheckHash: boolean=false): boolean; - /// serialize the dynamic array content as JSON - // - is just a wrapper around TTextWriter.AddDynArrayJSON() - // - this method will therefore recognize T*ObjArray types - function SaveToJSON(EnumSetsAsText: boolean=false; - reformat: TTextWriterJSONFormat=jsonCompact): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - /// serialize the dynamic array content as JSON - // - is just a wrapper around TTextWriter.AddDynArrayJSON() - // - this method will therefore recognize T*ObjArray types - procedure SaveToJSON(out Result: RawUTF8; EnumSetsAsText: boolean=false; - reformat: TTextWriterJSONFormat=jsonCompact); overload; - /// load the dynamic array content from an UTF-8 encoded JSON buffer - // - expect the format as saved by TTextWriter.AddDynArrayJSON method, i.e. - // handling TBooleanDynArray, TIntegerDynArray, TInt64DynArray, TCardinalDynArray, - // TDoubleDynArray, TCurrencyDynArray, TWordDynArray, TByteDynArray, - // TRawUTF8DynArray, TWinAnsiDynArray, TRawByteStringDynArray, - // TStringDynArray, TWideStringDynArray, TSynUnicodeDynArray, - // TTimeLogDynArray and TDateTimeDynArray as JSON array - or any customized - // valid JSON serialization as set by TTextWriter.RegisterCustomJSONSerializer - // - or any other kind of array as Base64 encoded binary stream precessed - // via JSON_BASE64_MAGIC (UTF-8 encoded \uFFF0 special code) - // - typical handled content could be - // ! '[1,2,3,4]' or '["\uFFF0base64encodedbinary"]' - // - return a pointer at the end of the data read from P, nil in case - // of an invalid input buffer - // - this method will recognize T*ObjArray types, and will first free - // any existing instance before unserializing, to avoid memory leak - // - warning: the content of P^ will be modified during parsing: please - // make a local copy if it will be needed later (using e.g. TSynTempBufer) - function LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions=nil{$endif}): PUTF8Char; - {$ifndef NOVARIANTS} - /// load the dynamic array content from a TDocVariant instance - // - will convert the TDocVariant into JSON, the call LoadFromJSON - function LoadFromVariant(const DocVariant: variant): boolean; - {$endif NOVARIANTS} - /// select a sub-section (slice) of a dynamic array content - procedure Slice(var Dest; aCount: Cardinal; aFirstIndex: cardinal=0); - /// add elements from a given dynamic array variable - // - the supplied source DynArray MUST be of the same exact type as the - // current used for this TDynArray - warning: pass here a reference to - // a "array of ..." variable, not another TDynArray instance; if you - // want to add another TDynArray, use AddDynArray() method - // - you can specify the start index and the number of items to take from - // the source dynamic array (leave as -1 to add till the end) - // - returns the number of items added to the array - function AddArray(const DynArrayVar; aStartIndex: integer=0; aCount: integer=-1): integer; - {$ifndef DELPHI5OROLDER} - /// fast initialize a wrapper for an existing dynamic array of the same type - // - is slightly faster than - // ! Init(aAnother.ArrayType,aValue,nil); - procedure InitFrom(const aAnother: TDynArray; var aValue); - {$ifdef HASINLINE}inline;{$endif} - /// add elements from a given TDynArray - // - the supplied source TDynArray MUST be of the same exact type as the - // current used for this TDynArray, otherwise it won't do anything - // - you can specify the start index and the number of items to take from - // the source dynamic array (leave as -1 to add till the end) - procedure AddDynArray(const aSource: TDynArray; aStartIndex: integer=0; aCount: integer=-1); - /// compare the content of the two arrays, returning TRUE if both match - // - this method compares using any supplied Compare property (unless - // ignorecompare=true), or by content using the RTTI element description - // of the whole array items - // - will call SaveToJSON to compare T*ObjArray kind of arrays - function Equals(const B: TDynArray; ignorecompare: boolean=false): boolean; - /// set all content of one dynamic array to the current array - // - both must be of the same exact type - // - T*ObjArray will be reallocated and copied by content (using a temporary - // JSON serialization), unless ObjArrayByRef is true and pointers are copied - procedure Copy(const Source: TDynArray; ObjArrayByRef: boolean=false); - /// set all content of one dynamic array to the current array - // - both must be of the same exact type - // - T*ObjArray will be reallocated and copied by content (using a temporary - // JSON serialization), unless ObjArrayByRef is true and pointers are copied - procedure CopyFrom(const Source; MaxElem: integer; ObjArrayByRef: boolean=false); - /// set all content of the current dynamic array to another array variable - // - both must be of the same exact type - // - resulting length(Dest) will match the exact items count, even if an - // external Count integer variable is used by this instance - // - T*ObjArray will be reallocated and copied by content (using a temporary - // JSON serialization), unless ObjArrayByRef is true and pointers are copied - procedure CopyTo(out Dest; ObjArrayByRef: boolean=false); - {$endif DELPHI5OROLDER} - /// returns a pointer to an element of the array - // - returns nil if aIndex is out of range - // - since TDynArray is just a wrapper around an existing array, you should - // better use direct access to its wrapped variable, and not using this - // slower and more error prone method (such pointer access lacks of strong - // typing abilities), which was designed for TDynArray internal use - function ElemPtr(index: PtrInt): pointer; {$ifdef HASINLINE}inline;{$endif} - /// will copy one element content from its index into another variable - // - do nothing if index is out of range - procedure ElemCopyAt(index: PtrInt; var Dest); {$ifdef FPC}inline;{$endif} - /// will move one element content from its index into another variable - // - will erase the internal item after copy - // - do nothing if index is out of range - procedure ElemMoveTo(index: PtrInt; var Dest); - /// will copy one variable content into an indexed element - // - do nothing if index is out of range - // - ClearBeforeCopy will call ElemClear() before the copy, which may be safer - // if the source item is a copy of Values[index] with some dynamic arrays - procedure ElemCopyFrom(const Source; index: PtrInt; - ClearBeforeCopy: boolean=false); {$ifdef FPC}inline;{$endif} - /// compare the content of two elements, returning TRUE if both values equal - // - this method compares first using any supplied Compare property, - // then by content using the RTTI element description of the whole record - function ElemEquals(const A,B): boolean; - /// will reset the element content - procedure ElemClear(var Elem); - /// will copy one element content - procedure ElemCopy(const A; var B); {$ifdef FPC}inline;{$endif} - /// will copy the first field value of an array element - // - will use the array KnownType to guess the copy routine to use - // - returns false if the type information is not enough for a safe copy - function ElemCopyFirstField(Source,Dest: Pointer): boolean; - /// save an array element into a serialized binary content - // - use the same layout as TDynArray.SaveTo, but for a single item - // - you can use ElemLoad method later to retrieve its content - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write ElemSave(i+10) e.g.) - function ElemSave(const Elem): RawByteString; - /// load an array element as saved by the ElemSave method into Elem variable - // - warning: Elem must be of the same exact type than the dynamic array, - // and must be a reference to a variable (you can't write ElemLoad(P,i+10) e.g.) - procedure ElemLoad(Source: PAnsiChar; var Elem; SourceMax: PAnsiChar=nil); overload; - /// load an array element as saved by the ElemSave method - // - this overloaded method will retrieve the element as a memory buffer, - // which should be cleared by ElemLoadClear() before release - function ElemLoad(Source: PAnsiChar; SourceMax: PAnsiChar=nil): RawByteString; overload; - /// search for an array element as saved by the ElemSave method - // - same as ElemLoad() + Find()/IndexOf() + ElemLoadClear() - // - will call Find() method if Compare property is set - // - will call generic IndexOf() method if no Compare property is set - function ElemLoadFind(Source: PAnsiChar; SourceMax: PAnsiChar=nil): integer; - /// finalize a temporary buffer used to store an element via ElemLoad() - // - will release any managed type referenced inside the RawByteString, - // then void the variable - // - is just a wrapper around ElemClear(pointer(ElemTemp)) + ElemTemp := '' - procedure ElemLoadClear(var ElemTemp: RawByteString); - - /// retrieve or set the number of elements of the dynamic array - // - same as length(DynArray) or SetLength(DynArray) - // - this property will recognize T*ObjArray types, so will free any stored - // instance if the array is sized down - property Count: PtrInt read GetCount write SetCount; - /// the internal buffer capacity - // - if no external Count pointer was set with Init, is the same as Count - // - if an external Count pointer is set, you can set a value to this - // property before a massive use of the Add() method e.g. - // - if no external Count pointer is set, set a value to this property - // will affect the Count value, i.e. Add() will append after this count - // - this property will recognize T*ObjArray types, so will free any stored - // instance if the array is sized down - property Capacity: PtrInt read GetCapacity write SetCapacity; - /// the compare function to be used for Sort and Find methods - // - by default, no comparison function is set - // - common functions exist for base types: e.g. SortDynArrayByte, SortDynArrayBoolean, - // SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle, - // SortDynArrayInt64, SortDynArrayDouble, SortDynArrayAnsiString, - // SortDynArrayAnsiStringI, SortDynArrayString, SortDynArrayStringI, - // SortDynArrayUnicodeString, SortDynArrayUnicodeStringI - property Compare: TDynArraySortCompare read fCompare write SetCompare; - /// must be TRUE if the array is currently in sorted order according to - // the compare function - // - Add/Delete/Insert/Load* methods will reset this property to false - // - Sort method will set this property to true - // - you MUST set this property to false if you modify the dynamic array - // content in your code, so that Find() won't try to wrongly use binary - // search in an unsorted array, and miss its purpose - property Sorted: boolean read fSorted write fSorted; - /// low-level direct access to the storage variable - property Value: PPointer read fValue; - /// the first field recognized type - // - could have been set at initialization, or after a GuessKnownType call - property KnownType: TDynArrayKind read fKnownType; - /// the raw storage size of the first field KnownType - property KnownSize: integer read fKnownSize; - /// the known RTTI information of the whole array - property ArrayType: pointer read fTypeInfo; - /// the known type name of the whole array, as RawUTF8 - property ArrayTypeName: RawUTF8 read GetArrayTypeName; - /// the known type name of the whole array, as PShortString - property ArrayTypeShort: PShortString read GetArrayTypeShort; - /// the internal in-memory size of one element, as retrieved from RTTI - property ElemSize: cardinal read fElemSize; - /// the internal type information of one element, as retrieved from RTTI - property ElemType: pointer read fElemType; - /// if this dynamic aray is a T*ObjArray - property IsObjArray: boolean read GetIsObjArray write SetIsObjArray; - end; - /// a pointer to a TDynArray wrapper instance - PDynArray = ^TDynArray; - - /// allows to iterate over a TDynArray.SaveTo binary buffer - // - may be used as alternative to TDynArray.LoadFrom, if you don't want - // to allocate all items at once, but retrieve items one by one - TDynArrayLoadFrom = object - protected - DynArray: TDynArray; // used to access RTTI - Hash: PCardinalArray; - PositionEnd: PAnsiChar; - public - /// how many items were saved in the TDynArray.SaveTo binary buffer - // - equals -1 if Init() failed to unserialize its header - Count: integer; - /// the zero-based index of the current item pointed by next Step() call - // - is in range 0..Count-1 until Step() returns false - Current: integer; - /// current position in the TDynArray.SaveTo binary buffer - // - after Step() returned false, points just after the binary buffer, - // like a regular TDynArray.LoadFrom - Position: PAnsiChar; - /// initialize iteration over a TDynArray.SaveTo binary buffer - // - returns true on success, with Count and Position being set - // - returns false if the supplied binary buffer is not correct - // - you can specify an optional SourceMaxLen to avoid any buffer overflow - function Init(ArrayTypeInfo: pointer; Source: PAnsiChar; - SourceMaxLen: PtrInt=0): boolean; overload; - /// initialize iteration over a TDynArray.SaveTo binary buffer - // - returns true on success, with Count and Position being set - // - returns false if the supplied binary buffer is not correct - function Init(ArrayTypeInfo: pointer; const Source: RawByteString): boolean; overload; - /// iterate over the current stored item - // - Elem should point to a variable of the exact item type stored in this - // dynamic array - // - returns true if Elem was filled with one value, or false if all - // items were read, and Position contains the end of the binary buffer - function Step(out Elem): boolean; - /// extract the first field value of the current stored item - // - returns true if Field was filled with one value, or false if all - // items were read, and Position contains the end of the binary buffer - // - could be called before Step(), to pre-allocate a new item instance, - // or update an existing instance - function FirstField(out Field): boolean; - /// after all items are read by Step(), validate the stored hash - // - returns true if items hash is correct, false otherwise - function CheckHash: boolean; - end; - - /// function prototype to be used for hashing of a dynamic array element - // - this function must use the supplied hasher on the Elem data - TDynArrayHashOne = function(const Elem; Hasher: THasher): cardinal; - - /// event handler to be used for hashing of a dynamic array element - // - can be set as an alternative to TDynArrayHashOne - TEventDynArrayHashOne = function(const Elem): cardinal of object; - - {.$define DYNARRAYHASHCOLLISIONCOUNT} - - /// allow O(1) lookup to any dynamic array content - // - this won't handle the storage process (like add/update), just efficiently - // maintain a hash table over an existing dynamic array: several TDynArrayHasher - // could be applied to a single TDynArray wrapper - // - TDynArrayHashed will use a TDynArrayHasher for its own store - {$ifdef USERECORDWITHMETHODS}TDynArrayHasher = record - {$else}TDynArrayHasher = object {$endif} - private - DynArray: PDynArray; - HashElement: TDynArrayHashOne; - EventHash: TEventDynArrayHashOne; - Hasher: THasher; - HashTable: TIntegerDynArray; // store 0 for void entry, or Index+1 - HashTableSize: integer; - ScanCounter: integer; // Scan()>=0 up to CountTrigger*2 - State: set of (hasHasher, canHash); - function HashTableIndex(aHashCode: cardinal): cardinal; {$ifdef HASINLINE}inline;{$endif} - procedure HashAdd(aHashCode: cardinal; var result: integer); - procedure HashDelete(aArrayIndex, aHashTableIndex: integer; aHashCode: cardinal); - procedure RaiseFatalCollision(const caller: RawUTF8; aHashCode: cardinal); - public - /// associated item comparison - may differ from DynArray^.Compare - Compare: TDynArraySortCompare; - /// custom method-based comparison function - EventCompare: TEventDynArraySortCompare; - /// after how many FindBeforeAdd() or Scan() the hashing starts - default 32 - CountTrigger: integer; - {$ifdef DYNARRAYHASHCOLLISIONCOUNT} - /// low-level access to an hash collisions counter - FindCollisions: cardinal; - {$endif} - /// initialize the hash table for a given dynamic array storage - // - you can call this method several times, e.g. if aCaseInsensitive changed - procedure Init(aDynArray: PDynArray; aHashElement: TDynArrayHashOne; - aEventHash: TEventDynArrayHashOne; aHasher: THasher; aCompare: TDynArraySortCompare; - aEventCompare: TEventDynArraySortCompare; aCaseInsensitive: boolean); - /// initialize a known hash table for a given dynamic array storage - // - you can call this method several times, e.g. if aCaseInsensitive changed - procedure InitSpecific(aDynArray: PDynArray; aKind: TDynArrayKind; aCaseInsensitive: boolean); - /// allow custom hashing via a method event - procedure SetEventHash(const event: TEventDynArrayHashOne); - /// search for an element value inside the dynamic array without hashing - // - trigger hashing if ScanCounter reaches CountTrigger*2 - function Scan(Elem: pointer): integer; - /// search for an element value inside the dynamic array with hashing - function Find(Elem: pointer): integer; overload; - /// search for a hashed element value inside the dynamic array with hashing - function Find(Elem: pointer; aHashCode: cardinal): integer; overload; - /// search for a hash position inside the dynamic array with hashing - function Find(aHashCode: cardinal; aForAdd: boolean): integer; overload; - /// returns position in array, or next void index in HashTable[] as -(index+1) - function FindOrNew(aHashCode: cardinal; Elem: pointer; aHashTableIndex: PInteger=nil): integer; - /// search an hashed element value for adding, updating the internal hash table - // - trigger hashing if Count reaches CountTrigger - function FindBeforeAdd(Elem: pointer; out wasAdded: boolean; aHashCode: cardinal): integer; - /// search and delete an element value, updating the internal hash table - function FindBeforeDelete(Elem: pointer): integer; - /// reset the hash table - no rehash yet - procedure Clear; - /// full computation of the internal hash table - // - returns the number of duplicated values found - function ReHash(forced: boolean): integer; - /// compute the hash of a given item - function HashOne(Elem: pointer): cardinal; {$ifdef FPC_OR_DELPHIXE4}inline;{$endif} - { not inlined to circumvent Delphi 2007=C1632, 2010=C1872, XE3=C2130 } - /// retrieve the low-level hash of a given item - function GetHashFromIndex(aIndex: PtrInt): cardinal; - end; - - /// pointer to a TDynArrayHasher instance - PDynArrayHasher = ^TDynArrayHasher; - - /// used to access any dynamic arrray elements using fast hash - // - by default, binary sort could be used for searching items for TDynArray: - // using a hash is faster on huge arrays for implementing a dictionary - // - in this current implementation, modification (update or delete) of an - // element is not handled yet: you should rehash all content - only - // TDynArrayHashed.FindHashedForAdding / FindHashedAndUpdate / - // FindHashedAndDelete will refresh the internal hash - // - this object extends the TDynArray type, since presence of Hashs[] dynamic - // array will increase code size if using TDynArrayHashed instead of TDynArray - // - in order to have the better performance, you should use an external Count - // variable, AND set the Capacity property to the expected maximum count (this - // will avoid most ReHash calls for FindHashedForAdding+FindHashedAndUpdate) - {$ifdef UNDIRECTDYNARRAY} - TDynArrayHashed = record - // pseudo inheritance for most used methods - private - function GetCount: PtrInt; inline; - procedure SetCount(aCount: PtrInt) ; inline; - procedure SetCapacity(aCapacity: PtrInt); inline; - function GetCapacity: PtrInt; inline; - public - InternalDynArray: TDynArray; - function Value: PPointer; inline; - function ElemSize: PtrUInt; inline; - function ElemType: Pointer; inline; - function KnownType: TDynArrayKind; inline; - procedure Clear; inline; - procedure ElemCopy(const A; var B); inline; - function ElemPtr(index: PtrInt): pointer; inline; - procedure ElemCopyAt(index: PtrInt; var Dest); inline; - // warning: you shall call ReHash() after manual Add/Delete - function Add(const Elem): integer; inline; - procedure Delete(aIndex: PtrInt); inline; - function SaveTo: RawByteString; overload; inline; - function SaveTo(Dest: PAnsiChar): PAnsiChar; overload; inline; - function SaveToJSON(EnumSetsAsText: boolean=false; - reformat: TTextWriterJSONFormat=jsonCompact): RawUTF8; inline; - procedure Sort(aCompare: TDynArraySortCompare=nil); inline; - function LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char=nil{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions=nil{$endif}): PUTF8Char; inline; - function SaveToLength: integer; inline; - function LoadFrom(Source: PAnsiChar; AfterEach: TDynArrayAfterLoadFrom=nil; - NoCheckHash: boolean=false; SourceMax: PAnsiChar=nil): PAnsiChar; inline; - function LoadFromBinary(const Buffer: RawByteString; - NoCheckHash: boolean=false): boolean; inline; - procedure CreateOrderedIndex(var aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare); - property Count: PtrInt read GetCount write SetCount; - property Capacity: PtrInt read GetCapacity write SetCapacity; - private - {$else UNDIRECTDYNARRAY} - TDynArrayHashed = object(TDynArray) - protected - {$endif UNDIRECTDYNARRAY} - fHash: TDynArrayHasher; - procedure SetEventHash(const event: TEventDynArrayHashOne); {$ifdef HASINLINE}inline;{$endif} - function GetHashFromIndex(aIndex: PtrInt): Cardinal; {$ifdef HASINLINE}inline;{$endif} - public - /// initialize the wrapper with a one-dimension dynamic array - // - this version accepts some hash-dedicated parameters: aHashElement to - // set how to hash each element, aCompare to handle hash collision - // - if no aHashElement is supplied, it will hash according to the RTTI, i.e. - // strings or binary types, and the first field for records (strings included) - // - if no aCompare is supplied, it will use default Equals() method - // - if no THasher function is supplied, it will use the one supplied in - // DefaultHasher global variable, set to crc32c() by default - using - // SSE4.2 instruction if available - // - if CaseInsensitive is set to TRUE, it will ignore difference in 7 bit - // alphabetic characters (e.g. compare 'a' and 'A' as equal) - procedure Init(aTypeInfo: pointer; var aValue; - aHashElement: TDynArrayHashOne=nil; aCompare: TDynArraySortCompare=nil; - aHasher: THasher=nil; aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false); - /// initialize the wrapper with a one-dimension dynamic array - // - this version accepts to specify how both hashing and comparison should - // occur, setting the TDynArrayKind kind of first/hashed field - // - djNone and djCustom are too vague, and will raise an exception - // - no RTTI check is made over the corresponding array layout: you shall - // ensure that aKind matches the dynamic array element definition - // - aCaseInsensitive will be used for djRawUTF8..djHash512 text comparison - procedure InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind; - aCountPointer: PInteger=nil; aCaseInsensitive: boolean=false); - /// will compute all hash from the current elements of the dynamic array - // - is called within the TDynArrayHashed.Init method to initialize the - // internal hash array - // - can be called on purpose, when modifications have been performed on - // the dynamic array content (e.g. in case of element deletion or update, - // or after calling LoadFrom/Clear method) - this is not necessary after - // FindHashedForAdding / FindHashedAndUpdate / FindHashedAndDelete methods - // - returns the number of duplicated items found - which won't be available - // by hashed FindHashed() by definition - function ReHash(forAdd: boolean=false): integer; - /// search for an element value inside the dynamic array using hashing - // - Elem should be of the type expected by both the hash function and - // Equals/Compare methods: e.g. if the searched/hashed field in a record is - // a string as first field, you can safely use a string variable as Elem - // - Elem must refer to a variable: e.g. you can't write FindHashed(i+10) - // - will call fHashElement(Elem,fHasher) to compute the needed hash - // - returns -1 if not found, or the index in the dynamic array if found - function FindHashed(const Elem): integer; - /// search for an element value inside the dynamic array using its hash - // - returns -1 if not found, or the index in the dynamic array if found - // - aHashCode parameter constains an already hashed value of the item, - // to be used e.g. after a call to HashFind() - function FindFromHash(const Elem; aHashCode: cardinal): integer; - /// search for an element value inside the dynamic array using hashing, and - // fill Elem with the found content - // - return the index found (0..Count-1), or -1 if Elem was not found - // - ElemToFill should be of the type expected by the dynamic array, since - // all its fields will be set on match - function FindHashedAndFill(var ElemToFill): integer; - /// search for an element value inside the dynamic array using hashing, and - // add a void entry to the array if was not found (unless noAddEntry is set) - // - this method will use hashing for fast retrieval - // - Elem should be of the type expected by both the hash function and - // Equals/Compare methods: e.g. if the searched/hashed field in a record is - // a string as first field, you can safely use a string variable as Elem - // - returns either the index in the dynamic array if found (and set wasAdded - // to false), either the newly created index in the dynamic array (and set - // wasAdded to true) - // - for faster process (avoid ReHash), please set the Capacity property - // - warning: in contrast to the Add() method, if an entry is added to the - // array (wasAdded=true), the entry is left VOID: you must set the field - // content to expecting value - in short, Elem is used only for searching, - // not copied to the newly created entry in the array - check - // FindHashedAndUpdate() for a method actually copying Elem fields - function FindHashedForAdding(const Elem; out wasAdded: boolean; - noAddEntry: boolean=false): integer; overload; - /// search for an element value inside the dynamic array using hashing, and - // add a void entry to the array if was not found (unless noAddEntry is set) - // - overloaded method acepting an already hashed value of the item, to be used - // e.g. after a call to HashFind() - function FindHashedForAdding(const Elem; out wasAdded: boolean; - aHashCode: cardinal; noAddEntry: boolean=false): integer; overload; - /// ensure a given element name is unique, then add it to the array - // - expected element layout is to have a RawUTF8 field at first position - // - the aName is searched (using hashing) to be unique, and if not the case, - // an ESynException.CreateUTF8() is raised with the supplied arguments - // - use internaly FindHashedForAdding method - // - this version will set the field content with the unique value - // - returns a pointer to the newly added element (to set other fields) - function AddUniqueName(const aName: RawUTF8; const ExceptionMsg: RawUTF8; - const ExceptionArgs: array of const; aNewIndex: PInteger=nil): pointer; overload; - /// ensure a given element name is unique, then add it to the array - // - just a wrapper to AddUniqueName(aName,'',[],aNewIndex) - function AddUniqueName(const aName: RawUTF8; aNewIndex: PInteger=nil): pointer; overload; - /// search for a given element name, make it unique, and add it to the array - // - expected element layout is to have a RawUTF8 field at first position - // - the aName is searched (using hashing) to be unique, and if not the case, - // some suffix is added to make it unique - // - use internaly FindHashedForAdding method - // - this version will set the field content with the unique value - // - returns a pointer to the newly added element (to set other fields) - function AddAndMakeUniqueName(aName: RawUTF8): pointer; - /// search for an element value inside the dynamic array using hashing, then - // update any matching item, or add the item if none matched - // - by design, hashed field shouldn't have been modified by this update, - // otherwise the method won't be able to find and update the old hash: in - // this case, you should first call FindHashedAndDelete(OldElem) then - // FindHashedForAdding(NewElem) to properly handle the internal hash table - // - if AddIfNotExisting is FALSE, returns the index found (0..Count-1), - // or -1 if Elem was not found - update will force slow rehash all content - // - if AddIfNotExisting is TRUE, returns the index found (0..Count-1), - // or the index newly created/added is the Elem value was not matching - - // add won't rehash all content - for even faster process (avoid ReHash), - // please set the Capacity property - // - Elem should be of the type expected by the dynamic array, since its - // content will be copied into the dynamic array, and it must refer to a - // variable: e.g. you can't write FindHashedAndUpdate(i+10) - function FindHashedAndUpdate(const Elem; AddIfNotExisting: boolean): integer; - /// search for an element value inside the dynamic array using hashing, and - // delete it if matchs - // - return the index deleted (0..Count-1), or -1 if Elem was not found - // - can optionally copy the deleted item to FillDeleted^ before erased - // - Elem should be of the type expected by both the hash function and - // Equals/Compare methods, and must refer to a variable: e.g. you can't - // write FindHashedAndDelete(i+10) - // - it won't call slow ReHash but refresh the hash table as needed - function FindHashedAndDelete(const Elem; FillDeleted: pointer=nil; - noDeleteEntry: boolean=false): integer; - /// will search for an element value inside the dynamic array without hashing - // - is used internally when Count < HashCountTrigger - // - is preferred to Find(), since EventCompare would be used if defined - // - Elem should be of the type expected by both the hash function and - // Equals/Compare methods, and must refer to a variable: e.g. you can't - // write Scan(i+10) - // - returns -1 if not found, or the index in the dynamic array if found - // - an internal algorithm can switch to hashing if Scan() is called often, - // even if the number of items is lower than HashCountTrigger - function Scan(const Elem): integer; - /// retrieve the hash value of a given item, from its index - property Hash[aIndex: PtrInt]: Cardinal read GetHashFromIndex; - /// alternative event-oriented Compare function to be used for Sort and Find - // - will be used instead of Compare, to allow object-oriented callbacks - property EventCompare: TEventDynArraySortCompare read fHash.EventCompare write fHash.EventCompare; - /// custom hash function to be used for hashing of a dynamic array element - property HashElement: TDynArrayHashOne read fHash.HashElement; - /// alternative event-oriented Hash function for ReHash - // - this object-oriented callback will be used instead of HashElement - // on each dynamic array entries - HashElement will still be used on - // const Elem values, since they may be just a sub part of the stored entry - property EventHash: TEventDynArrayHashOne read fHash.EventHash write SetEventHash; - /// after how many items the hashing take place - // - for smallest arrays, O(n) search if faster than O(1) hashing, since - // maintaining internal hash table has some CPU and memory costs - // - internal search is able to switch to hashing if it founds out that it - // may have some benefit, e.g. if Scan() is called 2*HashCountTrigger times - // - equals 32 by default, i.e. start hashing when Count reaches 32 or - // manual Scan() is called 64 times - property HashCountTrigger: integer read fHash.CountTrigger write fHash.CountTrigger; - /// access to the internal hash table - // - you can call e.g. Hasher.Clear to invalidate the whole hash table - property Hasher: TDynArrayHasher read fHash; - end; - - - /// defines a wrapper interface around a dynamic array of TObject - // - implemented by TObjectDynArrayWrapper for instance - // - i.e. most common methods are available to work with a dynamic array - // - warning: the IObjectDynArray MUST be defined in the stack, class or - // record BEFORE the dynamic array it is wrapping, otherwise you may leak - // memory - see for instance TSQLRestServer class: - // ! fSessionAuthentications: IObjectDynArray; // defined before the array - // ! fSessionAuthentication: TSQLRestServerAuthenticationDynArray; - // note that allocation time as variable on the local stack may depend on the - // compiler, and its optimization - IObjectDynArray = interface - ['{A0D50BD0-0D20-4552-B365-1D63393511FC}'] - /// search one element within the TObject instances - function Find(Instance: TObject): integer; - /// add one element to the dynamic array of TObject instances - // - once added, the Instance will be owned by this TObjectDynArray instance - function Add(Instance: TObject): integer; - /// delete one element from the TObject dynamic array - // - deleted TObject instance will be freed as expected - procedure Delete(Index: integer); - /// sort the dynamic array content according to a specified comparer - procedure Sort(Compare: TDynArraySortCompare); - /// delete all TObject instances, and release the memory - // - is not to be called for most use, thanks to reference-counting memory - // handling, but can be handy for quick release - procedure Clear; - /// ensure the internal list capacity is set to the current Count - // - may be used to publish the associated dynamic array with the expected - // final size, once IObjectDynArray is out of scope - procedure Slice; - /// returns the number of TObject instances available - // - note that the length of the associated dynamic array is used to store - // the capacity of the list, so won't probably never match with this value - function Count: integer; - /// returns the internal array capacity of TObject instances available - // - which is in fact the length() of the associated dynamic array - function Capacity: integer; - end; - - /// a wrapper to own a dynamic array of TObject - // - this version behave list a TObjectList (i.e. owning the class instances) - // - but the dynamic array is NOT owned by the instance - // - will define an internal Count property, using the dynamic array length - // as capacity: adding and deleting will be much faster - // - implements IObjectDynArray, so that most common methods are available - // to work with the dynamic array - // - does not need any sub-classing of generic overhead to work, and will be - // reference counted - // - warning: the IObjectDynArray MUST be defined in the stack, class or - // record BEFORE the dynamic array it is wrapping, otherwise you may leak - // memory, and TObjectDynArrayWrapper.Destroy will raise an ESynException - // - warning: issues with Delphi 10.4 Sydney were reported, which seemed to - // change the order of fields finalization, so the whole purpose of this - // wrapper may have become incompatible with Delphi 10.4 and up - // - a sample usage may be: - // !var DA: IObjectDynArray; // defined BEFORE the dynamic array itself - // ! A: array of TMyObject; - // ! i: integer; - // !begin - // ! DA := TObjectDynArrayWrapper.Create(A); - // ! DA.Add(TMyObject.Create('one')); - // ! DA.Add(TMyObject.Create('two')); - // ! DA.Delete(0); - // ! assert(DA.Count=1); - // ! assert(A[0].Name='two'); - // ! DA.Clear; - // ! assert(DA.Count=0); - // ! DA.Add(TMyObject.Create('new')); - // ! assert(DA.Count=1); - // !end; // will auto-release DA (no need of try..finally DA.Free) - TObjectDynArrayWrapper = class(TInterfacedObject, IObjectDynArray) - protected - fValue: PPointer; - fCount: integer; - fOwnObjects: boolean; - public - /// initialize the wrapper with a one-dimension dynamic array of TObject - // - by default, objects will be owned by this class, but you may set - // aOwnObjects=false if you expect the dynamic array to remain available - constructor Create(var aValue; aOwnObjects: boolean=true); - /// will release all associated TObject instances - destructor Destroy; override; - /// search one element within the TObject instances - function Find(Instance: TObject): integer; - /// add one element to the dynamic array of TObject instances - // - once added, the Instance will be owned by this TObjectDynArray instance - // (unless aOwnObjects was false in Create) - function Add(Instance: TObject): integer; - /// delete one element from the TObject dynamic array - // - deleted TObject instance will be freed as expected (unless aOwnObjects - // was defined as false in Create) - procedure Delete(Index: integer); - /// sort the dynamic array content according to a specified comparer - procedure Sort(Compare: TDynArraySortCompare); - /// delete all TObject instances, and release the memory - // - is not to be called for most use, thanks to reference-counting memory - // handling, but can be handy for quick release - // - warning: won't release the instances if aOwnObjects was false in Create - procedure Clear; - /// ensure the internal list capacity is set to the current Count - // - may be used to publish the associated dynamic array with the expected - // final size, once IObjectDynArray is out of scope - procedure Slice; - /// returns the number of TObject instances available - // - note that the length() of the associated dynamic array is used to store - // the capacity of the list, so won't probably never match with this value - function Count: integer; - /// returns the internal array capacity of TObject instances available - // - which is in fact the length() of the associated dynamic array - function Capacity: integer; - end; - - /// abstract parent class with a virtual constructor, ready to be overridden - // to initialize the instance - // - you can specify such a class if you need an object including published - // properties (like TPersistent) with a virtual constructor (e.g. to - // initialize some nested class properties) - TPersistentWithCustomCreate = class(TPersistent) - public - /// this virtual constructor will be called at instance creation - // - this constructor does nothing, but is declared as virtual so that - // inherited classes may safely override this default void implementation - constructor Create; virtual; - end; - - {$M+} - /// abstract parent class with threadsafe implementation of IInterface and - // a virtual constructor - // - you can specify e.g. such a class to TSQLRestServer.ServiceRegister() if - // you need an interfaced object with a virtual constructor, ready to be - // overridden to initialize the instance - TInterfacedObjectWithCustomCreate = class(TInterfacedObject) - public - /// this virtual constructor will be called at instance creation - // - this constructor does nothing, but is declared as virtual so that - // inherited classes may safely override this default void implementation - constructor Create; virtual; - /// used to mimic TInterfacedObject reference counting - // - Release=true will call TInterfacedObject._Release - // - Release=false will call TInterfacedObject._AddRef - // - could be used to emulate proper reference counting of the instance - // via interfaces variables, but still storing plain class instances - // (e.g. in a global list of instances) - procedure RefCountUpdate(Release: boolean); virtual; - end; - - /// our own empowered TPersistent-like parent class - // - TPersistent has an unexpected speed overhead due a giant lock introduced - // to manage property name fixup resolution (which we won't use outside the VCL) - // - this class has a virtual constructor, so is a preferred alternative - // to both TPersistent and TPersistentWithCustomCreate classes - // - for best performance, any type inheriting from this class will bypass - // some regular steps: do not implement interfaces or use TMonitor with them! - TSynPersistent = class(TObject) - protected - // this default implementation will call AssignError() - procedure AssignTo(Dest: TSynPersistent); virtual; - procedure AssignError(Source: TSynPersistent); - public - /// this virtual constructor will be called at instance creation - // - this constructor does nothing, but is declared as virtual so that - // inherited classes may safely override this default void implementation - constructor Create; virtual; - /// allows to implement a TPersistent-like assignement mechanism - // - inherited class should override AssignTo() protected method - // to implement the proper assignment - procedure Assign(Source: TSynPersistent); virtual; - /// optimized initialization code - // - somewhat faster than the regular RTL implementation - especially - // since rewritten in pure asm on Delphi/x86 - // - warning: this optimized version won't initialize the vmtIntfTable - // for this class hierarchy: as a result, you would NOT be able to - // implement an interface with a TSynPersistent descendent (but you should - // not need to, but inherit from TInterfacedObject) - // - warning: under FPC, it won't initialize fields management operators - class function NewInstance: TObject; override; - {$ifndef FPC_OR_PUREPASCAL} - /// optimized x86 asm finalization code - // - warning: this version won't release either any allocated TMonitor - // (as available since Delphi 2009) - do not use TMonitor with - // TSynPersistent, but rather the faster TSynPersistentLock class - procedure FreeInstance; override; - {$endif} - end; - {$M-} - - /// simple and efficient TList, without any notification - // - regular TList has an internal notification mechanism which slows down - // basic process, and most used methods were not defined as virtual, so can't - // be easily inherited - // - stateless methods (like Add/Clear/Exists/Remove) are defined as virtual - // since can be overriden e.g. by TSynObjectListLocked to add a TSynLocker - TSynList = class(TSynPersistent) - protected - fCount: integer; - fList: TPointerDynArray; - function Get(index: Integer): pointer; {$ifdef HASINLINE} inline; {$endif} - public - /// add one item to the list - function Add(item: pointer): integer; virtual; - /// delete all items of the list - procedure Clear; virtual; - /// delete one item from the list - procedure Delete(index: integer); virtual; - /// fast retrieve one item in the list - function IndexOf(item: pointer): integer; virtual; - /// fast check if one item exists in the list - function Exists(item: pointer): boolean; virtual; - /// fast delete one item in the list - function Remove(item: pointer): integer; virtual; - /// how many items are stored in this TList instance - property Count: integer read fCount; - /// low-level access to the items stored in this TList instance - property List: TPointerDynArray read fList; - /// low-level array-like access to the items stored in this TList instance - // - warning: if index is out of range, will return nil and won't raise - // any exception - property Items[index: Integer]: pointer read Get; default; - end; - - /// simple and efficient TObjectList, without any notification - TSynObjectList = class(TSynList) - protected - fOwnObjects: boolean; - public - /// initialize the object list - constructor Create(aOwnObjects: boolean=true); reintroduce; - /// delete one object from the list - procedure Delete(index: integer); override; - /// delete all objects of the list - procedure Clear; override; - /// delete all objects of the list in reverse order - // - for some kind of processes, owned objects should be removed from the - // last added to the first - procedure ClearFromLast; virtual; - /// finalize the store items - destructor Destroy; override; - end; - - /// allow to add cross-platform locking methods to any class instance - // - typical use is to define a Safe: TSynLocker property, call Safe.Init - // and Safe.Done in constructor/destructor methods, and use Safe.Lock/UnLock - // methods in a try ... finally section - // - in respect to the TCriticalSection class, fix a potential CPU cache line - // conflict which may degrade the multi-threading performance, as reported by - // @http://www.delphitools.info/2011/11/30/fixing-tcriticalsection - // - internal padding is used to safely store up to 7 values protected - // from concurrent access with a mutex, so that SizeOf(TSynLocker)>128 - // - for object-level locking, see TSynPersistentLock which owns one such - // instance, or call low-level fSafe := NewSynLocker in your constructor, - // then fSafe^.DoneAndFreemem in your destructor - TSynLocker = object - protected - fSection: TRTLCriticalSection; - fLockCount: integer; - fInitialized: boolean; - {$ifndef NOVARIANTS} - function GetVariant(Index: integer): Variant; - procedure SetVariant(Index: integer; const Value: Variant); - function GetInt64(Index: integer): Int64; - procedure SetInt64(Index: integer; const Value: Int64); - function GetBool(Index: integer): boolean; - procedure SetBool(Index: integer; const Value: boolean); - function GetUnlockedInt64(Index: integer): Int64; - procedure SetUnlockedInt64(Index: integer; const Value: Int64); - function GetPointer(Index: integer): Pointer; - procedure SetPointer(Index: integer; const Value: Pointer); - function GetUTF8(Index: integer): RawUTF8; - procedure SetUTF8(Index: integer; const Value: RawUTF8); - function GetIsLocked: boolean; {$ifdef HASINLINE}inline;{$endif} - {$endif NOVARIANTS} - public - /// number of values stored in the internal Padding[] array - // - equals 0 if no value is actually stored, or a 1..7 number otherwise - // - you should not have to use this field, but for optimized low-level - // direct access to Padding[] values, within a Lock/UnLock safe block - PaddingUsedCount: integer; - /// internal padding data, also used to store up to 7 variant values - // - this memory buffer will ensure no CPU cache line mixup occurs - // - you should not use this field directly, but rather the Locked[], - // LockedInt64[], LockedUTF8[] or LockedPointer[] methods - // - if you want to access those array values, ensure you protect them - // using a Safe.Lock; try ... Padding[n] ... finally Safe.Unlock structure, - // and maintain the PaddingUsedCount field accurately - Padding: array[0..6] of TVarData; - /// initialize the mutex - // - calling this method is mandatory (e.g. in the class constructor owning - // the TSynLocker instance), otherwise you may encounter unexpected - // behavior, like access violations or memory leaks - procedure Init; - /// finalize the mutex - // - calling this method is mandatory (e.g. in the class destructor owning - // the TSynLocker instance), otherwise you may encounter unexpected - // behavior, like access violations or memory leaks - procedure Done; - /// finalize the mutex, and call FreeMem() on the pointer of this instance - // - should have been initiazed with a NewSynLocker call - procedure DoneAndFreeMem; - /// lock the instance for exclusive access - // - this method is re-entrant from the same thread (you can nest Lock/UnLock - // calls in the same thread), but would block any other Lock attempt in - // another thread - // - use as such to avoid race condition (from a Safe: TSynLocker property): - // ! Safe.Lock; - // ! try - // ! ... - // ! finally - // ! Safe.Unlock; - // ! end; - procedure Lock; {$ifdef HASINLINE}inline;{$endif} - /// will try to acquire the mutex - // - use as such to avoid race condition (from a Safe: TSynLocker property): - // ! if Safe.TryLock then - // ! try - // ! ... - // ! finally - // ! Safe.Unlock; - // ! end; - function TryLock: boolean; {$ifdef HASINLINE}inline;{$endif} - /// will try to acquire the mutex for a given time - // - use as such to avoid race condition (from a Safe: TSynLocker property): - // ! if Safe.TryLockMS(100) then - // ! try - // ! ... - // ! finally - // ! Safe.Unlock; - // ! end; - function TryLockMS(retryms: integer): boolean; - /// release the instance for exclusive access - // - each Lock/TryLock should have its exact UnLock opposite, so a - // try..finally block is mandatory for safe code - procedure UnLock; {$ifdef HASINLINE}inline;{$endif} - /// will enter the mutex until the IUnknown reference is released - // - could be used as such under Delphi: - // !begin - // ! ... // unsafe code - // ! Safe.ProtectMethod; - // ! ... // thread-safe code - // !end; // local hidden IUnknown will release the lock for the method - // - warning: under FPC, you should assign its result to a local variable - - // see bug http://bugs.freepascal.org/view.php?id=26602 - // !var LockFPC: IUnknown; - // !begin - // ! ... // unsafe code - // ! LockFPC := Safe.ProtectMethod; - // ! ... // thread-safe code - // !end; // LockFPC will release the lock for the method - // or - // !begin - // ! ... // unsafe code - // ! with Safe.ProtectMethod do begin - // ! ... // thread-safe code - // ! end; // local hidden IUnknown will release the lock for the method - // !end; - function ProtectMethod: IUnknown; - /// returns true if the mutex is currently locked by another thread - property IsLocked: boolean read GetIsLocked; - /// returns true if the Init method has been called for this mutex - // - is only relevant if the whole object has been previously filled with 0, - // i.e. as part of a class or as global variable, but won't be accurate - // when allocated on stack - property IsInitialized: boolean read fInitialized; - {$ifndef NOVARIANTS} - /// safe locked access to a Variant value - // - you may store up to 7 variables, using an 0..6 index, shared with - // LockedBool, LockedInt64, LockedPointer and LockedUTF8 array properties - // - returns null if the Index is out of range - property Locked[Index: integer]: Variant read GetVariant write SetVariant; - /// safe locked access to a Int64 value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked and LockedUTF8 array properties - // - Int64s will be stored internally as a varInt64 variant - // - returns nil if the Index is out of range, or does not store a Int64 - property LockedInt64[Index: integer]: Int64 read GetInt64 write SetInt64; - /// safe locked access to a boolean value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked, LockedInt64, LockedPointer and LockedUTF8 array properties - // - value will be stored internally as a varBoolean variant - // - returns nil if the Index is out of range, or does not store a boolean - property LockedBool[Index: integer]: boolean read GetBool write SetBool; - /// safe locked access to a pointer/TObject value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked, LockedBool, LockedInt64 and LockedUTF8 array properties - // - pointers will be stored internally as a varUnknown variant - // - returns nil if the Index is out of range, or does not store a pointer - property LockedPointer[Index: integer]: Pointer read GetPointer write SetPointer; - /// safe locked access to an UTF-8 string value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked and LockedPointer array properties - // - UTF-8 string will be stored internally as a varString variant - // - returns '' if the Index is out of range, or does not store a string - property LockedUTF8[Index: integer]: RawUTF8 read GetUTF8 write SetUTF8; - /// safe locked in-place increment to an Int64 value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked and LockedUTF8 array properties - // - Int64s will be stored internally as a varInt64 variant - // - returns the newly stored value - // - if the internal value is not defined yet, would use 0 as default value - function LockedInt64Increment(Index: integer; const Increment: Int64): Int64; - /// safe locked in-place exchange of a Variant value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked and LockedUTF8 array properties - // - returns the previous stored value, or null if the Index is out of range - function LockedExchange(Index: integer; const Value: variant): variant; - /// safe locked in-place exchange of a pointer/TObject value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked and LockedUTF8 array properties - // - pointers will be stored internally as a varUnknown variant - // - returns the previous stored value, nil if the Index is out of range, - // or does not store a pointer - function LockedPointerExchange(Index: integer; Value: pointer): pointer; - /// unsafe access to a Int64 value - // - you may store up to 7 variables, using an 0..6 index, shared with - // Locked and LockedUTF8 array properties - // - Int64s will be stored internally as a varInt64 variant - // - returns nil if the Index is out of range, or does not store a Int64 - // - you should rather call LockedInt64[] property, or use this property - // with a Lock; try ... finally UnLock block - property UnlockedInt64[Index: integer]: Int64 read GetUnlockedInt64 write SetUnlockedInt64; - {$endif NOVARIANTS} - end; - PSynLocker = ^TSynLocker; - - /// adding locking methods to a TSynPersistent with virtual constructor - // - you may use this class instead of the RTL TCriticalSection, since it - // would use a TSynLocker which does not suffer from CPU cache line conflit - TSynPersistentLock = class(TSynPersistent) - protected - fSafe: PSynLocker; // TSynLocker would increase inherited fields offset - public - /// initialize the instance, and its associated lock - constructor Create; override; - /// finalize the instance, and its associated lock - destructor Destroy; override; - /// access to the associated instance critical section - // - call Safe.Lock/UnLock to protect multi-thread access on this storage - property Safe: PSynLocker read fSafe; - end; - - /// used for backward compatibility only with existing code - TSynPersistentLocked = class(TSynPersistentLock); - - /// adding locking methods to a TInterfacedObject with virtual constructor - TInterfacedObjectLocked = class(TInterfacedObjectWithCustomCreate) - protected - fSafe: PSynLocker; // TSynLocker would increase inherited fields offset - public - /// initialize the object instance, and its associated lock - constructor Create; override; - /// release the instance (including the locking resource) - destructor Destroy; override; - /// access to the locking methods of this instance - // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block - property Safe: PSynLocker read fSafe; - end; - - /// used to determine the exact class type of a TInterfacedObjectWithCustomCreate - // - could be used to create instances using its virtual constructor - TInterfacedObjectWithCustomCreateClass = class of TInterfacedObjectWithCustomCreate; - - /// used to determine the exact class type of a TPersistentWithCustomCreateClass - // - could be used to create instances using its virtual constructor - TPersistentWithCustomCreateClass = class of TPersistentWithCustomCreate; - - /// used to determine the exact class type of a TSynPersistent - // - could be used to create instances using its virtual constructor - TSynPersistentClass = class of TSynPersistent; - - - /// used to store one list of hashed RawUTF8 in TRawUTF8Interning pool - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}TRawUTF8InterningSlot = record - {$else}TRawUTF8InterningSlot = object{$endif} - public - /// actual RawUTF8 storage - Value: TRawUTF8DynArray; - /// hashed access to the Value[] list - Values: TDynArrayHashed; - /// associated mutex for thread-safe process - Safe: TSynLocker; - /// initialize the RawUTF8 slot (and its Safe mutex) - procedure Init; - /// finalize the RawUTF8 slot - mainly its associated Safe mutex - procedure Done; - /// returns the interned RawUTF8 value - procedure Unique(var aResult: RawUTF8; const aText: RawUTF8; aTextHash: cardinal); - /// ensure the supplied RawUTF8 value is interned - procedure UniqueText(var aText: RawUTF8; aTextHash: cardinal); - /// delete all stored RawUTF8 values - procedure Clear; - /// reclaim any unique RawUTF8 values - function Clean(aMaxRefCount: integer): integer; - /// how many items are currently stored in Value[] - function Count: integer; - end; - - /// allow to store only one copy of distinct RawUTF8 values - // - thanks to the Copy-On-Write feature of string variables, this may - // reduce a lot the memory overhead of duplicated text content - // - this class is thread-safe and optimized for performance - TRawUTF8Interning = class(TSynPersistent) - protected - fPool: array of TRawUTF8InterningSlot; - fPoolLast: integer; - public - /// initialize the storage and its internal hash pools - // - aHashTables is the pool size, and should be a power of two <= 512 - constructor Create(aHashTables: integer=4); reintroduce; - /// finalize the storage - destructor Destroy; override; - /// return a RawUTF8 variable stored within this class - // - if aText occurs for the first time, add it to the internal string pool - // - if aText does exist in the internal string pool, return the shared - // instance (with its reference counter increased), to reduce memory usage - function Unique(const aText: RawUTF8): RawUTF8; overload; - /// return a RawUTF8 variable stored within this class from a text buffer - // - if aText occurs for the first time, add it to the internal string pool - // - if aText does exist in the internal string pool, return the shared - // instance (with its reference counter increased), to reduce memory usage - function Unique(aText: PUTF8Char; aTextLen: PtrInt): RawUTF8; overload; - /// return a RawUTF8 variable stored within this class - // - if aText occurs for the first time, add it to the internal string pool - // - if aText does exist in the internal string pool, return the shared - // instance (with its reference counter increased), to reduce memory usage - procedure Unique(var aResult: RawUTF8; const aText: RawUTF8); overload; - /// return a RawUTF8 variable stored within this class from a text buffer - // - if aText occurs for the first time, add it to the internal string pool - // - if aText does exist in the internal string pool, return the shared - // instance (with its reference counter increased), to reduce memory usage - procedure Unique(var aResult: RawUTF8; aText: PUTF8Char; aTextLen: PtrInt); overload; - {$ifdef HASINLINE}inline;{$endif} - /// ensure a RawUTF8 variable is stored within this class - // - if aText occurs for the first time, add it to the internal string pool - // - if aText does exist in the internal string pool, set the shared - // instance (with its reference counter increased), to reduce memory usage - procedure UniqueText(var aText: RawUTF8); - {$ifndef NOVARIANTS} - /// return a variant containing a RawUTF8 stored within this class - // - similar to RawUTF8ToVariant(), but with string interning - procedure UniqueVariant(var aResult: variant; const aText: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - /// return a variant containing a RawUTF8 stored within this class - // - similar to RawUTF8ToVariant(StringToUTF8()), but with string interning - // - this method expects the text to be supplied as a VCL string, which will - // be converted into a variant containing a RawUTF8 varString instance - procedure UniqueVariantString(var aResult: variant; const aText: string); - /// return a variant, may be containing a RawUTF8 stored within this class - // - similar to TextToVariant(), but with string interning - // - first try with GetNumericVariantFromJSON(), then fallback to - // RawUTF8ToVariant() with string variable interning - procedure UniqueVariant(var aResult: variant; aText: PUTF8Char; aTextLen: PtrInt; - aAllowVarDouble: boolean=false); overload; - /// ensure a variant contains only RawUTF8 stored within this class - // - supplied variant should be a varString containing a RawUTF8 value - procedure UniqueVariant(var aResult: variant); overload; {$ifdef HASINLINE}inline;{$endif} - {$endif NOVARIANTS} - /// delete any previous storage pool - procedure Clear; - /// reclaim any unique RawUTF8 values - // - i.e. run a garbage collection process of all values with RefCount=1 - // by default, i.e. all string which are not used any more; you may set - // aMaxRefCount to a higher value, depending on your expecations, i.e. 2 to - // delete all string which are referenced only once outside of the pool - // - returns the number of unique RawUTF8 cleaned from the internal pool - // - to be executed on a regular basis - but not too often, since the - // process can be time consumming, and void the benefit of interning - function Clean(aMaxRefCount: integer=1): integer; - /// how many items are currently stored in this instance - function Count: integer; - end; - - /// store one Name/Value pair, as used by TSynNameValue class - TSynNameValueItem = record - /// the name of the Name/Value pair - // - this property is hashed by TSynNameValue for fast retrieval - Name: RawUTF8; - /// the value of the Name/Value pair - Value: RawUTF8; - /// any associated Pointer or numerical value - Tag: PtrInt; - end; - - /// Name/Value pairs storage, as used by TSynNameValue class - TSynNameValueItemDynArray = array of TSynNameValueItem; - - /// event handler used to convert on the fly some UTF-8 text content - TOnSynNameValueConvertRawUTF8 = function(const text: RawUTF8): RawUTF8 of object; - - /// callback event used by TSynNameValue - TOnSynNameValueNotify = procedure(const Item: TSynNameValueItem; Index: PtrInt) of object; - - /// pseudo-class used to store Name/Value RawUTF8 pairs - // - use internaly a TDynArrayHashed instance for fast retrieval - // - is therefore faster than TRawUTF8List - // - is defined as an object, not as a class: you can use this in any - // class, without the need to destroy the content - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}TSynNameValue = record - {$else}TSynNameValue = object {$endif} - private - fOnAdd: TOnSynNameValueNotify; - function GetBlobData: RawByteString; - procedure SetBlobData(const aValue: RawByteString); - function GetStr(const aName: RawUTF8): RawUTF8; {$ifdef HASINLINE}inline;{$endif} - function GetInt(const aName: RawUTF8): Int64; {$ifdef HASINLINE}inline;{$endif} - function GetBool(const aName: RawUTF8): Boolean; {$ifdef HASINLINE}inline;{$endif} - public - /// the internal Name/Value storage - List: TSynNameValueItemDynArray; - /// the number of Name/Value pairs - Count: integer; - /// low-level access to the internal storage hasher - DynArray: TDynArrayHashed; - /// initialize the storage - // - will also reset the internal List[] and the internal hash array - procedure Init(aCaseSensitive: boolean); - /// add an element to the array - // - if aName already exists, its associated Value will be updated - procedure Add(const aName, aValue: RawUTF8; aTag: PtrInt=0); - /// reset content, then add all name=value pairs from a supplied .ini file - // section content - // - will first call Init(false) to initialize the internal array - // - Section can be retrieved e.g. via FindSectionFirstLine() - procedure InitFromIniSection(Section: PUTF8Char; OnTheFlyConvert: TOnSynNameValueConvertRawUTF8=nil; - OnAdd: TOnSynNameValueNotify=nil); - /// reset content, then add all name=value; CSV pairs - // - will first call Init(false) to initialize the internal array - // - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled - procedure InitFromCSV(CSV: PUTF8Char; NameValueSep: AnsiChar='='; - ItemSep: AnsiChar=#10); - /// reset content, then add all fields from an JSON object - // - will first call Init() to initialize the internal array - // - then parse the incoming JSON object, storing all its field values - // as RawUTF8, and returning TRUE if the supplied content is correct - // - warning: the supplied JSON buffer will be decoded and modified in-place - function InitFromJSON(JSON: PUTF8Char; aCaseSensitive: boolean=false): boolean; - /// reset content, then add all name, value pairs - // - will first call Init(false) to initialize the internal array - procedure InitFromNamesValues(const Names, Values: array of RawUTF8); - /// search for a Name, return the index in List - // - using fast O(1) hash algoritm - function Find(const aName: RawUTF8): integer; - /// search for the first chars of a Name, return the index in List - // - using O(n) calls of IdemPChar() function - // - here aUpperName should be already uppercase, as expected by IdemPChar() - function FindStart(const aUpperName: RawUTF8): integer; - /// search for a Value, return the index in List - // - using O(n) brute force algoritm with case-sensitive aValue search - function FindByValue(const aValue: RawUTF8): integer; - /// search for a Name, and delete its entry in the List if it exists - function Delete(const aName: RawUTF8): boolean; - /// search for a Value, and delete its entry in the List if it exists - // - returns the number of deleted entries - // - you may search for more than one match, by setting a >1 Limit value - function DeleteByValue(const aValue: RawUTF8; Limit: integer=1): integer; - /// search for a Name, return the associated Value as a UTF-8 string - function Value(const aName: RawUTF8; const aDefaultValue: RawUTF8=''): RawUTF8; - /// search for a Name, return the associated Value as integer - function ValueInt(const aName: RawUTF8; const aDefaultValue: Int64=0): Int64; - /// search for a Name, return the associated Value as boolean - // - returns true only if the value is exactly '1' - function ValueBool(const aName: RawUTF8): Boolean; - /// search for a Name, return the associated Value as an enumerate - // - returns true and set aEnum if aName was found, and associated value - // matched an aEnumTypeInfo item - // - returns false if no match was found - function ValueEnum(const aName: RawUTF8; aEnumTypeInfo: pointer; out aEnum; - aEnumDefault: byte=0): boolean; overload; - /// returns all values, as CSV or INI content - function AsCSV(const KeySeparator: RawUTF8='='; - const ValueSeparator: RawUTF8=#13#10; const IgnoreKey: RawUTF8=''): RawUTF8; - /// returns all values as a JSON object of string fields - function AsJSON: RawUTF8; - /// fill the supplied two arrays of RawUTF8 with the stored values - procedure AsNameValues(out Names,Values: TRawUTF8DynArray); - {$ifndef NOVARIANTS} - /// search for a Name, return the associated Value as variant - // - returns null if the name was not found - function ValueVariantOrNull(const aName: RawUTF8): variant; - /// compute a TDocVariant document from the stored values - // - output variant will be reset and filled as a TDocVariant instance, - // ready to be serialized as a JSON object - // - if there is no value stored (i.e. Count=0), set null - procedure AsDocVariant(out DocVariant: variant; - ExtendedJson: boolean=false; ValueAsString: boolean=true; - AllowVarDouble: boolean=false); overload; - /// compute a TDocVariant document from the stored values - function AsDocVariant(ExtendedJson: boolean=false; ValueAsString: boolean=true): variant; overload; {$ifdef HASINLINE}inline;{$endif} - /// merge the stored values into a TDocVariant document - // - existing properties would be updated, then new values will be added to - // the supplied TDocVariant instance, ready to be serialized as a JSON object - // - if ValueAsString is TRUE, values would be stored as string - // - if ValueAsString is FALSE, numerical values would be identified by - // IsString() and stored as such in the resulting TDocVariant - // - if you let ChangedProps point to a TDocVariantData, it would contain - // an object with the stored values, just like AsDocVariant - // - returns the number of updated values in the TDocVariant, 0 if - // no value was changed - function MergeDocVariant(var DocVariant: variant; - ValueAsString: boolean; ChangedProps: PVariant=nil; - ExtendedJson: boolean=false; AllowVarDouble: boolean=false): integer; - {$endif} - /// returns true if the Init() method has been called - function Initialized: boolean; - /// can be used to set all data from one BLOB memory buffer - procedure SetBlobDataPtr(aValue: pointer); - /// can be used to set or retrieve all stored data as one BLOB content - property BlobData: RawByteString read GetBlobData write SetBlobData; - /// event triggerred after an item has just been added to the list - property OnAfterAdd: TOnSynNameValueNotify read fOnAdd write fOnAdd; - /// search for a Name, return the associated Value as a UTF-8 string - // - returns '' if aName is not found in the stored keys - property Str[const aName: RawUTF8]: RawUTF8 read GetStr; default; - /// search for a Name, return the associated Value as integer - // - returns 0 if aName is not found, or not a valid Int64 in the stored keys - property Int[const aName: RawUTF8]: Int64 read GetInt; - /// search for a Name, return the associated Value as boolean - // - returns true if aName stores '1' as associated value - property Bool[const aName: RawUTF8]: Boolean read GetBool; - end; - - /// a reference pointer to a Name/Value RawUTF8 pairs storage - PSynNameValue = ^TSynNameValue; - -/// allocate and initialize a TSynLocker instance -// - caller should call result^.DoneAndFreemem when not used any more -function NewSynLocker: PSynLocker; - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to add an item to a array of pointer dynamic array storage -function PtrArrayAdd(var aPtrArray; aItem: pointer): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to add once an item to a array of pointer dynamic array storage -function PtrArrayAddOnce(var aPtrArray; aItem: pointer): integer; - -/// wrapper to delete an item from a array of pointer dynamic array storage -function PtrArrayDelete(var aPtrArray; aItem: pointer; aCount: PInteger=nil): integer; overload; - -/// wrapper to delete an item from a array of pointer dynamic array storage -procedure PtrArrayDelete(var aPtrArray; aIndex: integer; aCount: PInteger=nil); overload; - -/// wrapper to find an item to a array of pointer dynamic array storage -function PtrArrayFind(var aPtrArray; aItem: pointer): integer; - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to add an item to a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - could be used as such (note the T*ObjArray type naming convention): -// ! TUserObjArray = array of TUser; -// ! ... -// ! var arr: TUserObjArray; -// ! user: TUser; -// ! .. -// ! try -// ! user := TUser.Create; -// ! user.Name := 'Name'; -// ! index := ObjArrayAdd(arr,user); -// ! ... -// ! finally -// ! ObjArrayClear(arr); // release all items -// ! end; -// - return the index of the item in the dynamic array -function ObjArrayAdd(var aObjArray; aItem: TObject): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to add items to a T*ObjArray dynamic array storage -// - aSourceObjArray[] items are just copied to aDestObjArray, which remains untouched -// - return the new number of the items in aDestObjArray -function ObjArrayAddFrom(var aDestObjArray; const aSourceObjArray): PtrInt; - -/// wrapper to add and move items to a T*ObjArray dynamic array storage -// - aSourceObjArray[] items will be owned by aDestObjArray[], therefore -// aSourceObjArray is set to nil -// - return the new number of the items in aDestObjArray -function ObjArrayAppend(var aDestObjArray, aSourceObjArray): PtrInt; - -/// wrapper to add an item to a T*ObjArray dynamic array storage -// - this overloaded function will use a separated variable to store the items -// count, so will be slightly faster: but you should call SetLength() when done, -// to have an array as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - return the index of the item in the dynamic array -function ObjArrayAddCount(var aObjArray; aItem: TObject; var aObjArrayCount: integer): PtrInt; - -/// wrapper to add once an item to a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - if the object is already in the array (searching by address/reference, -// not by content), return its current index in the dynamic array -// - if the object does not appear in the array, add it at the end -procedure ObjArrayAddOnce(var aObjArray; aItem: TObject); - -// - aSourceObjArray[] items are just copied to aDestObjArray, which remains untouched -// - will first check if aSourceObjArray[] items are not already in aDestObjArray -// - return the new number of the items in aDestObjArray -function ObjArrayAddOnceFrom(var aDestObjArray; const aSourceObjArray): PtrInt; - -/// wrapper to set the length of a T*ObjArray dynamic array storage -// - could be used as an alternative to SetLength() when you do not -// know the exact T*ObjArray type -procedure ObjArraySetLength(var aObjArray; aLength: integer); - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to search an item in a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - search is performed by address/reference, not by content -// - returns -1 if the item is not found in the dynamic array -function ObjArrayFind(const aObjArray; aItem: TObject): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to search an item in a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - search is performed by address/reference, not by content -// - returns -1 if the item is not found in the dynamic array -function ObjArrayFind(const aObjArray; aCount: integer; aItem: TObject): PtrInt; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to count all not nil items in a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -function ObjArrayCount(const aObjArray): integer; - -/// wrapper to delete an item in a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - do nothing if the index is out of range in the dynamic array -procedure ObjArrayDelete(var aObjArray; aItemIndex: PtrInt; - aContinueOnException: boolean=false; aCount: PInteger=nil); overload; - -/// wrapper to delete an item in a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - search is performed by address/reference, not by content -// - do nothing if the item is not found in the dynamic array -function ObjArrayDelete(var aObjArray; aItem: TObject): PtrInt; overload; - -/// wrapper to delete an item in a T*ObjArray dynamic array storage -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - search is performed by address/reference, not by content -// - do nothing if the item is not found in the dynamic array -function ObjArrayDelete(var aObjArray; aCount: integer; aItem: TObject): PtrInt; overload; - -/// wrapper to sort the items stored in a T*ObjArray dynamic array -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -procedure ObjArraySort(var aObjArray; Compare: TDynArraySortCompare); - -/// wrapper to release all items stored in a T*ObjArray dynamic array -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - you should always use ObjArrayClear() before the array storage is released, -// e.g. in the owner class destructor -// - will also set the dynamic array length to 0, so could be used to re-use -// an existing T*ObjArray -procedure ObjArrayClear(var aObjArray); overload; - -/// wrapper to release all items stored in a T*ObjArray dynamic array -// - this overloaded function will use the supplied array length as parameter -// - you should always use ObjArrayClear() before the array storage is released, -// e.g. in the owner class destructor -// - will also set the dynamic array length to 0, so could be used to re-use -// an existing T*ObjArray -procedure ObjArrayClear(var aObjArray; aCount: integer); overload; - -/// wrapper to release all items stored in a T*ObjArray dynamic array -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -// - you should always use ObjArrayClear() before the array storage is released, -// e.g. in the owner class destructor -// - will also set the dynamic array length to 0, so could be used to re-use -// an existing T*ObjArray -procedure ObjArrayClear(var aObjArray; aContinueOnException: boolean; - aCount: PInteger=nil); overload; - -/// wrapper to release all items stored in an array of T*ObjArray dynamic array -// - e.g. aObjArray may be defined as "array of array of TSynFilter" -procedure ObjArrayObjArrayClear(var aObjArray); - -/// wrapper to release all items stored in several T*ObjArray dynamic arrays -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -procedure ObjArraysClear(const aObjArray: array of pointer); - -/// low-level function calling FreeAndNil(o^) successively n times -procedure RawObjectsClear(o: PObject; n: integer); - -{$ifndef DELPHI5OROLDER} - -/// wrapper to add an item to a T*InterfaceArray dynamic array storage -function InterfaceArrayAdd(var aInterfaceArray; const aItem: IUnknown): PtrInt; - -/// wrapper to add once an item to a T*InterfaceArray dynamic array storage -procedure InterfaceArrayAddOnce(var aInterfaceArray; const aItem: IUnknown); - -/// wrapper to search an item in a T*InterfaceArray dynamic array storage -// - search is performed by address/reference, not by content -// - return -1 if the item is not found in the dynamic array, or the index of -// the matching entry otherwise -function InterfaceArrayFind(const aInterfaceArray; const aItem: IUnknown): PtrInt; - {$ifdef HASINLINE}inline;{$endif} - -/// wrapper to delete an item in a T*InterfaceArray dynamic array storage -// - search is performed by address/reference, not by content -// - do nothing if the item is not found in the dynamic array -function InterfaceArrayDelete(var aInterfaceArray; const aItem: IUnknown): PtrInt; overload; - -/// wrapper to delete an item in a T*InterfaceArray dynamic array storage -// - do nothing if the item is not found in the dynamic array -procedure InterfaceArrayDelete(var aInterfaceArray; aItemIndex: PtrInt); overload; - -{$endif DELPHI5OROLDER} - - -/// helper to retrieve the text of an enumerate item -// - see also RTTI related classes of mORMot.pas unit, e.g. TEnumType -function GetEnumName(aTypeInfo: pointer; aIndex: integer): PShortString; - -/// helper to retrieve all texts of an enumerate -// - may be used as cache for overloaded ToText() content -procedure GetEnumNames(aTypeInfo: pointer; aDest: PPShortString); - -/// helper to retrieve all trimmed texts of an enumerate -// - may be used as cache to retrieve UTF-8 text without lowercase 'a'..'z' chars -procedure GetEnumTrimmedNames(aTypeInfo: pointer; aDest: PRawUTF8); overload; - -/// helper to retrieve all trimmed texts of an enumerate as UTF-8 strings -function GetEnumTrimmedNames(aTypeInfo: pointer): TRawUTF8DynArray; overload; - -/// helper to retrieve all (translated) caption texts of an enumerate -// - may be used as cache for overloaded ToCaption() content -procedure GetEnumCaptions(aTypeInfo: pointer; aDest: PString); - -/// UnCamelCase and translate the enumeration item -function GetCaptionFromEnum(aTypeInfo: pointer; aIndex: integer): string; - -/// low-level helper to retrieve a (translated) caption from a PShortString -// - as used e.g. by GetEnumCaptions or GetCaptionFromEnum -procedure GetCaptionFromTrimmed(PS: PShortString; var result: string); - -/// helper to retrieve the index of an enumerate item from its text -// - returns -1 if aValue was not found -// - will search for the exact text and also trim the lowercase 'a'..'z' chars on -// left side of the text if no exact match is found and AlsoTrimLowerCase is TRUE -// - see also RTTI related classes of mORMot.pas unit, e.g. TEnumType -function GetEnumNameValue(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt; - AlsoTrimLowerCase: boolean=false): Integer; overload; - -/// retrieve the index of an enumerate item from its left-trimmed text -// - text comparison is case-insensitive for A-Z characters -// - will trim the lowercase 'a'..'z' chars on left side of the supplied aValue text -// - returns -1 if aValue was not found -function GetEnumNameValueTrimmed(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer; - -/// retrieve the index of an enumerate item from its left-trimmed text -// - text comparison is case-sensitive for A-Z characters -// - will trim the lowercase 'a'..'z' chars on left side of the supplied aValue text -// - returns -1 if aValue was not found -function GetEnumNameValueTrimmedExact(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer; - -/// helper to retrieve the index of an enumerate item from its text -function GetEnumNameValue(aTypeInfo: pointer; const aValue: RawUTF8; - AlsoTrimLowerCase: boolean=false): Integer; overload; - -/// helper to retrieve the bit mapped integer value of a set from its JSON text -// - if supplied P^ is a JSON integer number, will read it directly -// - if P^ maps some ["item1","item2"] content, would fill all matching bits -// - if P^ contains ['*'], would fill all bits -// - returns P=nil if reached prematurly the end of content, or returns -// the value separator (e.g. , or }) in EndOfObject (like GetJsonField) -function GetSetNameValue(aTypeInfo: pointer; var P: PUTF8Char; - out EndOfObject: AnsiChar): cardinal; - -/// helper to retrieve the CSV text of all enumerate items defined in a set -// - you'd better use RTTI related classes of mORMot.pas unit, e.g. TEnumType -function GetSetName(aTypeInfo: pointer; const value): RawUTF8; - -/// helper to retrieve the CSV text of all enumerate items defined in a set -// - you'd better use RTTI related classes of mORMot.pas unit, e.g. TEnumType -procedure GetSetNameShort(aTypeInfo: pointer; const value; out result: ShortString; - trimlowercase: boolean=false); - -/// low-level helper to retrive the base enumeration RTTI of a given set -function GetSetBaseEnum(aTypeInfo: pointer): pointer; - -/// fast append some UTF-8 text into a shortstring, with an ending ',' -procedure AppendShortComma(text: PAnsiChar; len: PtrInt; var result: shortstring; - trimlowercase: boolean); - -/// fast search of an exact case-insensitive match of a RTTI's PShortString array -function FindShortStringListExact(List: PShortString; MaxValue: integer; - aValue: PUTF8Char; aValueLen: PtrInt): integer; - -/// fast case-insensitive search of a left-trimmed lowercase match -// of a RTTI's PShortString array -function FindShortStringListTrimLowerCase(List: PShortString; MaxValue: integer; - aValue: PUTF8Char; aValueLen: PtrInt): integer; - -/// fast case-sensitive search of a left-trimmed lowercase match -// of a RTTI's PShortString array -function FindShortStringListTrimLowerCaseExact(List: PShortString; MaxValue: integer; - aValue: PUTF8Char; aValueLen: PtrInt): integer; - -/// retrieve the type name from its low-level RTTI -function TypeInfoToName(aTypeInfo: pointer): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// retrieve the type name from its low-level RTTI -procedure TypeInfoToName(aTypeInfo: pointer; var result: RawUTF8; - const default: RawUTF8=''); overload; - -/// retrieve the unit name and type name from its low-level RTTI -procedure TypeInfoToQualifiedName(aTypeInfo: pointer; var result: RawUTF8; - const default: RawUTF8=''); - -/// compute a crc32c-based hash of the RTTI for a managed given type -// - can be used to ensure that the RecordSave/TDynArray.SaveTo binary layout -// is compatible accross executables, even between FPC and Delphi -// - will ignore the type names, but will check the RTTI type kind and any -// nested fields (for records or arrays) - for a record/object type, will use -// TTextWriter.RegisterCustomJSONSerializerFromText definition, if available -function TypeInfoToHash(aTypeInfo: pointer): cardinal; - -/// retrieve the record size from its low-level RTTI -function RecordTypeInfoSize(aRecordTypeInfo: pointer): integer; - -/// retrieve the item type information of a dynamic array low-level RTTI -function DynArrayTypeInfoToRecordInfo(aDynArrayTypeInfo: pointer; - aDataSize: PInteger=nil): pointer; - -/// sort any dynamic array, via an external array of indexes -// - this function will use the supplied TSynTempBuffer for index storage, -// so use PIntegerArray(Indexes.buf) to access the values -// - caller should always make Indexes.Done once done -procedure DynArraySortIndexed(Values: pointer; ElemSize, Count: Integer; - out Indexes: TSynTempBuffer; Compare: TDynArraySortCompare); - -/// compare two TGUID values -// - this version is faster than the one supplied by SysUtils -function IsEqualGUID(const guid1, guid2: TGUID): Boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// compare two TGUID values -// - this version is faster than the one supplied by SysUtils -function IsEqualGUID(guid1, guid2: PGUID): Boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns the index of a matching TGUID in an array -// - returns -1 if no item matched -function IsEqualGUIDArray(const guid: TGUID; const guids: array of TGUID): integer; - -/// check if a TGUID value contains only 0 bytes -// - this version is faster than the one supplied by SysUtils -function IsNullGUID({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// append one TGUID item to a TGUID dynamic array -// - returning the newly inserted index in guids[], or an existing index in -// guids[] if NoDuplicates is TRUE and TGUID already exists -function AddGUID(var guids: TGUIDDynArray; const guid: TGUID; - NoDuplicates: boolean=false): integer; - -/// append a TGUID binary content as text -// - will store e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without any {}) -// - this will be the format used for JSON encoding, e.g. -// $ { "UID": "C9A646D3-9C61-4CB7-BFCD-EE2522C8F633" } -function GUIDToText(P: PUTF8Char; guid: PByteArray): PUTF8Char; - -/// convert a TGUID into UTF-8 encoded text -// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) -// - if you do not need the embracing { }, use ToUTF8() overloaded function -function GUIDToRawUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; - -/// convert a TGUID into text -// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) -// - this version is faster than the one supplied by SysUtils -function GUIDToString({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): string; - -type - /// low-level object implementing a 32-bit Pierre L'Ecuyer software generator - // - as used by Random32gsl, and Random32 if no RDRAND hardware is available - // - is not thread-safe by itself, but cross-compiler and cross-platform, still - // very fast with a much better distribution than Delphi system's Random() function - // - Random32gsl/Random32 will use a threadvar to have thread safety - TLecuyer = object - public - rs1, rs2, rs3, seedcount: cardinal; - /// force an immediate seed of the generator from current system state - // - should be called before any call to the Next method - procedure Seed(entropy: PByteArray; entropylen: PtrInt); - /// compute the next 32-bit generated value - // - will automatically reseed after around 65,000 generated values - function Next: cardinal; overload; - /// compute the next 32-bit generated value, in range [0..max-1] - // - will automatically reseed after around 65,000 generated values - function Next(max: cardinal): cardinal; overload; - end; - -/// fast compute of some 32-bit random value -// - will use (slow but) hardware-derivated RDRAND Intel x86/x64 opcode if -// available, or fast gsl_rng_taus2 generator by Pierre L'Ecuyer (which period -// is 2^88, i.e. about 10^26) if the CPU doesn't support it -// - will detect known AMD CPUs RDRAND bugs, and fallback to gsl_rng_taus2 -// - consider Random32gsl to avoid slow RDRAND call (up to 1500 cycles needed!) -// - use rather TAESPRNG.Main.FillRandom() for cryptographic-level randomness -// - thread-safe function: each thread will maintain its own TLecuyer table -function Random32: cardinal; overload; - -/// fast compute of some 32-bit random value, with a maximum (excluded) upper value -// - i.e. returns a value in range [0..max-1] -// - calls internally the overloaded Random32 function -function Random32(max: cardinal): cardinal; overload; - -/// fast compute of some 32-bit random value, using the gsl_rng_taus2 generator -// - Random32 may call RDRAND opcode on Intel CPUs, wherease this function will use -// well documented, much faster, and proven Pierre L'Ecuyer software generator -// - may be used if you don't want/trust RDRAND, if you expect a well defined -// cross-platform generator, or have higher performance expectations -// - use rather TAESPRNG.Main.FillRandom() for cryptographic-level randomness -// - thread-safe function: each thread will maintain its own TLecuyer table -function Random32gsl: cardinal; overload; - -/// fast compute of bounded 32-bit random value, using the gsl_rng_taus2 generator -// - calls internally the overloaded Random32gsl function -function Random32gsl(max: cardinal): cardinal; overload; - -/// seed the gsl_rng_taus2 Random32/Random32gsl generator -// - this seeding won't affect RDRAND Intel x86/x64 opcode generation -// - by default, gsl_rng_taus2 generator is re-seeded every 256KB, much more -// often than the Pierre L'Ecuyer's algorithm period of 2^88 -// - you can specify some additional entropy buffer; note that calling this -// function with the same entropy again WON'T seed the generator with the same -// sequence (as with RTL's RandomSeed function), but initiate a new one -// - thread-specific function: each thread will maintain its own seed table -procedure Random32Seed(entropy: pointer=nil; entropylen: PtrInt=0); - -/// fill some memory buffer with random values -// - the destination buffer is expected to be allocated as 32-bit items -// - use internally crc32c() with some rough entropy source, and Random32 -// gsl_rng_taus2 generator or hardware RDRAND Intel x86/x64 opcode if available -// (and ForceGsl is kept to its default false) -// - consider using instead the cryptographic secure TAESPRNG.Main.FillRandom() -// method from the SynCrypto unit, or set ForceGsl=true - in particular, RDRAND -// is reported as very slow: see https://en.wikipedia.org/wiki/RdRand#Performance -procedure FillRandom(Dest: PCardinalArray; CardinalCount: integer; ForceGsl: boolean=false); - -/// compute a random GUID value -procedure RandomGUID(out result: TGUID); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// compute a random GUID value -function RandomGUID: TGUID; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fill a GUID with 0 -procedure FillZero(var result: TGUID); overload; {$ifdef HASINLINE}inline;{$endif} - -type - /// stack-allocated ASCII string, used by GUIDToShort() function - TGUIDShortString = string[38]; - -const - /// a TGUID containing '{00000000-0000-0000-0000-00000000000}' - GUID_NULL: TGUID = (); - -/// convert a TGUID into text -// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) -// - using a shortstring will allow fast allocation on the stack, so is -// preferred e.g. when providing a GUID to a ESynException.CreateUTF8() -function GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} - guid: TGUID): TGUIDShortString; overload; {$ifdef HASINLINE}inline;{$endif} - -/// convert a TGUID into text -// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) -// - using a shortstring will allow fast allocation on the stack, so is -// preferred e.g. when providing a GUID to a ESynException.CreateUTF8() -procedure GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} - guid: TGUID; out dest: TGUIDShortString); overload; - -/// convert some text into its TGUID binary value -// - expect e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without any {}) -// - return nil if the supplied text buffer is not a valid TGUID -// - this will be the format used for JSON encoding, e.g. -// $ { "UID": "C9A646D3-9C61-4CB7-BFCD-EE2522C8F633" } -function TextToGUID(P: PUTF8Char; guid: PByteArray): PUTF8Char; - -/// convert some text into a TGUID -// - expect e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) -// - return {00000000-0000-0000-0000-000000000000} if the supplied text buffer -// is not a valid TGUID -function StringToGUID(const text: string): TGUID; - -/// convert some UTF-8 encoded text into a TGUID -// - expect e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {}) -// - return {00000000-0000-0000-0000-000000000000} if the supplied text buffer -// is not a valid TGUID -function RawUTF8ToGUID(const text: RawByteString): TGUID; - - -/// check equality of two records by content -// - will handle packed records, with binaries (byte, word, integer...) and -// string types properties -// - will use binary-level comparison: it could fail to match two floating-point -// values because of rounding issues (Currency won't have this problem) -function RecordEquals(const RecA, RecB; TypeInfo: pointer; - PRecSize: PInteger=nil): boolean; - -/// save a record content into a RawByteString -// - will handle packed records, with binaries (byte, word, integer...) and -// string types properties (but not with internal raw pointers, of course) -// - will use a proprietary binary format, with some variable-length encoding -// of the string length - note that if you change the type definition, any -// previously-serialized content will fail, maybe triggering unexpected GPF: you -// may use TypeInfoToHash() if you share this binary data accross executables -// - warning: will encode generic string fields as AnsiString (one byte per char) -// prior to Delphi 2009, and as UnicodeString (two bytes per char) since Delphi -// 2009: if you want to use this function between UNICODE and NOT UNICODE -// versions of Delphi, you should use some explicit types like RawUTF8, -// WinAnsiString, SynUnicode or even RawUnicode/WideString -function RecordSave(const Rec; TypeInfo: pointer): RawByteString; overload; - -/// save a record content into a TBytes dynamic array -// - could be used as an alternative to RawByteString's RecordSave() -function RecordSaveBytes(const Rec; TypeInfo: pointer): TBytes; - -/// save a record content into a destination memory buffer -// - Dest must be at least RecordSaveLength() bytes long -// - will return the Rec size, in bytes, into Len reference variable -// - will handle packed records, with binaries (byte, word, integer...) and -// string types properties (but not with internal raw pointers, of course) -// - will use a proprietary binary format, with some variable-length encoding -// of the string length - note that if you change the type definition, any -// previously-serialized content will fail, maybe triggering unexpected GPF: you -// may use TypeInfoToHash() if you share this binary data accross executables -// - warning: will encode generic string fields as AnsiString (one byte per char) -// prior to Delphi 2009, and as UnicodeString (two bytes per char) since Delphi -// 2009: if you want to use this function between UNICODE and NOT UNICODE -// versions of Delphi, you should use some explicit types like RawUTF8, -// WinAnsiString, SynUnicode or even RawUnicode/WideString -function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer; - out Len: integer): PAnsiChar; overload; - -/// save a record content into a destination memory buffer -// - Dest must be at least RecordSaveLength() bytes long -// - will handle packed records, with binaries (byte, word, integer...) and -// string types properties (but not with internal raw pointers, of course) -// - will use a proprietary binary format, with some variable-length encoding -// of the string length - note that if you change the type definition, any -// previously-serialized content will fail, maybe triggering unexpected GPF: you -// may use TypeInfoToHash() if you share this binary data accross executables -// - warning: will encode generic string fields as AnsiString (one byte per char) -// prior to Delphi 2009, and as UnicodeString (two bytes per char) since Delphi -// 2009: if you want to use this function between UNICODE and NOT UNICODE -// versions of Delphi, you should use some explicit types like RawUTF8, -// WinAnsiString, SynUnicode or even RawUnicode/WideString -function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer): PAnsiChar; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// save a record content into a destination memory buffer -// - caller should make Dest.Done once finished with Dest.buf/Dest.len buffer -procedure RecordSave(const Rec; var Dest: TSynTempBuffer; TypeInfo: pointer); overload; - -/// save a record content into a Base-64 encoded UTF-8 text content -// - will use RecordSave() format, with a left-sided binary CRC32C -function RecordSaveBase64(const Rec; TypeInfo: pointer; UriCompatible: boolean=false): RawUTF8; - -/// compute the number of bytes needed to save a record content -// using the RecordSave() function -// - will return 0 in case of an invalid (not handled) record type (e.g. if -// it contains an unknown variant) -// - optional Len parameter will contain the Rec memory buffer length, in bytes -function RecordSaveLength(const Rec; TypeInfo: pointer; Len: PInteger=nil): integer; - -/// save record into its JSON serialization as saved by TTextWriter.AddRecordJSON -// - will use default Base64 encoding over RecordSave() binary - or custom true -// JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via -// enhanced RTTI), if available (following EnumSetsAsText optional parameter -// for nested enumerates and sets) -function RecordSaveJSON(const Rec; TypeInfo: pointer; - EnumSetsAsText: boolean=false): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -/// fill a record content from a memory buffer as saved by RecordSave() -// - return nil if the Source buffer is incorrect -// - in case of success, return the memory buffer pointer just after the -// read content, and set the Rec size, in bytes, into Len reference variable -// - will use a proprietary binary format, with some variable-length encoding -// of the string length - note that if you change the type definition, any -// previously-serialized content will fail, maybe triggering unexpected GPF: you -// may use TypeInfoToHash() if you share this binary data accross executables -// - you can optionally provide in SourceMax the first byte after the input -// memory buffer, which will be used to avoid any unexpected buffer overflow - -// would be mandatory when decoding the content from any external process -// (e.g. a maybe-forged client) - only with slightly performance penalty -function RecordLoad(var Rec; Source: PAnsiChar; TypeInfo: pointer; - Len: PInteger=nil; SourceMax: PAnsiChar=nil): PAnsiChar; overload; - -/// fill a record content from a memory buffer as saved by RecordSave() -// - will use the Source length to detect and avoid any buffer overlow -// - returns false if the Source buffer was incorrect, true on success -function RecordLoad(var Res; const Source: RawByteString; TypeInfo: pointer): boolean; overload; - -/// read a record content from a Base-64 encoded content -// - expects RecordSaveBase64() format, with a left-sided binary CRC -function RecordLoadBase64(Source: PAnsiChar; Len: PtrInt; var Rec; TypeInfo: pointer; - UriCompatible: boolean=false): boolean; - -/// fill a record content from a JSON serialization as saved by -// TTextWriter.AddRecordJSON / RecordSaveJSON -// - will use default Base64 encoding over RecordSave() binary - or custom true -// JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via -// enhanced RTTI), if available -// - returns nil on error, or the end of buffer on success -// - warning: the JSON buffer will be modified in-place during process - use -// a temporary copy if you need to access it later or if the string comes from -// a constant (refcount=-1) - see e.g. the overloaded RecordLoadJSON() -function RecordLoadJSON(var Rec; JSON: PUTF8Char; TypeInfo: pointer; - EndOfObject: PUTF8Char=nil{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions=nil{$endif}): PUTF8Char; overload; - -/// fill a record content from a JSON serialization as saved by -// TTextWriter.AddRecordJSON / RecordSaveJSON -// - this overloaded function will make a private copy before parsing it, -// so is safe with a read/only or shared string - but slightly slower -// - will use default Base64 encoding over RecordSave() binary - or custom true -// JSON format (as set by TTextWriter.RegisterCustomJSONSerializer or via -// enhanced RTTI), if available -function RecordLoadJSON(var Rec; const JSON: RawUTF8; TypeInfo: pointer{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions=nil{$endif}): boolean; overload; - -/// copy a record content from source to Dest -// - this unit includes a fast optimized asm version for x86 on Delphi -procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); {$ifdef FPC}inline;{$endif} - -/// clear a record content -// - this unit includes a fast optimized asm version for x86 on Delphi -procedure RecordClear(var Dest; TypeInfo: pointer); {$ifdef FPC}inline;{$endif} - -/// initialize a record content -// - calls RecordClear() and FillCharFast() with 0 -// - do nothing if the TypeInfo is not from a record/object -procedure RecordZero(var Dest; TypeInfo: pointer); - -/// low-level finalization of a dynamic array of variants -// - faster than RTL Finalize() or setting nil -procedure FastDynArrayClear(Value: PPointer; ElemTypeInfo: pointer); - -/// low-level finalization of a dynamic array of RawUTF8 -// - faster than RTL Finalize() or setting nil -procedure RawUTF8DynArrayClear(var Value: TRawUTF8DynArray); - {$ifdef HASINLINE}inline;{$endif} - -{$ifndef DELPHI5OROLDER} -/// copy a dynamic array content from source to Dest -// - uses internally the TDynArray.CopyFrom() method and two temporary -// TDynArray wrappers -procedure DynArrayCopy(var Dest; const Source; SourceMaxElem: integer; - TypeInfo: pointer); -{$endif DELPHI5OROLDER} - -/// fill a dynamic array content from a binary serialization as saved by -// DynArraySave() / TDynArray.Save() -// - Value shall be set to the target dynamic array field -// - just a function helper around TDynArray.Init + TDynArray.* -function DynArrayLoad(var Value; Source: PAnsiChar; TypeInfo: pointer): PAnsiChar; - -/// serialize a dynamic array content as binary, ready to be loaded by -// DynArrayLoad() / TDynArray.Load() -// - Value shall be set to the source dynamic arry field -// - just a function helper around TDynArray.Init + TDynArray.SaveTo -function DynArraySave(var Value; TypeInfo: pointer): RawByteString; - -/// fill a dynamic array content from a JSON serialization as saved by -// TTextWriter.AddDynArrayJSON -// - Value shall be set to the target dynamic array field -// - is just a wrapper around TDynArray.LoadFromJSON(), creating a temporary -// TDynArray wrapper on the stack -// - return a pointer at the end of the data read from JSON, nil in case -// of an invalid input buffer -// - to be used e.g. for custom record JSON unserialization, within a -// TDynArrayJSONCustomReader callback -// - warning: the JSON buffer will be modified in-place during process - use -// a temporary copy if you need to access it later or if the string comes from -// a constant (refcount=-1) - see e.g. the overloaded DynArrayLoadJSON() -function DynArrayLoadJSON(var Value; JSON: PUTF8Char; TypeInfo: pointer; - EndOfObject: PUTF8Char=nil): PUTF8Char; overload; - -/// fill a dynamic array content from a JSON serialization as saved by -// TTextWriter.AddDynArrayJSON, which won't be modified -// - this overloaded function will make a private copy before parsing it, -// so is safe with a read/only or shared string - but slightly slower -function DynArrayLoadJSON(var Value; const JSON: RawUTF8; TypeInfo: pointer): boolean; overload; - -/// serialize a dynamic array content as JSON -// - Value shall be set to the source dynamic array field -// - is just a wrapper around TTextWriter.AddDynArrayJSON(), creating -// a temporary TDynArray wrapper on the stack -// - to be used e.g. for custom record JSON serialization, within a -// TDynArrayJSONCustomWriter callback or RegisterCustomJSONSerializerFromText() -// (following EnumSetsAsText optional parameter for nested enumerates and sets) -function DynArraySaveJSON(const Value; TypeInfo: pointer; - EnumSetsAsText: boolean=false): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -{$ifndef DELPHI5OROLDER} -/// compare two dynamic arrays by calling TDynArray.Equals -function DynArrayEquals(TypeInfo: pointer; var Array1, Array2; - Array1Count: PInteger=nil; Array2Count: PInteger=nil): boolean; -{$endif DELPHI5OROLDER} - -/// serialize a dynamic array content, supplied as raw binary buffer, as JSON -// - Value shall be set to the source dynamic array field -// - is just a wrapper around TTextWriter.AddDynArrayJSON(), creating -// a temporary TDynArray wrapper on the stack -// - to be used e.g. for custom record JSON serialization, within a -// TDynArrayJSONCustomWriter callback or RegisterCustomJSONSerializerFromText() -function DynArrayBlobSaveJSON(TypeInfo, BlobValue: pointer): RawUTF8; - -/// compute a dynamic array element information -// - will raise an exception if the supplied RTTI is not a dynamic array -// - will return the element type name and set ElemTypeInfo otherwise -// - if there is no element type information, an approximative element type name -// will be returned (e.g. 'byte' for an array of 1 byte items), and ElemTypeInfo -// will be set to nil -// - this low-level function is used e.g. by mORMotWrappers unit -function DynArrayElementTypeName(TypeInfo: pointer; ElemTypeInfo: PPointer=nil; - ExactType: boolean=false): RawUTF8; - -/// trim ending 'DynArray' or 's' chars from a dynamic array type name -// - used internally to guess the associated item type name -function DynArrayItemTypeLen(const aDynArrayTypeName: RawUTF8): PtrInt; - -/// was dynamic array item after RegisterCustomJSONSerializerFromTextBinaryType() -// - calls DynArrayItemTypeLen() to guess the internal type name -function DynArrayItemTypeIsSimpleBinary(const aDynArrayTypeName: RawUTF8): boolean; - - -/// compare two "array of boolean" elements -function SortDynArrayBoolean(const A,B): integer; - -/// compare two "array of shortint" elements -function SortDynArrayShortint(const A,B): integer; - -/// compare two "array of byte" elements -function SortDynArrayByte(const A,B): integer; - -/// compare two "array of smallint" elements -function SortDynArraySmallint(const A,B): integer; - -/// compare two "array of word" elements -function SortDynArrayWord(const A,B): integer; - -/// compare two "array of integer" elements -function SortDynArrayInteger(const A,B): integer; - -/// compare two "array of cardinal" elements -function SortDynArrayCardinal(const A,B): integer; - -/// compare two "array of Int64" or "array of Currency" elements -function SortDynArrayInt64(const A,B): integer; - -/// compare two "array of QWord" elements -// - note that QWord(A)>QWord(B) is wrong on older versions of Delphi, so you -// should better use this function or CompareQWord() to properly compare two -// QWord values over CPUX86 -function SortDynArrayQWord(const A,B): integer; - -/// compare two "array of THash128" elements -function SortDynArray128(const A,B): integer; - -/// compare two "array of THash256" elements -function SortDynArray256(const A,B): integer; - -/// compare two "array of THash512" elements -function SortDynArray512(const A,B): integer; - -/// compare two "array of TObject/pointer" elements -function SortDynArrayPointer(const A,B): integer; - -/// compare two "array of single" elements -function SortDynArraySingle(const A,B): integer; - -/// compare two "array of double" elements -function SortDynArrayDouble(const A,B): integer; - -/// compare two "array of AnsiString" elements, with case sensitivity -function SortDynArrayAnsiString(const A,B): integer; - -/// compare two "array of RawByteString" elements, with case sensitivity -// - can't use StrComp() or similar functions since RawByteString may contain #0 -function SortDynArrayRawByteString(const A,B): integer; - -/// compare two "array of AnsiString" elements, with no case sensitivity -function SortDynArrayAnsiStringI(const A,B): integer; - -/// compare two "array of PUTF8Char/PAnsiChar" elements, with case sensitivity -function SortDynArrayPUTF8Char(const A,B): integer; - -/// compare two "array of PUTF8Char/PAnsiChar" elements, with no case sensitivity -function SortDynArrayPUTF8CharI(const A,B): integer; - -/// compare two "array of WideString/UnicodeString" elements, with case sensitivity -function SortDynArrayUnicodeString(const A,B): integer; - -/// compare two "array of WideString/UnicodeString" elements, with no case sensitivity -function SortDynArrayUnicodeStringI(const A,B): integer; - -/// compare two "array of generic string" elements, with case sensitivity -// - the expected string type is the generic VCL string -function SortDynArrayString(const A,B): integer; - -/// compare two "array of generic string" elements, with no case sensitivity -// - the expected string type is the generic VCL string -function SortDynArrayStringI(const A,B): integer; - -/// compare two "array of TFileName" elements, as file names -// - i.e. with no case sensitivity, and grouped by file extension -// - the expected string type is the generic RTL string, i.e. TFileName -// - calls internally GetFileNameWithoutExt() and AnsiCompareFileName() -function SortDynArrayFileName(const A,B): integer; - -{$ifndef NOVARIANTS} -/// compare two "array of variant" elements, with case sensitivity -function SortDynArrayVariant(const A,B): integer; - -/// compare two "array of variant" elements, with no case sensitivity -function SortDynArrayVariantI(const A,B): integer; - -/// compare two "array of variant" elements, with or without case sensitivity -// - this low-level function is called by SortDynArrayVariant/VariantCompare -// - more optimized than the RTL function if A and B share the same type -function SortDynArrayVariantComp(const A,B: TVarData; caseInsensitive: boolean): integer; -{$endif NOVARIANTS} - - -{$ifdef CPU32DELPHI} -const - /// defined for inlining bitwise division in TDynArrayHasher.HashTableIndex - // - HashTableSize<=HASH_PO2 is expected to be a power of two (fast binary op); - // limit is set to 262,144 hash table slots (=1MB), for Capacity=131,072 items - // - above this limit, a set of increasing primes is used; using a prime as - // hashtable modulo enhances its distribution, especially for a weak hash function - // - 64-bit CPU and FPC can efficiently compute a prime reduction using Lemire - // algorithm, so no power of two is defined on those targets - HASH_PO2 = 1 shl 18; -{$endif CPU32DELPHI} - -/// compute the 32-bit default hash of a file content -// - you can specify your own hashing function if DefaultHasher is not what you expect -function HashFile(const FileName: TFileName; Hasher: THasher=nil): cardinal; - -/// hash one AnsiString content with the suppplied Hasher() function -function HashAnsiString(const Elem; Hasher: THasher): cardinal; - -/// case-insensitive hash one AnsiString content with the suppplied Hasher() function -function HashAnsiStringI(const Elem; Hasher: THasher): cardinal; - -/// hash one SynUnicode content with the suppplied Hasher() function -// - work with WideString for all Delphi versions, or UnicodeString in Delphi 2009+ -function HashSynUnicode(const Elem; Hasher: THasher): cardinal; - -/// case-insensitive hash one SynUnicode content with the suppplied Hasher() function -// - work with WideString for all Delphi versions, or UnicodeString in Delphi 2009+ -function HashSynUnicodeI(const Elem; Hasher: THasher): cardinal; - -/// hash one WideString content with the suppplied Hasher() function -// - work with WideString for all Delphi versions -function HashWideString(const Elem; Hasher: THasher): cardinal; - -/// case-insensitive hash one WideString content with the suppplied Hasher() function -// - work with WideString for all Delphi versions -function HashWideStringI(const Elem; Hasher: THasher): cardinal; - -{$ifdef UNICODE} -/// hash one UnicodeString content with the suppplied Hasher() function -// - work with UnicodeString in Delphi 2009+ -function HashUnicodeString(const Elem; Hasher: THasher): cardinal; - -/// case-insensitive hash one UnicodeString content with the suppplied Hasher() function -// - work with UnicodeString in Delphi 2009+ -function HashUnicodeStringI(const Elem; Hasher: THasher): cardinal; -{$endif UNICODE} - -{$ifndef NOVARIANTS} -/// case-sensitive hash one variant content with the suppplied Hasher() function -function HashVariant(const Elem; Hasher: THasher): cardinal; - -/// case-insensitive hash one variant content with the suppplied Hasher() function -function HashVariantI(const Elem; Hasher: THasher): cardinal; -{$endif NOVARIANTS} - -/// hash one PtrUInt (=NativeUInt) value with the suppplied Hasher() function -function HashPtrUInt(const Elem; Hasher: THasher): cardinal; - -/// hash one Byte value -function HashByte(const Elem; Hasher: THasher): cardinal; - -/// hash one Word value -function HashWord(const Elem; Hasher: THasher): cardinal; - -/// hash one Integer/cardinal value - simply return the value ignore Hasher() parameter -function HashInteger(const Elem; Hasher: THasher): cardinal; - -/// hash one Int64/Qword value with the suppplied Hasher() function -function HashInt64(const Elem; Hasher: THasher): cardinal; - -/// hash one THash128 value with the suppplied Hasher() function -function Hash128(const Elem; Hasher: THasher): cardinal; - -/// hash one THash256 value with the suppplied Hasher() function -function Hash256(const Elem; Hasher: THasher): cardinal; - -/// hash one THash512 value with the suppplied Hasher() function -function Hash512(const Elem; Hasher: THasher): cardinal; - -/// hash one pointer value with the suppplied Hasher() function -// - this version is not the same as HashPtrUInt, since it will always -// use the hasher function -function HashPointer(const Elem; Hasher: THasher): cardinal; - -var - /// helper array to get the comparison function corresponding to a given - // standard array type - // - e.g. as DYNARRAY_SORTFIRSTFIELD[CaseInSensitive,djRawUTF8] - // - not to be used as such, but e.g. when inlining TDynArray methods - DYNARRAY_SORTFIRSTFIELD: array[boolean,TDynArrayKind] of TDynArraySortCompare = ( - (nil, SortDynArrayBoolean, SortDynArrayByte, SortDynArrayWord, - SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle, - SortDynArrayInt64, SortDynArrayQWord, SortDynArrayDouble, - SortDynArrayInt64, SortDynArrayInt64, SortDynArrayDouble, SortDynArrayDouble, - SortDynArrayAnsiString, SortDynArrayAnsiString, SortDynArrayString, - SortDynArrayRawByteString, SortDynArrayUnicodeString, - SortDynArrayUnicodeString, SortDynArray128, SortDynArray256, - SortDynArray512, SortDynArrayPointer, - {$ifndef NOVARIANTS}SortDynArrayVariant,{$endif} nil), - (nil, SortDynArrayBoolean, SortDynArrayByte, SortDynArrayWord, - SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle, - SortDynArrayInt64, SortDynArrayQWord, SortDynArrayDouble, - SortDynArrayInt64, SortDynArrayInt64, SortDynArrayDouble, SortDynArrayDouble, - SortDynArrayAnsiStringI, SortDynArrayAnsiStringI, SortDynArrayStringI, - SortDynArrayRawByteString, SortDynArrayUnicodeStringI, - SortDynArrayUnicodeStringI, SortDynArray128, SortDynArray256, - SortDynArray512, SortDynArrayPointer, - {$ifndef NOVARIANTS}SortDynArrayVariantI,{$endif} nil)); - - /// helper array to get the hashing function corresponding to a given - // standard array type - // - e.g. as DYNARRAY_HASHFIRSTFIELD[CaseInSensitive,djRawUTF8] - // - not to be used as such, but e.g. when inlining TDynArray methods - DYNARRAY_HASHFIRSTFIELD: array[boolean,TDynArrayKind] of TDynArrayHashOne = ( - (nil, HashByte, HashByte, HashWord, HashInteger, - HashInteger, HashInteger, HashInt64, HashInt64, HashInt64, - HashInt64, HashInt64, HashInt64, HashInt64, - HashAnsiString, HashAnsiString, - {$ifdef UNICODE}HashUnicodeString{$else}HashAnsiString{$endif}, - HashAnsiString, HashWideString, HashSynUnicode, Hash128, - Hash256, Hash512, HashPointer, - {$ifndef NOVARIANTS}HashVariant,{$endif} nil), - (nil, HashByte, HashByte, HashWord, HashInteger, - HashInteger, HashInteger, HashInt64, HashInt64, HashInt64, - HashInt64, HashInt64, HashInt64, HashInt64, - HashAnsiStringI, HashAnsiStringI, - {$ifdef UNICODE}HashUnicodeStringI{$else}HashAnsiStringI{$endif}, - HashAnsiStringI, HashWideStringI, HashSynUnicodeI, Hash128, - Hash256, Hash512, HashPointer, - {$ifndef NOVARIANTS}HashVariantI,{$endif} nil)); - - -/// initialize the structure with a one-dimension dynamic array -// - the dynamic array must have been defined with its own type -// (e.g. TIntegerDynArray = array of Integer) -// - if aCountPointer is set, it will be used instead of length() to store -// the dynamic array items count - it will be much faster when adding -// elements to the array, because the dynamic array won't need to be -// resized each time - but in this case, you should use the Count property -// instead of length(array) or high(array) when accessing the data: in fact -// length(array) will store the memory size reserved, not the items count -// - if aCountPointer is set, its content will be set to 0, whatever the -// array length is, or the current aCountPointer^ value is -// - a typical usage could be: -// !var IntArray: TIntegerDynArray; -// !begin -// ! with DynArray(TypeInfo(TIntegerDynArray),IntArray) do -// ! begin -// ! (...) -// ! end; -// ! (...) -// ! DynArray(TypeInfo(TIntegerDynArray),IntArrayA).SaveTo -function DynArray(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil): TDynArray; - {$ifdef HASINLINE}inline;{$endif} - -/// wrap a simple dynamic array BLOB content as stored by TDynArray.SaveTo -// - a "simple" dynamic array contains data with no reference count, e.g. byte, -// word, integer, cardinal, Int64, double or Currency -// - same as TDynArray.LoadFrom() with no memory allocation nor memory copy: so -// is much faster than creating a temporary dynamic array to load the data -// - will return nil if no or invalid data, or a pointer to the data -// array otherwise, with the items number stored in Count and the individual -// element size in ElemSize (e.g. 2 for a TWordDynArray) -function SimpleDynArrayLoadFrom(Source: PAnsiChar; aTypeInfo: pointer; - var Count, ElemSize: integer; NoHash32Check: boolean=false): pointer; - -/// wrap an Integer dynamic array BLOB content as stored by TDynArray.SaveTo -// - same as TDynArray.LoadFrom() with no memory allocation nor memory copy: so -// is much faster than creating a temporary dynamic array to load the data -// - will return nil if no or invalid data, or a pointer to the integer -// array otherwise, with the items number stored in Count -// - sligtly faster than SimpleDynArrayLoadFrom(Source,TypeInfo(TIntegerDynArray),Count) -function IntegerDynArrayLoadFrom(Source: PAnsiChar; var Count: integer; - NoHash32Check: boolean=false): PIntegerArray; - -/// search in a RawUTF8 dynamic array BLOB content as stored by TDynArray.SaveTo -// - same as search within TDynArray.LoadFrom() with no memory allocation nor -// memory copy: so is much faster -// - will return -1 if no match or invalid data, or the matched entry index -function RawUTF8DynArrayLoadFromContains(Source: PAnsiChar; - Value: PUTF8Char; ValueLen: PtrInt; CaseSensitive: boolean): PtrInt; - - -{ ****************** text buffer and JSON functions and classes ************ } - -const - /// maximum number of fields in a database Table - // - is included in SynCommons so that all DB-related work will be able to - // share the same low-level types and functions (e.g. TSQLFieldBits, - // TJSONWriter, TSynTableStatement, TSynTable, TSQLRecordProperties) - // - default is 64, but can be set to any value (64, 128, 192 and 256 optimized) - // changing the source below or using MAX_SQLFIELDS_128, MAX_SQLFIELDS_192 or - // MAX_SQLFIELDS_256 conditional directives for your project - // - this constant is used internaly to optimize memory usage in the - // generated asm code, and statically allocate some arrays for better speed - // - note that due to compiler restriction, 256 is the maximum value - // (this is the maximum number of items in a Delphi/FPC set) - {$ifdef MAX_SQLFIELDS_128} - MAX_SQLFIELDS = 128; - {$else} - {$ifdef MAX_SQLFIELDS_192} - MAX_SQLFIELDS = 192; - {$else} - {$ifdef MAX_SQLFIELDS_256} - MAX_SQLFIELDS = 256; - {$else} - MAX_SQLFIELDS = 64; - {$endif} - {$endif} - {$endif} - - /// sometimes, the ID field is included in a bits set - MAX_SQLFIELDS_INCLUDINGID = MAX_SQLFIELDS+1; - - /// UTF-8 encoded \uFFF0 special code to mark Base64 binary content in JSON - // - Unicode special char U+FFF0 is UTF-8 encoded as EF BF B0 bytes - // - as generated by BinToBase64WithMagic() functions, and expected by - // SQLParamContent() and ExtractInlineParameters() functions - // - used e.g. when transmitting TDynArray.SaveTo() content - JSON_BASE64_MAGIC = $b0bfef; - - /// '"' + UTF-8 encoded \uFFF0 special code to mark Base64 binary in JSON - JSON_BASE64_MAGIC_QUOTE = ord('"')+cardinal(JSON_BASE64_MAGIC) shl 8; - - /// '"' + UTF-8 encoded \uFFF0 special code to mark Base64 binary in JSON - // - defined as a cardinal variable to be used as: - // ! AddNoJSONEscape(@JSON_BASE64_MAGIC_QUOTE_VAR,4); - JSON_BASE64_MAGIC_QUOTE_VAR: cardinal = JSON_BASE64_MAGIC_QUOTE; - - /// UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON - // - e.g. '"\uFFF12012-05-04"' pattern - // - Unicode special char U+FFF1 is UTF-8 encoded as EF BF B1 bytes - // - as generated by DateToSQL/DateTimeToSQL/TimeLogToSQL functions, and - // expected by SQLParamContent() and ExtractInlineParameters() functions - JSON_SQLDATE_MAGIC = $b1bfef; - - /// '"' + UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON - JSON_SQLDATE_MAGIC_QUOTE = ord('"')+cardinal(JSON_SQLDATE_MAGIC) shl 8; - - ///'"' + UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON - // - defined as a cardinal variable to be used as: - // ! AddNoJSONEscape(@JSON_SQLDATE_MAGIC_QUOTE_VAR,4); - JSON_SQLDATE_MAGIC_QUOTE_VAR: cardinal = JSON_SQLDATE_MAGIC_QUOTE; - - -type - TTextWriter = class; - TTextWriterWithEcho = class; - - /// method prototype for custom serialization of a dynamic array item - // - each element of the dynamic array will be called as aValue parameter - // of this callback - // - can be used also at record level, if the record has a type information - // (i.e. shall contain a managed type within its fields) - // - to be used with TTextWriter.RegisterCustomJSONSerializer() method - // - note that the generated JSON content will be appended after a '[' and - // before a ']' as a normal JSON arrray, but each item can be any JSON - // structure (i.e. a number, a string, but also an object or an array) - // - implementation code could call aWriter.Add/AddJSONEscapeString... - // - implementation code shall follow the same exact format for the - // associated TDynArrayJSONCustomReader callback - TDynArrayJSONCustomWriter = procedure(const aWriter: TTextWriter; const aValue) of object; - - /// method prototype for custom unserialization of a dynamic array item - // - each element of the dynamic array will be called as aValue parameter - // of this callback - // - can be used also at record level, if the record has a type information - // (i.e. shall contain a managed type within its fields) - // - to be used with TTextWriter.RegisterCustomJSONSerializer() method - // - implementation code could call e.g. GetJSONField() low-level function, and - // returns a pointer to the last handled element of the JSON input buffer, - // as such (aka EndOfBuffer variable as expected by GetJSONField): - // ! var V: TFV absolute aValue; - // ! begin - // ! (...) - // ! V.Detailed := UTF8ToString(GetJSONField(P,P)); - // ! if P=nil then - // ! exit; - // ! aValid := true; - // ! result := P; // ',' or ']' for last item of array - // ! end; - // - implementation code shall follow the same exact format for the - // associated TDynArrayJSONCustomWriter callback - TDynArrayJSONCustomReader = function(P: PUTF8Char; var aValue; out aValid: Boolean - {$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char of object; - - /// the kind of variables handled by TJSONCustomParser - // - the last item should be ptCustom, for non simple types - TJSONCustomParserRTTIType = ( - ptArray, ptBoolean, ptByte, ptCardinal, ptCurrency, ptDouble, ptExtended, - ptInt64, ptInteger, ptQWord, ptRawByteString, ptRawJSON, ptRawUTF8, ptRecord, - ptSingle, ptString, ptSynUnicode, ptDateTime, ptDateTimeMS, ptGUID, - ptID, ptTimeLog, {$ifdef HASVARUSTRING} ptUnicodeString, {$endif} - {$ifndef NOVARIANTS} ptVariant, {$endif} ptWideString, ptWord, ptCustom); - - /// how TJSONCustomParser would serialize/unserialize JSON content - TJSONCustomParserSerializationOption = ( - soReadIgnoreUnknownFields, soWriteHumanReadable, - soCustomVariantCopiedByReference, soWriteIgnoreDefault); - - /// how TJSONCustomParser would serialize/unserialize JSON content - // - by default, during reading any unexpected field will stop and fail the - // process - if soReadIgnoreUnknownFields is defined, such properties will - // be ignored (can be very handy when parsing JSON from a remote service) - // - by default, JSON content will be written in its compact standard form, - // ready to be parsed by any client - you can specify soWriteHumanReadable - // so that some line feeds and indentation will make the content more readable - // - by default, internal TDocVariant variants will be copied by-value from - // one instance to another, to ensure proper safety - but it may be too slow: - // if you set soCustomVariantCopiedByReference, any internal - // TDocVariantData.VValue/VName instances will be copied by-reference, - // to avoid memory allocations, BUT it may break internal process if you change - // some values in place (since VValue/VName and VCount won't match) - as such, - // if you set this option, ensure that you use the content as read-only - // - by default, all fields are persistented, unless soWriteIgnoreDefault is - // defined and void values (e.g. "" or 0) won't be written - // - you may use TTextWriter.RegisterCustomJSONSerializerSetOptions() class - // method to customize the serialization for a given type - TJSONCustomParserSerializationOptions = set of TJSONCustomParserSerializationOption; - - TJSONCustomParserRTTI = class; - - /// an array of RTTI properties information - // - we use dynamic arrays, since all the information is static and we - // do not need to remove any RTTI information - TJSONCustomParserRTTIs = array of TJSONCustomParserRTTI; - - /// used to store additional RTTI in TJSONCustomParser internal structures - TJSONCustomParserRTTI = class - protected - fPropertyName: RawUTF8; - fFullPropertyName: RawUTF8; - fPropertyType: TJSONCustomParserRTTIType; - fCustomTypeName: RawUTF8; - fNestedProperty: TJSONCustomParserRTTIs; - fDataSize: integer; - fNestedDataSize: integer; - procedure ComputeDataSizeAfterAdd; virtual; - procedure ComputeNestedDataSize; - procedure ComputeFullPropertyName; - procedure FinalizeNestedRecord(var Data: PByte); - procedure FinalizeNestedArray(var Data: PtrUInt); - procedure AllocateNestedArray(var Data: PtrUInt; NewLength: integer); - procedure ReAllocateNestedArray(var Data: PtrUInt; NewLength: integer); - function IfDefaultSkipped(var Value: PByte): boolean; - procedure WriteOneSimpleValue(aWriter: TTextWriter; var Value: PByte; - Options: TJSONCustomParserSerializationOptions); - public - /// initialize the instance - constructor Create(const aPropertyName: RawUTF8; - aPropertyType: TJSONCustomParserRTTIType); - /// initialize an instance from the RTTI type information - // - will return an instance of this class of any inherited class - class function CreateFromRTTI(const PropertyName: RawUTF8; - Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; - /// create an instance from a specified type name - // - will return an instance of this class of any inherited class - class function CreateFromTypeName(const aPropertyName, - aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; - /// recognize a simple type from a supplied type name - // - will return ptCustom for any unknown type - // - see also TypeInfoToRttiType() function - class function TypeNameToSimpleRTTIType( - const TypeName: RawUTF8): TJSONCustomParserRTTIType; overload; - /// recognize a simple type from a supplied type name - // - will return ptCustom for any unknown type - // - see also TypeInfoToRttiType() function - class function TypeNameToSimpleRTTIType( - TypeName: PShortString): TJSONCustomParserRTTIType; overload; - /// recognize a simple type from a supplied type name - // - will return ptCustom for any unknown type - // - see also TypeInfoToRttiType() function - class function TypeNameToSimpleRTTIType(TypeName: PUTF8Char; TypeNameLen: PtrInt; - ItemTypeName: PRawUTF8): TJSONCustomParserRTTIType; overload; - /// recognize a simple type from a supplied type information - // - to be called if TypeNameToSimpleRTTIType() did fail, i.e. return ptCustom - // - will return ptCustom for any complex type (e.g. a record) - // - see also TypeInfoToRttiType() function - class function TypeInfoToSimpleRTTIType(Info: pointer): TJSONCustomParserRTTIType; - /// recognize a ktBinary simple type from a supplied type name - // - as registered by TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType - class function TypeNameToSimpleBinary(const aTypeName: RawUTF8; - out aDataSize, aFieldSize: integer): boolean; - /// unserialize some JSON content into its binary internal representation - // - on error, returns false and P should point to the faulty text input - function ReadOneLevel(var P: PUTF8Char; var Data: PByte; - Options: TJSONCustomParserSerializationOptions{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): boolean; virtual; - /// serialize a binary internal representation into JSON content - // - this method won't append a trailing ',' character - procedure WriteOneLevel(aWriter: TTextWriter; var P: PByte; - Options: TJSONCustomParserSerializationOptions); virtual; - /// the associated type name, e.g. for a record - property CustomTypeName: RawUTF8 read fCustomTypeName; - /// the property name - // - may be void for the Root element - // - e.g. 'SubProp' - property PropertyName: RawUTF8 read fPropertyName; - /// the property name, including all parent elements - // - may be void for the Root element - // - e.g. 'MainProp.SubProp' - property FullPropertyName: RawUTF8 read fFullPropertyName; - /// the property type - // - support only a limited set of simple types, or ptRecord for a nested - // record, or ptArray for a nested array - property PropertyType: TJSONCustomParserRTTIType read fPropertyType; - /// the nested array of properties (if any) - // - assigned only if PropertyType is [ptRecord,ptArray] - // - is either the record type of each ptArray item: - // ! SubProp: array of record ... - // - or one NestedProperty[0] entry with PropertyName='' and PropertyType - // not in [ptRecord,ptArray]: - // ! SubPropNumber: array of integer; - // ! SubPropText: array of RawUTF8; - property NestedProperty: TJSONCustomParserRTTIs read fNestedProperty; - end; - - /// used to store additional RTTI as a ptCustom kind of property - TJSONCustomParserCustom = class(TJSONCustomParserRTTI) - protected - fCustomTypeInfo: pointer; - public - /// initialize the instance - constructor Create(const aPropertyName, aCustomTypeName: RawUTF8); virtual; - /// abstract method to write the instance as JSON - procedure CustomWriter(const aWriter: TTextWriter; const aValue); virtual; abstract; - /// abstract method to read the instance from JSON - // - should return nil on parsing error - function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; virtual; abstract; - /// release any memory used by the instance - procedure FinalizeItem(Data: Pointer); virtual; - /// the associated RTTI structure - property CustomTypeInfo: pointer read fCustomTypeInfo; - end; - - /// which kind of property does TJSONCustomParserCustomSimple refer to - TJSONCustomParserCustomSimpleKnownType = ( - ktNone, ktEnumeration, ktSet, ktGUID, - ktFixedArray, ktStaticArray, ktDynamicArray, ktBinary); - - /// used to store additional RTTI for simple type as a ptCustom kind - // - this class handle currently enumerate, TGUID or static/dynamic arrays - TJSONCustomParserCustomSimple = class(TJSONCustomParserCustom) - protected - fKnownType: TJSONCustomParserCustomSimpleKnownType; - fTypeData: pointer; - fFixedSize: integer; - fNestedArray: TJSONCustomParserRTTI; - public - /// initialize the instance from the given RTTI structure - constructor Create(const aPropertyName, aCustomTypeName: RawUTF8; - aCustomType: pointer); reintroduce; - /// initialize the instance for a static array - constructor CreateFixedArray(const aPropertyName: RawUTF8; - aFixedSize: cardinal); - /// initialize the instance for a binary blob - constructor CreateBinary(const aPropertyName: RawUTF8; - aDataSize, aFixedSize: cardinal); - /// released used memory - destructor Destroy; override; - /// method to write the instance as JSON - procedure CustomWriter(const aWriter: TTextWriter; const aValue); override; - /// method to read the instance from JSON - function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; override; - /// which kind of simple property this instance does refer to - property KnownType: TJSONCustomParserCustomSimpleKnownType read fKnownType; - /// the element type for ktStaticArray and ktDynamicArray - property NestedArray: TJSONCustomParserRTTI read fNestedArray; - end; - - /// implement a reference to a registered record type - // - i.e. ptCustom kind of property, handled by the - // TTextWriter.RegisterCustomJSONSerializer*() internal list - TJSONCustomParserCustomRecord = class(TJSONCustomParserCustom) - protected - fCustomTypeIndex: integer; - function GetJSONCustomParserRegistration: pointer; - public - /// initialize the instance from the given record custom serialization index - constructor Create(const aPropertyName: RawUTF8; - aCustomTypeIndex: integer); reintroduce; overload; - /// method to write the instance as JSON - procedure CustomWriter(const aWriter: TTextWriter; const aValue); override; - /// method to read the instance from JSON - function CustomReader(P: PUTF8Char; var aValue; out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; override; - /// release any memory used by the instance - procedure FinalizeItem(Data: Pointer); override; - end; - - /// how an RTTI expression is expected to finish - TJSONCustomParserRTTIExpectedEnd = (eeNothing, eeSquare, eeCurly, eeEndKeyWord); - - TJSONRecordAbstract = class; - - /// used to handle additional RTTI for JSON record serialization - // - this class is used to define how a record is defined, and will work - // with any version of Delphi - // - this Abstract class is not to be used as-this, but contains all - // needed information to provide CustomWriter/CustomReader methods - // - you can use e.g. TJSONRecordTextDefinition for text-based RTTI - // manual definition, or (not yet provided) a version based on Delphi 2010+ - // new RTTI information - TJSONRecordAbstract = class - protected - /// internal storage of TJSONCustomParserRTTI instances - fItems: TSynObjectList; - fRoot: TJSONCustomParserRTTI; - fOptions: TJSONCustomParserSerializationOptions; - function AddItem(const aPropertyName: RawUTF8; aPropertyType: TJSONCustomParserRTTIType; - const aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; - public - /// initialize the class instance - constructor Create; - /// callback for custom JSON serialization - // - will follow the RTTI textual information as supplied to the constructor - procedure CustomWriter(const aWriter: TTextWriter; const aValue); - /// callback for custom JSON unserialization - // - will follow the RTTI textual information as supplied to the constructor - function CustomReader(P: PUTF8Char; var aValue; out aValid: Boolean{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; - /// release used memory - // - when created via Compute() call, instances of this class are managed - // via a GarbageCollector() global list, so you do not need to free them - destructor Destroy; override; - /// store the RTTI information of properties at root level - // - is one instance with PropertyType=ptRecord and PropertyName='' - property Root: TJSONCustomParserRTTI read fRoot; - /// how this class would serialize/unserialize JSON content - // - by default, no option is defined - // - you can customize the expected options with the instance returned by - // TTextWriter.RegisterCustomJSONSerializerFromText() method, or via the - // TTextWriter.RegisterCustomJSONSerializerSetOptions() overloaded methods - property Options: TJSONCustomParserSerializationOptions read fOptions write fOptions; - end; - - /// used to handle JSON record serialization using RTTI - // - is able to handle any kind of record since Delphi 2010, thanks to - // enhanced RTTI - TJSONRecordRTTI = class(TJSONRecordAbstract) - protected - fRecordTypeInfo: pointer; - function AddItemFromRTTI(const PropertyName: RawUTF8; - Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; - {$ifdef ISDELPHI2010} - procedure FromEnhancedRTTI(Props: TJSONCustomParserRTTI; Info: pointer); - {$endif} - public - /// initialize the instance - // - you should NOT use this constructor directly, but let e.g. - // TJSONCustomParsers.TryToGetFromRTTI() create it for you - constructor Create(aRecordTypeInfo: pointer; aRoot: TJSONCustomParserRTTI); reintroduce; - /// the low-level address of the enhanced RTTI - property RecordTypeInfo: pointer read fRecordTypeInfo; - end; - - /// used to handle text-defined additional RTTI for JSON record serialization - // - is used by TTextWriter.RegisterCustomJSONSerializerFromText() method - TJSONRecordTextDefinition = class(TJSONRecordAbstract) - protected - fDefinition: RawUTF8; - procedure Parse(Props: TJSONCustomParserRTTI; var P: PUTF8Char; - PEnd: TJSONCustomParserRTTIExpectedEnd); - public - /// initialize a custom JSON serializer/unserializer from pseudo RTTI - // - you should NOT use this constructor directly, but call the FromCache() - // class function, which will use an internal definition cache - constructor Create(aRecordTypeInfo: pointer; const aDefinition: RawUTF8); reintroduce; - /// retrieve a custom cached JSON serializer/unserializer from pseudo RTTI - // - returned class instance will be cached for any further use - // - the record where the data will be stored should be defined as PACKED: - // ! type TMyRecord = packed record - // ! A,B,C: integer; - // ! D: RawUTF8; - // ! E: record; // or array of record/integer/string/... - // ! E1,E2: double; - // ! end; - // ! end; - // - only known sub types are integer, cardinal, Int64, single, double, - // currency, TDateTime, TTimeLog, RawUTF8, String, WideString, SynUnicode, - // or a nested record or dynamic array - // - RTTI textual information shall be supplied as text, with the - // same format as with a pascal record, or with some shorter variations: - // ! FromCache('A,B,C: integer; D: RawUTF8; E: record E1,E2: double; end;'); - // ! FromCache('A,B,C: integer; D: RawUTF8; E: array of record E1,E2: double; end;'); - // ! 'A,B,C: integer; D: RawUTF8; E: array of SynUnicode; F: array of integer' - // or a shorter alternative syntax for records and arrays: - // ! FromCache('A,B,C: integer; D: RawUTF8; E: {E1,E2: double}'); - // ! FromCache('A,B,C: integer; D: RawUTF8; E: [E1,E2: double]'); - // in fact ; could be ignored: - // ! FromCache('A,B,C:integer D:RawUTF8 E:{E1,E2:double}'); - // ! FromCache('A,B,C:integer D:RawUTF8 E:[E1,E2:double]'); - // or even : could be ignored: - // ! FromCache('A,B,C integer D RawUTF8 E{E1,E2 double}'); - // ! FromCache('A,B,C integer D RawUTF8 E[E1,E2 double]'); - class function FromCache(aTypeInfo: pointer; - const aDefinition: RawUTF8): TJSONRecordTextDefinition; - /// the textual definition of this RTTI information - property Definition: RawUTF8 read fDefinition; - end; - - /// the available logging events, as handled by TSynLog - // - defined in SynCommons so that it may be used with TTextWriter.AddEndOfLine - // - sllInfo will log general information events - // - sllDebug will log detailed debugging information - // - sllTrace will log low-level step by step debugging information - // - sllWarning will log unexpected values (not an error) - // - sllError will log errors - // - sllEnter will log every method start - // - sllLeave will log every method exit - // - sllLastError will log the GetLastError OS message - // - sllException will log all exception raised - available since Windows XP - // - sllExceptionOS will log all OS low-level exceptions (EDivByZero, - // ERangeError, EAccessViolation...) - // - sllMemory will log memory statistics - // - sllStackTrace will log caller's stack trace (it's by default part of - // TSynLogFamily.LevelStackTrace like sllError, sllException, sllExceptionOS, - // sllLastError and sllFail) - // - sllFail was defined for TSynTestsLogged.Failed method, and can be used - // to log some customer-side assertions (may be notifications, not errors) - // - sllSQL is dedicated to trace the SQL statements - // - sllCache should be used to trace the internal caching mechanism - // - sllResult could trace the SQL results, JSON encoded - // - sllDB is dedicated to trace low-level database engine features - // - sllHTTP could be used to trace HTTP process - // - sllClient/sllServer could be used to trace some Client or Server process - // - sllServiceCall/sllServiceReturn to trace some remote service or library - // - sllUserAuth to trace user authentication (e.g. for individual requests) - // - sllCustom* items can be used for any purpose - // - sllNewRun will be written when a process opens a rotated log - // - sllDDDError will log any DDD-related low-level error information - // - sllDDDInfo will log any DDD-related low-level debugging information - // - sllMonitoring will log the statistics information (if available), - // or may be used for real-time chat among connected people to ToolsAdmin - TSynLogInfo = ( - sllNone, sllInfo, sllDebug, sllTrace, sllWarning, sllError, - sllEnter, sllLeave, - sllLastError, sllException, sllExceptionOS, sllMemory, sllStackTrace, - sllFail, sllSQL, sllCache, sllResult, sllDB, sllHTTP, sllClient, sllServer, - sllServiceCall, sllServiceReturn, sllUserAuth, - sllCustom1, sllCustom2, sllCustom3, sllCustom4, sllNewRun, - sllDDDError, sllDDDInfo, sllMonitoring); - - /// used to define a set of logging level abilities - // - i.e. a combination of none or several logging event - // - e.g. use LOG_VERBOSE constant to log all events, or LOG_STACKTRACE - // to log all errors and exceptions - TSynLogInfos = set of TSynLogInfo; - - /// a dynamic array of logging event levels - TSynLogInfoDynArray = array of TSynLogInfo; - - - /// event signature for TTextWriter.OnFlushToStream callback - TOnTextWriterFlush = procedure(Text: PUTF8Char; Len: PtrInt) of object; - - /// available options for TTextWriter.WriteObject() method - // - woHumanReadable will add some line feeds and indentation to the content, - // to make it more friendly to the human eye - // - woDontStoreDefault (which is set by default for WriteObject method) will - // avoid serializing properties including a default value (JSONToObject function - // will set the default values, so it may help saving some bandwidth or storage) - // - woFullExpand will generate a debugger-friendly layout, including instance - // class name, sets/enumerates as text, and reference pointer - as used by - // TSynLog and ObjectToJSONFull() - // - woStoreClassName will add a "ClassName":"TMyClass" field - // - woStorePointer will add a "Address":"0431298A" field, and .map/.mab - // source code line number corresponding to ESynException.RaisedAt - // - woStoreStoredFalse will write the 'stored false' properties, even - // if they are marked as such (used e.g. to persist all settings on file, - // but disallow the sensitive - password - fields be logged) - // - woHumanReadableFullSetsAsStar will store an human-readable set with - // all its enumerates items set to be stored as ["*"] - // - woHumanReadableEnumSetAsComment will add a comment at the end of the - // line, containing all available values of the enumaration or set, e.g: - // $ "Enum": "Destroying", // Idle,Started,Finished,Destroying - // - woEnumSetsAsText will store sets and enumerables as text (is also - // included in woFullExpand or woHumanReadable) - // - woDateTimeWithMagic will append the JSON_SQLDATE_MAGIC (i.e. U+FFF1) - // before the ISO-8601 encoded TDateTime value - // - woDateTimeWithZSuffix will append the Z suffix to the ISO-8601 encoded - // TDateTime value, to identify the content as strict UTC value - // - TTimeLog would be serialized as Int64, unless woTimeLogAsText is defined - // - since TSQLRecord.ID could be huge Int64 numbers, they may be truncated - // on client side, e.g. to 53-bit range in JavaScript: you could define - // woIDAsIDstr to append an additional "ID_str":"##########" field - // - by default, TSQLRawBlob properties are serialized as null, unless - // woSQLRawBlobAsBase64 is defined - // - if woHideSynPersistentPassword is set, TSynPersistentWithPassword.Password - // field will be serialized as "***" to prevent security issues (e.g. in log) - // - by default, TObjectList will set the woStoreClassName for its nested - // objects, unless woObjectListWontStoreClassName is defined - // - void strings would be serialized as "", unless woDontStoreEmptyString - // is defined so that such properties would not be written - // - all inherited properties would be serialized, unless woDontStoreInherited - // is defined, and only the topmost class level properties would be serialized - // - woInt64AsHex will force Int64/QWord to be written as hexadecimal string - - // see j2oAllowInt64Hex reverse option fot Json2Object - // - woDontStore0 will avoid serializating number properties equal to 0 - TTextWriterWriteObjectOption = ( - woHumanReadable, woDontStoreDefault, woFullExpand, - woStoreClassName, woStorePointer, woStoreStoredFalse, - woHumanReadableFullSetsAsStar, woHumanReadableEnumSetAsComment, - woEnumSetsAsText, woDateTimeWithMagic, woDateTimeWithZSuffix, woTimeLogAsText, - woIDAsIDstr, woSQLRawBlobAsBase64, woHideSynPersistentPassword, - woObjectListWontStoreClassName, woDontStoreEmptyString, - woDontStoreInherited, woInt64AsHex, woDontStore0); - /// options set for TTextWriter.WriteObject() method - TTextWriterWriteObjectOptions = set of TTextWriterWriteObjectOption; - - /// callback used to echo each line of TTextWriter class - // - should return TRUE on success, FALSE if the log was not echoed: but - // TSynLog will continue logging, even if this event returned FALSE - TOnTextWriterEcho = function(Sender: TTextWriter; Level: TSynLogInfo; - const Text: RawUTF8): boolean of object; - /// callback used by TTextWriter.WriteObject to customize class instance - // serialization - // - should return TRUE if the supplied property has been written (including - // the property name and the ending ',' character), and doesn't need to be - // processed with the default RTTI-based serializer - TOnTextWriterObjectProp = function(Sender: TTextWriter; Value: TObject; - PropInfo: pointer; Options: TTextWriterWriteObjectOptions): boolean of object; - - /// the potential places were TTextWriter.AddHtmlEscape should process - // proper HTML string escaping, unless hfNone is used - // $ < > & " -> < > & "e; - // by default (hfAnyWhere) - // $ < > & -> < > & - // outside HTML attributes (hfOutsideAttributes) - // $ & " -> & "e; - // within HTML attributes (hfWithinAttributes) - TTextWriterHTMLFormat = ( - hfNone, hfAnyWhere, hfOutsideAttributes, hfWithinAttributes); - - /// available global options for a TTextWriter instance - // - TTextWriter.WriteObject() method behavior would be set via their own - // TTextWriterWriteObjectOptions, and work in conjunction with those settings - // - twoStreamIsOwned would be set if the associated TStream is owned by - // the TTextWriter instance - // - twoFlushToStreamNoAutoResize would forbid FlushToStream to resize the - // internal memory buffer when it appears undersized - FlushFinal will set it - // before calling a last FlushToStream - // - by default, custom serializers defined via RegisterCustomJSONSerializer() - // would let AddRecordJSON() and AddDynArrayJSON() write enumerates and sets - // as integer numbers, unless twoEnumSetsAsTextInRecord or - // twoEnumSetsAsBooleanInRecord (exclusively) are set - for Mustache data - // context, twoEnumSetsAsBooleanInRecord will return a JSON object with - // "setname":true/false fields - // - variants and nested objects would be serialized with their default - // JSON serialization options, unless twoForceJSONExtended or - // twoForceJSONStandard is defined - // - when enumerates and sets are serialized as text into JSON, you may force - // the identifiers to be left-trimed for all their lowercase characters - // (e.g. sllError -> 'Error') by setting twoTrimLeftEnumSets: this option - // would default to the global TTextWriter.SetDefaultEnumTrim setting - // - twoEndOfLineCRLF would reflect the TTextWriter.EndOfLineCRLF property - // - twoBufferIsExternal would be set if the temporary buffer is not handled - // by the instance, but specified at constructor, maybe from the stack - // - twoIgnoreDefaultInRecord will force custom record serialization to avoid - // writing the fields with default values, i.e. enable soWriteIgnoreDefault - // when TJSONCustomParserRTTI.WriteOneLevel is called - // - twoDateTimeWithZ appends an ending 'Z' to TDateTime/TDateTimeMS values - TTextWriterOption = ( - twoStreamIsOwned, - twoFlushToStreamNoAutoResize, - twoEnumSetsAsTextInRecord, - twoEnumSetsAsBooleanInRecord, - twoFullSetsAsStar, - twoTrimLeftEnumSets, - twoForceJSONExtended, - twoForceJSONStandard, - twoEndOfLineCRLF, - twoBufferIsExternal, - twoIgnoreDefaultInRecord, - twoDateTimeWithZ); - /// options set for a TTextWriter instance - // - allows to override e.g. AddRecordJSON() and AddDynArrayJSON() behavior; - // or set global process customization for a TTextWriter - TTextWriterOptions = set of TTextWriterOption; - - /// may be used to allocate on stack a 8KB work buffer for a TTextWriter - // - via the TTextWriter.CreateOwnedStream overloaded constructor - TTextWriterStackBuffer = array[0..8191] of AnsiChar; - PTextWriterStackBuffer = ^TTextWriterStackBuffer; - - /// simple writer to a Stream, specialized for the TEXT format - // - use an internal buffer, faster than string+string - // - some dedicated methods is able to encode any data with JSON/XML escape - // - see TTextWriterWithEcho below for optional output redirection (for TSynLog) - // - see SynTable.pas for SQL resultset export via TJSONWriter - // - see mORMot.pas for proper class serialization via TJSONSerializer.WriteObject - TTextWriter = class - protected - B, BEnd: PUTF8Char; - fStream: TStream; - fInitialStreamPosition: PtrUInt; - fTotalFileSize: PtrUInt; - fCustomOptions: TTextWriterOptions; - // internal temporary buffer - fTempBufSize: Integer; - fTempBuf: PUTF8Char; - fOnFlushToStream: TOnTextWriterFlush; - fOnWriteObject: TOnTextWriterObjectProp; - /// used by WriteObjectAsString/AddDynArrayJSONAsString methods - fInternalJSONWriter: TTextWriter; - fHumanReadableLevel: integer; - procedure WriteToStream(data: pointer; len: PtrUInt); virtual; - function GetTextLength: PtrUInt; - procedure SetStream(aStream: TStream); - procedure SetBuffer(aBuf: pointer; aBufSize: integer); - procedure InternalAddFixedAnsi(Source: PAnsiChar; SourceChars: Cardinal; - AnsiToWide: PWordArray; Escape: TTextWriterKind); - public - /// the data will be written to the specified Stream - // - aStream may be nil: in this case, it MUST be set before using any - // Add*() method - // - default internal buffer size if 8192 - constructor Create(aStream: TStream; aBufSize: integer=8192); overload; - /// the data will be written to the specified Stream - // - aStream may be nil: in this case, it MUST be set before using any - // Add*() method - // - will use an external buffer (which may be allocated on stack) - constructor Create(aStream: TStream; aBuf: pointer; aBufSize: integer); overload; - /// the data will be written to an internal TRawByteStringStream - // - TRawByteStringStream.DataString method will be used by TTextWriter.Text - // to retrieve directly the content without any data move nor allocation - // - default internal buffer size if 4096 (enough for most JSON objects) - // - consider using a stack-allocated buffer and the overloaded method - constructor CreateOwnedStream(aBufSize: integer=4096); overload; - /// the data will be written to an internal TRawByteStringStream - // - will use an external buffer (which may be allocated on stack) - // - TRawByteStringStream.DataString method will be used by TTextWriter.Text - // to retrieve directly the content without any data move nor allocation - constructor CreateOwnedStream(aBuf: pointer; aBufSize: integer); overload; - /// the data will be written to an internal TRawByteStringStream - // - will use the stack-allocated TTextWriterStackBuffer if possible - // - TRawByteStringStream.DataString method will be used by TTextWriter.Text - // to retrieve directly the content without any data move nor allocation - constructor CreateOwnedStream(var aStackBuf: TTextWriterStackBuffer; - aBufSize: integer=SizeOf(TTextWriterStackBuffer)); overload; - /// the data will be written to an external file - // - you should call explicitly FlushFinal or FlushToStream to write - // any pending data to the file - constructor CreateOwnedFileStream(const aFileName: TFileName; aBufSize: integer=8192); - /// release all internal structures - // - e.g. free fStream if the instance was owned by this class - destructor Destroy; override; - /// allow to override the default JSON serialization of enumerations and - // sets as text, which would write the whole identifier (e.g. 'sllError') - // - calling SetDefaultEnumTrim(true) would force the enumerations to - // be trimmed for any lower case char, e.g. sllError -> 'Error' - // - this is global to the current process, and should be use mainly for - // compatibility purposes for the whole process - // - you may change the default behavior by setting twoTrimLeftEnumSets - // in the TTextWriter.CustomOptions property of a given serializer - // - note that unserialization process would recognize both formats - class procedure SetDefaultEnumTrim(aShouldTrimEnumsAsText: boolean); - - /// retrieve the data as a string - function Text: RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - /// retrieve the data as a string - // - will avoid creation of a temporary RawUTF8 variable as for Text function - procedure SetText(var result: RawUTF8; reformat: TTextWriterJSONFormat=jsonCompact); - /// set the internal stream content with the supplied UTF-8 text - procedure ForceContent(const text: RawUTF8); - /// write pending data to the Stream, with automatic buffer resizal - // - you should not have to call FlushToStream in most cases, but FlushFinal - // at the end of the process, just before using the resulting Stream - // - FlushToStream may be used to force immediate writing of the internal - // memory buffer to the destination Stream - // - you can set FlushToStreamNoAutoResize=true or call FlushFinal if you - // do not want the automatic memory buffer resizal to take place - procedure FlushToStream; virtual; - /// write pending data to the Stream, without automatic buffer resizal - // - will append the internal memory buffer to the Stream - // - in short, FlushToStream may be called during the adding process, and - // FlushFinal at the end of the process, just before using the resulting Stream - // - if you don't call FlushToStream or FlushFinal, some pending characters - // may not be copied to the Stream: you should call it before using the Stream - procedure FlushFinal; - /// gives access to an internal temporary TTextWriter - // - may be used to escape some JSON espaced value (i.e. escape it twice), - // in conjunction with AddJSONEscape(Source: TTextWriter) - function InternalJSONWriter: TTextWriter; - - /// append one ASCII char to the buffer - procedure Add(c: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif} - /// append one ASCII char to the buffer, if not already there as LastChar - procedure AddOnce(c: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif} - /// append two chars to the buffer - procedure Add(c1,c2: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif} - {$ifndef CPU64} // already implemented by Add(Value: PtrInt) method - /// append a 64-bit signed Integer Value as text - procedure Add(Value: Int64); overload; - {$endif} - /// append a 32-bit signed Integer Value as text - procedure Add(Value: PtrInt); overload; - /// append a boolean Value as text - // - write either 'true' or 'false' - procedure Add(Value: boolean); overload; {$ifdef HASINLINE}inline;{$endif} - /// append a Currency from its Int64 in-memory representation - procedure AddCurr64(const Value: Int64); overload; - /// append a Currency from its Int64 in-memory representation - procedure AddCurr64(const Value: currency); overload; {$ifdef HASINLINE}inline;{$endif} - /// append a TTimeLog value, expanded as Iso-8601 encoded text - procedure AddTimeLog(Value: PInt64); - /// append a TUnixTime value, expanded as Iso-8601 encoded text - procedure AddUnixTime(Value: PInt64); - /// append a TUnixMSTime value, expanded as Iso-8601 encoded text - procedure AddUnixMSTime(Value: PInt64; WithMS: boolean=false); - /// append a TDateTime value, expanded as Iso-8601 encoded text - // - use 'YYYY-MM-DDThh:mm:ss' format (with FirstChar='T') - // - if twoDateTimeWithZ CustomOption is set, will append an ending 'Z' - // - if WithMS is TRUE, will append '.sss' for milliseconds resolution - // - if QuoteChar is not #0, it will be written before and after the date - procedure AddDateTime(Value: PDateTime; FirstChar: AnsiChar='T'; QuoteChar: AnsiChar=#0; - WithMS: boolean=false); overload; - /// append a TDateTime value, expanded as Iso-8601 encoded text - // - use 'YYYY-MM-DDThh:mm:ss' format - // - if twoDateTimeWithZ CustomOption is set, will append an ending 'Z' - // - append nothing if Value=0 - // - if WithMS is TRUE, will append '.sss' for milliseconds resolution - procedure AddDateTime(const Value: TDateTime; WithMS: boolean=false); overload; - /// append a TDateTime value, expanded as Iso-8601 text with milliseconds - // and Time Zone designator - // - twoDateTimeWithZ CustomOption is ignored in favor of the TZD parameter - // - i.e. 'YYYY-MM-DDThh:mm:ss.sssZ' format - // - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') - procedure AddDateTimeMS(const Value: TDateTime; Expanded: boolean=true; - FirstTimeChar: AnsiChar = 'T'; const TZD: RawUTF8='Z'); - /// append an Unsigned 32-bit Integer Value as a String - procedure AddU(Value: cardinal); - /// append an Unsigned 64-bit Integer Value as a String - procedure AddQ(Value: QWord); - /// append an Unsigned 64-bit Integer Value as a quoted hexadecimal String - procedure AddQHex(Value: Qword); {$ifdef HASINLINE}inline;{$endif} - /// append a GUID value, encoded as text without any {} - // - will store e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' - procedure Add({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID); overload; - /// append a floating-point Value as a String - // - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values - // - noexp=true will call ExtendedToShortNoExp() to avoid any scientific - // notation in the resulting text - procedure AddDouble(Value: double; noexp: boolean=false); {$ifdef HASINLINE}inline;{$endif} - /// append a floating-point Value as a String - // - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values - // - noexp=true will call ExtendedToShortNoExp() to avoid any scientific - // notation in the resulting text - procedure AddSingle(Value: single; noexp: boolean=false); {$ifdef HASINLINE}inline;{$endif} - /// append a floating-point Value as a String - // - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values - // - noexp=true will call ExtendedToShortNoExp() to avoid any scientific - // notation in the resulting text - procedure Add(Value: Extended; precision: integer; noexp: boolean=false); overload; - /// append a floating-point text buffer - // - will correct on the fly '.5' -> '0.5' and '-.5' -> '-0.5' - // - will end not only on #0 but on any char not matching 1[.2[e[-]3]] pattern - // - is used when the input comes from a third-party source with no regular - // output, e.g. a database driver - procedure AddFloatStr(P: PUTF8Char); - /// append strings or integers with a specified format - // - % = #37 marks a string, integer, floating-point, or class parameter - // to be appended as text (e.g. class name) - // - if StringEscape is false (by default), the text won't be escaped before - // adding; but if set to true text will be JSON escaped at writing - // - note that due to a limitation of the "array of const" format, cardinal - // values should be type-casted to Int64() - otherwise the integer mapped - // value will be transmitted, therefore wrongly - {$ifdef OLDTEXTWRITERFORMAT} - // - $ dollar = #36 indicates an integer to be written with 2 digits and a comma - // - | vertical = #124 will write the next char e.g. Add('%|$',[10]) will write '10$' - // - pound = #163 indicates an integer to be written with 4 digits and a comma - // - micro = #181 indicates an integer to be written with 3 digits without any comma - // - currency = #164 indicates CR+LF chars - // - section = #167 indicates to trim last comma - // - since some of this characters above are > #127, they are not UTF-8 - // ready, so we expect the input format to be WinAnsi, i.e. mostly English - // text (with chars < #128) with some values to be inserted inside - {$endif} - procedure Add(const Format: RawUTF8; const Values: array of const; - Escape: TTextWriterKind=twNone; WriteObjectOptions: TTextWriterWriteObjectOptions=[woFullExpand]); overload; - /// append some values at once - // - text values (e.g. RawUTF8) will be escaped as JSON - procedure Add(const Values: array of const); overload; - /// append CR+LF (#13#10) chars - // - this method won't call EchoAdd() registered events - use AddEndOfLine() - // method instead - // - AddEndOfLine() will append either CR+LF (#13#10) or LF (#10) depending - // on a flag - procedure AddCR; - /// append CR+LF (#13#10) chars and #9 indentation - // - indentation depth is defined by fHumanReadableLevel protected field - procedure AddCRAndIndent; - /// write the same character multiple times - procedure AddChars(aChar: AnsiChar; aCount: integer); - /// append an Integer Value as a 2 digits String with comma - procedure Add2(Value: PtrUInt); - /// append the current UTC date and time, in our log-friendly format - // - e.g. append '20110325 19241502' - with no trailing space nor tab - // - you may set LocalTime=TRUE to write the local date and time instead - // - this method is very fast, and avoid most calculation or API calls - procedure AddCurrentLogTime(LocalTime: boolean); - /// append the current UTC date and time, in our log-friendly format - // - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space - // - you may set LocalTime=TRUE to write the local date and time instead - // - this method is very fast, and avoid most calculation or API calls - procedure AddCurrentNCSALogTime(LocalTime: boolean); - /// append a time period, specified in micro seconds, in 00.000.000 TSynLog format - procedure AddMicroSec(MS: cardinal); - /// append an Integer Value as a 4 digits String with comma - procedure Add4(Value: PtrUInt); - /// append an Integer Value as a 3 digits String without any added comma - procedure Add3(Value: PtrUInt); - /// append a line of text with CR+LF at the end - procedure AddLine(const Text: shortstring); - /// append an UTF-8 String, with no JSON escaping - procedure AddString(const Text: RawUTF8); - /// append several UTF-8 strings - procedure AddStrings(const Text: array of RawUTF8); overload; - /// append an UTF-8 string several times - procedure AddStrings(const Text: RawUTF8; count: integer); overload; - /// append a ShortString - procedure AddShort(const Text: ShortString); - /// append a sub-part of an UTF-8 String - // - emulates AddString(copy(Text,start,len)) - procedure AddStringCopy(const Text: RawUTF8; start,len: PtrInt); - /// append after trim first lowercase chars ('otDone' will add 'Done' e.g.) - procedure AddTrimLeftLowerCase(Text: PShortString); - /// append a UTF-8 String excluding any space or control char - // - this won't escape the text as expected by JSON - procedure AddTrimSpaces(const Text: RawUTF8); overload; - {$ifdef HASINLINE}inline;{$endif} - /// append a UTF-8 String excluding any space or control char - // - this won't escape the text as expected by JSON - procedure AddTrimSpaces(P: PUTF8Char); overload; - /// append a property name, as '"PropName":' - // - PropName content should not need to be JSON escaped (e.g. no " within, - // and only ASCII 7-bit characters) - // - if twoForceJSONExtended is defined in CustomOptions, it would append - // 'PropName:' without the double quotes - procedure AddProp(PropName: PUTF8Char; PropNameLen: PtrInt); - /// append a ShortString property name, as '"PropName":' - // - PropName content should not need to be JSON escaped (e.g. no " within, - // and only ASCII 7-bit characters) - // - if twoForceJSONExtended is defined in CustomOptions, it would append - // 'PropName:' without the double quotes - // - is a wrapper around AddProp() - procedure AddPropName(const PropName: ShortString); - {$ifdef HASINLINE}inline;{$endif} - /// append a JSON field name, followed by an escaped UTF-8 JSON String and - // a comma (',') - procedure AddPropJSONString(const PropName: shortstring; const Text: RawUTF8); - /// append a JSON field name, followed by a number value and a comma (',') - procedure AddPropJSONInt64(const PropName: shortstring; Value: Int64); - /// append a RawUTF8 property name, as '"FieldName":' - // - FieldName content should not need to be JSON escaped (e.g. no " within) - // - if twoForceJSONExtended is defined in CustomOptions, it would append - // 'PropName:' without the double quotes - // - is a wrapper around AddProp() - procedure AddFieldName(const FieldName: RawUTF8); - {$ifdef HASINLINE}inline;{$endif} - /// append the class name of an Object instance as text - // - aClass must be not nil - procedure AddClassName(aClass: TClass); - /// append an Instance name and pointer, as '"TObjectList(00425E68)"'+SepChar - // - Instance must be not nil - procedure AddInstanceName(Instance: TObject; SepChar: AnsiChar); - /// append an Instance name and pointer, as 'TObjectList(00425E68)'+SepChar - // - Instance must be not nil - // - overriden version in TJSONSerializer would implement IncludeUnitName - procedure AddInstancePointer(Instance: TObject; SepChar: AnsiChar; - IncludeUnitName, IncludePointer: boolean); virtual; - /// append a quoted string as JSON, with in-place decoding - // - if QuotedString does not start with ' or ", it will written directly - // (i.e. expects to be a number, or null/true/false constants) - // - as used e.g. by TJSONObjectDecoder.EncodeAsJSON method and - // JSONEncodeNameSQLValue() function - procedure AddQuotedStringAsJSON(const QuotedString: RawUTF8); - /// append an array of integers as CSV - procedure AddCSVInteger(const Integers: array of Integer); overload; - /// append an array of doubles as CSV - procedure AddCSVDouble(const Doubles: array of double); overload; - /// append an array of RawUTF8 as CSV of JSON strings - procedure AddCSVUTF8(const Values: array of RawUTF8); overload; - /// append an array of const as CSV of JSON values - procedure AddCSVConst(const Values: array of const); - /// write some data Base64 encoded - // - if withMagic is TRUE, will write as '"\uFFF0base64encodedbinary"' - procedure WrBase64(P: PAnsiChar; Len: PtrUInt; withMagic: boolean); - /// write some record content as binary, Base64 encoded with our magic prefix - procedure WrRecord(const Rec; TypeInfo: pointer); - /// write some #0 ended UTF-8 text, according to the specified format - // - if Escape is a constant, consider calling directly AddNoJSONEscape, - // AddJSONEscape or AddOnSameLine methods - procedure Add(P: PUTF8Char; Escape: TTextWriterKind); overload; - /// write some #0 ended UTF-8 text, according to the specified format - // - if Escape is a constant, consider calling directly AddNoJSONEscape, - // AddJSONEscape or AddOnSameLine methods - procedure Add(P: PUTF8Char; Len: PtrInt; Escape: TTextWriterKind); overload; - /// write some #0 ended Unicode text as UTF-8, according to the specified format - // - if Escape is a constant, consider calling directly AddNoJSONEscapeW, - // AddJSONEscapeW or AddOnSameLineW methods - procedure AddW(P: PWord; Len: PtrInt; Escape: TTextWriterKind); - /// append some UTF-8 encoded chars to the buffer, from the main AnsiString type - // - use the current system code page for AnsiString parameter - procedure AddAnsiString(const s: AnsiString; Escape: TTextWriterKind); overload; - /// append some UTF-8 encoded chars to the buffer, from any AnsiString value - // - if CodePage is left to its default value of -1, it will assume - // CurrentAnsiConvert.CodePage prior to Delphi 2009, but newer UNICODE - // versions of Delphi will retrieve the code page from string - // - if CodePage is defined to a >= 0 value, the encoding will take place - procedure AddAnyAnsiString(const s: RawByteString; Escape: TTextWriterKind; - CodePage: Integer=-1); - /// append some UTF-8 encoded chars to the buffer, from any Ansi buffer - // - the codepage should be specified, e.g. CP_UTF8, CP_RAWBYTESTRING, - // CODEPAGE_US, or any version supported by the Operating System - // - if codepage is 0, the current CurrentAnsiConvert.CodePage would be used - // - will use TSynAnsiConvert to perform the conversion to UTF-8 - procedure AddAnyAnsiBuffer(P: PAnsiChar; Len: PtrInt; - Escape: TTextWriterKind; CodePage: Integer); - /// append some UTF-8 chars to the buffer - // - input length is calculated from zero-ended char - // - don't escapes chars according to the JSON RFC - procedure AddNoJSONEscape(P: Pointer); overload; - /// append some UTF-8 chars to the buffer - // - don't escapes chars according to the JSON RFC - procedure AddNoJSONEscape(P: Pointer; Len: PtrInt); overload; - /// append some UTF-8 chars to the buffer - // - don't escapes chars according to the JSON RFC - procedure AddNoJSONEscapeUTF8(const text: RawByteString); - {$ifdef HASINLINE}inline;{$endif} - /// flush a supplied TTextWriter, and write pending data as JSON escaped text - // - may be used with InternalJSONWriter, as a faster alternative to - // ! AddNoJSONEscapeUTF8(Source.Text); - procedure AddNoJSONEscape(Source: TTextWriter); overload; - /// append some UTF-8 chars to the buffer - // - if supplied json is '', will write 'null' - procedure AddRawJSON(const json: RawJSON); - /// append some UTF-8 text, quoting all " chars - // - same algorithm than AddString(QuotedStr()) - without memory allocation, - // and with an optional maximum text length (truncated with ending '...') - // - this function implements what is specified in the official SQLite3 - // documentation: "A string constant is formed by enclosing the string in single - // quotes ('). A single quote within the string can be encoded by putting two - // single quotes in a row - as in Pascal." - procedure AddQuotedStr(Text: PUTF8Char; Quote: AnsiChar; TextMaxLen: PtrInt=0); - /// append some chars, escaping all HTML special chars as expected - procedure AddHtmlEscape(Text: PUTF8Char; Fmt: TTextWriterHTMLFormat=hfAnyWhere); overload; - /// append some chars, escaping all HTML special chars as expected - procedure AddHtmlEscape(Text: PUTF8Char; TextLen: PtrInt; - Fmt: TTextWriterHTMLFormat=hfAnyWhere); overload; - /// append some chars, escaping all HTML special chars as expected - procedure AddHtmlEscapeString(const Text: string; - Fmt: TTextWriterHTMLFormat=hfAnyWhere); - /// append some chars, escaping all HTML special chars as expected - procedure AddHtmlEscapeUTF8(const Text: RawUTF8; - Fmt: TTextWriterHTMLFormat=hfAnyWhere); - /// append some chars, escaping all XML special chars as expected - // - i.e. < > & " ' as < > & "e; ' - // - and all control chars (i.e. #1..#31) as &#..; - // - see @http://www.w3.org/TR/xml/#syntax - procedure AddXmlEscape(Text: PUTF8Char); - /// append some chars, replacing a given character with another - procedure AddReplace(Text: PUTF8Char; Orig,Replaced: AnsiChar); - /// append some binary data as hexadecimal text conversion - procedure AddBinToHex(Bin: Pointer; BinBytes: integer); - /// fast conversion from binary data into hexa chars, ready to be displayed - // - using this function with Bin^ as an integer value will serialize it - // in big-endian order (most-significant byte first), as used by humans - // - up to the internal buffer bytes may be converted - procedure AddBinToHexDisplay(Bin: pointer; BinBytes: integer); - /// fast conversion from binary data into MSB hexa chars - // - up to the internal buffer bytes may be converted - procedure AddBinToHexDisplayLower(Bin: pointer; BinBytes: integer); - /// fast conversion from binary data into quoted MSB lowercase hexa chars - // - up to the internal buffer bytes may be converted - procedure AddBinToHexDisplayQuoted(Bin: pointer; BinBytes: integer); - /// append a Value as significant hexadecimal text - // - append its minimal size, i.e. excluding highest bytes containing 0 - // - use GetNextItemHexa() to decode such a text value - procedure AddBinToHexDisplayMinChars(Bin: pointer; BinBytes: PtrInt); - /// add the pointer into significant hexa chars, ready to be displayed - procedure AddPointer(P: PtrUInt); {$ifdef HASINLINE}inline;{$endif} - /// write a byte as hexa chars - procedure AddByteToHex(Value: byte); - /// write a Int18 value (0..262143) as 3 chars - // - this encoding is faster than Base64, and has spaces on the left side - // - use function Chars3ToInt18() to decode the textual content - procedure AddInt18ToChars3(Value: cardinal); - /// append some unicode chars to the buffer - // - WideCharCount is the unicode chars count, not the byte size - // - don't escapes chars according to the JSON RFC - // - will convert the Unicode chars into UTF-8 - procedure AddNoJSONEscapeW(WideChar: PWord; WideCharCount: integer); - /// append some UTF-8 encoded chars to the buffer - // - escapes chars according to the JSON RFC - // - if Len is 0, writing will stop at #0 (default Len=0 is slightly faster - // than specifying Len>0 if you are sure P is zero-ended - e.g. from RawUTF8) - procedure AddJSONEscape(P: Pointer; Len: PtrInt=0); overload; - /// append some UTF-8 encoded chars to the buffer, from a generic string type - // - faster than AddJSONEscape(pointer(StringToUTF8(string)) - // - escapes chars according to the JSON RFC - procedure AddJSONEscapeString(const s: string); {$ifdef HASINLINE}inline;{$endif} - /// append some UTF-8 encoded chars to the buffer, from the main AnsiString type - // - escapes chars according to the JSON RFC - procedure AddJSONEscapeAnsiString(const s: AnsiString); - /// append some UTF-8 encoded chars to the buffer, from a generic string type - // - faster than AddNoJSONEscape(pointer(StringToUTF8(string)) - // - don't escapes chars according to the JSON RFC - // - will convert the Unicode chars into UTF-8 - procedure AddNoJSONEscapeString(const s: string); {$ifdef UNICODE}inline;{$endif} - /// append some Unicode encoded chars to the buffer - // - if Len is 0, Len is calculated from zero-ended widechar - // - escapes chars according to the JSON RFC - procedure AddJSONEscapeW(P: PWord; Len: PtrInt=0); - /// append an open array constant value to the buffer - // - "" will be added if necessary - // - escapes chars according to the JSON RFC - // - very fast (avoid most temporary storage) - procedure AddJSONEscape(const V: TVarRec); overload; - /// flush a supplied TTextWriter, and write pending data as JSON escaped text - // - may be used with InternalJSONWriter, as a faster alternative to - // ! AddJSONEscape(Pointer(fInternalJSONWriter.Text),0); - procedure AddJSONEscape(Source: TTextWriter); overload; - /// append a UTF-8 JSON String, between double quotes and with JSON escaping - procedure AddJSONString(const Text: RawUTF8); - /// append an open array constant value to the buffer - // - "" won't be added for string values - // - string values may be escaped, depending on the supplied parameter - // - very fast (avoid most temporary storage) - procedure Add(const V: TVarRec; Escape: TTextWriterKind=twNone; - WriteObjectOptions: TTextWriterWriteObjectOptions=[woFullExpand]); overload; - /// encode the supplied data as an UTF-8 valid JSON object content - // - data must be supplied two by two, as Name,Value pairs, e.g. - // ! aWriter.AddJSONEscape(['name','John','year',1972]); - // will append to the buffer: - // ! '{"name":"John","year":1972}' - // - or you can specify nested arrays or objects with '['..']' or '{'..'}': - // ! aWriter.AddJSONEscape(['doc','{','name','John','ab','[','a','b']','}','id',123]); - // will append to the buffer: - // ! '{"doc":{"name":"John","abc":["a","b"]},"id":123}' - // - note that, due to a Delphi compiler limitation, cardinal values should be - // type-casted to Int64() (otherwise the integer mapped value will be converted) - // - you can pass nil as parameter for a null JSON value - procedure AddJSONEscape(const NameValuePairs: array of const); overload; - {$ifndef NOVARIANTS} - /// encode the supplied (extended) JSON content, with parameters, - // as an UTF-8 valid JSON object content - // - in addition to the JSON RFC specification strict mode, this method will - // handle some BSON-like extensions, e.g. unquoted field names: - // ! aWriter.AddJSON('{id:?,%:{name:?,birthyear:?}}',['doc'],[10,'John',1982]); - // - you can use nested _Obj() / _Arr() instances - // ! aWriter.AddJSON('{%:{$in:[?,?]}}',['type'],['food','snack']); - // ! aWriter.AddJSON('{type:{$in:?}}',[],[_Arr(['food','snack'])]); - // ! // which are the same as: - // ! aWriter.AddShort('{"type":{"$in":["food","snack"]}}'); - // - if the SynMongoDB unit is used in the application, the MongoDB Shell - // syntax will also be recognized to create TBSONVariant, like - // ! new Date() ObjectId() MinKey MaxKey // - // see @http://docs.mongodb.org/manual/reference/mongodb-extended-json - // ! aWriter.AddJSON('{name:?,field:/%/i}',['acme.*corp'],['John'])) - // ! // will write - // ! '{"name":"John","field":{"$regex":"acme.*corp","$options":"i"}}' - // - will call internally _JSONFastFmt() to create a temporary TDocVariant - // with all its features - so is slightly slower than other AddJSON* methods - procedure AddJSON(const Format: RawUTF8; const Args,Params: array of const); - {$endif} - /// append two JSON arrays of keys and values as one JSON object - // - i.e. makes the following transformation: - // $ [key1,key2...] + [value1,value2...] -> {key1:value1,key2,value2...} - // - this method won't allocate any memory during its process, nor - // modify the keys and values input buffers - // - is the reverse of the JSONObjectAsJSONArrays() function - procedure AddJSONArraysAsJSONObject(keys,values: PUTF8Char); - /// append a dynamic array content as UTF-8 encoded JSON array - // - expect a dynamic array TDynArray wrapper as incoming parameter - // - TIntegerDynArray, TInt64DynArray, TCardinalDynArray, TDoubleDynArray, - // TCurrencyDynArray, TWordDynArray and TByteDynArray will be written as - // numerical JSON values - // - TRawUTF8DynArray, TWinAnsiDynArray, TRawByteStringDynArray, - // TStringDynArray, TWideStringDynArray, TSynUnicodeDynArray, TTimeLogDynArray, - // and TDateTimeDynArray will be written as escaped UTF-8 JSON strings - // (and Iso-8601 textual encoding if necessary) - // - you can add some custom serializers via RegisterCustomJSONSerializer() - // class method, to serialize any dynamic array as valid JSON - // - any other non-standard or non-registered kind of dynamic array (including - // array of records) will be written as Base64 encoded binary stream, with a - // JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) - this will - // include TBytes (i.e. array of bytes) content, which is a good candidate - // for BLOB stream - // - typical content could be - // ! '[1,2,3,4]' or '["\uFFF0base64encodedbinary"]' - // - by default, custom serializers defined via RegisterCustomJSONSerializer() - // would write enumerates and sets as integer numbers, unless - // twoEnumSetsAsTextInRecord is set in the instance Options - procedure AddDynArrayJSON(var aDynArray: TDynArray); overload; - /// append a dynamic array content as UTF-8 encoded JSON array - // - expect a dynamic array TDynArrayHashed wrapper as incoming parameter - procedure AddDynArrayJSON(var aDynArray: TDynArrayHashed); overload; - {$ifdef HASINLINE}inline;{$endif} - /// append a dynamic array content as UTF-8 encoded JSON array - // - just a wrapper around the other overloaded method, creating a - // temporary TDynArray wrapper on the stack - // - to be used e.g. for custom record JSON serialization, within a - // TDynArrayJSONCustomWriter callback - procedure AddDynArrayJSON(aTypeInfo: pointer; const aValue); overload; - /// same as AddDynArrayJSON(), but will double all internal " and bound with " - // - this implementation will avoid most memory allocations - procedure AddDynArrayJSONAsString(aTypeInfo: pointer; var aValue); - /// append a T*ObjArray dynamic array as a JSON array - // - as expected by TJSONSerializer.RegisterObjArrayForJSON() - procedure AddObjArrayJSON(const aObjArray; - aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]); - /// append a record content as UTF-8 encoded JSON or custom serialization - // - default serialization will use Base64 encoded binary stream, or - // a custom serialization, in case of a previous registration via - // RegisterCustomJSONSerializer() class method - from a dynamic array - // handling this kind of records, or directly from TypeInfo() of the record - // - by default, custom serializers defined via RegisterCustomJSONSerializer() - // would write enumerates and sets as integer numbers, unless - // twoEnumSetsAsTextInRecord or twoEnumSetsAsBooleanInRecord is set in - // the instance CustomOptions - procedure AddRecordJSON(const Rec; TypeInfo: pointer); - {$ifndef NOVARIANTS} - /// append a variant content as number or string - // - default Escape=twJSONEscape will create valid JSON content, which - // can be converted back to a variant value using VariantLoadJSON() - // - default JSON serialization options would apply, unless - // twoForceJSONExtended or twoForceJSONStandard is defined - // - note that before Delphi 2009, any varString value is expected to be - // a RawUTF8 instance - which does make sense in the mORMot context - procedure AddVariant(const Value: variant; Escape: TTextWriterKind=twJSONEscape); - {$endif} - /// append a void record content as UTF-8 encoded JSON or custom serialization - // - this method will first create a void record (i.e. filled with #0 bytes) - // then save its content with default or custom serialization - procedure AddVoidRecordJSON(TypeInfo: pointer); - /// append a JSON value from its RTTI type - // - handle tkClass,tkEnumeration,tkSet,tkRecord,tkDynArray,tkVariant types - // - write null for other types - procedure AddTypedJSON(aTypeInfo: pointer; const aValue); - /// serialize as JSON the given object - // - this default implementation will write null, or only write the - // class name and pointer if FullExpand is true - use - // TJSONSerializer.WriteObject method for full RTTI handling - // - default implementation will write TList/TCollection/TStrings/TRawUTF8List - // as appropriate array of class name/pointer (if woFullExpand is set) - procedure WriteObject(Value: TObject; - Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]); virtual; - /// same as WriteObject(), but will double all internal " and bound with " - // - this implementation will avoid most memory allocations - procedure WriteObjectAsString(Value: TObject; - Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]); - /// append a JSON value, array or document as simple XML content - // - you can use JSONBufferToXML() and JSONToXML() functions as wrappers - // - this method is called recursively to handle all kind of JSON values - // - WARNING: the JSON buffer is decoded in-place, so will be changed - // - returns the end of the current JSON converted level, or nil if the - // supplied content was not correct JSON - function AddJSONToXML(JSON: PUTF8Char; ArrayName: PUTF8Char=nil; - EndOfObject: PUTF8Char=nil): PUTF8Char; - /// append a JSON value, array or document, in a specified format - // - will parse the JSON buffer and write its content with proper line - // feeds and indentation, according to the supplied TTextWriterJSONFormat - // - see also JSONReformat() and JSONBufferReformat() wrappers - // - this method is called recursively to handle all kind of JSON values - // - WARNING: the JSON buffer is decoded in-place, so will be changed - // - returns the end of the current JSON converted level, or nil if the - // supplied content was not valid JSON - function AddJSONReformat(JSON: PUTF8Char; Format: TTextWriterJSONFormat; - EndOfObject: PUTF8Char): PUTF8Char; - - /// define a custom serialization for a given dynamic array or record - // - expects TypeInfo() from a dynamic array or a record (will raise an - // exception otherwise) - // - for a dynamic array, the associated item record RTTI will be registered - // - for a record, any matching dynamic array will also be registered - // - by default, TIntegerDynArray and such known classes are processed as - // true JSON arrays: but you can specify here some callbacks to perform - // the serialization process for any kind of dynamic array - // - any previous registration is overridden - // - setting both aReader=aWriter=nil will return back to the default - // binary + Base64 encoding serialization (i.e. undefine custom serializer) - class procedure RegisterCustomJSONSerializer(aTypeInfo: pointer; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); - {$ifndef NOVARIANTS} - /// define a custom serialization for a given variant custom type - // - used e.g. to serialize TBCD values - class procedure RegisterCustomJSONSerializerForVariant(aClass: TCustomVariantType; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); - /// define a custom serialization for a given variant custom type - // - used e.g. to serialize TBCD values - class procedure RegisterCustomJSONSerializerForVariantByType(aVarType: TVarType; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); - {$endif NOVARIANTS} - /// define a custom serialization for a given dynamic array or record - // - the RTTI information will here be defined as plain text - // - since Delphi 2010, you can call directly - // RegisterCustomJSONSerializerFromTextSimpleType() - // - aTypeInfo may be valid TypeInfo(), or any fixed pointer value if the - // record does not have any RTTI (e.g. a record without any nested reference- - // counted types) - // - the record where the data will be stored should be defined as PACKED: - // ! type TMyRecord = packed record - // ! A,B,C: integer; - // ! D: RawUTF8; - // ! E: record; // or array of record/integer/string/... - // ! E1,E2: double; - // ! end; - // ! end; - // - call this method with aRTTIDefinition='' to return back to the default - // binary + Base64 encoding serialization (i.e. undefine custom serializer) - // - only known sub types are byte, word, integer, cardinal, Int64, single, - // double, currency, TDateTime, TTimeLog, RawUTF8, String, WideString, - // SynUnicode, TGUID (encoded via GUIDToText) or a nested record or dynamic - // array of the same simple types or record - // - RTTI textual information shall be supplied as text, with the - // same format as with a pascal record: - // ! 'A,B,C: integer; D: RawUTF8; E: record E1,E2: double;' - // ! 'A,B,C: integer; D: RawUTF8; E: array of record E1,E2: double;' - // ! 'A,B,C: integer; D: RawUTF8; E: array of SynUnicode; F: array of TGUID' - // or a shorter alternative syntax for records and arrays: - // ! 'A,B,C: integer; D: RawUTF8; E: {E1,E2: double}' - // ! 'A,B,C: integer; D: RawUTF8; E: [E1,E2: double]' - // in fact ; could be ignored: - // ! 'A,B,C:integer D:RawUTF8 E:{E1,E2:double}' - // ! 'A,B,C:integer D:RawUTF8 E:[E1,E2:double]' - // or even : could be ignored: - // ! 'A,B,C integer D RawUTF8 E{E1,E2 double}' - // ! 'A,B,C integer D RawUTF8 E[E1,E2 double]' - // - it will return the cached TJSONRecordTextDefinition - // instance corresponding to the supplied RTTI text definition - class function RegisterCustomJSONSerializerFromText(aTypeInfo: pointer; - const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; overload; - /// define a custom serialization for several dynamic arrays or records - // - the TypeInfo() and textual RTTI information will here be defined as - // ([TypeInfo(TType1),_TType1,TypeInfo(TType2),_TType2]) pairs - // - a wrapper around the overloaded RegisterCustomJSONSerializerFromText() - class procedure RegisterCustomJSONSerializerFromText( - const aTypeInfoTextDefinitionPairs: array of const); overload; - /// change options for custom serialization of dynamic array or record - // - will return TRUE if the options have been changed, FALSE if the - // supplied type info was not previously registered - // - if AddIfNotExisting is TRUE, and enhanced RTTI is available (since - // Delphi 2010), you would be able to customize the options of this type - class function RegisterCustomJSONSerializerSetOptions(aTypeInfo: pointer; - aOptions: TJSONCustomParserSerializationOptions; - aAddIfNotExisting: boolean=false): boolean; overload; - /// change options for custom serialization of dynamic arrays or records - // - will return TRUE if the options have been changed, FALSE if the - // supplied type info was not previously registered for at least one type - // - if AddIfNotExisting is TRUE, and enhanced RTTI is available (since - // Delphi 2010), you would be able to customize the options of this type - class function RegisterCustomJSONSerializerSetOptions( - const aTypeInfo: array of pointer; aOptions: TJSONCustomParserSerializationOptions; - aAddIfNotExisting: boolean=false): boolean; overload; - /// retrieve a previously registered custom parser instance from its type - // - will return nil if the type info was not available, or defined just - // with some callbacks - // - if AddIfNotExisting is TRUE, and enhanced RTTI is available (since - // Delphi 2010), you would be able to retrieve this type's parser even - // if the record type has not been previously used - class function RegisterCustomJSONSerializerFindParser( - aTypeInfo: pointer; aAddIfNotExisting: boolean=false): TJSONRecordAbstract; - /// define a custom serialization for a given simple type - // - you should be able to use this type in the RTTI text definition - // of any further RegisterCustomJSONSerializerFromText() call - // - the RTTI information should be enough to serialize the type from - // its name (e.g. an enumeration for older Delphi revision, but all records - // since Delphi 2010) - // - you can supply a custom type name, which will be registered in addition - // to the "official" name defined at RTTI level - // - on older Delphi versions (up to Delphi 2009), it will handle only - // enumerations, which will be transmitted as JSON string instead of numbers - // - since Delphi 2010, any record type can be supplied - which is more - // convenient than calling RegisterCustomJSONSerializerFromText() - class procedure RegisterCustomJSONSerializerFromTextSimpleType(aTypeInfo: pointer; - const aTypeName: RawUTF8=''); overload; - /// define a custom binary serialization for a given simple type - // - you should be able to use this type in the RTTI text definition - // of any further RegisterCustomJSONSerializerFromText() call - // - data will be serialized as BinToHexDisplayLower() JSON hexadecimal string - // - you can truncate the original data size (e.g. if all bits of an integer - // are not used) by specifying the aFieldSize optional parameter - class procedure RegisterCustomJSONSerializerFromTextBinaryType(aTypeInfo: pointer; - aDataSize: integer; aFieldSize: integer=0); overload; - /// define custom binary serialization for several simple types - // - data will be serialized as BinToHexDisplayLower() JSON hexadecimal string - // - the TypeInfo() and associated size information will here be defined as triplets: - // ([TypeInfo(TType1),SizeOf(TType1),TYPE1_BYTES,TypeInfo(TType2),SizeOf(TType2),TYPE2_BYTES]) - // - a wrapper around the overloaded RegisterCustomJSONSerializerFromTextBinaryType() - class procedure RegisterCustomJSONSerializerFromTextBinaryType( - const aTypeInfoDataFieldSize: array of const); overload; - /// define a custom serialization for several simple types - // - will call the overloaded RegisterCustomJSONSerializerFromTextSimpleType - // method for each supplied type information - class procedure RegisterCustomJSONSerializerFromTextSimpleType( - const aTypeInfos: array of pointer); overload; - /// undefine a custom serialization for a given dynamic array or record - // - it will un-register any callback or text-based custom serialization - // i.e. any previous RegisterCustomJSONSerializer() or - // RegisterCustomJSONSerializerFromText() call - // - expects TypeInfo() from a dynamic array or a record (will raise an - // exception otherwise) - // - it will set back to the default binary + Base64 encoding serialization - class procedure UnRegisterCustomJSONSerializer(aTypeInfo: pointer); - /// retrieve low-level custom serialization callbaks for a dynamic array - // - returns TRUE if this array has a custom JSON parser, and set the - // corresponding serialization/unserialization callbacks - class function GetCustomJSONParser(var DynArray: TDynArray; - out CustomReader: TDynArrayJSONCustomReader; - out CustomWriter: TDynArrayJSONCustomWriter): boolean; - - /// append some chars to the buffer in one line - // - P should be ended with a #0 - // - will write #1..#31 chars as spaces (so content will stay on the same line) - procedure AddOnSameLine(P: PUTF8Char); overload; - /// append some chars to the buffer in one line - // - will write #0..#31 chars as spaces (so content will stay on the same line) - procedure AddOnSameLine(P: PUTF8Char; Len: PtrInt); overload; - /// append some wide chars to the buffer in one line - // - will write #0..#31 chars as spaces (so content will stay on the same line) - procedure AddOnSameLineW(P: PWord; Len: PtrInt); - - /// return the last char appended - // - returns #0 if no char has been written yet - function LastChar: AnsiChar; - /// how many bytes are currently in the internal buffer and not on disk - // - see TextLength for the total number of bytes, on both disk and memory - function PendingBytes: PtrUInt; - {$ifdef HASINLINE}inline;{$endif} - /// how many bytes were currently written on disk - // - excluding the bytes in the internal buffer - // - see TextLength for the total number of bytes, on both disk and memory - property WrittenBytes: PtrUInt read fTotalFileSize; - /// low-level access to the current indentation level - property HumanReadableLevel: integer read fHumanReadableLevel write fHumanReadableLevel; - /// the last char appended is canceled - // - only one char cancelation is allowed at the same position: don't call - // CancelLastChar/CancelLastComma more than once without appending text inbetween - procedure CancelLastChar; overload; {$ifdef HASINLINE}inline;{$endif} - /// the last char appended is canceled, if match the supplied one - // - only one char cancelation is allowed at the same position: don't call - // CancelLastChar/CancelLastComma more than once without appending text inbetween - procedure CancelLastChar(aCharToCancel: AnsiChar); overload; {$ifdef HASINLINE}inline;{$endif} - /// the last char appended is canceled if it was a ',' - // - only one char cancelation is allowed at the same position: don't call - // CancelLastChar/CancelLastComma more than once without appending text inbetween - procedure CancelLastComma; {$ifdef HASINLINE}inline;{$endif} - /// rewind the Stream to the position when Create() was called - // - note that this does not clear the Stream content itself, just - // move back its writing position to its initial place - procedure CancelAll; - - /// count of added bytes to the stream - // - see PendingBytes for the number of bytes currently in the memory buffer - // or WrittenBytes for the number of bytes already written to disk - property TextLength: PtrUInt read GetTextLength; - /// optional event called before FlushToStream method process - property OnFlushToStream: TOnTextWriterFlush read fOnFlushToStream write fOnFlushToStream; - /// allows to override default WriteObject property JSON serialization - property OnWriteObject: TOnTextWriterObjectProp read fOnWriteObject write fOnWriteObject; - /// the internal TStream used for storage - // - you should call the FlushFinal (or FlushToStream) methods before using - // this TStream content, to flush all pending characters - // - if the TStream instance has not been specified when calling the - // TTextWriter constructor, it can be forced via this property, before - // any writting - property Stream: TStream read fStream write SetStream; - /// global options to customize this TTextWriter instance process - // - allows to override e.g. AddRecordJSON() and AddDynArrayJSON() behavior - property CustomOptions: TTextWriterOptions read fCustomOptions write fCustomOptions; - end; - - /// class of our simple TEXT format writer to a Stream, with echoing - // - as used by TSynLog for writing its content - // - see TTextWriterWithEcho.SetAsDefaultJSONClass - TTextWriterClass = class of TTextWriterWithEcho; - - /// Stream TEXT writer, with optional echoing of the lines - // - as used e.g. by TSynLog writer for log optional redirection - // - is defined as a sub-class to reduce plain TTextWriter scope - // - see SynTable.pas for SQL resultset export via TJSONWriter - // - see mORMot.pas for proper class serialization via TJSONSerializer.WriteObject - TTextWriterWithEcho = class(TTextWriter) - protected - fEchoStart: PtrInt; - fEchoBuf: RawUTF8; - fEchos: array of TOnTextWriterEcho; - function EchoFlush: PtrInt; - function GetEndOfLineCRLF: boolean; {$ifdef HASINLINE}inline;{$endif} - procedure SetEndOfLineCRLF(aEndOfLineCRLF: boolean); - public - /// write pending data to the Stream, with automatic buffer resizal and echoing - // - this overriden method will handle proper echoing - procedure FlushToStream; override; - /// mark an end of line, ready to be "echoed" to registered listeners - // - append a LF (#10) char or CR+LF (#13#10) chars to the buffer, depending - // on the EndOfLineCRLF property value (default is LF, to minimize storage) - // - any callback registered via EchoAdd() will monitor this line - // - used e.g. by TSynLog for console output, as stated by Level parameter - procedure AddEndOfLine(aLevel: TSynLogInfo=sllNone); - /// add a callback to echo each line written by this class - // - this class expects AddEndOfLine to mark the end of each line - procedure EchoAdd(const aEcho: TOnTextWriterEcho); - /// remove a callback to echo each line written by this class - // - event should have been previously registered by a EchoAdd() call - procedure EchoRemove(const aEcho: TOnTextWriterEcho); - /// reset the internal buffer used for echoing content - procedure EchoReset; - /// define how AddEndOfLine method stores its line feed characters - // - by default (FALSE), it will append a LF (#10) char to the buffer - // - you can set this property to TRUE, so that CR+LF (#13#10) chars will - // be appended instead - // - is just a wrapper around twoEndOfLineCRLF item in CustomOptions - property EndOfLineCRLF: boolean read GetEndOfLineCRLF write SetEndOfLineCRLF; - end; - -var - /// contains the default JSON serialization class for WriteObject - // - if only SynCommons.pas is used, it will be TTextWriterWithEcho - // - mORMot.pas will assign TJSONSerializer which uses RTTI to serialize - // TSQLRecord and any class published properties as JSON - DefaultTextWriterSerializer: TTextWriterClass = TTextWriterWithEcho; - -/// recognize a simple type from a supplied type information -// - first try by name via TJSONCustomParserRTTI.TypeNameToSimpleRTTIType, -// then from RTTI via TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType -// - will return ptCustom for any unknown type -function TypeInfoToRttiType(aTypeInfo: pointer): TJSONCustomParserRTTIType; - -/// serialize most kind of content as JSON, using its RTTI -// - is just a wrapper around TTextWriter.AddTypedJSON() -// - so would handle tkClass, tkEnumeration, tkSet, tkRecord, tkDynArray, -// tkVariant kind of content - other kinds would return 'null' -// - you can override serialization options if needed -procedure SaveJSON(const Value; TypeInfo: pointer; - Options: TTextWriterOptions; var result: RawUTF8); overload; - -/// serialize most kind of content as JSON, using its RTTI -// - is just a wrapper around TTextWriter.AddTypedJSON() -// - so would handle tkClass, tkEnumeration, tkSet, tkRecord, tkDynArray, -// tkVariant kind of content - other kinds would return 'null' -function SaveJSON(const Value; TypeInfo: pointer; - EnumSetsAsText: boolean=false): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// will serialize any TObject into its UTF-8 JSON representation -/// - serialize as JSON the published integer, Int64, floating point values, -// TDateTime (stored as ISO 8601 text), string, variant and enumerate -// (e.g. boolean) properties of the object (and its parents) -// - would set twoForceJSONStandard to force standard (non-extended) JSON -// - the enumerates properties are stored with their integer index value -// - will write also the properties published in the parent classes -// - nested properties are serialized as nested JSON objects -// - any TCollection property will also be serialized as JSON arrays -// - you can add some custom serializers for ANY Delphi class, via mORMot.pas' -// TJSONSerializer.RegisterCustomSerializer() class method -// - call internaly TJSONSerializer.WriteObject() method (or fallback to -// TJSONWriter if mORMot.pas is not linked to the executable) -function ObjectToJSON(Value: TObject; - Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8; - -/// will serialize set of TObject into its UTF-8 JSON representation -// - follows ObjectToJSON()/TTextWriter.WriterObject() functions output -// - if Names is not supplied, the corresponding class names would be used -function ObjectsToJSON(const Names: array of RawUTF8; const Values: array of TObject; - Options: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8; - - -type - /// abstract ancestor to manage a dynamic array of TObject - // - do not use this abstract class directly, but rather the inherited - // TObjectListHashed and TObjectListPropertyHashed - TObjectListHashedAbstract = class - protected - fList: TObjectDynArray; - fCount: integer; - fHash: TDynArrayHashed; - public - /// initialize the class instance - // - if aFreeItems is TRUE (default), will behave like a TObjectList - // - if aFreeItems is FALSE, will behave like a TList - constructor Create(aFreeItems: boolean=true); reintroduce; - /// release used memory - destructor Destroy; override; - /// search and add an object reference to the list - // - returns the found/added index - function Add(aObject: TObject; out wasAdded: boolean): integer; virtual; abstract; - /// retrieve an object index within the list, using a fast hash table - // - returns -1 if not found - function IndexOf(aObject: TObject): integer; virtual; abstract; - /// delete an object from the list - // - the internal hash table is not recreated, just invalidated - // (i.e. this method calls HashInvalidate not FindHashedAndDelete) - // - will invalide the whole hash table - procedure Delete(aIndex: integer); overload; - /// delete an object from the list - // - will invalide the whole hash table - procedure Delete(aObject: TObject); overload; virtual; - /// direct access to the items list array - property List: TObjectDynArray read fList; - /// returns the count of stored objects - property Count: integer read fCount; - /// direct access to the underlying hashing engine - property Hash: TDynArrayHashed read fHash; - end; - - /// this class behaves like TList/TObjectList, but will use hashing - // for (much) faster IndexOf() method - TObjectListHashed = class(TObjectListHashedAbstract) - public - /// search and add an object reference to the list - // - returns the found/added index - // - if added, hash is stored and Items[] := aObject - function Add(aObject: TObject; out wasAdded: boolean): integer; override; - /// retrieve an object index within the list, using a fast hash table - // - returns -1 if not found - function IndexOf(aObject: TObject): integer; override; - /// delete an object from the list - // - overriden method won't invalidate the whole hash table, but refresh it - procedure Delete(aObject: TObject); override; - end; - - /// function prototype used to retrieve a pointer to the hashed property - // value of a TObjectListPropertyHashed list - TObjectListPropertyHashedAccessProp = function(aObject: TObject): pointer; - - /// this class will hash and search for a sub property of the stored objects - TObjectListPropertyHashed = class(TObjectListHashedAbstract) - protected - fSubPropAccess: TObjectListPropertyHashedAccessProp; - function IntHash(const Elem): cardinal; - function IntComp(const A,B): integer; - public - /// initialize the class instance with the corresponding callback in order - // to handle sub-property hashing and search - // - see TSetWeakZeroClass in mORMot.pas unit as example: - // ! function WeakZeroClassSubProp(aObject: TObject): TObject; - // ! begin - // ! result := TSetWeakZeroInstance(aObject).fInstance; - // ! end; - // - by default, aHashElement/aCompare will hash/search for pointers: - // you can specify the hash/search methods according to your sub property - // (e.g. HashAnsiStringI/SortDynArrayAnsiStringI for a RawUTF8) - // - if aFreeItems is TRUE (default), will behave like a TObjectList; - // if aFreeItems is FALSE, will behave like a TList - constructor Create(aSubPropAccess: TObjectListPropertyHashedAccessProp; - aHashElement: TDynArrayHashOne=nil; aCompare: TDynArraySortCompare=nil; - aFreeItems: boolean=true); reintroduce; - /// search and add an object reference to the list - // - returns the found/added index - // - if added, only the hash is stored: caller has to set List[i] - function Add(aObject: TObject; out wasAdded: boolean): integer; override; - /// retrieve an object index within the list, using a fast hash table - // - returns -1 if not found - function IndexOf(aObject: TObject): integer; override; - end; - - /// abstract class stored by a TPointerClassHash list - TPointerClassHashed = class - protected - fInfo: pointer; - public - /// initialize the instance - constructor Create(aInfo: pointer); - /// the associated information of this instance - // - may be e.g. a PTypeInfo value, when caching RTTI information - property Info: pointer read fInfo write fInfo; - end; - /// a reference to a TPointerClassHashed instance - PPointerClassHashed = ^TPointerClassHashed; - - /// handle a O(1) hashed-based storage of TPointerClassHashed, from a pointer - // - used e.g. to store RTTI information from its PTypeInfo value - // - if not thread safe, but could be used to store RTTI, since all type - // information should have been initialized before actual process - TPointerClassHash = class(TObjectListPropertyHashed) - public - /// initialize the storage list - constructor Create; - /// try to add an entry to the storage - // - returns nil if the supplied information is already in the list - // - returns a pointer to where a newly created TPointerClassHashed - // instance should be stored - // - this method is not thread-safe - function TryAdd(aInfo: pointer): PPointerClassHashed; - /// search for a stored instance, from its supplied pointer reference - // - returns nil if aInfo was not previously added by FindOrAdd() - // - this method is not thread-safe - function Find(aInfo: pointer): TPointerClassHashed; - end; - - /// handle a O(1) hashed-based storage of TPointerClassHashed, from a pointer - // - this inherited class add a mutex to be thread-safe - TPointerClassHashLocked = class(TPointerClassHash) - protected - fSafe: TSynLocker; - public - /// initialize the storage list - constructor Create; - /// finalize the storage list - destructor Destroy; override; - /// try to add an entry to the storage - // - returns false if the supplied information is already in the list - // - returns true, and a pointer to where a newly created TPointerClassHashed - // instance should be stored: in this case, you should call UnLock once set - // - could be used as such: - // !var entry: PPointerClassHashed; - // !... - // ! if HashList.TryAddLocked(aTypeInfo,entry) then - // ! try - // ! entry^ := TMyCustomPointerClassHashed.Create(aTypeInfo,...); - // ! finally - // ! HashList.Unlock; - // ! end; - // !... - function TryAddLocked(aInfo: pointer; out aNewEntry: PPointerClassHashed): boolean; - /// release the lock after a previous TryAddLocked()=true call - procedure Unlock; - /// search for a stored instance, from its supplied pointer reference - // - returns nil if aInfo was not previously added by FindOrAdd() - // - this overriden method is thread-safe, unless returned TPointerClassHashed - // instance is deleted in-between - function FindLocked(aInfo: pointer): TPointerClassHashed; - end; - - /// add locking methods to a TSynObjectList - // - this class overrides the regular TSynObjectList, and do not share any - // code with the TObjectListHashedAbstract/TObjectListHashed classes - // - you need to call the Safe.Lock/Unlock methods by hand to protect the - // execution of index-oriented methods (like Delete/Items/Count...): the - // list content may change in the background, so using indexes is thread-safe - // - on the other hand, Add/Clear/ClearFromLast/Remove stateless methods have - // been overriden in this class to call Safe.Lock/Unlock, and therefore are - // thread-safe and protected to any background change - TSynObjectListLocked = class(TSynObjectList) - protected - fSafe: TSynLocker; - public - /// initialize the list instance - // - the stored TObject instances will be owned by this TSynObjectListLocked, - // unless AOwnsObjects is set to false - constructor Create(aOwnsObjects: boolean=true); reintroduce; - /// release the list instance (including the locking resource) - destructor Destroy; override; - /// add one item to the list using the global critical section - function Add(item: pointer): integer; override; - /// delete all items of the list using the global critical section - procedure Clear; override; - /// delete all items of the list in reverse order, using the global critical section - procedure ClearFromLast; override; - /// fast delete one item in the list - function Remove(item: pointer): integer; override; - /// check an item using the global critical section - function Exists(item: pointer): boolean; override; - /// the critical section associated to this list instance - // - could be used to protect shared resources within the internal process, - // for index-oriented methods like Delete/Items/Count... - // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block - property Safe: TSynLocker read fSafe; - end; - - /// deprecated class name, for backward compatibility only - TObjectListLocked = TSynObjectListLocked; - - /// possible values used by TRawUTF8List.Flags - TRawUTF8ListFlags = set of ( - fObjectsOwned, fCaseSensitive, fNoDuplicate, fOnChangeTrigerred); - - /// TStringList-class optimized to work with our native UTF-8 string type - // - can optionally store associated some TObject instances - // - high-level methods of this class are thread-safe - // - if fNoDuplicate flag is defined, an internal hash table will be - // maintained to perform IndexOf() lookups in O(1) linear way - TRawUTF8List = class - protected - fCount: PtrInt; - fValue: TRawUTF8DynArray; - fValues: TDynArrayHashed; - fObjects: TObjectDynArray; - fFlags: TRawUTF8ListFlags; - fNameValueSep: AnsiChar; - fOnChange, fOnChangeBackupForBeginUpdate: TNotifyEvent; - fOnChangeLevel: integer; - fSafe: TSynLocker; - function GetCount: PtrInt; {$ifdef HASINLINE}inline;{$endif} - procedure SetCapacity(const capa: PtrInt); - function GetCapacity: PtrInt; - function Get(Index: PtrInt): RawUTF8; {$ifdef HASINLINE}inline;{$endif} - procedure Put(Index: PtrInt; const Value: RawUTF8); - function GetObject(Index: PtrInt): pointer; {$ifdef HASINLINE}inline;{$endif} - procedure PutObject(Index: PtrInt; Value: pointer); - function GetName(Index: PtrInt): RawUTF8; - function GetValue(const Name: RawUTF8): RawUTF8; - procedure SetValue(const Name, Value: RawUTF8); - function GetTextCRLF: RawUTF8; - procedure SetTextCRLF(const Value: RawUTF8); - procedure SetTextPtr(P,PEnd: PUTF8Char; const Delimiter: RawUTF8); - function GetTextPtr: PPUtf8CharArray; {$ifdef HASINLINE}inline;{$endif} - function GetNoDuplicate: boolean; {$ifdef HASINLINE}inline;{$endif} - function GetObjectPtr: PPointerArray; {$ifdef HASINLINE}inline;{$endif} - function GetCaseSensitive: boolean; {$ifdef HASINLINE}inline;{$endif} - procedure SetCaseSensitive(Value: boolean); virtual; - procedure Changed; virtual; - procedure InternalDelete(Index: PtrInt); - procedure OnChangeHidden(Sender: TObject); - public - /// initialize the RawUTF8/Objects storage - // - by default, any associated Objects[] are just weak references; - // you may supply fOwnObjects flag to force object instance management - // - if you want the stored text items to be unique, set fNoDuplicate - // and then an internal hash table will be maintained for fast IndexOf() - // - you can unset fCaseSensitive to let the UTF-8 lookup be case-insensitive - constructor Create(aFlags: TRawUTF8ListFlags=[fCaseSensitive]); overload; - /// backward compatiliby overloaded constructor - // - please rather use the overloaded Create(TRawUTF8ListFlags) - constructor Create(aOwnObjects: boolean; aNoDuplicate: boolean=false; - aCaseSensitive: boolean=true); overload; - /// finalize the internal objects stored - // - if instance was created with fOwnObjects flag - destructor Destroy; override; - /// get a stored Object item by its associated UTF-8 text - // - returns nil and raise no exception if aText doesn't exist - // - thread-safe method, unless returned TObject is deleted in the background - function GetObjectFrom(const aText: RawUTF8): pointer; - /// store a new RawUTF8 item - // - without the fNoDuplicate flag, it will always add the supplied value - // - if fNoDuplicate was set and aText already exists (using the internal - // hash table), it will return -1 unless aRaiseExceptionIfExisting is forced - // - thread-safe method - function Add(const aText: RawUTF8; aRaiseExceptionIfExisting: boolean=false): PtrInt; {$ifdef HASINLINE}inline;{$endif} - /// store a new RawUTF8 item, and its associated TObject - // - without the fNoDuplicate flag, it will always add the supplied value - // - if fNoDuplicate was set and aText already exists (using the internal hash - // table), it will return -1 unless aRaiseExceptionIfExisting is forced; - // optionally freeing the supplied aObject if aFreeAndReturnExistingObject - // is true, in which pointer the existing Objects[] is copied (see - // AddObjectUnique as a convenient wrapper around this behavior) - // - thread-safe method - function AddObject(const aText: RawUTF8; aObject: TObject; - aRaiseExceptionIfExisting: boolean=false; aFreeAndReturnExistingObject: PPointer=nil): PtrInt; - /// try to store a new RawUTF8 item and its associated TObject - // - fNoDuplicate should have been specified in the list flags - // - if aText doesn't exist, will add the values - // - if aText exist, will call aObjectToAddOrFree.Free and set the value - // already stored in Objects[] into aObjectToAddOrFree - allowing dual - // commit thread-safe update of the list, e.g. after a previous unsuccessful - // call to GetObjectFrom(aText) - // - thread-safe method, using an internal Hash Table to speedup IndexOf() - // - in fact, this method is just a wrapper around - // ! AddObject(aText,aObjectToAddOrFree^,false,@aObjectToAddOrFree); - procedure AddObjectUnique(const aText: RawUTF8; aObjectToAddOrFree: PPointer); - {$ifdef HASINLINE}inline;{$endif} - /// append a specified list to the current content - // - thread-safe method - procedure AddRawUTF8List(List: TRawUTF8List); - /// delete a stored RawUTF8 item, and its associated TObject - // - raise no exception in case of out of range supplied index - // - this method is not thread-safe: use Safe.Lock/UnLock if needed - procedure Delete(Index: PtrInt); overload; - /// delete a stored RawUTF8 item, and its associated TObject - // - will search for the value using IndexOf(aText), and returns its index - // - returns -1 if no entry was found and deleted - // - thread-safe method, using the internal Hash Table if fNoDuplicate is set - function Delete(const aText: RawUTF8): PtrInt; overload; - /// delete a stored RawUTF8 item, and its associated TObject, from - // a given Name when stored as 'Name=Value' pairs - // - raise no exception in case of out of range supplied index - // - thread-safe method, but not using the internal Hash Table - // - consider using TSynNameValue if you expect efficient name/value process - function DeleteFromName(const Name: RawUTF8): PtrInt; virtual; - /// find the index of a given Name when stored as 'Name=Value' pairs - // - search on Name is case-insensitive with 'Name=Value' pairs - // - this method is not thread-safe, and won't use the internal Hash Table - // - consider using TSynNameValue if you expect efficient name/value process - function IndexOfName(const Name: RawUTF8): PtrInt; - /// access to the Value of a given 'Name=Value' pair at a given position - // - this method is not thread-safe - // - consider using TSynNameValue if you expect efficient name/value process - function GetValueAt(Index: PtrInt): RawUTF8; - /// retrieve Value from an existing Name=Value, then optinally delete the entry - // - if Name is found, will fill Value with the stored content and return true - // - if Name is not found, Value is not modified, and false is returned - // - thread-safe method, but not using the internal Hash Table - // - consider using TSynNameValue if you expect efficient name/value process - function UpdateValue(const Name: RawUTF8; var Value: RawUTF8; ThenDelete: boolean): boolean; - /// retrieve and delete the first RawUTF8 item in the list - // - could be used as a FIFO, calling Add() as a "push" method - // - thread-safe method - function PopFirst(out aText: RawUTF8; aObject: PObject=nil): boolean; - /// retrieve and delete the last RawUTF8 item in the list - // - could be used as a FILO, calling Add() as a "push" method - // - thread-safe method - function PopLast(out aText: RawUTF8; aObject: PObject=nil): boolean; - /// erase all stored RawUTF8 items - // - and corresponding objects (if aOwnObjects was true at constructor) - // - thread-safe method, also clearing the internal Hash Table - procedure Clear; virtual; - /// find a RawUTF8 item in the stored Strings[] list - // - this search is case sensitive if fCaseSensitive flag was set (which - // is the default) - // - this method is not thread-safe since the internal list may change - // and the returned index may not be accurate any more - // - see also GetObjectFrom() - // - uses the internal Hash Table if fNoDuplicate was set - function IndexOf(const aText: RawUTF8): PtrInt; - /// find a TObject item index in the stored Objects[] list - // - this method is not thread-safe since the internal list may change - // and the returned index may not be accurate any more - // - aObject lookup won't use the internal Hash Table - function IndexOfObject(aObject: TObject): PtrInt; - /// search for any RawUTF8 item containing some text - // - uses PosEx() on the stored lines - // - this method is not thread-safe since the internal list may change - // and the returned index may not be accurate any more - // - by design, aText lookup can't use the internal Hash Table - function Contains(const aText: RawUTF8; aFirstIndex: integer=0): PtrInt; - /// retrieve the all lines, separated by the supplied delimiter - // - this method is thread-safe - function GetText(const Delimiter: RawUTF8=#13#10): RawUTF8; - /// the OnChange event will be raised only when EndUpdate will be called - // - this method will also call Safe.Lock for thread-safety - procedure BeginUpdate; - /// call the OnChange event if changes occured - // - this method will also call Safe.UnLock for thread-safety - procedure EndUpdate; - /// set low-level text and objects from existing arrays - procedure SetFrom(const aText: TRawUTF8DynArray; const aObject: TObjectDynArray); - /// set all lines, separated by the supplied delimiter - // - this method is thread-safe - procedure SetText(const aText: RawUTF8; const Delimiter: RawUTF8=#13#10); - /// set all lines from an UTF-8 text file - // - expect the file is explicitly an UTF-8 file - // - will ignore any trailing UTF-8 BOM in the file content, but will not - // expect one either - // - this method is thread-safe - procedure LoadFromFile(const FileName: TFileName); - /// write all lines into the supplied stream - // - this method is thread-safe - procedure SaveToStream(Dest: TStream; const Delimiter: RawUTF8=#13#10); - /// write all lines into a new file - // - this method is thread-safe - procedure SaveToFile(const FileName: TFileName; const Delimiter: RawUTF8=#13#10); - /// return the count of stored RawUTF8 - // - reading this property is not thread-safe, since size may change - property Count: PtrInt read GetCount; - /// set or retrieve the current memory capacity of the RawUTF8 list - // - reading this property is not thread-safe, since size may change - property Capacity: PtrInt read GetCapacity write SetCapacity; - /// set if IndexOf() shall be case sensitive or not - // - default is TRUE - // - matches fCaseSensitive in Flags - property CaseSensitive: boolean read GetCaseSensitive write SetCaseSensitive; - /// set if the list doesn't allow duplicated UTF-8 text - // - if true, an internal hash table is maintained for faster IndexOf() - // - matches fNoDuplicate in Flags - property NoDuplicate: boolean read GetNoDuplicate; - /// access to the low-level flags of this list - property Flags: TRawUTF8ListFlags read fFlags write fFlags; - /// get or set a RawUTF8 item - // - returns '' and raise no exception in case of out of range supplied index - // - if you want to use it with the VCL, use UTF8ToString() function - // - reading this property is not thread-safe, since content may change - property Strings[Index: PtrInt]: RawUTF8 read Get write Put; default; - /// get or set a Object item - // - returns nil and raise no exception in case of out of range supplied index - // - reading this property is not thread-safe, since content may change - property Objects[Index: PtrInt]: pointer read GetObject write PutObject; - /// retrieve the corresponding Name when stored as 'Name=Value' pairs - // - reading this property is not thread-safe, since content may change - // - consider TSynNameValue if you expect more efficient name/value process - property Names[Index: PtrInt]: RawUTF8 read GetName; - /// access to the corresponding 'Name=Value' pairs - // - search on Name is case-insensitive with 'Name=Value' pairs - // - reading this property is thread-safe, but won't use the hash table - // - consider TSynNameValue if you expect more efficient name/value process - property Values[const Name: RawUTF8]: RawUTF8 read GetValue write SetValue; - /// the char separator between 'Name=Value' pairs - // - equals '=' by default - // - consider TSynNameValue if you expect more efficient name/value process - property NameValueSep: AnsiChar read fNameValueSep write fNameValueSep; - /// set or retrieve all items as text lines - // - lines are separated by #13#10 (CRLF) by default; use GetText and - // SetText methods if you want to use another line delimiter (even a comma) - // - this property is thread-safe - property Text: RawUTF8 read GetTextCRLF write SetTextCRLF; - /// Event triggered when an entry is modified - property OnChange: TNotifyEvent read fOnChange write fOnChange; - /// direct access to the memory of the TRawUTF8DynArray items - // - reading this property is not thread-safe, since content may change - property TextPtr: PPUtf8CharArray read GetTextPtr; - /// direct access to the memory of the TObjectDynArray items - // - reading this property is not thread-safe, since content may change - property ObjectPtr: PPointerArray read GetObjectPtr; - /// direct access to the TRawUTF8DynArray items dynamic array wrapper - // - using this property is not thread-safe, since content may change - property ValuesArray: TDynArrayHashed read fValues; - /// access to the locking methods of this instance - // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block - property Safe: TSynLocker read fSafe; - end; - - // some declarations used for backward compatibility only - TRawUTF8ListLocked = type TRawUTF8List; - TRawUTF8ListHashed = type TRawUTF8List; - TRawUTF8ListHashedLocked = type TRawUTF8ListHashed; - // deprecated TRawUTF8MethodList should be replaced by a TSynDictionary - - /// define the implemetation used by TAlgoCompress.Decompress() - TAlgoCompressLoad = (aclNormal, aclSafeSlow, aclNoCrcFast); - - /// abstract low-level parent class for generic compression/decompression algorithms - // - will encapsulate the compression algorithm with crc32c hashing - // - all Algo* abstract methods should be overriden by inherited classes - TAlgoCompress = class(TSynPersistent) - public - /// should return a genuine byte identifier - // - 0 is reserved for stored, 1 for TAlgoSynLz, 2/3 for TAlgoDeflate/Fast - // (in mORMot.pas), 4/5/6 for TAlgoLizard/Fast/Huffman (in SynLizard.pas) - function AlgoID: byte; virtual; abstract; - /// computes by default the crc32c() digital signature of the buffer - function AlgoHash(Previous: cardinal; Data: pointer; DataLen: integer): cardinal; virtual; - /// get maximum possible (worse) compressed size for the supplied length - function AlgoCompressDestLen(PlainLen: integer): integer; virtual; abstract; - /// this method will compress the supplied data - function AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; virtual; abstract; - /// this method will return the size of the decompressed data - function AlgoDecompressDestLen(Comp: pointer): integer; virtual; abstract; - /// this method will decompress the supplied data - function AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; virtual; abstract; - /// this method will partially and safely decompress the supplied data - // - expects PartialLen <= result < PartialLenMax, depending on the algorithm - function AlgoDecompressPartial(Comp: pointer; CompLen: integer; - Partial: pointer; PartialLen, PartialLenMax: integer): integer; virtual; abstract; - public - /// will register AlgoID in the global list, for Algo() class methods - // - no need to free this instance, since it will be owned by the global list - // - raise a ESynException if the class or its AlgoID are already registered - // - you should never have to call this constructor, but define a global - // variable holding a reference to a shared instance - constructor Create; override; - /// get maximum possible (worse) compressed size for the supplied length - // - including the crc32c + algo 9 bytes header - function CompressDestLen(PlainLen: integer): integer; - {$ifdef HASINLINE}inline;{$endif} - /// compress a memory buffer with crc32c hashing to a RawByteString - function Compress(const Plain: RawByteString; CompressionSizeTrigger: integer=100; - CheckMagicForCompressed: boolean=false; BufferOffset: integer=0): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - /// compress a memory buffer with crc32c hashing to a RawByteString - function Compress(Plain: PAnsiChar; PlainLen: integer; CompressionSizeTrigger: integer=100; - CheckMagicForCompressed: boolean=false; BufferOffset: integer=0): RawByteString; overload; - /// compress a memory buffer with crc32c hashing - // - supplied Comp buffer should contain at least CompressDestLen(PlainLen) bytes - function Compress(Plain, Comp: PAnsiChar; PlainLen, CompLen: integer; - CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false): integer; overload; - /// compress a memory buffer with crc32c hashing to a TByteDynArray - function CompressToBytes(const Plain: RawByteString; CompressionSizeTrigger: integer=100; - CheckMagicForCompressed: boolean=false): TByteDynArray; overload; - {$ifdef HASINLINE}inline;{$endif} - /// compress a memory buffer with crc32c hashing to a TByteDynArray - function CompressToBytes(Plain: PAnsiChar; PlainLen: integer; CompressionSizeTrigger: integer=100; - CheckMagicForCompressed: boolean=false): TByteDynArray; overload; - /// uncompress a RawByteString memory buffer with crc32c hashing - function Decompress(const Comp: RawByteString; Load: TAlgoCompressLoad=aclNormal; - BufferOffset: integer=0): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - /// uncompress a RawByteString memory buffer with crc32c hashing - // - returns TRUE on success - function TryDecompress(const Comp: RawByteString; out Dest: RawByteString; - Load: TAlgoCompressLoad=aclNormal): boolean; - /// uncompress a memory buffer with crc32c hashing - procedure Decompress(Comp: PAnsiChar; CompLen: integer; out Result: RawByteString; - Load: TAlgoCompressLoad=aclNormal; BufferOffset: integer=0); overload; - /// uncompress a RawByteString memory buffer with crc32c hashing - function Decompress(const Comp: TByteDynArray): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - /// uncompress a RawByteString memory buffer with crc32c hashing - // - returns nil if crc32 hash failed, i.e. if the supplied Comp is not correct - // - returns a pointer to the uncompressed data and fill PlainLen variable, - // after crc32c hash - // - avoid any memory allocation in case of a stored content - otherwise, would - // uncompress to the tmp variable, and return pointer(tmp) and length(tmp) - function Decompress(const Comp: RawByteString; out PlainLen: integer; - var tmp: RawByteString; Load: TAlgoCompressLoad=aclNormal): pointer; overload; - {$ifdef HASINLINE}inline;{$endif} - /// uncompress a RawByteString memory buffer with crc32c hashing - // - returns nil if crc32 hash failed, i.e. if the supplied Data is not correct - // - returns a pointer to an uncompressed data buffer of PlainLen bytes - // - avoid any memory allocation in case of a stored content - otherwise, would - // uncompress to the tmp variable, and return pointer(tmp) and length(tmp) - function Decompress(Comp: PAnsiChar; CompLen: integer; out PlainLen: integer; - var tmp: RawByteString; Load: TAlgoCompressLoad=aclNormal): pointer; overload; - /// decode the header of a memory buffer compressed via the Compress() method - // - validates the crc32c of the compressed data (unless Load=aclNoCrcFast), - // then return the uncompressed size in bytes, or 0 if the crc32c does not match - // - should call DecompressBody() later on to actually retrieve the content - function DecompressHeader(Comp: PAnsiChar; CompLen: integer; - Load: TAlgoCompressLoad=aclNormal): integer; - /// decode the content of a memory buffer compressed via the Compress() method - // - PlainLen has been returned by a previous call to DecompressHeader() - function DecompressBody(Comp,Plain: PAnsiChar; CompLen,PlainLen: integer; - Load: TAlgoCompressLoad=aclNormal): boolean; - /// partial decoding of a memory buffer compressed via the Compress() method - // - returns 0 on error, or how many bytes have been written to Partial - // - will call virtual AlgoDecompressPartial() which is slower, but expected - // to avoid any buffer overflow on the Partial destination buffer - // - some algorithms (e.g. Lizard) may need some additional bytes in the - // decode buffer, so PartialLenMax bytes should be allocated in Partial^, - // with PartialLenMax > expected PartialLen, and returned bytes may be > - // PartialLen, but always <= PartialLenMax - function DecompressPartial(Comp,Partial: PAnsiChar; CompLen,PartialLen,PartialLenMax: integer): integer; - /// get the TAlgoCompress instance corresponding to the AlgoID stored - // in the supplied compressed buffer - // - returns nil if no algorithm was identified - class function Algo(Comp: PAnsiChar; CompLen: integer): TAlgoCompress; overload; - {$ifdef HASINLINE}inline;{$endif} - /// get the TAlgoCompress instance corresponding to the AlgoID stored - // in the supplied compressed buffer - // - returns nil if no algorithm was identified - // - also identifies "stored" content in IsStored variable - class function Algo(Comp: PAnsiChar; CompLen: integer; out IsStored: boolean): TAlgoCompress; overload; - /// get the TAlgoCompress instance corresponding to the AlgoID stored - // in the supplied compressed buffer - // - returns nil if no algorithm was identified - class function Algo(const Comp: RawByteString): TAlgoCompress; overload; - {$ifdef HASINLINE}inline;{$endif} - /// get the TAlgoCompress instance corresponding to the AlgoID stored - // in the supplied compressed buffer - // - returns nil if no algorithm was identified - class function Algo(const Comp: TByteDynArray): TAlgoCompress; overload; - {$ifdef HASINLINE}inline;{$endif} - /// get the TAlgoCompress instance corresponding to the supplied AlgoID - // - returns nil if no algorithm was identified - // - stored content is identified as TAlgoSynLZ - class function Algo(AlgoID: byte): TAlgoCompress; overload; - /// quickly validate a compressed buffer content, without uncompression - // - extract the TAlgoCompress, and call DecompressHeader() to check the - // hash of the compressed data, and return then uncompressed size - // - returns 0 on error (e.g. unknown algorithm or incorrect hash) - class function UncompressedSize(const Comp: RawByteString): integer; - /// returns the algorithm name, from its classname - // - e.g. TAlgoSynLZ->'synlz' TAlgoLizard->'lizard' nil->'none' - function AlgoName: TShort16; - end; - - /// implement our fast SynLZ compression as a TAlgoCompress class - // - please use the AlgoSynLZ global variable methods instead of the deprecated - // SynLZCompress/SynLZDecompress wrapper functions - TAlgoSynLZ = class(TAlgoCompress) - public - /// returns 1 as genuine byte identifier for SynLZ - function AlgoID: byte; override; - /// get maximum possible (worse) SynLZ compressed size for the supplied length - function AlgoCompressDestLen(PlainLen: integer): integer; override; - /// compress the supplied data using SynLZ - function AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; override; - /// return the size of the SynLZ decompressed data - function AlgoDecompressDestLen(Comp: pointer): integer; override; - /// decompress the supplied data using SynLZ - function AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; override; - /// partial (and safe) decompression of the supplied data using SynLZ - function AlgoDecompressPartial(Comp: pointer; CompLen: integer; - Partial: pointer; PartialLen, PartialLenMax: integer): integer; override; - end; - - TAlgoCompressWithNoDestLenProcess = (doCompress, doUnCompress, doUncompressPartial); - - /// abstract class storing the plain length before calling compression API - // - some libraries (e.g. Deflate or Lizard) don't provide the uncompressed - // length from its output buffer - inherit from this class to store this value - // as ToVarUInt32, and override the RawProcess abstract protected method - TAlgoCompressWithNoDestLen = class(TAlgoCompress) - protected - /// inherited classes should implement this single method for the actual process - // - dstMax is oinly used for doUncompressPartial - function RawProcess(src,dst: pointer; srcLen,dstLen,dstMax: integer; - process: TAlgoCompressWithNoDestLenProcess): integer; virtual; abstract; - public - /// performs the compression, storing PlainLen and calling protected RawProcess - function AlgoCompress(Plain: pointer; PlainLen: integer; Comp: pointer): integer; override; - /// return the size of the decompressed data (using FromVarUInt32) - function AlgoDecompressDestLen(Comp: pointer): integer; override; - /// performs the decompression, retrieving PlainLen and calling protected RawProcess - function AlgoDecompress(Comp: pointer; CompLen: integer; Plain: pointer): integer; override; - /// performs the decompression, retrieving PlainLen and calling protected RawProcess - function AlgoDecompressPartial(Comp: pointer; CompLen: integer; - Partial: pointer; PartialLen, PartialLenMax: integer): integer; override; - end; - - // internal flag, used only by TSynDictionary.InArray protected method - TSynDictionaryInArray = ( - iaFind, iaFindAndDelete, iaFindAndUpdate, iaFindAndAddIfNotExisting, iaAdd); - - /// event called by TSynDictionary.ForEach methods to iterate over stored items - // - if the implementation method returns TRUE, will continue the loop - // - if the implementation method returns FALSE, will stop values browsing - // - aOpaque is a custom value specified at ForEach() method call - TSynDictionaryEvent = function(const aKey; var aValue; aIndex,aCount: integer; - aOpaque: pointer): boolean of object; - - /// event called by TSynDictionary.DeleteDeprecated - // - called just before deletion: return false to by-pass this item - TSynDictionaryCanDeleteEvent = function(const aKey, aValue; aIndex: integer): boolean of object; - - /// thread-safe dictionary to store some values from associated keys - // - will maintain a dynamic array of values, associated with a hash table - // for the keys, so that setting or retrieving values would be O(1) - // - all process is protected by a TSynLocker, so will be thread-safe - // - TDynArray is a wrapper which do not store anything, whereas this class - // is able to store both keys and values, and provide convenient methods to - // access the stored data, including JSON serialization and binary storage - TSynDictionary = class(TSynPersistentLock) - protected - fKeys: TDynArrayHashed; - fValues: TDynArray; - fTimeOut: TCardinalDynArray; - fTimeOuts: TDynArray; - fCompressAlgo: TAlgoCompress; - fOnCanDelete: TSynDictionaryCanDeleteEvent; - function InArray(const aKey,aArrayValue; aAction: TSynDictionaryInArray): boolean; - procedure SetTimeouts; - function ComputeNextTimeOut: cardinal; - function KeyFullHash(const Elem): cardinal; - function KeyFullCompare(const A,B): integer; - function GetCapacity: integer; - procedure SetCapacity(const Value: integer); - function GetTimeOutSeconds: cardinal; - public - /// initialize the dictionary storage, specifyng dynamic array keys/values - // - aKeyTypeInfo should be a dynamic array TypeInfo() RTTI pointer, which - // would store the keys within this TSynDictionary instance - // - aValueTypeInfo should be a dynamic array TypeInfo() RTTI pointer, which - // would store the values within this TSynDictionary instance - // - by default, string keys would be searched following exact case, unless - // aKeyCaseInsensitive is TRUE - // - you can set an optional timeout period, in seconds - you should call - // DeleteDeprecated periodically to search for deprecated items - constructor Create(aKeyTypeInfo,aValueTypeInfo: pointer; - aKeyCaseInsensitive: boolean=false; aTimeoutSeconds: cardinal=0; - aCompressAlgo: TAlgoCompress=nil); reintroduce; virtual; - /// finalize the storage - // - would release all internal stored values - destructor Destroy; override; - /// try to add a value associated with a primary key - // - returns the index of the inserted item, -1 if aKey is already existing - // - this method is thread-safe, since it will lock the instance - function Add(const aKey, aValue): integer; - /// store a value associated with a primary key - // - returns the index of the matching item - // - if aKey does not exist, a new entry is added - // - if aKey does exist, the existing entry is overriden with aValue - // - this method is thread-safe, since it will lock the instance - function AddOrUpdate(const aKey, aValue): integer; - /// clear the value associated via aKey - // - does not delete the entry, but reset its value - // - returns the index of the matching item, -1 if aKey was not found - // - this method is thread-safe, since it will lock the instance - function Clear(const aKey): integer; - /// delete all key/value stored in the current instance - procedure DeleteAll; - /// delete a key/value association from its supplied aKey - // - this would delete the entry, i.e. matching key and value pair - // - returns the index of the deleted item, -1 if aKey was not found - // - this method is thread-safe, since it will lock the instance - function Delete(const aKey): integer; - /// delete a key/value association from its internal index - // - this method is not thread-safe: you should use fSafe.Lock/Unlock - // e.g. then Find/FindValue to retrieve the index value - function DeleteAt(aIndex: integer): boolean; - /// search and delete all deprecated items according to TimeoutSeconds - // - returns how many items have been deleted - // - you can call this method very often: it will ensure that the - // search process will take place at most once every second - // - this method is thread-safe, but blocking during the process - function DeleteDeprecated: integer; - /// search of a primary key within the internal hashed dictionary - // - returns the index of the matching item, -1 if aKey was not found - // - if you want to access the value, you should use fSafe.Lock/Unlock: - // consider using Exists or FindAndCopy thread-safe methods instead - // - aUpdateTimeOut will update the associated timeout value of the entry - function Find(const aKey; aUpdateTimeOut: boolean=false): integer; - /// search of a primary key within the internal hashed dictionary - // - returns a pointer to the matching item, nil if aKey was not found - // - if you want to access the value, you should use fSafe.Lock/Unlock: - // consider using Exists or FindAndCopy thread-safe methods instead - // - aUpdateTimeOut will update the associated timeout value of the entry - function FindValue(const aKey; aUpdateTimeOut: boolean=false; aIndex: PInteger=nil): pointer; - /// search of a primary key within the internal hashed dictionary - // - returns a pointer to the matching or already existing item - // - if you want to access the value, you should use fSafe.Lock/Unlock: - // consider using Exists or FindAndCopy thread-safe methods instead - // - will update the associated timeout value of the entry, if applying - function FindValueOrAdd(const aKey; var added: boolean; aIndex: PInteger=nil): pointer; - /// search of a stored value by its primary key, and return a local copy - // - so this method is thread-safe - // - returns TRUE if aKey was found, FALSE if no match exists - // - will update the associated timeout value of the entry, unless - // aUpdateTimeOut is set to false - function FindAndCopy(const aKey; out aValue; aUpdateTimeOut: boolean=true): boolean; - /// search of a stored value by its primary key, then delete and return it - // - returns TRUE if aKey was found, fill aValue with its content, - // and delete the entry in the internal storage - // - so this method is thread-safe - // - returns FALSE if no match exists - function FindAndExtract(const aKey; out aValue): boolean; - /// search for a primary key presence - // - returns TRUE if aKey was found, FALSE if no match exists - // - this method is thread-safe - function Exists(const aKey): boolean; - /// apply a specified event over all items stored in this dictionnary - // - would browse the list in the adding order - // - returns the number of times OnEach has been called - // - this method is thread-safe, since it will lock the instance - function ForEach(const OnEach: TSynDictionaryEvent; Opaque: pointer=nil): integer; overload; - /// apply a specified event over matching items stored in this dictionnary - // - would browse the list in the adding order, comparing each key and/or - // value item with the supplied comparison functions and aKey/aValue content - // - returns the number of times OnMatch has been called, i.e. how many times - // KeyCompare(aKey,Keys[#])=0 or ValueCompare(aValue,Values[#])=0 - // - this method is thread-safe, since it will lock the instance - function ForEach(const OnMatch: TSynDictionaryEvent; - KeyCompare,ValueCompare: TDynArraySortCompare; const aKey,aValue; - Opaque: pointer=nil): integer; overload; - /// touch the entry timeout field so that it won't be deprecated sooner - // - this method is not thread-safe, and is expected to be execute e.g. - // from a ForEach() TSynDictionaryEvent callback - procedure SetTimeoutAtIndex(aIndex: integer); - /// search aArrayValue item in a dynamic-array value associated via aKey - // - expect the stored value to be a dynamic array itself - // - would search for aKey as primary key, then use TDynArray.Find - // to delete any aArrayValue match in the associated dynamic array - // - returns FALSE if Values is not a tkDynArray, or if aKey or aArrayValue - // were not found - // - this method is thread-safe, since it will lock the instance - function FindInArray(const aKey, aArrayValue): boolean; - /// search of a stored key by its associated key, and return a key local copy - // - won't use any hashed index but TDynArray.IndexOf over fValues, - // so is much slower than FindAndCopy() - // - will update the associated timeout value of the entry, unless - // aUpdateTimeOut is set to false - // - so this method is thread-safe - // - returns TRUE if aValue was found, FALSE if no match exists - function FindKeyFromValue(const aValue; out aKey; aUpdateTimeOut: boolean=true): boolean; - /// add aArrayValue item within a dynamic-array value associated via aKey - // - expect the stored value to be a dynamic array itself - // - would search for aKey as primary key, then use TDynArray.Add - // to add aArrayValue to the associated dynamic array - // - returns FALSE if Values is not a tkDynArray, or if aKey was not found - // - this method is thread-safe, since it will lock the instance - function AddInArray(const aKey, aArrayValue): boolean; - /// add once aArrayValue within a dynamic-array value associated via aKey - // - expect the stored value to be a dynamic array itself - // - would search for aKey as primary key, then use - // TDynArray.FindAndAddIfNotExisting to add once aArrayValue to the - // associated dynamic array - // - returns FALSE if Values is not a tkDynArray, or if aKey was not found - // - this method is thread-safe, since it will lock the instance - function AddOnceInArray(const aKey, aArrayValue): boolean; - /// clear aArrayValue item of a dynamic-array value associated via aKey - // - expect the stored value to be a dynamic array itself - // - would search for aKey as primary key, then use TDynArray.FindAndDelete - // to delete any aArrayValue match in the associated dynamic array - // - returns FALSE if Values is not a tkDynArray, or if aKey or aArrayValue were - // not found - // - this method is thread-safe, since it will lock the instance - function DeleteInArray(const aKey, aArrayValue): boolean; - /// replace aArrayValue item of a dynamic-array value associated via aKey - // - expect the stored value to be a dynamic array itself - // - would search for aKey as primary key, then use TDynArray.FindAndUpdate - // to delete any aArrayValue match in the associated dynamic array - // - returns FALSE if Values is not a tkDynArray, or if aKey or aArrayValue were - // not found - // - this method is thread-safe, since it will lock the instance - function UpdateInArray(const aKey, aArrayValue): boolean; - {$ifndef DELPHI5OROLDER} - /// make a copy of the stored values - // - this method is thread-safe, since it will lock the instance during copy - // - resulting length(Dest) will match the exact values count - // - T*ObjArray will be reallocated and copied by content (using a temporary - // JSON serialization), unless ObjArrayByRef is true and pointers are copied - procedure CopyValues(out Dest; ObjArrayByRef: boolean=false); - {$endif DELPHI5OROLDER} - /// serialize the content as a "key":value JSON object - procedure SaveToJSON(W: TTextWriter; EnumSetsAsText: boolean=false); overload; - /// serialize the content as a "key":value JSON object - function SaveToJSON(EnumSetsAsText: boolean=false): RawUTF8; overload; - /// serialize the Values[] as a JSON array - function SaveValuesToJSON(EnumSetsAsText: boolean=false): RawUTF8; - /// unserialize the content from "key":value JSON object - // - if the JSON input may not be correct (i.e. if not coming from SaveToJSON), - // you may set EnsureNoKeyCollision=TRUE for a slow but safe keys validation - function LoadFromJSON(const JSON: RawUTF8 {$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions=nil{$endif}): boolean; overload; - /// unserialize the content from "key":value JSON object - // - note that input JSON buffer is not modified in place: no need to create - // a temporary copy if the buffer is about to be re-used - function LoadFromJSON(JSON: PUTF8Char {$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions=nil{$endif}): boolean; overload; - /// save the content as SynLZ-compressed raw binary data - // - warning: this format is tied to the values low-level RTTI, so if you - // change the value/key type definitions, LoadFromBinary() would fail - function SaveToBinary(NoCompression: boolean=false): RawByteString; - /// load the content from SynLZ-compressed raw binary data - // - as previously saved by SaveToBinary method - function LoadFromBinary(const binary: RawByteString): boolean; - /// can be assigned to OnCanDeleteDeprecated to check TSynPersistentLock(aValue).Safe.IsLocked - class function OnCanDeleteSynPersistentLock(const aKey, aValue; aIndex: integer): boolean; - /// can be assigned to OnCanDeleteDeprecated to check TSynPersistentLock(aValue).Safe.IsLocked - class function OnCanDeleteSynPersistentLocked(const aKey, aValue; aIndex: integer): boolean; - /// returns how many items are currently stored in this dictionary - // - this method is thread-safe - function Count: integer; - /// fast returns how many items are currently stored in this dictionary - // - this method is NOT thread-safe so should be protected by fSafe.Lock/UnLock - function RawCount: integer; {$ifdef HASINLINE}inline;{$endif} - /// direct access to the primary key identifiers - // - if you want to access the keys, you should use fSafe.Lock/Unlock - property Keys: TDynArrayHashed read fKeys; - /// direct access to the associated stored values - // - if you want to access the values, you should use fSafe.Lock/Unlock - property Values: TDynArray read fValues; - /// defines how many items are currently stored in Keys/Values internal arrays - property Capacity: integer read GetCapacity write SetCapacity; - /// direct low-level access to the internal access tick (GetTickCount64 shr 10) - // - may be nil if TimeOutSeconds=0 - property TimeOut: TCardinalDynArray read fTimeOut; - /// returns the aTimeOutSeconds parameter value, as specified to Create() - property TimeOutSeconds: cardinal read GetTimeOutSeconds; - /// the compression algorithm used for binary serialization - property CompressAlgo: TAlgoCompress read fCompressAlgo write fCompressAlgo; - /// callback to by-pass DeleteDeprecated deletion by returning false - // - can be assigned e.g. to OnCanDeleteSynPersistentLock if Value is a - // TSynPersistentLock instance, to avoid any potential access violation - property OnCanDeleteDeprecated: TSynDictionaryCanDeleteEvent read fOnCanDelete write fOnCanDelete; - end; - - /// event signature to locate a service for a given string key - // - used e.g. by TRawUTF8ObjectCacheList.OnKeyResolve property - TOnKeyResolve = function(const aInterface: TGUID; const Key: RawUTF8; out Obj): boolean of object; - /// event signature to notify a given string key - TOnKeyNotify = procedure(Sender: TObject; const Key: RawUTF8) of object; - -var - /// mORMot.pas will registry here its T*ObjArray serialization process - // - will be used by TDynArray.GetIsObjArray - DynArrayIsObjArray: function(aDynArrayTypeInfo: Pointer): TPointerClassHashed; - -type - /// handle memory mapping of a file content - TMemoryMap = object - protected - fBuf: PAnsiChar; - fBufSize: PtrUInt; - fFile: THandle; - {$ifdef MSWINDOWS} - fMap: THandle; - {$endif} - fFileSize: Int64; - fFileLocal: boolean; - public - /// map the corresponding file handle - // - if aCustomSize and aCustomOffset are specified, the corresponding - // map view if created (by default, will map whole file) - function Map(aFile: THandle; aCustomSize: PtrUInt=0; aCustomOffset: Int64=0): boolean; overload; - /// map the file specified by its name - // - file will be closed when UnMap will be called - function Map(const aFileName: TFileName): boolean; overload; - /// set a fixed buffer for the content - // - emulated a memory-mapping from an existing buffer - procedure Map(aBuffer: pointer; aBufferSize: PtrUInt); overload; - /// unmap the file - procedure UnMap; - /// retrieve the memory buffer mapped to the file content - property Buffer: PAnsiChar read fBuf; - /// retrieve the buffer size - property Size: PtrUInt read fBufSize; - /// retrieve the mapped file size - property FileSize: Int64 read fFileSize; - /// access to the low-level associated File handle (if any) - property FileHandle: THandle read fFile; - end; - - {$M+} - /// able to read a UTF-8 text file using memory map - // - much faster than TStringList.LoadFromFile() - // - will ignore any trailing UTF-8 BOM in the file content, but will not - // expect one either - TMemoryMapText = class - protected - fLines: PPointerArray; - fLinesMax: integer; - fCount: integer; - fMapEnd: PUTF8Char; - fMap: TMemoryMap; - fFileName: TFileName; - fAppendedLines: TRawUTF8DynArray; - fAppendedLinesCount: integer; - function GetLine(aIndex: integer): RawUTF8; {$ifdef HASINLINE}inline;{$endif} - function GetString(aIndex: integer): string; {$ifdef HASINLINE}inline;{$endif} - /// call once by Create constructors when fMap has been initialized - procedure LoadFromMap(AverageLineLength: integer=32); virtual; - /// call once per line, from LoadFromMap method - // - default implementation will set fLines[fCount] := LineBeg; - // - override this method to add some per-line process at loading: it will - // avoid reading the entire file more than once - procedure ProcessOneLine(LineBeg, LineEnd: PUTF8Char); virtual; - public - /// initialize the memory mapped text file - // - this default implementation just do nothing but is called by overloaded - // constructors so may be overriden to initialize an inherited class - constructor Create; overload; virtual; - /// read an UTF-8 encoded text file - // - every line beginning is stored into LinePointers[] - constructor Create(const aFileName: TFileName); overload; - /// read an UTF-8 encoded text file content - // - every line beginning is stored into LinePointers[] - // - this overloaded constructor accept an existing memory buffer (some - // uncompressed data e.g.) - constructor Create(aFileContent: PUTF8Char; aFileSize: integer); overload; - /// release the memory map and internal LinePointers[] - destructor Destroy; override; - /// save the whole content into a specified stream - // - including any runtime appended values via AddInMemoryLine() - procedure SaveToStream(Dest: TStream; const Header: RawUTF8); - /// save the whole content into a specified file - // - including any runtime appended values via AddInMemoryLine() - // - an optional header text can be added to the beginning of the file - procedure SaveToFile(FileName: TFileName; const Header: RawUTF8=''); - /// add a new line to the already parsed content - // - this line won't be stored in the memory mapped file, but stay in memory - // and appended to the existing lines, until this instance is released - procedure AddInMemoryLine(const aNewLine: RawUTF8); virtual; - /// clear all in-memory appended rows - procedure AddInMemoryLinesClear; virtual; - /// retrieve the number of UTF-8 chars of the given line - // - warning: no range check is performed about supplied index - function LineSize(aIndex: integer): integer; - {$ifdef HASINLINE}inline;{$endif} - /// check if there is at least a given number of UTF-8 chars in the given line - // - this is faster than LineSize(aIndex) use this function to safe access files > 2 GB -// (thanks to sanyin for the report) -function FileSeek64(Handle: THandle; const Offset: Int64; Origin: cardinal): Int64; - -/// wrapper to serialize a T*ObjArray dynamic array as JSON -// - as expected by TJSONSerializer.RegisterObjArrayForJSON() -function ObjArrayToJSON(const aObjArray; - aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]): RawUTF8; - -/// encode the supplied data as an UTF-8 valid JSON object content -// - data must be supplied two by two, as Name,Value pairs, e.g. -// ! JSONEncode(['name','John','year',1972]) = '{"name":"John","year":1972}' -// - or you can specify nested arrays or objects with '['..']' or '{'..'}': -// ! J := JSONEncode(['doc','{','name','John','abc','[','a','b','c',']','}','id',123]); -// ! assert(J='{"doc":{"name":"John","abc":["a","b","c"]},"id":123}'); -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -// - you can pass nil as parameter for a null JSON value -function JSONEncode(const NameValuePairs: array of const): RawUTF8; overload; - -{$ifndef NOVARIANTS} -/// encode the supplied (extended) JSON content, with parameters, -// as an UTF-8 valid JSON object content -// - in addition to the JSON RFC specification strict mode, this method will -// handle some BSON-like extensions, e.g. unquoted field names: -// ! aJSON := JSONEncode('{id:?,%:{name:?,birthyear:?}}',['doc'],[10,'John',1982]); -// - you can use nested _Obj() / _Arr() instances -// ! aJSON := JSONEncode('{%:{$in:[?,?]}}',['type'],['food','snack']); -// ! aJSON := JSONEncode('{type:{$in:?}}',[],[_Arr(['food','snack'])]); -// ! // will both return -// ! '{"type":{"$in":["food","snack"]}}') -// - if the SynMongoDB unit is used in the application, the MongoDB Shell -// syntax will also be recognized to create TBSONVariant, like -// ! new Date() ObjectId() MinKey MaxKey // -// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json -// ! aJSON := JSONEncode('{name:?,field:/%/i}',['acme.*corp'],['John'])) -// ! // will return -// ! '{"name":"John","field":{"$regex":"acme.*corp","$options":"i"}}' -// - will call internally _JSONFastFmt() to create a temporary TDocVariant with -// all its features - so is slightly slower than other JSONEncode* functions -function JSONEncode(const Format: RawUTF8; const Args,Params: array of const): RawUTF8; overload; -{$endif} - -/// encode the supplied RawUTF8 array data as an UTF-8 valid JSON array content -function JSONEncodeArrayUTF8(const Values: array of RawUTF8): RawUTF8; overload; - -/// encode the supplied integer array data as a valid JSON array -function JSONEncodeArrayInteger(const Values: array of integer): RawUTF8; overload; - -/// encode the supplied floating-point array data as a valid JSON array -function JSONEncodeArrayDouble(const Values: array of double): RawUTF8; overload; - -/// encode the supplied array data as a valid JSON array content -// - if WithoutBraces is TRUE, no [ ] will be generated -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -function JSONEncodeArrayOfConst(const Values: array of const; - WithoutBraces: boolean=false): RawUTF8; overload; - -/// encode the supplied array data as a valid JSON array content -// - if WithoutBraces is TRUE, no [ ] will be generated -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -procedure JSONEncodeArrayOfConst(const Values: array of const; - WithoutBraces: boolean; var result: RawUTF8); overload; - -/// encode as JSON {"name":value} object, from a potential SQL quoted value -// - will unquote the SQLValue using TTextWriter.AddQuotedStringAsJSON() -procedure JSONEncodeNameSQLValue(const Name,SQLValue: RawUTF8; var result: RawUTF8); - -type - /// points to one value of raw UTF-8 content, decoded from a JSON buffer - // - used e.g. by JSONDecode() overloaded function to returns names/values - TValuePUTF8Char = object - public - /// a pointer to the actual UTF-8 text - Value: PUTF8Char; - /// how many UTF-8 bytes are stored in Value - ValueLen: PtrInt; - /// convert the value into a UTF-8 string - procedure ToUTF8(var Text: RawUTF8); overload; {$ifdef HASINLINE}inline;{$endif} - /// convert the value into a UTF-8 string - function ToUTF8: RawUTF8; overload; {$ifdef HASINLINE}inline;{$endif} - /// convert the value into a VCL/generic string - function ToString: string; - /// convert the value into a signed integer - function ToInteger: PtrInt; {$ifdef HASINLINE}inline;{$endif} - /// convert the value into an unsigned integer - function ToCardinal: PtrUInt; {$ifdef HASINLINE}inline;{$endif} - /// will call IdemPropNameU() over the stored text Value - function Idem(const Text: RawUTF8): boolean; {$ifdef HASINLINE}inline;{$endif} - end; - /// used e.g. by JSONDecode() overloaded function to returns values - TValuePUTF8CharArray = array[0..maxInt div SizeOf(TValuePUTF8Char)-1] of TValuePUTF8Char; - PValuePUTF8CharArray = ^TValuePUTF8CharArray; - - /// store one name/value pair of raw UTF-8 content, from a JSON buffer - // - used e.g. by JSONDecode() overloaded function or UrlEncodeJsonObject() - // to returns names/values - TNameValuePUTF8Char = record - /// a pointer to the actual UTF-8 name text - Name: PUTF8Char; - /// a pointer to the actual UTF-8 value text - Value: PUTF8Char; - /// how many UTF-8 bytes are stored in Name (should be integer, not PtrInt) - NameLen: integer; - /// how many UTF-8 bytes are stored in Value - ValueLen: integer; - end; - /// used e.g. by JSONDecode() overloaded function to returns name/value pairs - TNameValuePUTF8CharDynArray = array of TNameValuePUTF8Char; - -/// decode the supplied UTF-8 JSON content for the supplied names -// - data will be set in Values, according to the Names supplied e.g. -// ! JSONDecode(JSON,['name','year'],@Values) -> Values[0].Value='John'; Values[1].Value='1972'; -// - if any supplied name wasn't found its corresponding Values[] will be nil -// - this procedure will decode the JSON content in-memory, i.e. the PUtf8Char -// array is created inside JSON, which is therefore modified: make a private -// copy first if you want to reuse the JSON content -// - if HandleValuesAsObjectOrArray is TRUE, then this procedure will handle -// JSON arrays or objects -// - support enhanced JSON syntax, e.g. '{name:'"John",year:1972}' is decoded -// just like '{"name":'"John","year":1972}' -procedure JSONDecode(var JSON: RawUTF8; const Names: array of RawUTF8; - Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean=false); overload; - -/// decode the supplied UTF-8 JSON content for the supplied names -// - an overloaded function when the JSON is supplied as a RawJSON variable -procedure JSONDecode(var JSON: RawJSON; const Names: array of RawUTF8; - Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean=false); overload; - -/// decode the supplied UTF-8 JSON content for the supplied names -// - data will be set in Values, according to the Names supplied e.g. -// ! JSONDecode(P,['name','year'],Values) -> Values[0]^='John'; Values[1]^='1972'; -// - if any supplied name wasn't found its corresponding Values[] will be nil -// - this procedure will decode the JSON content in-memory, i.e. the PUtf8Char -// array is created inside P, which is therefore modified: make a private -// copy first if you want to reuse the JSON content -// - if HandleValuesAsObjectOrArray is TRUE, then this procedure will handle -// JSON arrays or objects -// - if ValuesLen is set, ValuesLen[] will contain the length of each Values[] -// - returns a pointer to the next content item in the JSON buffer -function JSONDecode(P: PUTF8Char; const Names: array of RawUTF8; - Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean=false): PUTF8Char; overload; - -/// decode the supplied UTF-8 JSON content into an array of name/value pairs -// - this procedure will decode the JSON content in-memory, i.e. the PUtf8Char -// array is created inside JSON, which is therefore modified: make a private -// copy first if you want to reuse the JSON content -// - the supplied JSON buffer should stay available until Name/Value pointers -// from returned Values[] are accessed -// - if HandleValuesAsObjectOrArray is TRUE, then this procedure will handle -// JSON arrays or objects -// - support enhanced JSON syntax, e.g. '{name:'"John",year:1972}' is decoded -// just like '{"name":'"John","year":1972}' -function JSONDecode(P: PUTF8Char; out Values: TNameValuePUTF8CharDynArray; - HandleValuesAsObjectOrArray: Boolean=false): PUTF8Char; overload; - -/// decode the supplied UTF-8 JSON content for the one supplied name -// - this function will decode the JSON content in-memory, so will unescape it -// in-place: it must be called only once with the same JSON data -function JSONDecode(var JSON: RawUTF8; const aName: RawUTF8='result'; - wasString: PBoolean=nil; HandleValuesAsObjectOrArray: Boolean=false): RawUTF8; overload; - -/// retrieve a pointer to JSON string field content -// - returns either ':' for name field, either '}',',' for value field -// - returns nil on JSON content error -// - this function won't touch the JSON buffer, so you can call it before -// using in-place escape process via JSONDecode() or GetJSONField() -function JSONRetrieveStringField(P: PUTF8Char; out Field: PUTF8Char; - out FieldLen: integer; ExpectNameField: boolean): PUTF8Char; - {$ifdef HASINLINE}inline;{$endif} - -/// efficient JSON field in-place decoding, within a UTF-8 encoded buffer -// - this function decodes in the P^ buffer memory itself (no memory allocation -// or copy), for faster process - so take care that P^ is not shared -// - PDest points to the next field to be decoded, or nil on JSON parsing error -// - EndOfObject (if not nil) is set to the JSON value char (',' ':' or '}' e.g.) -// - optional wasString is set to true if the JSON value was a JSON "string" -// - returns a PUTF8Char to the decoded value, with its optional length in Len^ -// - '"strings"' are decoded as 'strings', with wasString=true, properly JSON -// unescaped (e.g. any \u0123 pattern would be converted into UTF-8 content) -// - null is decoded as nil, with wasString=false -// - true/false boolean values are returned as 'true'/'false', with wasString=false -// - any number value is returned as its ascii representation, with wasString=false -// - works for both field names or values (e.g. '"FieldName":' or 'Value,') -function GetJSONField(P: PUTF8Char; out PDest: PUTF8Char; - wasString: PBoolean=nil; EndOfObject: PUTF8Char=nil; Len: PInteger=nil): PUTF8Char; - -/// decode a JSON field name in an UTF-8 encoded buffer -// - this function decodes in the P^ buffer memory itself (no memory allocation -// or copy), for faster process - so take care that P^ is not shared -// - it will return the property name (with an ending #0) or nil on error -// - this function will handle strict JSON property name (i.e. a "string"), but -// also MongoDB extended syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}} -// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json -function GetJSONPropName(var P: PUTF8Char; Len: PInteger=nil): PUTF8Char; overload; - -/// decode a JSON field name in an UTF-8 encoded shortstring variable -// - this function would left the P^ buffer memory untouched, so may be safer -// than the overloaded GetJSONPropName() function in some cases -// - it will return the property name as a local UTF-8 encoded shortstring, -// or PropName='' on error -// - this function won't unescape the property name, as strict JSON (i.e. a "st\"ring") -// - but it will handle MongoDB syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}} -// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json -procedure GetJSONPropName(var P: PUTF8Char; out PropName: shortstring); overload; - -/// decode a JSON content in an UTF-8 encoded buffer -// - GetJSONField() will only handle JSON "strings" or numbers - if -// HandleValuesAsObjectOrArray is TRUE, this function will process JSON { -// objects } or [ arrays ] and add a #0 at the end of it -// - this function decodes in the P^ buffer memory itself (no memory allocation -// or copy), for faster process - so take care that it is an unique string -// - returns a pointer to the value start, and moved P to the next field to -// be decoded, or P=nil in case of any unexpected input -// - wasString is set to true if the JSON value was a "string" -// - EndOfObject (if not nil) is set to the JSON value end char (',' ':' or '}') -// - if Len is set, it will contain the length of the returned pointer value -function GetJSONFieldOrObjectOrArray(var P: PUTF8Char; wasString: PBoolean=nil; - EndOfObject: PUTF8Char=nil; HandleValuesAsObjectOrArray: Boolean=false; - NormalizeBoolean: Boolean=true; Len: PInteger=nil): PUTF8Char; - -/// retrieve the next JSON item as a RawJSON variable -// - buffer can be either any JSON item, i.e. a string, a number or even a -// JSON array (ending with ]) or a JSON object (ending with }) -// - EndOfObject (if not nil) is set to the JSON value end char (',' ':' or '}') -procedure GetJSONItemAsRawJSON(var P: PUTF8Char; var result: RawJSON; - EndOfObject: PAnsiChar=nil); - -/// retrieve the next JSON item as a RawUTF8 decoded buffer -// - buffer can be either any JSON item, i.e. a string, a number or even a -// JSON array (ending with ]) or a JSON object (ending with }) -// - EndOfObject (if not nil) is set to the JSON value end char (',' ':' or '}') -// - just call GetJSONField(), and create a new RawUTF8 from the returned value, -// after proper unescape if wasString^=true -function GetJSONItemAsRawUTF8(var P: PUTF8Char; var output: RawUTF8; - wasString: PBoolean=nil; EndOfObject: PUTF8Char=nil): boolean; - -/// test if the supplied buffer is a "string" value or a numerical value -// (floating point or integer), according to the characters within -// - this version will recognize null/false/true as strings -// - e.g. IsString('0')=false, IsString('abc')=true, IsString('null')=true -function IsString(P: PUTF8Char): boolean; - -/// test if the supplied buffer is a "string" value or a numerical value -// (floating or integer), according to the JSON encoding schema -// - this version will NOT recognize JSON null/false/true as strings -// - e.g. IsStringJSON('0')=false, IsStringJSON('abc')=true, -// but IsStringJSON('null')=false -// - will follow the JSON definition of number, i.e. '0123' is a string (i.e. -// '0' is excluded at the begining of a number) and '123' is not a string -function IsStringJSON(P: PUTF8Char): boolean; - -/// test if the supplied buffer is a correct JSON value -function IsValidJSON(P: PUTF8Char; len: PtrInt): boolean; overload; - -/// test if the supplied buffer is a correct JSON value -function IsValidJSON(const s: RawUTF8): boolean; overload; - -/// reach positon just after the current JSON item in the supplied UTF-8 buffer -// - buffer can be either any JSON item, i.e. a string, a number or even a -// JSON array (ending with ]) or a JSON object (ending with }) -// - returns nil if the specified buffer is not valid JSON content -// - returns the position in buffer just after the item excluding the separator -// character - i.e. result^ may be ',','}',']' -function GotoEndJSONItem(P: PUTF8Char; strict: boolean=false): PUTF8Char; - -/// reach the positon of the next JSON item in the supplied UTF-8 buffer -// - buffer can be either any JSON item, i.e. a string, a number or even a -// JSON array (ending with ]) or a JSON object (ending with }) -// - returns nil if the specified number of items is not available in buffer -// - returns the position in buffer after the item including the separator -// character (optionally in EndOfObject) - i.e. result will be at the start of -// the next object, and EndOfObject may be ',','}',']' -function GotoNextJSONItem(P: PUTF8Char; NumberOfItemsToJump: cardinal=1; - EndOfObject: PAnsiChar=nil): PUTF8Char; - -/// read the position of the JSON value just after a property identifier -// - this function will handle strict JSON property name (i.e. a "string"), but -// also MongoDB extended syntax, e.g. {age:{$gt:18}} or {'people.age':{$gt:18}} -// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json -function GotoNextJSONPropName(P: PUTF8Char): PUTF8Char; - -/// reach the position of the next JSON object of JSON array -// - first char is expected to be either '[' or '{' -// - will return nil in case of parsing error or unexpected end (#0) -// - will return the next character after ending ] or } - i.e. may be , } ] -function GotoNextJSONObjectOrArray(P: PUTF8Char): PUTF8Char; overload; - {$ifdef FPC}inline;{$endif} - -/// reach the position of the next JSON object of JSON array -// - first char is expected to be just after the initial '[' or '{' -// - specify ']' or '}' as the expected EndChar -// - will return nil in case of parsing error or unexpected end (#0) -// - will return the next character after ending ] or } - i.e. may be , } ] -function GotoNextJSONObjectOrArray(P: PUTF8Char; EndChar: AnsiChar): PUTF8Char; overload; - {$ifdef FPC}inline;{$endif} - -/// reach the position of the next JSON object of JSON array -// - first char is expected to be either '[' or '{' -// - this version expects a maximum position in PMax: it may be handy to break -// the parsing for HUGE content - used e.g. by JSONArrayCount(P,PMax) -// - will return nil in case of parsing error or if P reached PMax limit -// - will return the next character after ending ] or { - i.e. may be , } ] -function GotoNextJSONObjectOrArrayMax(P,PMax: PUTF8Char): PUTF8Char; - -/// compute the number of elements of a JSON array -// - this will handle any kind of arrays, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first char AFTER the initial '[' (which -// may be a closing ']') -// - returns -1 if the supplied input is invalid, or the number of identified -// items in the JSON array buffer -function JSONArrayCount(P: PUTF8Char): integer; overload; - -/// compute the number of elements of a JSON array -// - this will handle any kind of arrays, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first char after the initial '[' (which -// may be a closing ']') -// - this overloaded method will abort if P reaches a certain position: for -// really HUGE arrays, it is faster to allocate the content within the loop, -// not ahead of time -function JSONArrayCount(P,PMax: PUTF8Char): integer; overload; - -/// go to the #nth item of a JSON array -// - implemented via a fast SAX-like approach: the input buffer is not changed, -// nor no memory buffer allocated neither content copied -// - returns nil if the supplied index is out of range -// - returns a pointer to the index-nth item in the JSON array (first index=0) -// - this will handle any kind of arrays, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first initial '[' char -function JSONArrayItem(P: PUTF8Char; Index: integer): PUTF8Char; - -/// retrieve all elements of a JSON array -// - this will handle any kind of arrays, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first char AFTER the initial '[' (which -// may be a closing ']') -// - returns false if the supplied input is invalid -// - returns true on success, with Values[] pointing to each unescaped value, -// may be a JSON string, object, array of constant -function JSONArrayDecode(P: PUTF8Char; out Values: TPUTF8CharDynArray): boolean; - -/// compute the number of fields in a JSON object -// - this will handle any kind of objects, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first char after the initial '{' (which -// may be a closing '}') -function JSONObjectPropCount(P: PUTF8Char): integer; - -/// go to a named property of a JSON object -// - implemented via a fast SAX-like approach: the input buffer is not changed, -// nor no memory buffer allocated neither content copied -// - returns nil if the supplied property name does not exist -// - returns a pointer to the matching item in the JSON object -// - this will handle any kind of objects, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first initial '{' char -function JsonObjectItem(P: PUTF8Char; const PropName: RawUTF8; - PropNameFound: PRawUTF8=nil): PUTF8Char; - -/// go to a property of a JSON object, by its full path, e.g. 'parent.child' -// - implemented via a fast SAX-like approach: the input buffer is not changed, -// nor no memory buffer allocated neither content copied -// - returns nil if the supplied property path does not exist -// - returns a pointer to the matching item in the JSON object -// - this will handle any kind of objects, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first initial '{' char -function JsonObjectByPath(JsonObject,PropPath: PUTF8Char): PUTF8Char; - -/// return all matching properties of a JSON object -// - here the PropPath could be a comma-separated list of full paths, -// e.g. 'Prop1,Prop2' or 'Obj1.Obj2.Prop1,Obj1.Prop2' -// - returns '' if no property did match -// - returns a JSON object of all matching properties -// - this will handle any kind of objects, including those with nested -// JSON objects or arrays -// - incoming P^ should point to the first initial '{' char -function JsonObjectsByPath(JsonObject,PropPath: PUTF8Char): RawUTF8; - -/// convert one JSON object into two JSON arrays of keys and values -// - i.e. makes the following transformation: -// $ {key1:value1,key2,value2...} -> [key1,key2...] + [value1,value2...] -// - this function won't allocate any memory during its process, nor -// modify the JSON input buffer -// - is the reverse of the TTextWriter.AddJSONArraysAsJSONObject() method -function JSONObjectAsJSONArrays(JSON: PUTF8Char; out keys,values: RawUTF8): boolean; - -/// remove comments and trailing commas from a text buffer before passing it to JSON parser -// - handle two types of comments: starting from // till end of line -// or /* ..... */ blocks anywhere in the text content -// - trailing commas is replaced by ' ', so resulting JSON is valid for parsers -// what not allows trailing commas (browsers for example) -// - may be used to prepare configuration files before loading; -// for example we store server configuration in file config.json and -// put some comments in this file then code for loading is: -// !var cfg: RawUTF8; -// ! cfg := StringFromFile(ExtractFilePath(paramstr(0))+'Config.json'); -// ! RemoveCommentsFromJSON(@cfg[1]); -// ! pLastChar := JSONToObject(sc,pointer(cfg),configValid); -procedure RemoveCommentsFromJSON(P: PUTF8Char); - -const - /// standard header for an UTF-8 encoded XML file - XMLUTF8_HEADER = ''#13#10; - - /// standard namespace for a generic XML File - XMLUTF8_NAMESPACE = ''; - -/// convert a JSON array or document into a simple XML content -// - just a wrapper around TTextWriter.AddJSONToXML, with an optional -// header before the XML converted data (e.g. XMLUTF8_HEADER), and an optional -// name space content node which will nest the generated XML data (e.g. -// '') - the -// corresponding ending token will be appended after (e.g. '') -// - WARNING: the JSON buffer is decoded in-place, so P^ WILL BE modified -procedure JSONBufferToXML(P: PUTF8Char; const Header,NameSpace: RawUTF8; out result: RawUTF8); - -/// convert a JSON array or document into a simple XML content -// - just a wrapper around TTextWriter.AddJSONToXML, making a private copy -// of the supplied JSON buffer using TSynTempBuffer (so that JSON content -// would stay untouched) -// - the optional header is added at the beginning of the resulting string -// - an optional name space content node could be added around the generated XML, -// e.g. '' -function JSONToXML(const JSON: RawUTF8; const Header: RawUTF8=XMLUTF8_HEADER; - const NameSpace: RawUTF8=''): RawUTF8; - -/// formats and indents a JSON array or document to the specified layout -// - just a wrapper around TTextWriter.AddJSONReformat() method -// - WARNING: the JSON buffer is decoded in-place, so P^ WILL BE modified -procedure JSONBufferReformat(P: PUTF8Char; out result: RawUTF8; - Format: TTextWriterJSONFormat=jsonHumanReadable); - -/// formats and indents a JSON array or document to the specified layout -// - just a wrapper around TTextWriter.AddJSONReformat, making a private -// of the supplied JSON buffer (so that JSON content would stay untouched) -function JSONReformat(const JSON: RawUTF8; - Format: TTextWriterJSONFormat=jsonHumanReadable): RawUTF8; - -/// formats and indents a JSON array or document as a file -// - just a wrapper around TTextWriter.AddJSONReformat() method -// - WARNING: the JSON buffer is decoded in-place, so P^ WILL BE modified -function JSONBufferReformatToFile(P: PUTF8Char; const Dest: TFileName; - Format: TTextWriterJSONFormat=jsonHumanReadable): boolean; - -/// formats and indents a JSON array or document as a file -// - just a wrapper around TTextWriter.AddJSONReformat, making a private -// of the supplied JSON buffer (so that JSON content would stay untouched) -function JSONReformatToFile(const JSON: RawUTF8; const Dest: TFileName; - Format: TTextWriterJSONFormat=jsonHumanReadable): boolean; - - -const - /// map a PtrInt type to the TJSONCustomParserRTTIType set - ptPtrInt = {$ifdef CPU64}ptInt64{$else}ptInteger{$endif}; - /// map a PtrUInt type to the TJSONCustomParserRTTIType set - ptPtrUInt = {$ifdef CPU64}ptQWord{$else}ptCardinal{$endif}; - /// which TJSONCustomParserRTTIType types are not simple types - // - ptTimeLog is complex, since could be also TCreateTime or TModTime - PT_COMPLEXTYPES = [ptArray, ptRecord, ptCustom, ptTimeLog]; - /// could be used to compute the index in a pointer list from its position - POINTERSHR = {$ifdef CPU64}3{$else}2{$endif}; - /// could be used to compute the bitmask of a pointer integer - POINTERAND = {$ifdef CPU64}7{$else}3{$endif}; - /// could be used to check all bits on a pointer - POINTERBITS = {$ifdef CPU64}64{$else}32{$endif}; - - -{ ************ some other common types and conversion routines ************** } - -type - /// timestamp stored as second-based Unix Time - // - i.e. the number of seconds since 1970-01-01 00:00:00 UTC - // - is stored as 64-bit value, so that it won't be affected by the - // "Year 2038" overflow issue - // - see TUnixMSTime for a millisecond resolution Unix Timestamp - // - use UnixTimeToDateTime/DateTimeToUnixTime functions to convert it to/from - // a regular TDateTime - // - use UnixTimeUTC to return the current timestamp, using fast OS API call - // - also one of the encodings supported by SQLite3 date/time functions - TUnixTime = type Int64; - - /// timestamp stored as millisecond-based Unix Time - // - i.e. the number of milliseconds since 1970-01-01 00:00:00 UTC - // - see TUnixTime for a second resolution Unix Timestamp - // - use UnixMSTimeToDateTime/DateTimeToUnixMSTime functions to convert it - // to/from a regular TDateTime - // - also one of the JavaScript date encodings - TUnixMSTime = type Int64; - - /// pointer to a timestamp stored as second-based Unix Time - PUnixTime = ^TUnixTime; - /// pointer to a timestamp stored as millisecond-based Unix Time - PUnixMSTime = ^TUnixMSTime; - /// dynamic array of timestamps stored as second-based Unix Time - TUnixTimeDynArray = array of TUnixTime; - /// dynamic array of timestamps stored as millisecond-based Unix Time - TUnixMSTimeDynArray = array of TUnixMSTime; - -type - /// calling context of TSynLogExceptionToStr callbacks - TSynLogExceptionContext = record - /// the raised exception class - EClass: ExceptClass; - /// the Delphi Exception instance - // - may be nil for external/OS exceptions - EInstance: Exception; - /// the OS-level exception code - // - could be $0EEDFAE0 of $0EEDFADE for Delphi-generated exceptions - ECode: DWord; - /// the address where the exception occured - EAddr: PtrUInt; - /// the optional stack trace - EStack: PPtrUInt; - /// = FPC's RaiseProc() FrameCount if EStack is Frame: PCodePointer - EStackCount: integer; - /// the timestamp of this exception, as number of seconds since UNIX Epoch - // - UnixTimeUTC is faster than NowUTC or GetSystemTime - // - use UnixTimeToDateTime() to convert it into a regular TDateTime - ETimestamp: TUnixTime; - /// the logging level corresponding to this exception - // - may be either sllException or sllExceptionOS - ELevel: TSynLogInfo; - end; - - /// global hook callback to customize exceptions logged by TSynLog - // - should return TRUE if all needed information has been logged by the - // event handler - // - should return FALSE if Context.EAddr and Stack trace is to be appended - TSynLogExceptionToStr = function(WR: TTextWriter; const Context: TSynLogExceptionContext): boolean; - - {$M+} - /// generic parent class of all custom Exception types of this unit - // - all our classes inheriting from ESynException are serializable, - // so you could use ObjectToJSONDebug(anyESynException) to retrieve some - // extended information - ESynException = class(Exception) - protected - fRaisedAt: pointer; - public - /// constructor which will use FormatUTF8() instead of Format() - // - expect % as delimiter, so is less error prone than %s %d %g - // - will handle vtPointer/vtClass/vtObject/vtVariant kind of arguments, - // appending class name for any class or object, the hexa value for a - // pointer, or the JSON representation of any supplied TDocVariant - constructor CreateUTF8(const Format: RawUTF8; const Args: array of const); - /// constructor appending some FormatUTF8() content to the GetLastError - // - message will contain GetLastError value followed by the formatted text - // - expect % as delimiter, so is less error prone than %s %d %g - // - will handle vtPointer/vtClass/vtObject/vtVariant kind of arguments, - // appending class name for any class or object, the hexa value for a - // pointer, or the JSON representation of any supplied TDocVariant - constructor CreateLastOSError(const Format: RawUTF8; const Args: array of const; - const Trailer: RawUtf8 = 'OSError'); - {$ifndef NOEXCEPTIONINTERCEPT} - /// can be used to customize how the exception is logged - // - this default implementation will call the DefaultSynLogExceptionToStr() - // function or the TSynLogExceptionToStrCustom global callback, if defined - // - override this method to provide a custom logging content - // - should return TRUE if Context.EAddr and Stack trace is not to be - // written (i.e. as for any TSynLogExceptionToStr callback) - function CustomLog(WR: TTextWriter; const Context: TSynLogExceptionContext): boolean; virtual; - {$endif} - /// the code location when this exception was triggered - // - populated by SynLog unit, during interception - so may be nil - // - you can use TSynMapFile.FindLocation(ESynException) class function to - // guess the corresponding source code line - // - will be serialized as "Address": hexadecimal and source code location - // (using TSynMapFile .map/.mab information) in TJSONSerializer.WriteObject - // when woStorePointer option is defined - e.g. with ObjectToJSONDebug() - property RaisedAt: pointer read fRaisedAt write fRaisedAt; - published - property Message; - end; - {$M-} - ESynExceptionClass = class of ESynException; - - /// exception class associated to TDocVariant JSON/BSON document - EDocVariant = class(ESynException); - - /// exception raised during TFastReader decoding - EFastReader = class(ESynException); - -var - /// allow to customize the ESynException logging message - TSynLogExceptionToStrCustom: TSynLogExceptionToStr = nil; - - {$ifndef NOEXCEPTIONINTERCEPT} - /// default exception logging callback - will be set by the SynLog unit - // - will add the default Exception details, including any Exception.Message - // - if the exception inherits from ESynException - // - returns TRUE: caller will then append ' at EAddr' and the stack trace - DefaultSynLogExceptionToStr: TSynLogExceptionToStr = nil; - {$endif} - - -/// convert a string into its INTEGER Curr64 (value*10000) representation -// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ -// - fast conversion, using only integer operations -// - if NoDecimal is defined, will be set to TRUE if there is no decimal, AND -// the returned value will be an Int64 (not a PInt64(@Curr)^) -function StrToCurr64(P: PUTF8Char; NoDecimal: PBoolean=nil): Int64; - -/// convert a string into its currency representation -// - will call StrToCurr64() -function StrToCurrency(P: PUTF8Char): currency; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a currency value into a string -// - fast conversion, using only integer operations -// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) -function CurrencyToStr(Value: currency): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an INTEGER Curr64 (value*10000) into a string -// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ -// - fast conversion, using only integer operations -// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) -function Curr64ToStr(const Value: Int64): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an INTEGER Curr64 (value*10000) into a string -// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ -// - fast conversion, using only integer operations -// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) -procedure Curr64ToStr(const Value: Int64; var result: RawUTF8); overload; - -/// convert an INTEGER Curr64 (value*10000) into a string -// - this type is compatible with Delphi currency memory map with PInt64(@Curr)^ -// - fast conversion, using only integer operations -// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals) -// - return the number of chars written to Dest^ -function Curr64ToPChar(const Value: Int64; Dest: PUTF8Char): PtrInt; - -/// internal fast INTEGER Curr64 (value*10000) value to text conversion -// - expect the last available temporary char position in P -// - return the last written char position (write in reverse order in P^) -// - will return 0 for Value=0, or a string representation with always 4 decimals -// (e.g. 1->'0.0001' 500->'0.0500' 25000->'2.5000' 30000->'3.0000') -// - is called by Curr64ToPChar() and Curr64ToStr() functions -function StrCurr64(P: PAnsiChar; const Value: Int64): PAnsiChar; - -/// truncate a Currency value to only 2 digits -// - implementation will use fast Int64 math to avoid any precision loss due to -// temporary floating-point conversion -function TruncTo2Digits(Value: Currency): Currency; - -/// truncate a Currency value, stored as Int64, to only 2 digits -// - implementation will use fast Int64 math to avoid any precision loss due to -// temporary floating-point conversion -procedure TruncTo2DigitsCurr64(var Value: Int64); - {$ifdef HASINLINE}inline;{$endif} - -/// truncate a Currency value, stored as Int64, to only 2 digits -// - implementation will use fast Int64 math to avoid any precision loss due to -// temporary floating-point conversion -function TruncTo2Digits64(Value: Int64): Int64; - {$ifdef HASINLINE}inline;{$endif} - -/// simple, no banker rounding of a Currency value to only 2 digits -// - #.##51 will round to #.##+0.01 and #.##50 will be truncated to #.## -// - implementation will use fast Int64 math to avoid any precision loss due to -// temporary floating-point conversion -function SimpleRoundTo2Digits(Value: Currency): Currency; - -/// simple, no banker rounding of a Currency value, stored as Int64, to only 2 digits -// - #.##51 will round to #.##+0.01 and #.##50 will be truncated to #.## -// - implementation will use fast Int64 math to avoid any precision loss due to -// temporary floating-point conversion -procedure SimpleRoundTo2DigitsCurr64(var Value: Int64); - -var - /// a conversion table from hexa chars into binary data - // - returns 255 for any character out of 0..9,A..Z,a..z range - // - used e.g. by HexToBin() function - // - is defined globally, since may be used from an inlined function - ConvertHexToBin: TNormTableByte; - - /// naive but efficient cache to avoid string memory allocation for - // 0..999 small numbers by Int32ToUTF8/UInt32ToUTF8 - // - use around 16KB of heap (since each item consumes 16 bytes), but increase - // overall performance and reduce memory allocation (and fragmentation), - // especially during multi-threaded execution - // - noticeable when strings are used as array indexes (e.g. in SynMongoDB BSON) - // - is defined globally, since may be used from an inlined function - SmallUInt32UTF8: array[0..999] of RawUTF8; - -/// fast conversion from hexa chars into binary data -// - BinBytes contain the bytes count to be converted: Hex^ must contain -// at least BinBytes*2 chars to be converted, and Bin^ enough space -// - if Bin=nil, no output data is written, but the Hex^ format is checked -// - return false if any invalid (non hexa) char is found in Hex^ -// - using this function with Bin^ as an integer value will decode in big-endian -// order (most-signignifican byte first) -function HexToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer): boolean; overload; - -/// fast conversion with no validity check from hexa chars into binary data -procedure HexToBinFast(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer); - -/// conversion from octal C-like escape into binary data -// - \xxx is converted into a single xxx byte from octal, and \\ into \ -// - will stop the conversion when Oct^=#0 or when invalid \xxx is reached -// - returns the number of bytes written to Bin^ -function OctToBin(Oct: PAnsiChar; Bin: PByte): PtrInt; overload; - -/// conversion from octal C-like escape into binary data -// - \xxx is converted into a single xxx byte from octal, and \\ into \ -function OctToBin(const Oct: RawUTF8): RawByteString; overload; - -/// fast conversion from one hexa char pair into a 8 bit AnsiChar -// - return false if any invalid (non hexa) char is found in Hex^ -// - similar to HexToBin(Hex,nil,1) -function HexToCharValid(Hex: PAnsiChar): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// fast check if the supplied Hex buffer is an hexadecimal representation -// of a binary buffer of a given number of bytes -function IsHex(const Hex: RawByteString; BinBytes: integer): boolean; - -/// fast conversion from one hexa char pair into a 8 bit AnsiChar -// - return false if any invalid (non hexa) char is found in Hex^ -// - similar to HexToBin(Hex,Bin,1) but with Bin<>nil -// - use HexToCharValid if you want to check a hexadecimal char content -function HexToChar(Hex: PAnsiChar; Bin: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from two hexa bytes into a 16 bit UTF-16 WideChar -// - similar to HexToBin(Hex,@wordvar,2) + bswap(wordvar) -function HexToWideChar(Hex: PAnsiChar): cardinal; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from binary data into hexa chars -// - BinBytes contain the bytes count to be converted: Hex^ must contain -// enough space for at least BinBytes*2 chars -// - using this function with BinBytes^ as an integer value will encode it -// in low-endian order (less-signignifican byte first): don't use it for display -procedure BinToHex(Bin, Hex: PAnsiChar; BinBytes: integer); overload; - -/// fast conversion from hexa chars into binary data -function HexToBin(const Hex: RawUTF8): RawByteString; overload; - -/// fast conversion from binary data into hexa chars -function BinToHex(const Bin: RawByteString): RawUTF8; overload; - -/// fast conversion from binary data into hexa chars -function BinToHex(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; - -/// fast conversion from binary data into hexa chars, ready to be displayed -// - BinBytes contain the bytes count to be converted: Hex^ must contain -// enough space for at least BinBytes*2 chars -// - using this function with Bin^ as an integer value will encode it -// in big-endian order (most-signignifican byte first): use it for display -procedure BinToHexDisplay(Bin, Hex: PAnsiChar; BinBytes: integer); overload; - -/// fast conversion from binary data into hexa chars, ready to be displayed -function BinToHexDisplay(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; - -/// fast conversion from binary data into lowercase hexa chars -// - BinBytes contain the bytes count to be converted: Hex^ must contain -// enough space for at least BinBytes*2 chars -// - using this function with BinBytes^ as an integer value will encode it -// in low-endian order (less-signignifican byte first): don't use it for display -procedure BinToHexLower(Bin, Hex: PAnsiChar; BinBytes: integer); overload; - -/// fast conversion from binary data into lowercase hexa chars -function BinToHexLower(const Bin: RawByteString): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from binary data into lowercase hexa chars -function BinToHexLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from binary data into lowercase hexa chars -procedure BinToHexLower(Bin: PAnsiChar; BinBytes: integer; var result: RawUTF8); overload; - -/// fast conversion from binary data into lowercase hexa chars -// - BinBytes contain the bytes count to be converted: Hex^ must contain -// enough space for at least BinBytes*2 chars -// - using this function with Bin^ as an integer value will encode it -// in big-endian order (most-signignifican byte first): use it for display -procedure BinToHexDisplayLower(Bin, Hex: PAnsiChar; BinBytes: PtrInt); overload; - -/// fast conversion from binary data into lowercase hexa chars -function BinToHexDisplayLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; - -/// fast conversion from up to 127 bytes of binary data into lowercase hexa chars -function BinToHexDisplayLowerShort(Bin: PAnsiChar; BinBytes: integer): shortstring; - -/// fast conversion from up to 64-bit of binary data into lowercase hexa chars -function BinToHexDisplayLowerShort16(Bin: Int64; BinBytes: integer): TShort16; - -/// fast conversion from binary data into hexa lowercase chars, ready to be -// used as a convenient TFileName prefix -function BinToHexDisplayFile(Bin: PAnsiChar; BinBytes: integer): TFileName; - -/// append one byte as hexadecimal char pairs, into a text buffer -function ByteToHex(P: PAnsiChar; Value: byte): PAnsiChar; - -/// fast conversion from binary data to escaped text -// - non printable characters will be written as $xx hexadecimal codes -// - will be #0 terminated, with '...' characters trailing on overflow -// - ensure the destination buffer contains at least max*3+3 bytes, which is -// always the case when using LogEscape() and its local TLogEscape variable -function EscapeBuffer(s,d: PAnsiChar; len,max: integer): PAnsiChar; - -const - /// maximum size, in bytes, of a TLogEscape / LogEscape() buffer - LOGESCAPELEN = 200; -type - /// buffer to be allocated on stack when using LogEscape() - TLogEscape = array[0..LOGESCAPELEN*3+5] of AnsiChar; - -/// fill TLogEscape stack buffer with the (hexadecimal) chars of the input binary -// - up to LOGESCAPELEN (i.e. 200) bytes will be escaped and appended to a -// Local temp: TLogEscape variable, using the EscapeBuffer() low-level function -// - you can then log the resulting escaped text by passing the returned -// PAnsiChar as % parameter to a TSynLog.Log() method -// - the "enabled" parameter can be assigned from a process option, avoiding to -// process the escape if verbose logs are disabled -// - used e.g. to implement logBinaryFrameContent option for WebSockets -function LogEscape(source: PAnsiChar; sourcelen: integer; var temp: TLogEscape; - enabled: boolean=true): PAnsiChar; - {$ifdef HASINLINE}inline;{$endif} - -/// returns a text buffer with the (hexadecimal) chars of the input binary -// - is much slower than LogEscape/EscapeToShort, but has no size limitation -function LogEscapeFull(source: PAnsiChar; sourcelen: integer): RawUTF8; overload; - -/// returns a text buffer with the (hexadecimal) chars of the input binary -// - is much slower than LogEscape/EscapeToShort, but has no size limitation -function LogEscapeFull(const source: RawByteString): RawUTF8; overload; - -/// fill a shortstring with the (hexadecimal) chars of the input text/binary -function EscapeToShort(source: PAnsiChar; sourcelen: integer): shortstring; overload; - -/// fill a shortstring with the (hexadecimal) chars of the input text/binary -function EscapeToShort(const source: RawByteString): shortstring; overload; - -/// fast conversion from a pointer data into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -function PointerToHex(aPointer: Pointer): RawUTF8; overload; - -/// fast conversion from a pointer data into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -procedure PointerToHex(aPointer: Pointer; var result: RawUTF8); overload; - -/// fast conversion from a pointer data into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - such result type would avoid a string allocation on heap -function PointerToHexShort(aPointer: Pointer): TShort16; overload; - -/// fast conversion from a Cardinal value into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - reverse function of HexDisplayToCardinal() -function CardinalToHex(aCardinal: Cardinal): RawUTF8; - -/// fast conversion from a Cardinal value into hexa chars, ready to be displayed -// - use internally BinToHexDisplayLower() -// - reverse function of HexDisplayToCardinal() -function CardinalToHexLower(aCardinal: Cardinal): RawUTF8; - -/// fast conversion from a Cardinal value into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - such result type would avoid a string allocation on heap -function CardinalToHexShort(aCardinal: Cardinal): TShort16; - -/// fast conversion from a Int64 value into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - reverse function of HexDisplayToInt64() -function Int64ToHex(aInt64: Int64): RawUTF8; overload; - -/// fast conversion from a Int64 value into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - reverse function of HexDisplayToInt64() -procedure Int64ToHex(aInt64: Int64; var result: RawUTF8); overload; - -/// fast conversion from a Int64 value into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - such result type would avoid a string allocation on heap -procedure Int64ToHexShort(aInt64: Int64; out result: TShort16); overload; - -/// fast conversion from a Int64 value into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - such result type would avoid a string allocation on heap -function Int64ToHexShort(aInt64: Int64): TShort16; overload; - -/// fast conversion from a Int64 value into hexa chars, ready to be displayed -// - use internally BinToHexDisplay() -// - reverse function of HexDisplayToInt64() -function Int64ToHexString(aInt64: Int64): string; - -/// fast conversion from hexa chars into a binary buffer -function HexDisplayToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: integer): boolean; - -/// fast conversion from hexa chars into a cardinal -// - reverse function of CardinalToHex() -// - returns false and set aValue=0 if Hex is not a valid hexadecimal 32-bit -// unsigned integer -// - returns true and set aValue with the decoded number, on success -function HexDisplayToCardinal(Hex: PAnsiChar; out aValue: cardinal): boolean; - {$ifndef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} - // inline gives an error under release conditions with FPC - -/// fast conversion from hexa chars into a cardinal -// - reverse function of Int64ToHex() -// - returns false and set aValue=0 if Hex is not a valid hexadecimal 64-bit -// signed integer -// - returns true and set aValue with the decoded number, on success -function HexDisplayToInt64(Hex: PAnsiChar; out aValue: Int64): boolean; overload; - {$ifndef FPC}{$ifdef HASINLINE}inline;{$endif}{$endif} - { inline gives an error under release conditions with FPC } - -/// fast conversion from hexa chars into a cardinal -// - reverse function of Int64ToHex() -// - returns 0 if the supplied text buffer is not a valid hexadecimal 64-bit -// signed integer -function HexDisplayToInt64(const Hex: RawByteString): Int64; overload; - {$ifdef HASINLINE}inline;{$endif} - - -/// fast conversion from binary data into Base64 encoded UTF-8 text -function BinToBase64(const s: RawByteString): RawUTF8; overload; - -/// fast conversion from binary data into Base64 encoded UTF-8 text -function BinToBase64(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; - -/// fast conversion from a small binary data into Base64 encoded UTF-8 text -function BinToBase64Short(const s: RawByteString): shortstring; overload; - -/// fast conversion from a small binary data into Base64 encoded UTF-8 text -function BinToBase64Short(Bin: PAnsiChar; BinBytes: integer): shortstring; overload; - -/// fast conversion from binary data into prefixed/suffixed Base64 encoded UTF-8 text -// - with optional JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) -function BinToBase64(const data, Prefix, Suffix: RawByteString; WithMagic: boolean): RawUTF8; overload; - -/// fast conversion from binary data into Base64 encoded UTF-8 text -// with JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) -function BinToBase64WithMagic(const data: RawByteString): RawUTF8; overload; - -/// fast conversion from binary data into Base64 encoded UTF-8 text -// with JSON_BASE64_MAGIC prefix (UTF-8 encoded \uFFF0 special code) -function BinToBase64WithMagic(Data: pointer; DataLen: integer): RawUTF8; overload; - -/// fast conversion from Base64 encoded text into binary data -// - is now just an alias to Base64ToBinSafe() overloaded function -// - returns '' if s was not a valid Base64-encoded input -function Base64ToBin(const s: RawByteString): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from Base64 encoded text into binary data -// - is now just an alias to Base64ToBinSafe() overloaded function -// - returns '' if sp/len buffer was not a valid Base64-encoded input -function Base64ToBin(sp: PAnsiChar; len: PtrInt): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from Base64 encoded text into binary data -// - is now just an alias to Base64ToBinSafe() overloaded function -// - returns false and data='' if sp/len buffer was invalid -function Base64ToBin(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from Base64 encoded text into binary data -// - returns TRUE on success, FALSE if sp/len buffer was invvalid -function Base64ToBin(sp: PAnsiChar; len: PtrInt; var Blob: TSynTempBuffer): boolean; overload; - -/// fast conversion from Base64 encoded text into binary data -// - returns TRUE on success, FALSE if base64 does not match binlen -// - nofullcheck is deprecated and not used any more, since nofullcheck=false -// is now processed with no performance cost -function Base64ToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt; - nofullcheck: boolean=true): boolean; overload; - -/// fast conversion from Base64 encoded text into binary data -// - returns TRUE on success, FALSE if base64 does not match binlen -// - nofullcheck is deprecated and not used any more, since nofullcheck=false -// is now processed with no performance cost -function Base64ToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt; - nofullcheck: boolean=true): boolean; overload; - -/// fast conversion from Base64 encoded text into binary data -// - will check supplied text is a valid Base64 encoded stream -function Base64ToBinSafe(const s: RawByteString): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from Base64 encoded text into binary data -// - will check supplied text is a valid Base64 encoded stream -function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from Base64 encoded text into binary data -// - will check supplied text is a valid Base64 encoded stream -function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; overload; - -/// just a wrapper around Base64ToBin() for in-place decode of JSON_BASE64_MAGIC -// '\uFFF0base64encodedbinary' content into binary -// - input ParamValue shall have been checked to match the expected pattern -procedure Base64MagicDecode(var ParamValue: RawUTF8); - -/// check and decode '\uFFF0base64encodedbinary' content into binary -// - this method will check the supplied value to match the expected -// JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE -function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: RawByteString): boolean; overload; - -/// check and decode '\uFFF0base64encodedbinary' content into binary -// - this method will check the supplied value to match the expected -// JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE -function Base64MagicCheckAndDecode(Value: PUTF8Char; ValueLen: Integer; - var Blob: RawByteString): boolean; overload; - -/// check and decode '\uFFF0base64encodedbinary' content into binary -// - this method will check the supplied value to match the expected -// JSON_BASE64_MAGIC pattern, decode and set Blob and return TRUE -function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: TSynTempBuffer): boolean; overload; - -/// check if the supplied text is a valid Base64 encoded stream -function IsBase64(const s: RawByteString): boolean; overload; - -/// check if the supplied text is a valid Base64 encoded stream -function IsBase64(sp: PAnsiChar; len: PtrInt): boolean; overload; - -/// retrieve the expected encoded length after Base64 process -function BinToBase64Length(len: PtrUInt): PtrUInt; - {$ifdef HASINLINE}inline;{$endif} - -/// retrieve the expected undecoded length of a Base64 encoded buffer -// - here len is the number of bytes in sp -function Base64ToBinLength(sp: PAnsiChar; len: PtrInt): PtrInt; - -/// retrieve the expected undecoded length of a Base64 encoded buffer -// - here len is the number of bytes in sp -// - will check supplied text is a valid Base64 encoded stream -function Base64ToBinLengthSafe(sp: PAnsiChar; len: PtrInt): PtrInt; - -/// direct low-level decoding of a Base64 encoded buffer -// - here len is the number of 4 chars chunks in sp input -// - deprecated low-level function: use Base64ToBin/Base64ToBinSafe instead -function Base64Decode(sp,rp: PAnsiChar; len: PtrInt): boolean; - -/// fast conversion from binary data into Base64-like URI-compatible encoded text -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -function BinToBase64uri(const s: RawByteString): RawUTF8; overload; - -/// fast conversion from a binary buffer into Base64-like URI-compatible encoded text -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -function BinToBase64uri(Bin: PAnsiChar; BinBytes: integer): RawUTF8; overload; - -/// fast conversion from a binary buffer into Base64-like URI-compatible encoded shortstring -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -// - returns '' if BinBytes void or too big for the resulting shortstring -function BinToBase64uriShort(Bin: PAnsiChar; BinBytes: integer): shortstring; - -/// conversion from any Base64 encoded value into URI-compatible encoded text -// - warning: will modify the supplied base64 string in-place -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -procedure Base64ToURI(var base64: RawUTF8); - -/// low-level conversion from a binary buffer into Base64-like URI-compatible encoded text -// - you should rather use the overloaded BinToBase64uri() functions -procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal); - -/// retrieve the expected encoded length after Base64-URI process -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -function BinToBase64uriLength(len: PtrUInt): PtrUInt; - {$ifdef HASINLINE}inline;{$endif} - -/// retrieve the expected undecoded length of a Base64-URI encoded buffer -// - here len is the number of bytes in sp -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -function Base64uriToBinLength(len: PtrInt): PtrInt; - -/// fast conversion from Base64-URI encoded text into binary data -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -function Base64uriToBin(sp: PAnsiChar; len: PtrInt): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from Base64-URI encoded text into binary data -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -procedure Base64uriToBin(sp: PAnsiChar; len: PtrInt; var result: RawByteString); overload; - -/// fast conversion from Base64-URI encoded text into binary data -// - caller should always execute temp.Done when finished with the data -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -function Base64uriToBin(sp: PAnsiChar; len: PtrInt; var temp: TSynTempBuffer): boolean; overload; - -/// fast conversion from Base64-URI encoded text into binary data -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -function Base64uriToBin(const s: RawByteString): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast conversion from Base64-URI encoded text into binary data -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -// - will check supplied text is a valid Base64-URI encoded stream -function Base64uriToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt): boolean; overload; - -/// fast conversion from Base64-URI encoded text into binary data -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -// - will check supplied text is a valid Base64-URI encoded stream -function Base64uriToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// direct low-level decoding of a Base64-URI encoded buffer -// - the buffer is expected to be at least Base64uriToBinLength() bytes long -// - returns true if the supplied sp[] buffer has been successfully decoded -// into rp[] - will break at any invalid character, so is always safe to use -// - in comparison to Base64 standard encoding, will trim any right-sided '=' -// unsignificant characters, and replace '+' or '/' by '_' or '-' -// - you should better not use this, but Base64uriToBin() overloaded functions -function Base64uriDecode(sp,rp: PAnsiChar; len: PtrInt): boolean; - - -/// generate some pascal source code holding some data binary as constant -// - can store sensitive information (e.g. certificates) within the executable -// - generates a source code snippet of the following format: -// ! const -// ! // Comment -// ! ConstName: array[0..2] of byte = ( -// ! $01,$02,$03); -procedure BinToSource(Dest: TTextWriter; const ConstName, Comment: RawUTF8; - Data: pointer; Len: integer; PerLine: integer=16); overload; - -/// generate some pascal source code holding some data binary as constant -// - can store sensitive information (e.g. certificates) within the executable -// - generates a source code snippet of the following format: -// ! const -// ! // Comment -// ! ConstName: array[0..2] of byte = ( -// ! $01,$02,$03); -function BinToSource(const ConstName, Comment: RawUTF8; Data: pointer; - Len: integer; PerLine: integer=16; const Suffix: RawUTF8=''): RawUTF8; overload; - - -/// revert the value as encoded by TTextWriter.AddInt18ToChars3() or Int18ToChars3() -// - no range check is performed: you should ensure that the incoming text -// follows the expected 3-chars layout -function Chars3ToInt18(P: pointer): cardinal; - {$ifdef HASINLINE}inline;{$endif} - -/// compute the value as encoded by TTextWriter.AddInt18ToChars3() method -function Int18ToChars3(Value: cardinal): RawUTF8; overload; - -/// compute the value as encoded by TTextWriter.AddInt18ToChars3() method -procedure Int18ToChars3(Value: cardinal; var result: RawUTF8); overload; - -/// add the 4 digits of integer Y to P^ as '0000'..'9999' -procedure YearToPChar(Y: PtrUInt; P: PUTF8Char); - {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} - -/// creates a 3 digits string from a 0..999 value as '000'..'999' -// - consider using UInt3DigitsToShort() to avoid temporary memory allocation, -// e.g. when used as FormatUTF8() parameter -function UInt3DigitsToUTF8(Value: Cardinal): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -/// creates a 4 digits string from a 0..9999 value as '0000'..'9999' -// - consider using UInt4DigitsToShort() to avoid temporary memory allocation, -// e.g. when used as FormatUTF8() parameter -function UInt4DigitsToUTF8(Value: Cardinal): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -type - /// used e.g. by UInt4DigitsToShort/UInt3DigitsToShort/UInt2DigitsToShort - // - such result type would avoid a string allocation on heap - TShort4 = string[4]; - -/// creates a 4 digits short string from a 0..9999 value -// - using TShort4 as returned string would avoid a string allocation on heap -// - could be used e.g. as parameter to FormatUTF8() -function UInt4DigitsToShort(Value: Cardinal): TShort4; - {$ifdef HASINLINE}inline;{$endif} - -/// creates a 3 digits short string from a 0..999 value -// - using TShort4 as returned string would avoid a string allocation on heap -// - could be used e.g. as parameter to FormatUTF8() -function UInt3DigitsToShort(Value: Cardinal): TShort4; - {$ifdef HASINLINE}inline;{$endif} - -/// creates a 2 digits short string from a 0..99 value -// - using TShort4 as returned string would avoid a string allocation on heap -// - could be used e.g. as parameter to FormatUTF8() -function UInt2DigitsToShort(Value: byte): TShort4; - {$ifdef HASINLINE}inline;{$endif} - -/// creates a 2 digits short string from a 0..99 value -// - won't test Value>99 as UInt2DigitsToShort() -function UInt2DigitsToShortFast(Value: byte): TShort4; - {$ifdef HASINLINE}inline;{$endif} - - -/// compute CRC16-CCITT checkum on the supplied buffer -// - i.e. 16-bit CRC-CCITT, with polynomial x^16 + x^12 + x^5 + 1 ($1021) -// and $ffff as initial value -// - this version is not optimized for speed, but for correctness -function crc16(Data: PAnsiChar; Len: integer): cardinal; - -// our custom efficient 32-bit hash/checksum function -// - a Fletcher-like checksum algorithm, not a hash function: has less colisions -// than Adler32 for short strings, but more than xxhash32 or crc32/crc32c -// - written in simple plain pascal, with no L1 CPU cache pollution, but we -// also provide optimized x86/x64 assembly versions, since the algorithm is used -// heavily e.g. for TDynArray binary serialization, TSQLRestStorageInMemory -// binary persistence, or CompressSynLZ/StreamSynLZ/FileSynLZ -// - some numbers on Linux x86_64: -// $ 2500 hash32 in 707us i.e. 3536067/s or 7.3 GB/s -// $ 2500 xxhash32 in 1.34ms i.e. 1861504/s or 3.8 GB/s -// $ 2500 crc32c in 943us i.e. 2651113/s or 5.5 GB/s (SSE4.2 disabled) -// $ 2500 crc32c in 387us i.e. 6459948/s or 13.4 GB/s (SSE4.2 enabled) -function Hash32(Data: PCardinalArray; Len: integer): cardinal; overload; - -// our custom efficient 32-bit hash/checksum function -// - a Fletcher-like checksum algorithm, not a hash function: has less colisions -// than Adler32 for short strings, but more than xxhash32 or crc32/crc32c -// - overloaded function using RawByteString for binary content hashing, -// whatever the codepage is -function Hash32(const Text: RawByteString): cardinal; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// standard Kernighan & Ritchie hash from "The C programming Language", 3rd edition -// - simple and efficient code, but too much collisions for THasher -// - kr32() is 898.8 MB/s - crc32cfast() 1.7 GB/s, crc32csse42() 4.3 GB/s -function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; - -/// simple FNV-1a hashing function -// - when run over our regression suite, is similar to crc32c() about collisions, -// and 4 times better than kr32(), but also slower than the others -// - fnv32() is 715.5 MB/s - kr32() 898.8 MB/s -// - this hash function should not be usefull, unless you need several hashing -// algorithms at once (e.g. if crc32c with diverse seeds is not enough) -function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; - -/// perform very fast xxHash hashing in 32-bit mode -// - will use optimized asm for x86/x64, or a pascal version on other CPUs -function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; - -type - TCrc32tab = array[0..7,byte] of cardinal; - PCrc32tab = ^TCrc32tab; - -var - /// tables used by crc32cfast() function - // - created with a polynom diverse from zlib's crc32() algorithm, but - // compatible with SSE 4.2 crc32 instruction - // - tables content is created from code in initialization section below - // - will also be used internally by SymmetricEncrypt, FillRandom and - // TSynUniqueIdentifierGenerator as 1KB master/reference key tables - crc32ctab: TCrc32tab; - -/// compute CRC32C checksum on the supplied buffer on processor-neutral code -// - result is compatible with SSE 4.2 based hardware accelerated instruction -// - will use fast x86/x64 asm or efficient pure pascal implementation on ARM -// - result is not compatible with zlib's crc32() - not the same polynom -// - crc32cfast() is 1.7 GB/s, crc32csse42() is 4.3 GB/s -// - you should use crc32c() function instead of crc32cfast() or crc32csse42() -function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; - -/// compute CRC32C checksum on the supplied buffer using inlined code -// - if the compiler supports inlining, will compute a slow but safe crc32c -// checksum of the binary buffer, without calling the main crc32c() function -// - may be used e.g. to identify patched executable at runtime, for a licensing -// protection system -function crc32cinlined(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; - {$ifdef HASINLINE}inline;{$endif} - -/// compute CRC64C checksum on the supplied buffer, cascading two crc32c -// - will use SSE 4.2 hardware accelerated instruction, if available -// - will combine two crc32c() calls into a single Int64 result -// - by design, such combined hashes cannot be cascaded -function crc64c(buf: PAnsiChar; len: cardinal): Int64; - -/// compute CRC63C checksum on the supplied buffer, cascading two crc32c -// - similar to crc64c, but with 63-bit, so no negative value: may be used -// safely e.g. as mORMot's TID source -// - will use SSE 4.2 hardware accelerated instruction, if available -// - will combine two crc32c() calls into a single Int64 result -// - by design, such combined hashes cannot be cascaded -function crc63c(buf: PAnsiChar; len: cardinal): Int64; - -type - /// binary access to an unsigned 32-bit value (4 bytes in memory) - TDWordRec = record - case integer of - 0: (V: DWord); - 1: (L,H: word); - 2: (B: array[0..3] of byte); - end; - /// points to the binary of an unsigned 32-bit value - PDWordRec = ^TDWordRec; - - /// binary access to an unsigned 64-bit value (8 bytes in memory) - TQWordRec = record - case integer of - 0: (V: Qword); - 1: (L,H: cardinal); - 2: (W: array[0..3] of word); - 3: (B: array[0..7] of byte); - end; - /// points to the binary of an unsigned 64-bit value - PQWordRec = ^TQWordRec; - - /// store a 128-bit hash value - // - e.g. a MD5 digest, or array[0..3] of cardinal (TBlock128) - // - consumes 16 bytes of memory - THash128 = array[0..15] of byte; - /// pointer to a 128-bit hash value - PHash128 = ^THash128; - /// store a 160-bit hash value - // - e.g. a SHA-1 digest - // - consumes 20 bytes of memory - THash160 = array[0..19] of byte; - /// pointer to a 160-bit hash value - PHash160 = ^THash160; - /// store a 192-bit hash value - // - consumes 24 bytes of memory - THash192 = array[0..23] of byte; - /// pointer to a 192-bit hash value - PHash192 = ^THash192; - /// store a 256-bit hash value - // - e.g. a SHA-256 digest, a TECCSignature result, or array[0..7] of cardinal - // - consumes 32 bytes of memory - THash256 = array[0..31] of byte; - /// pointer to a 256-bit hash value - PHash256 = ^THash256; - /// store a 384-bit hash value - // - e.g. a SHA-384 digest - // - consumes 48 bytes of memory - THash384 = array[0..47] of byte; - /// pointer to a 384-bit hash value - PHash384 = ^THash384; - /// store a 512-bit hash value - // - e.g. a SHA-512 digest, a TECCSignature result, or array[0..15] of cardinal - // - consumes 64 bytes of memory - THash512 = array[0..63] of byte; - /// pointer to a 512-bit hash value - PHash512 = ^THash512; - - /// store a 128-bit buffer - // - e.g. an AES block - // - consumes 16 bytes of memory - TBlock128 = array[0..3] of cardinal; - /// pointer to a 128-bit buffer - PBlock128 = ^TBlock128; - - /// map an infinite array of 128-bit hash values - // - each item consumes 16 bytes of memory - THash128Array = array[0..(maxInt div SizeOf(THash128))-1] of THash128; - /// pointer to an infinite array of 128-bit hash values - PHash128Array = ^THash128Array; - /// store several 128-bit hash values - // - e.g. MD5 digests - // - consumes 16 bytes of memory per item - THash128DynArray = array of THash128; - /// map a 128-bit hash as an array of lower bit size values - // - consumes 16 bytes of memory - THash128Rec = packed record - case integer of - 0: (Lo,Hi: Int64); - 1: (L,H: QWord); - 2: (i0,i1,i2,i3: integer); - 3: (c0,c1,c2,c3: cardinal); - 4: (c: TBlock128); - 5: (b: THash128); - 6: (w: array[0..7] of word); - 7: (l64,h64: Int64Rec); - end; - /// pointer to 128-bit hash map variable record - PHash128Rec = ^THash128Rec; - - /// map an infinite array of 256-bit hash values - // - each item consumes 32 bytes of memory - THash256Array = array[0..(maxInt div SizeOf(THash256))-1] of THash256; - /// pointer to an infinite array of 256-bit hash values - PHash256Array = ^THash256Array; - /// store several 256-bit hash values - // - e.g. SHA-256 digests, TECCSignature results, or array[0..7] of cardinal - // - consumes 32 bytes of memory per item - THash256DynArray = array of THash256; - /// map a 256-bit hash as an array of lower bit size values - // - consumes 32 bytes of memory - THash256Rec = packed record - case integer of - 0: (Lo,Hi: THash128); - 1: (d0,d1,d2,d3: Int64); - 2: (i0,i1,i2,i3,i4,i5,i6,i7: integer); - 3: (c0,c1: TBlock128); - 4: (b: THash256); - 5: (q: array[0..3] of QWord); - 6: (c: array[0..7] of cardinal); - 7: (w: array[0..15] of word); - 8: (l,h: THash128Rec); - end; - /// pointer to 256-bit hash map variable record - PHash256Rec = ^THash256Rec; - - /// map an infinite array of 512-bit hash values - // - each item consumes 64 bytes of memory - THash512Array = array[0..(maxInt div SizeOf(THash512))-1] of THash512; - /// pointer to an infinite array of 512-bit hash values - PHash512Array = ^THash512Array; - /// store several 512-bit hash values - // - e.g. SHA-512 digests, or array[0..15] of cardinal - // - consumes 64 bytes of memory per item - THash512DynArray = array of THash512; - /// map a 512-bit hash as an array of lower bit size values - // - consumes 64 bytes of memory - THash512Rec = packed record - case integer of - 0: (Lo,Hi: THash256); - 1: (h0,h1,h2,h3: THash128); - 2: (d0,d1,d2,d3,d4,d5,d6,d7: Int64); - 3: (i0,i1,i2,i3,i4,i5,i6,i7,i8,i9,i10,i11,i12,i13,i14,i15: integer); - 4: (c0,c1,c2,c3: TBlock128); - 5: (b: THash512); - 6: (b160: THash160); - 7: (b384: THash384); - 8: (w: array[0..31] of word); - 9: (c: array[0..15] of cardinal); - 10: (i: array[0..7] of Int64); - 11: (r: array[0..3] of THash128Rec); - 12: (l,h: THash256Rec); - end; - /// pointer to 512-bit hash map variable record - PHash512Rec = ^THash512Rec; - -/// compute a 128-bit checksum on the supplied buffer, cascading two crc32c -// - will use SSE 4.2 hardware accelerated instruction, if available -// - will combine two crc32c() calls into a single TAESBlock result -// - by design, such combined hashes cannot be cascaded -procedure crc128c(buf: PAnsiChar; len: cardinal; out crc: THash128); - -/// compute a proprietary 128-bit CRC of 128-bit binary buffers -// - to be used for regression tests only: crcblocks will use the fastest -// implementation available on the current CPU (e.g. with SSE 4.2 opcodes) -procedure crcblocksfast(crc128, data128: PBlock128; count: integer); - -/// compute a proprietary 128-bit CRC of 128-bit binary buffers -// - apply four crc32c() calls on the 128-bit input chunks, into a 128-bit crc -// - its output won't match crc128c() value, which works on 8-bit input -// - will use SSE 4.2 hardware accelerated instruction, if available -// - is used e.g. by SynEcc's TECDHEProtocol.ComputeMAC for macCrc128c -var crcblocks: procedure(crc128, data128: PBlock128; count: integer)=crcblocksfast; - -/// computation of our 128-bit CRC of a 128-bit binary buffer without SSE4.2 -// - to be used for regression tests only: crcblock will use the fastest -// implementation available on the current CPU (e.g. with SSE 4.2 opcodes) -procedure crcblockNoSSE42(crc128, data128: PBlock128); - -/// compute a proprietary 128-bit CRC of a 128-bit binary buffer -// - apply four crc32c() calls on the 128-bit input chunk, into a 128-bit crc -// - its output won't match crc128c() value, which works on 8-bit input -// - will use SSE 4.2 hardware accelerated instruction, if available -// - is used e.g. by SynCrypto's TAESCFBCRC to check for data integrity -var crcblock: procedure(crc128, data128: PBlock128) = crcblockNoSSE42; - -/// returns TRUE if all 16 bytes of this 128-bit buffer equal zero -// - e.g. a MD5 digest, or an AES block -function IsZero(const dig: THash128): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if all 16 bytes of both 128-bit buffers do match -// - e.g. a MD5 digest, or an AES block -// - this function is not sensitive to any timing attack, so is designed -// for cryptographic purpose - and it is also branchless therefore fast -function IsEqual(const A,B: THash128): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fill all 16 bytes of this 128-bit buffer with zero -// - may be used to cleanup stack-allocated content -// ! ... finally FillZero(digest); end; -procedure FillZero(out dig: THash128); overload; - -/// fast O(n) search of a 128-bit item in an array of such values -function Hash128Index(P: PHash128Rec; Count: integer; h: PHash128Rec): integer; - {$ifdef CPU64} inline; {$endif} - -/// convert a 32-bit integer (storing a IP4 address) into its full notation -// - returns e.g. '1.2.3.4' for any valid address, or '' if ip4=0 -function IP4Text(ip4: cardinal): shortstring; overload; - -/// convert a 128-bit buffer (storing an IP6 address) into its full notation -// - returns e.g. '2001:0db8:0a0b:12f0:0000:0000:0000:0001' -function IP6Text(ip6: PHash128): shortstring; overload; {$ifdef HASINLINE}inline;{$endif} - -/// convert a 128-bit buffer (storing an IP6 address) into its full notation -// - returns e.g. '2001:0db8:0a0b:12f0:0000:0000:0000:0001' -procedure IP6Text(ip6: PHash128; result: PShortString); overload; - -/// compute a 256-bit checksum on the supplied buffer using crc32c -// - will use SSE 4.2 hardware accelerated instruction, if available -// - will combine two crc32c() calls into a single THash256 result -// - by design, such combined hashes cannot be cascaded -procedure crc256c(buf: PAnsiChar; len: cardinal; out crc: THash256); - -/// returns TRUE if all 20 bytes of this 160-bit buffer equal zero -// - e.g. a SHA-1 digest -function IsZero(const dig: THash160): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if all 20 bytes of both 160-bit buffers do match -// - e.g. a SHA-1 digest -// - this function is not sensitive to any timing attack, so is designed -// for cryptographic purpose -function IsEqual(const A,B: THash160): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fill all 20 bytes of this 160-bit buffer with zero -// - may be used to cleanup stack-allocated content -// ! ... finally FillZero(digest); end; -procedure FillZero(out dig: THash160); overload; - -/// returns TRUE if all 32 bytes of this 256-bit buffer equal zero -// - e.g. a SHA-256 digest, or a TECCSignature result -function IsZero(const dig: THash256): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if all 32 bytes of both 256-bit buffers do match -// - e.g. a SHA-256 digest, or a TECCSignature result -// - this function is not sensitive to any timing attack, so is designed -// for cryptographic purpose -function IsEqual(const A,B: THash256): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fill all 32 bytes of this 256-bit buffer with zero -// - may be used to cleanup stack-allocated content -// ! ... finally FillZero(digest); end; -procedure FillZero(out dig: THash256); overload; - -/// fast O(n) search of a 256-bit item in an array of such values -function Hash256Index(P: PHash256Rec; Count: integer; h: PHash256Rec): integer; overload; - -/// returns TRUE if all 48 bytes of this 384-bit buffer equal zero -// - e.g. a SHA-384 digest -function IsZero(const dig: THash384): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if all 48 bytes of both 384-bit buffers do match -// - e.g. a SHA-384 digest -// - this function is not sensitive to any timing attack, so is designed -// for cryptographic purpose -function IsEqual(const A,B: THash384): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fill all 32 bytes of this 384-bit buffer with zero -// - may be used to cleanup stack-allocated content -// ! ... finally FillZero(digest); end; -procedure FillZero(out dig: THash384); overload; - -/// returns TRUE if all 64 bytes of this 512-bit buffer equal zero -// - e.g. a SHA-512 digest -function IsZero(const dig: THash512): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if all 64 bytes of both 512-bit buffers do match -// - e.g. two SHA-512 digests -// - this function is not sensitive to any timing attack, so is designed -// for cryptographic purpose -function IsEqual(const A,B: THash512): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fill all 64 bytes of this 512-bit buffer with zero -// - may be used to cleanup stack-allocated content -// ! ... finally FillZero(digest); end; -procedure FillZero(out dig: THash512); overload; - -/// compute a 512-bit checksum on the supplied buffer using crc32c -// - will use SSE 4.2 hardware accelerated instruction, if available -// - will combine two crc32c() calls into a single THash512 result -// - by design, such combined hashes cannot be cascaded -procedure crc512c(buf: PAnsiChar; len: cardinal; out crc: THash512); - -/// fill all bytes of this memory buffer with zeros, i.e. 'toto' -> #0#0#0#0 -// - will write the memory buffer directly, so if this string instance is shared -// (i.e. has refcount>1), all other variables will contains zeros -// - may be used to cleanup stack-allocated content -// ! ... finally FillZero(secret); end; -procedure FillZero(var secret: RawByteString); overload; - {$ifdef FPC}inline;{$endif} - -/// fill all bytes of this UTF-8 string with zeros, i.e. 'toto' -> #0#0#0#0 -// - will write the memory buffer directly, so if this string instance is shared -// (i.e. has refcount>1), all other variables will contains zeros -// - may be used to cleanup stack-allocated content -// ! ... finally FillZero(secret); end; -procedure FillZero(var secret: RawUTF8); overload; - {$ifdef FPC}inline;{$endif} - -/// fill all bytes of a memory buffer with zero -// - just redirect to FillCharFast(..,...,0) -procedure FillZero(var dest; count: PtrInt); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if all bytes of both buffers do match -// - this function is not sensitive to any timing attack, so is designed -// for cryptographic purposes - use CompareMem/CompareMemSmall/CompareMemFixed -// as faster alternatives for general-purpose code -function IsEqual(const A,B; count: PtrInt): boolean; overload; - -/// fast computation of two 64-bit unsigned integers into a 128-bit value -procedure mul64x64(const left, right: QWord; out product: THash128Rec); - {$ifndef CPUINTEL}inline;{$endif} - -type - /// the potential features, retrieved from an Intel CPU - // - see https://en.wikipedia.org/wiki/CPUID#EAX.3D1:_Processor_Info_and_Feature_Bits - // - is defined on all platforms, since an ARM desktop could browse Intel logs - TIntelCpuFeature = ( - { CPUID 1 in EDX } - cfFPU, cfVME, cfDE, cfPSE, cfTSC, cfMSR, cfPAE, cfMCE, - cfCX8, cfAPIC, cf_d10, cfSEP, cfMTRR, cfPGE, cfMCA, cfCMOV, - cfPAT, cfPSE36, cfPSN, cfCLFSH, cf_d20, cfDS, cfACPI, cfMMX, - cfFXSR, cfSSE, cfSSE2, cfSS, cfHTT, cfTM, cfIA64, cfPBE, - { CPUID 1 in ECX } - cfSSE3, cfCLMUL, cfDS64, cfMON, cfDSCPL, cfVMX, cfSMX, cfEST, - cfTM2, cfSSSE3, cfCID, cfSDBG, cfFMA, cfCX16, cfXTPR, cfPDCM, - cf_c16, cfPCID, cfDCA, cfSSE41, cfSSE42, cfX2A, cfMOVBE, cfPOPCNT, - cfTSC2, cfAESNI, cfXS, cfOSXS, cfAVX, cfF16C, cfRAND, cfHYP, - { extended features CPUID 7 in EBX, ECX, EDX } - cfFSGS, cfTSCADJ, cfSGX, cfBMI1, cfHLE, cfAVX2, cfFDPEO, cfSMEP, - cfBMI2, cfERMS, cfINVPCID, cfRTM, cfPQM, cf_b13, cfMPX, cfPQE, - cfAVX512F, cfAVX512DQ, cfRDSEED, cfADX, cfSMAP, cfAVX512IFMA, cfPCOMMIT, cfCLFLUSH, - cfCLWB, cfIPT, cfAVX512PF, cfAVX512ER, cfAVX512CD, cfSHA, cfAVX512BW, cfAVX512VL, - cfPREFW1, cfAVX512VBMI, cfUMIP, cfPKU, cfOSPKE, cf_c05, cfAVX512VBMI2, cfCETSS, - cfGFNI, cfVAES, cfVCLMUL, cfAVX512NNI, cfAVX512BITALG, cf_c13, cfAVX512VPC, cf_c15, - cfFLP, cf_c17, cf_c18, cf_c19, cf_c20, cf_c21, cfRDPID, cf_c23, - cf_c24, cfCLDEMOTE, cf_c26, cfMOVDIRI, cfMOVDIR64B, cfENQCMD, cfSGXLC, cfPKS, - cf_d0, cf_d1, cfAVX512NNIW, cfAVX512MAPS, cfFSRM, cf_d5, cf_d6, cf_d7, - cfAVX512VP2I, cfSRBDS, cfMDCLR, cf_d11, cf_d12, cfTSXFA, cfSER, cfHYBRID, - cfTSXLDTRK, cf_d17, cfPCFG, cfLBR, cfIBT, cf_d21, cfAMXBF16, cf_d23, - cfAMXTILE, cfAMXINT8, cfIBRSPB, cfSTIBP, cfL1DFL, cfARCAB, cfCORCAB, cfSSBD); - - /// all features, as retrieved from an Intel CPU - TIntelCpuFeatures = set of TIntelCpuFeature; - -/// convert Intel CPU features as plain CSV text -function ToText(const aIntelCPUFeatures: TIntelCpuFeatures; - const Sep: RawUTF8=','): RawUTF8; overload; - -{$ifdef CPUINTEL} -var - /// the available CPU features, as recognized at program startup - CpuFeatures: TIntelCpuFeatures; - -/// compute CRC32C checksum on the supplied buffer using SSE 4.2 -// - use Intel Streaming SIMD Extensions 4.2 hardware accelerated instruction -// - SSE 4.2 shall be available on the processor (i.e. cfSSE42 in CpuFeatures) -// - result is not compatible with zlib's crc32() - not the same polynom -// - crc32cfast() is 1.7 GB/s, crc32csse42() is 4.3 GB/s -// - you should use crc32c() function instead of crc32cfast() or crc32csse42() -function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; -{$endif CPUINTEL} - -/// naive symmetric encryption scheme using a 32-bit key -// - fast, but not very secure, since uses crc32ctab[] content as master cypher -// key: consider using SynCrypto proven AES-based algorithms instead -procedure SymmetricEncrypt(key: cardinal; var data: RawByteString); - -type - TCrc32cBy4 = function(crc, value: cardinal): cardinal; - -var - /// compute CRC32C checksum on the supplied buffer - // - result is not compatible with zlib's crc32() - Intel/SCSI CRC32C is not - // the same polynom - but will use the fastest mean available, e.g. SSE 4.2, - // to achieve up to 16GB/s with the optimized implementation from SynCrypto.pas - // - you should use this function instead of crc32cfast() or crc32csse42() - crc32c: THasher; - /// compute CRC32C checksum on one 32-bit unsigned integer - // - can be used instead of crc32c() for inlined process during data acquisition - // - doesn't make "crc := not crc" before and after the computation: caller has - // to start with "crc := cardinal(not 0)" and make "crc := not crc" at the end, - // to compute the very same hash value than regular crc32c() - // - this variable will use the fastest mean available, e.g. SSE 4.2 - crc32cBy4: TCrc32cBy4; - -/// compute the hexadecimal representation of the crc32 checkum of a given text -// - wrapper around CardinalToHex(crc32c(...)) -function crc32cUTF8ToHex(const str: RawUTF8): RawUTF8; - -var - /// the default hasher used by TDynArrayHashed - // - set to crc32csse42() if SSE4.2 instructions are available on this CPU, - // or fallback to xxHash32() which performs better than crc32cfast() - DefaultHasher: THasher; - - /// the hash function used by TRawUTF8Interning - // - set to crc32csse42() if SSE4.2 instructions are available on this CPU, - // or fallback to xxHash32() which performs better than crc32cfast() - InterningHasher: THasher; - -/// retrieve a particular bit status from a bit array -// - this function can't be inlined, whereas GetBitPtr() function can -function GetBit(const Bits; aIndex: PtrInt): boolean; - -/// set a particular bit into a bit array -// - this function can't be inlined, whereas SetBitPtr() function can -procedure SetBit(var Bits; aIndex: PtrInt); - -/// unset/clear a particular bit into a bit array -// - this function can't be inlined, whereas UnSetBitPtr() function can -procedure UnSetBit(var Bits; aIndex: PtrInt); - -/// retrieve a particular bit status from a bit array -// - GetBit() can't be inlined, whereas this pointer-oriented function can -function GetBitPtr(Bits: pointer; aIndex: PtrInt): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// set a particular bit into a bit array -// - SetBit() can't be inlined, whereas this pointer-oriented function can -procedure SetBitPtr(Bits: pointer; aIndex: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// unset/clear a particular bit into a bit array -// - UnSetBit() can't be inlined, whereas this pointer-oriented function can -procedure UnSetBitPtr(Bits: pointer; aIndex: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// compute the number of bits set in a bit array -// - Count is the bit count, not byte size -// - will use fast SSE4.2 popcnt instruction if available on the CPU -function GetBitsCount(const Bits; Count: PtrInt): PtrInt; - -/// pure pascal version of GetBitsCountPtrInt() -// - defined just for regression tests - call GetBitsCountPtrInt() instead -// - has optimized asm on x86_64 and i386 -function GetBitsCountPas(value: PtrInt): PtrInt; - -/// compute how many bits are set in a given pointer-sized integer -// - the PopCnt() intrinsic under FPC doesn't have any fallback on older CPUs, -// and default implementation is 5 times slower than our GetBitsCountPas() on x64 -// - this redirected function will use fast SSE4.2 popcnt opcode, if available -var GetBitsCountPtrInt: function(value: PtrInt): PtrInt = GetBitsCountPas; - -const - /// constant array used by GetAllBits() function (when inlined) - ALLBITS_CARDINAL: array[1..32] of Cardinal = ( - 1 shl 1-1, 1 shl 2-1, 1 shl 3-1, 1 shl 4-1, 1 shl 5-1, 1 shl 6-1, - 1 shl 7-1, 1 shl 8-1, 1 shl 9-1, 1 shl 10-1, 1 shl 11-1, 1 shl 12-1, - 1 shl 13-1, 1 shl 14-1, 1 shl 15-1, 1 shl 16-1, 1 shl 17-1, 1 shl 18-1, - 1 shl 19-1, 1 shl 20-1, 1 shl 21-1, 1 shl 22-1, 1 shl 23-1, 1 shl 24-1, - 1 shl 25-1, 1 shl 26-1, 1 shl 27-1, 1 shl 28-1, 1 shl 29-1, 1 shl 30-1, - $7fffffff, $ffffffff); - -/// returns TRUE if all BitCount bits are set in the input 32-bit cardinal -function GetAllBits(Bits, BitCount: cardinal): boolean; - {$ifdef HASINLINE}inline;{$endif} - -type - /// fast access to 8-bit integer bits - // - the compiler will generate bt/btr/bts opcodes - TBits8 = set of 0..7; - PBits8 = ^TBits8; - TBits8Array = array[0..maxInt-1] of TBits8; - /// fast access to 32-bit integer bits - // - the compiler will generate bt/btr/bts opcodes - TBits32 = set of 0..31; - PBits32 = ^TBits32; - /// fast access to 64-bit integer bits - // - the compiler will generate bt/btr/bts opcodes - // - as used by GetBit64/SetBit64/UnSetBit64 - TBits64 = set of 0..63; - PBits64 = ^TBits64; - -/// retrieve a particular bit status from a 64-bit integer bits (max aIndex is 63) -function GetBit64(const Bits: Int64; aIndex: PtrInt): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// set a particular bit into a 64-bit integer bits (max aIndex is 63) -procedure SetBit64(var Bits: Int64; aIndex: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// unset/clear a particular bit into a 64-bit integer bits (max aIndex is 63) -procedure UnSetBit64(var Bits: Int64; aIndex: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// logical OR of two memory buffers -// - will perform on all buffer bytes: -// ! Dest[i] := Dest[i] or Source[i]; -procedure OrMemory(Dest,Source: PByteArray; size: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// logical XOR of two memory buffers -// - will perform on all buffer bytes: -// ! Dest[i] := Dest[i] xor Source[i]; -procedure XorMemory(Dest,Source: PByteArray; size: PtrInt); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// logical XOR of two memory buffers into a third -// - will perform on all buffer bytes: -// ! Dest[i] := Source1[i] xor Source2[i]; -procedure XorMemory(Dest,Source1,Source2: PByteArray; size: PtrInt); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// logical AND of two memory buffers -// - will perform on all buffer bytes: -// ! Dest[i] := Dest[i] and Source[i]; -procedure AndMemory(Dest,Source: PByteArray; size: PtrInt); - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if all bytes equal zero -function IsZero(P: pointer; Length: integer): boolean; overload; - -/// returns TRUE if all of a few bytes equal zero -// - to be called instead of IsZero() e.g. for 1..8 bytes -function IsZeroSmall(P: pointer; Length: PtrInt): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if Value is nil or all supplied Values[] equal '' -function IsZero(const Values: TRawUTF8DynArray): boolean; overload; - -/// returns TRUE if Value is nil or all supplied Values[] equal 0 -function IsZero(const Values: TIntegerDynArray): boolean; overload; - -/// returns TRUE if Value is nil or all supplied Values[] equal 0 -function IsZero(const Values: TInt64DynArray): boolean; overload; - -/// fill all entries of a supplied array of RawUTF8 with '' -procedure FillZero(var Values: TRawUTF8DynArray); overload; - -/// fill all entries of a supplied array of 32-bit integers with 0 -procedure FillZero(var Values: TIntegerDynArray); overload; - -/// fill all entries of a supplied array of 64-bit integers with 0 -procedure FillZero(var Values: TInt64DynArray); overload; - - -/// name the current thread so that it would be easily identified in the IDE debugger -procedure SetCurrentThreadName(const Format: RawUTF8; const Args: array of const); - -/// name a thread so that it would be easily identified in the IDE debugger -// - you can force this function to do nothing by setting the NOSETTHREADNAME -// conditional, if you have issues with this feature when debugging your app -// - most meanling less characters (like 'TSQL') are trimmed to reduce the -// resulting length - which is convenient e.g. with POSIX truncation to 16 chars -procedure SetThreadName(ThreadID: TThreadID; const Format: RawUTF8; - const Args: array of const); - -/// could be used to override SetThreadNameInternal() -// - under Linux/FPC, calls pthread_setname_np API which truncates to 16 chars -procedure SetThreadNameDefault(ThreadID: TThreadID; const Name: RawUTF8); - -var - /// is overriden e.g. by mORMot.pas to log the thread name - SetThreadNameInternal: procedure(ThreadID: TThreadID; const Name: RawUTF8) = SetThreadNameDefault; - - - -/// low-level wrapper to add a callback to a dynamic list of events -// - by default, you can assign only one callback to an Event: but by storing -// it as a dynamic array of events, you can use this wrapper to add one callback -// to this list of events -// - if the event was already registered, do nothing (i.e. won't call it twice) -// - since this function uses an unsafe typeless EventList parameter, you should -// not use it in high-level code, but only as wrapper within dedicated methods -// - will add Event to EventList[] unless Event is already registered -// - is used e.g. by TTextWriter as such: -// ! ... -// ! fEchos: array of TOnTextWriterEcho; -// ! ... -// ! procedure EchoAdd(const aEcho: TOnTextWriterEcho); -// ! ... -// ! procedure TTextWriter.EchoAdd(const aEcho: TOnTextWriterEcho); -// ! begin -// ! MultiEventAdd(fEchos,TMethod(aEcho)); -// ! end; -// then callbacks are then executed as such: -// ! if fEchos<>nil then -// ! for i := 0 to length(fEchos)-1 do -// ! fEchos[i](self,fEchoBuf); -// - use MultiEventRemove() to un-register a callback from the list -function MultiEventAdd(var EventList; const Event: TMethod): boolean; - -/// low-level wrapper to remove a callback from a dynamic list of events -// - by default, you can assign only one callback to an Event: but by storing -// it as a dynamic array of events, you can use this wrapper to remove one -// callback already registered by MultiEventAdd() to this list of events -// - since this function uses an unsafe typeless EventList parameter, you should -// not use it in high-level code, but only as wrapper within dedicated methods -// - is used e.g. by TTextWriter as such: -// ! ... -// ! fEchos: array of TOnTextWriterEcho; -// ! ... -// ! procedure EchoRemove(const aEcho: TOnTextWriterEcho); -// ! ... -// ! procedure TTextWriter.EchoRemove(const aEcho: TOnTextWriterEcho); -// ! begin -// ! MultiEventRemove(fEchos,TMethod(aEcho)); -// ! end; -procedure MultiEventRemove(var EventList; const Event: TMethod); overload; - -/// low-level wrapper to remove a callback from a dynamic list of events -// - same as the same overloaded procedure, but accepting an EventList[] index -// to identify the Event to be suppressed -procedure MultiEventRemove(var EventList; Index: Integer); overload; - -/// low-level wrapper to check if a callback is in a dynamic list of events -// - by default, you can assign only one callback to an Event: but by storing -// it as a dynamic array of events, you can use this wrapper to check if -// a callback has already been registered to this list of events -// - used internally by MultiEventAdd() and MultiEventRemove() functions -function MultiEventFind(const EventList; const Event: TMethod): integer; - -/// low-level wrapper to add one or several callbacks from another list of events -// - all events of the ToBeAddedList would be added to DestList -// - the list is not checked for duplicates -procedure MultiEventMerge(var DestList; const ToBeAddedList); - -/// compare two TMethod instances -function EventEquals(const eventA,eventB): boolean; - - -{ ************ fast ISO-8601 types and conversion routines ***************** } - -type - /// a type alias, which will be serialized as ISO-8601 with milliseconds - // - i.e. 'YYYY-MM-DD hh:mm:ss.sss' or 'YYYYMMDD hhmmss.sss' format - TDateTimeMS = type TDateTime; - - /// a dynamic array of TDateTimeMS values - TDateTimeMSDynArray = array of TDateTimeMS; - PDateTimeMSDynArray = ^TDateTimeMSDynArray; - - {$A-} - /// a simple way to store a date as Year/Month/Day - // - with no needed computation as with TDate/TUnixTime values - // - consider using TSynSystemTime if you need to handle both Date and Time - // - match the first 4 fields of TSynSystemTime - so PSynDate(@aSynSystemTime)^ - // is safe to be used - // - DayOfWeek field is not handled by its methods by default, but could be - // filled on demand via ComputeDayOfWeek - making this record 64-bit long - // - some Delphi revisions have trouble with "object" as own method parameters - // (e.g. IsEqual) so we force to use "record" type if possible - {$ifdef USERECORDWITHMETHODS}TSynDate = record{$else} - TSynDate = object{$endif} - Year, Month, DayOfWeek, Day: word; - /// set all fields to 0 - procedure Clear; {$ifdef HASINLINE}inline;{$endif} - /// set internal date to 9999-12-31 - procedure SetMax; {$ifdef HASINLINE}inline;{$endif} - /// returns true if all fields are zero - function IsZero: boolean; {$ifdef HASINLINE}inline;{$endif} - /// try to parse a YYYY-MM-DD or YYYYMMDD ISO-8601 date from the supplied buffer - // - on success, move P^ just after the date, and return TRUE - function ParseFromText(var P: PUTF8Char): boolean; {$ifdef HASINLINE}inline;{$endif} - /// fill fields with the current UTC/local date, using a 8-16ms thread-safe cache - procedure FromNow(localtime: boolean=false); - /// fill fields with the supplied date - procedure FromDate(date: TDate); - /// returns true if all fields do match - ignoring DayOfWeek field value - function IsEqual({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean; - /// compare the stored value to a supplied value - // - returns <0 if the stored value is smaller than the supplied value, - // 0 if both are equals, and >0 if the stored value is bigger - // - DayOfWeek field value is not compared - function Compare({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): integer; - {$ifdef HASINLINE}inline;{$endif} - /// fill the DayOfWeek field from the stored Year/Month/Day - // - by default, most methods will just store 0 in the DayOfWeek field - // - sunday is DayOfWeek 1, saturday is 7 - procedure ComputeDayOfWeek; - /// convert the stored date into a Delphi TDate floating-point value - function ToDate: TDate; {$ifdef HASINLINE}inline;{$endif} - /// encode the stored date as ISO-8601 text - // - returns '' if the stored date is 0 (i.e. after Clear) - function ToText(Expanded: boolean=true): RawUTF8; - end; - /// store several dates as Year/Month/Day - TSynDateDynArray = array of TSynDate; - /// a pointer to a TSynDate instance - PSynDate = ^TSynDate; - - /// a cross-platform and cross-compiler TSystemTime 128-bit structure - // - FPC's TSystemTime in datih.inc does NOT match Windows TSystemTime fields! - // - also used to store a Date/Time in TSynTimeZone internal structures, or - // for fast conversion from TDateTime to its ready-to-display members - // - DayOfWeek field is not handled by most methods by default (left as 0), - // but could be filled on demand via ComputeDayOfWeek into its 1..7 value - // - some Delphi revisions have trouble with "object" as own method parameters - // (e.g. IsEqual) so we force to use "record" type if possible - {$ifdef USERECORDWITHMETHODS}TSynSystemTime = record{$else} - TSynSystemTime = object{$endif} - public - Year, Month, DayOfWeek, Day, - Hour, Minute, Second, MilliSecond: word; - /// set all fields to 0 - procedure Clear; {$ifdef HASINLINE}inline;{$endif} - /// returns true if all fields are zero - function IsZero: boolean; {$ifdef HASINLINE}inline;{$endif} - /// returns true if all fields do match - function IsEqual(const another{$ifndef DELPHI5OROLDER}: TSynSystemTime{$endif}): boolean; - /// returns true if date fields do match (ignoring DayOfWeek) - function IsDateEqual(const date{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean; - /// used by TSynTimeZone - function EncodeForTimeChange(const aYear: word): TDateTime; - /// fill fields with the current UTC time, using a 8-16ms thread-safe cache - procedure FromNowUTC; - /// fill fields with the current Local time, using a 8-16ms thread-safe cache - procedure FromNowLocal; - /// fill fields from the given value - but not DayOfWeek - procedure FromDateTime(const dt: TDateTime); - /// fill Year/Month/Day fields from the given value - but not DayOfWeek - // - faster than the RTL DecodeDate() function - procedure FromDate(const dt: TDateTime); - /// fill Hour/Minute/Second/Millisecond fields from the given number of milliseconds - // - faster than the RTL DecodeTime() function - procedure FromMS(ms: PtrUInt); - /// fill Hour/Minute/Second/Millisecond fields from the given number of seconds - // - faster than the RTL DecodeTime() function - procedure FromSec(s: PtrUInt); - /// fill Hour/Minute/Second/Millisecond fields from the given TDateTime value - // - faster than the RTL DecodeTime() function - procedure FromTime(const dt: TDateTime); - /// fill Year/Month/Day and Hour/Minute/Second fields from the given ISO-8601 text - // - returns true on success - function FromText(const iso: RawUTF8): boolean; - /// encode the stored date/time as ISO-8601 text with Milliseconds - function ToText(Expanded: boolean=true; FirstTimeChar: AnsiChar='T'; const TZD: RawUTF8=''): RawUTF8; - /// append the stored date and time, in a log-friendly format - // - e.g. append '20110325 19241502' - with no trailing space nor tab - // - as called by TTextWriter.AddCurrentLogTime() - procedure AddLogTime(WR: TTextWriter); - /// append the stored date and time, in apache-like format, to a TTextWriter - // - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space - procedure AddNCSAText(WR: TTextWriter); - /// append the stored date and time, in apache-like format, to a memory buffer - // - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space - // - returns the number of chars added to P, i.e. always 21 - function ToNCSAText(P: PUTF8Char): PtrInt; - /// convert the stored date and time to its text in HTTP-like format - // - i.e. "Tue, 15 Nov 1994 12:45:26 GMT" to be used as a value of - // "Date", "Expires" or "Last-Modified" HTTP header - // - handle UTC/GMT time zone by default - procedure ToHTTPDate(out text: RawUTF8; const tz: RawUTF8='GMT'); - /// convert the stored date and time into its Iso-8601 text, with no Milliseconds - procedure ToIsoDateTime(out text: RawUTF8; const FirstTimeChar: AnsiChar='T'); - /// convert the stored date into its Iso-8601 text with no time part - procedure ToIsoDate(out text: RawUTF8); - /// convert the stored time into its Iso-8601 text with no date part nor Milliseconds - procedure ToIsoTime(out text: RawUTF8; const FirstTimeChar: RawUTF8='T'); - /// convert the stored time into a TDateTime - function ToDateTime: TDateTime; - /// copy Year/Month/DayOfWeek/Day fields to a TSynDate - procedure ToSynDate(out date: TSynDate); {$ifdef HASINLINE}inline;{$endif} - /// fill the DayOfWeek field from the stored Year/Month/Day - // - by default, most methods will just store 0 in the DayOfWeek field - // - sunday is DayOfWeek 1, saturday is 7 - procedure ComputeDayOfWeek; {$ifdef HASINLINE}inline;{$endif} - /// add some 1..999 milliseconds to the stored time - // - not to be used for computation, but e.g. for fast AddLogTime generation - procedure IncrementMS(ms: integer); - end; - PSynSystemTime = ^TSynSystemTime; - {$A+} - - /// fast bit-encoded date and time value - // - faster than Iso-8601 text and TDateTime, e.g. can be used as published - // property field in mORMot's TSQLRecord (see also TModTime and TCreateTime) - // - use internally for computation an abstract "year" of 16 months of 32 days - // of 32 hours of 64 minutes of 64 seconds - same as Iso8601ToTimeLog() - // - use TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow functions, or - // type-cast any TTimeLog value with the TTimeLogBits memory structure for - // direct access to its bit-oriented content (or via PTimeLogBits pointer) - // - since TTimeLog type is bit-oriented, you can't just add or substract two - // TTimeLog values when doing date/time computation: use a TDateTime temporary - // conversion in such case: - // ! aTimestamp := TimeLogFromDateTime(IncDay(TimeLogToDateTime(aTimestamp))); - TTimeLog = type Int64; - - /// dynamic array of TTimeLog - // - used by TDynArray JSON serialization to handle textual serialization - TTimeLogDynArray = array of TTimeLog; - - /// pointer to a memory structure for direct access to a TTimeLog type value - PTimeLogBits = ^TTimeLogBits; - - /// internal memory structure for direct access to a TTimeLog type value - // - most of the time, you should not use this object, but higher level - // TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow/Iso8601ToTimeLog functions - // - since TTimeLogBits.Value is bit-oriented, you can't just add or substract - // two TTimeLog values when doing date/time computation: use a TDateTime - // temporary conversion in such case - // - TTimeLogBits.Value needs up to 40-bit precision, so features exact - // representation as JavaScript numbers (stored in a 52-bit mantissa) - TTimeLogBits = object - public - /// the bit-encoded value itself, which follows an abstract "year" of 16 - // months of 32 days of 32 hours of 64 minutes of 64 seconds - // - bits 0..5 = Seconds (0..59) - // - bits 6..11 = Minutes (0..59) - // - bits 12..16 = Hours (0..23) - // - bits 17..21 = Day-1 (0..31) - // - bits 22..25 = Month-1 (0..11) - // - bits 26..40 = Year (0..9999) - Value: Int64; - /// extract the date and time content in Value into individual values - procedure Expand(out Date: TSynSystemTime); - /// convert to Iso-8601 encoded text, truncated to date/time only if needed - function Text(Expanded: boolean; FirstTimeChar: AnsiChar = 'T'): RawUTF8; overload; - /// convert to Iso-8601 encoded text, truncated to date/time only if needed - function Text(Dest: PUTF8Char; Expanded: boolean; - FirstTimeChar: AnsiChar = 'T'): integer; overload; - /// convert to Iso-8601 encoded text with date and time part - // - never truncate to date/time nor return '' as Text() does - function FullText(Expanded: boolean; FirstTimeChar: AnsiChar = 'T'; - QuotedChar: AnsiChar = #0): RawUTF8; overload; - {$ifdef FPC}inline;{$endif} // URW1111 on Delphi 2010 and URW1136 on XE - /// convert to Iso-8601 encoded text with date and time part - // - never truncate to date/time or return '' as Text() does - function FullText(Dest: PUTF8Char; Expanded: boolean; - FirstTimeChar: AnsiChar = 'T'; QuotedChar: AnsiChar = #0): PUTF8Char; overload; - /// convert to ready-to-be displayed text - // - using i18nDateText global event, if set (e.g. by mORMoti18n.pas) - function i18nText: string; - /// convert to a Delphi Time - function ToTime: TDateTime; - /// convert to a Delphi Date - // - will return 0 if the stored value is not a valid date - function ToDate: TDateTime; - /// convert to a Delphi Date and Time - // - will return 0 if the stored value is not a valid date - function ToDateTime: TDateTime; - /// convert to a second-based c-encoded time (from Unix epoch 1/1/1970) - function ToUnixTime: TUnixTime; - /// convert to a millisecond-based c-encoded time (from Unix epoch 1/1/1970) - // - of course, milliseconds will be 0 due to TTimeLog second resolution - function ToUnixMSTime: TUnixMSTime; - /// fill Value from specified Date and Time - procedure From(Y,M,D, HH,MM,SS: cardinal); overload; - /// fill Value from specified TDateTime - procedure From(DateTime: TDateTime; DateOnly: Boolean=false); overload; - /// fill Value from specified File Date - procedure From(FileDate: integer); overload; - /// fill Value from Iso-8601 encoded text - procedure From(P: PUTF8Char; L: integer); overload; {$ifdef HASINLINE}inline;{$endif} - /// fill Value from Iso-8601 encoded text - procedure From(const S: RawUTF8); overload; - /// fill Value from specified Date/Time individual fields - procedure From(Time: PSynSystemTime); overload; - /// fill Value from second-based c-encoded time (from Unix epoch 1/1/1970) - procedure FromUnixTime(const UnixTime: TUnixTime); - /// fill Value from millisecond-based c-encoded time (from Unix epoch 1/1/1970) - // - of course, millisecond resolution will be lost during conversion - procedure FromUnixMSTime(const UnixMSTime: TUnixMSTime); - /// fill Value from current local system Date and Time - procedure FromNow; - /// fill Value from current UTC system Date and Time - // - FromNow uses local time: this function retrieves the system time - // expressed in Coordinated Universal Time (UTC) - procedure FromUTCTime; - /// get the year (e.g. 2015) of the TTimeLog value - function Year: Integer; {$ifdef HASINLINE}inline;{$endif} - /// get the month (1..12) of the TTimeLog value - function Month: Integer; {$ifdef HASINLINE}inline;{$endif} - /// get the day (1..31) of the TTimeLog value - function Day: Integer; {$ifdef HASINLINE}inline;{$endif} - /// get the hour (0..23) of the TTimeLog value - function Hour: integer; {$ifdef HASINLINE}inline;{$endif} - /// get the minute (0..59) of the TTimeLog value - function Minute: integer; {$ifdef HASINLINE}inline;{$endif} - /// get the second (0..59) of the TTimeLog value - function Second: integer; {$ifdef HASINLINE}inline;{$endif} - end; - -/// get TTimeLog value from current local system date and time -// - handle TTimeLog bit-encoded Int64 format -function TimeLogNow: TTimeLog; - {$ifdef HASINLINE}inline;{$endif} - -/// get TTimeLog value from current UTC system Date and Time -// - handle TTimeLog bit-encoded Int64 format -function TimeLogNowUTC: TTimeLog; - {$ifdef HASINLINE}inline;{$endif} - -/// get TTimeLog value from a file date and time -// - handle TTimeLog bit-encoded Int64 format -function TimeLogFromFile(const FileName: TFileName): TTimeLog; - -/// get TTimeLog value from a given Delphi date and time -// - handle TTimeLog bit-encoded Int64 format -// - just a wrapper around PTimeLogBits(@aTime)^.From() -// - we defined such a function since TTimeLogBits(aTimeLog).From() won't change -// the aTimeLog variable content -function TimeLogFromDateTime(const DateTime: TDateTime): TTimeLog; - {$ifdef HASINLINE}inline;{$endif} - -/// get TTimeLog value from a given Unix seconds since epoch timestamp -// - handle TTimeLog bit-encoded Int64 format -// - just a wrapper around PTimeLogBits(@aTime)^.FromUnixTime() -function TimeLogFromUnixTime(const UnixTime: TUnixTime): TTimeLog; - {$ifdef HASINLINE}inline;{$endif} - -/// Date/Time conversion from a TTimeLog value -// - handle TTimeLog bit-encoded Int64 format -// - just a wrapper around PTimeLogBits(@Timestamp)^.ToDateTime -// - we defined such a function since TTimeLogBits(aTimeLog).ToDateTime gives an -// internall compiler error on some Delphi IDE versions (e.g. Delphi 6) -function TimeLogToDateTime(const Timestamp: TTimeLog): TDateTime; - {$ifdef HASINLINE}inline;{$endif} - -/// Unix seconds since epoch timestamp conversion from a TTimeLog value -// - handle TTimeLog bit-encoded Int64 format -// - just a wrapper around PTimeLogBits(@Timestamp)^.ToUnixTime -function TimeLogToUnixTime(const Timestamp: TTimeLog): TUnixTime; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a Iso8601 encoded string into a TTimeLog value -// - handle TTimeLog bit-encoded Int64 format -// - use this function only for fast comparison between two Iso8601 date/time -// - conversion is faster than Iso8601ToDateTime: use only binary integer math -// - ContainsNoTime optional pointer can be set to a boolean, which will be -// set according to the layout in P (e.g. TRUE for '2012-05-26') -// - returns 0 in case of invalid input string -function Iso8601ToTimeLogPUTF8Char(P: PUTF8Char; L: integer; ContainsNoTime: PBoolean=nil): TTimeLog; - -/// convert a Iso8601 encoded string into a TTimeLog value -// - handle TTimeLog bit-encoded Int64 format -// - use this function only for fast comparison between two Iso8601 date/time -// - conversion is faster than Iso8601ToDateTime: use only binary integer math -function Iso8601ToTimeLog(const S: RawByteString): TTimeLog; - {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} - -/// test if P^ contains a valid ISO-8601 text encoded value -// - calls internally Iso8601ToTimeLogPUTF8Char() and returns true if contains -// at least a valid year (YYYY) -function IsIso8601(P: PUTF8Char; L: integer): boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// Date/Time conversion from ISO-8601 -// - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format -// - will also recognize '.sss' milliseconds suffix, if any -function Iso8601ToDateTime(const S: RawByteString): TDateTime; overload; - {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} {$endif} - -/// Date/Time conversion from ISO-8601 -// - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format -// - will also recognize '.sss' milliseconds suffix, if any -// - if L is left to default 0, it will be computed from StrLen(P) -function Iso8601ToDateTimePUTF8Char(P: PUTF8Char; L: integer=0): TDateTime; - {$ifdef HASINLINE}inline;{$endif} - -/// Date/Time conversion from ISO-8601 -// - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format, with potentially -// shorten versions has handled by the ISO-8601 standard (e.g. 'YYYY') -// - will also recognize '.sss' milliseconds suffix, if any -// - if L is left to default 0, it will be computed from StrLen(P) -procedure Iso8601ToDateTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); - -/// Date/Time conversion from strict ISO-8601 content -// - recognize 'YYYY-MM-DDThh:mm:ss[.sss]' or 'YYYY-MM-DD' or 'Thh:mm:ss[.sss]' -// patterns, as e.g. generated by TTextWriter.AddDateTime() or RecordSaveJSON() -// - will also recognize '.sss' milliseconds suffix, if any -function Iso8601CheckAndDecode(P: PUTF8Char; L: integer; var Value: TDateTime): boolean; - -/// Time conversion from ISO-8601 (with no Date part) -// - handle 'hhmmss' and 'hh:mm:ss' format -// - will also recognize '.sss' milliseconds suffix, if any -// - if L is left to default 0, it will be computed from StrLen(P) -function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer=0): TDateTime; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// Time conversion from ISO-8601 (with no Date part) -// - handle 'hhmmss' and 'hh:mm:ss' format -// - will also recognize '.sss' milliseconds suffix, if any -// - if L is left to default 0, it will be computed from StrLen(P) -procedure Iso8601ToTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); - -/// Time conversion from ISO-8601 (with no Date part) -// - recognize 'hhmmss' and 'hh:mm:ss' format into H,M,S variables -// - will also recognize '.sss' milliseconds suffix, if any, into MS -// - if L is left to default 0, it will be computed from StrLen(P) -function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer; var H,M,S,MS: cardinal): boolean; overload; - -/// Date conversion from ISO-8601 (with no Time part) -// - recognize 'YYYY-MM-DD' and 'YYYYMMDD' format into Y,M,D variables -// - if L is left to default 0, it will be computed from StrLen(P) -function Iso8601ToDatePUTF8Char(P: PUTF8Char; L: integer; var Y,M,D: cardinal): boolean; - -/// Interval date/time conversion from simple text -// - expected format does not match ISO-8601 Time intervals format, but Oracle -// interval litteral representation, i.e. '+/-D HH:MM:SS' -// - e.g. IntervalTextToDateTime('+0 06:03:20') will return 0.25231481481 and -// IntervalTextToDateTime('-20 06:03:20') -20.252314815 -// - as a consequence, negative intervals will be written as TDateTime values: -// !DateTimeToIso8601Text(IntervalTextToDateTime('+0 06:03:20'))='T06:03:20' -// !DateTimeToIso8601Text(IntervalTextToDateTime('+1 06:03:20'))='1899-12-31T06:03:20' -// !DateTimeToIso8601Text(IntervalTextToDateTime('-2 06:03:20'))='1899-12-28T06:03:20' -function IntervalTextToDateTime(Text: PUTF8Char): TDateTime; - {$ifdef HASINLINE}inline;{$endif} - -/// Interval date/time conversion from simple text -// - expected format does not match ISO-8601 Time intervals format, but Oracle -// interval litteral representation, i.e. '+/-D HH:MM:SS' -// - e.g. '+1 06:03:20' will return 1.25231481481 -procedure IntervalTextToDateTimeVar(Text: PUTF8Char; var result: TDateTime); - -/// basic Date/Time conversion into ISO-8601 -// - use 'YYYYMMDDThhmmss' format if not Expanded -// - use 'YYYY-MM-DDThh:mm:ss' format if Expanded -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -// - if QuotedChar is not default #0, will (double) quote the resulted text -// - you may rather use DateTimeToIso8601Text() to handle 0 or date-only values -function DateTimeToIso8601(D: TDateTime; Expanded: boolean; - FirstChar: AnsiChar='T'; WithMS: boolean=false; QuotedChar: AnsiChar=#0): RawUTF8; overload; - -/// basic Date/Time conversion into ISO-8601 -// - use 'YYYYMMDDThhmmss' format if not Expanded -// - use 'YYYY-MM-DDThh:mm:ss' format if Expanded -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -// - if QuotedChar is not default #0, will (double) quote the resulted text -// - you may rather use DateTimeToIso8601Text() to handle 0 or date-only values -// - returns the number of chars written to P^ buffer -function DateTimeToIso8601(P: PUTF8Char; D: TDateTime; Expanded: boolean; - FirstChar: AnsiChar='T'; WithMS: boolean=false; QuotedChar: AnsiChar=#0): integer; overload; - -/// basic Date conversion into ISO-8601 -// - use 'YYYYMMDD' format if not Expanded -// - use 'YYYY-MM-DD' format if Expanded -function DateToIso8601(Date: TDateTime; Expanded: boolean): RawUTF8; overload; - -/// basic Date conversion into ISO-8601 -// - use 'YYYYMMDD' format if not Expanded -// - use 'YYYY-MM-DD' format if Expanded -function DateToIso8601(Y,M,D: cardinal; Expanded: boolean): RawUTF8; overload; - -/// basic Date period conversion into ISO-8601 -// - will convert an elapsed number of days as ISO-8601 text -// - use 'YYYYMMDD' format if not Expanded -// - use 'YYYY-MM-DD' format if Expanded -function DaysToIso8601(Days: cardinal; Expanded: boolean): RawUTF8; - -/// basic Time conversion into ISO-8601 -// - use 'Thhmmss' format if not Expanded -// - use 'Thh:mm:ss' format if Expanded -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -function TimeToIso8601(Time: TDateTime; Expanded: boolean; FirstChar: AnsiChar='T'; - WithMS: boolean=false): RawUTF8; - -/// Write a Date to P^ Ansi buffer -// - if Expanded is false, 'YYYYMMDD' date format is used -// - if Expanded is true, 'YYYY-MM-DD' date format is used -function DateToIso8601PChar(P: PUTF8Char; Expanded: boolean; Y,M,D: PtrUInt): PUTF8Char; overload; - -/// convert a date into 'YYYY-MM-DD' date format -// - resulting text is compatible with all ISO-8601 functions -function DateToIso8601Text(Date: TDateTime): RawUTF8; - -/// Write a Date/Time to P^ Ansi buffer -function DateToIso8601PChar(Date: TDateTime; P: PUTF8Char; Expanded: boolean): PUTF8Char; overload; - -/// Write a TDateTime value, expanded as Iso-8601 encoded text into P^ Ansi buffer -// - if DT=0, returns '' -// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' -// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' -// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -function DateTimeToIso8601ExpandedPChar(const Value: TDateTime; Dest: PUTF8Char; - FirstChar: AnsiChar='T'; WithMS: boolean=false): PUTF8Char; - -/// write a TDateTime into strict ISO-8601 date and/or time text -// - if DT=0, returns '' -// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' -// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' -// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods -function DateTimeToIso8601Text(DT: TDateTime; FirstChar: AnsiChar='T'; - WithMS: boolean=false): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - -/// write a TDateTime into strict ISO-8601 date and/or time text -// - if DT=0, returns '' -// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' -// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' -// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods -procedure DateTimeToIso8601TextVar(DT: TDateTime; FirstChar: AnsiChar; var result: RawUTF8; - WithMS: boolean=false); - -/// write a TDateTime into strict ISO-8601 date and/or time text -// - if DT=0, returns '' -// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD' -// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss' -// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss' -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods -procedure DateTimeToIso8601StringVar(DT: TDateTime; FirstChar: AnsiChar; var result: string; - WithMS: boolean=false); - -/// Write a Time to P^ Ansi buffer -// - if Expanded is false, 'Thhmmss' time format is used -// - if Expanded is true, 'Thh:mm:ss' time format is used -// - you can custom the first char in from of the resulting text time -// - if WithMS is TRUE, will append MS as '.sss' for milliseconds resolution -function TimeToIso8601PChar(P: PUTF8Char; Expanded: boolean; H,M,S,MS: PtrUInt; - FirstChar: AnsiChar = 'T'; WithMS: boolean=false): PUTF8Char; overload; - -/// Write a Time to P^ Ansi buffer -// - if Expanded is false, 'Thhmmss' time format is used -// - if Expanded is true, 'Thh:mm:ss' time format is used -// - you can custom the first char in from of the resulting text time -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -function TimeToIso8601PChar(Time: TDateTime; P: PUTF8Char; Expanded: boolean; - FirstChar: AnsiChar = 'T'; WithMS: boolean=false): PUTF8Char; overload; - -var - /// custom TTimeLog date to ready to be displayed text function - // - you can override this pointer in order to display the text according - // to your expected i18n settings - // - this callback will therefore be set by the mORMoti18n.pas unit - // - used e.g. by TTimeLogBits.i18nText and by TSQLTable.ExpandAsString() - // methods, i.e. TSQLTableToGrid.DrawCell() - i18nDateText: function(const Iso: TTimeLog): string = nil; - /// custom date to ready to be displayed text function - // - you can override this pointer in order to display the text according - // to your expected i18n settings - // - this callback will therefore be set by the mORMoti18n.pas unit - // - used e.g. by TSQLTable.ExpandAsString() method, - // i.e. TSQLTableToGrid.DrawCell() - i18nDateTimeText: function(const DateTime: TDateTime): string = nil; - -/// wrapper calling global i18nDateTimeText() callback if set, -// or returning ISO-8601 standard layout on default -function DateTimeToi18n(const DateTime: TDateTime): string; - - -/// fast conversion of 2 digit characters into a 0..99 value -// - returns FALSE on success, TRUE if P^ is not correct -function Char2ToByte(P: PUTF8Char; out Value: Cardinal): Boolean; - -/// fast conversion of 3 digit characters into a 0..9999 value -// - returns FALSE on success, TRUE if P^ is not correct -function Char3ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; - -/// fast conversion of 4 digit characters into a 0..9999 value -// - returns FALSE on success, TRUE if P^ is not correct -function Char4ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; - -/// our own fast version of the corresponding low-level RTL function -function TryEncodeDate(Year, Month, Day: cardinal; out Date: TDateTime): Boolean; - -/// our own fast version of the corresponding low-level RTL function -function IsLeapYear(Year: cardinal): boolean; - {$ifdef HASINLINE} inline; {$endif} - -/// retrieve the current Date, in the ISO 8601 layout, but expanded and -// ready to be displayed -function NowToString(Expanded: boolean=true; FirstTimeChar: AnsiChar=' '): RawUTF8; - -/// retrieve the current UTC Date, in the ISO 8601 layout, but expanded and -// ready to be displayed -function NowUTCToString(Expanded: boolean=true; FirstTimeChar: AnsiChar=' '): RawUTF8; - -/// convert some date/time to the ISO 8601 text layout, including milliseconds -// - i.e. 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format -// - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') -// - see also TTextWriter.AddDateTimeMS method -function DateTimeMSToString(DateTime: TDateTime; Expanded: boolean=true; - FirstTimeChar: AnsiChar=' '; const TZD: RawUTF8='Z'): RawUTF8; overload; - -/// convert some date/time to the ISO 8601 text layout, including milliseconds -// - i.e. 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format -// - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') -// - see also TTextWriter.AddDateTimeMS method -function DateTimeMSToString(HH,MM,SS,MS,Y,M,D: cardinal; Expanded: boolean; - FirstTimeChar: AnsiChar=' '; const TZD: RawUTF8='Z'): RawUTF8; overload; - -/// convert some date/time to the "HTTP-date" format as defined by RFC 7231 -// - i.e. "Tue, 15 Nov 1994 12:45:26 GMT" to be used as a value of -// "Date", "Expires" or "Last-Modified" HTTP header -// - if you care about timezones Value must be converted to UTC first -// using TSynTimeZone.LocalToUtc, or tz should be properly set -function DateTimeToHTTPDate(dt: TDateTime; const tz: RawUTF8='GMT'): RawUTF8; overload; - -/// convert some TDateTime to a small text layout, perfect e.g. for naming a local file -// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting -// a date > 1999 (a current date would be fine) -function DateTimeToFileShort(const DateTime: TDateTime): TShort16; overload; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - -/// convert some TDateTime to a small text layout, perfect e.g. for naming a local file -// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting -// a date > 1999 (a current date would be fine) -procedure DateTimeToFileShort(const DateTime: TDateTime; out result: TShort16); overload; - -/// retrieve the current Time (whithout Date), in the ISO 8601 layout -// - useful for direct on screen logging e.g. -function TimeToString: RawUTF8; - -const - /// a contemporary, but elapsed, TUnixTime second-based value - // - corresponds to Thu, 08 Dec 2016 08:50:20 GMT - // - may be used to check for a valid just-generated Unix timestamp value - UNIXTIME_MINIMAL = 1481187020; - -/// convert a second-based c-encoded time as TDateTime -// - i.e. number of seconds elapsed since Unix epoch 1/1/1970 into TDateTime -function UnixTimeToDateTime(const UnixTime: TUnixTime): TDateTime; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a TDateTime into a second-based c-encoded time -// - i.e. TDateTime into number of seconds elapsed since Unix epoch 1/1/1970 -function DateTimeToUnixTime(const AValue: TDateTime): TUnixTime; - {$ifdef HASINLINE}inline;{$endif} - -/// returns the current UTC date/time as a second-based c-encoded time -// - i.e. current number of seconds elapsed since Unix epoch 1/1/1970 -// - faster than NowUTC or GetTickCount64, on Windows or Unix platforms -// (will use e.g. fast clock_gettime(CLOCK_REALTIME_COARSE) under Linux, -// or GetSystemTimeAsFileTime under Windows) -// - returns a 64-bit unsigned value, so is "Year2038bug" free -function UnixTimeUTC: TUnixTime; - {$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// convert some second-based c-encoded time (from Unix epoch 1/1/1970) to -// the ISO 8601 text layout -// - use 'YYYYMMDDThhmmss' format if not Expanded -// - use 'YYYY-MM-DDThh:mm:ss' format if Expanded -function UnixTimeToString(const UnixTime: TUnixTime; Expanded: boolean=true; - FirstTimeChar: AnsiChar='T'): RawUTF8; - -/// convert some second-based c-encoded time (from Unix epoch 1/1/1970) to -// a small text layout, perfect e.g. for naming a local file -// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting -// a date > 1999 (a current date would be fine) -procedure UnixTimeToFileShort(const UnixTime: TUnixTime; out result: TShort16); overload; - -/// convert some second-based c-encoded time (from Unix epoch 1/1/1970) to -// a small text layout, perfect e.g. for naming a local file -// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting -// a date > 1999 (a current date would be fine) -function UnixTimeToFileShort(const UnixTime: TUnixTime): TShort16; overload; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - -/// convert some second-based c-encoded time to the ISO 8601 text layout, either -// as time or date elapsed period -// - this function won't add the Unix epoch 1/1/1970 offset to the timestamp -// - returns 'Thh:mm:ss' or 'YYYY-MM-DD' format, depending on the supplied value -function UnixTimePeriodToString(const UnixTime: TUnixTime; FirstTimeChar: AnsiChar='T'): RawUTF8; - -/// returns the current UTC date/time as a millisecond-based c-encoded time -// - i.e. current number of milliseconds elapsed since Unix epoch 1/1/1970 -// - faster and more accurate than NowUTC or GetTickCount64, on Windows or Unix -// - will use e.g. fast clock_gettime(CLOCK_REALTIME_COARSE) under Linux, -// or GetSystemTimeAsFileTime/GetSystemTimePreciseAsFileTime under Windows - the -// later being more accurate, but slightly slower than the former, so you may -// consider using UnixMSTimeUTCFast on Windows if its 10-16ms accuracy is enough -function UnixMSTimeUTC: TUnixMSTime; - {$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// returns the current UTC date/time as a millisecond-based c-encoded time -// - under Linux/POSIX, is the very same than UnixMSTimeUTC -// - under Windows 8+, will call GetSystemTimeAsFileTime instead of -// GetSystemTimePreciseAsFileTime, which has higher precision, but is slower -// - prefer it under Windows, if a dozen of ms resolution is enough for your task -function UnixMSTimeUTCFast: TUnixMSTime; - {$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif} - -/// convert a millisecond-based c-encoded time (from Unix epoch 1/1/1970) as TDateTime -function UnixMSTimeToDateTime(const UnixMSTime: TUnixMSTime): TDateTime; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a TDateTime into a millisecond-based c-encoded time (from Unix epoch 1/1/1970) -// - if AValue is 0, will return 0 (since is likely to be an error constant) -function DateTimeToUnixMSTime(const AValue: TDateTime): TUnixMSTime; - {$ifdef HASINLINE}inline;{$endif} - -/// convert some millisecond-based c-encoded time (from Unix epoch 1/1/1970) to -// the ISO 8601 text layout, including milliseconds -// - i.e. 'YYYY-MM-DDThh:mm:ss.sssZ' or 'YYYYMMDDThhmmss.sssZ' format -// - TZD is the ending time zone designator ('', 'Z' or '+hh:mm' or '-hh:mm') -function UnixMSTimeToString(const UnixMSTime: TUnixMSTime; Expanded: boolean=true; - FirstTimeChar: AnsiChar='T'; const TZD: RawUTF8=''): RawUTF8; - -/// convert some milllisecond-based c-encoded time (from Unix epoch 1/1/1970) to -// a small text layout, trimming to the second resolution, perfect e.g. for -// naming a local file -// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits, expecting -// a date > 1999 (a current date would be fine) -function UnixMSTimeToFileShort(const UnixMSTime: TUnixMSTime): TShort16; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - -/// convert some millisecond-based c-encoded time to the ISO 8601 text layout, -// as time or date elapsed period -// - this function won't add the Unix epoch 1/1/1970 offset to the timestamp -// - returns 'Thh:mm:ss' or 'YYYY-MM-DD' format, depending on the supplied value -function UnixMSTimePeriodToString(const UnixMSTime: TUnixMSTime; FirstTimeChar: AnsiChar='T'): RawUTF8; - -/// returns the current UTC system date and time -// - SysUtils.Now returns local time: this function returns the system time -// expressed in Coordinated Universal Time (UTC) -// - under Windows, will use GetSystemTimeAsFileTime() so will achieve about -// 16 ms of resolution -// - under POSIX, will call clock_gettime(CLOCK_REALTIME_COARSE) -function NowUTC: TDateTime; - -{$ifndef ENHANCEDRTL} -{$ifndef LVCL} { don't define these twice } - -var - /// these procedure type must be defined if a default system.pas is used - // - mORMoti18n.pas unit will hack default LoadResString() procedure - // - already defined in our Extended system.pas unit - // - needed with FPC, Delphi 2009 and up, i.e. when ENHANCEDRTL is not defined - // - expect generic "string" type, i.e. UnicodeString for Delphi 2009+ - // - not needed with the LVCL framework (we should be on server side) - LoadResStringTranslate: procedure(var Text: string) = nil; - - /// current LoadResString() cached entries count - // - i.e. resourcestring caching for faster use - // - used only if a default system.pas is used, not our Extended version - // - defined here, but resourcestring caching itself is implemented in the - // mORMoti18n.pas unit, if the ENHANCEDRTL conditional is not defined - CacheResCount: integer = -1; - -{$endif} -{$endif} - -type - /// a generic callback, which can be used to translate some text on the fly - // - maps procedure TLanguageFile.Translate(var English: string) signature - // as defined in mORMoti18n.pas - // - can be used e.g. for TSynMustache's {{"English text}} callback - TOnStringTranslate = procedure (var English: string) of object; - - -const - /// Rotate local log file if reached this size (1MB by default) - // - .log file will be save as .log.bak file - // - a new .log file is created - // - used by AppendToTextFile() and LogToTextFile() functions (not TSynLog) - MAXLOGSIZE = 1024*1024; - -/// log a message to a local text file -// - the text file is located in the executable directory, and its name is -// simply the executable file name with the '.log' extension instead of '.exe' -// - format contains the current date and time, then the Msg on one line -// - date and time format used is 'YYYYMMDD hh:mm:ss (i.e. ISO-8601)' -procedure LogToTextFile(Msg: RawUTF8); - -/// log a message to a local text file -// - this version expects the filename to be specified -// - format contains the current date and time, then the Msg on one line -// - date and time format used is 'YYYYMMDD hh:mm:ss' -procedure AppendToTextFile(aLine: RawUTF8; const aFileName: TFileName; aMaxSize: Int64=MAXLOGSIZE; - aUTCTimeStamp: boolean=false); - - -{ ************ fast low-level lookup types used by internal conversion routines } - -{$ifndef ENHANCEDRTL} -{$ifndef LVCL} { don't define these const twice } - -const - /// fast lookup table for converting any decimal number from - // 0 to 99 into their ASCII equivalence - // - our enhanced SysUtils.pas (normal and LVCL) contains the same array - TwoDigitLookup: packed array[0..99] of array[1..2] of AnsiChar = - ('00','01','02','03','04','05','06','07','08','09', - '10','11','12','13','14','15','16','17','18','19', - '20','21','22','23','24','25','26','27','28','29', - '30','31','32','33','34','35','36','37','38','39', - '40','41','42','43','44','45','46','47','48','49', - '50','51','52','53','54','55','56','57','58','59', - '60','61','62','63','64','65','66','67','68','69', - '70','71','72','73','74','75','76','77','78','79', - '80','81','82','83','84','85','86','87','88','89', - '90','91','92','93','94','95','96','97','98','99'); - -{$endif} -{$endif} - -var - /// fast lookup table for converting any decimal number from - // 0 to 99 into their ASCII ('0'..'9') equivalence - TwoDigitLookupW: packed array[0..99] of word absolute TwoDigitLookup; - /// fast lookup table for converting any decimal number from - // 0 to 99 into their byte digits (0..9) equivalence - // - used e.g. by DoubleToAscii() implementing Grisu algorithm - TwoDigitByteLookupW: packed array[0..99] of word; - -type - /// char categories for text line/word/identifiers/uri parsing - TTextChar = set of (tcNot01013, tc1013, tcCtrlNotLF, tcCtrlNot0Comma, - tcWord, tcIdentifierFirstChar, tcIdentifier, tcURIUnreserved); - TTextCharSet = array[AnsiChar] of TTextChar; - PTextCharSet = ^TTextCharSet; - TTextByteSet = array[byte] of TTextChar; - PTextByteSet = ^TTextByteSet; -var - /// branch-less table used for text line/word/identifiers/uri parsing - TEXT_CHARS: TTextCharSet; - TEXT_BYTES: TTextByteSet absolute TEXT_CHARS; - -{$M+} // to have existing RTTI for published properties -type - /// used to retrieve version information from any EXE - // - under Linux, all version numbers are set to 0 by default - // - you should not have to use this class directly, but via the - // ExeVersion global variable - TFileVersion = class - protected - fDetailed: string; - fFileName: TFileName; - fBuildDateTime: TDateTime; - /// change the version (not to be used in most cases) - procedure SetVersion(aMajor,aMinor,aRelease,aBuild: integer); - public - /// executable major version number - Major: Integer; - /// executable minor version number - Minor: Integer; - /// executable release version number - Release: Integer; - /// executable release build number - Build: Integer; - /// build year of this exe file - BuildYear: word; - /// version info of the exe file as '3.1' - // - return "string" type, i.e. UnicodeString for Delphi 2009+ - Main: string; - /// associated CompanyName string version resource - // - only available on Windows - contains '' under Linux/POSIX - CompanyName: RawUTF8; - /// associated FileDescription string version resource - // - only available on Windows - contains '' under Linux/POSIX - FileDescription: RawUTF8; - /// associated FileVersion string version resource - // - only available on Windows - contains '' under Linux/POSIX - FileVersion: RawUTF8; - /// associated InternalName string version resource - // - only available on Windows - contains '' under Linux/POSIX - InternalName: RawUTF8; - /// associated LegalCopyright string version resource - // - only available on Windows - contains '' under Linux/POSIX - LegalCopyright: RawUTF8; - /// associated OriginalFileName string version resource - // - only available on Windows - contains '' under Linux/POSIX - OriginalFilename: RawUTF8; - /// associated ProductName string version resource - // - only available on Windows - contains '' under Linux/POSIX - ProductName: RawUTF8; - /// associated ProductVersion string version resource - // - only available on Windows - contains '' under Linux/POSIX - ProductVersion: RawUTF8; - /// associated Comments string version resource - // - only available on Windows - contains '' under Linux/POSIX - Comments: RawUTF8; - /// retrieve application version from exe file name - // - DefaultVersion32 is used if no information Version was included into - // the executable resources (on compilation time) - // - you should not have to use this constructor, but rather access the - // ExeVersion global variable - constructor Create(const aFileName: TFileName; aMajor: integer=0; - aMinor: integer=0; aRelease: integer=0; aBuild: integer=0); - /// retrieve the version as a 32-bit integer with Major.Minor.Release - // - following Major shl 16+Minor shl 8+Release bit pattern - function Version32: integer; - /// build date and time of this exe file, as plain text - function BuildDateTimeString: string; - /// version info of the exe file as '3.1.0.123' or '' - // - this method returns '' if Detailed is '0.0.0.0' - function DetailedOrVoid: string; - /// returns the version information of this exe file as text - // - includes FileName (without path), Detailed and BuildDateTime properties - // - e.g. 'myprogram.exe 3.1.0.123 (2016-06-14 19:07:55)' - function VersionInfo: RawUTF8; - /// returns a ready-to-use User-Agent header with exe name, version and OS - // - e.g. 'myprogram/3.1.0.123W32' for myprogram running on Win32 - // - here OS_INITIAL[] character is used to identify the OS, with '32' - // appended on Win32 only (e.g. 'myprogram/3.1.0.2W', is for Win64) - function UserAgent: RawUTF8; - /// returns the version information of a specified exe file as text - // - includes FileName (without path), Detailed and BuildDateTime properties - // - e.g. 'myprogram.exe 3.1.0.123 2016-06-14 19:07:55' - class function GetVersionInfo(const aFileName: TFileName): RawUTF8; - published - /// version info of the exe file as '3.1.0.123' - // - return "string" type, i.e. UnicodeString for Delphi 2009+ - // - under Linux, always return '0.0.0.0' if no custom version number - // has been defined - // - consider using DetailedOrVoid method if '0.0.0.0' is not expected - property Detailed: string read fDetailed write fDetailed; - /// build date and time of this exe file - property BuildDateTime: TDateTime read fBuildDateTime write fBuildDateTime; - end; -{$M-} - - -{$ifdef DELPHI6OROLDER} - -// define some common constants not available prior to Delphi 7 -const - HoursPerDay = 24; - MinsPerHour = 60; - SecsPerMin = 60; - MSecsPerSec = 1000; - MinsPerDay = HoursPerDay * MinsPerHour; - SecsPerDay = MinsPerDay * SecsPerMin; - MSecsPerDay = SecsPerDay * MSecsPerSec; - DateDelta = 693594; - UnixDateDelta = 25569; - -/// GetFileVersion returns the most significant 32-bit of a file's binary -// version number -// - typically, this includes the major and minor version placed -// together in one 32-bit integer -// - generally does not include the release or build numbers -// - returns Cardinal(-1) in case of failure -function GetFileVersion(const FileName: TFileName): cardinal; - -{$endif DELPHI6OROLDER} - -type - /// the recognized operating systems - // - it will also recognize some Linux distributions - TOperatingSystem = (osUnknown, osWindows, osLinux, osOSX, osBSD, osPOSIX, - osArch, osAurox, osDebian, osFedora, osGentoo, osKnoppix, osMint, osMandrake, - osMandriva, osNovell, osUbuntu, osSlackware, osSolaris, osSuse, osSynology, - osTrustix, osClear, osUnited, osRedHat, osLFS, osOracle, osMageia, osCentOS, - osCloud, osXen, osAmazon, osCoreOS, osAlpine, osAndroid); - /// the recognized Windows versions - // - defined even outside MSWINDOWS to allow process e.g. from monitoring tools - TWindowsVersion = ( - wUnknown, w2000, wXP, wXP_64, wServer2003, wServer2003_R2, - wVista, wVista_64, wServer2008, wServer2008_64, - wSeven, wSeven_64, wServer2008_R2, wServer2008_R2_64, - wEight, wEight_64, wServer2012, wServer2012_64, - wEightOne, wEightOne_64, wServer2012R2, wServer2012R2_64, - wTen, wTen_64, wServer2016, wServer2016_64, - wEleven, wEleven_64, wServer2019_64); - /// the running Operating System, encoded as a 32-bit integer - TOperatingSystemVersion = packed record - case os: TOperatingSystem of - osUnknown: (b: array[0..2] of byte); - osWindows: (win: TWindowsVersion); - osLinux: (utsrelease: array[0..2] of byte); - end; - -const - /// the recognized Windows versions, as plain text - // - defined even outside MSWINDOWS to allow process e.g. from monitoring tools - WINDOWS_NAME: array[TWindowsVersion] of RawUTF8 = ( - '', '2000', 'XP', 'XP 64bit', 'Server 2003', 'Server 2003 R2', - 'Vista', 'Vista 64bit', 'Server 2008', 'Server 2008 64bit', - '7', '7 64bit', 'Server 2008 R2', 'Server 2008 R2 64bit', - '8', '8 64bit', 'Server 2012', 'Server 2012 64bit', - '8.1', '8.1 64bit', 'Server 2012 R2', 'Server 2012 R2 64bit', - '10', '10 64bit', 'Server 2016', 'Server 2016 64bit', - '11', '11 64bit', 'Server 2019 64bit'); - /// the recognized Windows versions which are 32-bit - WINDOWS_32 = [w2000, wXP, wServer2003, wServer2003_R2, wVista, wServer2008, - wSeven, wServer2008_R2, wEight, wServer2012, wEightOne, wServer2012R2, - wTen, wServer2016, wEleven]; - /// translate one operating system (and distribution) into a single character - // - may be used internally e.g. for a HTTP User-Agent header, as with - // TFileVersion.UserAgent - OS_INITIAL: array[TOperatingSystem] of AnsiChar = - ('?', 'W', 'L', 'X', 'B', 'P', 'A', 'a', 'D', 'F', 'G', 'K', 'M', 'm', - 'n', 'N', 'U', 'S', 's', 'u', 'Y', 'T', 'C', 't', 'R', 'l', 'O', 'G', - 'c', 'd', 'x', 'Z', 'r', 'p', 'J'); // for Android ... J = Java VM - /// the operating systems items which actually are Linux distributions - OS_LINUX = [osLinux, osArch .. osAndroid]; - - /// the compiler family used - COMP_TEXT = {$ifdef FPC}'Fpc'{$else}'Delphi'{$endif}; - /// the target Operating System used for compilation, as text - OS_TEXT = {$ifdef MSWINDOWS}'Win'{$else}{$ifdef DARWIN}'OSX'{$else} - {$ifdef BSD}'BSD'{$else}{$ifdef ANDROID}'Android'{$else}{$ifdef LINUX}'Linux'{$else}'Posix' - {$endif}{$endif}{$endif}{$endif}{$endif}; - /// the CPU architecture used for compilation - CPU_ARCH_TEXT = {$ifdef CPUX86}'x86'{$else}{$ifdef CPUX64}'x64'{$else} - {$ifdef CPUARM}'arm'+{$else} - {$ifdef CPUAARCH64}'arm'+{$else} - {$ifdef CPUPOWERPC}'ppc'+{$else} - {$ifdef CPUSPARC}'sparc'+{$endif}{$endif}{$endif}{$endif} - {$ifdef CPU32}'32'{$else}'64'{$endif}{$endif}{$endif}; - -function ToText(os: TOperatingSystem): PShortString; overload; -function ToText(const osv: TOperatingSystemVersion): ShortString; overload; -function ToTextOS(osint32: integer): RawUTF8; - -var - /// the target Operating System used for compilation, as TOperatingSystem - // - a specific Linux distribution may be detected instead of plain osLinux - OS_KIND: TOperatingSystem = {$ifdef MSWINDOWS}osWindows{$else}{$ifdef DARWIN}osOSX{$else} - {$ifdef BSD}osBSD{$else}{$ifdef Android}osAndroid{$else}{$ifdef LINUX}osLinux{$else}osPOSIX - {$endif}{$endif}{$endif}{$endif}{$endif}; - /// the current Operating System version, as retrieved for the current process - // - contains e.g. 'Windows Seven 64 SP1 (6.1.7601)' or - // 'Ubuntu 16.04.5 LTS - Linux 3.13.0 110 generic#157 Ubuntu SMP Mon Feb 20 11:55:25 UTC 2017' - OSVersionText: RawUTF8; - /// some addition system information as text, e.g. 'Wine 1.1.5' - // - also always appended to OSVersionText high-level description - OSVersionInfoEx: RawUTF8; - /// some textual information about the current CPU - CpuInfoText: RawUTF8; - /// some textual information about the current computer hardware, from BIOS - BiosInfoText: RawUTF8; - /// the running Operating System - OSVersion32: TOperatingSystemVersion; - OSVersionInt32: integer absolute OSVersion32; - -{$ifdef MSWINDOWS} - {$ifndef UNICODE} -type - /// low-level API structure, not defined in older Delphi versions - TOSVersionInfoEx = record - dwOSVersionInfoSize: DWORD; - dwMajorVersion: DWORD; - dwMinorVersion: DWORD; - dwBuildNumber: DWORD; - dwPlatformId: DWORD; - szCSDVersion: array[0..127] of char; - wServicePackMajor: WORD; - wServicePackMinor: WORD; - wSuiteMask: WORD; - wProductType: BYTE; - wReserved: BYTE; - end; - {$endif UNICODE} - -var - /// is set to TRUE if the current process is a 32-bit image running under WOW64 - // - WOW64 is the x86 emulator that allows 32-bit Windows-based applications - // to run seamlessly on 64-bit Windows - // - equals always FALSE if the current executable is a 64-bit image - IsWow64: boolean; - /// the current System information, as retrieved for the current process - // - under a WOW64 process, it will use the GetNativeSystemInfo() new API - // to retrieve the real top-most system information - // - note that the lpMinimumApplicationAddress field is replaced by a - // more optimistic/realistic value ($100000 instead of default $10000) - // - under BSD/Linux, only contain dwPageSize and dwNumberOfProcessors fields - SystemInfo: TSystemInfo; - /// the current Operating System information, as retrieved for the current process - OSVersionInfo: TOSVersionInfoEx; - /// the current Operating System version, as retrieved for the current process - OSVersion: TWindowsVersion; - -/// this function can be used to create a GDI compatible window, able to -// receive Windows Messages for fast local communication -// - will return 0 on failure (window name already existing e.g.), or -// the created HWND handle on success -// - it will call the supplied message handler defined for a given Windows Message: -// for instance, define such a method in any object definition: -// ! procedure WMCopyData(var Msg : TWMCopyData); message WM_COPYDATA; -function CreateInternalWindow(const aWindowName: string; aObject: TObject): HWND; - -/// delete the window resources used to receive Windows Messages -// - must be called for each CreateInternalWindow() function -// - both parameter values are then reset to ''/0 -function ReleaseInternalWindow(var aWindowName: string; var aWindow: HWND): boolean; - -/// under Windows 7 and later, will set an unique application-defined -// Application User Model ID (AppUserModelID) that identifies the current -// process to the taskbar -// - this identifier allows an application to group its associated processes -// and windows under a single taskbar button -// - value can have no more than 128 characters, cannot contain spaces, and -// each section should be camel-cased, as such: -// $ CompanyName.ProductName.SubProduct.VersionInformation -// CompanyName and ProductName should always be used, while the SubProduct and -// VersionInformation portions are optional and depend on the application's requirements -// - if the supplied text does not contain an '.', 'ID.ID' will be used -function SetAppUserModelID(const AppUserModelID: string): boolean; - -var - /// the number of milliseconds that have elapsed since the system was started - // - compatibility function, to be implemented according to the running OS - // - will use the corresponding native API function under Vista+, or - // will emulate it for older Windows versions (XP) - // - warning: FPC's SysUtils.GetTickCount64 or TThread.GetTickCount64 don't - // handle properly 49 days wrapping under XP -> always use this safe version - GetTickCount64: function: Int64; stdcall; - - /// returns the highest resolution possible UTC timestamp on this system - // - detects newer API available since Windows 8, or fallback to good old - // GetSystemTimeAsFileTime() which may have the resolution of the HW timer, - // i.e. typically around 16 ms - // - GetSystemTimeAsFileTime() is always faster, so is to be preferred - // if second resolution is enough (e.g. for UnixTimeUTC) - // - see http://www.windowstimestamp.com/description - GetSystemTimePreciseAsFileTime: procedure(var ft: TFILETIME); stdcall; - -/// similar to Windows sleep() API call, to be truly cross-platform -// - it should have a millisecond resolution, and handle ms=0 as a switch to -// another pending thread, i.e. under Windows will call SwitchToThread API -procedure SleepHiRes(ms: cardinal); - -/// low-level wrapper to get the 64-bit value from a TFileTime -// - as recommended by MSDN to avoid dword alignment issue -procedure FileTimeToInt64(const FT: TFileTime; out I64: Int64); - {$ifdef HASINLINE}inline;{$endif} - -/// low-level conversion of a Windows 64-bit TFileTime into a Unix time seconds stamp -function FileTimeToUnixTime(const FT: TFileTime): TUnixTime; - -/// low-level conversion of a Windows 64-bit TFileTime into a Unix time ms stamp -function FileTimeToUnixMSTime(const FT: TFileTime): TUnixMSTime; - -type - /// direct access to the Windows Registry - // - could be used as alternative to TRegistry, which doesn't behave the same on - // all Delphi versions, and is enhanced on FPC (e.g. which supports REG_MULTI_SZ) - // - is also Unicode ready for text, using UTF-8 conversion on all compilers - TWinRegistry = object - public - /// the opened HKEY handle - key: HKEY; - /// start low-level read access to a Windows Registry node - // - on success (returned true), ReadClose() should be called - function ReadOpen(root: HKEY; const keyname: RawUTF8; closefirst: boolean=false): boolean; - /// finalize low-level read access to the Windows Registry after ReadOpen() - procedure Close; - /// low-level read a string from the Windows Registry after ReadOpen() - // - in respect to Delphi's TRegistry, will properly handle REG_MULTI_SZ - // (return the first value of the multi-list) - function ReadString(const entry: SynUnicode; andtrim: boolean=true): RawUTF8; - /// low-level read a Windows Registry content after ReadOpen() - // - works with any kind of key, but was designed for REG_BINARY - function ReadData(const entry: SynUnicode): RawByteString; - /// low-level read a Windows Registry 32-bit REG_DWORD value after ReadOpen() - function ReadDword(const entry: SynUnicode): cardinal; - /// low-level read a Windows Registry 64-bit REG_QWORD value after ReadOpen() - function ReadQword(const entry: SynUnicode): QWord; - /// low-level enumeration of all sub-entries names of a Windows Registry key - function ReadEnumEntries: TRawUTF8DynArray; - end; - -{$else MSWINDOWS} - -var - /// emulate only some used fields of Windows' TSystemInfo - SystemInfo: record - // retrieved from libc's getpagesize() - is expected to not be 0 - dwPageSize: cardinal; - // retrieved from HW_NCPU (BSD) or /proc/cpuinfo (Linux) - dwNumberOfProcessors: cardinal; - // as returned by fpuname() - uts: UtsName; - // as from /etc/*-release - release: RawUTF8; - end; - -{$ifdef KYLIX3} - -/// compatibility function for Linux -function GetCurrentThreadID: TThreadID; cdecl; - external 'libpthread.so.0' name 'pthread_self'; - -/// overloaded function using open64() to allow 64-bit positions -function FileOpen(const FileName: string; Mode: LongWord): Integer; - -{$endif} - -/// compatibility function, to be implemented according to the running OS -// - expect more or less the same result as the homonymous Win32 API function, -// but usually with a better resolution (Windows has only around 10-16 ms) -// - will call the corresponding function in SynKylix.pas or SynFPCLinux.pas, -// using the very fast CLOCK_MONOTONIC_COARSE if available on the kernel -function GetTickCount64: Int64; - -{$endif MSWINDOWS} - -/// overloaded function optimized for one pass file reading -// - will use e.g. the FILE_FLAG_SEQUENTIAL_SCAN flag under Windows, as stated -// by http://blogs.msdn.com/b/oldnewthing/archive/2012/01/20/10258690.aspx -// - note: under XP, we observed ERROR_NO_SYSTEM_RESOURCES problems when calling -// FileRead() for chunks bigger than 32MB on files opened with this flag, -// so it would use regular FileOpen() on this deprecated OS -// - under POSIX, calls plain fpOpen(FileName,O_RDONLY) which would avoid a -// syscall to fpFlock() which is not needed here -// - is used e.g. by StringFromFile() and TSynMemoryStreamMapped.Create() -function FileOpenSequentialRead(const FileName: string): Integer; - {$ifdef HASINLINE}inline;{$endif} - -/// returns a TFileStream optimized for one pass file reading -// - will use FileOpenSequentialRead(), i.e. FILE_FLAG_SEQUENTIAL_SCAN under -// Windows, and plain fpOpen(FileName, O_RDONLY) on POSIX -function FileStreamSequentialRead(const FileName: string): THandleStream; - -/// check if the current timestamp, in ms, matched a given period -// - will compare the current GetTickCount64 to the supplied PreviousTix -// - returns TRUE if the Internal ms period was not elapsed -// - returns TRUE, and set PreviousTix, if the Interval ms period was elapsed -// - possible use case may be: -// !var Last: Int64; -// !... -// ! Last := GetTickCount64; -// ! repeat -// ! ... -// ! if Elapsed(Last,1000) then begin -// ! ... // do something every second -// ! end; -// ! until Terminated; -// !... -function Elapsed(var PreviousTix: Int64; Interval: Integer): Boolean; - -/// thread-safe move of a 32-bit value using a simple Read-Copy-Update pattern -procedure RCU32(var src,dst); - -/// thread-safe move of a 64-bit value using a simple Read-Copy-Update pattern -procedure RCU64(var src,dst); - -/// thread-safe move of a 128-bit value using a simple Read-Copy-Update pattern -procedure RCU128(var src,dst); - -/// thread-safe move of a pointer value using a simple Read-Copy-Update pattern -procedure RCUPtr(var src,dst); - -/// thread-safe move of a memory buffer using a simple Read-Copy-Update pattern -procedure RCU(var src,dst; len: integer); - -{$ifndef FPC} { FPC defines those functions as built-in } - -/// compatibility function, to be implemented according to the running CPU -// - expect the same result as the homonymous Win32 API function -function InterlockedIncrement(var I: Integer): Integer; - {$ifdef PUREPASCAL}{$ifndef MSWINDOWS}{$ifdef HASINLINE}inline;{$endif}{$endif}{$endif} - -/// compatibility function, to be implemented according to the running CPU -// - expect the same result as the homonymous Win32 API function -function InterlockedDecrement(var I: Integer): Integer; - {$ifdef PUREPASCAL}{$ifdef HASINLINE}inline;{$endif}{$endif} - -{$endif FPC} - -/// low-level string reference counter unprocess -// - caller should have tested that refcnt>=0 -// - returns true if the managed variable should be released (i.e. refcnt was 1) -function StrCntDecFree(var refcnt: TStrCnt): boolean; - {$ifndef CPUINTEL} inline; {$endif} - -/// low-level dynarray reference counter unprocess -// - caller should have tested that refcnt>=0 -function DACntDecFree(var refcnt: TDACnt): boolean; - {$ifndef CPUINTEL} inline; {$endif} - -type - /// stores some global information about the current executable and computer - TExeVersion = record - /// the main executable name, without any path nor extension - // - e.g. 'Test' for 'c:\pathto\Test.exe' - ProgramName: RawUTF8; - /// the main executable details, as used e.g. by TSynLog - // - e.g. 'C:\Dev\lib\SQLite3\exe\TestSQL3.exe 1.2.3.123 (2011-03-29 11:09:06)' - ProgramFullSpec: RawUTF8; - /// the main executable file name (including full path) - // - same as paramstr(0) - ProgramFileName: TFileName; - /// the main executable full path (excluding .exe file name) - // - same as ExtractFilePath(paramstr(0)) - ProgramFilePath: TFileName; - /// the full path of the running executable or library - // - for an executable, same as paramstr(0) - // - for a library, will contain the whole .dll file name - InstanceFileName: TFileName; - /// the current executable version - Version: TFileVersion; - /// the current computer host name - Host: RawUTF8; - /// the current computer user name - User: RawUTF8; - /// some hash representation of this information - // - the very same executable on the very same computer run by the very - // same user will always have the same Hash value - // - is computed from the crc32c of this TExeVersion fields: c0 from - // Version32, CpuFeatures and Host, c1 from User, c2 from ProgramFullSpec - // and c3 from InstanceFileName - // - may be used as an entropy seed, or to identify a process execution - Hash: THash128Rec; - end; - -var - /// global information about the current executable and computer - // - this structure is initialized in this unit's initialization block below - // - you can call SetExecutableVersion() with a custom version, if needed - ExeVersion: TExeVersion; - -/// initialize ExeVersion global variable, supplying a custom version number -// - by default, the version numbers will be retrieved at startup from the -// executable itself (if it was included at build time) -// - but you can use this function to set any custom version numbers -procedure SetExecutableVersion(aMajor,aMinor,aRelease,aBuild: integer); overload; - -/// initialize ExeVersion global variable, supplying the version as text -// - e.g. SetExecutableVersion('7.1.2.512'); -procedure SetExecutableVersion(const aVersionText: RawUTF8); overload; - -type - /// identify an operating system folder - TSystemPath = ( - spCommonData, spUserData, spCommonDocuments, spUserDocuments, spTempFolder, spLog); - -/// returns an operating system folder -// - will return the full path of a given kind of private or shared folder, -// depending on the underlying operating system -// - will use SHGetFolderPath and the corresponding CSIDL constant under Windows -// - under POSIX, will return $TMP/$TMPDIR folder for spTempFolder, ~/.cache/appname -// for spUserData, /var/log for spLog, or the $HOME folder -// - returned folder name contains the trailing path delimiter (\ or /) -function GetSystemPath(kind: TSystemPath): TFileName; - -/// self-modifying code - change some memory buffer in the code segment -// - if Backup is not nil, it should point to a Size array of bytes, ready -// to contain the overridden code buffer, for further hook disabling -procedure PatchCode(Old,New: pointer; Size: integer; Backup: pointer=nil; - LeaveUnprotected: boolean=false); - -/// self-modifying code - change one PtrUInt in the code segment -procedure PatchCodePtrUInt(Code: PPtrUInt; Value: PtrUInt; - LeaveUnprotected: boolean=false); - -{$ifdef CPUINTEL} -type - /// small memory buffer used to backup a RedirectCode() redirection hook - TPatchCode = array[0..4] of byte; - /// pointer to a small memory buffer used to backup a RedirectCode() hook - PPatchCode = ^TPatchCode; - -/// self-modifying code - add an asm JUMP to a redirected function -// - if Backup is not nil, it should point to a TPatchCode buffer, ready -// to contain the overridden code buffer, for further hook disabling -procedure RedirectCode(Func, RedirectFunc: Pointer; Backup: PPatchCode=nil); - -/// self-modifying code - restore a code from its RedirectCode() backup -procedure RedirectCodeRestore(Func: pointer; const Backup: TPatchCode); -{$endif CPUINTEL} - -type - /// to be used instead of TMemoryStream, for speed - // - allocates memory from Delphi heap (i.e. FastMM4/SynScaleMM) - // and not GlobalAlloc(), as was the case for oldest versions of Delphi - // - uses bigger growing size of the capacity - // - consider using TRawByteStringStream, as we do in our units -{$ifdef LVCL} // LVCL already use Delphi heap instead of GlobalAlloc() - THeapMemoryStream = TMemoryStream; -{$else} - {$ifdef FPC} // FPC already use heap instead of GlobalAlloc() - THeapMemoryStream = TMemoryStream; - {$else} - {$ifndef UNICODE} // old Delphi used GlobalAlloc() - THeapMemoryStream = class(TMemoryStream) - protected - function Realloc(var NewCapacity: longint): Pointer; override; - end; - {$else} - THeapMemoryStream = TMemoryStream; - {$endif} - {$endif} -{$endif} - -var - /// a global "Garbage collector", for some classes instances which must - // live during whole main executable process - // - used to avoid any memory leak with e.g. 'class var RecordProps', i.e. - // some singleton or static objects - // - to be used, e.g. as: - // ! Version := TFileVersion.Create(InstanceFileName,DefaultVersion32); - // ! GarbageCollector.Add(Version); - // - see also GarbageCollectorFreeAndNil() as an alternative - GarbageCollector: TSynObjectList; - - /// set to TRUE when the global "Garbage collector" are beeing freed - GarbageCollectorFreeing: boolean; - -/// a global "Garbage collector" for some TObject global variables which must -// live during whole main executable process -// - this list expects a pointer to the TObject instance variable to be -// specified, and will be set to nil (like a FreeAndNil) -// - this may be useful when used when targetting Delphi IDE packages, -// to circumvent the bug of duplicated finalization of units, in the scope -// of global variables -// - to be used, e.g. as: -// ! if SynAnsiConvertList=nil then -// ! GarbageCollectorFreeAndNil(SynAnsiConvertList,TObjectList.Create); -procedure GarbageCollectorFreeAndNil(var InstanceVariable; Instance: TObject); - -/// force the global "Garbage collector" list to be released immediately -// - this function is called in the finalization section of this unit -// - you should NEVER have to call this function, unless some specific cases -// (e.g. when using Delphi packages, just before releasing the package) -procedure GarbageCollectorFree; - -/// enter a giant lock for thread-safe shared process -// - shall be protected as such: -// ! GlobalLock; -// ! try -// ! .... do something thread-safe but as short as possible -// ! finally -// ! GlobalUnLock; -// ! end; -// - you should better not use such a giant-lock, but an instance-dedicated -// critical section - these functions are just here to be convenient, for -// non time-critical process -procedure GlobalLock; - -/// release the giant lock for thread-safe shared process -// - you should better not use such a giant-lock, but an instance-dedicated -// critical section - these functions are just here to be convenient, for -// non time-critical process -procedure GlobalUnLock; - - -var - /// JSON compatible representation of a boolean value, i.e. 'false' and 'true' - // - can be used when a RawUTF8 string is expected - BOOL_UTF8: array[boolean] of RawUTF8; - -const - /// JSON compatible representation of a boolean value, i.e. 'false' and 'true' - // - can be used e.g. in logs, or anything accepting a shortstring - BOOL_STR: array[boolean] of string[7] = ('false','true'); - - /// can be used to append to most English nouns to form a plural - // - see also the Plural function - PLURAL_FORM: array[boolean] of RawUTF8 = ('','s'); - -/// write count number and append 's' (if needed) to form a plural English noun -// - for instance, Plural('row',100) returns '100 rows' with no heap allocation -function Plural(const itemname: shortstring; itemcount: cardinal): shortstring; - -/// returns TRUE if the specified field name is either 'ID', either 'ROWID' -function IsRowID(FieldName: PUTF8Char): boolean; - {$ifdef HASINLINE}inline;{$endif} overload; - -/// returns TRUE if the specified field name is either 'ID', either 'ROWID' -function IsRowID(FieldName: PUTF8Char; FieldLen: integer): boolean; - {$ifdef HASINLINE}inline;{$endif} overload; - -/// returns TRUE if the specified field name is either 'ID', either 'ROWID' -function IsRowIDShort(const FieldName: shortstring): boolean; - {$ifdef HASINLINE}inline;{$endif} overload; - -/// retrieve the next SQL-like identifier within the UTF-8 buffer -// - will also trim any space (or line feeds) and trailing ';' -// - any comment like '/*nocache*/' will be ignored -// - returns true if something was set to Prop -function GetNextFieldProp(var P: PUTF8Char; var Prop: RawUTF8): boolean; - -/// retrieve the next identifier within the UTF-8 buffer on the same line -// - GetNextFieldProp() will just handle line feeds (and ';') as spaces - which -// is fine e.g. for SQL, but not for regular config files with name/value pairs -// - returns true if something was set to Prop -function GetNextFieldPropSameLine(var P: PUTF8Char; var Prop: ShortString): boolean; - - -{ ************ variant-based process, including JSON/BSON document content } - -const - /// unsigned 64bit integer variant type - // - currently called varUInt64 in Delphi (not defined in older versions), - // and varQWord in FPC - varWord64 = 21; - - /// this variant type will map the current SynUnicode type - // - depending on the compiler version - varSynUnicode = {$ifdef HASVARUSTRING}varUString{$else}varOleStr{$endif}; - - /// this variant type will map the current string type - // - depending on the compiler version - varNativeString = {$ifdef UNICODE}varUString{$else}varString{$endif}; - -{$ifdef HASINLINE} -/// overloaded function which can be properly inlined -procedure VarClear(var v: variant); inline; -{$endif HASINLINE} - -/// same as Dest := TVarData(Source) for simple values -// - will return TRUE for all simple values after varByRef unreference, and -// copying the unreferenced Source value into Dest raw storage -// - will return FALSE for not varByRef values, or complex values (e.g. string) -function SetVariantUnRefSimpleValue(const Source: variant; var Dest: TVarData): boolean; - {$ifdef HASINLINE}inline;{$endif} - -{$ifndef LVCL} - -/// convert a raw binary buffer into a variant RawByteString varString -// - you can then use VariantToRawByteString() to retrieve the binary content -procedure RawByteStringToVariant(Data: PByte; DataLen: Integer; var Value: variant); overload; - -/// convert a RawByteString content into a variant varString -// - you can then use VariantToRawByteString() to retrieve the binary content -procedure RawByteStringToVariant(const Data: RawByteString; var Value: variant); overload; - -/// convert back a RawByteString from a variant -// - the supplied variant should have been created via a RawByteStringToVariant() -// function call -procedure VariantToRawByteString(const Value: variant; var Dest: RawByteString); - -/// same as Value := Null, but slightly faster -procedure SetVariantNull(var Value: variant); - {$ifdef HASINLINE}inline;{$endif} - -const - NullVarData: TVarData = (VType: varNull); -var - /// a slightly faster alternative to Variants.Null function - Null: variant absolute NullVarData; - -{$endif LVCL} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - we also discovered some issues with FPC's Variants unit, so this function -// may be used even in end-user cross-compiler code -function VarIsEmptyOrNull(const V: Variant): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(PVariant(V)^) or VarIsEmpty(PVariant(V)^), but faster -// - we also discovered some issues with FPC's Variants unit, so this function -// may be used even in end-user cross-compiler code -function VarDataIsEmptyOrNull(VarData: pointer): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// fastcheck if a variant hold a value -// - varEmpty, varNull or a '' string would be considered as void -// - varBoolean=false or varDate=0 would be considered as void -// - a TDocVariantData with Count=0 would be considered as void -// - any other value (e.g. integer) would be considered as not void -function VarIsVoid(const V: Variant): boolean; - -/// returns a supplied string as variant, or null if v is void ('') -function VarStringOrNull(const v: RawUTF8): variant; - -type - TVarDataTypes = set of 0..255; - -/// allow to check for a specific set of TVarData.VType -function VarIs(const V: Variant; const VTypes: TVarDataTypes): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -{$ifndef NOVARIANTS} - -type - /// custom variant handler with easier/faster access of variant properties, - // and JSON serialization support - // - default GetProperty/SetProperty methods are called via some protected - // virtual IntGet/IntSet methods, with less overhead (to be overriden) - // - these kind of custom variants will be faster than the default - // TInvokeableVariantType for properties getter/setter, but you should - // manually register each type by calling SynRegisterCustomVariantType() - // - also feature custom JSON parsing, via TryJSONToVariant() protected method - TSynInvokeableVariantType = class(TInvokeableVariantType) - protected - {$ifndef FPC} - {$ifndef DELPHI6OROLDER} - /// our custom call backs do not want the function names to be uppercased - function FixupIdent(const AText: string): string; override; - {$endif} - {$endif} - /// override those two abstract methods for fast getter/setter implementation - function IntGet(var Dest: TVarData; const Instance: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; virtual; - function IntSet(const Instance, Value: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; virtual; - public - /// search of a registered custom variant type from its low-level VarType - // - will first compare with its own VarType for efficiency - function FindSynVariantType(aVarType: Word; out CustomType: TSynInvokeableVariantType): boolean; - /// customization of JSON parsing into variants - // - will be called by e.g. by VariantLoadJSON() or GetVariantFromJSON() - // with Options: PDocVariantOptions parameter not nil - // - this default implementation will always returns FALSE, - // meaning that the supplied JSON is not to be handled by this custom - // (abstract) variant type - // - this method could be overridden to identify any custom JSON content - // and convert it into a dedicated variant instance, then return TRUE - // - warning: should NOT modify JSON buffer in-place, unless it returns true - function TryJSONToVariant(var JSON: PUTF8Char; var Value: variant; - EndOfObject: PUTF8Char): boolean; virtual; - /// customization of variant into JSON serialization - procedure ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind); overload; virtual; - /// retrieve the field/column value - // - this method will call protected IntGet abstract method - function GetProperty(var Dest: TVarData; const V: TVarData; - const Name: String): Boolean; override; - /// set the field/column value - // - this method will call protected IntSet abstract method - {$ifdef FPC_VARIANTSETVAR} // see http://mantis.freepascal.org/view.php?id=26773 - function SetProperty(var V: TVarData; const Name: string; - const Value: TVarData): Boolean; override; - {$else} - function SetProperty(const V: TVarData; const Name: string; - const Value: TVarData): Boolean; override; - {$endif} - /// clear the content - // - this default implementation will set VType := varEmpty - // - override it if your custom type needs to manage its internal memory - procedure Clear(var V: TVarData); override; - /// copy two variant content - // - this default implementation will copy the TVarData memory - // - override it if your custom type needs to manage its internal structure - procedure Copy(var Dest: TVarData; const Source: TVarData; - const Indirect: Boolean); override; - /// copy two variant content by value - // - this default implementation will call the Copy() method - // - override it if your custom types may use a by reference copy pattern - procedure CopyByValue(var Dest: TVarData; const Source: TVarData); virtual; - /// this method will allow to look for dotted name spaces, e.g. 'parent.child' - // - should return Unassigned if the FullName does not match any value - // - will identify TDocVariant storage, or resolve and call the generic - // TSynInvokeableVariantType.IntGet() method until nested value match - procedure Lookup(var Dest: TVarData; const Instance: TVarData; FullName: PUTF8Char); - /// will check if the value is an array, and return the number of items - // - if the document is an array, will return the items count (0 meaning - // void array) - used e.g. by TSynMustacheContextVariant - // - this default implementation will return -1 (meaning this is not an array) - // - overridden method could implement it, e.g. for TDocVariant of kind dvArray - function IterateCount(const V: TVarData): integer; virtual; - /// allow to loop over an array document - // - Index should be in 0..IterateCount-1 range - // - this default implementation will do nothing - procedure Iterate(var Dest: TVarData; const V: TVarData; Index: integer); virtual; - /// returns TRUE if the supplied variant is of the exact custom type - function IsOfType(const V: variant): boolean; - {$ifdef HASINLINE}inline;{$endif} - end; - - /// class-reference type (metaclass) of custom variant type definition - // - used by SynRegisterCustomVariantType() function - TSynInvokeableVariantTypeClass = class of TSynInvokeableVariantType; - -/// register a custom variant type to handle properties -// - this will implement an internal mechanism used to bypass the default -// _DispInvoke() implementation in Variant.pas, to use a faster version -// - is called in case of TSynTableVariant, TDocVariant, TBSONVariant or -// TSQLDBRowVariant -function SynRegisterCustomVariantType(aClass: TSynInvokeableVariantTypeClass): TSynInvokeableVariantType; - -/// same as Dest := Source, but copying by reference -// - i.e. VType is defined as varVariant or varByRef -// - for instance, it will be used for late binding of TDocVariant properties, -// to let following statements work as expected: -// ! V := _Json('{arr:[1,2]}'); -// ! V.arr.Add(3); // will work, since V.arr will be returned by reference -// ! writeln(V); // will write '{"arr":[1,2,3]}' -procedure SetVariantByRef(const Source: Variant; var Dest: Variant); - -/// same as Dest := Source, but copying by value -// - will unreference any varByRef content -// - will convert any string value into RawUTF8 (varString) for consistency -procedure SetVariantByValue(const Source: Variant; var Dest: Variant); - -/// same as FillChar(Value^,SizeOf(TVarData),0) -// - so can be used for TVarData or Variant -// - it will set V.VType := varEmpty, so Value will be Unassigned -// - it won't call VarClear(variant(Value)): it should have been cleaned before -procedure ZeroFill(Value: PVarData); {$ifdef HASINLINE}inline;{$endif} - -/// fill all bytes of the value's memory buffer with zeros, i.e. 'toto' -> #0#0#0#0 -// - may be used to cleanup stack-allocated content -procedure FillZero(var value: variant); overload; - -/// retrieve a variant value from variable-length buffer -// - matches TFileBufferWriter.Write() -// - how custom type variants are created can be defined via CustomVariantOptions -// - is just a wrapper around VariantLoad() -procedure FromVarVariant(var Source: PByte; var Value: variant; - CustomVariantOptions: PDocVariantOptions=nil); {$ifdef HASINLINE}inline;{$endif} - -/// compute the number of bytes needed to save a Variant content -// using the VariantSave() function -// - will return 0 in case of an invalid (not handled) Variant type -function VariantSaveLength(const Value: variant): integer; - -/// save a Variant content into a destination memory buffer -// - Dest must be at least VariantSaveLength() bytes long -// - will handle standard Variant types and custom types (serialized as JSON) -// - will return nil in case of an invalid (not handled) Variant type -// - will use a proprietary binary format, with some variable-length encoding -// of the string length -// - warning: will encode generic string fields as within the variant type -// itself: using this function between UNICODE and NOT UNICODE -// versions of Delphi, will propably fail - you have been warned! -function VariantSave(const Value: variant; Dest: PAnsiChar): PAnsiChar; overload; - -/// save a Variant content into a binary buffer -// - will handle standard Variant types and custom types (serialized as JSON) -// - will return '' in case of an invalid (not handled) Variant type -// - just a wrapper around VariantSaveLength()+VariantSave() -// - warning: will encode generic string fields as within the variant type -// itself: using this function between UNICODE and NOT UNICODE -// versions of Delphi, will propably fail - you have been warned! -function VariantSave(const Value: variant): RawByteString; overload; - -/// retrieve a variant value from our optimized binary serialization format -// - follow the data layout as used by RecordLoad() or VariantSave() function -// - return nil if the Source buffer is incorrect -// - in case of success, return the memory buffer pointer just after the -// read content -// - how custom type variants are created can be defined via CustomVariantOptions -function VariantLoad(var Value: variant; Source: PAnsiChar; - CustomVariantOptions: PDocVariantOptions; SourceMax: PAnsiChar=nil): PAnsiChar; overload; - -/// retrieve a variant value from our optimized binary serialization format -// - follow the data layout as used by RecordLoad() or VariantSave() function -// - return varEmpty if the Source buffer is incorrect -// - just a wrapper around VariantLoad() -// - how custom type variants are created can be defined via CustomVariantOptions -function VariantLoad(const Bin: RawByteString; - CustomVariantOptions: PDocVariantOptions): variant; overload; - -/// retrieve a variant value from a JSON number or string -// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) -// - will instantiate either an Integer, Int64, currency, double or string value -// (as RawUTF8), guessing the best numeric type according to the textual content, -// and string in all other cases, except TryCustomVariants points to some options -// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or -// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some -// extended (e.g. BSON) syntax -// - warning: the JSON buffer will be modified in-place during process - use -// a temporary copy or the overloaded functions with RawUTF8 parameter -// if you need to access it later -function VariantLoadJSON(var Value: variant; JSON: PUTF8Char; - EndOfObject: PUTF8Char=nil; TryCustomVariants: PDocVariantOptions=nil; - AllowDouble: boolean=false): PUTF8Char; overload; - -/// retrieve a variant value from a JSON number or string -// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) -// - will instantiate either an Integer, Int64, currency, double or string value -// (as RawUTF8), guessing the best numeric type according to the textual content, -// and string in all other cases, except TryCustomVariants points to some options -// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or -// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some -// extended (e.g. BSON) syntax -// - this overloaded procedure will make a temporary copy before JSON parsing -// and return the variant as result -procedure VariantLoadJSON(var Value: Variant; const JSON: RawUTF8; - TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false); overload; - -/// retrieve a variant value from a JSON number or string -// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) -// - will instantiate either an Integer, Int64, currency, double or string value -// (as RawUTF8), guessing the best numeric type according to the textual content, -// and string in all other cases, except TryCustomVariants points to some options -// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or -// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some -// extended (e.g. BSON) syntax -// - this overloaded procedure will make a temporary copy before JSON parsing -// and return the variant as result -function VariantLoadJSON(const JSON: RawUTF8; - TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false): variant; overload; - -/// save a variant value into a JSON content -// - follows the TTextWriter.AddVariant() and VariantLoadJSON() format -// - is able to handle simple and custom variant types, for instance: -// ! VariantSaveJSON(1.5)='1.5' -// ! VariantSaveJSON('test')='"test"' -// ! o := _Json('{ BSON: [ "test", 5.05, 1986 ] }'); -// ! VariantSaveJSON(o)='{"BSON":["test",5.05,1986]}' -// ! o := _Obj(['name','John','doc',_Obj(['one',1,'two',_Arr(['one',2])])]); -// ! VariantSaveJSON(o)='{"name":"John","doc":{"one":1,"two":["one",2]}}' -// - note that before Delphi 2009, any varString value is expected to be -// a RawUTF8 instance - which does make sense in the mORMot area -function VariantSaveJSON(const Value: variant; Escape: TTextWriterKind=twJSONEscape): RawUTF8; overload; - -/// save a variant value into a JSON content -// - follows the TTextWriter.AddVariant() and VariantLoadJSON() format -// - is able to handle simple and custom variant types, for instance: -// ! VariantSaveJSON(1.5)='1.5' -// ! VariantSaveJSON('test')='"test"' -// ! o := _Json('{BSON: ["test", 5.05, 1986]}'); -// ! VariantSaveJSON(o)='{"BSON":["test",5.05,1986]}' -// ! o := _Obj(['name','John','doc',_Obj(['one',1,'two',_Arr(['one',2])])]); -// ! VariantSaveJSON(o)='{"name":"John","doc":{"one":1,"two":["one",2]}}' -// - note that before Delphi 2009, any varString value is expected to be -// a RawUTF8 instance - which does make sense in the mORMot area -procedure VariantSaveJSON(const Value: variant; Escape: TTextWriterKind; - var result: RawUTF8); overload; - -/// compute the number of chars needed to save a variant value into a JSON content -// - follows the TTextWriter.AddVariant() and VariantLoadJSON() format -// - this will be much faster than length(VariantSaveJSON()) for huge content -// - note that before Delphi 2009, any varString value is expected to be -// a RawUTF8 instance - which does make sense in the mORMot area -function VariantSaveJSONLength(const Value: variant; Escape: TTextWriterKind=twJSONEscape): integer; - -/// low-level function to set a variant from an unescaped JSON number or string -// - expect the JSON input buffer to be already unescaped, e.g. by GetJSONField() -// - is called e.g. by function VariantLoadJSON() -// - will instantiate either a null, boolean, Integer, Int64, currency, double -// (if AllowDouble is true or dvoAllowDoubleValue is in TryCustomVariants^) or -// string value (as RawUTF8), guessing the best numeric type according to the textual content, -// and string in all other cases, except if TryCustomVariants points to some -// options (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known -// object or array, either encoded as strict-JSON (i.e. {..} or [..]), -// or with some extended (e.g. BSON) syntax -procedure GetVariantFromJSON(JSON: PUTF8Char; wasString: Boolean; var Value: variant; - TryCustomVariants: PDocVariantOptions=nil; AllowDouble: boolean=false); - -/// low-level function to set a variant from an unescaped JSON non string -// - expect the JSON input buffer to be already unescaped, e.g. by GetJSONField(), -// and having returned wasString=TRUE (i.e. not surrounded by double quotes) -// - is called e.g. by function GetVariantFromJSON() -// - will recognize null, boolean, Integer, Int64, currency, double -// (if AllowDouble is true) input, then set Value and return TRUE -// - returns FALSE if the supplied input has no expected JSON format -function GetVariantFromNotStringJSON(JSON: PUTF8Char; var Value: TVarData; - AllowDouble: boolean): boolean; - -/// identify either varInt64, varDouble, varCurrency types following JSON format -// - any non valid number is returned as varString -// - is used e.g. by GetVariantFromJSON() to guess the destination variant type -// - warning: supplied JSON is expected to be not nil -function TextToVariantNumberType(JSON: PUTF8Char): cardinal; - -/// identify either varInt64 or varCurrency types following JSON format -// - this version won't return varDouble, i.e. won't handle more than 4 exact -// decimals (as varCurrency), nor scientific notation with exponent (1.314e10) -// - this will ensure that any incoming JSON will converted back with its exact -// textual representation, without digit truncation due to limited precision -// - any non valid number is returned as varString -// - is used e.g. by GetVariantFromJSON() to guess the destination variant type -// - warning: supplied JSON is expected to be not nil -function TextToVariantNumberTypeNoDouble(JSON: PUTF8Char): cardinal; - -/// low-level function to set a numerical variant from an unescaped JSON number -// - returns TRUE if TextToVariantNumberType/TextToVariantNumberTypeNoDouble(JSON) -// identified it as a number and set Value to the corresponding content -// - returns FALSE if JSON is a string, or null/true/false -function GetNumericVariantFromJSON(JSON: PUTF8Char; var Value: TVarData; - AllowVarDouble: boolean): boolean; - -/// convert the next CSV item from an UTF-8 encoded text buffer -// into a variant number or RawUTF8 varString -// - first try with GetNumericVariantFromJSON(), then fallback to RawUTF8ToVariant -// - is a wrapper around GetNextItem() + TextToVariant() -function GetNextItemToVariant(var P: PUTF8Char; out Value: Variant; - Sep: AnsiChar= ','; AllowDouble: boolean=true): boolean; - -/// retrieve a variant value from a JSON buffer as per RFC 8259, RFC 7159, RFC 7158 -// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) -// - will instantiate either an Integer, Int64, currency, double or string value -// (as RawUTF8), guessing the best numeric type according to the textual content, -// and string in all other cases, except TryCustomVariants points to some options -// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or -// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some -// extended (e.g. BSON) syntax -// - warning: the JSON buffer will be modified in-place during process - use -// a temporary copy or the overloaded functions with RawUTF8 parameter -// if you need to access it later -procedure JSONToVariantInPlace(var Value: Variant; JSON: PUTF8Char; - Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]; - AllowDouble: boolean=false); - -/// retrieve a variant value from a JSON UTF-8 text as per RFC 8259, RFC 7159, RFC 7158 -// - follows TTextWriter.AddVariant() format (calls GetVariantFromJSON) -// - will instantiate either an Integer, Int64, currency, double or string value -// (as RawUTF8), guessing the best numeric type according to the textual content, -// and string in all other cases, except TryCustomVariants points to some options -// (e.g. @JSON_OPTIONS[true] for fast instance) and input is a known object or -// array, either encoded as strict-JSON (i.e. {..} or [..]), or with some -// extended (e.g. BSON) syntax -// - this overloaded procedure will make a temporary copy before JSON parsing -// and return the variant as result -function JSONToVariant(const JSON: RawUTF8; - Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]; - AllowDouble: boolean=false): variant; - -/// convert an UTF-8 encoded text buffer into a variant number or RawUTF8 varString -// - first try with GetNumericVariantFromJSON(), then fallback to RawUTF8ToVariant -procedure TextToVariant(const aValue: RawUTF8; AllowVarDouble: boolean; - out aDest: variant); - -/// convert an UTF-8 encoded text buffer into a variant RawUTF8 varString -procedure RawUTF8ToVariant(Txt: PUTF8Char; TxtLen: integer; var Value: variant); overload; - -/// convert an UTF-8 encoded string into a variant RawUTF8 varString -procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: variant); overload; - -/// convert a FormatUTF8() UTF-8 encoded string into a variant RawUTF8 varString -procedure FormatUTF8ToVariant(const Fmt: RawUTF8; const Args: array of const; var Value: variant); - -/// convert an UTF-8 encoded string into a variant RawUTF8 varString -function RawUTF8ToVariant(const Txt: RawUTF8): variant; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert an UTF-8 encoded text buffer into a variant RawUTF8 varString -// - this overloaded version expects a destination variant type (e.g. varString -// varOleStr / varUString) - if the type is not handled, will raise an -// EVariantTypeCastError -procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: TVarData; - ExpectedValueType: cardinal); overload; - -/// convert an open array (const Args: array of const) argument to a variant -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -procedure VarRecToVariant(const V: TVarRec; var result: variant); overload; - -/// convert an open array (const Args: array of const) argument to a variant -// - note that, due to a Delphi compiler limitation, cardinal values should be -// type-casted to Int64() (otherwise the integer mapped value will be converted) -function VarRecToVariant(const V: TVarRec): variant; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a variant to an open array (const Args: array of const) argument -// - will always map to a vtVariant kind of argument -procedure VariantToVarRec(const V: variant; var result: TVarRec); - {$ifdef HASINLINE}inline;{$endif} - -/// convert a dynamic array of variants into its JSON serialization -// - will use a TDocVariantData temporary storage -function VariantDynArrayToJSON(const V: TVariantDynArray): RawUTF8; - -/// convert a JSON array into a dynamic array of variants -// - will use a TDocVariantData temporary storage -function JSONToVariantDynArray(const JSON: RawUTF8): TVariantDynArray; - -/// convert an open array list into a dynamic array of variants -// - will use a TDocVariantData temporary storage -function ValuesToVariantDynArray(const items: array of const): TVariantDynArray; - -type - /// pointer to a TDocVariant storage - // - since variants may be stored by reference (i.e. as varByRef), it may - // be a good idea to use such a pointer via DocVariantData(aVariant)^ or - // _Safe(aVariant)^ instead of TDocVariantData(aVariant), - // if you are not sure how aVariant was allocated (may be not _Obj/_Json) - PDocVariantData = ^TDocVariantData; - - /// a custom variant type used to store any JSON/BSON document-based content - // - i.e. name/value pairs for objects, or an array of values (including - // nested documents), stored in a TDocVariantData memory structure - // - you can use _Obj()/_ObjFast() _Arr()/_ArrFast() _Json()/_JsonFast() or - // _JsonFmt()/_JsonFastFmt() functions to create instances of such variants - // - property access may be done via late-binding - with some restrictions - // for older versions of FPC, e.g. allowing to write: - // ! TDocVariant.NewFast(aVariant); - // ! aVariant.Name := 'John'; - // ! aVariant.Age := 35; - // ! writeln(aVariant.Name,' is ',aVariant.Age,' years old'); - // - it also supports a small set of pseudo-properties or pseudo-methods: - // ! aVariant._Count = DocVariantData(aVariant).Count - // ! aVariant._Kind = ord(DocVariantData(aVariant).Kind) - // ! aVariant._JSON = DocVariantData(aVariant).JSON - // ! aVariant._(i) = DocVariantData(aVariant).Value[i] - // ! aVariant.Value(i) = DocVariantData(aVariant).Value[i] - // ! aVariant.Value(aName) = DocVariantData(aVariant).Value[aName] - // ! aVariant.Name(i) = DocVariantData(aVariant).Name[i] - // ! aVariant.Add(aItem) = DocVariantData(aVariant).AddItem(aItem) - // ! aVariant._ := aItem = DocVariantData(aVariant).AddItem(aItem) - // ! aVariant.Add(aName,aValue) = DocVariantData(aVariant).AddValue(aName,aValue) - // ! aVariant.Exists(aName) = DocVariantData(aVariant).GetValueIndex(aName)>=0 - // ! aVariant.Delete(i) = DocVariantData(aVariant).Delete(i) - // ! aVariant.Delete(aName) = DocVariantData(aVariant).Delete(aName) - // ! aVariant.NameIndex(aName) = DocVariantData(aVariant).GetValueIndex(aName) - // - it features direct JSON serialization/unserialization, e.g.: - // ! assert(_Json('["one",2,3]')._JSON='["one",2,3]'); - // - it features direct trans-typing into a string encoded as JSON, e.g.: - // ! assert(_Json('["one",2,3]')='["one",2,3]'); - TDocVariant = class(TSynInvokeableVariantType) - protected - /// name and values interning are shared among all TDocVariantData instances - fInternNames, fInternValues: TRawUTF8Interning; - /// fast getter/setter implementation - function IntGet(var Dest: TVarData; const Instance: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; override; - function IntSet(const Instance, Value: TVarData; Name: PAnsiChar; NameLen: PtrInt): boolean; override; - public - /// initialize a variant instance to store some document-based content - // - by default, every internal value will be copied, so access of nested - // properties can be slow - if you expect the data to be read-only or not - // propagated into another place, set aOptions=[dvoValueCopiedByReference] - // will increase the process speed a lot - class procedure New(out aValue: variant; - aOptions: TDocVariantOptions=[]); overload; - {$ifdef HASINLINE}inline;{$endif} - /// initialize a variant instance to store per-reference document-based content - // - same as New(aValue,JSON_OPTIONS[true]); - // - to be used e.g. as - // !var v: variant; - // !begin - // ! TDocVariant.NewFast(v); - // ! ... - class procedure NewFast(out aValue: variant); overload; - {$ifdef HASINLINE}inline;{$endif} - /// ensure a variant is a TDocVariant instance - // - if aValue is not a TDocVariant, will create a new JSON_OPTIONS[true] - class procedure IsOfTypeOrNewFast(var aValue: variant); - /// initialize several variant instances to store document-based content - // - replace several calls to TDocVariantData.InitFast - // - to be used e.g. as - // !var v1,v2,v3: TDocVariantData; - // !begin - // ! TDocVariant.NewFast([@v1,@v2,@v3]); - // ! ... - class procedure NewFast(const aValues: array of PDocVariantData); overload; - /// initialize a variant instance to store some document-based content - // - you can use this function to create a variant, which can be nested into - // another document, e.g.: - // ! aVariant := TDocVariant.New; - // ! aVariant.id := 10; - // - by default, every internal value will be copied, so access of nested - // properties can be slow - if you expect the data to be read-only or not - // propagated into another place, set Options=[dvoValueCopiedByReference] - // will increase the process speed a lot - // - in practice, you should better use _Obj()/_ObjFast() _Arr()/_ArrFast() - // functions or TDocVariant.NewFast() - class function New(Options: TDocVariantOptions=[]): variant; overload; - {$ifdef HASINLINE}inline;{$endif} - /// initialize a variant instance to store some document-based object content - // - object will be initialized with data supplied two by two, as Name,Value - // pairs, e.g. - // ! aVariant := TDocVariant.NewObject(['name','John','year',1972]); - // which is the same as: - // ! TDocVariant.New(aVariant); - // ! TDocVariantData(aVariant).AddValue('name','John'); - // ! TDocVariantData(aVariant).AddValue('year',1972); - // - by default, every internal value will be copied, so access of nested - // properties can be slow - if you expect the data to be read-only or not - // propagated into another place, set Options=[dvoValueCopiedByReference] - // will increase the process speed a lot - // - in practice, you should better use the function _Obj() which is a - // wrapper around this class method - class function NewObject(const NameValuePairs: array of const; - Options: TDocVariantOptions=[]): variant; - /// initialize a variant instance to store some document-based array content - // - array will be initialized with data supplied as parameters, e.g. - // ! aVariant := TDocVariant.NewArray(['one',2,3.0]); - // which is the same as: - // ! TDocVariant.New(aVariant); - // ! TDocVariantData(aVariant).AddItem('one'); - // ! TDocVariantData(aVariant).AddItem(2); - // ! TDocVariantData(aVariant).AddItem(3.0); - // - by default, every internal value will be copied, so access of nested - // properties can be slow - if you expect the data to be read-only or not - // propagated into another place, set aOptions=[dvoValueCopiedByReference] - // will increase the process speed a lot - // - in practice, you should better use the function _Arr() which is a - // wrapper around this class method - class function NewArray(const Items: array of const; - Options: TDocVariantOptions=[]): variant; overload; - /// initialize a variant instance to store some document-based array content - // - array will be initialized with data supplied dynamic array of variants - class function NewArray(const Items: TVariantDynArray; - Options: TDocVariantOptions=[]): variant; overload; - /// initialize a variant instance to store some document-based object content - // from a supplied (extended) JSON content - // - in addition to the JSON RFC specification strict mode, this method will - // handle some BSON-like extensions, e.g. unquoted field names - // - a private copy of the incoming JSON buffer will be used, then - // it will call the TDocVariantData.InitJSONInPlace() method - // - to be used e.g. as: - // ! var V: variant; - // ! begin - // ! V := TDocVariant.NewJSON('{"id":10,"doc":{"name":"John","birthyear":1972}}'); - // ! assert(V.id=10); - // ! assert(V.doc.name='John'); - // ! assert(V.doc.birthYear=1972); - // ! // and also some pseudo-properties: - // ! assert(V._count=2); - // ! assert(V.doc._kind=ord(dvObject)); - // - or with a JSON array: - // ! V := TDocVariant.NewJSON('["one",2,3]'); - // ! assert(V._kind=ord(dvArray)); - // ! for i := 0 to V._count-1 do - // ! writeln(V._(i)); - // - by default, every internal value will be copied, so access of nested - // properties can be slow - if you expect the data to be read-only or not - // propagated into another place, add dvoValueCopiedByReference in Options - // will increase the process speed a lot - // - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency - // - in practice, you should better use the function _Json()/_JsonFast() - // which are handy wrappers around this class method - class function NewJSON(const JSON: RawUTF8; - Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; - {$ifdef HASINLINE}inline;{$endif} - /// initialize a variant instance to store some document-based object content - // from a supplied existing TDocVariant instance - // - use it on a value returned as varByRef (e.g. by _() pseudo-method), - // to ensure the returned variant will behave as a stand-alone value - // - for instance, the following: - // ! oSeasons := TDocVariant.NewUnique(o.Seasons); - // is the same as: - // ! oSeasons := o.Seasons; - // ! _Unique(oSeasons); - // or even: - // ! oSeasons := _Copy(o.Seasons); - class function NewUnique(const SourceDocVariant: variant; - Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; - {$ifdef HASINLINE}inline;{$endif} - /// will return the unique element of a TDocVariant array or a default - // - if the value is a dvArray with one single item, it will this value - // - if the value is not a TDocVariant nor a dvArray with one single item, - // it wil return the default value - class procedure GetSingleOrDefault(const docVariantArray, default: variant; - var result: variant); - - /// finalize the stored information - destructor Destroy; override; - /// used by dvoInternNames for string interning of all Names[] values - function InternNames: TRawUTF8Interning; {$ifdef HASINLINE}inline;{$endif} - /// used by dvoInternValues for string interning of all RawUTF8 Values[] - function InternValues: TRawUTF8Interning; {$ifdef HASINLINE}inline;{$endif} - // this implementation will write the content as JSON object or array - procedure ToJSON(W: TTextWriter; const Value: variant; Escape: TTextWriterKind); override; - /// will check if the value is an array, and return the number of items - // - if the document is an array, will return the items count (0 meaning - // void array) - used e.g. by TSynMustacheContextVariant - // - this overridden method will implement it for dvArray instance kind - function IterateCount(const V: TVarData): integer; override; - /// allow to loop over an array document - // - Index should be in 0..IterateCount-1 range - // - this default implementation will do handle dvArray instance kind - procedure Iterate(var Dest: TVarData; const V: TVarData; Index: integer); override; - /// low-level callback to access internal pseudo-methods - // - mainly the _(Index: integer): variant method to retrieve an item - // if the document is an array - function DoFunction(var Dest: TVarData; const V: TVarData; - const Name: string; const Arguments: TVarDataArray): Boolean; override; - /// low-level callback to clear the content - procedure Clear(var V: TVarData); override; - /// low-level callback to copy two variant content - // - such copy will by default be done by-value, for safety - // - if you are sure you will use the variants as read-only, you can set - // the dvoValueCopiedByReference Option to use faster by-reference copy - procedure Copy(var Dest: TVarData; const Source: TVarData; - const Indirect: Boolean); override; - /// copy two variant content by value - // - overridden method since instance may use a by-reference copy pattern - procedure CopyByValue(var Dest: TVarData; const Source: TVarData); override; - /// handle type conversion - // - only types processed by now are string/OleStr/UnicodeString/date - procedure Cast(var Dest: TVarData; const Source: TVarData); override; - /// handle type conversion - // - only types processed by now are string/OleStr/UnicodeString/date - procedure CastTo(var Dest: TVarData; const Source: TVarData; - const AVarType: TVarType); override; - /// compare two variant values - // - it uses case-sensitive text comparison of the JSON representation - // of each variant (including TDocVariant instances) - procedure Compare(const Left, Right: TVarData; - var Relationship: TVarCompareResult); override; - end; - - /// define the TDocVariant storage layout - // - if it has one or more named properties, it is a dvObject - // - if it has no name property, it is a dvArray - TDocVariantKind = (dvUndefined, dvObject, dvArray); - - /// method used by TDocVariantData.ReduceAsArray to filter each object - // - should return TRUE if the item match the expectations - TOnReducePerItem = function(Item: PDocVariantData): boolean of object; - - /// method used by TDocVariantData.ReduceAsArray to filter each object - // - should return TRUE if the item match the expectations - TOnReducePerValue = function(const Value: variant): boolean of object; - - {$A-} { packet object not allowed since Delphi 2009 :( } - /// memory structure used for TDocVariant storage of any JSON/BSON - // document-based content as variant - // - i.e. name/value pairs for objects, or an array of values (including - // nested documents) - // - you can use _Obj()/_ObjFast() _Arr()/_ArrFast() _Json()/_JsonFast() or - // _JsonFmt()/_JsonFastFmt() functions to create instances of such variants - // - you can transtype such an allocated variant into TDocVariantData - // to access directly its internals (like Count or Values[]/Names[]): - // ! aVariantObject := TDocVariant.NewObject(['name','John','year',1972]); - // ! aVariantObject := _ObjFast(['name','John','year',1972]); - // ! with _Safe(aVariantObject)^ do - // ! for i := 0 to Count-1 do - // ! writeln(Names[i],'=',Values[i]); // for an object - // ! aVariantArray := TDocVariant.NewArray(['one',2,3.0]); - // ! aVariantArray := _JsonFast('["one",2,3.0]'); - // ! with _Safe(aVariantArray)^ do - // ! for i := 0 to Count-1 do - // ! writeln(Values[i]); // for an array - // - use "with _Safe(...)^ do" and not "with TDocVariantData(...) do" as the - // former will handle internal variant redirection (varByRef), e.g. from late - // binding or assigned another TDocVariant - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}TDocVariantData = record - {$else}TDocVariantData = object {$endif} - private - VType: TVarType; - VOptions: TDocVariantOptions; - (* this structure uses all TVarData available space: no filler needed! - {$HINTS OFF} // does not complain if Filler is declared but never used - Filler: array[1..SizeOf(TVarData)-SizeOf(TVarType)-SizeOf(TDocVariantOptions)- - SizeOf(TDocVariantKind)-SizeOf(TRawUTF8DynArray)-SizeOf(TVariantDynArray)- - SizeOf(integer)] of byte; - {$HINTS ON} *) - VName: TRawUTF8DynArray; - VValue: TVariantDynArray; - VCount: integer; - // retrieve the value as varByRef - function GetValueOrItem(const aNameOrIndex: variant): variant; - procedure SetValueOrItem(const aNameOrIndex, aValue: variant); - function GetKind: TDocVariantKind; {$ifdef HASINLINE}inline;{$endif} - procedure SetOptions(const opt: TDocVariantOptions); // keep dvoIsObject/Array - {$ifdef HASINLINE}inline;{$endif} - procedure SetCapacity(aValue: integer); - function GetCapacity: integer; - {$ifdef HASINLINE}inline;{$endif} - // implement U[] I[] B[] D[] O[] O_[] A[] A_[] _[] properties - function GetOrAddIndexByName(const aName: RawUTF8): integer; - {$ifdef HASINLINE}inline;{$endif} - function GetOrAddPVariantByName(const aName: RawUTF8): PVariant; - {$ifdef HASINLINE}inline;{$endif} - function GetPVariantByName(const aName: RawUTF8): PVariant; - function GetRawUTF8ByName(const aName: RawUTF8): RawUTF8; - procedure SetRawUTF8ByName(const aName, aValue: RawUTF8); - function GetStringByName(const aName: RawUTF8): string; - procedure SetStringByName(const aName: RawUTF8; const aValue: string); - function GetInt64ByName(const aName: RawUTF8): Int64; - procedure SetInt64ByName(const aName: RawUTF8; const aValue: Int64); - function GetBooleanByName(const aName: RawUTF8): Boolean; - procedure SetBooleanByName(const aName: RawUTF8; aValue: Boolean); - function GetDoubleByName(const aName: RawUTF8): Double; - procedure SetDoubleByName(const aName: RawUTF8; const aValue: Double); - function GetDocVariantExistingByName(const aName: RawUTF8; - aNotMatchingKind: TDocVariantKind): PDocVariantData; - function GetObjectExistingByName(const aName: RawUTF8): PDocVariantData; - function GetDocVariantOrAddByName(const aName: RawUTF8; - aKind: TDocVariantKind): PDocVariantData; - function GetObjectOrAddByName(const aName: RawUTF8): PDocVariantData; - function GetArrayExistingByName(const aName: RawUTF8): PDocVariantData; - function GetArrayOrAddByName(const aName: RawUTF8): PDocVariantData; - function GetAsDocVariantByIndex(aIndex: integer): PDocVariantData; - public - /// initialize a TDocVariantData to store some document-based content - // - can be used with a stack-allocated TDocVariantData variable: - // !var Doc: TDocVariantData; // stack-allocated variable - // !begin - // ! Doc.Init; - // ! Doc.AddValue('name','John'); - // ! assert(Doc.Value['name']='John'); - // ! assert(variant(Doc).name='John'); - // !end; - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure Init(aOptions: TDocVariantOptions=[]; aKind: TDocVariantKind=dvUndefined); - /// initialize a TDocVariantData to store per-reference document-based content - // - same as Doc.Init(JSON_OPTIONS[true]); - // - can be used with a stack-allocated TDocVariantData variable: - // !var Doc: TDocVariantData; // stack-allocated variable - // !begin - // ! Doc.InitFast; - // ! Doc.AddValue('name','John'); - // ! assert(Doc.Value['name']='John'); - // ! assert(variant(Doc).name='John'); - // !end; - // - see also TDocVariant.NewFast() if you want to initialize several - // TDocVariantData variable instances at once - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitFast; overload; - /// initialize a TDocVariantData to store per-reference document-based content - // - this overloaded method allows to specify an estimation of how many - // properties or items this aKind document would contain - procedure InitFast(InitialCapacity: integer; aKind: TDocVariantKind); overload; - /// initialize a TDocVariantData to store document-based object content - // - object will be initialized with data supplied two by two, as Name,Value - // pairs, e.g. - // !var Doc: TDocVariantData; // stack-allocated variable - // !begin - // ! Doc.InitObject(['name','John','year',1972]); - // which is the same as: - // ! var Doc: TDocVariantData; - // !begin - // ! Doc.Init; - // ! Doc.AddValue('name','John'); - // ! Doc.AddValue('year',1972); - // - this method is called e.g. by _Obj() and _ObjFast() global functions - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitObject(const NameValuePairs: array of const; - aOptions: TDocVariantOptions=[]); - /// initialize a variant instance to store some document-based array content - // - array will be initialized with data supplied as parameters, e.g. - // !var Doc: TDocVariantData; // stack-allocated variable - // !begin - // ! Doc.InitArray(['one',2,3.0]); - // ! assert(Doc.Count=3); - // !end; - // which is the same as: - // ! var Doc: TDocVariantData; - // ! i: integer; - // !begin - // ! Doc.Init; - // ! Doc.AddItem('one'); - // ! Doc.AddItem(2); - // ! Doc.AddItem(3.0); - // ! assert(Doc.Count=3); - // ! for i := 0 to Doc.Count-1 do - // ! writeln(Doc.Value[i]); - // !end; - // - this method is called e.g. by _Arr() and _ArrFast() global functions - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitArray(const Items: array of const; - aOptions: TDocVariantOptions=[]); - /// initialize a variant instance to store some document-based array content - // - array will be initialized with data supplied as variant dynamic array - // - if Items is [], the variant will be set as null - // - will be almost immediate, since TVariantDynArray is reference-counted, - // unless ItemsCopiedByReference is set to FALSE - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitArrayFromVariants(const Items: TVariantDynArray; - aOptions: TDocVariantOptions=[]; ItemsCopiedByReference: boolean=true); - /// initialize a variant instance to store some RawUTF8 array content - procedure InitArrayFrom(const Items: TRawUTF8DynArray; aOptions: TDocVariantOptions); overload; - /// initialize a variant instance to store some 32-bit integer array content - procedure InitArrayFrom(const Items: TIntegerDynArray; aOptions: TDocVariantOptions); overload; - /// initialize a variant instance to store some 64-bit integer array content - procedure InitArrayFrom(const Items: TInt64DynArray; aOptions: TDocVariantOptions); overload; - /// initialize a variant instance to store a T*ObjArray content - // - will call internally ObjectToVariant() to make the conversion - procedure InitArrayFromObjArray(const ObjArray; aOptions: TDocVariantOptions; - aWriterOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]); - /// initialize a variant instance to store document-based array content - // - array will be initialized from the supplied variable (which would be - // e.g. a T*ObjArray or a dynamic array), using RTTI - // - will use a temporary JSON serialization via SaveJSON() - procedure InitFromTypeInfo(const aValue; aTypeInfo: pointer; - aEnumSetsAsText: boolean; aOptions: TDocVariantOptions); - /// initialize a variant instance to store some document-based object content - // - object will be initialized with names and values supplied as dynamic arrays - // - if aNames and aValues are [] or do have matching sizes, the variant - // will be set as null - // - will be almost immediate, since Names and Values are reference-counted - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitObjectFromVariants(const aNames: TRawUTF8DynArray; - const aValues: TVariantDynArray; aOptions: TDocVariantOptions=[]); - /// initialize a variant instance to store a document-based object with a - // single property - // - the supplied path could be 'Main.Second.Third', to create nested - // objects, e.g. {"Main":{"Second":{"Third":value}}} - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitObjectFromPath(const aPath: RawUTF8; const aValue: variant; - aOptions: TDocVariantOptions=[]); - /// initialize a variant instance to store some document-based object content - // from a supplied JSON array or JSON object content - // - warning: the incoming JSON buffer will be modified in-place: so you should - // make a private copy before running this method, e.g. using TSynTempBuffer - // - this method is called e.g. by _JsonFmt() _JsonFastFmt() global functions - // with a temporary JSON buffer content created from a set of parameters - // - if you call Init*() methods in a row, ensure you call Clear in-between - function InitJSONInPlace(JSON: PUTF8Char; - aOptions: TDocVariantOptions=[]; aEndOfObject: PUTF8Char=nil): PUTF8Char; - /// initialize a variant instance to store some document-based object content - // from a supplied JSON array of JSON object content - // - a private copy of the incoming JSON buffer will be used, then - // it will call the other overloaded InitJSONInPlace() method - // - this method is called e.g. by _Json() and _JsonFast() global functions - // - if you call Init*() methods in a row, ensure you call Clear in-between - function InitJSON(const JSON: RawUTF8; aOptions: TDocVariantOptions=[]): boolean; - /// initialize a variant instance to store some document-based object content - // from a JSON array of JSON object content, stored in a file - // - any kind of file encoding will be handled, via AnyTextFileToRawUTF8() - // - you can optionally remove any comment from the file content - // - if you call Init*() methods in a row, ensure you call Clear in-between - function InitJSONFromFile(const JsonFile: TFileName; aOptions: TDocVariantOptions=[]; - RemoveComments: boolean=false): boolean; - /// ensure a document-based variant instance will have one unique options set - // - this will create a copy of the supplied TDocVariant instance, forcing - // all nested events to have the same set of Options - // - you can use this function to ensure that all internal properties of this - // variant will be copied e.g. per-reference (if you set JSON_OPTIONS[false]) - // or per-value (if you set JSON_OPTIONS[false]) whatever options the nested - // objects or arrays were created with - // - will raise an EDocVariant if the supplied variant is not a TDocVariant - // - you may rather use _Unique() or _UniqueFast() wrappers if you want to - // ensure that a TDocVariant instance is unique - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitCopy(const SourceDocVariant: variant; aOptions: TDocVariantOptions); - /// initialize a variant instance to store some document-based object content - // from a supplied CSV UTF-8 encoded text - // - the supplied content may have been generated by ToTextPairs() method - // - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitCSV(CSV: PUTF8Char; aOptions: TDocVariantOptions; - NameValueSep: AnsiChar='='; ItemSep: AnsiChar=#10; DoTrim: boolean=true); overload; - /// initialize a variant instance to store some document-based object content - // from a supplied CSV UTF-8 encoded text - // - the supplied content may have been generated by ToTextPairs() method - // - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled - // - if you call Init*() methods in a row, ensure you call Clear in-between - procedure InitCSV(const CSV: RawUTF8; aOptions: TDocVariantOptions; - NameValueSep: AnsiChar='='; ItemSep: AnsiChar=#10; DoTrim: boolean=true); overload; - {$ifdef HASINLINE}inline;{$endif} - - /// to be called before any Init*() method call, when a previous Init*() - // has already be performed on the same instance, to avoid memory leaks - // - for instance: - // !var Doc: TDocVariantData; // stack-allocated variable - // !begin - // ! Doc.InitArray(['one',2,3.0]); // no need of any Doc.Clear here - // ! assert(Doc.Count=3); - // ! Doc.Clear; // to release memory before following InitObject() - // ! Doc.InitObject(['name','John','year',1972]); - // !end; - // - implemented as just a wrapper around DocVariantType.Clear() - procedure Clear; - /// delete all internal stored values - // - like Clear + Init() with the same options - // - will reset Kind to dvUndefined - procedure Reset; - /// fill all Values[] with #0, then delete all values - // - could be used to specifically remove sensitive information from memory - procedure FillZero; - /// low-level method to force a number of items - // - could be used to fast add items to the internal Values[]/Names[] arrays - // - just set protected VCount field, do not resize the arrays: caller - // should ensure that Capacity is big enough - procedure SetCount(aCount: integer); {$ifdef HASINLINE}inline;{$endif} - /// low-level method called internally to reserve place for new values - // - returns the index of the newly created item in Values[]/Names[] arrays - // - you should not have to use it, unless you want to add some items - // directly within the Values[]/Names[] arrays, using e.g. - // InitFast(InitialCapacity) to initialize the document - // - if aName='', append a dvArray item, otherwise append a dvObject field - // - warning: FPC optimizer is confused by Values[InternalAdd(name)] so - // you should call InternalAdd() in an explicit previous step - function InternalAdd(const aName: RawUTF8): integer; - - /// save a document as UTF-8 encoded JSON - // - will write either a JSON object or array, depending of the internal - // layout of this instance (i.e. Kind property value) - // - will write 'null' if Kind is dvUndefined - // - implemented as just a wrapper around VariantSaveJSON() - function ToJSON(const Prefix: RawUTF8=''; const Suffix: RawUTF8=''; - Format: TTextWriterJSONFormat=jsonCompact): RawUTF8; - /// save an array of objects as UTF-8 encoded non expanded layout JSON - // - returned content would be a JSON object in mORMot's TSQLTable non - // expanded format, with reduced JSON size, i.e. - // $ {"fieldCount":3,"values":["ID","FirstName","LastName",...']} - // - will write '' if Kind is dvUndefined or dvObject - // - will raise an exception if the array document is not an array of - // objects with identical field names - function ToNonExpandedJSON: RawUTF8; - /// save a document as an array of UTF-8 encoded JSON - // - will expect the document to be a dvArray - otherwise, will raise a - // EDocVariant exception - // - will use VariantToUTF8() to populate the result array: as a consequence, - // any nested custom variant types (e.g. TDocVariant) will be stored as JSON - procedure ToRawUTF8DynArray(out Result: TRawUTF8DynArray); overload; - /// save a document as an array of UTF-8 encoded JSON - // - will expect the document to be a dvArray - otherwise, will raise a - // EDocVariant exception - // - will use VariantToUTF8() to populate the result array: as a consequence, - // any nested custom variant types (e.g. TDocVariant) will be stored as JSON - function ToRawUTF8DynArray: TRawUTF8DynArray; overload; - {$ifdef HASINLINE}inline;{$endif} - /// save a document as an CSV of UTF-8 encoded JSON - // - will expect the document to be a dvArray - otherwise, will raise a - // EDocVariant exception - // - will use VariantToUTF8() to populate the result array: as a consequence, - // any nested custom variant types (e.g. TDocVariant) will be stored as JSON - function ToCSV(const Separator: RawUTF8=','): RawUTF8; - /// save a document as UTF-8 encoded Name=Value pairs - // - will follow by default the .INI format, but you can specify your - // own expected layout - procedure ToTextPairsVar(out result: RawUTF8; const NameValueSep: RawUTF8='='; - const ItemSep: RawUTF8=#13#10; Escape: TTextWriterKind=twJSONEscape); - /// save a document as UTF-8 encoded Name=Value pairs - // - will follow by default the .INI format, but you can specify your - // own expected layout - function ToTextPairs(const NameValueSep: RawUTF8='='; - const ItemSep: RawUTF8=#13#10; Escape: TTextWriterKind=twJSONEscape): RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - /// save an array document as an array of TVarRec, i.e. an array of const - // - will expect the document to be a dvArray - otherwise, will raise a - // EDocVariant exception - // - would allow to write code as such: - // ! Doc.InitArray(['one',2,3]); - // ! Doc.ToArrayOfConst(vr); - // ! s := FormatUTF8('[%,%,%]',vr,[],true); - // ! // here s='[one,2,3]') since % would be replaced by Args[] parameters - // ! s := FormatUTF8('[?,?,?]',[],vr,true); - // ! // here s='["one",2,3]') since ? would be escaped by Params[] parameters - procedure ToArrayOfConst(out Result: TTVarRecDynArray); overload; - /// save an array document as an array of TVarRec, i.e. an array of const - // - will expect the document to be a dvArray - otherwise, will raise a - // EDocVariant exception - // - would allow to write code as such: - // ! Doc.InitArray(['one',2,3]); - // ! s := FormatUTF8('[%,%,%]',Doc.ToArrayOfConst,[],true); - // ! // here s='[one,2,3]') since % would be replaced by Args[] parameters - // ! s := FormatUTF8('[?,?,?]',[],Doc.ToArrayOfConst,true); - // ! // here s='["one",2,3]') since ? would be escaped by Params[] parameters - function ToArrayOfConst: TTVarRecDynArray; overload; - {$ifdef HASINLINE}inline;{$endif} - /// save an object document as an URI-encoded list of parameters - // - object field names should be plain ASCII-7 RFC compatible identifiers - // (0..9a..zA..Z_.~), otherwise their values are skipped - function ToUrlEncode(const UriRoot: RawUTF8): RawUTF8; - - /// find an item index in this document from its name - // - search will follow dvoNameCaseSensitive option of this document - // - lookup the value by name for an object document, or accept an integer - // text as index for an array document - // - returns -1 if not found - function GetValueIndex(const aName: RawUTF8): integer; overload; - {$ifdef HASINLINE}inline;{$endif} - /// find an item index in this document from its name - // - lookup the value by name for an object document, or accept an integer - // text as index for an array document - // - returns -1 if not found - function GetValueIndex(aName: PUTF8Char; aNameLen: PtrInt; aCaseSensitive: boolean): integer; overload; - /// find an item in this document, and returns its value - // - raise an EDocVariant if not found and dvoReturnNullForUnknownProperty - // is not set in Options (in this case, it will return Null) - function GetValueOrRaiseException(const aName: RawUTF8): variant; - /// find an item in this document, and returns its value - // - return the supplied default if aName is not found, or if the instance - // is not a TDocVariant - function GetValueOrDefault(const aName: RawUTF8; const aDefault: variant): variant; - /// find an item in this document, and returns its value - // - return null if aName is not found, or if the instance is not a TDocVariant - function GetValueOrNull(const aName: RawUTF8): variant; - /// find an item in this document, and returns its value - // - return a cleared variant if aName is not found, or if the instance is - // not a TDocVariant - function GetValueOrEmpty(const aName: RawUTF8): variant; - /// find an item in this document, and returns its value as enumerate - // - return false if aName is not found, if the instance is not a TDocVariant, - // or if the value is not a string corresponding to the supplied enumerate - // - return true if the name has been found, and aValue stores the value - // - will call Delete() on the found entry, if aDeleteFoundEntry is true - function GetValueEnumerate(const aName: RawUTF8; aTypeInfo: pointer; - out aValue; aDeleteFoundEntry: boolean=false): Boolean; - /// returns a TDocVariant object containing all properties matching the - // first characters of the supplied property name - // - returns null if the document is not a dvObject - // - will use IdemPChar(), so search would be case-insensitive - function GetValuesByStartName(const aStartName: RawUTF8; - TrimLeftStartName: boolean=false): variant; - /// returns a JSON object containing all properties matching the - // first characters of the supplied property name - // - returns null if the document is not a dvObject - // - will use IdemPChar(), so search would be case-insensitive - function GetJsonByStartName(const aStartName: RawUTF8): RawUTF8; - /// find an item in this document, and returns its value as TVarData - // - return false if aName is not found, or if the instance is not a TDocVariant - // - return true and set aValue if the name has been found - // - will use simple loop lookup to identify the name, unless aSortedCompare is - // set, and would let use a faster O(log(n)) binary search after a SortByName() - function GetVarData(const aName: RawUTF8; var aValue: TVarData; - aSortedCompare: TUTF8Compare=nil): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - /// find an item in this document, and returns its value as TVarData pointer - // - return nil if aName is not found, or if the instance is not a TDocVariant - // - return a pointer to the value if the name has been found - // - after a SortByName(aSortedCompare), could use faster binary search - function GetVarData(const aName: RawUTF8; - aSortedCompare: TUTF8Compare=nil): PVarData; overload; - /// find an item in this document, and returns its value as boolean - // - return false if aName is not found, or if the instance is not a TDocVariant - // - return true if the name has been found, and aValue stores the value - // - after a SortByName(aSortedCompare), could use faster binary search - // - consider using B[] property if you want simple read/write typed access - function GetAsBoolean(const aName: RawUTF8; out aValue: boolean; - aSortedCompare: TUTF8Compare=nil): Boolean; - /// find an item in this document, and returns its value as integer - // - return false if aName is not found, or if the instance is not a TDocVariant - // - return true if the name has been found, and aValue stores the value - // - after a SortByName(aSortedCompare), could use faster binary search - // - consider using I[] property if you want simple read/write typed access - function GetAsInteger(const aName: RawUTF8; out aValue: integer; - aSortedCompare: TUTF8Compare=nil): Boolean; - /// find an item in this document, and returns its value as integer - // - return false if aName is not found, or if the instance is not a TDocVariant - // - return true if the name has been found, and aValue stores the value - // - after a SortByName(aSortedCompare), could use faster binary search - // - consider using I[] property if you want simple read/write typed access - function GetAsInt64(const aName: RawUTF8; out aValue: Int64; - aSortedCompare: TUTF8Compare=nil): Boolean; - /// find an item in this document, and returns its value as floating point - // - return false if aName is not found, or if the instance is not a TDocVariant - // - return true if the name has been found, and aValue stores the value - // - after a SortByName(aSortedCompare), could use faster binary search - // - consider using D[] property if you want simple read/write typed access - function GetAsDouble(const aName: RawUTF8; out aValue: double; - aSortedCompare: TUTF8Compare=nil): Boolean; - /// find an item in this document, and returns its value as RawUTF8 - // - return false if aName is not found, or if the instance is not a TDocVariant - // - return true if the name has been found, and aValue stores the value - // - after a SortByName(aSortedCompare), could use faster binary search - // - consider using U[] property if you want simple read/write typed access - function GetAsRawUTF8(const aName: RawUTF8; out aValue: RawUTF8; - aSortedCompare: TUTF8Compare=nil): Boolean; - /// find an item in this document, and returns its value as a TDocVariantData - // - return false if aName is not found, or if the instance is not a TDocVariant - // - return true if the name has been found and points to a TDocVariant: - // then aValue stores a pointer to the value - // - after a SortByName(aSortedCompare), could use faster binary search - function GetAsDocVariant(const aName: RawUTF8; out aValue: PDocVariantData; - aSortedCompare: TUTF8Compare=nil): boolean; overload; - /// find an item in this document, and returns its value as a TDocVariantData - // - returns a void TDocVariant if aName is not a document - // - after a SortByName(aSortedCompare), could use faster binary search - // - consider using O[] or A[] properties if you want simple read-only - // access, or O_[] or A_[] properties if you want the ability to add - // a missing object or array in the document - function GetAsDocVariantSafe(const aName: RawUTF8; - aSortedCompare: TUTF8Compare=nil): PDocVariantData; - /// find an item in this document, and returns pointer to its value - // - return false if aName is not found - // - return true if the name has been found: then aValue stores a pointer - // to the value - // - after a SortByName(aSortedCompare), could use faster binary search - function GetAsPVariant(const aName: RawUTF8; out aValue: PVariant; - aSortedCompare: TUTF8Compare=nil): boolean; overload; {$ifdef HASINLINE}inline;{$endif} - /// find an item in this document, and returns pointer to its value - // - lookup the value by aName/aNameLen for an object document, or accept - // an integer text as index for an array document - // - return nil if aName is not found, or if the instance is not a TDocVariant - // - return a pointer to the stored variant, if the name has been found - function GetAsPVariant(aName: PUTF8Char; aNameLen: PtrInt): PVariant; overload; - {$ifdef HASINLINE}inline;{$endif} - /// retrieve a value, given its path - // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' - // - it will return Unassigned if the path does match the supplied aPath - function GetValueByPath(const aPath: RawUTF8): variant; overload; - /// retrieve a value, given its path - // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' - // - it will return FALSE if the path does not match the supplied aPath - // - returns TRUE and set the found value in aValue - function GetValueByPath(const aPath: RawUTF8; out aValue: variant): boolean; overload; - /// retrieve a value, given its path - // - path is defined as a list of names, e.g. ['doc','glossary','title'] - // - it will return Unassigned if the path does not match the data - // - this method will only handle nested TDocVariant values: use the - // slightly slower GetValueByPath() overloaded method, if any nested object - // may be of another type (e.g. a TBSONVariant) - function GetValueByPath(const aDocVariantPath: array of RawUTF8): variant; overload; - /// retrieve a reference to a value, given its path - // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' - // - if the supplied aPath does not match any object, it will return nil - // - if aPath is found, returns a pointer to the corresponding value - function GetPVariantByPath(const aPath: RawUTF8): PVariant; - /// retrieve a reference to a TDocVariant, given its path - // - path is defined as a dotted name-space, e.g. 'doc.glossary.title' - // - if the supplied aPath does not match any object, it will return false - // - if aPath stores a valid TDocVariant, returns true and a pointer to it - function GetDocVariantByPath(const aPath: RawUTF8; out aValue: PDocVariantData): boolean; - /// retrieve a dvObject in the dvArray, from a property value - // - {aPropName:aPropValue} will be searched within the stored array, - // and the corresponding item will be copied into Dest, on match - // - returns FALSE if no match is found, TRUE if found and copied - // - create a copy of the variant by default, unless DestByRef is TRUE - // - will call VariantEquals() for value comparison - function GetItemByProp(const aPropName,aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean; var Dest: variant; DestByRef: boolean=false): boolean; - /// retrieve a reference to a dvObject in the dvArray, from a property value - // - {aPropName:aPropValue} will be searched within the stored array, - // and the corresponding item will be copied into Dest, on match - // - returns FALSE if no match is found, TRUE if found and copied by reference - function GetDocVariantByProp(const aPropName,aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean; out Dest: PDocVariantData): boolean; - /// find an item in this document, and returns its value - // - raise an EDocVariant if not found and dvoReturnNullForUnknownProperty - // is not set in Options (in this case, it will return Null) - // - create a copy of the variant by default, unless DestByRef is TRUE - function RetrieveValueOrRaiseException(aName: PUTF8Char; aNameLen: integer; - aCaseSensitive: boolean; var Dest: variant; DestByRef: boolean): boolean; overload; - /// retrieve an item in this document from its index, and returns its value - // - raise an EDocVariant if the supplied Index is not in the 0..Count-1 - // range and dvoReturnNullForUnknownProperty is set in Options - // - create a copy of the variant by default, unless DestByRef is TRUE - procedure RetrieveValueOrRaiseException(Index: integer; - var Dest: variant; DestByRef: boolean); overload; - /// retrieve an item in this document from its index, and returns its Name - // - raise an EDocVariant if the supplied Index is not in the 0..Count-1 - // range and dvoReturnNullForUnknownProperty is set in Options - procedure RetrieveNameOrRaiseException(Index: integer; var Dest: RawUTF8); - /// set an item in this document from its index - // - raise an EDocVariant if the supplied Index is not in 0..Count-1 range - procedure SetValueOrRaiseException(Index: integer; const NewValue: variant); - - /// add a value in this document - // - if aName is set, if dvoCheckForDuplicatedNames option is set, any - // existing duplicated aName will raise an EDocVariant; if instance's - // kind is dvArray and aName is defined, it will raise an EDocVariant - // - aName may be '' e.g. if you want to store an array: in this case, - // dvoCheckForDuplicatedNames option should not be set; if instance's Kind - // is dvObject, it will raise an EDocVariant exception - // - if aValueOwned is true, then the supplied aValue will be assigned to - // the internal values - by default, it will use SetVariantByValue() - // - you can therefore write e.g.: - // ! TDocVariant.New(aVariant); - // ! Assert(TDocVariantData(aVariant).Kind=dvUndefined); - // ! TDocVariantData(aVariant).AddValue('name','John'); - // ! Assert(TDocVariantData(aVariant).Kind=dvObject); - // - returns the index of the corresponding newly added value - function AddValue(const aName: RawUTF8; const aValue: variant; - aValueOwned: boolean=false): integer; overload; - /// add a value in this document - // - overloaded function accepting a UTF-8 encoded buffer for the name - function AddValue(aName: PUTF8Char; aNameLen: integer; const aValue: variant; - aValueOwned: boolean=false): integer; overload; - /// add a value in this document, or update an existing entry - // - if instance's Kind is dvArray, it will raise an EDocVariant exception - // - any existing Name would be updated with the new Value, unless - // OnlyAddMissing is set to TRUE, in which case existing values would remain - // - returns the index of the corresponding value, which may be just added - function AddOrUpdateValue(const aName: RawUTF8; const aValue: variant; - wasAdded: PBoolean=nil; OnlyAddMissing: boolean=false): integer; - /// add a value in this document, from its text representation - // - this function expects a UTF-8 text for the value, which would be - // converted to a variant number, if possible (as varInt/varInt64/varCurrency - // and/or as varDouble is AllowVarDouble is set) - // - if Update=TRUE, will set the property, even if it is existing - function AddValueFromText(const aName,aValue: RawUTF8; Update: boolean=false; - AllowVarDouble: boolean=false): integer; - /// add some properties to a TDocVariantData dvObject - // - data is supplied two by two, as Name,Value pairs - // - caller should ensure that Kind=dvObject, otherwise it won't do anything - // - any existing Name would be duplicated - procedure AddNameValuesToObject(const NameValuePairs: array of const); - /// merge some properties to a TDocVariantData dvObject - // - data is supplied two by two, as Name,Value pairs - // - caller should ensure that Kind=dvObject, otherwise it won't do anything - // - any existing Name would be updated with the new Value - procedure AddOrUpdateNameValuesToObject(const NameValuePairs: array of const); - /// merge some TDocVariantData dvObject properties to a TDocVariantData dvObject - // - data is supplied two by two, as Name,Value pairs - // - caller should ensure that both variants have Kind=dvObject, otherwise - // it won't do anything - // - any existing Name would be updated with the new Value, unless - // OnlyAddMissing is set to TRUE, in which case existing values would remain - procedure AddOrUpdateObject(const NewValues: variant; OnlyAddMissing: boolean=false; - RecursiveUpdate: boolean=false); - /// add a value to this document, handled as array - // - if instance's Kind is dvObject, it will raise an EDocVariant exception - // - you can therefore write e.g.: - // ! TDocVariant.New(aVariant); - // ! Assert(TDocVariantData(aVariant).Kind=dvUndefined); - // ! TDocVariantData(aVariant).AddItem('one'); - // ! Assert(TDocVariantData(aVariant).Kind=dvArray); - // - returns the index of the corresponding newly added item - function AddItem(const aValue: variant): integer; - /// add a value to this document, handled as array, from its text representation - // - this function expects a UTF-8 text for the value, which would be - // converted to a variant number, if possible (as varInt/varInt64/varCurrency - // unless AllowVarDouble is set) - // - if instance's Kind is dvObject, it will raise an EDocVariant exception - // - returns the index of the corresponding newly added item - function AddItemFromText(const aValue: RawUTF8; - AllowVarDouble: boolean=false): integer; - /// add a RawUTF8 value to this document, handled as array - // - if instance's Kind is dvObject, it will raise an EDocVariant exception - // - returns the index of the corresponding newly added item - function AddItemText(const aValue: RawUTF8): integer; - /// add one or several values to this document, handled as array - // - if instance's Kind is dvObject, it will raise an EDocVariant exception - procedure AddItems(const aValue: array of const); - /// add one or several values from another document - // - supplied document should be of the same kind than the current one, - // otherwise nothing is added - procedure AddFrom(const aDocVariant: Variant); - /// add or update or on several valeus from another object - // - current document should be an object - procedure AddOrUpdateFrom(const aDocVariant: Variant; aOnlyAddMissing: boolean=false); - /// add one or several properties, specified by path, from another object - // - path are defined as a dotted name-space, e.g. 'doc.glossary.title' - // - matching values would be added as root values, with the path as name - // - instance and supplied aSource should be a dvObject - procedure AddByPath(const aSource: TDocVariantData; const aPaths: array of RawUTF8); - /// delete a value/item in this document, from its index - // - return TRUE on success, FALSE if the supplied index is not correct - function Delete(Index: integer): boolean; overload; - /// delete a value/item in this document, from its name - // - return TRUE on success, FALSE if the supplied name does not exist - function Delete(const aName: RawUTF8): boolean; overload; - /// delete a value in this document, by property name match - // - {aPropName:aPropValue} will be searched within the stored array or - // object, and the corresponding item will be deleted, on match - // - returns FALSE if no match is found, TRUE if found and deleted - // - will call VariantEquals() for value comparison - function DeleteByProp(const aPropName,aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean): boolean; - /// delete one or several value/item in this document, from its value - // - returns the number of deleted items - // - returns 0 if the document is not a dvObject, or if no match was found - // - if the value exists several times, all occurences would be removed - // - is optimized for DeleteByValue(null) call - function DeleteByValue(const aValue: Variant; CaseInsensitive: boolean=false): integer; - /// delete all values matching the first characters of a property name - // - returns the number of deleted items - // - returns 0 if the document is not a dvObject, or if no match was found - // - will use IdemPChar(), so search would be case-insensitive - function DeleteByStartName(aStartName: PUTF8Char; aStartNameLen: integer): integer; - /// search a property match in this document, handled as array or object - // - {aPropName:aPropValue} will be searched within the stored array or - // object, and the corresponding item index will be returned, on match - // - returns -1 if no match is found - // - will call VariantEquals() for value comparison - function SearchItemByProp(const aPropName,aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean): integer; overload; - /// search a property match in this document, handled as array or object - // - {aPropName:aPropValue} will be searched within the stored array or - // object, and the corresponding item index will be returned, on match - // - returns -1 if no match is found - // - will call VariantEquals() for value comparison - function SearchItemByProp(const aPropNameFmt: RawUTF8; const aPropNameArgs: array of const; - const aPropValue: RawUTF8; aPropValueCaseSensitive: boolean): integer; overload; - /// search a value in this document, handled as array - // - aValue will be searched within the stored array - // and the corresponding item index will be returned, on match - // - returns -1 if no match is found - // - you could make several searches, using the StartIndex optional parameter - function SearchItemByValue(const aValue: Variant; - CaseInsensitive: boolean=false; StartIndex: integer=0): integer; - /// sort the document object values by name - // - do nothing if the document is not a dvObject - // - will follow case-insensitive order (@StrIComp) by default, but you - // can specify @StrComp as comparer function for case-sensitive ordering - // - once sorted, you can use GetVarData(..,Compare) or GetAs*(..,Compare) - // methods for much faster O(log(n)) binary search - procedure SortByName(Compare: TUTF8Compare=nil); - /// sort the document object values by value - // - work for both dvObject and dvArray documents - // - will sort by UTF-8 text (VariantCompare) if no custom aCompare is supplied - procedure SortByValue(Compare: TVariantCompare = nil); - /// sort the document array values by a field of some stored objet values - // - do nothing if the document is not a dvArray, or if the items are no dvObject - // - will sort by UTF-8 text (VariantCompare) if no custom aValueCompare is supplied - procedure SortArrayByField(const aItemPropName: RawUTF8; - aValueCompare: TVariantCompare=nil; aValueCompareReverse: boolean=false; - aNameSortedCompare: TUTF8Compare=nil); - /// reverse the order of the document object or array items - procedure Reverse; - /// create a TDocVariant object, from a selection of properties of this - // document, by property name - // - if the document is a dvObject, to reduction will be applied to all - // its properties - // - if the document is a dvArray, the reduction will be applied to each - // stored item, if it is a document - procedure Reduce(const aPropNames: array of RawUTF8; aCaseSensitive: boolean; - out result: TDocVariantData; aDoNotAddVoidProp: boolean=false); overload; - /// create a TDocVariant object, from a selection of properties of this - // document, by property name - // - always returns a TDocVariantData, even if no property name did match - // (in this case, it is dvUndefined) - function Reduce(const aPropNames: array of RawUTF8; aCaseSensitive: boolean; - aDoNotAddVoidProp: boolean=false): variant; overload; - /// create a TDocVariant array, from the values of a single properties of - // this document, specified by name - // - you can optionally apply an additional filter to each reduced item - procedure ReduceAsArray(const aPropName: RawUTF8; out result: TDocVariantData; - OnReduce: TOnReducePerItem=nil); overload; - /// create a TDocVariant array, from the values of a single properties of - // this document, specified by name - // - always returns a TDocVariantData, even if no property name did match - // (in this case, it is dvUndefined) - // - you can optionally apply an additional filter to each reduced item - function ReduceAsArray(const aPropName: RawUTF8; OnReduce: TOnReducePerItem=nil): variant; overload; - /// create a TDocVariant array, from the values of a single properties of - // this document, specified by name - // - this overloaded method accepts an additional filter to each reduced item - procedure ReduceAsArray(const aPropName: RawUTF8; out result: TDocVariantData; - OnReduce: TOnReducePerValue); overload; - /// create a TDocVariant array, from the values of a single properties of - // this document, specified by name - // - always returns a TDocVariantData, even if no property name did match - // (in this case, it is dvUndefined) - // - this overloaded method accepts an additional filter to each reduced item - function ReduceAsArray(const aPropName: RawUTF8; OnReduce: TOnReducePerValue): variant; overload; - /// rename some properties of a TDocVariant object - // - returns the number of property names modified - function Rename(const aFromPropName, aToPropName: TRawUTF8DynArray): integer; - /// map {"obj.prop1"..,"obj.prop2":..} into {"obj":{"prop1":..,"prop2":...}} - // - the supplied aObjectPropName should match the incoming dotted value - // of all properties (e.g. 'obj' for "obj.prop1") - // - if any of the incoming property is not of "obj.prop#" form, the - // whole process would be ignored - // - return FALSE if the TDocVariant did not change - // - return TRUE if the TDocVariant has been flattened - function FlattenAsNestedObject(const aObjectPropName: RawUTF8): boolean; - - /// how this document will behave - // - those options are set when creating the instance - // - dvoArray and dvoObject are not options, but define the document Kind, - // so those items are ignored when assigned to this property - property Options: TDocVariantOptions read VOptions write SetOptions; - /// returns the document internal layout - // - just after initialization, it will return dvUndefined - // - most of the time, you will add named values with AddValue() or by - // setting the variant properties: it will return dvObject - // - but is you use AddItem(), values will have no associated names: the - // document will be a dvArray - // - value computed from the dvoArray and dvoObject presence in Options - property Kind: TDocVariantKind read GetKind; - /// return the custom variant type identifier, i.e. DocVariantType.VarType - property VarType: word read VType; - /// number of items stored in this document - // - is 0 if Kind=dvUndefined - // - is the number of name/value pairs for Kind=dvObject - // - is the number of items for Kind=dvArray - property Count: integer read VCount; - /// the current capacity of this document - // - allow direct access to VValue[] length - property Capacity: integer read GetCapacity write SetCapacity; - /// direct acces to the low-level internal array of values - // - transtyping a variant and direct access to TDocVariantData is the - // fastest way of accessing all properties of a given dvObject: - // ! with TDocVariantData(aVariantObject) do - // ! for i := 0 to Count-1 do - // ! writeln(Names[i],'=',Values[i]); - // - or to access a dvArray items (e.g. a MongoDB collection): - // ! with TDocVariantData(aVariantArray) do - // ! for i := 0 to Count-1 do - // ! writeln(Values[i]); - property Values: TVariantDynArray read VValue; - /// direct acces to the low-level internal array of names - // - is void (nil) if Kind is not dvObject - // - transtyping a variant and direct access to TDocVariantData is the - // fastest way of accessing all properties of a given dvObject: - // ! with TDocVariantData(aVariantObject) do - // ! for i := 0 to Count-1 do - // ! writeln(Names[i],'=',Values[i]); - property Names: TRawUTF8DynArray read VName; - /// find an item in this document, and returns its value - // - raise an EDocVariant if aNameOrIndex is neither an integer nor a string - // - raise an EDocVariant if Kind is dvArray and aNameOrIndex is a string - // or if Kind is dvObject and aNameOrIndex is an integer - // - raise an EDocVariant if Kind is dvObject and if aNameOrIndex is a - // string, which is not found within the object property names and - // dvoReturnNullForUnknownProperty is set in Options - // - raise an EDocVariant if Kind is dvArray and if aNameOrIndex is a - // integer, which is not within 0..Count-1 and dvoReturnNullForUnknownProperty - // is set in Options - // - so you can use directly: - // ! // for an array document: - // ! aVariant := TDocVariant.NewArray(['one',2,3.0]); - // ! for i := 0 to TDocVariantData(aVariant).Count-1 do - // ! aValue := TDocVariantData(aVariant).Value[i]; - // ! // for an object document: - // ! aVariant := TDocVariant.NewObject(['name','John','year',1972]); - // ! assert(aVariant.Name=TDocVariantData(aVariant)['name']); - // ! assert(aVariant.year=TDocVariantData(aVariant)['year']); - // - due to the internal implementation of variant execution (somewhat - // slow _DispInvoke() function), it is a bit faster to execute: - // ! aValue := TDocVariantData(aVariant).Value['name']; - // instead of - // ! aValue := aVariant.name; - // but of course, if want to want to access the content by index (typically - // for a dvArray), using Values[] - and Names[] - properties is much faster - // than this variant-indexed pseudo-property: - // ! with TDocVariantData(aVariant) do - // ! for i := 0 to Count-1 do - // ! Writeln(Values[i]); - // is faster than: - // ! with TDocVariantData(aVariant) do - // ! for i := 0 to Count-1 do - // ! Writeln(Value[i]); - // which is faster than: - // ! for i := 0 to aVariant.Count-1 do - // ! Writeln(aVariant._(i)); - // - this property will return the value as varByRef (just like with - // variant late binding of any TDocVariant instance), so you can write: - // !var Doc: TDocVariantData; // stack-allocated variable - // !begin - // ! Doc.InitJSON('{arr:[1,2]}'); - // ! assert(Doc.Count=2); - // ! Doc.Value['arr'].Add(3); // works since Doc.Value['arr'] is varByRef - // ! writeln(Doc.ToJSON); // will write '{"arr":[1,2,3]}' - // !end; - // - if you want to access a property as a copy, i.e. to assign it to a - // variant variable which will stay alive after this TDocVariant instance - // is release, you should not use Value[] but rather - // GetValueOrRaiseException or GetValueOrNull/GetValueOrEmpty - // - see U[] I[] B[] D[] O[] O_[] A[] A_[] _[] properties for direct access - // of strong typed values - property Value[const aNameOrIndex: Variant]: Variant read GetValueOrItem - write SetValueOrItem; default; - - /// direct access to a dvObject UTF-8 stored property value from its name - // - slightly faster than the variant-based Value[] default property - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - use GetAsRawUTF8() if you want to check the availability of the field - // - U['prop'] := 'value' would add a new property, or overwrite an existing - property U[const aName: RawUTF8]: RawUTF8 read GetRawUTF8ByName write SetRawUTF8ByName; - /// direct string access to a dvObject UTF-8 stored property value from its name - // - just a wrapper around U[] property, to avoid a compilation warning when - // using plain string variables (internaly, RawUTF8 will be used for storage) - // - slightly faster than the variant-based Value[] default property - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - use GetAsRawUTF8() if you want to check the availability of the field - // - S['prop'] := 'value' would add a new property, or overwrite an existing - property S[const aName: RawUTF8]: string read GetStringByName write SetStringByName; - /// direct access to a dvObject Integer stored property value from its name - // - slightly faster than the variant-based Value[] default property - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - use GetAsInt/GetAsInt64 if you want to check the availability of the field - // - I['prop'] := 123 would add a new property, or overwrite an existing - property I[const aName: RawUTF8]: Int64 read GetInt64ByName write SetInt64ByName; - /// direct access to a dvObject Boolean stored property value from its name - // - slightly faster than the variant-based Value[] default property - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - use GetAsBoolean if you want to check the availability of the field - // - B['prop'] := true would add a new property, or overwrite an existing - property B[const aName: RawUTF8]: Boolean read GetBooleanByName write SetBooleanByName; - /// direct access to a dvObject floating-point stored property value from its name - // - slightly faster than the variant-based Value[] default property - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - use GetAsDouble if you want to check the availability of the field - // - D['prop'] := 1.23 would add a new property, or overwrite an existing - property D[const aName: RawUTF8]: Double read GetDoubleByName write SetDoubleByName; - /// direct access to a dvObject existing dvObject property from its name - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - O['prop'] would return a fake void TDocVariant if the property is not - // existing or not a dvObject, just like GetAsDocVariantSafe() - // - use O_['prop'] to force adding any missing property - property O[const aName: RawUTF8]: PDocVariantData read GetObjectExistingByName; - /// direct access or add a dvObject's dvObject property from its name - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - O_['prop'] would add a new property if there is none existing, or - // overwrite an existing property which is not a dvObject - property O_[const aName: RawUTF8]: PDocVariantData read GetObjectOrAddByName; - /// direct access to a dvObject existing dvArray property from its name - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - A['prop'] would return a fake void TDocVariant if the property is not - // existing or not a dvArray, just like GetAsDocVariantSafe() - // - use A_['prop'] to force adding any missing property - property A[const aName: RawUTF8]: PDocVariantData read GetArrayExistingByName; - /// direct access or add a dvObject's dvArray property from its name - // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options - // - A_['prop'] would add a new property if there is none existing, or - // overwrite an existing property which is not a dvArray - property A_[const aName: RawUTF8]: PDocVariantData read GetArrayOrAddByName; - /// direct access to a dvArray's TDocVariant property from its index - // - simple values may directly use Values[] dynamic array, but to access - // a TDocVariantData members, this property is safer - // - follows dvoReturnNullForUnknownProperty option to raise an exception - // - _[ndx] would return a fake void TDocVariant if aIndex is out of range, - // if the property is not existing or not a TDocVariantData (just like - // GetAsDocVariantSafe) - property _[aIndex: integer]: PDocVariantData read GetAsDocVariantByIndex; - end; - {$A+} { packet object not allowed since Delphi 2009 :( } - -var - /// the internal custom variant type used to register TDocVariant - DocVariantType: TDocVariant = nil; - /// copy of DocVariantType.VarType - // - as used by inlined functions of TDocVariantData - DocVariantVType: integer = -1; - -/// retrieve the text representation of a TDocVairnatKind -function ToText(kind: TDocVariantKind): PShortString; overload; - -/// direct access to a TDocVariantData from a given variant instance -// - return a pointer to the TDocVariantData corresponding to the variant -// instance, which may be of kind varByRef (e.g. when retrieved by late binding) -// - raise an EDocVariant exception if the instance is not a TDocVariant -// - the following direct trans-typing may fail, e.g. for varByRef value: -// ! TDocVariantData(aVarDoc.ArrayProp).Add('new item'); -// - so you can write the following: -// ! DocVariantData(aVarDoc.ArrayProp).AddItem('new item'); -function DocVariantData(const DocVariant: variant): PDocVariantData; - -const - /// constant used e.g. by _Safe() overloaded functions - // - will be in code section of the exe, so will be read-only by design - // - would have Kind=dvUndefined and Count=0, so _Safe() would return - // a valid, but void document - // - its VType is varNull, so would be viewed as a null variant - // - dvoReturnNullForUnknownProperty is defined, so that U[]/I[]... methods - // won't raise any exception about unexpected field name - DocVariantDataFake: TDocVariantData = ( - VType:1; VOptions:[dvoReturnNullForUnknownProperty]); - -/// direct access to a TDocVariantData from a given variant instance -// - return a pointer to the TDocVariantData corresponding to the variant -// instance, which may be of kind varByRef (e.g. when retrieved by late binding) -// - will return a read-only fake TDocVariantData with Kind=dvUndefined if the -// supplied variant is not a TDocVariant instance, so could be safely used -// in a with block (use "with" moderation, of course): -// ! with _Safe(aDocVariant)^ do -// ! for ndx := 0 to Count-1 do // here Count=0 for the "fake" result -// ! writeln(Names[ndx]); -// or excluding the "with" statement, as more readable code: -// ! var dv: PDocVariantData; -// ! ndx: PtrInt; -// ! begin -// ! dv := _Safe(aDocVariant); -// ! for ndx := 0 to dv.Count-1 do // here Count=0 for the "fake" result -// ! writeln(dv.Names[ndx]); -function _Safe(const DocVariant: variant): PDocVariantData; overload; - {$ifdef FPC}inline;{$endif} // Delphi has problems inlining this :( - -/// direct access to a TDocVariantData from a given variant instance -// - return a pointer to the TDocVariantData corresponding to the variant -// instance, which may be of kind varByRef (e.g. when retrieved by late binding) -// - will check the supplied document kind, i.e. either dvObject or dvArray and -// raise a EDocVariant exception if it does not match -function _Safe(const DocVariant: variant; ExpectedKind: TDocVariantKind): PDocVariantData; overload; - -/// initialize a variant instance to store some document-based object content -// - object will be initialized with data supplied two by two, as Name,Value -// pairs, e.g. -// ! aVariant := _Obj(['name','John','year',1972]); -// or even with nested objects: -// ! aVariant := _Obj(['name','John','doc',_Obj(['one',1,'two',2.0])]); -// - this global function is an alias to TDocVariant.NewObject() -// - by default, every internal value will be copied, so access of nested -// properties can be slow - if you expect the data to be read-only or not -// propagated into another place, set Options=[dvoValueCopiedByReference] -// or using _ObjFast() will increase the process speed a lot -function _Obj(const NameValuePairs: array of const; - Options: TDocVariantOptions=[]): variant; - -/// add some property values to a document-based object content -// - if Obj is a TDocVariant object, will add the Name/Value pairs -// - if Obj is not a TDocVariant, will create a new fast document, -// initialized with supplied the Name/Value pairs -// - this function will also ensure that ensure Obj is not stored by reference, -// but as a true TDocVariantData -procedure _ObjAddProps(const NameValuePairs: array of const; var Obj: variant); overload; - -/// add the property values of a document to a document-based object content -// - if Document is not a TDocVariant object, will do nothing -// - if Obj is a TDocVariant object, will add Document fields to its content -// - if Obj is not a TDocVariant object, Document will be copied to Obj -procedure _ObjAddProps(const Document: variant; var Obj: variant); overload; - -/// initialize a variant instance to store some document-based array content -// - array will be initialized with data supplied as parameters, e.g. -// ! aVariant := _Arr(['one',2,3.0]); -// - this global function is an alias to TDocVariant.NewArray() -// - by default, every internal value will be copied, so access of nested -// properties can be slow - if you expect the data to be read-only or not -// propagated into another place, set Options=[dvoValueCopiedByReference] -// or using _ArrFast() will increase the process speed a lot -function _Arr(const Items: array of const; - Options: TDocVariantOptions=[]): variant; - -/// initialize a variant instance to store some document-based content -// from a supplied (extended) JSON content -// - this global function is an alias to TDocVariant.NewJSON(), and -// will return an Unassigned variant if JSON content was not correctly converted -// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency -// - object or array will be initialized from the supplied JSON content, e.g. -// ! aVariant := _Json('{"id":10,"doc":{"name":"John","birthyear":1972}}'); -// ! // now you can access to the properties via late binding -// ! assert(aVariant.id=10); -// ! assert(aVariant.doc.name='John'); -// ! assert(aVariant.doc.birthYear=1972); -// ! // and also some pseudo-properties: -// ! assert(aVariant._count=2); -// ! assert(aVariant.doc._kind=ord(dvObject)); -// ! // or with a JSON array: -// ! aVariant := _Json('["one",2,3]'); -// ! assert(aVariant._kind=ord(dvArray)); -// ! for i := 0 to aVariant._count-1 do -// ! writeln(aVariant._(i)); -// - in addition to the JSON RFC specification strict mode, this method will -// handle some BSON-like extensions, e.g. unquoted field names: -// ! aVariant := _Json('{id:10,doc:{name:"John",birthyear:1972}}'); -// - if the SynMongoDB unit is used in the application, the MongoDB Shell -// syntax will also be recognized to create TBSONVariant, like -// ! new Date() ObjectId() MinKey MaxKey // -// see @http://docs.mongodb.org/manual/reference/mongodb-extended-json -// - by default, every internal value will be copied, so access of nested -// properties can be slow - if you expect the data to be read-only or not -// propagated into another place, add dvoValueCopiedByReference in Options -// will increase the process speed a lot, or use _JsonFast() -function _Json(const JSON: RawUTF8; - Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// initialize a variant instance to store some document-based content -// from a supplied (extended) JSON content, with parameters formating -// - wrapper around the _Json(FormatUTF8(...,JSONFormat=true)) function, -// i.e. every Args[] will be inserted for each % and Params[] for each ?, -// with proper JSON escaping of string values, and writing nested _Obj() / -// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency -// _Arr() instances as expected JSON objects / arrays -// - typical use (in the context of SynMongoDB unit) could be: -// ! aVariant := _JSONFmt('{%:{$in:[?,?]}}',['type'],['food','snack']); -// ! aVariant := _JSONFmt('{type:{$in:?}}',[],[_Arr(['food','snack'])]); -// ! // which are the same as: -// ! aVariant := _JSONFmt('{type:{$in:["food","snack"]}}'); -// ! // in this context: -// ! u := VariantSaveJSON(aVariant); -// ! assert(u='{"type":{"$in":["food","snack"]}}'); -// ! u := VariantSaveMongoJSON(aVariant,modMongoShell); -// ! assert(u='{type:{$in:["food","snack"]}}'); -// - by default, every internal value will be copied, so access of nested -// properties can be slow - if you expect the data to be read-only or not -// propagated into another place, add dvoValueCopiedByReference in Options -// will increase the process speed a lot, or use _JsonFast() -function _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; - Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): variant; overload; - -/// initialize a variant instance to store some document-based content -// from a supplied (extended) JSON content, with parameters formating -// - this overload function will set directly a local variant variable, -// and would be used by inlined _JsonFmt/_JsonFastFmt functions -procedure _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; - Options: TDocVariantOptions; out result: variant); overload; - -/// initialize a variant instance to store some document-based content -// from a supplied (extended) JSON content -// - this global function is an alias to TDocVariant.NewJSON(), and -// will return TRUE if JSON content was correctly converted into a variant -// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency -// - in addition to the JSON RFC specification strict mode, this method will -// handle some BSON-like extensions, e.g. unquoted field names or ObjectID() -// - by default, every internal value will be copied, so access of nested -// properties can be slow - if you expect the data to be read-only or not -// propagated into another place, add dvoValueCopiedByReference in Options -// will increase the process speed a lot, or use _JsonFast() -function _Json(const JSON: RawUTF8; var Value: variant; - Options: TDocVariantOptions=[dvoReturnNullForUnknownProperty]): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// initialize a variant instance to store some document-based object content -// - this global function is an handy alias to: -// ! Obj(NameValuePairs,JSON_OPTIONS[true]); -// - so all created objects and arrays will be handled by reference, for best -// speed - but you should better write on the resulting variant tree with caution -function _ObjFast(const NameValuePairs: array of const): variant; overload; - -/// initialize a variant instance to store any object as a TDocVariant -// - is a wrapper around _JsonFast(ObjectToJson(aObject,aOptions)) -function _ObjFast(aObject: TObject; - aOptions: TTextWriterWriteObjectOptions=[woDontStoreDefault]): variant; overload; - -/// initialize a variant instance to store some document-based array content -// - this global function is an handy alias to: -// ! _Array(Items,JSON_OPTIONS[true]); -// - so all created objects and arrays will be handled by reference, for best -// speed - but you should better write on the resulting variant tree with caution -function _ArrFast(const Items: array of const): variant; overload; - -/// initialize a variant instance to store some document-based content -// from a supplied (extended) JSON content -// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency -// - this global function is an handy alias to: -// ! _Json(JSON,JSON_OPTIONS[true]); or _Json(JSON,JSON_OPTIONS_FAST) -// so it will return an Unassigned variant if JSON content was not correct -// - so all created objects and arrays will be handled by reference, for best -// speed - but you should better write on the resulting variant tree with caution -// - in addition to the JSON RFC specification strict mode, this method will -// handle some BSON-like extensions, e.g. unquoted field names or ObjectID() -function _JsonFast(const JSON: RawUTF8): variant; - {$ifdef HASINLINE}inline;{$endif} - -/// initialize a variant instance to store some document-based content -// from a supplied (extended) JSON content, parsing any kind of float -// - use JSON_OPTIONS_FAST_FLOAT including the dvoAllowDoubleValue option -function _JsonFastFloat(const JSON: RawUTF8): variant; - {$ifdef HASINLINE}inline;{$endif} - -/// initialize a variant instance to store some extended document-based content -// - this global function is an handy alias to: -// ! _Json(JSON,JSON_OPTIONS_FAST_EXTENDED); -function _JsonFastExt(const JSON: RawUTF8): variant; - {$ifdef HASINLINE}inline;{$endif} - -/// initialize a variant instance to store some document-based content -// from a supplied (extended) JSON content, with parameters formating -// - warning: exclude dvoAllowDoubleValue so won't parse any float, just currency -// - this global function is an handy alias e.g. to: -// ! aVariant := _JSONFmt('{%:{$in:[?,?]}}',['type'],['food','snack'],JSON_OPTIONS[true]); -// - so all created objects and arrays will be handled by reference, for best -// speed - but you should better write on the resulting variant tree with caution -// - in addition to the JSON RFC specification strict mode, this method will -// handle some BSON-like extensions, e.g. unquoted field names or ObjectID(): -function _JsonFastFmt(const Format: RawUTF8; const Args,Params: array of const): variant; - -/// ensure a document-based variant instance will have only per-value nested -// objects or array documents -// - is just a wrapper around: -// ! TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[false]) -// - you can use this function to ensure that all internal properties of this -// variant will be copied per-value whatever options the nested objects or -// arrays were created with -// - for huge document with a big depth of nested objects or arrays, a full -// per-value copy may be time and resource consuming, but will be also safe -// - will raise an EDocVariant if the supplied variant is not a TDocVariant or -// a varByRef pointing to a TDocVariant -procedure _Unique(var DocVariant: variant); - -/// ensure a document-based variant instance will have only per-value nested -// objects or array documents -// - is just a wrapper around: -// ! TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[true]) -// - you can use this function to ensure that all internal properties of this -// variant will be copied per-reference whatever options the nested objects or -// arrays were created with -// - for huge document with a big depth of nested objects or arrays, it will -// first create a whole copy of the document nodes, but further assignments -// of the resulting value will be per-reference, so will be almost instant -// - will raise an EDocVariant if the supplied variant is not a TDocVariant or -// a varByRef pointing to a TDocVariant -procedure _UniqueFast(var DocVariant: variant); - -/// return a full nested copy of a document-based variant instance -// - is just a wrapper around: -// ! TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[false]) -// - you can use this function to ensure that all internal properties of this -// variant will be copied per-value whatever options the nested objects or -// arrays were created with: to be used on a value returned as varByRef -// (e.g. by _() pseudo-method) -// - for huge document with a big depth of nested objects or arrays, a full -// per-value copy may be time and resource consuming, but will be also safe - -// consider using _ByRef() instead if a fast copy-by-reference is enough -// - will raise an EDocVariant if the supplied variant is not a TDocVariant or -// a varByRef pointing to a TDocVariant -function _Copy(const DocVariant: variant): variant; - {$ifdef HASINLINE}inline;{$endif} - -/// return a full nested copy of a document-based variant instance -// - is just a wrapper around: -// ! TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[true]) -// - you can use this function to ensure that all internal properties of this -// variant will be copied per-value whatever options the nested objects or -// arrays were created with: to be used on a value returned as varByRef -// (e.g. by _() pseudo-method) -// - for huge document with a big depth of nested objects or arrays, a full -// per-value copy may be time and resource consuming, but will be also safe - -// consider using _ByRef() instead if a fast copy-by-reference is enough -// - will raise an EDocVariant if the supplied variant is not a TDocVariant or -// a varByRef pointing to a TDocVariant -function _CopyFast(const DocVariant: variant): variant; - {$ifdef HASINLINE}inline;{$endif} - -/// copy a TDocVariant to another variable, changing the options on the fly -// - note that the content (items or properties) is copied by reference, -// so consider using _Copy() instead if you expect to safely modify its content -// - will return null if the supplied variant is not a TDocVariant -function _ByRef(const DocVariant: variant; Options: TDocVariantOptions): variant; overload; - -/// copy a TDocVariant to another variable, changing the options on the fly -// - note that the content (items or properties) is copied by reference, -// so consider using _Copy() instead if you expect to safely modify its content -// - will return null if the supplied variant is not a TDocVariant -procedure _ByRef(const DocVariant: variant; out Dest: variant; - Options: TDocVariantOptions); overload; - -/// convert a TDocVariantData array or a string value into a CSV -// - will call either TDocVariantData.ToCSV, or return the string -// - returns '' if the supplied value is neither a TDocVariant or a string -// - could be used e.g. to store either a JSON CSV string or a JSON array of -// strings in a settings property -function _CSV(const DocVariantOrString: variant): RawUTF8; - -/// will convert any TObject into a TDocVariant document instance -// - a slightly faster alternative to Dest := _JsonFast(ObjectToJSON(Value)) -// - this would convert the TObject by representation, using only serializable -// published properties: do not use this function to store temporary a class -// instance, but e.g. to store an object values in a NoSQL database -// - if you expect lazy-loading of a TObject, see TObjectVariant.New() -procedure ObjectToVariant(Value: TObject; out Dest: variant); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// will convert any TObject into a TDocVariant document instance -// - a faster alternative to _JsonFast(ObjectToJSON(Value)) -// - if you expect lazy-loading of a TObject, see TObjectVariant.New() -function ObjectToVariant(Value: TObject; EnumSetsAsText: boolean=false): variant; overload; - -/// will convert any TObject into a TDocVariant document instance -// - a faster alternative to _Json(ObjectToJSON(Value),Options) -// - note that the result variable should already be cleared: no VarClear() -// is done by this function -// - would be used e.g. by VarRecToVariant() function -// - if you expect lazy-loading of a TObject, see TObjectVariant.New() -procedure ObjectToVariant(Value: TObject; var result: variant; - Options: TTextWriterWriteObjectOptions); overload; - -{$endif NOVARIANTS} - - -{ ******************* process monitoring / statistics ********************** } - -type - /// the kind of value stored in a TSynMonitor / TSynMonitorUsage property - // - i.e. match TSynMonitorTotalMicroSec, TSynMonitorOneMicroSec, - // TSynMonitorOneCount, TSynMonitorOneBytes, TSynMonitorBytesPerSec, - // TSynMonitorTotalBytes, TSynMonitorCount and TSynMonitorCount64 types as - // used to store statistic information - // - "cumulative" values would sum each process values, e.g. total elapsed - // time for SOA execution, task count or total I/O bytes - // - "immediate" (e.g. svOneBytes or smvBytesPerSec) values would be an evolving - // single value, e.g. an average value or current disk free size - // - use SYNMONITORVALUE_CUMULATIVE = [smvMicroSec,smvBytes,smvCount,smvCount64] - // constant to identify the kind of value - // - TSynMonitorUsage.Track() would use MonitorPropUsageValue() to guess - // the tracked properties type from class RTTI - TSynMonitorType = ( - smvUndefined, smvOneMicroSec, smvOneBytes, smvOneCount, smvBytesPerSec, - smvMicroSec, smvBytes, smvCount, smvCount64); - /// value types as stored in TSynMonitor / TSynMonitorUsage - TSynMonitorTypes = set of TSynMonitorType; - - /// would identify a cumulative time process information in micro seconds, during monitoring - // - "cumulative" time would add each process timing, e.g. for statistics about - // SOA computation of a given service - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorTotalMicroSec = type QWord; - - /// would identify an immediate time count information, during monitoring - // - "immediate" counts won't accumulate, e.g. may store the current number - // of thread used by a process - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorOneCount = type cardinal; - - /// would identify an immediate time process information in micro seconds, during monitoring - // - "immediate" time won't accumulate, i.e. may store the duration of the - // latest execution of a SOA computation - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorOneMicroSec = type QWord; - - /// would identify a process information as cumulative bytes count, during monitoring - // - "cumulative" size would add some byte for each process, e.g. input/output - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorTotalBytes = type QWord; - - /// would identify an immediate process information as bytes count, during monitoring - // - "immediate" size won't accumulate, i.e. may be e.g. computer free memory - // at a given time - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorOneBytes = type QWord; - - /// would identify the process throughput, during monitoring - // - it indicates e.g. "immediate" bandwith usage - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorBytesPerSec = type QWord; - - /// would identify a cumulative number of processes, during monitoring - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorCount = type cardinal; - - /// would identify a cumulative number of processes, during monitoring - // - any property defined with this type would be identified by TSynMonitorUsage - TSynMonitorCount64 = type QWord; - - /// pointer to a high resolution timer object/record - PPrecisionTimer = ^TPrecisionTimer; - - /// indirect reference to a pointer to a high resolution timer object/record - PPPrecisionTimer = ^PPrecisionTimer; - - /// high resolution timer (for accurate speed statistics) - // - WARNING: under Windows, this record MUST be aligned to 32-bit, otherwise - // iFreq=0 - so you can use TLocalPrecisionTimer/ILocalPrecisionTimer if you - // want to alllocate a local timer instance on the stack - TPrecisionTimer = object - protected - fStart,fStop: Int64; - {$ifndef LINUX} // use QueryPerformanceMicroSeconds() fast API - fWinFreq: Int64; - {$endif} - /// contains the time elapsed in micro seconds between Start and Stop - fTime: TSynMonitorTotalMicroSec; - /// contains the time elapsed in micro seconds between Resume and Pause - fLastTime: TSynMonitorOneMicroSec; - fPauseCount: TSynMonitorCount; - public - /// initialize the timer - // - will fill all internal state with 0 - // - not necessary e.g. if TPrecisionTimer is defined as a TObject field - procedure Init; {$ifdef HASINLINE}inline;{$endif} - /// initialize and start the high resolution timer - // - similar to Init + Resume - procedure Start; - /// stop the timer, returning the total time elapsed as text - // - with appended time resolution (us,ms,s) - from MicroSecToString() - // - is just a wrapper around Pause + Time - // - you can call Resume to continue adding time to this timer - function Stop: TShort16; {$ifdef HASINLINE}inline;{$endif} - /// stop the timer, returning the total time elapsed as microseconds - // - is just a wrapper around Pause + Time - // - you can call Resume to continue adding time to this timer - function StopInMicroSec: TSynMonitorTotalMicroSec; {$ifdef HASINLINE}inline;{$endif} - /// stop the timer, ready to continue its time measurement via Resume - // - will also compute the global Time value - // - do nothing if no previous Start/Resume call is pending - procedure Pause; - /// resume a paused timer, or start an initialized timer - // - do nothing if no timer has been initialized or paused just before - // - if the previous method called was Init, will act like Start - // - if the previous method called was Pause, it will continue counting - procedure Resume; {$ifdef HASINLINE}inline;{$endif} - /// resume a paused timer until the method ends - // - will internaly create a TInterfaceObject class to let the compiler - // generate a try..finally block as expected to call Pause at method ending - // - is therefore very convenient to have consistent Resume/Pause calls - // - for proper use, expect TPrecisionTimer to be initialized to 0 before - // execution (e.g. define it as a protected member of a class) - // - typical use is to declare a fTimeElapsed: TPrecisionTimer protected - // member, then call fTimeElapsed.ProfileCurrentMethod at the beginning of - // all process expecting some timing, then log/save fTimeElapsed.Stop content - // - FPC TIP: result should be assigned to a local variable of IUnknown type - function ProfileCurrentMethod: IUnknown; - /// low-level method to force values settings to allow thread safe timing - // - by default, this timer is not thread safe: you can use this method to - // set the timing values from manually computed performance counters - // - the caller should also use a mutex to prevent from race conditions: - // see e.g. TSynMonitor.FromExternalMicroSeconds implementation - // - warning: Start, Stop, Pause and Resume methods are then disallowed - procedure FromExternalMicroSeconds(const MicroSeconds: QWord); - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - /// low-level method to force values settings to allow thread safe timing - // - by default, this timer is not thread safe: you can use this method to - // set the timing values from manually computed performance counters - // - the caller should also use a mutex to prevent from race conditions: - // see e.g. TSynMonitor.FromExternalQueryPerformanceCounters implementation - // - returns the time elapsed, in micro seconds (i.e. LastTime value) - // - warning: Start, Stop, Pause and Resume methods are then disallowed - function FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; - {$ifdef FPCLINUX}inline;{$endif} - /// compute the per second count - function PerSec(const Count: QWord): QWord; - /// compute the time elapsed by count, with appened time resolution (us,ms,s) - function ByCount(Count: QWord): TShort16; - /// returns e.g. '16.9 MB in 102.20ms i.e. 165.5 MB/s' - function SizePerSec(Size: QWord): shortstring; - /// textual representation of total time elapsed - // - with appened time resolution (us,ms,s) - from MicroSecToString() - // - not to be used in normal code (which could rather call the Stop method), - // but e.g. for custom performance analysis - function Time: TShort16; - /// textual representation of last process timing after counter stopped - // - Time returns a total elapsed time, whereas this method only returns - // the latest resumed time - // - with appened time resolution (us,ms,s) - from MicroSecToString() - // - not to be used in normal code, but e.g. for custom performance analysis - function LastTime: TShort16; - /// check if Start/Resume were called at least once - function Started: boolean; - /// time elapsed in micro seconds after counter stopped - // - not to be used in normal code, but e.g. for custom performance analysis - property TimeInMicroSec: TSynMonitorTotalMicroSec read fTime write fTime; - /// timing in micro seconds of the last process - // - not to be used in normal code, but e.g. for custom performance analysis - property LastTimeInMicroSec: TSynMonitorOneMicroSec read fLastTime write fLastTime; - /// how many times the Pause method was called, i.e. the number of tasks - // processeed - property PauseCount: TSynMonitorCount read fPauseCount; - end; - - /// interface to a reference counted high resolution timer instance - // - implemented by TLocalPrecisionTimer - ILocalPrecisionTimer = interface - /// start the high resolution timer - procedure Start; - /// stop the timer, returning the time elapsed, with appened time resolution (us,ms,s) - function Stop: TShort16; - /// stop the timer, ready to continue its time measure - procedure Pause; - /// resume a paused timer, or start it if it hasn't be started - procedure Resume; - /// compute the per second count - function PerSec(Count: cardinal): cardinal; - /// compute the time elapsed by count, with appened time resolution (us,ms,s) - function ByCount(Count: cardinal): RawUTF8; - end; - - /// reference counted high resolution timer (for accurate speed statistics) - // - since TPrecisionTimer shall be 32-bit aligned, you can use this class - // to initialize a local auto-freeing ILocalPrecisionTimer variable on stack - // - to be used as such: - // ! var Timer: ILocalPrecisionTimer; - // ! (...) - // ! Timer := TLocalPrecisionTimer.Create; - // ! Timer.Start; - // ! (...) - TLocalPrecisionTimer = class(TInterfacedObject,ILocalPrecisionTimer) - protected - fTimer: TPrecisionTimer; - public - /// initialize the instance, and start the high resolution timer - constructor CreateAndStart; - /// start the high resolution timer - procedure Start; - /// stop the timer, returning the time elapsed, with appened time resolution (us,ms,s) - function Stop: TShort16; - /// stop the timer, ready to continue its time measure - procedure Pause; - /// resume a paused timer, or start the timer - procedure Resume; - /// compute the per second count - function PerSec(Count: cardinal): cardinal; - /// compute the time elapsed by count, with appened time resolution (us,ms,s) - function ByCount(Count: cardinal): RawUTF8; - end; - - /// able to serialize any cumulative timing as raw micro-seconds number or text - // - "cumulative" time would add each process value, e.g. SOA methods execution - TSynMonitorTime = class(TSynPersistent) - protected - fMicroSeconds: TSynMonitorTotalMicroSec; - function GetAsText: TShort16; - public - /// compute a number per second, of the current value - function PerSecond(const Count: QWord): QWord; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - published - /// micro seconds time elapsed, as raw number - property MicroSec: TSynMonitorTotalMicroSec read fMicroSeconds write fMicroSeconds; - /// micro seconds time elapsed, as '... us-ns-ms-s' text - property Text: TShort16 read GetAsText; - end; - - /// able to serialize any immediate timing as raw micro-seconds number or text - // - "immediate" size won't accumulate, i.e. may be e.g. last process time - TSynMonitorOneTime = class(TSynPersistent) - protected - fMicroSeconds: TSynMonitorOneMicroSec; - function GetAsText: TShort16; - public - /// compute a number per second, of the current value - function PerSecond(const Count: QWord): QWord; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - published - /// micro seconds time elapsed, as raw number - property MicroSec: TSynMonitorOneMicroSec read fMicroSeconds write fMicroSeconds; - /// micro seconds time elapsed, as '... us-ns-ms-s' text - property Text: TShort16 read GetAsText; - end; - - TSynMonitorSizeParent = class(TSynPersistent) - protected - fTextNoSpace: boolean; - public - /// initialize the instance - constructor Create(aTextNoSpace: boolean); reintroduce; - end; - - /// able to serialize any cumulative size as bytes number - // - "cumulative" time would add each process value, e.g. global IO consumption - TSynMonitorSize = class(TSynMonitorSizeParent) - protected - fBytes: TSynMonitorTotalBytes; - function GetAsText: TShort16; - published - /// number of bytes, as raw number - property Bytes: TSynMonitorTotalBytes read fBytes write fBytes; - /// number of bytes, as '... B-KB-MB-GB' text - property Text: TShort16 read GetAsText; - end; - - /// able to serialize any immediate size as bytes number - // - "immediate" size won't accumulate, i.e. may be e.g. computer free memory - // at a given time - TSynMonitorOneSize = class(TSynMonitorSizeParent) - protected - fBytes: TSynMonitorOneBytes; - function GetAsText: TShort16; - published - /// number of bytes, as raw number - property Bytes: TSynMonitorOneBytes read fBytes write fBytes; - /// number of bytes, as '... B-KB-MB-GB' text - property Text: TShort16 read GetAsText; - end; - - /// able to serialize any bandwith as bytes count per second - // - is usually associated with TSynMonitorOneSize properties, - // e.g. to monitor IO activity - TSynMonitorThroughput = class(TSynMonitorSizeParent) - protected - fBytesPerSec: QWord; - function GetAsText: TShort16; - published - /// number of bytes per second, as raw number - property BytesPerSec: QWord read fBytesPerSec write fBytesPerSec; - /// number of bytes per second, as '... B-KB-MB-GB/s' text - property Text: TShort16 read GetAsText; - end; - - /// a generic value object able to handle any task / process statistic - // - base class shared e.g. for ORM, SOA or DDD, when a repeatable data - // process is to be monitored - // - this class is thread-safe for its methods, but you should call explicitly - // Lock/UnLock to access its individual properties - TSynMonitor = class(TSynPersistentLock) - protected - fName: RawUTF8; - fTaskCount: TSynMonitorCount64; - fTotalTime: TSynMonitorTime; - fLastTime: TSynMonitorOneTime; - fMinimalTime: TSynMonitorOneTime; - fAverageTime: TSynMonitorOneTime; - fMaximalTime: TSynMonitorOneTime; - fPerSec: QWord; - fInternalErrors: TSynMonitorCount; - fProcessing: boolean; - fTaskStatus: (taskNotStarted,taskStarted); - fLastInternalError: variant; - procedure LockedPerSecProperties; virtual; - procedure LockedFromProcessTimer; virtual; - procedure LockedSum(another: TSynMonitor); virtual; - procedure WriteDetailsTo(W: TTextWriter); virtual; - procedure Changed; virtual; - public - /// low-level high-precision timer instance - InternalTimer: TPrecisionTimer; - /// initialize the instance nested class properties - // - you can specify identifier associated to this monitored resource - // which would be used for TSynMonitorUsage persistence - constructor Create(const aName: RawUTF8); reintroduce; overload; virtual; - /// initialize the instance nested class properties - constructor Create; overload; override; - /// finalize the instance - destructor Destroy; override; - /// lock the instance for exclusive access - // - needed only if you access directly the instance properties - procedure Lock; {$ifdef HASINLINE}inline;{$endif} - /// release the instance for exclusive access - // - needed only if you access directly the instance properties - procedure UnLock; {$ifdef HASINLINE}inline;{$endif} - /// create Count instances of this actual class in the supplied ObjArr[] - class procedure InitializeObjArray(var ObjArr; Count: integer); virtual; - /// should be called when the process starts, to resume the internal timer - // - thread-safe method - procedure ProcessStart; virtual; - /// should be called each time a pending task is processed - // - will increase the TaskCount property - // - thread-safe method - procedure ProcessDoTask; virtual; - /// should be called when the process starts, and a task is processed - // - similar to ProcessStart + ProcessDoTask - // - thread-safe method - procedure ProcessStartTask; virtual; - /// should be called when an error occurred - // - typical use is with ObjectToVariantDebug(E,...) kind of information - // - thread-safe method - procedure ProcessError(const info: variant); virtual; - /// should be called when an error occurred - // - typical use is with a HTTP status, e.g. as ProcessError(Call.OutStatus) - // - just a wraper around overloaded ProcessError(), so a thread-safe method - procedure ProcessErrorNumber(info: integer); - /// should be called when an error occurred - // - just a wraper around overloaded ProcessError(), so a thread-safe method - procedure ProcessErrorFmt(const Fmt: RawUTF8; const Args: array of const); - /// should be called when an Exception occurred - // - just a wraper around overloaded ProcessError(), so a thread-safe method - procedure ProcessErrorRaised(E: Exception); - /// should be called when the process stops, to pause the internal timer - // - thread-safe method - procedure ProcessEnd; virtual; - /// could be used to manage information average or sums - // - thread-safe method calling LockedSum protected virtual method - procedure Sum(another: TSynMonitor); - /// returns a JSON content with all published properties information - // - thread-safe method - function ComputeDetailsJSON: RawUTF8; - /// appends a JSON content with all published properties information - // - thread-safe method - procedure ComputeDetailsTo(W: TTextWriter); virtual; - {$ifndef NOVARIANTS} - /// returns a TDocVariant with all published properties information - // - thread-safe method - function ComputeDetails: variant; - {$endif NOVARIANTS} - /// used to allow thread safe timing - // - by default, the internal TPrecisionTimer is not thread safe: you can - // use this method to update the timing from many threads - // - if you use this method, ProcessStart, ProcessDoTask and ProcessEnd - // methods are disallowed, and the global fTimer won't be used any more - // - will return the processing time, converted into micro seconds, ready - // to be logged if needed - // - thread-safe method - function FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; - /// used to allow thread safe timing - // - by default, the internal TPrecisionTimer is not thread safe: you can - // use this method to update the timing from many threads - // - if you use this method, ProcessStart, ProcessDoTask and ProcessEnd - // methods are disallowed, and the global fTimer won't be used any more - // - thread-safe method - procedure FromExternalMicroSeconds(const MicroSecondsElapsed: QWord); - /// an identifier associated to this monitored resource - // - is used e.g. for TSynMonitorUsage persistence/tracking - property Name: RawUTF8 read fName write fName; - published - /// indicates if this thread is currently working on some process - property Processing: boolean read fProcessing write fProcessing; - /// how many times the task was performed - property TaskCount: TSynMonitorCount64 read fTaskCount write fTaskCount; - /// the whole time spend during all working process - property TotalTime: TSynMonitorTime read fTotalTime; - /// the time spend during the last task processing - property LastTime: TSynMonitorOneTime read fLastTime; - /// the lowest time spent during any working process - property MinimalTime: TSynMonitorOneTime read fMinimalTime; - /// the time spent in average during any working process - property AverageTime: TSynMonitorOneTime read fAverageTime; - /// the highest time spent during any working process - property MaximalTime: TSynMonitorOneTime read fMaximalTime; - /// average of how many tasks did occur per second - property PerSec: QWord read fPerSec; - /// how many errors did occur during the processing - property Errors: TSynMonitorCount read fInternalErrors; - /// information about the last error which occured during the processing - property LastError: variant read fLastInternalError; - end; - /// references a TSynMonitor instance - PSynMonitor = ^TSynMonitor; - - /// handle generic process statistic with a processing data size and bandwitdh - TSynMonitorWithSize = class(TSynMonitor) - protected - fSize: TSynMonitorSize; - fThroughput: TSynMonitorThroughput; - procedure LockedPerSecProperties; override; - procedure LockedSum(another: TSynMonitor); override; - public - /// initialize the instance nested class properties - constructor Create; override; - /// finalize the instance - destructor Destroy; override; - /// increase the internal size counter - // - thread-safe method - procedure AddSize(const Bytes: QWord); - published - /// how many total data has been hanlded during all working process - property Size: TSynMonitorSize read fSize; - /// data processing bandwith, returned as B/KB/MB per second - property Throughput: TSynMonitorThroughput read fThroughput; - end; - - /// handle generic process statistic with a incoming and outgoing processing - // data size and bandwitdh - TSynMonitorInputOutput = class(TSynMonitor) - protected - fInput: TSynMonitorSize; - fOutput: TSynMonitorSize; - fInputThroughput: TSynMonitorThroughput; - fOutputThroughput: TSynMonitorThroughput; - procedure LockedPerSecProperties; override; - procedure LockedSum(another: TSynMonitor); override; - public - /// initialize the instance nested class properties - constructor Create; override; - /// finalize the instance - destructor Destroy; override; - /// increase the internal size counters - // - thread-safe method - procedure AddSize(const Incoming, Outgoing: QWord); - published - /// how many data has been received - property Input: TSynMonitorSize read fInput; - /// how many data has been sent back - property Output: TSynMonitorSize read fOutput; - /// incoming data processing bandwith, returned as B/KB/MB per second - property InputThroughput: TSynMonitorThroughput read fInputThroughput; - /// outgoing data processing bandwith, returned as B/KB/MB per second - property OutputThroughput: TSynMonitorThroughput read fOutputThroughput; - end; - - /// could monitor a standard Server - // - including Input/Output statistics and connected Clients count - TSynMonitorServer = class(TSynMonitorInputOutput) - protected - fCurrentRequestCount: integer; - fClientsCurrent: TSynMonitorOneCount; - fClientsMax: TSynMonitorOneCount; - public - /// update ClientsCurrent and ClientsMax - // - thread-safe method - procedure ClientConnect; - /// update ClientsCurrent and ClientsMax - // - thread-safe method - procedure ClientDisconnect; - /// update ClientsCurrent to 0 - // - thread-safe method - procedure ClientDisconnectAll; - /// retrieve the number of connected clients - // - thread-safe method - function GetClientsCurrent: TSynMonitorOneCount; - /// how many concurrent requests are currently processed - // - returns the updated number of requests - // - thread-safe method - function AddCurrentRequestCount(diff: integer): integer; - published - /// current count of connected clients - property ClientsCurrent: TSynMonitorOneCount read fClientsCurrent; - /// max count of connected clients - property ClientsMax: TSynMonitorOneCount read fClientsMax; - /// how many concurrent requests are currently processed - // - modified via AddCurrentRequestCount() in TSQLRestServer.URI() - property CurrentRequestCount: integer read fCurrentRequestCount; - end; - - /// a list of simple process statistics - TSynMonitorObjArray = array of TSynMonitor; - - /// a list of data process statistics - TSynMonitorWithSizeObjArray = array of TSynMonitorWithSize; - - /// a list of incoming/outgoing data process statistics - TSynMonitorInputOutputObjArray = array of TSynMonitorInputOutput; - - /// class-reference type (metaclass) of a process statistic information - TSynMonitorClass = class of TSynMonitor; - - -{ ******************* cross-cutting classes and functions ***************** } - -type - /// an abstract ancestor, for implementing a custom TInterfacedObject like class - // - by default, will do nothing: no instance would be retrieved by - // QueryInterface unless the VirtualQueryInterface protected method is - // overriden, and _AddRef/_Release methods would call VirtualAddRef and - // VirtualRelease pure abstract methods - // - using this class will leverage the signature difference between Delphi - // and FPC, among all supported platforms - // - the class includes a RefCount integer field - TSynInterfacedObject = class(TObject,IUnknown) - protected - fRefCount: integer; - // returns E_NOINTERFACE - function VirtualQueryInterface(const IID: TGUID; out Obj): HResult; virtual; - // always return 1 for a "non allocated" instance (0 triggers release) - function VirtualAddRef: Integer; virtual; abstract; - function VirtualRelease: Integer; virtual; abstract; - {$ifdef FPC} - function QueryInterface( - {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; - out Obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; - function _AddRef: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; - function _Release: longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; - {$else} - function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; - function _AddRef: Integer; stdcall; - function _Release: Integer; stdcall; - {$endif} - public - /// the associated reference count - property RefCount: integer read fRefCount write fRefCount; - end; - -{$ifdef CPUINTEL} -{$ifndef DELPHI5OROLDER} - /// a simple class which will set FPU exception flags for a code block - // - using an IUnknown interface to let the compiler auto-generate a - // try..finally block statement to reset the FPU exception register - // - to be used e.g. as such: - // !begin - // ! TSynFPUException.ForLibrayCode; - // ! ... now FPU exceptions will be ignored - // ! ... so here it is safe to call external libray code - // !end; // now FPU exception will be reset as with standard Delphi - // - it will avoid any unexpected invalid floating point operation in Delphi - // code, whereas it was in fact triggerred in some external library code - TSynFPUException = class(TSynInterfacedObject) - protected - {$ifndef CPU64} - fExpected8087, fSaved8087: word; - {$else} - fExpectedMXCSR, fSavedMXCSR: word; - {$endif} - function VirtualAddRef: Integer; override; - function VirtualRelease: Integer; override; - public - /// internal constructor - // - do not call this constructor directly, but rather use - // ForLibraryCode/ForDelphiCode class methods - // - for cpu32 flags are $1372 for Delphi, or $137F for library (mask all exceptions) - // - for cpu64 flags are $1920 for Delphi, or $1FA0 for library (mask all exceptions) - {$ifndef CPU64} - constructor Create(Expected8087Flag: word); reintroduce; - {$else} - constructor Create(ExpectedMXCSR: word); reintroduce; - {$endif} - /// after this method call, all FPU exceptions will be ignored - // - until the method finishes (a try..finally block is generated by - // the compiler), then FPU exceptions will be reset into "Delphi" mode - // - you have to put this e.g. before calling an external libray - // - this method is thread-safe and re-entrant (by reference-counting) - class function ForLibraryCode: IUnknown; - /// after this method call, all FPU exceptions will be enabled - // - this is the Delphi normal behavior - // - until the method finishes (a try..finally block is generated by - // the compiler), then FPU execptions will be disabled again - // - you have to put this e.g. before running an Delphi code from - // a callback executed in an external libray - // - this method is thread-safe and re-entrant (by reference-counting) - class function ForDelphiCode: IUnknown; - end; -{$endif DELPHI5OROLDER} -{$endif CPUINTEL} - - /// interface for TAutoFree to register another TObject instance - // to an existing IAutoFree local variable - IAutoFree = interface - procedure Another(var objVar; obj: TObject); - end; - - /// simple reference-counted storage for local objects - // - WARNING: both FPC and Delphi 10.4+ don't keep the IAutoFree instance - // up to the end-of-method -> you should not use TAutoFree for new projects - // :( - see https://quality.embarcadero.com/browse/RSP-30050 - // - be aware that it won't implement a full ARC memory model, but may be - // just used to avoid writing some try ... finally blocks on local variables - // - use with caution, only on well defined local scope - TAutoFree = class(TInterfacedObject,IAutoFree) - protected - fObject: TObject; - fObjectList: array of TObject; - public - /// initialize the TAutoFree class for one local variable - // - do not call this constructor, but class function One() instead - constructor Create(var localVariable; obj: TObject); reintroduce; overload; - /// initialize the TAutoFree class for several local variables - // - do not call this constructor, but class function Several() instead - constructor Create(const varObjPairs: array of pointer); reintroduce; overload; - /// protect one local TObject variable instance life time - // - for instance, instead of writing: - // !var myVar: TMyClass; - // !begin - // ! myVar := TMyClass.Create; - // ! try - // ! ... use myVar - // ! finally - // ! myVar.Free; - // ! end; - // !end; - // - you may write: - // !var myVar: TMyClass; - // !begin - // ! TAutoFree.One(myVar,TMyClass.Create); - // ! ... use myVar - // !end; // here myVar will be released - // - warning: under FPC, you should assign the result of this method to a local - // IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602 - // - Delphi 10.4 also did change it and release the IAutoFree before the - // end of the current method, so you should better use a local variable - class function One(var localVariable; obj: TObject): IAutoFree; - /// protect several local TObject variable instances life time - // - specified as localVariable/objectInstance pairs - // - you may write: - // !var var1,var2: TMyClass; - // !begin - // ! TAutoFree.Several([ - // ! @var1,TMyClass.Create, - // ! @var2,TMyClass.Create]); - // ! ... use var1 and var2 - // !end; // here var1 and var2 will be released - // - warning: under FPC, you should assign the result of this method to a local - // IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602 - // - Delphi 10.4 also did change it and release the IAutoFree before the - // end of the current method, so you should better use a local variable - class function Several(const varObjPairs: array of pointer): IAutoFree; - /// protect another TObject variable to an existing IAutoFree instance life time - // - you may write: - // !var var1,var2: TMyClass; - // ! auto: IAutoFree; - // !begin - // ! auto := TAutoFree.One(var1,TMyClass.Create);, - // ! .... do something - // ! auto.Another(var2,TMyClass.Create); - // ! ... use var1 and var2 - // !end; // here var1 and var2 will be released - procedure Another(var localVariable; obj: TObject); - /// will finalize the associated TObject instances - // - note that releasing the TObject instances won't be protected, so - // any exception here may induce a memory leak: use only with "safe" - // simple objects, e.g. mORMot's TSQLRecord - destructor Destroy; override; - end; - -{$ifdef DELPHI5OROLDER} // IAutoLocker -> internal error C3517 under Delphi 5 :( - TAutoLocker = class - protected - fSafe: TSynLocker; - public - constructor Create; - destructor Destroy; override; - procedure Enter; virtual; - procedure Leave; virtual; - function ProtectMethod: IUnknown; - /// gives an access to the internal low-level TSynLocker instance used - function Safe: PSynLocker; - property Locker: TSynLocker read fSafe; - end; - IAutoLocker = TAutoLocker; -{$else DELPHI5OROLDER} - /// an interface used by TAutoLocker to protect multi-thread execution - IAutoLocker = interface - ['{97559643-6474-4AD3-AF72-B9BB84B4955D}'] - /// enter the mutex - // - any call to Enter should be ended with a call to Leave, and - // protected by a try..finally block, as such: - // !begin - // ! ... // unsafe code - // ! fSharedAutoLocker.Enter; - // ! try - // ! ... // thread-safe code - // ! finally - // ! fSharedAutoLocker.Leave; - // ! end; - // !end; - procedure Enter; - /// leave the mutex - // - any call to Leave should be preceded with a call to Enter - procedure Leave; - /// will enter the mutex until the IUnknown reference is released - // - using an IUnknown interface to let the compiler auto-generate a - // try..finally block statement to release the lock for the code block - // - could be used as such under Delphi: - // !begin - // ! ... // unsafe code - // ! fSharedAutoLocker.ProtectMethod; - // ! ... // thread-safe code - // !end; // local hidden IUnknown will release the lock for the method - // - warning: under FPC, you should assign its result to a local variable - - // see bug http://bugs.freepascal.org/view.php?id=26602 - // !var LockFPC: IUnknown; - // !begin - // ! ... // unsafe code - // ! LockFPC := fSharedAutoLocker.ProtectMethod; - // ! ... // thread-safe code - // !end; // LockFPC will release the lock for the method - // or - // !begin - // ! ... // unsafe code - // ! with fSharedAutoLocker.ProtectMethod do begin - // ! ... // thread-safe code - // ! end; // local hidden IUnknown will release the lock for the method - // !end; - function ProtectMethod: IUnknown; - /// gives an access to the internal low-level TSynLocker instance used - function Safe: PSynLocker; - end; - - /// reference-counted block code critical section - // - you can use one instance of this to protect multi-threaded execution - // - the main class may initialize a IAutoLocker property in Create, then call - // IAutoLocker.ProtectMethod in any method to make its execution thread safe - // - this class inherits from TInterfacedObjectWithCustomCreate so you - // could define one published property of a mORMot.pas' TInjectableObject - // as IAutoLocker so that this class may be automatically injected - // - you may use the inherited TAutoLockerDebug class, as defined in SynLog.pas, - // to debug unexpected race conditions due to such critical sections - // - consider inherit from high-level TSynPersistentLock or call low-level - // fSafe := NewSynLocker / fSafe^.DoneAndFreemem instead - TAutoLocker = class(TInterfacedObjectWithCustomCreate,IAutoLocker) - protected - fSafe: TSynLocker; - public - /// initialize the mutex - constructor Create; override; - /// finalize the mutex - destructor Destroy; override; - /// will enter the mutex until the IUnknown reference is released - // - as expected by IAutoLocker interface - // - could be used as such under Delphi: - // !begin - // ! ... // unsafe code - // ! fSharedAutoLocker.ProtectMethod; - // ! ... // thread-safe code - // !end; // local hidden IUnknown will release the lock for the method - // - warning: under FPC, you should assign its result to a local variable - - // see bug http://bugs.freepascal.org/view.php?id=26602 - // !var LockFPC: IUnknown; - // !begin - // ! ... // unsafe code - // ! LockFPC := fSharedAutoLocker.ProtectMethod; - // ! ... // thread-safe code - // !end; // LockFPC will release the lock for the method - // or - // !begin - // ! ... // unsafe code - // ! with fSharedAutoLocker.ProtectMethod do begin - // ! ... // thread-safe code - // ! end; // local hidden IUnknown will release the lock for the method - // !end; - function ProtectMethod: IUnknown; - /// enter the mutex - // - as expected by IAutoLocker interface - // - any call to Enter should be ended with a call to Leave, and - // protected by a try..finally block, as such: - // !begin - // ! ... // unsafe code - // ! fSharedAutoLocker.Enter; - // ! try - // ! ... // thread-safe code - // ! finally - // ! fSharedAutoLocker.Leave; - // ! end; - // !end; - procedure Enter; virtual; - /// leave the mutex - // - as expected by IAutoLocker interface - procedure Leave; virtual; - /// access to the locking methods of this instance - // - as expected by IAutoLocker interface - function Safe: PSynLocker; - /// direct access to the locking methods of this instance - // - faster than IAutoLocker.Safe function - property Locker: TSynLocker read fSafe; - end; -{$endif DELPHI5OROLDER} - - -{$ifndef DELPHI5OROLDER} // internal error C3517 under Delphi 5 :( -{$ifndef NOVARIANTS} - /// ref-counted interface for thread-safe access to a TDocVariant document - // - is implemented e.g. by TLockedDocVariant, for IoC/DI resolution - // - fast and safe storage of any JSON-like object, as property/value pairs, - // or a JSON-like array, as values - ILockedDocVariant = interface - ['{CADC2C20-3F5D-4539-9D23-275E833A86F3}'] - function GetValue(const Name: RawUTF8): Variant; - procedure SetValue(const Name: RawUTF8; const Value: Variant); - /// check and return a given property by name - // - returns TRUE and fill Value with the value associated with the supplied - // Name, using an internal lock for thread-safety - // - returns FALSE if the Name was not found, releasing the internal lock: - // use ExistsOrLock() if you want to add the missing value - function Exists(const Name: RawUTF8; out Value: Variant): boolean; - /// check and return a given property by name - // - returns TRUE and fill Value with the value associated with the supplied - // Name, using an internal lock for thread-safety - // - returns FALSE and set the internal lock if Name does not exist: - // caller should then release the lock via ReplaceAndUnlock() - function ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean; - /// set a value by property name, and set a local copy - // - could be used as such, for implementing a thread-safe cache: - // ! if not cache.ExistsOrLock('prop',local) then - // ! cache.ReplaceAndUnlock('prop',newValue,local); - // - call of this method should have been precedeed by ExistsOrLock() - // returning false, i.e. be executed on a locked instance - procedure ReplaceAndUnlock(const Name: RawUTF8; const Value: Variant; out LocalValue: Variant); - /// add an existing property value to the given TDocVariant document object - // - returns TRUE and add the Name/Value pair to Obj if Name is existing, - // using an internal lock for thread-safety - // - returns FALSE if Name is not existing in the stored document, and - // lock the internal storage: caller should eventually release the lock - // via AddNewPropAndUnlock() - // - could be used as such, for implementing a thread-safe cache: - // ! if not cache.AddExistingPropOrLock('Articles',Scope) then - // ! cache.AddNewPropAndUnlock('Articles',GetArticlesFromDB,Scope); - // here GetArticlesFromDB would occur inside the main lock - function AddExistingPropOrLock(const Name: RawUTF8; var Obj: variant): boolean; - /// add a property value to the given TDocVariant document object and - // to the internal stored document, then release a previous lock - // - call of this method should have been precedeed by AddExistingPropOrLock() - // returning false, i.e. be executed on a locked instance - procedure AddNewPropAndUnlock(const Name: RawUTF8; const Value: variant; var Obj: variant); - /// add an existing property value to the given TDocVariant document object - // - returns TRUE and add the Name/Value pair to Obj if Name is existing - // - returns FALSE if Name is not existing in the stored document - // - this method would use a lock during the Name lookup, but would always - // release the lock, even if returning FALSE (see AddExistingPropOrLock) - function AddExistingProp(const Name: RawUTF8; var Obj: variant): boolean; - /// add a property value to the given TDocVariant document object - // - this method would not expect the resource to be locked when called, - // as with AddNewPropAndUnlock - // - will use the internal lock for thread-safety - // - if the Name is already existing, would update/change the existing value - // - could be used as such, for implementing a thread-safe cache: - // ! if not cache.AddExistingProp('Articles',Scope) then - // ! cache.AddNewProp('Articles',GetArticlesFromDB,Scope); - // here GetArticlesFromDB would occur outside the main lock - procedure AddNewProp(const Name: RawUTF8; const Value: variant; var Obj: variant); - /// append a value to the internal TDocVariant document array - // - you should not use this method in conjunction with other document-based - // alternatives, like Exists/AddExistingPropOrLock or AddExistingProp - procedure AddItem(const Value: variant); - /// makes a thread-safe copy of the internal TDocVariant document object or array - function Copy: variant; - /// delete all stored properties - procedure Clear; - /// save the stored values as UTF-8 encoded JSON Object - function ToJSON(HumanReadable: boolean=false): RawUTF8; - /// low-level access to the associated thread-safe mutex - function Lock: TAutoLocker; - /// the document fields would be safely accessed via this property - // - this is the main entry point of this storage - // - will raise an EDocVariant exception if Name does not exist at reading - // - implementation class would make a thread-safe copy of the variant value - property Value[const Name: RawUTF8]: Variant read GetValue write SetValue; default; - end; - - /// allows thread-safe access to a TDocVariant document - // - this class inherits from TInterfacedObjectWithCustomCreate so you - // could define one published property of a mORMot.pas' TInjectableObject - // as ILockedDocVariant so that this class may be automatically injected - TLockedDocVariant = class(TInterfacedObjectWithCustomCreate,ILockedDocVariant) - protected - fValue: TDocVariantData; - fLock: TAutoLocker; - function GetValue(const Name: RawUTF8): Variant; - procedure SetValue(const Name: RawUTF8; const Value: Variant); - public - /// initialize the thread-safe document with a fast TDocVariant - // - i.e. call Create(true) aka Create(JSON_OPTIONS[true]) - // - will be the TInterfacedObjectWithCustomCreate default constructor, - // called e.g. during IoC/DI resolution - constructor Create; overload; override; - /// initialize the thread-safe document storage - constructor Create(FastStorage: boolean); reintroduce; overload; - /// initialize the thread-safe document storage with the corresponding options - constructor Create(options: TDocVariantOptions); reintroduce; overload; - /// finalize the storage - destructor Destroy; override; - /// check and return a given property by name - function Exists(const Name: RawUTF8; out Value: Variant): boolean; - /// check and return a given property by name - // - this version - function ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean; - /// set a value by property name, and set a local copy - procedure ReplaceAndUnlock(const Name: RawUTF8; const Value: Variant; out LocalValue: Variant); - /// add an existing property value to the given TDocVariant document object - // - returns TRUE and add the Name/Value pair to Obj if Name is existing - // - returns FALSE if Name is not existing in the stored document - function AddExistingPropOrLock(const Name: RawUTF8; var Obj: variant): boolean; - /// add a property value to the given TDocVariant document object and - // to the internal stored document - procedure AddNewPropAndUnlock(const Name: RawUTF8; const Value: variant; var Obj: variant); - /// add an existing property value to the given TDocVariant document object - // - returns TRUE and add the Name/Value pair to Obj if Name is existing - // - returns FALSE if Name is not existing in the stored document - // - this method would use a lock during the Name lookup, but would always - // release the lock, even if returning FALSE (see AddExistingPropOrLock) - function AddExistingProp(const Name: RawUTF8; var Obj: variant): boolean; - /// add a property value to the given TDocVariant document object - // - this method would not expect the resource to be locked when called, - // as with AddNewPropAndUnlock - // - will use the internal lock for thread-safety - // - if the Name is already existing, would update/change the existing value - procedure AddNewProp(const Name: RawUTF8; const Value: variant; var Obj: variant); - /// append a value to the internal TDocVariant document array - procedure AddItem(const Value: variant); - /// makes a thread-safe copy of the internal TDocVariant document object or array - function Copy: variant; - /// delete all stored properties - procedure Clear; - /// save the stored value as UTF-8 encoded JSON Object - // - implemented as just a wrapper around VariantSaveJSON() - function ToJSON(HumanReadable: boolean=false): RawUTF8; - /// low-level access to the associated thread-safe mutex - function Lock: TAutoLocker; - /// the document fields would be safely accessed via this property - // - will raise an EDocVariant exception if Name does not exist - // - result variant is returned as a copy, not as varByRef, since a copy - // will definitively be more thread safe - property Value[const Name: RawUTF8]: Variant read GetValue write SetValue; default; - end; -{$endif} -{$endif} - -type - /// class-reference type (metaclass) of an TSynPersistentLock class - TSynPersistentLockClass = class of TSynPersistentLock; - - /// abstract dynamic array of TSynPersistentLock instance - // - note defined as T*ObjArray, since it won't - TSynPersistentLockDynArray = array of TSynPersistentLock; - -/// convert a size to a human readable value power-of-two metric value -// - append EB, PB, TB, GB, MB, KB or B symbol with or without preceding space -// - for EB, PB, TB, GB, MB and KB, add one fractional digit -procedure KB(bytes: Int64; out result: TShort16; nospace: boolean); overload; - -/// convert a size to a human readable value -// - append EB, PB, TB, GB, MB, KB or B symbol with preceding space -// - for EB, PB, TB, GB, MB and KB, add one fractional digit -function KB(bytes: Int64): TShort16; overload; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - -/// convert a size to a human readable value -// - append EB, PB, TB, GB, MB, KB or B symbol without preceding space -// - for EB, PB, TB, GB, MB and KB, add one fractional digit -function KBNoSpace(bytes: Int64): TShort16; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - -/// convert a size to a human readable value -// - append EB, PB, TB, GB, MB, KB or B symbol with or without preceding space -// - for EB, PB, TB, GB, MB and KB, add one fractional digit -function KB(bytes: Int64; nospace: boolean): TShort16; overload; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - -/// convert a string size to a human readable value -// - append EB, PB, TB, GB, MB, KB or B symbol -// - for EB, PB, TB, GB, MB and KB, add one fractional digit -function KB(const buffer: RawByteString): TShort16; overload; - {$ifdef FPC_OR_UNICODE}inline;{$endif} - -/// convert a size to a human readable value -// - append EB, PB, TB, GB, MB, KB or B symbol -// - for EB, PB, TB, GB, MB and KB, add one fractional digit -procedure KBU(bytes: Int64; var result: RawUTF8); - -/// convert a micro seconds elapsed time into a human readable value -// - append 'us', 'ms', 's', 'm', 'h' and 'd' symbol for the given value range, -// with two fractional digits -function MicroSecToString(Micro: QWord): TShort16; overload; - {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell - -/// convert a micro seconds elapsed time into a human readable value -// - append 'us', 'ms', 's', 'm', 'h' and 'd' symbol for the given value range, -// with two fractional digits -procedure MicroSecToString(Micro: QWord; out result: TShort16); overload; - -/// convert an integer value into its textual representation with thousands marked -// - ThousandSep is the character used to separate thousands in numbers with -// more than three digits to the left of the decimal separator -function IntToThousandString(Value: integer; const ThousandSep: TShort4=','): shortstring; - -/// return the Delphi/FPC Compiler Version -// - returns 'Delphi 2007', 'Delphi 2010' or 'Free Pascal 3.3.1' e.g. -function GetDelphiCompilerVersion: RawUTF8; - -/// returns TRUE if the supplied mutex has been initialized -// - will check if the supplied mutex is void (i.e. all filled with 0 bytes) -function IsInitializedCriticalSection(const CS: TRTLCriticalSection): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// on need initialization of a mutex, then enter the lock -// - if the supplied mutex has been initialized, do nothing -// - if the supplied mutex is void (i.e. all filled with 0), initialize it -procedure InitializeCriticalSectionIfNeededAndEnter(var CS: TRTLCriticalSection); - {$ifdef HASINLINE}inline;{$endif} - -/// on need finalization of a mutex -// - if the supplied mutex has been initialized, delete it -// - if the supplied mutex is void (i.e. all filled with 0), do nothing -procedure DeleteCriticalSectionIfNeeded(var CS: TRTLCriticalSection); - -/// compress a data content using the SynLZ algorithm -// - as expected by THttpSocket.RegisterCompress -// - will return 'synlz' as ACCEPT-ENCODING: header parameter -// - will store a hash of both compressed and uncompressed stream: if the -// data is corrupted during transmission, will instantly return '' -function CompressSynLZ(var DataRawByteString; Compress: boolean): AnsiString; - -/// compress a data content using the SynLZ algorithm from one stream into another -// - returns the number of bytes written to Dest -// - you should specify a Magic number to be used to identify the block -function StreamSynLZ(Source: TCustomMemoryStream; Dest: TStream; - Magic: cardinal): integer; overload; - -/// compress a data content using the SynLZ algorithm from one stream into a file -// - returns the number of bytes written to the destination file -// - you should specify a Magic number to be used to identify the block -function StreamSynLZ(Source: TCustomMemoryStream; const DestFile: TFileName; - Magic: cardinal): integer; overload; - -/// uncompress using the SynLZ algorithm from one stream into another -// - returns a newly create memory stream containing the uncompressed data -// - returns nil if source data is invalid -// - you should specify a Magic number to be used to identify the block -// - this function will also recognize the block at the end of the source stream -// (if was appended to an existing data - e.g. a .mab at the end of a .exe) -// - on success, Source will point after all read data (so that you can e.g. -// append several data blocks to the same stream) -function StreamUnSynLZ(Source: TStream; Magic: cardinal): TMemoryStream; overload; - -/// compute the real length of a given StreamSynLZ-compressed buffer -// - allows to replace an existing appended content, for instance -function StreamSynLZComputeLen(P: PAnsiChar; Len, aMagic: cardinal): integer; - -/// uncompress using the SynLZ algorithm from one file into another -// - returns a newly create memory stream containing the uncompressed data -// - returns nil if source file is invalid (e.g. invalid name or invalid content) -// - you should specify a Magic number to be used to identify the block -// - this function will also recognize the block at the end of the source file -// (if was appended to an existing data - e.g. a .mab at the end of a .exe) -function StreamUnSynLZ(const Source: TFileName; Magic: cardinal): TMemoryStream; overload; - -/// compress a file content using the SynLZ algorithm -// - source file is split into 128 MB blocks for fast in-memory compression of -// any file size, then SynLZ compressed and including a Hash32 checksum -// - it is not compatible with StreamSynLZ format, which has no 128 MB chunking -// - you should specify a Magic number to be used to identify the compressed -// file format -function FileSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; - -/// uncompress a file previoulsy compressed via FileSynLZ( -// - you should specify a Magic number to be used to identify the compressed -// file format -function FileUnSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; - -/// returns TRUE if the supplied file name is a SynLZ compressed file, -// matching the Magic number as supplied to FileSynLZ() function -function FileIsSynLZ(const Name: TFileName; Magic: Cardinal): boolean; - -var - /// acccess to our fast SynLZ compression as a TAlgoCompress class - // - please use this global variable methods instead of the deprecated - // SynLZCompress/SynLZDecompress wrapper functions - AlgoSynLZ: TAlgoCompress; - -const - /// CompressionSizeTrigger parameter SYNLZTRIG[true] will disable then - // SynLZCompress() compression - SYNLZTRIG: array[boolean] of integer = (100, maxInt); - /// used e.g. as when ALGO_SAFE[SafeDecompression] for TAlgoCompress.Decompress - ALGO_SAFE: array[boolean] of TAlgoCompressLoad = (aclNormal, aclSafeSlow); - - -/// deprecated function - please call AlgoSynLZ.Compress() method -function SynLZCompress(const Data: RawByteString; CompressionSizeTrigger: integer=100; - CheckMagicForCompressed: boolean=false): RawByteString; overload; - -/// deprecated function - please call AlgoSynLZ.Compress() method -procedure SynLZCompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; - CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false); overload; - -/// deprecated function - please call AlgoSynLZ.Compress() method -function SynLZCompress(P, Dest: PAnsiChar; PLen, DestLen: integer; - CompressionSizeTrigger: integer=100; CheckMagicForCompressed: boolean=false): integer; overload; - -/// deprecated function - please call AlgoSynLZ.Decompress() method -function SynLZDecompress(const Data: RawByteString): RawByteString; overload; - -/// deprecated function - please call AlgoSynLZ.Decompress() method -procedure SynLZDecompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; - SafeDecompression: boolean=false); overload; - -/// deprecated function - please call AlgoSynLZ.DecompressToBytes() method -function SynLZCompressToBytes(const Data: RawByteString; - CompressionSizeTrigger: integer=100): TByteDynArray; overload; - -/// deprecated function - please call AlgoSynLZ.CompressToBytes() method -function SynLZCompressToBytes(P: PAnsiChar; PLen: integer; - CompressionSizeTrigger: integer=100): TByteDynArray; overload; - -/// deprecated function - please call AlgoSynLZ.Decompress() method -function SynLZDecompress(const Data: TByteDynArray): RawByteString; overload; - -/// deprecated function - please call AlgoSynLZ.Decompress() method -function SynLZDecompress(const Data: RawByteString; out Len: integer; - var tmp: RawByteString): pointer; overload; - -/// deprecated function - please call AlgoSynLZ.Decompress() method -function SynLZDecompress(P: PAnsiChar; PLen: integer; out Len: integer; - var tmp: RawByteString): pointer; overload; - -/// deprecated function - please call AlgoSynLZ.DecompressHeader() method -function SynLZDecompressHeader(P: PAnsiChar; PLen: integer): integer; - -/// deprecated function - please call AlgoSynLZ.DecompressBody() method -function SynLZDecompressBody(P,Body: PAnsiChar; PLen,BodyLen: integer; - SafeDecompression: boolean=false): boolean; - -/// deprecated function - please call AlgoSynLZ.DecompressPartial() method -function SynLZDecompressPartial(P,Partial: PAnsiChar; PLen,PartialLen: integer): integer; - - - -implementation - -{$ifdef FPC} -uses - {$ifdef FPC_X64MM} - {$ifdef CPUX64} - SynFPCx64MM, - {$else} - {$undef FPC_X64MM} - {$endif CPUX64} - {$endif FPC_X64MM} - {$ifdef LINUX} - Unix, - dynlibs, - {$ifdef BSD} - sysctl, - {$else} - Linux, - {$endif BSD} - {$ifdef FPCUSEVERSIONINFO} // to be enabled in Synopse.inc - fileinfo, // FPC 3.0 and up - {$ifdef DARWIN} - machoreader, // MACH-O executables - {$else} - elfreader, // ELF executables - {$endif DARWIN} - {$endif FPCUSEVERSIONINFO} - {$ifdef ISFPC271} - unixcp, // for GetSystemCodePage - {$endif} - SynFPCLinux, - {$endif LINUX} - SynFPCTypInfo; // small wrapper unit around FPC's TypInfo.pp -{$endif FPC} - - -{ ************ some fast UTF-8 / Unicode / Ansi conversion routines } - -var - // internal list of TSynAnsiConvert instances - SynAnsiConvertList: TSynObjectList = nil; - -{$ifdef HASINLINE} -{$ifdef USE_VTYPE_STATIC} // circumvent weird bug on BSD + ARM (Alfred) -procedure VarClear(var v: variant); // defined here for proper inlining -const VTYPE_STATIC = $BFE8; // bitmask to avoid remote VarClearProc call -var p: PInteger; // more efficient generated asm with an explicit temp variable -begin - p := @v; - if p^ and VTYPE_STATIC=0 then - p^ := 0 else - VarClearProc(PVarData(p)^); -end; -{$else} -procedure VarClear(var v: variant); // defined here for proper inlining -begin - VarClearProc(PVarData(@v)^); -end; -{$endif USE_VTYPE_STATIC} -{$endif HASINLINE} - -procedure MoveSmall(Source, Dest: Pointer; Count: PtrUInt); -var c: AnsiChar; // better FPC inlining -begin - inc(PtrUInt(Source),Count); - inc(PtrUInt(Dest),Count); - PtrInt(Count) := -PtrInt(Count); - repeat - c := PAnsiChar(Source)[Count]; - PAnsiChar(Dest)[Count] := c; - inc(Count); - until Count=0; -end; - - -{ TSynTempBuffer } - -procedure TSynTempBuffer.Init(Source: pointer; SourceLen: PtrInt); -begin - len := SourceLen; - if len<=0 then - buf := nil else begin - if len<=SizeOf(tmp)-16 then - buf := @tmp else - GetMem(buf,len+16); // +16 for trailing #0 and for PInteger() parsing - if Source<>nil then begin - MoveFast(Source^,buf^,len); - PPtrInt(PAnsiChar(buf)+len)^ := 0; // init last 4/8 bytes (makes valgrid happy) - end; - end; -end; - -function TSynTempBuffer.InitOnStack: pointer; -begin - buf := @tmp; - len := SizeOf(tmp); - result := @tmp; -end; - -procedure TSynTempBuffer.Init(const Source: RawByteString); -begin - Init(pointer(Source),length(Source)); -end; - -function TSynTempBuffer.Init(Source: PUTF8Char): PUTF8Char; -begin - Init(Source,StrLen(Source)); - result := buf; -end; - -function TSynTempBuffer.Init(SourceLen: PtrInt): pointer; -begin - len := SourceLen; - if len<=0 then - buf := nil else begin - if len<=SizeOf(tmp)-16 then - buf := @tmp else - GetMem(buf,len+16); // +16 for trailing #0 and for PInteger() parsing - end; - result := buf; -end; - -function TSynTempBuffer.Init: integer; -begin - buf := @tmp; - result := SizeOf(tmp)-16; - len := result; -end; - -function TSynTempBuffer.InitRandom(RandomLen: integer; forcegsl: boolean): pointer; -begin - Init(RandomLen); - if RandomLen>0 then - FillRandom(buf,(RandomLen shr 2)+1,forcegsl); - result := buf; -end; - -function TSynTempBuffer.InitIncreasing(Count, Start: PtrInt): PIntegerArray; -begin - Init((Count-Start)*4); - FillIncreasing(buf,Start,Count); - result := buf; -end; - -function TSynTempBuffer.InitZero(ZeroLen: PtrInt): pointer; -begin - Init(ZeroLen-16); - FillCharFast(buf^,ZeroLen,0); - result := buf; -end; - -procedure TSynTempBuffer.Done; -begin - if (buf<>@tmp) and (buf<>nil) then - FreeMem(buf); -end; - -procedure TSynTempBuffer.Done(EndBuf: pointer; var Dest: RawUTF8); -begin - if EndBuf=nil then - Dest := '' else - FastSetString(Dest,buf,PAnsiChar(EndBuf)-PAnsiChar(buf)); - if (buf<>@tmp) and (buf<>nil) then - FreeMem(buf); -end; - - -{ TSynAnsiConvert } - -{$ifdef MSWINDOWS} -const - DefaultCharVar: AnsiChar = '?'; -{$endif} - -function TSynAnsiConvert.AnsiBufferToUnicode(Dest: PWideChar; - Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PWideChar; -var c: cardinal; -{$ifndef MSWINDOWS} -{$ifdef KYLIX3} - ic: iconv_t; - DestBegin: PAnsiChar; - SourceCharsBegin: integer; -{$endif} -{$endif} -begin - {$ifdef KYLIX3} - SourceCharsBegin := SourceChars; - DestBegin := pointer(Dest); - {$endif} - // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) - if SourceChars>=4 then - repeat - c := PCardinal(Source)^; - if c and $80808080<>0 then - break; // break on first non ASCII quad - dec(SourceChars,4); - inc(Source,4); - PCardinal(Dest)^ := (c shl 8 or (c and $FF)) and $00ff00ff; - c := c shr 16; - PCardinal(Dest+2)^ := (c shl 8 or c) and $00ff00ff; - inc(Dest,4); - until SourceChars<4; - if (SourceChars>0) and (ord(Source^)<=127) then - repeat - dec(SourceChars); - PWord(Dest)^ := ord(Source^); // much faster than dest^ := WideChar(c) for FPC - inc(Source); - inc(Dest); - until (SourceChars=0) or (ord(Source^)>=128); - // rely on the Operating System for all remaining ASCII characters - if SourceChars=0 then - result := Dest else begin - {$ifdef MSWINDOWS} - result := Dest+MultiByteToWideChar( - fCodePage,MB_PRECOMPOSED,Source,SourceChars,Dest,SourceChars); - {$else} - {$ifdef ISDELPHIXE} // use cross-platform wrapper for MultiByteToWideChar() - result := Dest+UnicodeFromLocaleChars( - fCodePage,MB_PRECOMPOSED,Source,SourceChars,Dest,SourceChars); - {$else} - {$ifdef FPC} - // uses our SynFPCLinux ICU API helper - result := Dest+AnsiToWideICU(fCodePage,Source,Dest,SourceChars); - {$else} - {$ifdef KYLIX3} - result := Dest; // makes compiler happy - ic := LibC.iconv_open('UTF-16LE',Pointer(fIConvCodeName)); - if PtrInt(ic)>=0 then - try - result := IconvBufConvert(ic,Source,SourceChars,1, - Dest,SourceCharsBegin*2-(PAnsiChar(Dest)-DestBegin),2); - finally - LibC.iconv_close(ic); - end else - {$else} - raise ESynException.CreateUTF8('%.AnsiBufferToUnicode() not supported yet for CP=%', - [self,CodePage]); - {$endif KYLIX3} - {$endif FPC} - {$endif ISDELPHIXE} - {$endif MSWINDOWS} - end; - if not NoTrailingZero then - result^ := #0; -end; - -function TSynAnsiConvert.AnsiBufferToUTF8(Dest: PUTF8Char; - Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PUTF8Char; -var tmp: TSynTempBuffer; - c: cardinal; - U: PWideChar; -begin - // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) - if SourceChars>=4 then - repeat - c := PCardinal(Source)^; - if c and $80808080<>0 then - break; // break on first non ASCII quad - PCardinal(Dest)^ := c; - dec(SourceChars,4); - inc(Source,4); - inc(Dest,4); - until SourceChars<4; - if (SourceChars>0) and (ord(Source^)<=127) then - repeat - Dest^ := Source^; - dec(SourceChars); - inc(Source); - inc(Dest); - until (SourceChars=0) or (ord(Source^)>=128); - // rely on the Operating System for all remaining ASCII characters - if SourceChars=0 then - result := Dest else begin - U := AnsiBufferToUnicode(tmp.Init(SourceChars*3),Source,SourceChars); - result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3,tmp.buf, - (PtrUInt(U)-PtrUInt(tmp.buf))shr 1,[ccfNoTrailingZero]); - tmp.Done; - end; - if not NoTrailingZero then - result^ := #0; -end; - -// UTF-8 is AT MOST 50% bigger than UTF-16 in bytes in range U+0800..U+FFFF -// see http://stackoverflow.com/a/7008095 -> bytes=WideCharCount*3 below - -procedure TSynAnsiConvert.InternalAppendUTF8(Source: PAnsiChar; SourceChars: Cardinal; - DestTextWriter: TObject; Escape: TTextWriterKind); -var W: TTextWriter absolute DestTextWriter; - tmp: TSynTempBuffer; -begin // rely on explicit conversion - SourceChars := AnsiBufferToUTF8(tmp.Init(SourceChars*3),Source,SourceChars)-PUTF8Char(tmp.buf); - W.Add(tmp.buf,SourceChars,Escape); - tmp.Done; -end; - -function TSynAnsiConvert.AnsiToRawUnicode(const AnsiText: RawByteString): RawUnicode; -begin - result := AnsiToRawUnicode(pointer(AnsiText),length(AnsiText)); -end; - -function TSynAnsiConvert.AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; -var U: PWideChar; - tmp: TSynTempBuffer; -begin - if SourceChars=0 then - result := '' else begin - U := AnsiBufferToUnicode(tmp.Init(SourceChars*2),Source,SourceChars); - U^ := #0; - SetString(result,PAnsiChar(tmp.buf),PtrUInt(U)-PtrUInt(tmp.buf)+1); - tmp.Done; - end; -end; - -function TSynAnsiConvert.AnsiToUnicodeString(Source: PAnsiChar; SourceChars: Cardinal): SynUnicode; -var tmp: TSynTempBuffer; - U: PWideChar; -begin - if SourceChars=0 then - result := '' else begin - U := AnsiBufferToUnicode(tmp.Init(SourceChars*2),Source,SourceChars); - SetString(result,PWideChar(tmp.buf),(PtrUInt(U)-PtrUInt(tmp.buf))shr 1); - tmp.Done; - end; -end; - -function TSynAnsiConvert.AnsiToUnicodeString(const Source: RawByteString): SynUnicode; -var tmp: TSynTempBuffer; - U: PWideChar; -begin - if Source='' then - result := '' else begin - tmp.Init(length(Source)*2); // max dest size in bytes - U := AnsiBufferToUnicode(tmp.buf,pointer(Source),length(Source)); - SetString(result,PWideChar(tmp.buf),(PtrUInt(U)-PtrUInt(tmp.buf))shr 1); - tmp.Done; - end; -end; - -function TSynAnsiConvert.AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; -begin - result := AnsiBufferToRawUTF8(pointer(AnsiText),length(AnsiText)); -end; - -function TSynAnsiConvert.AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; -var tmp: TSynTempBuffer; - endchar: pointer; // try circumvent Delphi 10.4 optimization issue -begin - if (Source=nil) or (SourceChars=0) then - result := '' else begin - endchar := AnsiBufferToUTF8(tmp.Init(SourceChars*3),Source,SourceChars,true); - tmp.Done(endchar,result); - end; -end; - -constructor TSynAnsiConvert.Create(aCodePage: cardinal); -begin - fCodePage := aCodePage; - fAnsiCharShift := 1; // default is safe - {$ifdef KYLIX3} - fIConvCodeName := 'CP'+UInt32ToUTF8(aCodePage); - {$endif} -end; - -function IsFixedWidthCodePage(aCodePage: cardinal): boolean; -begin - result := ((aCodePage>=1250) and (aCodePage<=1258)) or - (aCodePage=CODEPAGE_LATIN1) or (aCodePage=CP_RAWBYTESTRING); -end; - -class function TSynAnsiConvert.Engine(aCodePage: cardinal): TSynAnsiConvert; -var i: PtrInt; -begin - if SynAnsiConvertList=nil then begin - GarbageCollectorFreeAndNil(SynAnsiConvertList,TSynObjectList.Create); - CurrentAnsiConvert := TSynAnsiConvert.Engine(GetACP); - WinAnsiConvert := TSynAnsiConvert.Engine(CODEPAGE_US) as TSynAnsiFixedWidth; - UTF8AnsiConvert := TSynAnsiConvert.Engine(CP_UTF8) as TSynAnsiUTF8; - end; - if aCodePage<=0 then begin - result := CurrentAnsiConvert; - exit; - end; - with SynAnsiConvertList do - for i := 0 to Count-1 do begin - result := List[i]; - if result.CodePage=aCodePage then - exit; - end; - if aCodePage=CP_UTF8 then - result := TSynAnsiUTF8.Create(CP_UTF8) else - if aCodePage=CP_UTF16 then - result := TSynAnsiUTF16.Create(CP_UTF16) else - if IsFixedWidthCodePage(aCodePage) then - result := TSynAnsiFixedWidth.Create(aCodePage) else - result := TSynAnsiConvert.Create(aCodePage); - SynAnsiConvertList.Add(result); -end; - -function TSynAnsiConvert.UnicodeBufferToAnsi(Dest: PAnsiChar; - Source: PWideChar; SourceChars: Cardinal): PAnsiChar; -var c: cardinal; -{$ifndef MSWINDOWS} -{$ifdef KYLIX3} - ic: iconv_t; - DestBegin: PAnsiChar; - SourceCharsBegin: integer; -{$endif} -{$endif MSWINDOWS} -begin - {$ifdef KYLIX3} - SourceCharsBegin := SourceChars; - DestBegin := Dest; - {$endif} - // first handle trailing 7 bit ASCII chars, by pairs (Sha optimization) - if SourceChars>=2 then - repeat - c := PCardinal(Source)^; - if c and $ff80ff80<>0 then - break; // break on first non ASCII pair - dec(SourceChars,2); - inc(Source,2); - c := c shr 8 or c; - PWord(Dest)^ := c; - inc(Dest,2); - until SourceChars<2; - if (SourceChars>0) and (ord(Source^)<=127) then - repeat - Dest^ := AnsiChar(ord(Source^)); - dec(SourceChars); - inc(Source); - inc(Dest); - until (SourceChars=0) or (ord(Source^)>=128); - // rely on the Operating System for all remaining ASCII characters - if SourceChars=0 then - result := Dest else begin - {$ifdef MSWINDOWS} - result := Dest+WideCharToMultiByte( - fCodePage,0,Source,SourceChars,Dest,SourceChars*3,@DefaultCharVar,nil); - {$else} - {$ifdef ISDELPHIXE} // use cross-platform wrapper for WideCharToMultiByte() - result := Dest+System.LocaleCharsFromUnicode( - fCodePage,0,Source,SourceChars,Dest,SourceChars*3,@DefaultCharVar,nil); - {$else} - {$ifdef FPC} - // uses our SynFPCLinux ICU API helper - result := Dest+WideToAnsiICU(fCodePage,Source,Dest,SourceChars); - {$else} - {$ifdef KYLIX3} - result := Dest; // makes compiler happy - ic := LibC.iconv_open(Pointer(fIConvCodeName),'UTF-16LE'); - if PtrInt(ic)>=0 then - try - result := IconvBufConvert(ic,Source,SourceChars,2, - Dest,SourceCharsBegin*3-(PAnsiChar(Dest)-DestBegin),1); - finally - LibC.iconv_close(ic); - end else - {$else} - raise ESynException.CreateUTF8('%.UnicodeBufferToAnsi() not supported yet for CP=%', - [self,CodePage]); {$endif KYLIX3} - {$endif FPC} - {$endif ISDELPHIXE} - {$endif MSWINDOWS} - end; -end; - -function TSynAnsiConvert.UTF8BufferToAnsi(Dest: PAnsiChar; - Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; -var tmp: TSynTempBuffer; -begin - if (Source=nil) or (SourceChars=0) then - result := Dest else begin - tmp.Init((SourceChars+1) shl fAnsiCharShift); - result := UnicodeBufferToAnsi(Dest,tmp.buf,UTF8ToWideChar(tmp.buf,Source,SourceChars) shr 1); - tmp.Done; - end; -end; - -function TSynAnsiConvert.UTF8BufferToAnsi(Source: PUTF8Char; - SourceChars: Cardinal): RawByteString; -begin - UTF8BufferToAnsi(Source,SourceChars,result); -end; - -procedure TSynAnsiConvert.UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal; - var result: RawByteString); -var tmp: TSynTempBuffer; -begin - if (Source=nil) or (SourceChars=0) then - result := '' else begin - tmp.Init((SourceChars+1) shl fAnsiCharShift); - FastSetStringCP(result,tmp.buf, - Utf8BufferToAnsi(tmp.buf,Source,SourceChars)-PAnsiChar(tmp.buf),fCodePage); - tmp.Done; - end; -end; - -function TSynAnsiConvert.UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; -begin - UTF8BufferToAnsi(pointer(UTF8),length(UTF8),result); -end; - -function TSynAnsiConvert.Utf8ToAnsiBuffer(const S: RawUTF8; - Dest: PAnsiChar; DestSize: integer): integer; -var tmp: array[0..2047] of AnsiChar; // truncated to 2KB as documented -begin - if (DestSize<=0) or (Dest=nil) then begin - result := 0; - exit; - end; - result := length(s); - if result>0 then begin - if result>SizeOf(tmp) then - result := SizeOf(tmp); - result := UTF8BufferToAnsi(tmp,pointer(s),result)-tmp; - if result>=DestSize then - result := DestSize-1; - MoveFast(tmp,Dest^,result); - end; - Dest[result] := #0; -end; - -function TSynAnsiConvert.UnicodeBufferToAnsi(Source: PWideChar; SourceChars: Cardinal): RawByteString; -var tmp: TSynTempBuffer; -begin - if (Source=nil) or (SourceChars=0) then - result := '' else begin - tmp.Init((SourceChars+1) shl fAnsiCharShift); - FastSetStringCP(result,tmp.buf, - UnicodeBufferToAnsi(tmp.buf,Source,SourceChars)-PAnsiChar(tmp.buf),fCodePage); - tmp.Done; - end; -end; - -function TSynAnsiConvert.RawUnicodeToAnsi(const Source: RawUnicode): RawByteString; -begin - result := UnicodeBufferToAnsi(pointer(Source),length(Source) shr 1); -end; - -function TSynAnsiConvert.AnsiToAnsi(From: TSynAnsiConvert; const Source: RawByteString): RawByteString; -begin - if From=self then - result := Source else - result := AnsiToAnsi(From,pointer(Source),length(Source)); -end; - -function TSynAnsiConvert.AnsiToAnsi(From: TSynAnsiConvert; Source: PAnsiChar; SourceChars: cardinal): RawByteString; -var tmpU: array[byte] of WideChar; - U: PWideChar; -begin - if From=self then - FastSetStringCP(result,Source,SourceChars,fCodePage) else - if (Source=nil) or (SourceChars=0) then - result := '' else - if SourceCharsnil) and (SourceChars>0) then begin - // handle 7 bit ASCII WideChars, by quads (Sha optimization) - EndSource := Source+SourceChars; - EndSourceBy4 := EndSource-4; - if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then - repeat -By4: c := PCardinal(Source)^; - if c and $80808080<>0 then - goto By1; // break on first non ASCII quad - inc(Source,4); - PCardinal(Dest)^ := c; - inc(Dest,4); - until Source>EndSourceBy4; - // generic loop, handling one WideChar per iteration - if Source$7ff then begin - Dest[0] := AnsiChar($E0 or (c shr 12)); - Dest[1] := AnsiChar($80 or ((c shr 6) and $3F)); - Dest[2] := AnsiChar($80 or (c and $3F)); - Inc(Dest,3); - if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then goto By4; - if Source 255 - // - values taken from MultiByteToWideChar(1252,0,@Tmp,256,@WinAnsiTable,256) - // so these values are available outside the Windows platforms (e.g. Linux/BSD) - // and even if registry has been tweaked as such: - // http://www.fas.harvard.edu/~chgis/data/chgis/downloads/v4/howto/cyrillic.html - WinAnsiUnicodeChars: packed array[128..159] of word = - (8364, 129, 8218, 402, 8222, 8230, 8224, 8225, 710, 8240, 352, 8249, 338, - 141, 381, 143, 144, 8216, 8217, 8220, 8221, 8226, 8211, 8212, 732, 8482, - 353, 8250, 339, 157, 382, 376); - -constructor TSynAnsiFixedWidth.Create(aCodePage: cardinal); -var i: PtrInt; - A256: array[0..256] of AnsiChar; - U256: array[0..256] of WideChar; // AnsiBufferToUnicode() write a last #0 -begin - inherited; - if not IsFixedWidthCodePage(aCodePage) then - // ESynException.CreateUTF8() uses UTF8ToString() -> use CreateFmt() here - raise ESynException.CreateFmt('%s.Create - Invalid code page %d', - [ClassName,fCodePage]); - // create internal look-up tables - SetLength(fAnsiToWide,256); - if (aCodePage=CODEPAGE_US) or (aCodePage=CODEPAGE_LATIN1) or - (aCodePage=CP_RAWBYTESTRING) then begin - for i := 0 to 255 do - fAnsiToWide[i] := i; - if aCodePage=CODEPAGE_US then // do not trust the Windows API :( - for i := low(WinAnsiUnicodeChars) to high(WinAnsiUnicodeChars) do - fAnsiToWide[i] := WinAnsiUnicodeChars[i]; - end else begin // from Operating System returned values - for i := 0 to 255 do - A256[i] := AnsiChar(i); - FillcharFast(U256,SizeOf(U256),0); - if PtrUInt(inherited AnsiBufferToUnicode(U256,A256,256))-PtrUInt(@U256)>512 then - // warning: CreateUTF8() uses UTF8ToString() -> use CreateFmt() now - raise ESynException.CreateFmt('OS error for %s.Create(%d)',[ClassName,aCodePage]); - MoveFast(U256[0],fAnsiToWide[0],512); - end; - SetLength(fWideToAnsi,65536); - for i := 1 to 126 do - fWideToAnsi[i] := i; - FillcharFast(fWideToAnsi[127],65536-127,ord('?')); // '?' for unknown char - for i := 127 to 255 do - if (fAnsiToWide[i]<>0) and (fAnsiToWide[i]<>ord('?')) then - fWideToAnsi[fAnsiToWide[i]] := i; - // fixed width Ansi will never be bigger than UTF-8 - fAnsiCharShift := 0; -end; - -function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar; Length: PtrInt): boolean; -var i: PtrInt; - wc: PtrUInt; -begin - result := false; - if WideText<>nil then - for i := 0 to Length-1 do begin - wc := PtrUInt(WideText[i]); - if wc=0 then - break else - if wc<256 then - if fAnsiToWide[wc]<256 then - continue else - exit else - if fWideToAnsi[wc]=ord('?') then - exit else - continue; - end; - result := true; -end; - -function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar): boolean; -var wc: PtrUInt; -begin - result := false; - if WideText<>nil then - repeat - wc := PtrUInt(WideText^); - inc(WideText); - if wc=0 then - break else - if wc<256 then - if fAnsiToWide[wc]<256 then - continue else - exit else - if fWideToAnsi[wc]=ord('?') then - exit else - continue; - until false; - result := true; -end; - -function TSynAnsiFixedWidth.IsValidAnsiU(UTF8Text: PUTF8Char): boolean; -var c: PtrUInt; - i, extra: PtrInt; -begin - result := false; - if UTF8Text<>nil then - repeat - c := byte(UTF8Text^); - inc(UTF8Text); - if c=0 then break else - if c<=127 then - continue else begin - extra := UTF8_EXTRABYTES[c]; - if UTF8_EXTRA[extra].minimum>$ffff then - exit; - for i := 1 to extra do begin - if byte(UTF8Text^) and $c0<>$80 then exit; // invalid UTF-8 content - c := c shl 6+byte(UTF8Text^); - inc(UTF8Text); - end; - dec(c,UTF8_EXTRA[extra].offset); - if (c>$ffff) or (fWideToAnsi[c]=ord('?')) then - exit; // invalid char in the WinAnsi code page - end; - until false; - result := true; -end; - -function TSynAnsiFixedWidth.IsValidAnsiU8Bit(UTF8Text: PUTF8Char): boolean; -var c: PtrUInt; - i, extra: PtrInt; -begin - result := false; - if UTF8Text<>nil then - repeat - c := byte(UTF8Text^); - inc(UTF8Text); - if c=0 then break else - if c<=127 then - continue else begin - extra := UTF8_EXTRABYTES[c]; - if UTF8_EXTRA[extra].minimum>$ffff then - exit; - for i := 1 to extra do begin - if byte(UTF8Text^) and $c0<>$80 then exit; // invalid UTF-8 content - c := c shl 6+byte(UTF8Text^); - inc(UTF8Text); - end; - dec(c,UTF8_EXTRA[extra].offset); - if (c>255) or (fAnsiToWide[c]>255) then - exit; // not 8 bit char (like "tm" or such) is marked invalid - end; - until false; - result := true; -end; - -function TSynAnsiFixedWidth.UnicodeBufferToAnsi(Dest: PAnsiChar; - Source: PWideChar; SourceChars: Cardinal): PAnsiChar; -var c: cardinal; - tab: PAnsiChar; -begin - // first handle trailing 7 bit ASCII chars, by pairs (Sha optimization) - if SourceChars>=2 then - repeat - c := PCardinal(Source)^; - if c and $ff80ff80<>0 then - break; // break on first non ASCII pair - dec(SourceChars,2); - inc(Source,2); - c := c shr 8 or c; - PWord(Dest)^ := c; - inc(Dest,2); - until SourceChars<2; - // use internal lookup tables for fast process of remaining chars - tab := pointer(fWideToAnsi); - for c := 1 to SourceChars shr 2 do begin - Dest[0] := tab[Ord(Source[0])]; - Dest[1] := tab[Ord(Source[1])]; - Dest[2] := tab[Ord(Source[2])]; - Dest[3] := tab[Ord(Source[3])]; - inc(Source,4); - inc(Dest,4); - end; - for c := 1 to SourceChars and 3 do begin - Dest^ := tab[Ord(Source^)]; - inc(Dest); - inc(Source); - end; - result := Dest; -end; - -function TSynAnsiFixedWidth.UTF8BufferToAnsi(Dest: PAnsiChar; - Source: PUTF8Char; SourceChars: Cardinal): PAnsiChar; -var c: cardinal; - endSource, endSourceBy4: PUTF8Char; - i,extra: integer; -label By1, By4, Quit; // ugly but faster -begin - // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) - endSource := Source+SourceChars; - endSourceBy4 := endSource-4; - if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then - repeat -By4: c := PCardinal(Source)^; - if c and $80808080<>0 then - goto By1; // break on first non ASCII quad - PCardinal(Dest)^ := c; - inc(Source,4); - inc(Dest,4); - until Source>endSourceBy4; - // generic loop, handling one UTF-8 code per iteration - if SourceendSource) then break; - for i := 1 to extra do begin - if byte(Source^) and $c0<>$80 then - goto Quit; // invalid UTF-8 content - c := c shl 6+byte(Source^); - inc(Source); - end; - dec(c,UTF8_EXTRA[extra].offset); - if c>$ffff then - Dest^ := '?' else // '?' as in unknown fWideToAnsi[] items - Dest^ := AnsiChar(fWideToAnsi[c]); - inc(Dest); - if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then goto By4; - if SourceCP_UTF8 then - raise ESynException.CreateUTF8('%.Create(%)',[self,aCodePage]); - inherited Create(aCodePage); -end; - -function TSynAnsiUTF8.UnicodeBufferToUTF8(Dest: PAnsiChar; DestChars: Cardinal; - Source: PWideChar; SourceChars: Cardinal): PAnsiChar; -begin - result := Dest+RawUnicodeToUTF8(PUTF8Char(Dest),DestChars,Source,SourceChars, - [ccfNoTrailingZero]); -end; - -function TSynAnsiUTF8.UnicodeBufferToAnsi(Dest: PAnsiChar; - Source: PWideChar; SourceChars: Cardinal): PAnsiChar; -begin - result := UnicodeBufferToUTF8(Dest,SourceChars,Source,SourceChars); -end; - -function TSynAnsiUTF8.UnicodeBufferToAnsi(Source: PWideChar; - SourceChars: Cardinal): RawByteString; -var tmp: TSynTempBuffer; -begin - if (Source=nil) or (SourceChars=0) then - result := '' else begin - tmp.Init(SourceChars*3); - FastSetStringCP(result,tmp.buf,UnicodeBufferToUTF8(tmp.buf, - SourceChars*3,Source,SourceChars)-PAnsiChar(tmp.buf),fCodePage); - tmp.Done; - end; -end; - -function TSynAnsiUTF8.UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; - SourceChars: Cardinal): PAnsiChar; -begin - MoveFast(Source^,Dest^,SourceChars); - result := Dest+SourceChars; -end; - -procedure TSynAnsiUTF8.UTF8BufferToAnsi(Source: PUTF8Char; SourceChars: Cardinal; - var result: RawByteString); -begin - FastSetString(RawUTF8(result),Source,SourceChars); -end; - -function TSynAnsiUTF8.UTF8ToAnsi(const UTF8: RawUTF8): RawByteString; -begin - result := UTF8; - {$ifdef HASCODEPAGE} - SetCodePage(result,CP_UTF8,false); - {$endif} -end; - -function TSynAnsiUTF8.AnsiToUTF8(const AnsiText: RawByteString): RawUTF8; -begin - result := AnsiText; - {$ifdef HASCODEPAGE} - SetCodePage(RawByteString(result),CP_UTF8,false); - {$endif} -end; - -function TSynAnsiUTF8.AnsiBufferToRawUTF8(Source: PAnsiChar; SourceChars: Cardinal): RawUTF8; -begin - FastSetString(Result,Source,SourceChars); -end; - - -{ TSynAnsiUTF16 } - -function TSynAnsiUTF16.AnsiBufferToUnicode(Dest: PWideChar; - Source: PAnsiChar; SourceChars: Cardinal; NoTrailingZero: boolean): PWideChar; -begin - MoveFast(Source^,Dest^,SourceChars); - result := Pointer(PtrUInt(Dest)+SourceChars); - if not NoTrailingZero then - result^ := #0; -end; - -const - NOTRAILING: array[boolean] of TCharConversionFlags = - ([],[ccfNoTrailingZero]); - -function TSynAnsiUTF16.AnsiBufferToUTF8(Dest: PUTF8Char; Source: PAnsiChar; - SourceChars: Cardinal; NoTrailingZero: boolean): PUTF8Char; -begin - SourceChars := SourceChars shr 1; // from byte count to WideChar count - result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3, - PWideChar(Source),SourceChars,NOTRAILING[NoTrailingZero]); -end; - -function TSynAnsiUTF16.AnsiToRawUnicode(Source: PAnsiChar; SourceChars: Cardinal): RawUnicode; -begin - SetString(result,Source,SourceChars); // byte count -end; - -constructor TSynAnsiUTF16.Create(aCodePage: cardinal); -begin - if aCodePage<>CP_UTF16 then - raise ESynException.CreateUTF8('%.Create(%)',[self,aCodePage]); - inherited Create(aCodePage); -end; - -function TSynAnsiUTF16.UnicodeBufferToAnsi(Dest: PAnsiChar; - Source: PWideChar; SourceChars: Cardinal): PAnsiChar; -begin - SourceChars := SourceChars shl 1; // from WideChar count to byte count - MoveFast(Source^,Dest^,SourceChars); - result := Dest+SourceChars; -end; - -function TSynAnsiUTF16.UTF8BufferToAnsi(Dest: PAnsiChar; Source: PUTF8Char; - SourceChars: Cardinal): PAnsiChar; -begin - result := Dest+UTF8ToWideChar(PWideChar(Dest),Source,SourceChars,true); -end; - - -function WideCharToUtf8(Dest: PUTF8Char; aWideChar: PtrUInt): integer; -begin - if aWideChar<=$7F then begin - Dest^ := AnsiChar(aWideChar); - result := 1; - end else - if aWideChar>$7ff then begin - Dest[0] := AnsiChar($E0 or (aWideChar shr 12)); - Dest[1] := AnsiChar($80 or ((aWideChar shr 6) and $3F)); - Dest[2] := AnsiChar($80 or (aWideChar and $3F)); - result := 3; - end else begin - Dest[0] := AnsiChar($C0 or (aWideChar shr 6)); - Dest[1] := AnsiChar($80 or (aWideChar and $3F)); - result := 2; - end; -end; - -function UTF16CharToUtf8(Dest: PUTF8Char; var Source: PWord): integer; -var c: cardinal; - j: integer; -begin - c := Source^; - inc(Source); - case c of - 0..$7f: begin - Dest^ := AnsiChar(c); - result := 1; - exit; - end; - UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX: begin - c := ((c-$D7C0)shl 10)+(Source^ xor UTF16_LOSURROGATE_MIN); - inc(Source); - end; - UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX: begin - c := ((cardinal(Source^)-$D7C0)shl 10)+(c xor UTF16_LOSURROGATE_MIN); - inc(Source); - end; - end; // now c is the UTF-32/UCS4 code point - case c of - 0..$7ff: result := 2; - $800..$ffff: result := 3; - $10000..$1FFFFF: result := 4; - $200000..$3FFFFFF: result := 5; - else result := 6; - end; - for j := result-1 downto 1 do begin - Dest[j] := AnsiChar((c and $3f)+$80); - c := c shr 6; - end; - Dest^ := AnsiChar(Byte(c) or UTF8_FIRSTBYTE[result]); -end; - -function UCS4ToUTF8(ucs4: cardinal; Dest: PUTF8Char): integer; -var j: integer; -begin - case ucs4 of - 0..$7f: begin - Dest^ := AnsiChar(ucs4); - result := 1; - exit; - end; - $80..$7ff: result := 2; - $800..$ffff: result := 3; - $10000..$1FFFFF: result := 4; - $200000..$3FFFFFF: result := 5; - else result := 6; - end; - for j := result-1 downto 1 do begin - Dest[j] := AnsiChar((ucs4 and $3f)+$80); - ucs4 := ucs4 shr 6; - end; - Dest^ := AnsiChar(Byte(ucs4) or UTF8_FIRSTBYTE[result]); -end; - -procedure AnyAnsiToUTF8(const s: RawByteString; var result: RawUTF8); -{$ifdef HASCODEPAGE}var CodePage: Cardinal;{$endif} -begin - if s='' then - result := '' else begin - {$ifdef HASCODEPAGE} - CodePage := StringCodePage(s); - if (CodePage=CP_UTF8) or (CodePage=CP_RAWBYTESTRING) then - result := s else - result := TSynAnsiConvert.Engine(CodePage). - {$else} - result := CurrentAnsiConvert. - {$endif} - AnsiBufferToRawUTF8(pointer(s),length(s)); - end; -end; - -function AnyAnsiToUTF8(const s: RawByteString): RawUTF8; -begin - AnyAnsiToUTF8(s,result); -end; - -function WinAnsiBufferToUtf8(Dest: PUTF8Char; Source: PAnsiChar; SourceChars: Cardinal): PUTF8Char; -begin - result := WinAnsiConvert.AnsiBufferToUTF8(Dest,Source,SourceChars); -end; - -function ShortStringToUTF8(const source: ShortString): RawUTF8; -begin - result := WinAnsiConvert.AnsiBufferToRawUTF8(@source[1],ord(source[0])); -end; - -procedure WinAnsiToUnicodeBuffer(const S: WinAnsiString; Dest: PWordArray; DestLen: PtrInt); -var L: PtrInt; -begin - L := length(S); - if L<>0 then begin - if L>=DestLen then - L := DestLen-1; // truncate to avoid buffer overflow - WinAnsiConvert.AnsiBufferToUnicode(PWideChar(Dest),pointer(S),L); // include last #0 - end else - Dest^[0] := 0; -end; - -function WinAnsiToRawUnicode(const S: WinAnsiString): RawUnicode; -begin - result := WinAnsiConvert.AnsiToRawUnicode(S); -end; - -function WinAnsiToUtf8(const S: WinAnsiString): RawUTF8; -begin - result := WinAnsiConvert.AnsiBufferToRawUTF8(pointer(S),length(s)); -end; - -function WinAnsiToUtf8(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): RawUTF8; -begin - result := WinAnsiConvert.AnsiBufferToRawUTF8(WinAnsi,WinAnsiLen); -end; - -function WideCharToWinAnsiChar(wc: cardinal): AnsiChar; -begin - wc := WinAnsiConvert.WideCharToAnsiChar(wc); - if integer(wc)=-1 then - result := '?' else - result := AnsiChar(wc); -end; - -function WideCharToWinAnsi(wc: cardinal): integer; -begin - result := WinAnsiConvert.WideCharToAnsiChar(wc); -end; - -function IsWinAnsi(WideText: PWideChar; Length: integer): boolean; -begin - result := WinAnsiConvert.IsValidAnsi(WideText,Length); -end; - -function IsAnsiCompatible(PC: PAnsiChar): boolean; -begin - result := false; - if PC<>nil then - while true do - if PC^=#0 then - break else - if PC^<=#127 then - inc(PC) else // 7 bits chars are always OK, whatever codepage/charset is used - exit; - result := true; -end; - -function IsAnsiCompatible(PC: PAnsiChar; Len: PtrUInt): boolean; -begin - if PC<>nil then begin - result := false; - Len := PtrUInt(@PC[Len-4]); - if Len>=PtrUInt(PC) then - repeat - if PCardinal(PC)^ and $80808080<>0 then - exit; - inc(PC,4); - until LenPtrUInt(PC) then - repeat - if PC^>=#127 then - exit; - inc(PC); - until Len<=PtrUInt(PC); - end; - result := true; -end; - -function IsAnsiCompatible(const Text: RawByteString): boolean; -begin - result := IsAnsiCompatible(PAnsiChar(pointer(Text)),length(Text)); -end; - -function IsAnsiCompatibleW(PW: PWideChar): boolean; -begin - result := false; - if PW<>nil then - while true do - if ord(PW^)=0 then - break else - if ord(PW^)<=127 then - inc(PW) else // 7 bits chars are always OK, whatever codepage/charset is used - exit; - result := true; -end; - -function IsAnsiCompatibleW(PW: PWideChar; Len: PtrInt): boolean; -var i: PtrInt; -begin - result := false; - if PW<>nil then - for i := 0 to Len-1 do - if ord(PW[i])>127 then - exit; - result := true; -end; - -function IsWinAnsi(WideText: PWideChar): boolean; -begin - result := WinAnsiConvert.IsValidAnsi(WideText); -end; - -function IsWinAnsiU(UTF8Text: PUTF8Char): boolean; -begin - result := WinAnsiConvert.IsValidAnsiU(UTF8Text); -end; - -function IsWinAnsiU8Bit(UTF8Text: PUTF8Char): boolean; -begin - result := WinAnsiConvert.IsValidAnsiU8Bit(UTF8Text); -end; - -function UTF8ToWinPChar(dest: PAnsiChar; source: PUTF8Char; count: integer): integer; -begin - result := WinAnsiConvert.UTF8BufferToAnsi(dest,source,count)-dest; -end; - -function ShortStringToAnsi7String(const source: shortstring): RawByteString; -begin - FastSetString(RawUTF8(result),@source[1],ord(source[0])); -end; - -procedure ShortStringToAnsi7String(const source: shortstring; var result: RawUTF8); -begin - FastSetString(result,@source[1],ord(source[0])); -end; - -procedure UTF8ToShortString(var dest: shortstring; source: PUTF8Char); -var c: cardinal; - len,extra,i: integer; -begin - len := 0; - if source<>nil then - repeat - c := byte(source^); inc(source); - if c=0 then break else - if c<=127 then begin - inc(len); dest[len] := AnsiChar(c); - if len<253 then continue else break; - end else begin - extra := UTF8_EXTRABYTES[c]; - if extra=0 then break; // invalid leading byte - for i := 1 to extra do begin - if byte(source^) and $c0<>$80 then begin - dest[0] := AnsiChar(len); - exit; // invalid UTF-8 content - end; - c := c shl 6+byte(source^); - inc(Source); - end; - dec(c,UTF8_EXTRA[extra].offset); - // #256.. -> slower but accurate conversion - inc(len); - if c>$ffff then - dest[len] := '?' else - dest[len] := AnsiChar(WinAnsiConvert.fWideToAnsi[c]); - if len<253 then continue else break; - end; - until false; - dest[0] := AnsiChar(len); -end; - -function Utf8ToWinAnsi(const S: RawUTF8): WinAnsiString; -begin - result := WinAnsiConvert.UTF8ToAnsi(S); -end; - -function Utf8ToWinAnsi(P: PUTF8Char): WinAnsiString; -begin - result := WinAnsiConvert.UTF8ToAnsi(P); -end; - -procedure Utf8ToRawUTF8(P: PUTF8Char; var result: RawUTF8); -begin // fast and Delphi 2009+ ready - FastSetString(result,P,StrLen(P)); -end; - -function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; - MaxDestChars, sourceBytes: PtrInt; NoTrailingZero: boolean): PtrInt; -// faster than System.Utf8ToUnicode() -var c: cardinal; - begd: PWideChar; - endSource: PUTF8Char; - endDest: PWideChar; - i,extra: integer; -label Quit, NoSource; -begin - result := 0; - if dest=nil then - exit; - if source=nil then - goto NoSource; - if sourceBytes=0 then begin - if source^=#0 then - goto NoSource; - sourceBytes := StrLen(source); - end; - endSource := source+sourceBytes; - endDest := dest+MaxDestChars; - begd := dest; - repeat - c := byte(source^); - inc(source); - if c<=127 then begin - PWord(dest)^ := c; // much faster than dest^ := WideChar(c) for FPC - inc(dest); - if (sourceendSource) then break; - for i := 1 to extra do begin - if byte(Source^) and $c0<>$80 then - goto Quit; // invalid input content - c := c shl 6+byte(Source^); - inc(Source); - end; - with UTF8_EXTRA[extra] do begin - dec(c,offset); - if c=endsource) or (dest>=endDest) then - break; - until false; -Quit: - result := PtrUInt(dest)-PtrUInt(begd); // dest-begd return byte length -NoSource: - if not NoTrailingZero then - dest^ := #0; // always append a WideChar(0) to the end of the buffer -end; - -function UTF8ToWideChar(dest: PWideChar; source: PUTF8Char; sourceBytes: PtrInt; - NoTrailingZero: boolean): PtrInt; -// faster than System.UTF8Decode() -var c: cardinal; - begd: PWideChar; - endSource, endSourceBy4: PUTF8Char; - i,extra: PtrInt; -label Quit, NoSource, By1, By4; -begin - result := 0; - if dest=nil then - exit; - if source=nil then - goto NoSource; - if sourceBytes=0 then begin - if source^=#0 then - goto NoSource; - sourceBytes := StrLen(source); - end; - begd := dest; - endSource := Source+SourceBytes; - endSourceBy4 := endSource-4; - if (PtrUInt(Source) and 3=0) and (Source<=EndSourceBy4) then - repeat // handle 7 bit ASCII chars, by quad (Sha optimization) -By4: c := PCardinal(Source)^; - if c and $80808080<>0 then - goto By1; // break on first non ASCII quad - inc(Source,4); - PCardinal(dest)^ := (c shl 8 or (c and $FF)) and $00ff00ff; - c := c shr 16; - PCardinal(dest+2)^ := (c shl 8 or c) and $00ff00ff; - inc(dest,4); - until Source>EndSourceBy4; - if SourceendSource) then break; - for i := 1 to extra do begin - if byte(Source^) and $c0<>$80 then - goto Quit; // invalid input content - c := c shl 6+byte(Source^); - inc(Source); - end; - with UTF8_EXTRA[extra] do begin - dec(c,offset); - if c=endSource then break; - until false; -Quit: - result := PtrUInt(dest)-PtrUInt(begd); // dest-begd returns bytes length -NoSource: - if not NoTrailingZero then - dest^ := #0; // always append a WideChar(0) to the end of the buffer -end; - -function IsValidUTF8WithoutControlChars(source: PUTF8Char): Boolean; -var extra, i: integer; - c: cardinal; -begin - result := false; - if source<>nil then - repeat - c := byte(source^); - inc(source); - if c=0 then break else - if c<32 then exit else // disallow #1..#31 control char - if c and $80<>0 then begin - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - for i := 1 to extra do - if byte(source^) and $c0<>$80 then // invalid UTF-8 encoding - exit else - inc(source); - end; - until false; - result := true; -end; - -function IsValidUTF8WithoutControlChars(const source: RawUTF8): Boolean; -var s, extra, i, len: integer; - c: cardinal; -begin - result := false; - s := 1; - len := length(source); - while s<=len do begin - c := byte(source[s]); - inc(s); - if c<32 then exit else // disallow #0..#31 control char - if c and $80<>0 then begin - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - for i := 1 to extra do - if byte(source[s]) and $c0<>$80 then // reached #0 or invalid UTF-8 - exit else - inc(s); - end; - end; - result := true; -end; - - -function Utf8ToUnicodeLength(source: PUTF8Char): PtrUInt; -var c: PtrUInt; - extra,i: integer; -begin - result := 0; - if source<>nil then - repeat - c := byte(source^); - inc(source); - if c=0 then break else - if c<=127 then - inc(result) else begin - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - if extra>=UTF8_EXTRA_SURROGATE then - inc(result,2) else - inc(result); - for i := 1 to extra do // inc(source,extra) is faster but not safe - if byte(source^) and $c0<>$80 then - exit else - inc(source); // check valid UTF-8 content - end; - until false; -end; - -function Utf8TruncateToUnicodeLength(var text: RawUTF8; maxUTF16: integer): boolean; -var c: PtrUInt; - extra,i: integer; - source: PUTF8Char; -begin - source := pointer(text); - if (source<>nil) and (cardinal(maxUtf16)=UTF8_EXTRA_SURROGATE then - dec(maxUTF16,2) else - dec(maxUTF16); - for i := 1 to extra do // inc(source,extra) is faster but not safe - if byte(source^) and $c0<>$80 then - break else - inc(source); // check valid UTF-8 content - end; - until false; - result := false; -end; - -function Utf8TruncateToLength(var text: RawUTF8; maxBytes: PtrUInt): boolean; -begin - if PtrUInt(length(text))0) and (ord(text[maxBytes]) and $c0=$80) do dec(maxBytes); - if (maxBytes>0) and (ord(text[maxBytes]) and $80<>0) then dec(maxBytes); - SetLength(text,maxBytes); - result := true; -end; - -function Utf8TruncatedLength(const text: RawUTF8; maxBytes: PtrUInt): PtrInt; -begin - result := length(text); - if PtrUInt(result)0) and (ord(text[result]) and $c0=$80) do dec(result); - if (result>0) and (ord(text[result]) and $80<>0) then dec(result); -end; - -function Utf8TruncatedLength(text: PAnsiChar; textlen,maxBytes: PtrUInt): PtrInt; -begin - if textlen0) and (ord(text[result]) and $c0=$80) do dec(result); - if (result>0) and (ord(text[result]) and $80<>0) then dec(result); -end; - -function Utf8FirstLineToUnicodeLength(source: PUTF8Char): PtrInt; -var c,extra: PtrUInt; -begin - result := 0; - if source<>nil then - repeat - c := byte(source^); - inc(source); - if c in [0,10,13] then break else // #0, #10 or #13 stop the count - if c<=127 then - inc(result) else begin - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - if extra>=UTF8_EXTRA_SURROGATE then - inc(result,2) else - inc(result); - inc(source,extra); // a bit less safe, but faster - end; - until false; -end; - -function Utf8DecodeToRawUnicode(P: PUTF8Char; L: integer): RawUnicode; -var tmp: TSynTempBuffer; -begin - result := ''; // somewhat faster if result is freed before any SetLength() - if L=0 then - L := StrLen(P); - if L=0 then - exit; - // +1 below is for #0 ending -> true WideChar(#0) ending - tmp.Init(L*3); // maximum posible unicode size (if all <#128) - SetString(result,PAnsiChar(tmp.buf),UTF8ToWideChar(tmp.buf,P,L)+1); - tmp.Done; -end; - -function Utf8DecodeToRawUnicode(const S: RawUTF8): RawUnicode; -begin - if S='' then - result := '' else - result := Utf8DecodeToRawUnicode(pointer(S),length(S)); -end; - -function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; DestLen: PInteger): RawUnicode; -var L: integer; -begin - L := Utf8DecodeToRawUnicodeUI(S,result); - if DestLen<>nil then - DestLen^ := L; -end; - -function Utf8DecodeToRawUnicodeUI(const S: RawUTF8; var Dest: RawUnicode): integer; -begin - Dest := ''; // somewhat faster if Dest is freed before any SetLength() - if S='' then begin - result := 0; - exit; - end; - result := length(S); - SetLength(Dest,result*2+2); - result := UTF8ToWideChar(pointer(Dest),Pointer(S),result); -end; - -function RawUnicodeToUtf8(Dest: PUTF8Char; DestLen: PtrInt; Source: PWideChar; - SourceLen: PtrInt; Flags: TCharConversionFlags): PtrInt; -var c: Cardinal; - Tail: PWideChar; - i,j: integer; -label unmatch; -begin - result := PtrInt(Dest); - inc(DestLen,PtrInt(Dest)); - if (Source<>nil) and (Dest<>nil) then begin - // first handle 7 bit ASCII WideChars, by pairs (Sha optimization) - SourceLen := SourceLen*2+PtrInt(PtrUInt(Source)); - Tail := PWideChar(SourceLen)-2; - if (PtrInt(PtrUInt(Dest))0 then - break; // break on first non ASCII pair - inc(Source,2); - c := c shr 8 or c; - PWord(Dest)^ := c; - inc(Dest,2); - until (Source>Tail) or (PtrInt(PtrUInt(Dest))>=DestLen); - // generic loop, handling one UCS4 char per iteration - if (PtrInt(PtrUInt(Dest))=SourceLen) or - ((cardinal(Source^)UTF16_LOSURROGATE_MAX)) then begin -unmatch: if (PtrInt(PtrUInt(@Dest[3]))>DestLen) or - not (ccfReplacementCharacterForUnmatchedSurrogate in Flags) then - break; - PWord(Dest)^ := $BFEF; - Dest[2] := AnsiChar($BD); - inc(Dest,3); - if (PtrInt(PtrUInt(Dest))=SourceLen) or - ((cardinal(Source^)UTF16_HISURROGATE_MAX)) then - goto unmatch else begin - c := ((cardinal(Source^)-$D7C0)shl 10)+(c xor UTF16_LOSURROGATE_MIN); - inc(Source); - end; - end; // now c is the UTF-32/UCS4 code point - case c of - 0..$7ff: i := 2; - $800..$ffff: i := 3; - $10000..$1FFFFF: i := 4; - $200000..$3FFFFFF: i := 5; - else i := 6; - end; - if PtrInt(PtrUInt(Dest))+i>DestLen then - break; - for j := i-1 downto 1 do begin - Dest[j] := AnsiChar((c and $3f)+$80); - c := c shr 6; - end; - Dest^ := AnsiChar(Byte(c) or UTF8_FIRSTBYTE[i]); - inc(Dest,i); - if (PtrInt(PtrUInt(Dest)) direct assign -end; -{$endif} - -function Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt): string; -begin - {$ifdef UNICODE} - Ansi7ToString(Text,Len,result); - {$else} - SetString(result,PAnsiChar(Text),Len); - {$endif} -end; - -procedure Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt; var result: string); -{$ifdef UNICODE} -var i: PtrInt; -begin - SetString(result,nil,Len); - for i := 0 to Len-1 do - PWordArray(result)[i] := PByteArray(Text)[i]; // no conversion for 7 bit Ansi -end; -{$else} -begin - SetString(result,PAnsiChar(Text),Len); -end; -{$endif} - -function StringToAnsi7(const Text: string): RawByteString; -{$ifdef UNICODE} -var i: PtrInt; -begin - SetString(result,nil,length(Text)); - for i := 0 to length(Text)-1 do - PByteArray(result)[i] := PWordArray(Text)[i]; // no conversion for 7 bit Ansi -end; -{$else} -begin - result := Text; // if we are SURE this text is 7 bit Ansi -> direct assign -end; -{$endif} - -function StringToWinAnsi(const Text: string): WinAnsiString; -begin - {$ifdef UNICODE} - result := RawUnicodeToWinAnsi(Pointer(Text),length(Text)); - {$else} - result := WinAnsiConvert.AnsiToAnsi(CurrentAnsiConvert,Text); - {$endif} -end; - -function StringBufferToUtf8(Dest: PUTF8Char; Source: PChar; SourceChars: PtrInt): PUTF8Char; -begin - {$ifdef UNICODE} - result := Dest+RawUnicodeToUtf8(Dest,SourceChars*3,PWideChar(Source),SourceChars,[]); - {$else} - result := CurrentAnsiConvert.AnsiBufferToUTF8(Dest,Source,SourceChars); - {$endif} -end; - -procedure StringBufferToUtf8(Source: PChar; out result: RawUTF8); overload; -begin - {$ifdef UNICODE} - RawUnicodeToUtf8(Source,StrLenW(Source),result); - {$else} - result := CurrentAnsiConvert.AnsiBufferToRawUTF8(Source,StrLen(Source)); - {$endif} -end; - -function StringToUTF8(const Text: string): RawUTF8; -begin - {$ifdef UNICODE} - RawUnicodeToUtf8(pointer(Text),length(Text),result); - {$else} - result := CurrentAnsiConvert.AnsiToUTF8(Text); - {$endif} -end; - -procedure StringToUTF8(Text: PChar; TextLen: PtrInt; var result: RawUTF8); -begin - {$ifdef UNICODE} - RawUnicodeToUtf8(Text,TextLen,result); - {$else} - result := CurrentAnsiConvert.AnsiBufferToRawUTF8(Text, TextLen); - {$endif} -end; - -procedure StringToUTF8(const Text: string; var result: RawUTF8); -begin - {$ifdef UNICODE} - RawUnicodeToUtf8(pointer(Text),length(Text),result); - {$else} - result := CurrentAnsiConvert.AnsiToUTF8(Text); - {$endif} -end; - -function ToUTF8(const Text: string): RawUTF8; -begin - {$ifdef UNICODE} - RawUnicodeToUtf8(pointer(Text),length(Text),result); - {$else} - result := CurrentAnsiConvert.AnsiToUTF8(Text); - {$endif} -end; - -function ToUTF8(const Ansi7Text: ShortString): RawUTF8; -begin - FastSetString(result,@Ansi7Text[1],ord(Ansi7Text[0])); -end; - -function ToUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; -begin - FastSetString(result,nil,36); - GUIDToText(pointer(result),@guid); -end; - - -{$ifdef HASVARUSTRING} // some UnicodeString dedicated functions -function UnicodeStringToUtf8(const S: UnicodeString): RawUTF8; -begin - RawUnicodeToUtf8(pointer(S),length(S),result); -end; - -function UTF8DecodeToUnicodeString(const S: RawUTF8): UnicodeString; -begin - UTF8DecodeToUnicodeString(pointer(S),length(S),result); -end; - -procedure UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer; var result: UnicodeString); -var tmp: TSynTempBuffer; -begin - if (P=nil) or (L=0) then - result := '' else begin - tmp.Init(L*3); // maximum posible unicode size (if all <#128) - SetString(result,PWideChar(tmp.buf),UTF8ToWideChar(tmp.buf,P,L) shr 1); - tmp.Done; - end; -end; - -function UnicodeStringToWinAnsi(const S: UnicodeString): WinAnsiString; -begin - result := WinAnsiConvert.UnicodeBufferToAnsi(pointer(S),length(S)); -end; - -function UTF8DecodeToUnicodeString(P: PUTF8Char; L: integer): UnicodeString; -begin - UTF8DecodeToUnicodeString(P,L,result); -end; - -function WinAnsiToUnicodeString(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): UnicodeString; -begin - SetString(result,nil,WinAnsiLen); - WinAnsiConvert.AnsiBufferToUnicode(pointer(result),WinAnsi,WinAnsiLen); -end; - -function WinAnsiToUnicodeString(const WinAnsi: WinAnsiString): UnicodeString; -begin - result := WinAnsiToUnicodeString(pointer(WinAnsi),length(WinAnsi)); -end; -{$endif HASVARUSTRING} - - -function StrInt32(P: PAnsiChar; val: PtrInt): PAnsiChar; -{$ifdef ABSOLUTEPASCALORNOTINTEL} -begin // fallback to pure pascal version for ARM or PIC - if val<0 then begin - result := StrUInt32(P,PtrUInt(-val))-1; - result^ := '-'; - end else - result := StrUInt32(P,val); -end; -{$else} -{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=P, rdx=val (Linux: rdi,rsi) - val is QWord on CPUX64 -{$endif FPC} - {$ifndef win64} - mov rcx, rdi - mov rdx, rsi - {$endif win64} - mov r10, rdx - sar r10, 63 // r10=0 if val>=0 or -1 if val<0 - xor rdx, r10 - sub rdx, r10 // rdx=abs(val) - cmp rdx, 10 - jb @3 // direct process of common val<10 - mov rax, rdx - lea r8, [rip + TwoDigitLookup] -@s: lea rcx, [rcx - 2] - cmp rax, 100 - jb @2 - lea r9, [rax * 2] - shr rax, 2 - mov rdx, 2951479051793528259 // use power of two reciprocal to avoid division - mul rdx - shr rdx, 2 - mov rax, rdx - imul rdx, -200 - lea rdx, [rdx + r8] - movzx rdx, word ptr[rdx + r9] - mov [rcx], dx - cmp rax, 10 - jae @s -@1: or al, '0' - mov byte ptr[rcx - 2], '-' - mov [rcx - 1], al - lea rax, [rcx + r10 - 1] // includes '-' if val<0 - ret -@2: movzx eax, word ptr[r8 + rax * 2] - mov byte ptr[rcx - 1], '-' - mov [rcx], ax - lea rax, [rcx + r10] // includes '-' if val<0 - ret -@3: or dl, '0' - mov byte ptr[rcx - 2], '-' - mov [rcx - 1], dl - lea rax, [rcx + r10 - 1] // includes '-' if val<0 -end; -{$else} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=P, edx=val - mov ecx, edx - sar ecx, 31 // 0 if val>=0 or -1 if val<0 - push ecx - xor edx, ecx - sub edx, ecx // edx=abs(val) - cmp edx, 10 - jb @3 // direct process of common val<10 - push edi - mov edi, eax - mov eax, edx -@s: sub edi, 2 - cmp eax, 100 - jb @2 - mov ecx, eax - mov edx, 1374389535 // use power of two reciprocal to avoid division - mul edx - shr edx, 5 // now edx=eax div 100 - mov eax, edx - imul edx, -200 - movzx edx, word ptr[TwoDigitLookup + ecx * 2 + edx] - mov [edi], dx - cmp eax, 10 - jae @s -@1: dec edi - or al, '0' - mov byte ptr[edi - 1], '-' - mov [edi], al - mov eax, edi - pop edi - pop ecx - add eax, ecx // includes '-' if val<0 - ret -@2: movzx eax, word ptr[TwoDigitLookup + eax * 2] - mov byte ptr[edi - 1], '-' - mov [edi], ax - mov eax, edi - pop edi - pop ecx - add eax, ecx // includes '-' if val<0 - ret -@3: dec eax - pop ecx - or dl, '0' - mov byte ptr[eax - 1], '-' - mov [eax], dl - add eax, ecx // includes '-' if val<0 -end; -{$endif CPUX64} -{$endif ABSOLUTEPASCALORNOTINTEL} - -function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar; -{$ifdef ABSOLUTEPASCALORNOTINTEL} // fallback to pure pascal version for ARM or PIC -var c100: PtrUInt; // val/c100 are QWord on 64-bit CPU - tab: PWordArray; -begin // this code is faster than Borland's original str() or IntToStr() - tab := @TwoDigitLookupW; - repeat - if val<10 then begin - dec(P); - P^ := AnsiChar(val+ord('0')); - break; - end else - if val<100 then begin - dec(P,2); - PWord(P)^ := tab[val]; - break; - end; - dec(P,2); - c100 := val div 100; - dec(val,c100*100); - PWord(P)^ := tab[val]; - val := c100; - if c100=0 then - break; - until false; - result := P; -end; -{$else} -{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=P, rdx=val (Linux: rdi,rsi) - val is QWord on CPUX64 -{$endif FPC} - {$ifndef win64} - mov rcx, rdi - mov rdx, rsi - {$endif win64} - cmp rdx, 10 - jb @3 // direct process of common val<10 - mov rax, rdx - lea r8, [rip + TwoDigitLookup] -@s: lea rcx, [rcx - 2] - cmp rax, 100 - jb @2 - lea r9, [rax * 2] - shr rax, 2 - mov rdx, 2951479051793528259 // use power of two reciprocal to avoid division - mul rdx - shr rdx, 2 - mov rax, rdx - imul rdx, -200 - add rdx, r8 - movzx rdx, word ptr[rdx + r9] - mov [rcx], dx - cmp rax, 10 - jae @s -@1: dec rcx - or al, '0' - mov [rcx], al -@0: mov rax, rcx - ret -@2: movzx eax, word ptr[r8 + rax * 2] - mov [rcx], ax - mov rax, rcx - ret -@3: lea rax, [rcx - 1] - or dl, '0' - mov [rax], dl -end; -{$else} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=P, edx=val - cmp edx, 10 - jb @3 // direct process of common val=0 (or val<10) - push edi - mov edi, eax - mov eax, edx - nop - nop // @s loop alignment -@s: sub edi, 2 - cmp eax, 100 - jb @2 - mov ecx, eax - mov edx, 1374389535 // use power of two reciprocal to avoid division - mul edx - shr edx, 5 // now edx=eax div 100 - mov eax, edx - imul edx, -200 - movzx edx, word ptr[TwoDigitLookup + ecx * 2 + edx] - mov [edi], dx - cmp eax, 10 - jae @s -@1: dec edi - or al, '0' - mov [edi], al - mov eax, edi - pop edi - ret -@2: movzx eax, word ptr[TwoDigitLookup + eax * 2] - mov [edi], ax - mov eax, edi - pop edi - ret -@3: dec eax - or dl, '0' - mov [eax], dl -end; -{$endif CPU64} -{$endif ABSOLUTEPASCALORNOTINTEL} - -function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar; -{$ifdef CPU64} -begin - result := StrUInt32(P,val); // StrUInt32 converts PtrUInt=QWord on 64-bit CPU -end; -{$else} -var c,c100: QWord; - tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; -begin - if PInt64Rec(@val)^.Hi=0 then - P := StrUInt32(P,PCardinal(@val)^) else begin - {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} - c := val; - repeat - {$ifdef PUREPASCAL} - c100 := c div 100; // one div by two digits - dec(c,c100*100); // fast c := c mod 100 - {$else} - asm // by-passing the RTL is a good idea here - push ebx - mov edx, dword ptr[c + 4] - mov eax, dword ptr[c] - mov ebx, 100 - mov ecx, eax - mov eax, edx - xor edx, edx - div ebx - mov dword ptr[c100 + 4], eax - xchg eax, ecx - div ebx - mov dword ptr[c100], eax - imul ebx, ecx - mov ecx, 100 - mul ecx - add edx, ebx - pop ebx - sub dword ptr[c + 4], edx - sbb dword ptr[c], eax - end; - {$endif} - dec(P,2); - PWord(P)^ := tab[c]; - c := c100; - if PInt64Rec(@c)^.Hi=0 then begin - if PCardinal(@c)^<>0 then - P := StrUInt32(P,PCardinal(@c)^); - break; - end; - until false; - end; - result := P; -end; -{$endif} - -function StrInt64(P: PAnsiChar; const val: Int64): PAnsiChar; -begin - {$ifdef CPU64} - result := StrInt32(P,val); // StrInt32 converts PtrInt=Int64 on 64-bit CPU - {$else} - if val<0 then begin - P := StrUInt64(P,-val)-1; - P^ := '-'; - end else - P := StrUInt64(P,val); - result := P; - {$endif CPU64} -end; - -procedure Int32ToUTF8(Value: PtrInt; var result: RawUTF8); -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - if PtrUInt(Value)<=high(SmallUInt32UTF8) then - result := SmallUInt32UTF8[Value] else begin - P := StrInt32(@tmp[23],Value); - FastSetString(result,P,@tmp[23]-P); - end; -end; - -procedure Int64ToUtf8(Value: Int64; var result: RawUTF8); -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - {$ifdef CPU64} - if PtrUInt(Value)<=high(SmallUInt32UTF8) then - {$else} // Int64Rec gives compiler internal error C4963 - if (PCardinalArray(@Value)^[0]<=high(SmallUInt32UTF8)) and - (PCardinalArray(@Value)^[1]=0) then - {$endif CPU64} - result := SmallUInt32UTF8[Value] else begin - P := {$ifdef CPU64}StrInt32{$else}StrInt64{$endif}(@tmp[23],Value); - FastSetString(result,P,@tmp[23]-P); - end; -end; - -procedure UInt64ToUtf8(Value: QWord; var result: RawUTF8); -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - {$ifdef CPU64} - if Value<=high(SmallUInt32UTF8) then - {$else} // Int64Rec gives compiler internal error C4963 - if (PCardinalArray(@Value)^[0]<=high(SmallUInt32UTF8)) and - (PCardinalArray(@Value)^[1]=0) then - {$endif CPU64} - result := SmallUInt32UTF8[Value] else begin - P := {$ifdef CPU64}StrUInt32{$else}StrUInt64{$endif}(@tmp[23],Value); - FastSetString(result,P,@tmp[23]-P); - end; -end; - -function ClassNameShort(C: TClass): PShortString; -// new TObject.ClassName is UnicodeString (since Delphi 2009) -> inline code -// with vmtClassName = UTF-8 encoded text stored in a shortstring = -44 -begin - result := PPointer(PtrInt(PtrUInt(C))+vmtClassName)^; -end; - -function ClassNameShort(Instance: TObject): PShortString; -begin - result := PPointer(PPtrInt(Instance)^+vmtClassName)^; -end; - -function ToText(C: TClass): RawUTF8; -var P: PShortString; -begin - if C=nil then - result := '' else begin - P := PPointer(PtrInt(PtrUInt(C))+vmtClassName)^; - FastSetString(result,@P^[1],ord(P^[0])); - end; -end; - -procedure ToText(C: TClass; var result: RawUTF8); -var P: PShortString; -begin - if C=nil then - result := '' else begin - P := PPointer(PtrInt(PtrUInt(C))+vmtClassName)^; - FastSetString(result,@P^[1],ord(P^[0])); - end; -end; - -function GetClassParent(C: TClass): TClass; -begin - result := PPointer(PtrInt(PtrUInt(C))+vmtParent)^; - {$ifndef HASDIRECTTYPEINFO} // e.g. for Delphi and newer FPC - if result<>nil then - result := PPointer(result)^; - {$endif HASDIRECTTYPEINFO} -end; - -function VarRecAsChar(const V: TVarRec): integer; -begin - case V.VType of - vtChar: result := ord(V.VChar); - vtWideChar: result := ord(V.VWideChar); - else result := 0; - end; -end; - -function VarRecToInt64(const V: TVarRec; out value: Int64): boolean; -begin - case V.VType of - vtInteger: value := V.VInteger; - vtInt64 {$ifdef FPC}, vtQWord{$endif}: value := V.VInt64^; - vtBoolean: if V.VBoolean then value := 1 else value := 0; // normalize - {$ifndef NOVARIANTS} - vtVariant: value := V.VVariant^; - {$endif} - else begin - result := false; - exit; - end; - end; - result := true; -end; - -function VarRecToDouble(const V: TVarRec; out value: double): boolean; -begin - case V.VType of - vtInteger: value := V.VInteger; - vtInt64: value := V.VInt64^; - {$ifdef FPC} - vtQWord: value := V.VQWord^; - {$endif} - vtBoolean: if V.VBoolean then value := 1 else value := 0; // normalize - vtExtended: value := V.VExtended^; - vtCurrency: value := V.VCurrency^; - {$ifndef NOVARIANTS} - vtVariant: value := V.VVariant^; - {$endif} - else begin - result := false; - exit; - end; - end; - result := true; -end; - -function VarRecToTempUTF8(const V: TVarRec; var Res: TTempUTF8): integer; -{$ifndef NOVARIANTS} -var v64: Int64; - isString: boolean; -{$endif} -label smlu32; -begin - Res.TempRawUTF8 := nil; // avoid GPF - case V.VType of - vtString: begin - Res.Text := @V.VString^[1]; - Res.Len := ord(V.VString^[0]); - result := Res.Len; - exit; - end; - vtAnsiString: begin // expect UTF-8 content - Res.Text := pointer(V.VAnsiString); - Res.Len := length(RawUTF8(V.VAnsiString)); - result := Res.Len; - exit; - end; - {$ifdef HASVARUSTRING} - vtUnicodeString: - RawUnicodeToUtf8(V.VPWideChar,length(UnicodeString(V.VUnicodeString)),RawUTF8(Res.TempRawUTF8)); - {$endif} - vtWideString: - RawUnicodeToUtf8(V.VPWideChar,length(WideString(V.VWideString)),RawUTF8(Res.TempRawUTF8)); - vtPChar: begin // expect UTF-8 content - Res.Text := V.VPointer; - Res.Len := StrLen(V.VPointer); - result := Res.Len; - exit; - end; - vtChar: begin - Res.Temp[0] := V.VChar; // V may be on transient stack (alf: FPC) - Res.Text := @Res.Temp; - Res.Len := 1; - result := 1; - exit; - end; - vtPWideChar: - RawUnicodeToUtf8(V.VPWideChar,StrLenW(V.VPWideChar),RawUTF8(Res.TempRawUTF8)); - vtWideChar: - RawUnicodeToUtf8(@V.VWideChar,1,RawUTF8(Res.TempRawUTF8)); - vtBoolean: begin - if V.VBoolean then // normalize - Res.Text := pointer(SmallUInt32UTF8[1]) else - Res.Text := pointer(SmallUInt32UTF8[0]); - Res.Len := 1; - result := 1; - exit; - end; - vtInteger: begin - result := V.VInteger; - if cardinal(result)<=high(SmallUInt32UTF8) then begin -smlu32: Res.Text := pointer(SmallUInt32UTF8[result]); - Res.Len := PStrLen(Res.Text-_STRLEN)^; - end else begin - Res.Text := PUTF8Char(StrInt32(@Res.Temp[23],result)); - Res.Len := @Res.Temp[23]-Res.Text; - end; - result := Res.Len; - exit; - end; - vtInt64: - if (PCardinalArray(V.VInt64)^[0]<=high(SmallUInt32UTF8)) and - (PCardinalArray(V.VInt64)^[1]=0) then begin - result := V.VInt64^; - goto smlu32; - end else begin - Res.Text := PUTF8Char(StrInt64(@Res.Temp[23],V.VInt64^)); - Res.Len := @Res.Temp[23]-Res.Text; - result := Res.Len; - exit; - end; - {$ifdef FPC} - vtQWord: - if V.VQWord^<=high(SmallUInt32UTF8) then begin - result := V.VQWord^; - goto smlu32; - end else begin - Res.Text := PUTF8Char(StrUInt64(@Res.Temp[23],V.VQWord^)); - Res.Len := @Res.Temp[23]-Res.Text; - result := Res.Len; - exit; - end; - {$endif} - vtCurrency: begin - Res.Text := @Res.Temp; - Res.Len := Curr64ToPChar(V.VInt64^,Res.Temp); - result := Res.Len; - exit; - end; - vtExtended: - DoubleToStr(V.VExtended^,RawUTF8(Res.TempRawUTF8)); - vtPointer,vtInterface: begin - Res.Text := @Res.Temp; - Res.Len := SizeOf(pointer)*2; - BinToHexDisplayLower(@V.VPointer,@Res.Temp,SizeOf(Pointer)); - result := SizeOf(pointer)*2; - exit; - end; - vtClass: begin - if V.VClass<>nil then begin - Res.Text := PPUTF8Char(PtrInt(PtrUInt(V.VClass))+vmtClassName)^+1; - Res.Len := ord(Res.Text[-1]); - end else - Res.Len := 0; - result := Res.Len; - exit; - end; - vtObject: begin - if V.VObject<>nil then begin - Res.Text := PPUTF8Char(PPtrInt(V.VObject)^+vmtClassName)^+1; - Res.Len := ord(Res.Text[-1]); - end else - Res.Len := 0; - result := Res.Len; - exit; - end; - {$ifndef NOVARIANTS} - vtVariant: - if VariantToInt64(V.VVariant^,v64) then - if (PCardinalArray(@v64)^[0]<=high(SmallUInt32UTF8)) and - (PCardinalArray(@v64)^[1]=0) then begin - result := v64; - goto smlu32; - end else begin - Res.Text := PUTF8Char(StrInt64(@Res.Temp[23],v64)); - Res.Len := @Res.Temp[23]-Res.Text; - result := Res.Len; - exit; - end else - VariantToUTF8(V.VVariant^,RawUTF8(Res.TempRawUTF8),isString); - {$endif} - else begin - Res.Len := 0; - result := 0; - exit; - end; - end; - Res.Text := Res.TempRawUTF8; - Res.Len := length(RawUTF8(Res.TempRawUTF8)); - result := Res.Len; -end; - -procedure VarRecToUTF8(const V: TVarRec; var result: RawUTF8; wasString: PBoolean); -var isString: boolean; -begin - isString := not (V.VType in [ - vtBoolean,vtInteger,vtInt64{$ifdef FPC},vtQWord{$endif},vtCurrency,vtExtended]); - with V do - case V.VType of - vtString: - FastSetString(result,@VString^[1],ord(VString^[0])); - vtAnsiString: - result := RawUTF8(VAnsiString); // expect UTF-8 content - {$ifdef HASVARUSTRING} - vtUnicodeString: - RawUnicodeToUtf8(VUnicodeString,length(UnicodeString(VUnicodeString)),result); - {$endif} - vtWideString: - RawUnicodeToUtf8(VWideString,length(WideString(VWideString)),result); - vtPChar: - FastSetString(result,VPChar,StrLen(VPChar)); - vtChar: - FastSetString(result,PAnsiChar(@VChar),1); - vtPWideChar: - RawUnicodeToUtf8(VPWideChar,StrLenW(VPWideChar),result); - vtWideChar: - RawUnicodeToUtf8(@VWideChar,1,result); - vtBoolean: - if VBoolean then // normalize - result := SmallUInt32UTF8[1] else - result := SmallUInt32UTF8[0]; - vtInteger: - Int32ToUtf8(VInteger,result); - vtInt64: - Int64ToUtf8(VInt64^,result); - {$ifdef FPC} - vtQWord: - UInt64ToUtf8(VQWord^,result); - {$endif} - vtCurrency: - Curr64ToStr(VInt64^,result); - vtExtended: - DoubleToStr(VExtended^,result); - vtPointer: - PointerToHex(VPointer,result); - vtClass: - if VClass<>nil then - ToText(VClass,result) else - result := ''; - vtObject: - if VObject<>nil then - ToText(PClass(VObject)^,result) else - result := ''; - vtInterface: - {$ifdef HASINTERFACEASTOBJECT} - if VInterface<>nil then - ToText((IInterface(VInterface) as TObject).ClassType,result) else - result := ''; - {$else} - PointerToHex(VInterface,result); - {$endif} - {$ifndef NOVARIANTS} - vtVariant: - VariantToUTF8(VVariant^,result,isString); - {$endif} - else begin - isString := false; - result := ''; - end; - end; - if wasString<>nil then - wasString^ := isString; -end; - -function VarRecToUTF8IsString(const V: TVarRec; var value: RawUTF8): boolean; -begin - VarRecToUTF8(V,value,@result); -end; - -procedure VarRecToInlineValue(const V: TVarRec; var result: RawUTF8); -var wasString: boolean; - tmp: RawUTF8; -begin - VarRecToUTF8(V,tmp,@wasString); - if wasString then - QuotedStr(tmp,'"',result) else - result := tmp; -end; - -{$ifdef UNICODE} -function StringToRawUnicode(const S: string): RawUnicode; -begin - SetString(result,PAnsiChar(pointer(S)),length(S)*2+1); // +1 for last wide #0 -end; -function StringToSynUnicode(const S: string): SynUnicode; -begin - result := S; -end; -procedure StringToSynUnicode(const S: string; var result: SynUnicode); overload; -begin - result := S; -end; -function StringToRawUnicode(P: PChar; L: integer): RawUnicode; -begin - SetString(result,PAnsiChar(P),L*2+1); // +1 for last wide #0 -end; -function RawUnicodeToString(P: PWideChar; L: integer): string; -begin - SetString(result,P,L); -end; -procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); -begin - SetString(result,P,L); -end; -function RawUnicodeToString(const U: RawUnicode): string; -begin // uses StrLenW() and not length(U) to handle case when was used as buffer - SetString(result,PWideChar(pointer(U)),StrLenW(Pointer(U))); -end; -function SynUnicodeToString(const U: SynUnicode): string; -begin - result := U; -end; -function UTF8DecodeToString(P: PUTF8Char; L: integer): string; -begin - UTF8DecodeToUnicodeString(P,L,result); -end; -procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string); -begin - UTF8DecodeToUnicodeString(P,L,result); -end; -function UTF8ToString(const Text: RawUTF8): string; -begin - UTF8DecodeToUnicodeString(pointer(Text),length(Text),result); -end; -{$else} -function StringToRawUnicode(const S: string): RawUnicode; -begin - result := CurrentAnsiConvert.AnsiToRawUnicode(S); -end; -function StringToSynUnicode(const S: string): SynUnicode; -begin - result := CurrentAnsiConvert.AnsiToUnicodeString(pointer(S),length(S)); -end; -procedure StringToSynUnicode(const S: string; var result: SynUnicode); overload; -begin - result := CurrentAnsiConvert.AnsiToUnicodeString(pointer(S),length(S)); -end; -function StringToRawUnicode(P: PChar; L: integer): RawUnicode; -begin - result := CurrentAnsiConvert.AnsiToRawUnicode(P,L); -end; -function RawUnicodeToString(P: PWideChar; L: integer): string; -begin - result := CurrentAnsiConvert.UnicodeBufferToAnsi(P,L); -end; -procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); -begin - result := CurrentAnsiConvert.UnicodeBufferToAnsi(P,L); -end; -function RawUnicodeToString(const U: RawUnicode): string; -begin // uses StrLenW() and not length(U) to handle case when was used as buffer - result := CurrentAnsiConvert.UnicodeBufferToAnsi(Pointer(U),StrLenW(Pointer(U))); -end; -function SynUnicodeToString(const U: SynUnicode): string; -begin - result := CurrentAnsiConvert.UnicodeBufferToAnsi(Pointer(U),length(U)); -end; -function UTF8DecodeToString(P: PUTF8Char; L: integer): string; -begin - CurrentAnsiConvert.UTF8BufferToAnsi(P,L,RawByteString(result)); -end; -procedure UTF8DecodeToString(P: PUTF8Char; L: integer; var result: string); -begin - CurrentAnsiConvert.UTF8BufferToAnsi(P,L,RawByteString(result)); -end; -function UTF8ToString(const Text: RawUTF8): string; -begin - CurrentAnsiConvert.UTF8BufferToAnsi(pointer(Text),length(Text),RawByteString(result)); -end; -{$endif UNICODE} - -procedure UTF8ToWideString(const Text: RawUTF8; var result: WideString); -begin - UTF8ToWideString(pointer(Text),Length(Text),result); -end; - -function UTF8ToWideString(const Text: RawUTF8): WideString; -begin - {$ifdef FPC} - Finalize(result); - {$endif FPC} - UTF8ToWideString(pointer(Text),Length(Text),result); -end; - -procedure UTF8ToWideString(Text: PUTF8Char; Len: PtrInt; var result: WideString); -var tmp: TSynTempBuffer; -begin - if (Text=nil) or (Len=0) then - result := '' else begin - tmp.Init(Len*3); // maximum posible unicode size (if all <#128) - SetString(result,PWideChar(tmp.buf),UTF8ToWideChar(tmp.buf,Text,Len) shr 1); - tmp.Done; - end; -end; - -function WideStringToUTF8(const aText: WideString): RawUTF8; -begin - RawUnicodeToUtf8(pointer(aText),length(aText),result); -end; - -function UTF8ToSynUnicode(const Text: RawUTF8): SynUnicode; -begin - UTF8ToSynUnicode(pointer(Text),length(Text),result); -end; - -procedure UTF8ToSynUnicode(const Text: RawUTF8; var result: SynUnicode); -begin - UTF8ToSynUnicode(pointer(Text),length(Text),result); -end; - -procedure UTF8ToSynUnicode(Text: PUTF8Char; Len: PtrInt; var result: SynUnicode); -var tmp: TSynTempBuffer; -begin - if (Text=nil) or (Len=0) then - result := '' else begin - tmp.Init(Len*3); // maximum posible unicode size (if all <#128) - SetString(result,PWideChar(tmp.buf),UTF8ToWideChar(tmp.buf,Text,Len) shr 1); - tmp.Done; - end; -end; - - - -{ TRawUTF8InterningSlot } - -procedure TRawUTF8InterningSlot.Init; -begin - Safe.Init; - {$ifndef NOVARIANTS} - Safe.LockedInt64[0] := 0; - {$endif} - Values.Init(TypeInfo(TRawUTF8DynArray),Value,HashAnsiString, - SortDynArrayAnsiString,InterningHasher,@Safe.Padding[0].VInteger,false); -end; - -procedure TRawUTF8InterningSlot.Done; -begin - Safe.Done; -end; - -function TRawUTF8InterningSlot.Count: integer; -begin - {$ifdef NOVARIANTS} - result := Safe.Padding[0].VInteger; - {$else} - result := Safe.LockedInt64[0]; - {$endif} -end; - -procedure TRawUTF8InterningSlot.Unique(var aResult: RawUTF8; - const aText: RawUTF8; aTextHash: cardinal); -var i: PtrInt; - added: boolean; -begin - EnterCriticalSection(Safe.fSection); - try - i := Values.FindHashedForAdding(aText,added,aTextHash); - if added then begin - Value[i] := aText; // copy new value to the pool - aResult := aText; - end else - aResult := Value[i]; // return unified string instance - finally - LeaveCriticalSection(Safe.fSection); - end; -end; - -procedure TRawUTF8InterningSlot.UniqueText(var aText: RawUTF8; aTextHash: cardinal); -var i: PtrInt; - added: boolean; -begin - EnterCriticalSection(Safe.fSection); - try - i := Values.FindHashedForAdding(aText,added,aTextHash); - if added then - Value[i] := aText else // copy new value to the pool - aText := Value[i]; // return unified string instance - finally - LeaveCriticalSection(Safe.fSection); - end; -end; - -procedure TRawUTF8InterningSlot.Clear; -begin - EnterCriticalSection(Safe.fSection); - try - Values.SetCount(0); // Values.Clear - Values.Hasher.Clear; - finally - LeaveCriticalSection(Safe.fSection); - end; -end; - -function TRawUTF8InterningSlot.Clean(aMaxRefCount: integer): integer; -var i: integer; - s,d: PPtrUInt; // points to RawUTF8 values (bypass COW assignments) -begin - result := 0; - EnterCriticalSection(Safe.fSection); - try - if Safe.Padding[0].VInteger=0 then - exit; - s := pointer(Value); - d := s; - for i := 1 to Safe.Padding[0].VInteger do begin - if PStrCnt(PAnsiChar(s^)-_STRREFCNT)^<=aMaxRefCount then begin - {$ifdef FPC} - Finalize(PRawUTF8(s)^); - {$else} - PRawUTF8(s)^ := ''; - {$endif FPC} - inc(result); - end else begin - if s<>d then begin - d^ := s^; - s^ := 0; // avoid GPF - end; - inc(d); - end; - inc(s); - end; - if result>0 then begin - Values.SetCount((PtrUInt(d)-PtrUInt(Value))div SizeOf(d^)); - Values.ReHash; - end; - finally - LeaveCriticalSection(Safe.fSection); - end; -end; - - -{ TRawUTF8Interning } - -constructor TRawUTF8Interning.Create(aHashTables: integer); -var p: integer; - i: PtrInt; -begin - for p := 0 to 9 do - if aHashTables=1 shl p then begin - SetLength(fPool,aHashTables); - fPoolLast := aHashTables-1; - for i := 0 to fPoolLast do - fPool[i].Init; - exit; - end; - raise ESynException.CreateUTF8('%.Create(%) not allowed: should be a power of 2', - [self,aHashTables]); -end; - -destructor TRawUTF8Interning.Destroy; -var i: PtrInt; -begin - for i := 0 to fPoolLast do - fPool[i].Done; - inherited Destroy; -end; - -procedure TRawUTF8Interning.Clear; -var i: PtrInt; -begin - if self<>nil then - for i := 0 to fPoolLast do - fPool[i].Clear; -end; - -function TRawUTF8Interning.Clean(aMaxRefCount: integer): integer; -var i: PtrInt; -begin - result := 0; - if self<>nil then - for i := 0 to fPoolLast do - inc(result,fPool[i].Clean(aMaxRefCount)); -end; - -function TRawUTF8Interning.Count: integer; -var i: PtrInt; -begin - result := 0; - if self<>nil then - for i := 0 to fPoolLast do - inc(result,fPool[i].Count); -end; - -procedure TRawUTF8Interning.Unique(var aResult: RawUTF8; const aText: RawUTF8); -var hash: cardinal; -begin - if aText='' then - aResult := '' else - if self=nil then - aResult := aText else begin - hash := InterningHasher(0,pointer(aText),length(aText)); // = fPool[].Values.HashElement - fPool[hash and fPoolLast].Unique(aResult,aText,hash); - end; -end; - -procedure TRawUTF8Interning.UniqueText(var aText: RawUTF8); -var hash: cardinal; -begin - if (self<>nil) and (aText<>'') then begin - hash := InterningHasher(0,pointer(aText),length(aText)); // = fPool[].Values.HashElement - fPool[hash and fPoolLast].UniqueText(aText,hash); - end; -end; - -function TRawUTF8Interning.Unique(const aText: RawUTF8): RawUTF8; -var hash: cardinal; -begin - if aText='' then - result := '' else - if self=nil then - result := aText else begin - hash := InterningHasher(0,pointer(aText),length(aText)); // = fPool[].Values.HashElement - fPool[hash and fPoolLast].Unique(result,aText,hash); - end; -end; - -function TRawUTF8Interning.Unique(aText: PUTF8Char; aTextLen: PtrInt): RawUTF8; -begin - FastSetString(result,aText,aTextLen); - UniqueText(result); -end; - -procedure TRawUTF8Interning.Unique(var aResult: RawUTF8; aText: PUTF8Char; - aTextLen: PtrInt); -begin - FastSetString(aResult,aText,aTextLen); - UniqueText(aResult); -end; - -procedure ClearVariantForString(var Value: variant); {$ifdef HASINLINE} inline; {$endif} -var v: TVarData absolute Value; -begin - if cardinal(v.VType) = varString then - Finalize(RawByteString(v.VString)) - else - begin - VarClear(Value); - PInteger(@v.VType)^ := varString; - v.VString := nil; // to avoid GPF when assign a RawByteString - end; -end; - -{$ifndef NOVARIANTS} - -procedure TRawUTF8Interning.UniqueVariant(var aResult: variant; const aText: RawUTF8); -begin - ClearVariantForString(aResult); - Unique(RawUTF8(TVarData(aResult).VAny),aText); -end; - -procedure TRawUTF8Interning.UniqueVariantString(var aResult: variant; const aText: string); -var tmp: RawUTF8; -begin - StringToUTF8(aText,tmp); - UniqueVariant(aResult,tmp); -end; - -procedure TRawUTF8Interning.UniqueVariant(var aResult: variant; - aText: PUTF8Char; aTextLen: PtrInt; aAllowVarDouble: boolean); -var tmp: RawUTF8; -begin - if not GetNumericVariantFromJSON(aText,TVarData(aResult),aAllowVarDouble) then begin - FastSetString(tmp,aText,aTextLen); - UniqueVariant(aResult,tmp); - end; -end; - -procedure TRawUTF8Interning.UniqueVariant(var aResult: variant); -var vt: cardinal; -begin - vt := TVarData(aResult).VType; - with TVarData(aResult) do - if vt=varString then - UniqueText(RawUTF8(VString)) else - if vt=varVariant or varByRef then - UniqueVariant(PVariant(VPointer)^) else - if vt=varString or varByRef then - UniqueText(PRawUTF8(VPointer)^); -end; - -{$endif NOVARIANTS} - -const - // see https://en.wikipedia.org/wiki/Baudot_code - Baudot2Char: array[0..63] of AnsiChar = - #0'e'#10'a siu'#13'drjnfcktzlwhypqobg'#254'mxv'#255+ - #0'3'#10'- ''87'#13#0'4'#0',!:(5+)2$6019?@'#254'./;'#255; -var - Char2Baudot: array[AnsiChar] of byte; - -function AsciiToBaudot(const Text: RawUTF8): RawByteString; -begin - result := AsciiToBaudot(pointer(Text),length(Text)); -end; - -function AsciiToBaudot(P: PAnsiChar; len: PtrInt): RawByteString; -var i: PtrInt; - c,d,bits: integer; - shift: boolean; - dest: PByte; - tmp: TSynTempBuffer; -begin - result := ''; - if (P=nil) or (len=0) then - exit; - shift := false; - dest := tmp.Init((len*10)shr 3); - d := 0; - bits := 0; - for i := 0 to len-1 do begin - c := Char2Baudot[P[i]]; - if c>32 then begin - if not shift then begin - d := (d shl 5) or 27; - inc(bits,5); - shift := true; - end; - d := (d shl 5) or (c-32); - inc(bits,5); - end else - if c>0 then begin - if shift and (P[i]>=' ') then begin - d := (d shl 5) or 31; - inc(bits,5); - shift := false; - end; - d := (d shl 5) or c; - inc(bits,5); - end; - while bits>=8 do begin - dec(bits,8); - dest^ := d shr bits; - inc(dest); - end; - end; - if bits>0 then begin - dest^ := d shl (8-bits); - inc(dest); - end; - SetString(result,PAnsiChar(tmp.buf),PAnsiChar(dest)-PAnsiChar(tmp.buf)); - tmp.Done; -end; - -function BaudotToAscii(const Baudot: RawByteString): RawUTF8; -begin - result := BaudotToAscii(pointer(Baudot),length(Baudot)); -end; - -function BaudotToAscii(Baudot: PByteArray; len: PtrInt): RawUTF8; -var i: PtrInt; - c,b,bits,shift: integer; - tmp: TSynTempBuffer; - dest: PAnsiChar; -begin - result := ''; - if (Baudot=nil) or (len<=0) then - exit; - dest := tmp.Init((len shl 3)div 5); - try - shift := 0; - b := 0; - bits := 0; - for i := 0 to len-1 do begin - b := (b shl 8) or Baudot[i]; - inc(bits,8); - while bits>=5 do begin - dec(bits,5); - c := (b shr bits) and 31; - case c of - 27: if shift<>0 then - exit else - shift := 32; - 31: if shift<>0 then - shift := 0 else - exit; - else begin - c := ord(Baudot2Char[c+shift]); - if c=0 then - if Baudot[i+1]=0 then // allow triming of last 5 bits - break else - exit; - dest^ := AnsiChar(c); - inc(dest); - end; - end; - end; - end; - finally - tmp.Done(dest,result); - end; -end; - -function IsVoid(const text: RawUTF8): boolean; -var i: PtrInt; -begin - result := false; - for i := 1 to length(text) do - if text[i]>' ' then - exit; - result := true; -end; - -function TrimControlChars(const text: RawUTF8; const controls: TSynAnsicharSet): RawUTF8; -var len,i,j,n: PtrInt; - P: PAnsiChar; -begin - len := length(text); - for i := 1 to len do - if text[i] in controls then begin - n := i-1; - FastSetString(result,nil,len); - P := pointer(result); - if n>0 then - MoveFast(pointer(text)^,P^,n); - for j := i+1 to len do - if not(text[j] in controls) then begin - P[n] := text[j]; - inc(n); - end; - SetLength(result,n); // truncate - exit; - end; - result := text; // no control char found -end; - -procedure ExchgPointer(n1,n2: PPointer); {$ifdef HASINLINE}inline;{$endif} -var n: pointer; -begin - n := n2^; - n2^ := n1^; - n1^ := n; -end; - -procedure ExchgVariant(v1,v2: PPtrIntArray); {$ifdef CPU64}inline;{$endif} -var c: PtrInt; // 32-bit:16bytes=4ptr 64-bit:24bytes=3ptr -begin - c := v2[0]; - v2[0] := v1[0]; - v1[0] := c; - c := v2[1]; - v2[1] := v1[1]; - v1[1] := c; - c := v2[2]; - v2[2] := v1[2]; - v1[2] := c; - {$ifdef CPU32} - c := v2[3]; - v2[3] := v1[3]; - v1[3] := c; - {$endif} -end; - -{$ifdef CPU64} -procedure Exchg16(P1,P2: PPtrIntArray); inline; -var c: PtrInt; -begin - c := P1[0]; - P1[0] := P2[0]; - P2[0] := c; - c := P1[1]; - P1[1] := P2[1]; - P2[1] := c; -end; -{$endif} - -procedure Exchg(P1,P2: PAnsiChar; count: PtrInt); - {$ifdef PUREPASCAL} {$ifdef HASINLINE}inline;{$endif} -var i, c: PtrInt; - u: AnsiChar; -begin - for i := 1 to count shr POINTERSHR do begin - c := PPtrInt(P1)^; - PPtrInt(P1)^ := PPtrInt(P2)^; - PPtrInt(P2)^ := c; - inc(P1,SizeOf(c)); - inc(P2,SizeOf(c)); - end; - for i := 0 to (count and POINTERAND)-1 do begin - u := P1[i]; - P1[i] := P2[i]; - P2[i] := u; - end; -end; -{$else} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=P1, edx=P2, ecx=count - push ebx - push esi - push ecx - shr ecx, 2 - jz @2 -@4: mov ebx, [eax] - mov esi, [edx] - mov [eax], esi - mov [edx], ebx - add eax, 4 - add edx, 4 - dec ecx - jnz @4 -@2: pop ecx - and ecx, 3 - jz @0 -@1: mov bl, [eax] - mov bh, [edx] - mov [eax], bh - mov [edx], bl - inc eax - inc edx - dec ecx - jnz @1 -@0: pop esi - pop ebx -end; -{$endif} - -function GetAllBits(Bits, BitCount: Cardinal): boolean; -begin - if BitCount in [low(ALLBITS_CARDINAL)..high(ALLBITS_CARDINAL)] then begin - BitCount := ALLBITS_CARDINAL[BitCount]; - result := (Bits and BitCount)=BitCount; - end else - result := false; -end; - -// naive code gives the best performance - bts [Bits] has an overhead -function GetBit(const Bits; aIndex: PtrInt): boolean; -begin - result := PByteArray(@Bits)[aIndex shr 3] and (1 shl (aIndex and 7)) <> 0; -end; - -procedure SetBit(var Bits; aIndex: PtrInt); -begin - TByteArray(Bits)[aIndex shr 3] := TByteArray(Bits)[aIndex shr 3] - or (1 shl (aIndex and 7)); -end; - -procedure UnSetBit(var Bits; aIndex: PtrInt); -begin - PByteArray(@Bits)[aIndex shr 3] := PByteArray(@Bits)[aIndex shr 3] - and not (1 shl (aIndex and 7)); -end; - -function GetBitPtr(Bits: pointer; aIndex: PtrInt): boolean; -begin - result := PByteArray(Bits)[aIndex shr 3] and (1 shl (aIndex and 7)) <> 0; -end; - -procedure SetBitPtr(Bits: pointer; aIndex: PtrInt); -begin - PByteArray(Bits)[aIndex shr 3] := PByteArray(Bits)[aIndex shr 3] - or (1 shl (aIndex and 7)); -end; - -procedure UnSetBitPtr(Bits: pointer; aIndex: PtrInt); -begin - PByteArray(Bits)[aIndex shr 3] := PByteArray(Bits)[aIndex shr 3] - and not (1 shl (aIndex and 7)); -end; - -function GetBit64(const Bits: Int64; aIndex: PtrInt): boolean; -begin - result := aIndex in TBits64(Bits); -end; - -procedure SetBit64(var Bits: Int64; aIndex: PtrInt); -begin - include(PBits64(@Bits)^,aIndex); -end; - -procedure UnSetBit64(var Bits: Int64; aIndex: PtrInt); -begin - exclude(PBits64(@Bits)^,aIndex); -end; - -function GetBitsCount(const Bits; Count: PtrInt): PtrInt; -var P: PPtrInt; - popcnt: function(value: PtrInt): PtrInt; // fast redirection within loop -begin - P := @Bits; - result := 0; - popcnt := @GetBitsCountPtrInt; - if Count>=POINTERBITS then - repeat - dec(Count,POINTERBITS); - inc(result,popcnt(P^)); // use SSE4.2 if available - inc(P); - until Count0 then - inc(result,popcnt(P^ and ((PtrInt(1) shl Count)-1))); -end; - -{ FPC x86_64 Linux: - 1000000 pas in 4.67ms i.e. 213,949,507/s, aver. 0us, 1.5 GB/s - 1000000 asm in 4.14ms i.e. 241,196,333/s, aver. 0us, 1.8 GB/s - 1000000 sse4.2 in 2.36ms i.e. 423,011,844/s, aver. 0us, 3.1 GB/s - 1000000 FPC in 21.32ms i.e. 46,886,721/s, aver. 0us, 357.7 MB/s - FPC i386 Windows: - 1000000 pas in 3.40ms i.e. 293,944,738/s, aver. 0us, 1 GB/s - 1000000 asm in 3.18ms i.e. 313,971,742/s, aver. 0us, 1.1 GB/s - 1000000 sse4.2 in 2.74ms i.e. 364,166,059/s, aver. 0us, 1.3 GB/s - 1000000 FPC in 8.18ms i.e. 122,204,570/s, aver. 0us, 466.1 MB/s - notes: - 1. AVX2 faster than popcnt on big buffers - https://arxiv.org/pdf/1611.07612.pdf - 2. our pascal/asm versions below use the efficient Wilkes-Wheeler-Gill algorithm - whereas FPC RTL's popcnt() is much slower } - -{$ifdef CPUX86} -function GetBitsCountSSE42(value: PtrInt): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif} -asm - {$ifdef FPC_X86ASM} - popcnt eax, eax - {$else} // oldest Delphi don't support this opcode - db $f3,$0f,$B8,$c0 - {$endif} -end; -function GetBitsCountPas(value: PtrInt): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // branchless Wilkes-Wheeler-Gill i386 asm implementation - mov edx, eax - shr eax, 1 - and eax, $55555555 - sub edx, eax - mov eax, edx - shr edx, 2 - and eax, $33333333 - and edx, $33333333 - add eax, edx - mov edx, eax - shr eax, 4 - add eax, edx - and eax, $0f0f0f0f - mov edx, eax - shr edx, 8 - add eax, edx - mov edx, eax - shr edx, 16 - add eax, edx - and eax, $3f -end; -{$else} -{$ifdef CPUX64} -function GetBitsCountSSE42(value: PtrInt): PtrInt; -{$ifdef FPC} assembler; nostackframe; -asm - popcnt rax, value -{$else} // oldest Delphi don't support this opcode -asm .noframe - {$ifdef win64} db $f3,$48,$0f,$B8,$c1 - {$else} db $f3,$48,$0f,$B8,$c7 {$endif} -{$endif FPC} -end; -function GetBitsCountPas(value: PtrInt): PtrInt; -{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif} - mov rax, value - mov rdx, value - shr rax, 1 - mov rcx, $5555555555555555 - mov r8, $3333333333333333 - mov r10, $0f0f0f0f0f0f0f0f - mov r11, $0101010101010101 - and rax, rcx - sub rdx, rax - mov rax, rdx - shr rdx, 2 - and rax, r8 - and rdx, r8 - add rax, rdx - mov rdx, rax - shr rax, 4 - add rax, rdx - and rax, r10 - imul rax, r11 - shr rax, 56 -end; -{$else} -function GetBitsCountPas(value: PtrInt): PtrInt; -begin // generic branchless Wilkes-Wheeler-Gill pure pascal version - result := value; - {$ifdef CPU64} - result := result-((result shr 1) and $5555555555555555); - result := (result and $3333333333333333)+((result shr 2) and $3333333333333333); - result := (result+(result shr 4)) and $0f0f0f0f0f0f0f0f; - inc(result,result shr 8); // avoid slow multiplication on ARM - inc(result,result shr 16); - inc(result,result shr 32); - result := result and $7f; - {$else} - result := result-((result shr 1) and $55555555); - result := (result and $33333333)+((result shr 2) and $33333333); - result := (result+(result shr 4)) and $0f0f0f0f; - inc(result,result shr 8); - inc(result,result shr 16); - result := result and $3f; - {$endif CPU64} -end; -{$endif CPUX64} -{$endif CPUX86} - -type -{$ifdef FPC} - {$packrecords c} // as expected by FPC's RTTI record definitions - TStrRec = record // see TAnsiRec/TUnicodeRec in astrings/ustrings.inc - {$ifdef ISFPC27} - codePage: TSystemCodePage; // =Word - elemSize: Word; - {$ifndef STRCNT32} - {$ifdef CPU64} - _PaddingToQWord: DWord; - {$endif} {$endif} {$endif} - refCnt: TStrCnt; // =SizeInt on older FPC, =longint since FPC 3.4 - length: SizeInt; - end; -{$else FPC} - /// map the Delphi/FPC dynamic array header (stored before each instance) - TDynArrayRec = packed record - {$ifdef CPUX64} - /// padding bytes for 16 byte alignment of the header - _Padding: LongInt; - {$endif} - /// dynamic array reference count (basic garbage memory mechanism) - refCnt: TDACnt; - /// length in element count - // - size in bytes = length*ElemSize - length: PtrInt; - end; - PDynArrayRec = ^TDynArrayRec; - - /// map the Delphi/FPC string header (stored before each instance) - TStrRec = packed record - {$ifdef UNICODE} - {$ifdef CPU64} - /// padding bytes for 16 bytes alignment of the header - _Padding: LongInt; - {$endif} - /// the associated code page used for this string - // - exist only since Delphi/FPC 2009 - // - 0 or 65535 for RawByteString - // - 1200=CP_UTF16 for UnicodeString - // - 65001=CP_UTF8 for RawUTF8 - // - the current code page for AnsiString - codePage: Word; - /// either 1 (for AnsiString) or 2 (for UnicodeString) - // - exist only since Delphi/FPC 2009 - elemSize: Word; - {$endif UNICODE} - /// COW string reference count (basic garbage memory mechanism) - refCnt: TStrCnt; - /// length in characters - // - size in bytes = length*elemSize - length: Longint; - end; -{$endif FPC} - PStrRec = ^TStrRec; - - PTypeInfo = ^TTypeInfo; - {$ifdef HASDIRECTTYPEINFO} // for old FPC (<=3.0) - PTypeInfoStored = PTypeInfo; - {$else} // e.g. for Delphi and newer FPC - PTypeInfoStored = ^PTypeInfo; // = TypeInfoPtr macro in FPC typinfo.pp - {$endif} - - // note: FPC TRecInitData is taken from typinfo.pp via SynFPCTypInfo - // since this information is evolving/breaking a lot in the current FPC trunk - - /// map the Delphi/FPC record field RTTI - TFieldInfo = - {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} - packed - {$endif FPC_REQUIRES_PROPER_ALIGNMENT} - record - TypeInfo: PTypeInfoStored; - {$ifdef FPC} - Offset: sizeint; - {$else} - Offset: PtrUInt; - {$endif FPC} - end; - PFieldInfo = ^TFieldInfo; - {$ifdef ISDELPHI2010_OR_FPC_NEWRTTI} - /// map the Delphi record field enhanced RTTI (available since Delphi 2010) - TEnhancedFieldInfo = - {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} - packed - {$endif FPC_REQUIRES_PROPER_ALIGNMENT} - record - TypeInfo: PTypeInfoStored; - {$ifdef FPC} - Offset: sizeint; // match TInitManagedField/TManagedField in FPC typinfo.pp - {$else} - Offset: PtrUInt; - {$endif FPC} - {$ifdef ISDELPHI2010} - Flags: Byte; - NameLen: byte; // = Name[0] = length(Name) - {$ENDIF} - end; - PEnhancedFieldInfo = ^TEnhancedFieldInfo; - {$endif} - - TTypeInfo = - {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} - packed - {$endif FPC_REQUIRES_PROPER_ALIGNMENT} - record - kind: TTypeKind; - NameLen: byte; - case TTypeKind of - tkUnknown: ( - NameFirst: AnsiChar; - ); - tkDynArray: ( - {$ifdef FPC} - elSize: SizeUInt; // and $7FFFFFFF = item/record size - elType2: PTypeInfoStored; - varType: LongInt; - elType: PTypeInfoStored; - //DynUnitName: ShortStringBase; - {$else} - // storage byte count for this field - elSize: Longint; - // nil for unmanaged field - elType: PTypeInfoStored; - // OleAuto compatible type - varType: Integer; - // also unmanaged field - elType2: PTypeInfoStored; - {$endif FPC} - ); - tkArray: ( - {$ifdef FPC} - // warning: in VER2_6, this is the element size, not full array size - arraySize: SizeInt; - // product of lengths of all dimensions - elCount: SizeInt; - {$else} - arraySize: Integer; - // product of lengths of all dimensions - elCount: Integer; - {$endif FPC} - arrayType: PTypeInfoStored; - dimCount: Byte; - dims: array[0..255 {DimCount-1}] of PTypeInfoStored; - ); - {$ifdef FPC} - tkRecord, tkObject:( - {$ifdef FPC_NEWRTTI} - RecInitInfo: Pointer; // call GetManagedFields() to use FPC's TypInfo.pp - recSize: longint; - {$else} - ManagedCount: longint; - ManagedFields: array[0..0] of TFieldInfo; - // note: FPC for 3.0.x and previous generates RTTI for unmanaged fields (as in TEnhancedFieldInfo) - {$endif FPC_NEWRTTI} - {$else} - tkRecord: ( - recSize: cardinal; - ManagedCount: integer; - ManagedFields: array[0..0] of TFieldInfo; - {$ifdef ISDELPHI2010} // enhanced RTTI containing info about all fields - NumOps: Byte; - //RecOps: array[0..0] of Pointer; - AllCount: Integer; // !!!! may need $RTTI EXPLICIT FIELDS([vcPublic]) - AllFields: array[0..0] of TEnhancedFieldInfo; - {$endif ISDELPHI2010} - {$endif FPC} - ); - tkEnumeration: ( - EnumType: TOrdType; - {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} - EnumDummy: DWORD; // needed on ARM for correct alignment - {$endif} - {$ifdef FPC_ENUMHASINNER} inner: - {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} packed {$endif} record - {$endif FPC_ENUMHASINNER} - MinValue: longint; - MaxValue: longint; - EnumBaseType: PTypeInfoStored; // BaseTypeRef in FPC TypInfo.pp - {$ifdef FPC_ENUMHASINNER} end; {$endif FPC_ENUMHASINNER} - NameList: string[255]; - ); - tkInteger: ( - IntegerType: TOrdType; - ); - tkInt64: ( - MinInt64Value, MaxInt64Value: Int64; - ); - tkSet: ( - SetType: TOrdType; - {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} - SetDummy: DWORD; // needed on ARM for correct alignment - {$endif} - {$ifdef FPC} - {$ifndef VER3_0} - SetSize: SizeInt; - {$endif VER3_0} - {$endif FPC} - SetBaseType: PTypeInfoStored; // CompTypeRef in FPC TypInfo.pp - ); - tkFloat: ( - FloatType: TFloatType; - ); - tkClass: ( - ClassType: TClass; - ParentInfo: PTypeInfoStored; // ParentInfoRef in FPC TypInfo.pp - PropCount: SmallInt; - UnitNameLen: byte; - ); - end; - - {$ifdef FPC} - {$push} - {$PACKRECORDS 1} - {$endif} - TPropInfo = packed record - PropType: PTypeInfoStored; - GetProc: PtrInt; - SetProc: PtrInt; - StoredProc: PtrInt; - Index: Integer; - Default: Longint; - NameIndex: SmallInt; - {$ifdef FPC} - PropProcs : Byte; - {$ifdef FPC_PROVIDE_ATTR_TABLE} - /// property attributes, introduced since FPC SVN 42356-42411 (2019/07) - AttributeTable: Pointer; - {$endif FPC_PROVIDE_ATTR_TABLE} - {$endif} - NameLen: byte; - end; - PPropInfo = ^TPropInfo; - {$ifdef FPC} - {$pop} - {$endif} - -{$ifdef HASDIRECTTYPEINFO} -type - Deref = PTypeInfo; -{$else} -function Deref(Info: PTypeInfoStored): PTypeInfo; // for Delphi and newer FPC -{$ifdef HASINLINE} inline; -begin - result := pointer(Info); - if Info<>nil then - result := Info^; -end; -{$else} -asm // Delphi is so bad at compiling above code... - or eax, eax - jz @z - mov eax, [eax] - ret -@z: db $f3 // rep ret -end; -{$endif HASINLINE} -{$endif HASDIRECTTYPEINFO} - -const - /// codePage offset = string header size - // - used to calc the beginning of memory allocation of a string - STRRECSIZE = SizeOf(TStrRec); - -{$ifdef HASCODEPAGE} -function FastNewString(len: PtrInt; cp: cardinal): PAnsiChar; inline; -begin - if len>0 then begin - {$ifdef FPC_X64MM}result := _Getmem({$else}GetMem(result,{$endif}len+(STRRECSIZE+4)); - PStrRec(result)^.codePage := cp; - PStrRec(result)^.elemSize := 1; - PStrRec(result)^.refCnt := 1; - PStrRec(result)^.length := len; - PCardinal(result+len+STRRECSIZE)^ := 0; // ensure ends with four #0 - inc(PStrRec(result)); - end else - result := nil; -end; -{$endif HASCODEPAGE} - -{$ifdef FPC_X64} -procedure fpc_ansistr_decr_ref; external name 'FPC_ANSISTR_DECR_REF'; -procedure fpc_ansistr_incr_ref; external name 'FPC_ANSISTR_INCR_REF'; -procedure fpc_ansistr_assign; external name 'FPC_ANSISTR_ASSIGN'; -procedure fpc_ansistr_setlength; external name 'FPC_ANSISTR_SETLENGTH'; -procedure fpc_ansistr_compare; external name 'FPC_ANSISTR_COMPARE'; -procedure fpc_ansistr_compare_equal; external name 'FPC_ANSISTR_COMPARE_EQUAL'; -procedure fpc_unicodestr_decr_ref; external name 'FPC_UNICODESTR_DECR_REF'; -procedure fpc_unicodestr_incr_ref; external name 'FPC_UNICODESTR_INCR_REF'; -procedure fpc_unicodestr_assign; external name 'FPC_UNICODESTR_ASSIGN'; -procedure fpc_dynarray_incr_ref; external name 'FPC_DYNARRAY_INCR_REF'; -procedure fpc_dynarray_decr_ref; external name 'FPC_DYNARRAY_DECR_REF'; -procedure fpc_dynarray_clear; external name 'FPC_DYNARRAY_CLEAR'; -{$ifdef FPC_X64MM} -procedure fpc_getmem; external name 'FPC_GETMEM'; -procedure fpc_freemem; external name 'FPC_FREEMEM'; -{$else} -procedure _Getmem; external name 'FPC_GETMEM'; -procedure _Freemem; external name 'FPC_FREEMEM'; -{$endif FPC_X64MM} - -procedure PatchJmp(old, new: PByteArray; size: PtrInt; jmp: PtrUInt=0); -var - rel: PCardinal; -begin - PatchCode(old, new, size, nil, {unprotected=}true); - if jmp = 0 then - jmp := PtrUInt(@_Freemem); - repeat // search and fix "jmp rel fpc_freemem/_dynarray_decr_ref_free" - dec(size); - if size = 0 then - exit; - rel := @old[size + 1]; - until (old[size] = $e9) and - (rel^ = cardinal(jmp - PtrUInt(@new[size]) - 5)); - rel^ := jmp - PtrUInt(rel) - 4; -end; - -procedure _ansistr_decr_ref(var p: Pointer); nostackframe; assembler; -asm - mov rax, qword ptr[p] - xor edx, edx - test rax, rax - jz @z - mov qword ptr[p], rdx - mov p, rax - {$ifdef STRCNT32} - cmp dword ptr[rax - _STRREFCNT], rdx - jl @z -lock dec dword ptr[rax - _STRREFCNT] - {$else} - cmp qword ptr[rax - _STRREFCNT], rdx - jl @z -lock dec qword ptr[rax - _STRREFCNT] - {$endif STRCNT32} - jbe @free -@z: ret -@free: sub p, STRRECSIZE - jmp _Freemem -end; - -procedure _ansistr_incr_ref(p: pointer); nostackframe; assembler; -asm - test p, p - jz @z - {$ifdef STRCNT32} - cmp dword ptr[p - _STRREFCNT], 0 - jl @z -lock inc dword ptr[p - _STRREFCNT] - {$else} - cmp qword ptr[p - _STRREFCNT], 0 - jl @z -lock inc qword ptr[p - _STRREFCNT] - {$endif STRCNT32} -@z: -end; - -procedure _ansistr_assign(var d: pointer; s: pointer); nostackframe; assembler; -asm - mov rax, qword ptr[d] - cmp rax, s - jz @eq - test s, s - jz @ns - {$ifdef STRCNT32} - cmp dword ptr[s - _STRREFCNT], 0 - jl @ns -lock inc dword ptr[s - _STRREFCNT] -@ns: mov qword ptr[d], s - test rax, rax - jnz @z -@eq: ret -@z: mov d, rax - cmp dword ptr[rax - _STRREFCNT], 0 - jl @n - lock dec dword ptr[rax - _STRREFCNT] - {$else} - cmp qword ptr[s - _STRREFCNT], 0 - jl @ns -lock inc qword ptr[s - _STRREFCNT] -@ns: mov qword ptr[d], s - test rax, rax - jnz @z -@eq: ret -@z: mov d, rax - cmp qword ptr[rax - _STRREFCNT], 0 - jl @n - lock dec qword ptr[rax - _STRREFCNT] - {$endif STRCNT32} - ja @n -@free: sub d, STRRECSIZE - jmp _Freemem -@n: -end; - -{ note: fpc_ansistr_compare/_equal do check the codepage and make a UTF-8 - conversion if necessary, whereas Delphi _LStrCmp/_LStrEqual don't; - involving codepage is safer, but paranoid, and 1. is (much) slower, and - 2. is not Delphi compatible -> we rather follow the Delphi/Lazy's way } - -function _ansistr_compare(s1, s2: pointer): SizeInt; nostackframe; assembler; -asm - xor eax, eax - cmp s1, s2 - je @0 - test s1, s2 - jz @maybe0 -@first: mov al, byte ptr[s1] // we can check the first char (for quicksort) - sub al, byte ptr[s2] - jne @ne - mov r8, qword ptr[s1 - _STRLEN] - mov r11, r8 - sub r8, qword ptr[s2 - _STRLEN] // r8 = length(s1)-length(s2) - adc rax, -1 - and rax, r8 // rax = -min(length(s1),length(s2)) - sub rax, r11 - sub s1, rax - sub s2, rax - align 8 -@s: mov r10, qword ptr[s1 + rax] // compare by 8 bytes (may include len) - xor r10, qword ptr[s2 + rax] - jnz @d - add rax, 8 - js @s -@e: mov rax, r8 // all equal -> return difflen -@0: ret -@ne: movsx rax, al - ret -@d: bsf r10, r10 // compute s1^-s2^ - shr r10, 3 - add rax, r10 - jns @e - movzx edx, byte ptr[s2 + rax] - movzx eax, byte ptr[s1 + rax] - sub rax, rdx - ret -@maybe0:test s2, s2 - jz @1 - test s1, s1 - jnz @first - dec rax - ret -@1: inc eax -end; - -function _ansistr_compare_equal(s1, s2: pointer): SizeInt; nostackframe; assembler; -asm - xor eax, eax - cmp s1, s2 - je @q - test s1, s2 - jz @maybe0 -@ok: mov rax, qword ptr[s1 - _STRLEN] // len must match - cmp rax, qword ptr[s2 - _STRLEN] - jne @q - lea s1, qword ptr[s1 + rax - 8] - lea s2, qword ptr[s2 + rax - 8] - neg rax - mov r8, qword ptr[s1] // compare last 8 bytes (may include len) - cmp r8, qword ptr[s2] - jne @q - align 16 -@s: add rax, 8 // compare remaining 8 bytes per iteration - jns @0 - mov r8, qword ptr[s1 + rax] - cmp r8, qword ptr[s2 + rax] - je @s - mov eax, 1 - ret -@0: xor eax, eax -@q: ret -@maybe0:test s2, s2 - jz @1 - test s1, s1 - jnz @ok -@1: inc eax // not zero is enough -end; - -procedure _dynarray_incr_ref(p: pointer); nostackframe; assembler; -asm - test p, p - jz @z - cmp qword ptr[p - _DAREFCNT], 0 - jle @z -lock inc qword ptr[p - _DAREFCNT] -@z: -end; - -procedure _dynarray_decr_ref_free(p: PDynArrayRec; info: pointer); forward; - -procedure _dynarray_decr_ref(var p: Pointer; info: pointer); nostackframe; assembler; -asm - mov rax, qword ptr[p] - test rax, rax - jz @z - mov qword ptr[p], 0 - mov p, rax - sub p, SizeOf(TDynArrayRec) - cmp qword ptr[rax - _DAREFCNT], 0 - jle @z -lock dec qword ptr[p] - jbe @free -@z: ret -@free: jmp _dynarray_decr_ref_free -end; - -procedure FastAssignNew(var d; s: pointer); nostackframe; assembler; -asm - mov rax, qword ptr[d] - mov qword ptr[d], s - test rax, rax - jz @z - mov d, rax - {$ifdef STRCNT32} - cmp dword ptr[rax - _STRREFCNT], 0 - jl @z -lock dec dword ptr[rax - _STRREFCNT] - {$else} - cmp qword ptr[rax - _STRREFCNT], 0 - jl @z -lock dec qword ptr[rax - _STRREFCNT] - {$endif STRCNT32} - jbe @free -@z: ret -@free: sub d, STRRECSIZE - jmp _Freemem -end; - -{$ifdef FPC_HAS_CPSTRING} - -{$ifdef FPC_X64MM} -procedure _ansistr_setlength_new(var s: RawByteString; len: PtrInt; cp: cardinal); -var p, new: PAnsiChar; - l: PtrInt; -begin - if cp<=CP_OEMCP then begin // TranslatePlaceholderCP logic - cp := DefaultSystemCodePage; - if cp=0 then - cp := CP_NONE; - end; - new := FastNewString(len,cp); - p := pointer(s); - if p<>nil then begin - l := PStrLen(p-_STRLEN)^+1; - if l>len then - l := len; - MoveFast(p^,new^,l); - end; - FastAssignNew(s,new); -end; - -procedure _ansistr_setlength(var s: RawByteString; len: PtrInt; cp: cardinal); - nostackframe; assembler; -asm - mov rax, qword ptr[s] - test len, len - jle _ansistr_decr_ref - test rax, rax - jz _ansistr_setlength_new - {$ifdef STRCNT32} - cmp dword ptr[rax - _STRREFCNT], 1 - {$else} - cmp qword ptr[rax - _STRREFCNT], 1 - {$endif STRCNT32} - jne _ansistr_setlength_new - push len - push s - sub qword ptr[s], STRRECSIZE - add len, STRRECSIZE + 1 - call _reallocmem // rely on MM in-place detection - pop s - pop len - add qword ptr[s], STRRECSIZE - mov qword ptr[rax].TStrRec.length, len - mov byte ptr[rax + len + STRRECSIZE], 0 -end; -{$endif FPC_X64MM} - -// _ansistr_concat_convert* optimized for systemcodepage=CP_UTF8 - -function ToTempUTF8(var temp: TSynTempBuffer; p: pointer; len, cp: cardinal): pointer; -begin - if (len=0) or (cp=CP_UTF8) or (cp>=CP_SQLRAWBLOB) or IsAnsiCompatible(p,len) then begin - temp.buf := nil; - temp.len := len; - result := p; - end else begin - temp.Init(len*3); - p := TSynAnsiConvert.Engine(cp).AnsiBufferToUTF8(temp.buf,p,len); - temp.len := PAnsiChar(p)-PAnsiChar(temp.buf); - result := temp.buf; - end; -end; - -procedure _ansistr_concat_convert(var dest: RawByteString; const s1,s2: RawByteString; - cp,cp1,cp2: cardinal); -var t1, t2, t: TSynTempBuffer; // avoid most memory allocation - p1, p2, p: PAnsiChar; - eng: TSynAnsiConvert; -begin - p1 := ToTempUTF8(t1,pointer(s1),length(s1),cp1); - p2 := ToTempUTF8(t2,pointer(s2),length(s2),cp2); - if (cp=CP_UTF8) or (cp>=CP_SQLRAWBLOB) or ((t1.buf=nil) and (t2.buf=nil)) then begin - p := FastNewString(t1.len+t2.len,cp); - MoveFast(p1^,p[0],t1.len); - MoveFast(p2^,p[t1.len],t2.len); - FastAssignNew(dest,p); - end else begin - eng := TSynAnsiConvert.Engine(cp); - t.Init((t1.len+t2.len) shl eng.fAnsiCharShift); - p := eng.UTF8BufferToAnsi(eng.UTF8BufferToAnsi(t.buf,p1,t1.len),p2,t2.len); - FastSetStringCP(dest,t.buf,p-t.buf,cp); - t.Done; - end; - t2.Done; - t1.Done; -end; - -function _lstrlen(const s: RawByteString): TStrLen; inline; -begin - result := PStrLen(PtrUInt(s)-_STRLEN)^; -end; - -function _lstrcp(const s: RawByteString; cp: integer): integer; inline; -begin - result := cp; - if s<>'' then begin - result := PStrRec(PtrUInt(s)-STRRECSIZE)^.codePage; - if result<=CP_OEMCP then - result := CP_UTF8; - end; -end; - -procedure _ansistr_concat_utf8(var dest: RawByteString; - const s1,s2: RawByteString; cp: cardinal); -var cp1, cp2: cardinal; - new: PAnsiChar; - l1: PtrInt; -begin - if cp<=CP_OEMCP then // TranslatePlaceholderCP logic - cp := CP_UTF8; - cp1 := _lstrcp(s1,cp); - cp2 := _lstrcp(s2,cp1); - if (cp1=cp2) and ((cp>=CP_SQLRAWBLOB) or (cp=cp1)) then - cp := cp1 else - if ((cp1<>cp) and (cp1cp) and (cp2 self-resize dest - SetLength(dest,l1+_lstrlen(s2)); - PStrRec(PtrUInt(dest)-STRRECSIZE)^.codepage := cp; - MoveFast(pointer(s2)^,PByteArray(dest)[l1],_lstrlen(s2)); - end else begin - new := FastNewString(l1+_lstrlen(s2),cp); - MoveFast(pointer(s1)^,new[0],l1); - MoveFast(pointer(s2)^,new[l1],_lstrlen(s2)); - FastAssignNew(dest,new); - end; - end; -end; - -procedure _ansistr_concat_multi_convert(var dest: RawByteString; - s: PRawByteString; scount, cp: cardinal); -var t: TTextWriter; - u: RawUTF8; - tmp: TTextWriterStackBuffer; -begin - t := TTextWriter.CreateOwnedStream(tmp); - try - repeat - if s^<>'' then - t.AddAnyAnsiBuffer(pointer(s^),_lstrlen(s^),twNone,_lstrcp(s^,cp)); - inc(s); - dec(scount); - until scount=0; - t.SetText(u); - finally - t.Free; - end; - if (cp=CP_UTF8) or (cp>=CP_SQLRAWBLOB) then - dest := u else - TSynAnsiConvert.Engine(cp).UTF8BufferToAnsi(pointer(u),length(u),dest); -end; - -procedure _ansistr_concat_multi_utf8(var dest: RawByteString; - const s: array of RawByteString; cp: cardinal); -var first,len,i,l: integer; // should NOT be PtrInt/SizeInt to avoid FPC bug with high(s) :( - cpf,cpi: cardinal; - p: pointer; - new: PAnsiChar; -begin - if cp<=CP_OEMCP then - cp := CP_UTF8; - first := 0; - repeat - if first>high(s) then begin - _ansistr_decr_ref(pointer(dest)); - exit; - end; - p := pointer(s[first]); - if p<>nil then - break; - inc(first); - until false; - len := _lstrlen(RawByteString(p)); - cpf := _lstrcp(RawByteString(p),cp); - if (cpf<>cp) and (cpfnil then begin - inc(len,_lstrlen(RawByteString(p))); - cpi := PStrRec(PtrUInt(p)-STRRECSIZE)^.codePage; - if cpi<=CP_OEMCP then - cpi := CP_UTF8; - if (cpi<>cpf) and (cpi self-resize - SetLength(dest,len); - new := pointer(dest); - PStrRec(PtrUInt(dest)-STRRECSIZE)^.codepage := cp; - cp := 0; - end else begin - new := FastNewString(len,cp); - MoveFast(p^,new[0],l); - end; - for i := first+1 to high(s) do begin - p := pointer(s[i]); - if p<>nil then begin - MoveFast(p^,new[l],_lstrlen(RawByteString(p))); - inc(l,_lstrlen(RawByteString(p))); - end; - end; - if cp<>0 then - FastAssignNew(dest,new); - end; -end; - -procedure _fpc_ansistr_concat(var a: RawUTF8); -begin - a := a+a; // to generate "call fpc_ansistr_concat" opcode -end; - -procedure _fpc_ansistr_concat_multi(var a: RawUTF8); -begin - a := a+a+a; // to generate "call fpc_ansistr_concat_multi" opcode -end; - -procedure RedirectRtl(dummy, dest: PByteArray); -begin - repeat - if (dummy[0]=$b9) and (PCardinal(@dummy[1])^=CP_UTF8) then - case dummy[5] of - $e8: begin - // found "mov ecx,65001; call fpc_ansistr_concat" opcodes - RedirectCode(@dummy[PInteger(@dummy[6])^+10],dest); - exit; - end; - $ba: if (PCardinal(@dummy[6])^=2) and (dummy[10]=$e8) then - begin - // found "mov ecx,65001; mov edx,2; call fpc_ansistr_concat_multi" - RedirectCode(@dummy[PInteger(@dummy[11])^+15],dest); - exit; - end; - end; - inc(PByte(dummy)); - until PInt64(dummy)^=0; -end; - -{$endif FPC_HAS_CPSTRING} - -{$else} - -procedure FastAssignNew(var d; s: pointer); {$ifdef HASINLINE} inline; {$endif} -var - sr: PStrRec; // local copy to use register -begin - sr := Pointer(d); - Pointer(d) := s; - if sr = nil then - exit; - dec(sr); - if (sr^.refcnt >= 0) and StrCntDecFree(sr^.refcnt) then - FreeMem(sr); -end; -{$endif FPC_X64} - -{$ifdef HASCODEPAGE} -procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt); -var r: pointer; -begin - r := FastNewString(len,codepage); - if p<>nil then - MoveFast(p^,r^,len); - FastAssignNew(s,r); -end; - -procedure FastSetString(var s: RawUTF8; p: pointer; len: PtrInt); -var r: pointer; -begin - r := FastNewString(len,CP_UTF8); - if p<>nil then - MoveFast(p^,r^,len); - FastAssignNew(s,r); -end; -{$else not HASCODEPAGE} -procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt); -begin - SetString(RawByteString(s),PAnsiChar(p),len); -end; -procedure FastSetString(var s: RawUTF8; p: pointer; len: PtrInt); -begin - SetString(RawByteString(s),PAnsiChar(p),len); -end; -{$endif HASCODEPAGE} - -procedure GetMemAligned(var s: RawByteString; p: pointer; len: PtrInt; - out aligned: pointer); -begin - SetString(s,nil,len+16); - aligned := pointer(s); - inc(PByte(aligned),PtrUInt(aligned) and 15); - if p<>nil then - MoveFast(p^,aligned^,len); -end; - -function ToText(k: TTypeKind): PShortString; -begin - result := GetEnumName(TypeInfo(TTypeKind),ord(k)); -end; - -function ToText(k: TDynArrayKind): PShortString; -begin - result := GetEnumName(TypeInfo(TDynArrayKind),ord(k)); -end; - -function UniqueRawUTF8(var UTF8: RawUTF8): pointer; -begin - {$ifdef FPC} - UniqueString(UTF8); // @UTF8[1] won't call UniqueString() under FPC :( - {$endif} - result := @UTF8[1]; -end; - -procedure UniqueRawUTF8ZeroToTilde(var UTF8: RawUTF8; MaxSize: integer); -var i: integer; -begin - i := length(UTF8); - if i>MaxSize then - PByteArray(UTF8)[MaxSize] := 0 else - MaxSize := i; - for i := 0 to MaxSize-1 do - if PByteArray(UTF8)[i]=0 then - PByteArray(UTF8)[i] := ord('~'); -end; - -{$ifdef FPC} -function TDynArrayRec.GetLength: sizeint; -begin - result := high+1; -end; - -procedure TDynArrayRec.SetLength(len: sizeint); -begin - high := len-1; -end; -{$endif FPC} - -function DynArrayLength(Value: Pointer): PtrInt; - {$ifdef HASINLINE}inline;{$endif} -begin - result := PtrInt(Value); - if result<>0 then - result := PDALen(result-_DALEN)^{$ifdef FPC}+1{$endif}; -end; - -{$ifdef HASALIGNTYPEDATA} -function FPCTypeInfoOverName(P: pointer): pointer; inline; -{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} {$ifdef CPUARM3264} -const diff=SizeOf(QWord);// always on these two CPU's -{$else} var diff: PtrUInt; {$endif} {$endif} -begin - {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} - {$ifndef CPUARM3264} - diff := PtrUInt(@PTypeInfo(P)^.NameFirst)-PtrUInt(@PTypeInfo(P)^.Kind); - {$endif} - result := AlignTypeData(P+2+PByte(P+1)^); - dec(PByte(result),diff); - {$else} - result := AlignTypeData(P+PByte(P+1)^); - {$endif} -end; -{$endif HASALIGNTYPEDATA} - -function GetTypeInfo(aTypeInfo: pointer; aExpectedKind: TTypeKind): PTypeInfo; overload; -{$ifdef HASINLINE} inline; -begin - result := aTypeInfo; - if result<>nil then - if result^.Kind=aExpectedKind then - {$ifdef HASALIGNTYPEDATA} - result := FPCTypeInfoOverName(result) - {$else} - inc(PByte(result),result^.NameLen) - {$endif} - else - result := nil; -end; -{$else} -asm - test eax, eax - jz @n - movzx ecx, byte ptr[eax + TTypeInfo.NameLen] - cmp dl, [eax] - jne @n - add eax, ecx - ret -@n: xor eax, eax -end; -{$endif HASINLINE} - -function GetTypeInfo(aTypeInfo: pointer; const aExpectedKind: TTypeKinds): PTypeInfo; overload; -{$ifdef HASINLINE} inline; -begin - result := aTypeInfo; - if result<>nil then - if result^.Kind in aExpectedKind then - {$ifdef HASALIGNTYPEDATA} - result := FPCTypeInfoOverName(result) - {$else} - inc(PByte(result),result^.NameLen) - {$endif} - else - result := nil; -end; -{$else} -asm // eax=aTypeInfo edx=aExpectedKind - test eax, eax - jz @n - movzx ecx, byte ptr[eax] - bt edx, ecx - movzx ecx, byte ptr[eax + TTypeInfo.NameLen] - jnb @n - add eax, ecx - ret -@n: xor eax, eax -end; -{$endif HASINLINE} - -function GetTypeInfo(aTypeInfo: pointer): PTypeInfo; overload; -{$ifdef HASINLINE} inline; -begin - {$ifdef HASALIGNTYPEDATA} - result := FPCTypeInfoOverName(aTypeInfo); - {$else} - result := @PAnsiChar(aTypeInfo)[PTypeInfo(aTypeInfo)^.NameLen]; - {$endif} -end; -{$else} -asm - movzx ecx, byte ptr[eax + TTypeInfo.NameLen] - add eax, ecx -end; -{$endif HASINLINE} - -function DynArrayTypeInfoToRecordInfo(aDynArrayTypeInfo: pointer; - aDataSize: PInteger): pointer; -var info: PTypeInfo; -begin - result := nil; - info := GetTypeInfo(aDynArrayTypeInfo,tkDynArray); - if info=nil then - exit; - if info^.elType<>nil then - result := Deref(info^.elType); - if aDataSize<>nil then - aDataSize^ := info^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}; -end; - -procedure TypeInfoToName(aTypeInfo: pointer; var result: RawUTF8; - const default: RawUTF8); -begin - if aTypeInfo<>nil then - FastSetString(result,PAnsiChar(@PTypeInfo(aTypeInfo)^.NameLen)+1, - PTypeInfo(aTypeInfo)^.NameLen) else - result := default; -end; - -function TypeInfoToShortString(aTypeInfo: pointer): PShortString; -begin - if aTypeInfo<>nil then - result := @PTypeInfo(aTypeInfo)^.NameLen else - result := nil; -end; - -procedure TypeInfoToQualifiedName(aTypeInfo: pointer; var result: RawUTF8; - const default: RawUTF8); -var unitname: RawUTF8; -begin - if aTypeInfo<>nil then begin - FastSetString(result,PAnsiChar(@PTypeInfo(aTypeInfo)^.NameLen)+1, - PTypeInfo(aTypeInfo)^.NameLen); - if PTypeInfo(aTypeInfo)^.Kind=tkClass then begin - with GetTypeInfo(aTypeInfo)^ do - FastSetString(unitname,PAnsiChar(@UnitNameLen)+1,UnitNameLen); - result := unitname+'.'+result; - end; - end else result := default; -end; - -function TypeInfoToName(aTypeInfo: pointer): RawUTF8; -begin - TypeInfoToName(aTypeInfo,Result,''); -end; - -function RecordTypeInfoSize(aRecordTypeInfo: pointer): integer; -var info: PTypeInfo; -begin - info := GetTypeInfo(aRecordTypeInfo,tkRecordKinds); - if info=nil then - result := 0 else - result := info^.recSize; -end; - -function GetEnumInfo(aTypeInfo: pointer; out MaxValue: Integer): PShortString; -{$ifdef HASINLINE} inline; -var info: PTypeInfo; - base: PTypeInfoStored; -begin - if (aTypeInfo<>nil) and (PTypeKind(aTypeInfo)^=tkEnumeration) then begin - info := GetTypeInfo(aTypeInfo); - base := info^.{$ifdef FPC_ENUMHASINNER}inner.{$endif}EnumBaseType; - {$ifdef FPC} // no redirection if aTypeInfo is already the base type - if (base<>nil) and (base{$ifndef HASDIRECTTYPEINFO}^{$endif}<>aTypeInfo) then - {$endif} - info := GetTypeInfo(base{$ifndef HASDIRECTTYPEINFO}^{$endif}); - MaxValue := info^.{$ifdef FPC_ENUMHASINNER}inner.{$endif}MaxValue; - result := @info^.NameList; - end else - result := nil; -end; -{$else} -asm // eax=aTypeInfo edx=@MaxValue - test eax, eax - jz @n - cmp byte ptr[eax], tkEnumeration - jnz @n - movzx ecx, byte ptr[eax + TTypeInfo.NameLen] - mov eax, [eax + ecx + TTypeInfo.EnumBaseType] - mov eax, [eax] - movzx ecx, byte ptr[eax + TTypeInfo.NameLen] - add eax, ecx - mov ecx, [eax + TTypeInfo.MaxValue] - mov [edx], ecx - lea eax, [eax + TTypeInfo.NameList] - ret -@n: xor eax, eax -end; -{$endif HASINLINE} - -function GetSetBaseEnum(aTypeInfo: pointer): pointer; -begin - result := GetTypeInfo(aTypeInfo,tkSet); - if result<>nil then - result := Deref(PTypeInfo(result)^.SetBaseType); -end; - -function GetSetInfo(aTypeInfo: pointer; out MaxValue: Integer; - out Names: PShortString): boolean; {$ifdef HASINLINE}inline;{$endif} -var info: PTypeInfo; -begin - info := GetTypeInfo(aTypeInfo,tkSet); - if info<>nil then begin - Names := GetEnumInfo(Deref(info^.SetBaseType),MaxValue); - result := Names<>nil; - end else - result := false; -end; - -const - NULL_LOW = ord('n')+ord('u')shl 8+ord('l')shl 16+ord('l')shl 24; - FALSE_LOW = ord('f')+ord('a')shl 8+ord('l')shl 16+ord('s')shl 24; - FALSE_LOW2 = ord('a')+ord('l')shl 8+ord('s')shl 16+ord('e')shl 24; - TRUE_LOW = ord('t')+ord('r')shl 8+ord('u')shl 16+ord('e')shl 24; - - NULL_SHORTSTRING: string[1] = ''; - -procedure GetEnumNames(aTypeInfo: pointer; aDest: PPShortString); -var MaxValue, i: integer; - res: PShortString; -begin - res := GetEnumInfo(aTypeInfo,MaxValue); - if res<>nil then - for i := 0 to MaxValue do begin - aDest^ := res; - inc(PByte(res),PByte(res)^+1); // next - inc(aDest); - end; -end; - -procedure GetEnumTrimmedNames(aTypeInfo: pointer; aDest: PRawUTF8); -var MaxValue, i: integer; - res: PShortString; -begin - res := GetEnumInfo(aTypeInfo,MaxValue); - if res<>nil then - for i := 0 to MaxValue do begin - aDest^ := TrimLeftLowerCaseShort(res); - inc(PByte(res),PByte(res)^+1); // next - inc(aDest); - end; -end; - -function GetEnumTrimmedNames(aTypeInfo: pointer): TRawUTF8DynArray; -var MaxValue, i: integer; - res: PShortString; -begin - Finalize(result); - res := GetEnumInfo(aTypeInfo,MaxValue); - if res=nil then - exit; - SetLength(result,MaxValue+1); - for i := 0 to MaxValue do begin - result[i] := TrimLeftLowerCaseShort(res); - inc(PByte(res),PByte(res)^+1); // next - end; -end; - -procedure GetCaptionFromTrimmed(PS: PShortString; var result: string); -var tmp: array[byte] of AnsiChar; - L: integer; -begin - L := ord(PS^[0]); - inc(PByte(PS)); - while (L>0) and (PS^[0] in ['a'..'z']) do begin inc(PByte(PS)); dec(L); end; - tmp[L] := #0; // as expected by GetCaptionFromPCharLen/UnCamelCase - if L>0 then - MoveSmall(PS,@tmp,L); - GetCaptionFromPCharLen(tmp,result); -end; - -procedure GetEnumCaptions(aTypeInfo: pointer; aDest: PString); -var MaxValue, i: integer; - res: PShortString; -begin - res := GetEnumInfo(aTypeInfo,MaxValue); - if res<>nil then - for i := 0 to MaxValue do begin - GetCaptionFromTrimmed(res,aDest^); - inc(PByte(res),PByte(res)^+1); // next - inc(aDest); - end; -end; - -function GetEnumName(aTypeInfo: pointer; aIndex: integer): PShortString; -{$ifdef HASINLINENOTX86} -var MaxValue: integer; -begin - result := GetEnumInfo(aTypeInfo,MaxValue); - if (result<>nil) and (cardinal(aIndex)<=cardinal(MaxValue)) then begin - if aIndex>0 then - repeat - inc(PByte(result),PByte(result)^+1); // next - dec(aIndex); - if aIndex=0 then - break; - inc(PByte(result),PByte(result)^+1); // loop unrolled twice - dec(aIndex); - until aIndex=0; - end else - result := @NULL_SHORTSTRING; -end; -{$else} -asm // eax=aTypeInfo edx=aIndex - test eax, eax - jz @0 - cmp byte ptr[eax], tkEnumeration - jnz @0 - movzx ecx, byte ptr[eax + TTypeInfo.NameLen] - mov eax, [eax + ecx + TTypeInfo.EnumBaseType] - mov eax, [eax] - movzx ecx, byte ptr[eax + TTypeInfo.NameLen] - cmp edx, [eax + ecx + TTypeInfo.MaxValue] - ja @0 - lea eax, [eax + ecx + TTypeInfo.NameList] - test edx, edx - jz @z - push edx - shr edx, 2 // fast by-four scanning - jz @1 -@4: dec edx - movzx ecx, byte ptr[eax] - lea eax, [eax + ecx + 1] - movzx ecx, byte ptr[eax] - lea eax, [eax + ecx + 1] - movzx ecx, byte ptr[eax] - lea eax, [eax + ecx + 1] - movzx ecx, byte ptr[eax] - lea eax, [eax + ecx + 1] - jnz @4 - pop edx - and edx, 3 - jnz @s - ret -@1: pop edx -@s: movzx ecx, byte ptr[eax] - dec edx - lea eax, [eax + ecx + 1] // next - jnz @s - ret -@z: rep ret -@0: lea eax, NULL_SHORTSTRING -end; -{$endif HASINLINENOTX86} - -{$ifdef PUREPASCAL} // for proper inlining -function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: PtrInt): boolean; -label zero; -begin - P1P2Len := PtrInt(@PAnsiChar(P1)[P1P2Len-SizeOf(cardinal)]); - if P1P2Len>=PtrInt(PtrUInt(P1)) then - repeat // case-insensitive compare 4 bytes per loop - if (PCardinal(P1)^ xor PCardinal(P2)^) and $dfdfdfdf<>0 then - goto zero; - inc(P1,SizeOf(cardinal)); - inc(P2,SizeOf(cardinal)); - until P1P2Len0 then - goto zero; - inc(P1); - until PtrInt(PtrUInt(P1))>=P1P2Len; - result := true; - exit; -zero: - result := false; -end; -{$endif PUREPASCAL} - -function IdemPropNameUSmallNotVoid(P1,P2,P1P2Len: PtrInt): boolean; - {$ifdef HASINLINE}inline;{$endif} -label zero; -begin - inc(P1P2Len,P1); - dec(P2,P1); - repeat - if (PByte(P1)^ xor ord(PAnsiChar(P1)[P2])) and $df<>0 then - goto zero; - inc(P1); - until P1>=P1P2Len; - result := true; - exit; -zero: - result := false; -end; - -function FindShortStringListExact(List: PShortString; MaxValue: integer; - aValue: PUTF8Char; aValueLen: PtrInt): integer; -var PLen: PtrInt; -begin - if aValueLen<>0 then - for result := 0 to MaxValue do begin - PLen := PByte(List)^; - if (PLen=aValuelen) and - IdemPropNameUSmallNotVoid(PtrInt(@List^[1]),PtrInt(aValue),PLen) then - exit; - List := pointer(@PAnsiChar(PLen)[PtrUInt(List)+1]); // next - end; - result := -1; -end; - -function FindShortStringListTrimLowerCase(List: PShortString; MaxValue: integer; - aValue: PUTF8Char; aValueLen: PtrInt): integer; -var PLen: PtrInt; -begin - if aValueLen<>0 then - for result := 0 to MaxValue do begin - PLen := ord(List^[0]); - inc(PUTF8Char(List)); - repeat // trim lower case - if not(PUTF8Char(List)^ in ['a'..'z']) then - break; - inc(PUTF8Char(List)); - dec(PLen); - until PLen=0; - if (PLen=aValueLen) and IdemPropNameUSmallNotVoid(PtrInt(aValue),PtrInt(List),PLen) then - exit; - inc(PUTF8Char(List),PLen); // next - end; - result := -1; -end; - -{$ifdef HASINLINE} -function CompareMemFixed(P1, P2: Pointer; Length: PtrInt): Boolean; -label zero; -begin // cut-down version of our pure pascal CompareMem() function - {$ifndef CPUX86} result := false; {$endif} - Length := PtrInt(@PAnsiChar(P1)[Length-SizeOf(PtrInt)]); - if Length>=PtrInt(PtrUInt(P1)) then - repeat // compare one PtrInt per loop - if PPtrInt(P1)^<>PPtrInt(P2)^ then - goto zero; - inc(PPtrInt(P1)); - inc(PPtrInt(P2)); - until LengthPByteArray(P2)[PtrUInt(P1)] then - goto zero; - inc(PByte(P1)); - until PtrInt(PtrUInt(P1))>=Length; - result := true; - exit; -zero: - {$ifdef CPUX86} result := false; {$endif} -end; -{$endif HASINLINE} - -function FindShortStringListTrimLowerCaseExact(List: PShortString; MaxValue: integer; - aValue: PUTF8Char; aValueLen: PtrInt): integer; -var PLen: PtrInt; -begin - if aValueLen<>0 then - for result := 0 to MaxValue do begin - PLen := ord(List^[0]); - inc(PUTF8Char(List)); - repeat - if not(PUTF8Char(List)^ in ['a'..'z']) then - break; - inc(PUTF8Char(List)); - dec(PLen); - until PLen=0; - if (PLen=aValueLen) and CompareMemFixed(aValue,List,PLen) then - exit; - inc(PUTF8Char(List),PLen); - end; - result := -1; -end; - -function GetEnumNameValue(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt; - AlsoTrimLowerCase: boolean): Integer; -var List: PShortString; - MaxValue: integer; -begin - List := GetEnumInfo(aTypeInfo,MaxValue); - if (aValueLen<>0) and (List<>nil) then begin - result := FindShortStringListExact(List,MaxValue,aValue,aValueLen); - if (result<0) and AlsoTrimLowerCase then - result := FindShortStringListTrimLowerCase(List,MaxValue,aValue,aValueLen); - end else - result := -1; -end; - -function GetEnumNameValueTrimmed(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer; -var List: PShortString; - MaxValue: integer; -begin - List := GetEnumInfo(aTypeInfo,MaxValue); - if (aValueLen<>0) and (List<>nil) then - result := FindShortStringListTrimLowerCase(List,MaxValue,aValue,aValueLen) else - result := -1; -end; - -function GetEnumNameValueTrimmedExact(aTypeInfo: pointer; aValue: PUTF8Char; aValueLen: PtrInt): integer; -var List: PShortString; - MaxValue: integer; -begin - List := GetEnumInfo(aTypeInfo,MaxValue); - if (aValueLen<>0) and (List<>nil) then - result := FindShortStringListTrimLowerCaseExact(List,MaxValue,aValue,aValueLen) else - result := -1; -end; - -function GetEnumNameValue(aTypeInfo: pointer; const aValue: RawUTF8; - AlsoTrimLowerCase: boolean): Integer; -begin - result := GetEnumNameValue(aTypeInfo, pointer(aValue), length(aValue), - AlsoTrimLowerCase); -end; - -function GetSetName(aTypeInfo: pointer; const value): RawUTF8; -var PS: PShortString; - i,max: integer; -begin - result := ''; - if GetSetInfo(aTypeInfo,max,PS) then begin - for i := 0 to max do begin - if GetBitPtr(@value,i) then - result := FormatUTF8('%%,',[result,PS^]); - inc(PByte(PS),PByte(PS)^+1); // next - end; - end; - if result<>'' then - SetLength(result,length(result)-1); // trim last comma -end; - -procedure AppendShortComma(text: PAnsiChar; len: PtrInt; var result: shortstring; - trimlowercase: boolean); -begin - if trimlowercase then - while text^ in ['a'..'z'] do - if len=1 then - exit else begin - inc(text); - dec(len); - end; - if integer(ord(result[0]))+len>=255 then - exit; - if len>0 then - MoveSmall(text,@result[ord(result[0])+1],len); - inc(result[0],len+1); - result[ord(result[0])] := ','; -end; - -procedure GetSetNameShort(aTypeInfo: pointer; const value; out result: ShortString; - trimlowercase: boolean); -var PS: PShortString; - i,max: integer; -begin - result := ''; - if GetSetInfo(aTypeInfo,max,PS) then begin - for i := 0 to max do begin - if GetBitPtr(@value,i) then - AppendShortComma(@PS^[1],ord(PS^[0]),result,trimlowercase); - inc(PByte(PS),PByte(PS)^+1); // next - end; - end; - if result[ord(result[0])]=',' then - dec(result[0]); -end; - -function GetSetNameValue(aTypeInfo: pointer; var P: PUTF8Char; - out EndOfObject: AnsiChar): cardinal; -var names: PShortString; - Text: PUTF8Char; - wasString: boolean; - MaxValue, TextLen, i: integer; -begin - result := 0; - if (P<>nil) and GetSetInfo(aTypeInfo,MaxValue,names) then begin - while (P^<=' ') and (P^<>#0) do inc(P); - if P^='[' then begin - repeat inc(P) until (P^>' ') or (P^=#0); - if P^=']' then - inc(P) else begin - repeat - Text := GetJSONField(P,P,@wasString,@EndOfObject,@TextLen); - if (Text=nil) or not wasString then begin - P := nil; // invalid input (expects a JSON array of strings) - exit; - end; - if Text^='*' then begin - if MaxValue<32 then - result := ALLBITS_CARDINAL[MaxValue+1] else - result := cardinal(-1); - break; - end; - if Text^ in ['a'..'z'] then - i := FindShortStringListExact(names,MaxValue,Text,TextLen) else - i := -1; - if i<0 then - i := FindShortStringListTrimLowerCase(names,MaxValue,Text,TextLen); - if i>=0 then - SetBitPtr(@result,i); - // unknown enum names (i=-1) would just be ignored - until EndOfObject=']'; - if P=nil then - exit; // avoid GPF below if already reached the input end - end; - while not (jcEndOfJSONField in JSON_CHARS[P^]) do begin // mimics GetJSONField() - if P^=#0 then begin - P := nil; - exit; // unexpected end - end; - inc(P); - end; - EndOfObject := P^; - repeat inc(P) until (P^>' ') or (P^=#0); - end else - result := GetCardinal(GetJSONField(P,P,nil,@EndOfObject)); - end; -end; - - -{ note: those low-level VariantTo*() functions are expected to be there - even if NOVARIANTS conditional is defined (used e.g. by SynDB.TQuery) } - -function SetVariantUnRefSimpleValue(const Source: variant; var Dest: TVarData): boolean; -var typ: cardinal; -begin - result := false; - typ := TVarData(Source).VType; - if typ and varByRef=0 then - exit; - typ := typ and not varByRef; - case typ of - varVariant: - if integer(PVarData(TVarData(Source).VPointer)^.VType) in - [varEmpty..varDate,varBoolean,varShortInt..varWord64] then begin - Dest := PVarData(TVarData(Source).VPointer)^; - result := true; - end; - varEmpty..varDate,varBoolean,varShortInt..varWord64: begin - Dest.VType := typ; - Dest.VInt64 := PInt64(TVarData(Source).VAny)^; - result := true; - end; - end; -end; - -function VariantToInteger(const V: Variant; var Value: integer): boolean; -var tmp: TVarData; - vt: cardinal; -begin - result := false; - vt := TVarData(V).VType; - case vt of - varNull, - varEmpty: Value := 0; - varBoolean: if TVarData(V).VBoolean then Value := 1 else Value := 0; // normalize - varSmallint: Value := TVarData(V).VSmallInt; - {$ifndef DELPHI5OROLDER} - varShortInt: Value := TVarData(V).VShortInt; - varWord: Value := TVarData(V).VWord; - varLongWord: - if TVarData(V).VLongWord<=cardinal(High(integer)) then - Value := TVarData(V).VLongWord else - exit; - {$endif} - varByte: Value := TVarData(V).VByte; - varInteger: Value := TVarData(V).VInteger; - varWord64: - if (TVarData(V).VInt64>=0) and (TVarData(V).VInt64<=High(integer)) then - Value := TVarData(V).VInt64 else - exit; - varInt64: - if (TVarData(V).VInt64>=Low(integer)) and (TVarData(V).VInt64<=High(integer)) then - Value := TVarData(V).VInt64 else - exit; - else - if SetVariantUnRefSimpleValue(V,tmp) then begin - result := VariantToInteger(variant(tmp),Value); - exit; - end else - exit; - end; - result := true; -end; - -function VariantToDouble(const V: Variant; var Value: double): boolean; -var tmp: TVarData; - vt: cardinal; -begin - vt := TVarData(V).VType; - if vt=varVariant or varByRef then - result := VariantToDouble(PVariant(TVarData(V).VPointer)^,Value) else begin - result := true; - if VariantToInt64(V,tmp.VInt64) then // also handle varEmpty,varNull - Value := tmp.VInt64 else - case vt of - varDouble,varDate: - Value := TVarData(V).VDouble; - varSingle: - Value := TVarData(V).VSingle; - varCurrency: - Value := TVarData(V).VCurrency; - else begin - if SetVariantUnRefSimpleValue(V,tmp) then - result := VariantToDouble(variant(tmp),Value) else - result := false; - end; - end; - end; -end; - -function VariantToDoubleDef(const V: Variant; const default: double=0): double; -begin - if not VariantToDouble(V,result) then - result := default; -end; - -function VariantToCurrency(const V: Variant; var Value: currency): boolean; -var tmp: TVarData; - vt: cardinal; -begin - vt := TVarData(V).VType; - if vt=varVariant or varByRef then - result := VariantToCurrency(PVariant(TVarData(V).VPointer)^,Value) else begin - result := true; - if VariantToInt64(V,tmp.VInt64) then - Value := tmp.VInt64 else - case vt of - varDouble,varDate: - Value := TVarData(V).VDouble; - varSingle: - Value := TVarData(V).VSingle; - varCurrency: - Value := TVarData(V).VCurrency; - else - if SetVariantUnRefSimpleValue(V,tmp) then - result := VariantToCurrency(variant(tmp),Value) else - result := false; - end; - end; -end; - -function VariantToBoolean(const V: Variant; var Value: Boolean): boolean; -var tmp: TVarData; - vt: cardinal; -begin - vt := TVarData(V).VType; - case vt of - varEmpty, varNull: begin - result := false; - exit; - end; - varBoolean: - Value := TVarData(V).VBoolean; - varInteger: // coming e.g. from GetJsonField() - Value := TVarData(V).VInteger=1; - varString: - Value := IdemPropNameU(RawUTF8(TVarData(V).VAny),BOOL_UTF8[true]); - {$ifndef DELPHI5OROLDER} // WideCompareText() not defined on this old RTL - varOleStr: - Value := WideCompareText(WideString(TVarData(V).VAny),'true')=0; - {$endif DELPHI5OROLDER} - {$ifdef HASVARUSTRING} - varUString: Value := {$ifdef FPC}UnicodeCompareText{$else}CompareText{$endif}( - UnicodeString(TVarData(V).VAny),'true')=0; - {$endif HASVARUSTRING} - else - if SetVariantUnRefSimpleValue(V,tmp) then - if tmp.VType=varBoolean then - Value := tmp.VBoolean else begin - result := false; - exit; - end else begin - result := false; - exit; - end; - end; - result := true; -end; - -function VariantToInt64(const V: Variant; var Value: Int64): boolean; -var tmp: TVarData; - vt: cardinal; -begin - vt := TVarData(V).VType; - case vt of - varNull, - varEmpty: Value := 0; - varBoolean: if TVarData(V).VBoolean then Value := 1 else Value := 0; // normalize - varSmallint: Value := TVarData(V).VSmallInt; - {$ifndef DELPHI5OROLDER} - varShortInt: Value := TVarData(V).VShortInt; - varWord: Value := TVarData(V).VWord; - varLongWord: Value := TVarData(V).VLongWord; - {$endif} - varByte: Value := TVarData(V).VByte; - varInteger: Value := TVarData(V).VInteger; - varWord64: if TVarData(V).VInt64>=0 then - Value := TVarData(V).VInt64 else begin - result := false; - exit; - end; - varInt64: Value := TVarData(V).VInt64; - else - if SetVariantUnRefSimpleValue(V,tmp) then begin - result := VariantToInt64(variant(tmp),Value); - exit; - end else begin - result := false; - exit; - end; - end; - result := true; -end; - -function VariantToInt64Def(const V: Variant; DefaultValue: Int64): Int64; -begin - if not VariantToInt64(V,result) then - result := DefaultValue; -end; - -function VariantToIntegerDef(const V: Variant; DefaultValue: integer): integer; -begin - if not VariantToInteger(V,result) then - result := DefaultValue; -end; - -{$ifndef NOVARIANTS} - -function BinToHexDisplayLowerVariant(Bin: pointer; BinBytes: integer): variant; -begin - RawUTF8ToVariant(BinToHexDisplayLower(Bin,BinBytes),result); -end; - -function VariantHexDisplayToBin(const Hex: variant; Bin: PByte; BinBytes: integer): boolean; -var tmp: RawUTF8; - wasString: boolean; -begin - VariantToUTF8(hex,tmp,wasString); - result := wasstring and HexDisplayToBin(pointer(tmp),Bin,BinBytes); -end; - -function VariantToDateTime(const V: Variant; var Value: TDateTime): boolean; -var tmp: RawUTF8; - vd: TVarData; - vt: cardinal; -begin - vt := TVarData(V).VType; - if vt=varVariant or varByRef then - result := VariantToDateTime(PVariant(TVarData(V).VPointer)^,Value) else begin - result := true; - case vt of - varDouble,varDate: - Value := TVarData(V).VDouble; - varSingle: - Value := TVarData(V).VSingle; - varCurrency: - Value := TVarData(V).VCurrency; - else - if SetVariantUnRefSimpleValue(V,vd) then - result := VariantToDateTime(variant(vd),Value) else begin - VariantToUTF8(V,tmp); - Iso8601ToDateTimePUTF8CharVar(pointer(tmp),length(tmp),Value); - result := Value<>0; - end; - end; - end; -end; - -procedure VariantToInlineValue(const V: Variant; var result: RawUTF8); -var tmp: RawUTF8; - wasString: boolean; -begin - VariantToUTF8(V,tmp,wasString); - if wasString then - QuotedStr(tmp,'"',result) else - result := tmp; -end; - -function VariantToVariantUTF8(const V: Variant): variant; -var tmp: RawUTF8; - wasString: boolean; -begin - VariantToUTF8(V,tmp,wasString); - if wasString then - result := V else - RawUTF8ToVariant(tmp,result); -end; - -procedure VariantToUTF8(const V: Variant; var result: RawUTF8; - var wasString: boolean); -var tmp: TVarData; - vt: cardinal; -begin - wasString := false; - vt := TVarData(V).VType; - with TVarData(V) do - case vt of - varEmpty, - varNull: - result := NULL_STR_VAR; - varSmallint: - Int32ToUTF8(VSmallInt,result); - {$ifndef DELPHI5OROLDER} - varShortInt: - Int32ToUTF8(VShortInt,result); - varWord: - UInt32ToUTF8(VWord,result); - varLongWord: - UInt32ToUTF8(VLongWord,result); - {$endif} - varByte: - result := SmallUInt32UTF8[VByte]; - varBoolean: - if VBoolean then - result := SmallUInt32UTF8[1] else - result := SmallUInt32UTF8[0]; - varInteger: - Int32ToUTF8(VInteger,result); - varInt64: - Int64ToUTF8(VInt64,result); - varWord64: - UInt64ToUTF8(VInt64,result); - varSingle: - ExtendedToStr(VSingle,SINGLE_PRECISION,result); - varDouble: - DoubleToStr(VDouble,result); - varCurrency: - Curr64ToStr(VInt64,result); - varDate: begin - wasString := true; - DateTimeToIso8601TextVar(VDate,'T',result); - end; - varString: begin - wasString := true; - {$ifdef HASCODEPAGE} - AnyAnsiToUTF8(RawByteString(VString),result); - {$else} - result := RawUTF8(VString); - {$endif} - end; - {$ifdef HASVARUSTRING} - varUString: begin - wasString := true; - RawUnicodeToUtf8(VAny,length(UnicodeString(VAny)),result); - end; - {$endif} - varOleStr: begin - wasString := true; - RawUnicodeToUtf8(VAny,length(WideString(VAny)),result); - end; - else - if SetVariantUnRefSimpleValue(V,tmp) then - VariantToUTF8(Variant(tmp),result,wasString) else - if vt=varVariant or varByRef then // complex varByRef - VariantToUTF8(PVariant(VPointer)^,result,wasString) else - if vt=varByRef or varString then begin - wasString := true; - {$ifdef HASCODEPAGE} - AnyAnsiToUTF8(PRawByteString(VString)^,result); - {$else} - result := PRawUTF8(VString)^; - {$endif} - end else - if vt=varByRef or varOleStr then begin - wasString := true; - RawUnicodeToUtf8(pointer(PWideString(VAny)^),length(PWideString(VAny)^),result); - end else - {$ifdef HASVARUSTRING} - if vt=varByRef or varUString then begin - wasString := true; - RawUnicodeToUtf8(pointer(PUnicodeString(VAny)^),length(PUnicodeString(VAny)^),result); - end else - {$endif} - VariantSaveJSON(V,twJSONEscape,result); // will handle also custom types - end; -end; - -function VariantToUTF8(const V: Variant): RawUTF8; -var wasString: boolean; -begin - VariantToUTF8(V,result,wasString); -end; - -function ToUTF8(const V: Variant): RawUTF8; -var wasString: boolean; -begin - VariantToUTF8(V,result,wasString); -end; - -function VariantToUTF8(const V: Variant; var Text: RawUTF8): boolean; -begin - VariantToUTF8(V,Text,result); -end; - -function VariantEquals(const V: Variant; const Str: RawUTF8; - CaseSensitive: boolean): boolean; - function Complex: boolean; - var wasString: boolean; - tmp: RawUTF8; - begin - VariantToUTF8(V,tmp,wasString); - if CaseSensitive then - result := (tmp=Str) else - result := IdemPropNameU(tmp,Str); - end; -var v1,v2: Int64; - vt: cardinal; -begin - vt := TVarData(V).VType; - with TVarData(V) do - case vt of - varEmpty,varNull: - result := Str=''; - varBoolean: - result := VBoolean=(Str<>''); - varString: - if CaseSensitive then - result := RawUTF8(VString)=Str else - result := IdemPropNameU(RawUTF8(VString),Str); - else if VariantToInt64(V,v1) then begin - SetInt64(pointer(Str),v2); - result := v1=v2; - end else - result := Complex; - end; -end; - -function VariantToString(const V: Variant): string; -var wasString: boolean; - tmp: RawUTF8; - vt: cardinal; -begin - vt := TVarData(V).VType; - with TVarData(V) do - case vt of - varEmpty,varNull: - result := ''; // default VariantToUTF8(null)='null' - {$ifdef UNICODE} // not HASVARUSTRING: here we handle string=UnicodeString - varUString: - result := UnicodeString(VAny); - else - if vt=varByRef or varUString then - result := PUnicodeString(VAny)^ - {$endif} - else begin - VariantToUTF8(V,tmp,wasString); - if tmp='' then - result := '' else - UTF8DecodeToString(pointer(tmp),length(tmp),result); - end; - end; -end; - -procedure RawVariantDynArrayClear(V: PVarData; n: integer); -var vt,docv: integer; - handler: TCustomVariantType; -begin - handler := nil; - docv := DocVariantVType; - repeat - vt := V^.VType; - case vt of - varEmpty..varDate,varError,varBoolean,varShortInt..varWord64: ; - varString: {$ifdef FPC}Finalize(RawUTF8(V^.VAny)){$else}RawUTF8(V^.VAny) := ''{$endif}; - varOleStr: WideString(V^.VAny) := ''; - {$ifdef HASVARUSTRING} - varUString: UnicodeString(V^.VAny) := ''; - {$endif} - else - if vt=docv then - DocVariantType.Clear(V^) else - if vt=varVariant or varByRef then - VarClear(PVariant(V^.VPointer)^) else - if handler=nil then - if (vt and varByRef=0) and FindCustomVariantType(vt,handler) then - handler.Clear(V^) else - VarClear(variant(V^)) else - if vt=handler.VarType then - handler.Clear(V^) else - VarClear(variant(V^)); - end; - inc(V); - dec(n); - until n=0; -end; - -procedure VariantDynArrayClear(var Value: TVariantDynArray); -begin - FastDynArrayClear(@Value,TypeInfo(variant)); -end; - -{$endif NOVARIANTS} - -{$ifdef UNICODE} -// this Pos() is seldom used, it was decided to only define it under -// Delphi 2009+ (which expect such a RawUTF8 specific overloaded version) - -function Pos(const substr, str: RawUTF8): Integer; overload; -begin - Result := PosEx(substr,str,1); -end; - -function IntToString(Value: integer): string; -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - P := StrInt32(@tmp[23],Value); - Ansi7ToString(PWinAnsiChar(P),@tmp[23]-P,result); -end; - -function IntToString(Value: cardinal): string; -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - P := StrUInt32(@tmp[23],Value); - Ansi7ToString(PWinAnsiChar(P),@tmp[23]-P,result); -end; - -function IntToString(Value: Int64): string; -var tmp: array[0..31] of AnsiChar; - P: PAnsiChar; -begin - P := StrInt64(@tmp[31],Value); - Ansi7ToString(PWinAnsiChar(P),@tmp[31]-P,result); -end; - -function DoubleToString(Value: Double): string; -var tmp: ShortString; -begin - if Value=0 then - result := '0' else - Ansi7ToString(PWinAnsiChar(@tmp[1]),DoubleToShort(tmp,Value),result); -end; - -function Curr64ToString(Value: Int64): string; -var tmp: array[0..31] of AnsiChar; -begin - Ansi7ToString(tmp,Curr64ToPChar(Value,tmp),result); -end; - -{$else UNICODE} - -{$ifdef PUREPASCAL} -function IntToString(Value: integer): string; -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - if cardinal(Value)<=high(SmallUInt32UTF8) then - result := SmallUInt32UTF8[Value] else begin - P := StrInt32(@tmp[23],Value); - SetString(result,P,@tmp[23]-P); - end; -end; -{$else} -function IntToString(Value: integer): string; {$ifdef FPC} nostackframe; assembler; {$endif} -asm - jmp Int32ToUTF8 -end; -{$endif PUREPASCAL} - -function IntToString(Value: cardinal): string; -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - if Value<=high(SmallUInt32UTF8) then - result := SmallUInt32UTF8[Value] else begin - P := StrUInt32(@tmp[23],Value); - SetString(result,P,@tmp[23]-P); - end; -end; - -function IntToString(Value: Int64): string; -var tmp: array[0..31] of AnsiChar; - P: PAnsiChar; -begin - if (Value>=0) and (Value<=high(SmallUInt32UTF8)) then - result := SmallUInt32UTF8[Value] else begin - P := StrInt64(@tmp[31],Value); - SetString(result,P,@tmp[31]-P); - end; -end; - -function DoubleToString(Value: Double): string; -var tmp: ShortString; -begin - if Value=0 then - result := '0' else - SetString(result,PAnsiChar(@tmp[1]),DoubleToShort(tmp,Value)); -end; - -function Curr64ToString(Value: Int64): string; -begin - result := Curr64ToStr(Value); -end; - -{$endif UNICODE} - -procedure bswap64array(a,b: PQWordArray; n: PtrInt); -{$ifdef CPUX86} {$ifdef FPC}nostackframe; assembler;{$endif} -asm - push ebx - push esi -@1: mov ebx, dword ptr[eax] - mov esi, dword ptr[eax + 4] - bswap ebx - bswap esi - mov dword ptr[edx + 4], ebx - mov dword ptr[edx], esi - add eax, 8 - add edx, 8 - dec ecx - jnz @1 - pop esi - pop ebx -end; -{$else} -{$ifdef CPUX64} -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} -@1: mov rax, qword ptr[a] - bswap rax - mov qword ptr[b], rax - add a, 8 - add b, 8 - dec n - jnz @1 -end; -{$else} -var i: PtrInt; -begin - for i := 0 to n-1 do - b^[i] := {$ifdef FPC}SwapEndian{$else}bswap64{$endif}(a^[i]); -end; -{$endif CPUX64} -{$endif CPUX86} - -{$ifdef CPUX64} -function bswap32(a: cardinal): cardinal; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - mov eax, a - bswap eax -end; - -function bswap64(const a: QWord): QWord; {$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=a (Linux: rdi) -{$endif FPC} - mov rax, a - bswap rax -end; -{$else} -{$ifdef CPUX86} -function bswap32(a: cardinal): cardinal; {$ifdef FPC} nostackframe; assembler; {$endif} -asm - bswap eax -end; - -function bswap64({$ifdef FPC_X86}constref{$else}const{$endif} a: QWord): QWord; -{$ifdef FPC} nostackframe; assembler; {$endif} asm - {$ifdef FPC_X86} - mov edx, dword ptr[eax] - mov eax, dword ptr[eax + 4] - {$else} - mov edx, a.TQWordRec.L - mov eax, a.TQWordRec.H - {$endif FPC_X86} - bswap edx - bswap eax -end; -{$else} -{$ifdef FPC} -function bswap32(a: cardinal): cardinal; -begin - result := SwapEndian(a); // use fast platform-specific function -end; - -function bswap64(const a: QWord): QWord; -begin - result := SwapEndian(a); // use fast platform-specific function -end; -{$else} -function bswap32(a: cardinal): cardinal; -begin - result := ((a and $ff)shl 24)or((a and $ff00)shl 8)or - ((a and $ff0000)shr 8)or((a and $ff000000)shr 24); -end; - -function bswap64(const a: QWord): QWord; -begin - TQWordRec(result).L := bswap32(TQWordRec(a).H); - TQWordRec(result).H := bswap32(TQWordRec(a).L); -end; -{$endif FPC} -{$endif CPUX86} -{$endif CPUX64} - -{$ifndef PUREPASCAL} { these functions are implemented in asm } -{$ifndef LVCL} { don't define these functions twice } -{$ifndef FPC} { some asm functions use some low-level system.pas calls } - -{$define DEFINED_INT32TOUTF8} - -function Int32ToUTF8(Value : PtrInt): RawUtf8; // 3x faster than SysUtils.IntToStr -// from IntToStr32_JOH_IA32_6_a, adapted for Delphi 2009+ -asm // eax=Value, edx=@result - push ebx - push edi - push esi - mov ebx, eax // value - sar ebx, 31 // 0 for +ve value or -1 for -ve value - xor eax, ebx - sub eax, ebx // abs(value) - mov esi, 10 // max dig in result - mov edi, edx // @result - cmp eax, 10 - sbb esi, 0 - cmp eax, 100 - sbb esi, 0 - cmp eax, 1000 - sbb esi, 0 - cmp eax, 10000 - sbb esi, 0 - cmp eax, 100000 - sbb esi, 0 - cmp eax, 1000000 - sbb esi, 0 - cmp eax, 10000000 - sbb esi, 0 - cmp eax, 100000000 - sbb esi, 0 - cmp eax, 1000000000 - sbb esi, ebx // esi=dig (including sign character) - mov ecx, [edx] // result - test ecx, ecx - je @newstr // create new string for result - cmp dword ptr[ecx - 8], 1 - jne @chgstr // reference count <> 1 - cmp esi, [ecx - 4] - je @lenok // existing length = required length - sub ecx, STRRECSIZE // allocation address - push eax // abs(value) - push ecx - mov eax, esp - lea edx, [esi + STRRECSIZE + 1] // new allocation size - call System.@ReallocMem // reallocate result string - pop ecx - pop eax // abs(value) - add ecx, STRRECSIZE // result - mov [ecx - 4], esi // set new length - mov byte ptr[ecx + esi], 0 // add null terminator - mov [edi], ecx // set result address - jmp @lenok -@chgstr:mov edx, dword ptr[ecx - 8] // reference count - add edx, 1 - jz @newstr // refcount = -1 (string constant) -lock dec dword ptr[ecx - 8] // decrement existing reference count -@newstr:push eax // abs(value) - mov eax, esi // length - {$ifdef UNICODE} - mov edx, CP_UTF8 // utf-8 code page for delphi 2009+ - {$endif} - call System.@NewAnsiString - mov [edi], eax // set result address - mov ecx, eax // result - pop eax // abs(value) -@lenok: mov byte ptr[ecx], '-' // store '-' character (may be overwritten) - add esi, ebx // dig (excluding sign character) - sub ecx, ebx // destination of 1st dig - sub esi, 2 // dig (excluding sign character) - 2 - jle @findig // 1 or 2 dig value - cmp esi, 8 // 10 dig value? - jne @setres // not a 10 dig value - sub eax, 2000000000 // dig 10 must be either '1' or '2' - mov dl, '2' - jnc @set10 // dig 10 = '2' - mov dl, '1' // dig 10 = '1' - add eax, 1000000000 -@set10: mov [ecx], dl // save dig 10 - mov esi, 7 // 9 dig remaining - add ecx, 1 // destination of 2nd dig -@setres:mov edi, $28f5c29 // ((2^32)+100-1)/100 -@loop: mov ebx, eax // dividend - mul edi // edx = dividend div 100 - mov eax, edx // set next dividend - imul edx, -200 // -2 * (100 * dividend div 100) - movzx edx, word ptr[TwoDigitLookup + ebx * 2 + edx] // dividend mod 100 in ascii - mov [ecx + esi], dx - sub esi, 2 - jg @loop // loop until 1 or 2 dig remaining -@findig:pop esi - pop edi - pop ebx - jnz @last - movzx eax, word ptr[TwoDigitLookup + eax * 2] - mov [ecx], ax // save final 2 dig - ret -@last: or al, '0' // ascii adjustment - mov [ecx], al // save final dig -end; - -function Int64ToUTF8(Value: Int64): RawUtf8; -asm // from IntToStr64_JOH_IA32_6_b, adapted for Delphi 2009+ - push ebx - mov ecx, [ebp + 8] // low integer of val - mov edx, [ebp + 12] // high integer of val - xor ebp, ebp // clear sign flag (ebp already pushed) - mov ebx, ecx // low integer of val - test edx, edx - jnl @absval - mov ebp, 1 // ebp = 1 for -ve val or 0 for +ve val - neg ecx - adc edx, 0 - neg edx -@absval:jnz @large // edx:ecx = abs(val) - test ecx, ecx - js @large - mov edx, eax // @result - mov eax, ebx // low integer of val - call Int32ToUtf8 // call fastest integer inttostr function - pop ebx -@exit: pop ebp // restore stack and exit - ret 8 -@large: push edi - push esi - mov edi, eax - xor ebx, ebx - xor eax, eax -@t15: cmp edx, $00005af3 // test for 15 or more dig - jne @chk15 // 100000000000000 div $100000000 - cmp ecx, $107a4000 // 100000000000000 mod $100000000 -@chk15: jb @t13 -@t17: cmp edx, $002386f2 // test for 17 or more dig - jne @chk17 // 10000000000000000 div $100000000 - cmp ecx, $6fc10000 // 10000000000000000 mod $100000000 -@chk17: jb @t1516 -@t19: cmp edx, $0de0b6b3 // test for 19 dig - jne @chk19 // 1000000000000000000 div $100000000 - cmp ecx, $a7640000 // 1000000000000000000 mod $100000000 -@chk19: jb @t1718 - mov al, 19 - jmp @setl2 -@t1718: mov bl, 18 // 17 or 18 dig - cmp edx, $01634578 // 100000000000000000 div $100000000 - jne @setlen - cmp ecx, $5d8a0000 // 100000000000000000 mod $100000000 - jmp @setlen -@t1516: mov bl, 16 // 15 or 16 dig - cmp edx, $00038d7e // 1000000000000000 div $100000000 - jne @setlen - cmp ecx, $a4c68000 // 1000000000000000 mod $100000000 - jmp @setlen -@t13: cmp edx, $000000e8 // test for 13 or more dig - jne @chk13 // 1000000000000 div $100000000 - cmp ecx, $d4a51000 // 1000000000000 mod $100000000 -@chk13: jb @t11 -@t1314: mov bl, 14 // 13 or 14 dig - cmp edx, $00000918 // 10000000000000 div $100000000 - jne @setlen - cmp ecx, $4e72a000 // 10000000000000 mod $100000000 - jmp @setlen -@t11: cmp edx, $02 // 10, 11 or 12 dig - jne @chk11 // 10000000000 div $100000000 - cmp ecx, $540be400 // 10000000000 mod $100000000 -@chk11: mov bl, 11 - jb @setlen // 10 dig -@t1112: mov bl, 12 // 11 or 12 dig - cmp edx, $17 // 100000000000 div $100000000 - jne @setlen - cmp ecx, $4876e800 // 100000000000 mod $100000000 -@setlen:sbb eax, 0 // adjust for odd/evem digit count - add eax, ebx -@setl2: push ecx // abs(val) in edx:ecx, dig in eax - push edx // save abs(val) - lea edx, [eax + ebp] // digit needed (including sign character) - mov ecx, [edi] // @result - mov esi, edx // digit needed (including sign character) - test ecx, ecx - je @newstr // create new ansistring for result - cmp dword ptr[ecx - 8], 1 - jne @chgstr // reference count <> 1 - cmp esi, [ecx - 4] - je @lenok // existing length = required length - sub ecx, STRRECSIZE // allocation address - push eax // abs(val) - push ecx - mov eax, esp - lea edx, [esi + STRRECSIZE + 1] // new allocation size - call System.@ReallocMem // reallocate result ansistring - pop ecx - pop eax // abs(val) - add ecx, STRRECSIZE // @result - mov [ecx - 4], esi // set new length - mov byte ptr[ecx + esi], 0 // add null terminator - mov [edi], ecx // set result address - jmp @lenok -@chgstr:mov edx, dword ptr[ecx - 8] // reference count - add edx, 1 - jz @newstr // refcount = -1 (ansistring constant) -lock dec dword ptr[ecx - 8] // decrement existing reference count -@newstr:push eax // abs(val) - mov eax, esi // length - {$ifdef UNICODE} - mov edx, CP_UTF8 // utf-8 code page for delphi 2009+ - {$endif} - call System.@NewAnsiString - mov [edi], eax // set result address - mov ecx, eax // @result - pop eax // abs(val) -@lenok: mov edi, [edi] // @result - sub esi, ebp // digit needed (excluding sign character) - mov byte ptr[edi], '-' // store '-' character (may be overwritten) - add edi, ebp // destination of 1st digit - pop edx // restore abs(val) - pop eax - cmp esi, 17 - jl @less17 // dig < 17 - je @set17 // dig = 17 - cmp esi, 18 - je @set18 // dig = 18 - mov cl, '0' - 1 - mov ebx, $a7640000 // 1000000000000000000 mod $100000000 - mov ebp, $0de0b6b3 // 1000000000000000000 div $100000000 -@dig19: add ecx, 1 - sub eax, ebx - sbb edx, ebp - jnc @dig19 - add eax, ebx - adc edx, ebp - mov [edi], cl - add edi, 1 -@set18: mov cl, '0' - 1 - mov ebx, $5d8a0000 // 100000000000000000 mod $100000000 - mov ebp, $01634578 // 100000000000000000 div $100000000 -@dig18: add ecx, 1 - sub eax, ebx - sbb edx, ebp - jnc @dig18 - add eax, ebx - adc edx, ebp - mov [edi], cl - add edi, 1 -@set17: mov cl, '0' - 1 - mov ebx, $6fc10000 // 10000000000000000 mod $100000000 - mov ebp, $002386f2 // 10000000000000000 div $100000000 -@dig17: add ecx, 1 - sub eax, ebx - sbb edx, ebp - jnc @dig17 - add eax, ebx - adc edx, ebp - mov [edi], cl - add edi, 1 // update destination - mov esi, 16 // set 16 dig left -@less17:mov ecx, 100000000 // process next 8 dig - div ecx // edx:eax = abs(val) = dividend - mov ebp, eax // dividend div 100000000 - mov ebx, edx - mov eax, edx // dividend mod 100000000 - mov edx, $51eb851f - mul edx - shr edx, 5 // dividend div 100 - mov eax, edx // set next dividend - lea edx, [edx * 4 + edx] - lea edx, [edx * 4 + edx] - shl edx, 2 // dividend div 100 * 100 - sub ebx, edx // remainder (0..99) - movzx ebx, word ptr[TwoDigitLookup + ebx * 2] - shl ebx, 16 - mov edx, $51eb851f - mov ecx, eax // dividend - mul edx - shr edx, 5 // dividend div 100 - mov eax, edx - lea edx, [edx * 4 + edx] - lea edx, [edx * 4 + edx] - shl edx, 2 // dividend div 100 * 100 - sub ecx, edx // remainder (0..99) - or bx, word ptr[TwoDigitLookup + ecx * 2] - mov [edi + esi - 4], ebx // store 4 dig - mov ebx, eax - mov edx, $51eb851f - mul edx - shr edx, 5 // edx = dividend div 100 - lea eax, [edx * 4 + edx] - lea eax, [eax * 4 + eax] - shl eax, 2 // eax = dividend div 100 * 100 - sub ebx, eax // remainder (0..99) - movzx ebx, word ptr[TwoDigitLookup + ebx * 2] - movzx ecx, word ptr[TwoDigitLookup + edx * 2] - shl ebx, 16 - or ebx, ecx - mov [edi + esi - 8], ebx // store 4 dig - mov eax, ebp // remainder - sub esi, 10 // dig left - 2 - jz @last2 -@small: mov edx, $28f5c29 // ((2^32)+100-1)/100 - mov ebx, eax // dividend - mul edx - mov eax, edx // set next dividend - imul edx, -200 - movzx edx, word ptr[TwoDigitLookup + ebx * 2 + edx] // dividend mod 100 in ascii - mov [edi + esi], dx - sub esi, 2 - jg @small // repeat until less than 2 dig remaining - jz @last2 - or al, '0' // ascii adjustment - mov [edi], al // save final digit - jmp @done -@last2: movzx eax, word ptr[TwoDigitLookup + eax * 2] - mov [edi], ax // save final 2 dig -@done: pop esi - pop edi - pop ebx -end; - -function Trim(const S: RawUTF8): RawUTF8; -asm // fast implementation by John O'Harrow, modified for Delphi 2009+ - test eax, eax // S = nil? - xchg eax, edx - jz System.@LStrClr // Yes, Return Empty String - mov ecx, [edx - 4] // Length(S) - cmp byte ptr[edx], ' ' // S[1] <= ' '? - jbe @left // Yes, Trim Leading Spaces - cmp byte ptr[edx + ecx - 1], ' ' // S[Length(S)] <= ' '? - jbe @right // Yes, Trim Trailing Spaces - jmp System.@LStrLAsg // No, Result := S (which occurs most time) -@left: dec ecx // Strip Leading Whitespace - jle System.@LStrClr // All Whitespace - inc edx - cmp byte ptr[edx], ' ' - jbe @left -@done: cmp byte ptr[edx + ecx - 1], ' ' -{$ifdef UNICODE} - jbe @right - push CP_UTF8 // UTF-8 code page for Delphi 2009+ - call System.@LStrFromPCharLen // we need a call, not a jmp here - rep ret -{$else} ja System.@LStrFromPCharLen -{$endif} -@right: dec ecx // Strip Trailing Whitespace - jmp @done -end; - -{$endif FPC} { above asm function had some low-level system.pas calls } - -{$endif LVCL} -{$endif PUREPASCAL} - -function CompareMemSmall(P1, P2: Pointer; Length: PtrUInt): Boolean; -label zero; -var c: AnsiChar; // explicit temp variable for better FPC code generation -begin - {$ifndef CPUX86} result := false; {$endif} - inc(PtrUInt(P1),PtrUInt(Length)); - inc(PtrUInt(P2),PtrUInt(Length)); - Length := -Length; - if Length<>0 then - repeat - c := PAnsiChar(P1)[Length]; - if c<>PAnsiChar(P2)[Length] then - goto zero; - inc(Length); - until Length=0; - result := true; - {$ifdef CPUX86} exit; {$endif} -zero: - {$ifdef CPUX86} result := false; {$endif} -end; - -{$ifdef HASINLINE} -procedure FillZero(var dest; count: PtrInt); -begin - FillCharFast(dest,count,0); -end; -{$else} -procedure FillZero(var dest; count: PtrInt); -asm - xor ecx, ecx - jmp dword ptr [FillCharFast] -end; -{$endif} - -function IsEqual(const A,B; count: PtrInt): boolean; -var perbyte: boolean; // ensure no optimization takes place -begin - result := true; - while count>0 do begin - dec(count); - perbyte := PByteArray(@A)[count]=PByteArray(@B)[count]; - result := result and perbyte; - end; -end; - -function PosCharAny(Str: PUTF8Char; Characters: PAnsiChar): PUTF8Char; -var s: PAnsiChar; - c: AnsiChar; -begin - if (Str<>nil) and (Characters<>nil) and (Characters^<>#0) then - repeat - c := Str^; - if c=#0 then - break; - s := Characters; - repeat - if s^=c then begin - result := Str; - exit; - end; - inc(s); - until s^=#0; - inc(Str); - until false; - result := nil; -end; - -function StringReplaceChars(const Source: RawUTF8; OldChar, NewChar: AnsiChar): RawUTF8; -var i,j,n: PtrInt; -begin - if (OldChar<>NewChar) and (Source<>'') then begin - n := length(Source); - for i := 0 to n-1 do - if PAnsiChar(pointer(Source))[i]=OldChar then begin - FastSetString(result,PAnsiChar(pointer(Source)),n); - for j := i to n-1 do - if PAnsiChar(pointer(result))[j]=OldChar then - PAnsiChar(pointer(result))[j] := NewChar; - exit; - end; - end; - result := Source; -end; - -function IdemPChar2(table: PNormTable; p: PUTF8Char; up: PAnsiChar): boolean; - {$ifdef HASINLINE}inline;{$endif} -var u: AnsiChar; -begin // here p and up are expected to be <> nil - result := false; - dec(PtrUInt(p),PtrUInt(up)); - repeat - u := up^; - if u=#0 then - break; - if table^[up[PtrUInt(p)]]<>u then - exit; - inc(up); - until false; - result := true; -end; - -function PosI(uppersubstr: PUTF8Char; const str: RawUTF8): PtrInt; -var u: AnsiChar; - table: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif}; -begin - if uppersubstr<>nil then begin - {$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7;{$endif} - u := uppersubstr^; - for result := 1 to Length(str) do - if table[str[result]]=u then - if {$ifdef CPUX86NOTPIC}IdemPChar({$else}IdemPChar2(table,{$endif} - @PUTF8Char(pointer(str))[result],PAnsiChar(uppersubstr)+1) then - exit; - end; - result := 0; -end; - -function StrPosI(uppersubstr,str: PUTF8Char): PUTF8Char; -var u: AnsiChar; - table: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif}; -begin - if (uppersubstr<>nil) and (str<>nil) then begin - {$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7;{$endif} - u := uppersubstr^; - inc(uppersubstr); - result := str; - while result^<>#0 do begin - if table[result^]=u then - if {$ifdef CPUX86NOTPIC}IdemPChar({$else}IdemPChar2(table,{$endif} - result+1,PAnsiChar(uppersubstr)) then - exit; - inc(result); - end; - end; - result := nil; -end; - -function PosIU(substr: PUTF8Char; const str: RawUTF8): Integer; -var p: PUTF8Char; -begin - if (substr<>nil) and (str<>'') then begin - p := pointer(str); - repeat - if GetNextUTF8Upper(p)=ord(substr^) then - if IdemPCharU(p,substr+1) then begin - result := p-pointer(str); - exit; - end; - until p^=#0; - end; - result := 0; -end; - -// same as PosExPas() but using char/PChar for (unicode)string process -function PosExStringPas(pSub, p: PChar; Offset: PtrUInt): PtrInt; -var len, lenSub: PtrInt; - ch: char; - pStart, pStop: PChar; -label Loop2, Loop6, TestT, Test0, Test1, Test2, Test3, Test4, - AfterTestT, AfterTest0, Ret, Exit; -begin - result := 0; - if (p=nil) or (pSub=nil) or (PtrInt(Offset)<=0) then - goto Exit; - len := PStrLen(PtrUInt(p)-_STRLEN)^; - lenSub := PStrLen(PtrUInt(pSub)-_STRLEN)^-1; - if (len=pStop then goto Exit; - goto Loop2; -Test4: dec(p,2); -Test2: dec(p,2); - goto Test0; -Test3: dec(p,2); -Test1: dec(p,2); -TestT: len := lenSub; - if lenSub<>0 then - repeat - if (psub[len]<>p[len+1]) or (psub[len+1]<>p[len+2]) then - goto AfterTestT; - inc(len,2); - until len>=0; - inc(p,2); - if p<=pStop then goto Ret; - goto Exit; -Test0: len := lenSub; - if lenSub<>0 then - repeat - if (psub[len]<>p[len]) or (psub[len+1]<>p[len+1]) then - goto AfterTest0; - inc(len,2); - until len>=0; - inc(p); -Ret: - result := p-pStart; -Exit: -end; - -procedure AppendCharToRawUTF8(var Text: RawUTF8; Ch: AnsiChar); -var L: PtrInt; -begin - L := length(Text); - SetLength(Text,L+1); // reallocate - PByteArray(Text)[L] := ord(Ch); -end; - -procedure AppendBufferToRawUTF8(var Text: RawUTF8; Buffer: pointer; BufferLen: PtrInt); -var L: PtrInt; -begin - if BufferLen<=0 then - exit; - L := length(Text); - SetLength(Text,L+BufferLen); - MoveFast(Buffer^,pointer(PtrInt(Text)+L)^,BufferLen); -end; - -procedure AppendBuffersToRawUTF8(var Text: RawUTF8; const Buffers: array of PUTF8Char); -var i,len,TextLen: PtrInt; - lens: array[0..63] of integer; - P: PUTF8Char; -begin - if high(Buffers)>high(lens) then - raise ESynException.Create('Too many params in AppendBuffersToRawUTF8()'); - len := 0; - for i := 0 to high(Buffers) do begin - lens[i] := StrLen(Buffers[i]); - inc(len,lens[i]); - end; - TextLen := Length(Text); - SetLength(Text,TextLen+len); - P := pointer(Text); - inc(P,TextLen); - for i := 0 to high(Buffers) do - if Buffers[i]<>nil then begin - MoveFast(Buffers[i]^,P^,lens[i]); - inc(P,lens[i]); - end; -end; - -function AppendRawUTF8ToBuffer(Buffer: PUTF8Char; const Text: RawUTF8): PUTF8Char; -var L: PtrInt; -begin - L := length(Text); - if L<>0 then begin - MoveFast(Pointer(Text)^,Buffer^,L); - inc(Buffer,L); - end; - result := Buffer; -end; - -function AppendUInt32ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char; -var L: PtrInt; - P: PAnsiChar; - tmp: array[0..23] of AnsiChar; -begin - if Value<=high(SmallUInt32UTF8) then begin - P := pointer(SmallUInt32UTF8[Value]); - L := PStrLen(P-_STRLEN)^; - end else begin - P := StrUInt32(@tmp[23],Value); - L := @tmp[23]-P; - end; - result := Buffer; - repeat - result^ := P^; - inc(result); - inc(P); - dec(L); - until L=0; -end; - -function Append999ToBuffer(Buffer: PUTF8Char; Value: PtrUInt): PUTF8Char; -var L: PtrInt; - P: PAnsiChar; - c: cardinal; -begin - P := pointer(SmallUInt32UTF8[Value]); - L := PStrLen(P-_STRLEN)^; - c := PCardinal(P)^; - Buffer[0] := AnsiChar(c); // PCardinal() write = FastMM4 FullDebugMode errors - inc(Buffer); - if L>1 then begin - Buffer^ := AnsiChar(c shr 8); - inc(Buffer); - if L>2 then begin - Buffer^ := AnsiChar(c shr 16); - inc(Buffer); - end; - end; - result := pointer(Buffer); -end; - -function QuotedStr(const S: RawUTF8; Quote: AnsiChar): RawUTF8; -begin - QuotedStr(S,Quote,result); -end; - -procedure QuotedStr(const S: RawUTF8; Quote: AnsiChar; var result: RawUTF8); -var i,L,quote1,nquote: PtrInt; - P,R: PUTF8Char; - tmp: pointer; // will hold a RawUTF8 with no try..finally exception block - c: AnsiChar; -begin - tmp := nil; - L := length(S); - P := pointer(S); - if (P<>nil) and (P=pointer(result)) then begin - RawUTF8(tmp) := S; // make private ref-counted copy for QuotedStr(U,'"',U) - P := pointer(tmp); - end; - nquote := 0; - {$ifdef FPC} // will use fast FPC SSE version - quote1 := IndexByte(P^,L,byte(Quote)); - if quote1>=0 then - for i := quote1 to L-1 do - if P[i]=Quote then - inc(nquote); - {$else} - quote1 := 0; - for i := 0 to L-1 do - if P[i]=Quote then begin - if nquote=0 then - quote1 := i; - inc(nquote); - end; - {$endif} - FastSetString(result,nil,L+nquote+2); - R := pointer(result); - R^ := Quote; - inc(R); - if nquote=0 then begin - MoveFast(P^,R^,L); - R[L] := Quote; - end else begin - MoveFast(P^,R^,quote1); - inc(R,quote1); - inc(quote1,PtrInt(P)); // trick for reusing a register on FPC - repeat - c := PAnsiChar(quote1)^; - if c=#0 then - break; - inc(quote1); - R^ := c; - inc(R); - if c<>Quote then - continue; - R^ := c; - inc(R); - until false; - R^ := Quote; - end; - if tmp<>nil then - {$ifdef FPC}Finalize(RawUTF8(tmp)){$else}RawUTF8(tmp) := ''{$endif}; -end; - -function GotoEndOfQuotedString(P: PUTF8Char): PUTF8Char; -var quote: AnsiChar; -begin // P^=" or P^=' at function call - quote := P^; - inc(P); - repeat - if P^=#0 then - break else - if P^<>quote then - inc(P) else - if P[1]=quote then // allow double quotes inside string - inc(P,2) else - break; // end quote - until false; - result := P; -end; // P^='"' at function return - -procedure QuotedStrJSON(P: PUTF8Char; PLen: PtrInt; var result: RawUTF8; - const aPrefix, aSuffix: RawUTF8); -var temp: TTextWriterStackBuffer; - Lp,Ls: PtrInt; - D: PUTF8Char; -begin - if (P=nil) or (PLen<=0) then - result := '""' else - if (pointer(result)=pointer(P)) or NeedsJsonEscape(P,PLen) then - with TTextWriter.CreateOwnedStream(temp) do - try - AddString(aPrefix); - Add('"'); - AddJSONEscape(P,PLen); - Add('"'); - AddString(aSuffix); - SetText(result); - exit; - finally - Free; - end else begin - Lp := length(aPrefix); - Ls := length(aSuffix); - FastSetString(result,nil,PLen+Lp+Ls+2); - D := pointer(result); // we checked dest result <> source P above - if Lp>0 then begin - MoveFast(pointer(aPrefix)^,D^,Lp); - inc(D,Lp); - end; - D^ := '"'; - MoveFast(P^,D[1],PLen); - inc(D,PLen); - D[1] := '"'; - if Ls>0 then - MoveFast(pointer(aSuffix)^,D[2],Ls); - end; -end; - -procedure QuotedStrJSON(const aText: RawUTF8; var result: RawUTF8; - const aPrefix, aSuffix: RawUTF8); -begin - QuotedStrJSON(pointer(aText),Length(aText),result,aPrefix,aSuffix); -end; - -function QuotedStrJSON(const aText: RawUTF8): RawUTF8; -begin - QuotedStrJSON(pointer(aText),Length(aText),result,'',''); -end; - -function GotoEndOfJSONString(P: PUTF8Char): PUTF8Char; -var c: AnsiChar; -begin // P^='"' at function call - inc(P); - repeat - c := P^; - if c=#0 then - break else - if c<>'\' then - if c<>'"' then // ignore \" - inc(P) else - break else // found ending " - if P[1]=#0 then // avoid potential buffer overflow issue for \#0 - break else - inc(P,2); // ignore \? - until false; - result := P; -end; // P^='"' at function return - -function GotoNextNotSpace(P: PUTF8Char): PUTF8Char; -begin - {$ifdef FPC} - while (P^<=' ') and (P^<>#0) do inc(P); - {$else} - if P^ in [#1..' '] then - repeat - inc(P) - until not(P^ in [#1..' ']); - {$endif} - result := P; -end; - -function GotoNextNotSpaceSameLine(P: PUTF8Char): PUTF8Char; -begin - while P^ in [#9,' '] do inc(P); - result := P; -end; - -function GotoNextSpace(P: PUTF8Char): PUTF8Char; -begin - if P^>' ' then - repeat - inc(P) - until P^<=' '; - result := P; -end; - -function NextNotSpaceCharIs(var P: PUTF8Char; ch: AnsiChar): boolean; -begin - while (P^<=' ') and (P^<>#0) do inc(P); - if P^=ch then begin - inc(P); - result := true; - end else - result := false; -end; - -function UnQuoteSQLStringVar(P: PUTF8Char; out Value: RawUTF8): PUTF8Char; -var quote: AnsiChar; - PBeg, PS: PUTF8Char; - internalquote: PtrInt; -begin - if P=nil then begin - result := nil; - exit; - end; - quote := P^; // " or ' - inc(P); - // compute unquoted string length - PBeg := P; - internalquote := 0; - repeat - if P^=#0 then - break; - if P^<>quote then - inc(P) else - if P[1]=quote then begin - inc(P,2); // allow double quotes inside string - inc(internalquote); - end else - break; // end quote - until false; - if P^=#0 then begin - result := nil; // end of string before end quote -> incorrect - exit; - end; - // create unquoted string - if internalquote=0 then - // no quote within - FastSetString(Value,PBeg,P-PBeg) else begin - // unescape internal quotes - SetLength(Value,P-PBeg-internalquote); - P := PBeg; - PS := Pointer(Value); - repeat - if P^=quote then - if P[1]=quote then - inc(P) else // allow double quotes inside string - break; // end quote - PS^ := P^; - inc(PByte(PS)); - inc(P); - until false; - end; - result := P+1; -end; - -function UnQuoteSQLString(const Value: RawUTF8): RawUTF8; -begin - UnQuoteSQLStringVar(pointer(Value),result); -end; - -function UnQuotedSQLSymbolName(const ExternalDBSymbol: RawUTF8): RawUTF8; -begin - if (ExternalDBSymbol<>'') and - (ExternalDBSymbol[1] in ['[','"','''','(']) then // e.g. for ZDBC's GetFields() - result := copy(ExternalDBSymbol,2,length(ExternalDBSymbol)-2) else - result := ExternalDBSymbol; -end; - -function isSelect(P: PUTF8Char; SelectClause: PRawUTF8): boolean; -var from: PUTF8Char; -begin - if P<>nil then begin - P := SQLBegin(P); - case IdemPCharArray(P, ['SELECT','EXPLAIN ','VACUUM','PRAGMA','WITH','EXECUTE']) of - 0: if P[6]<=' ' then begin - if SelectClause<>nil then begin - inc(P,7); - from := StrPosI(' FROM ',P); - if from=nil then - SelectClause^ := '' else - FastSetString(SelectClause^,P,from-P); - end; - result := true; - end else - result := false; - 1: result := true; - 2,3: result := P[6] in [#0..' ',';']; - 4: result := (P[4]<=' ') and not (StrPosI('INSERT',P+5)<>nil) or - (StrPosI('UPDATE',P+5)<>nil) or (StrPosI('DELETE',P+5)<>nil); - 5: begin // FireBird specific - P := GotoNextNotSpace(P+7); - result := IdemPChar(P,'BLOCK') and IdemPChar(GotoNextNotSpace(P+5),'RETURNS'); - end - else result := false; - end; - end else - result := true; // assume '' statement is SELECT command -end; - -function SQLBegin(P: PUTF8Char): PUTF8Char; -begin - if P<>nil then - repeat - if P^<=' ' then // ignore blanks - repeat - if P^=#0 then - break else - inc(P) - until P^>' '; - if PWord(P)^=ord('-')+ord('-')shl 8 then // SQL comments - repeat - inc(P) - until P^ in [#0,#10] - else - if PWord(P)^=ord('/')+ord('*')shl 8 then begin // C comments - inc(P); - repeat - inc(P); - if PWord(P)^=ord('*')+ord('/')shl 8 then begin - inc(P,2); - break; - end; - until P^=#0; - end - else break; - until false; - result := P; -end; - -procedure SQLAddWhereAnd(var where: RawUTF8; const condition: RawUTF8); -begin - if where='' then - where := condition else - where := where+' and '+condition; -end; - -procedure Base64MagicDecode(var ParamValue: RawUTF8); -var - tmp: RawUTF8; -begin // '\uFFF0base64encodedbinary' decode into binary (input shall have been checked) - tmp := ParamValue; - if not Base64ToBinSafe(PAnsiChar(pointer(tmp))+3,length(tmp)-3,RawByteString(ParamValue)) then - ParamValue := ''; -end; - -function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: RawByteString): boolean; -var ValueLen: integer; -begin // '\uFFF0base64encodedbinary' checked and decode into binary - if (Value=nil) or (Value[0]=#0) or (Value[1]=#0) or (Value[2]=#0) or - (PCardinal(Value)^ and $ffffff<>JSON_BASE64_MAGIC) then - result := false else begin - ValueLen := StrLen(Value)-3; - if ValueLen>0 then - result := Base64ToBinSafe(PAnsiChar(Value)+3,ValueLen,Blob) else - result := false; - end; -end; - -function Base64MagicCheckAndDecode(Value: PUTF8Char; var Blob: TSynTempBuffer): boolean; -var ValueLen: integer; -begin // '\uFFF0base64encodedbinary' checked and decode into binary - if (Value=nil) or (Value[0]=#0) or (Value[1]=#0) or (Value[2]=#0) or - (PCardinal(Value)^ and $ffffff<>JSON_BASE64_MAGIC) then - result := false else begin - ValueLen := StrLen(Value)-3; - if ValueLen>0 then - result := Base64ToBin(PAnsiChar(Value)+3,ValueLen,Blob) else - result := false; - end; -end; - -function Base64MagicCheckAndDecode(Value: PUTF8Char; ValueLen: integer; - var Blob: RawByteString): boolean; -begin // '\uFFF0base64encodedbinary' checked and decode into binary - if (ValueLen<4) or (PCardinal(Value)^ and $ffffff<>JSON_BASE64_MAGIC) then - result := false else - result := Base64ToBinSafe(PAnsiChar(Value)+3,ValueLen-3,Blob); -end; - -{$ifndef DEFINED_INT32TOUTF8} - -function Int32ToUtf8(Value: PtrInt): RawUTF8; // faster than SysUtils.IntToStr -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - if PtrUInt(Value)<=high(SmallUInt32UTF8) then - result := SmallUInt32UTF8[Value] else begin - P := StrInt32(@tmp[23],Value); - FastSetString(result,P,@tmp[23]-P); - end; -end; - -function Int64ToUtf8(Value: Int64): RawUTF8; // faster than SysUtils.IntToStr -begin - Int64ToUtf8(Value,result); -end; - -function Trim(const S: RawUTF8): RawUTF8; -var I,L: PtrInt; -begin - L := Length(S); - I := 1; - while (I<=L) and (S[I]<=' ') do inc(I); - if I>L then // void string - result := '' else - if (I=1) and (S[L]>' ') then // nothing to trim - result := S else begin - while S[L]<=' ' do dec(L); // allocated trimmed - result := Copy(S,I,L-I+1); - end; -end; - -{$endif DEFINED_INT32TOUTF8} - -{$ifndef CPU64} // already implemented by ToUTF8(Value: PtrInt) below -function ToUTF8(Value: Int64): RawUTF8; -begin - Int64ToUTF8(Value,result); -end; -{$endif CPU64} - -function ToUTF8(Value: PtrInt): RawUTF8; -begin - Int32ToUTF8(Value,result); -end; - -procedure UInt32ToUtf8(Value: PtrUInt; var result: RawUTF8); -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; -begin - if Value<=high(SmallUInt32UTF8) then - result := SmallUInt32UTF8[Value] else begin - P := StrUInt32(@tmp[23],Value); - FastSetString(result,P,@tmp[23]-P); - end; -end; - -function UInt32ToUtf8(Value: PtrUInt): RawUTF8; -begin - UInt32ToUTF8(Value,result); -end; - -{$ifndef EXTENDEDTOSHORT_USESTR} -var // standard FormatSettings: force US decimal display (with '.' for floats) - SettingsUS: TFormatSettings; -{$endif EXTENDEDTOSHORT_USESTR} - -function FloatStringNoExp(S: PAnsiChar; Precision: PtrInt): PtrInt; -var i, prec: PtrInt; - c: AnsiChar; -begin - result := ord(S[0]); - prec := result; // if no decimal - if S[1]='-' then - dec(prec); - for i := 2 to result do begin // test if scientific format -> return as this - c := S[i]; - if c='E' then // should not appear - exit else - if c='.' then - if i>=precision then begin // return huge decimal number as is - result := i-1; - exit; - end else - dec(prec); - end; - if (prec>=Precision) and (prec<>result) then begin - dec(result,prec-Precision); - if S[result+1]>'5' then begin // manual rounding - prec := result; - repeat - c := S[prec]; - if c<>'.' then - if c='9' then begin - S[prec] := '0'; - if ((prec=2) and (S[1]='-')) or (prec=1) then begin - i := result; - inc(S,prec); - repeat // inlined Move(S[prec],S[prec+1],result); - S[i] := S[i-1]; - dec(i); - until i=0; - S^ := '1'; - dec(S,prec); - break; - end; - end else - if (c>='0') and (c<='8') then begin - inc(S[prec]); - break; - end else - break; - dec(prec); - until prec=0; - end; // note: this fixes http://stackoverflow.com/questions/2335162 - end; - if S[result]='0' then - repeat - dec(result); // trunc any trimming 0 - c := S[result]; - if c<>'.' then - if c<>'0' then - break else - continue else begin - dec(result); - if (result=2) and (S[1]='-') and (S[2]='0') then begin - result := 1; - S[1] := '0'; // '-0.000' -> '0' - end; - break; // if decimal are all '0' -> return only integer part - end; - until false; -end; - -function ExtendedToShortNoExp(var S: ShortString; Value: TSynExtended; - Precision: integer): integer; -begin - {$ifdef DOUBLETOSHORT_USEGRISU} - if Precision=DOUBLE_PRECISION then - DoubleToAscii(0,Precision,Value,@S) else - {$endif DOUBLETOSHORT_USEGRISU} - str(Value:0:Precision,S); // not str(Value:0,S) -> ' 0.0E+0000' - result := FloatStringNoExp(@S,Precision); - S[0] := AnsiChar(result); -end; - -const // range when to switch into scientific notation - minimal 6 digits - SINGLE_HI: TSynExtended = 1E3; // for proper Delphi 5 compilation - SINGLE_LO: TSynExtended = 1E-3; - DOUBLE_HI: TSynExtended = 1E9; - DOUBLE_LO: TSynExtended = 1E-9; - EXT_HI: TSynExtended = 1E12; - EXT_LO: TSynExtended = 1E-12; - -function ExtendedToShort(var S: ShortString; Value: TSynExtended; - Precision: integer): integer; -{$ifdef EXTENDEDTOSHORT_USESTR} -var scientificneeded: boolean; - valueabs: TSynExtended; -begin - {$ifdef DOUBLETOSHORT_USEGRISU} - if Precision=DOUBLE_PRECISION then begin - result := DoubleToShort(S,Value); - exit; - end; - {$endif DOUBLETOSHORT_USEGRISU} - if Value=0 then begin - PWord(@s)^ := 1 + ord('0') shl 8; - result := 1; - exit; - end; - scientificneeded := false; - valueabs := abs(Value); - if Precision<=SINGLE_PRECISION then begin - if (valueabs>SINGLE_HI) or (valueabsDOUBLE_PRECISION then begin - if (valueabs>EXT_HI) or (valueabsDOUBLE_HI) or (valueabs ' 0.0E+0000' - result := FloatStringNoExp(@S,Precision); - S[0] := AnsiChar(result); - end; -end; -{$else} -{$ifdef UNICODE} -var i: PtrInt; -{$endif} -begin - // use ffGeneral: see https://synopse.info/forum/viewtopic.php?pid=442#p442 - result := FloatToText(PChar(@S[1]), Value, fvExtended, ffGeneral, - Precision, 0, SettingsUS); - {$ifdef UNICODE} // FloatToText(PWideChar) is faster than FloatToText(PAnsiChar) - for i := 1 to result do - PByteArray(@S)[i] := PWordArray(PtrInt(@S)-1)[i]; - {$endif} - S[0] := AnsiChar(result); -end; -{$endif EXTENDEDTOSHORT_USESTR} - -function FloatToShortNan(const s: shortstring): TFloatNan; -begin - case PInteger(@s)^ and $ffdfdfdf of - 3+ord('N')shl 8+ord('A')shl 16+ord('N')shl 24: - result := fnNan; - 3+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24, - 4+ord('+')shl 8+ord('I')shl 16+ord('N')shl 24: - result := fnInf; - 4+ord('-')shl 8+ord('I')shl 16+ord('N')shl 24: - result := fnNegInf; - else - result := fnNumber; - end; -end; - -function FloatToStrNan(const s: RawUTF8): TFloatNan; -begin - case length(s) of - 3: case PInteger(s)^ and $dfdfdf of - ord('N')+ord('A')shl 8+ord('N')shl 16: result := fnNan; - ord('I')+ord('N')shl 8+ord('F')shl 16: result := fnInf; - else result := fnNumber; - end; - 4: case PInteger(s)^ and $dfdfdfdf of - ord('+')+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24: result := fnInf; - ord('-')+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24: result := fnNegInf; - else result := fnNumber; - end; - else result := fnNumber; - end; -end; - -function ExtendedToStr(Value: TSynExtended; Precision: integer): RawUTF8; -begin - ExtendedToStr(Value,Precision,result); -end; - -procedure ExtendedToStr(Value: TSynExtended; Precision: integer; - var result: RawUTF8); -var tmp: ShortString; -begin - if Value=0 then - result := SmallUInt32UTF8[0] else - FastSetString(result,@tmp[1],ExtendedToShort(tmp,Value,Precision)); -end; - -function FloatToJSONNan(const s: ShortString): PShortString; -begin - case PInteger(@s)^ and $ffdfdfdf of - 3+ord('N')shl 8+ord('A')shl 16+ord('N')shl 24: - result := @JSON_NAN[fnNan]; - 3+ord('I')shl 8+ord('N')shl 16+ord('F')shl 24, - 4+ord('+')shl 8+ord('I')shl 16+ord('N')shl 24: - result := @JSON_NAN[fnInf]; - 4+ord('-')shl 8+ord('I')shl 16+ord('N')shl 24: - result := @JSON_NAN[fnNegInf]; - else - result := @s; - end; -end; - -function ExtendedToJSON(var tmp: ShortString; Value: TSynExtended; - Precision: integer; NoExp: boolean): PShortString; -begin - if Value=0 then - result := @JSON_NAN[fnNumber] else begin - if noexp then - ExtendedToShortNoExp(tmp,Value,precision) else - ExtendedToShort(tmp,Value,precision); - result := FloatToJSONNan(tmp); - end; -end; - -procedure Div100(Y: cardinal; var res: TDiv100Rec); -{$ifdef FPC} -var Y100: cardinal; -begin - Y100 := Y div 100; // FPC will use fast reciprocal - res.D := Y100; - res.M := Y-Y100*100; // avoid div twice -end; -{$else} -{$ifdef CPUX64} -asm - .noframe - mov r8, res - mov edx, Y - mov dword ptr [r8].TDiv100Rec.M,edx - mov eax, 1374389535 - mul edx - shr edx, 5 - mov dword ptr [r8].TDiv100Rec.D, edx - imul eax, edx, 100 - sub dword ptr [r8].TDiv100Rec.M, eax -end; -{$else} -asm - mov dword ptr [edx].TDiv100Rec.M, eax - mov ecx, edx - mov edx, eax - mov eax, 1374389535 - mul edx - shr edx, 5 - mov dword ptr [ecx].TDiv100Rec.D, edx - imul eax, edx, 100 - sub dword ptr [ecx].TDiv100Rec.M, eax -end; -{$endif CPUX64} -{$endif FPC} - -{$ifdef DOUBLETOSHORT_USEGRISU} - -// includes Fabian Loitsch's Grisu algorithm especially compiled for double -{$I SynDoubleToText.inc} // implements DoubleToAscii() - -function DoubleToShort(var S: ShortString; const Value: double): integer; -var valueabs: double; -begin - valueabs := abs(Value); - if (valueabs>DOUBLE_HI) or (valueabs=high(blocks) then - raise ESynException.Create('FormatUTF8: too many args (max=32)!'); - L := 0; - argN := 0; - b := @blocks; - F := pointer(Format); - repeat - if F^=#0 then - break; - if F^<>'%' then begin - FDeb := F; - repeat - inc(F); - until (F^='%') or (F^=#0); - b^.Text := FDeb; - b^.Len := F-FDeb; - b^.TempRawUTF8 := nil; - inc(L,b^.Len); - inc(b); - if F^=#0 then - break; - end; - inc(F); // jump '%' - if argN<=high(Args) then begin - inc(L,VarRecToTempUTF8(Args[argN],b^)); - if b.Len>0 then - inc(b); - inc(argN); - if F^=#0 then - break; - end else // no more available Args -> add all remaining text - if F^=#0 then - break else begin - b^.Len := length(Format)-(F-pointer(Format)); - b^.Text := F; - b^.TempRawUTF8 := nil; - inc(L,b^.Len); - inc(b); - break; - end; - until false; -end; - -procedure TFormatUTF8.Write(Dest: PUTF8Char); -var d: PTempUTF8; -begin - d := @blocks; - repeat - {$ifdef HASINLINE}MoveSmall(d^.Text,Dest{$else}MoveFast(d^.Text^,Dest^{$endif},d^.Len); - inc(Dest,d^.Len); - if d^.TempRawUTF8<>nil then - {$ifdef FPC}Finalize(RawUTF8(d^.TempRawUTF8)){$else}RawUTF8(d^.TempRawUTF8) := ''{$endif}; - inc(d); - until d=b; -end; - -function TFormatUTF8.WriteMax(Dest: PUTF8Char; Max: PtrUInt): PUTF8Char; -var d: PTempUTF8; -begin - if Max>0 then begin - inc(Max,PtrUInt(Dest)); - d := @blocks; - if Dest<>nil then - repeat - if PtrUInt(Dest)+PtrUInt(d^.Len)>Max then begin // avoid buffer overflow - {$ifdef HASINLINE}MoveSmall(d^.Text,Dest{$else}MoveFast(d^.Text^,Dest^{$endif},Max-PtrUInt(Dest)); - repeat - if d^.TempRawUTF8<>nil then - {$ifdef FPC}Finalize(RawUTF8(d^.TempRawUTF8)){$else}RawUTF8(d^.TempRawUTF8) := ''{$endif}; - inc(d); - until d=b; // avoid memory leak - result := PUTF8Char(Max); - exit; - end; - {$ifdef HASINLINE}MoveSmall(d^.Text,Dest{$else}MoveFast(d^.Text^,Dest^{$endif},d^.Len); - inc(Dest,d^.Len); - if d^.TempRawUTF8<>nil then - {$ifdef FPC}Finalize(RawUTF8(d^.TempRawUTF8)){$else}RawUTF8(d^.TempRawUTF8) := ''{$endif}; - inc(d); - until d=b; - end; - result := Dest; -end; - -procedure FormatUTF8(const Format: RawUTF8; const Args: array of const; - out result: RawUTF8); -var process: TFormatUTF8; -begin - if (Format='') or (high(Args)<0) then // no formatting needed - result := Format else - if PWord(Format)^=ord('%') then // optimize raw conversion - VarRecToUTF8(Args[0],result) else begin - process.Parse(Format,Args); - if process.L<>0 then begin - FastSetString(result,nil,process.L); - process.Write(pointer(result)); - end; - end; -end; - -procedure FormatShort(const Format: RawUTF8; const Args: array of const; - var result: shortstring); -var process: TFormatUTF8; -begin - if (Format='') or (high(Args)<0) then // no formatting needed - SetString(result,PAnsiChar(pointer(Format)),length(Format)) else begin - process.Parse(Format,Args); - result[0] := AnsiChar(process.WriteMax(@result[1],255)-@result[1]); - end; -end; - -function FormatBuffer(const Format: RawUTF8; const Args: array of const; - Dest: pointer; DestLen: PtrInt): PtrInt; -var process: TFormatUTF8; -begin - if (Dest=nil) or (DestLen<=0) then begin - result := 0; - exit; // avoid buffer overflow - end; - process.Parse(Format,Args); - result := PtrInt(process.WriteMax(Dest,DestLen))-PtrInt(Dest); -end; - -function FormatToShort(const Format: RawUTF8; const Args: array of const): shortstring; -var process: TFormatUTF8; -begin // Delphi 5 has troubles compiling overloaded FormatShort() - process.Parse(Format,Args); - result[0] := AnsiChar(process.WriteMax(@result[1],255)-@result[1]); -end; - -procedure FormatShort16(const Format: RawUTF8; const Args: array of const; - var result: TShort16); -var process: TFormatUTF8; -begin - if (Format='') or (high(Args)<0) then // no formatting needed - SetString(result,PAnsiChar(pointer(Format)),length(Format)) else begin - process.Parse(Format,Args); - result[0] := AnsiChar(process.WriteMax(@result[1],16)-@result[1]); - end; -end; - -procedure FormatString(const Format: RawUTF8; const Args: array of const; - out result: string); -var process: TFormatUTF8; - temp: TSynTempBuffer; // will avoid most memory allocations -begin - if (Format='') or (high(Args)<0) then begin // no formatting needed - UTF8DecodeToString(pointer(Format),length(Format),result); - exit; - end; - process.Parse(Format,Args); - temp.Init(process.L); - process.Write(temp.buf); - UTF8DecodeToString(temp.buf,process.L,result); - temp.Done; -end; - -function FormatString(const Format: RawUTF8; const Args: array of const): string; -begin - FormatString(Format,Args,result); -end; - -function FormatUTF8(const Format: RawUTF8; const Args, Params: array of const; JSONFormat: boolean): RawUTF8; -var i, tmpN, L, A, P, len: PtrInt; - isParam: AnsiChar; - tmp: TRawUTF8DynArray; - inlin: set of 0..255; - F,FDeb: PUTF8Char; - wasString: Boolean; -const NOTTOQUOTE: array[boolean] of set of 0..31 = ( - [vtBoolean,vtInteger,vtInt64{$ifdef FPC},vtQWord{$endif},vtCurrency,vtExtended], - [vtBoolean,vtInteger,vtInt64{$ifdef FPC},vtQWord{$endif},vtCurrency,vtExtended,vtVariant]); -label Txt; -begin - if Format='' then begin - result := ''; - exit; - end; - if (high(Args)<0) and (high(Params)<0) then begin - // no formatting to process, but may be a const -> make unique - FastSetString(result,pointer(Format),length(Format)); - exit; // e.g. _JsonFmt() will parse it in-place - end; - if high(Params)<0 then begin - FormatUTF8(Format,Args,result); // slightly faster overloaded function - exit; - end; - if Format='%' then begin - VarRecToUTF8(Args[0],result); // optimize raw conversion - exit; - end; - result := ''; - tmpN := 0; - FillCharFast(inlin,SizeOf(inlin),0); - L := 0; - A := 0; - P := 0; - F := pointer(Format); - while F^<>#0 do begin - if F^<>'%' then begin - FDeb := F; - while not (F^ in [#0,'%','?']) do inc(F); -Txt: len := F-FDeb; - if len>0 then begin - inc(L,len); - if tmpN=length(tmp) then - SetLength(tmp,tmpN+8); - FastSetString(tmp[tmpN],FDeb,len); // add inbetween text - inc(tmpN); - end; - end; - if F^=#0 then - break; - isParam := F^; - inc(F); // jump '%' or '?' - if (isParam='%') and (A<=high(Args)) then begin // handle % substitution - if tmpN=length(tmp) then - SetLength(tmp,tmpN+8); - VarRecToUTF8(Args[A],tmp[tmpN]); - inc(A); - if tmp[tmpN]<>'' then begin - inc(L,length(tmp[tmpN])); - inc(tmpN); - end; - end else - if (isParam='?') and (P<=high(Params)) then begin // handle ? substitution - if tmpN=length(tmp) then - SetLength(tmp,tmpN+8); - {$ifndef NOVARIANTS} - if JSONFormat and (Params[P].VType=vtVariant) then - VariantSaveJSON(Params[P].VVariant^,twJSONEscape,tmp[tmpN]) else - {$endif} - begin - VarRecToUTF8(Params[P],tmp[tmpN]); - wasString := not (Params[P].VType in NOTTOQUOTE[JSONFormat]); - if wasString then - if JSONFormat then - QuotedStrJSON(tmp[tmpN],tmp[tmpN]) else - tmp[tmpN] := QuotedStr(tmp[tmpN],''''); - if not JSONFormat then begin - inc(L,4); // space for :(): - include(inlin,tmpN); - end; - end; - inc(P); - inc(L,length(tmp[tmpN])); - inc(tmpN); - end else - if F^<>#0 then begin // no more available Args -> add all remaining text - FDeb := F; - repeat inc(F) until (F^=#0); - goto Txt; - end; - end; - if L=0 then - exit; - if not JSONFormat and (tmpN>SizeOf(inlin)shl 3) then - raise ESynException.CreateUTF8( - 'Too many parameters for FormatUTF8(): %>%',[tmpN,SizeOf(inlin)shl 3]); - FastSetString(result,nil,L); - F := pointer(result); - for i := 0 to tmpN-1 do - if tmp[i]<>'' then begin - if byte(i) in inlin then begin - PWord(F)^ := ord(':')+ord('(')shl 8; - inc(F,2); - end; - L := PStrLen(PtrUInt(tmp[i])-_STRLEN)^; - MoveFast(pointer(tmp[i])^,F^,L); - inc(F,L); - if byte(i) in inlin then begin - PWord(F)^ := ord(')')+ord(':')shl 8; - inc(F,2); - end; - end; -end; - -function ScanUTF8(P: PUTF8Char; PLen: PtrInt; const fmt: RawUTF8; - const values: array of pointer; ident: PRawUTF8DynArray): integer; -var - v,w: PtrInt; - F,FEnd,PEnd: PUTF8Char; - tab: PTextCharSet; -label next; -begin - result := 0; - if (fmt='') or (P=nil) or (PLen<=0) or (high(values)<0) then - exit; - if ident<>nil then - SetLength(ident^,length(values)); - F := pointer(fmt); - FEnd := F+length(fmt); - PEnd := P+PLen; - for v := 0 to high(values) do - repeat - if (P^<=' ') and (P^<>#0) then // ignore any whitespace char in text - repeat - inc(P); - if P=PEnd then - exit; - until (P^>' ') or (P^=#0); - while (F^<=' ') and (F^<>#0) do begin // ignore any whitespace char in fmt - inc(F); - if F=FEnd then - exit; - end; - if F^='%' then begin // format specifier - inc(F); - if F=FEnd then - exit; - case F^ of - 'd': PInteger(values[v])^ := GetNextItemInteger(P,#0); - 'D': PInt64(values[v])^ := GetNextItemInt64(P,#0); - 'u': PCardinal(values[v])^ := GetNextItemCardinal(P,#0); - 'U': PQword(values[v])^ := GetNextItemQword(P,#0); - 'f': unaligned(PDouble(values[v])^) := GetNextItemDouble(P,#0); - 'F': GetNextItemCurrency(P,PCurrency(values[v])^,#0); - 'x': if not GetNextItemHexDisplayToBin(P,values[v],4,#0) then - exit; - 'X': if not GetNextItemHexDisplayToBin(P,values[v],8,#0) then - exit; - 's','S': begin - w := 0; - while (P[w]>' ') and (P+w<=PEnd) do inc(w); - if F^='s' then - SetString(PShortString(values[v])^,PAnsiChar(P),w) else - FastSetString(PRawUTF8(values[v])^,P,w); - inc(P,w); - while (P^<=' ') and (P^<>#0) and (P<=PEnd) do inc(P); - end; - 'L': begin - w := 0; - tab := @TEXT_CHARS; - while (tcNot01013 in tab[P[w]]) and (P+w<=PEnd) do inc(w); - FastSetString(PRawUTF8(values[v])^,P,w); - inc(P,w); - end; - '%': goto next; - else raise ESynException.CreateUTF8('ScanUTF8: unknown ''%'' specifier [%]',[F^,fmt]); - end; - inc(result); - tab := @TEXT_CHARS; - if (tcIdentifier in tab[F[1]]) or (ident<>nil) then begin - w := 0; - repeat inc(w) until not(tcIdentifier in tab[F[w]]) or (F+w=FEnd); - if ident<>nil then - FastSetString(ident^[v],F,w); - inc(F,w); - end else - inc(F); - if (F>=FEnd) or (P>=PEnd) then - exit; - break; - end else begin -next: while (P^<>F^) and (P<=PEnd) do inc(P); - inc(F); - inc(P); - if (F>=FEnd) or (P>=PEnd) then - exit; - end; - until false; -end; - -function ScanUTF8(const text, fmt: RawUTF8; const values: array of pointer; - ident: PRawUTF8DynArray): integer; -begin - result := ScanUTF8(pointer(text),length(text),fmt,values,ident); -end; - -function RawByteStringArrayConcat(const Values: array of RawByteString): RawByteString; -var i, L: PtrInt; - P: PAnsiChar; -begin - L := 0; - for i := 0 to high(Values) do - inc(L,length(Values[i])); - SetString(Result,nil,L); - P := pointer(Result); - for i := 0 to high(Values) do begin - L := length(Values[i]); - MoveFast(pointer(Values[i])^,P^,L); - inc(P,L); - end; -end; - -procedure RawByteStringToBytes(const buf: RawByteString; out bytes: TBytes); -var L: Integer; -begin - L := Length(buf); - if L<>0 then begin - SetLength(bytes,L); - MoveFast(pointer(buf)^,pointer(bytes)^,L); - end; -end; - -procedure BytesToRawByteString(const bytes: TBytes; out buf: RawByteString); -begin - SetString(buf,PAnsiChar(pointer(bytes)),Length(bytes)); -end; - -procedure ResourceToRawByteString(const ResName: string; ResType: PChar; - out buf: RawByteString; Instance: THandle); -var HResInfo: THandle; - HGlobal: THandle; -begin - if Instance=0 then - Instance := HInstance; - HResInfo := FindResource(Instance,PChar(ResName),ResType); - if HResInfo=0 then - exit; - HGlobal := LoadResource(Instance,HResInfo); - if HGlobal<>0 then begin - SetString(buf,PAnsiChar(LockResource(HGlobal)),SizeofResource(Instance,HResInfo)); - UnlockResource(HGlobal); // only needed outside of Windows - FreeResource(HGlobal); - end; -end; - -procedure ResourceSynLZToRawByteString(const ResName: string; - out buf: RawByteString; Instance: THandle); -var HResInfo: THandle; - HGlobal: THandle; -begin - if Instance=0 then - Instance := HInstance; - HResInfo := FindResource(Instance,PChar(ResName),PChar(10)); - if HResInfo=0 then - exit; - HGlobal := LoadResource(Instance,HResInfo); - if HGlobal<>0 then // direct decompression from memory mapped .exe content - try - AlgoSynLZ.Decompress(LockResource(HGlobal),SizeofResource(Instance,HResInfo),buf); - finally - UnlockResource(HGlobal); // only needed outside of Windows - FreeResource(HGlobal); - end; -end; - -function StrLenW(S: PWideChar): PtrInt; -begin - result := 0; - if S<>nil then - while true do - if S[result+0]<>#0 then - if S[result+1]<>#0 then - if S[result+2]<>#0 then - if S[result+3]<>#0 then - inc(result,4) else begin - inc(result,3); - exit; - end else begin - inc(result,2); - exit; - end else begin - inc(result); - exit; - end else - exit; -end; - -function StrCompW(Str1, Str2: PWideChar): PtrInt; -begin - if Str1<>Str2 then - if Str1<>nil then - if Str2<>nil then begin - if Str1^=Str2^ then - repeat - if (Str1^=#0) or (Str2^=#0) then break; - inc(Str1); - inc(Str2); - until Str1^<>Str2^; - result := PWord(Str1)^-PWord(Str2)^; - exit; - end else - result := 1 else // Str2='' - result := -1 else // Str1='' - result := 0; // Str1=Str2 -end; - -{$ifdef PUREPASCAL} - -function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean; -// if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper) -var table: PNormTable; - u: AnsiChar; -begin - result := false; - if p=nil then - exit; - if up<>nil then begin - dec(PtrUInt(p),PtrUInt(up)); - table := @NormToUpperAnsi7; - repeat - u := up^; - if u=#0 then - break; - if u<>table^[up[PtrUInt(p)]] then - exit; - inc(up); - until false; - end; - result := true; -end; - -function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt; -begin - result := 0; - dec(Count,4); - if P<>nil then begin - repeat - if result>Count then - break; - if P^[result]<>Value then - if P^[result+1]<>Value then - if P^[result+2]<>Value then - if P^[result+3]<>Value then begin - inc(result,4); - continue; - end else - inc(result,3) else - inc(result,2) else - inc(result); - exit; - until false; - inc(Count,4); - repeat - if result>=Count then - break; - if P^[result]=Value then - exit else - inc(result); - until false; - end; - result := -1; -end; - -function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal; -begin - result := nil; - if P=nil then - exit; - Count := PtrInt(@P[Count-4]); - repeat - if PtrUInt(P)>PtrUInt(Count) then - break; - if P^[0]<>Value then - if P^[1]<>Value then - if P^[2]<>Value then - if P^[3]<>Value then begin - P := @P[4]; - continue; - end else - result := @P[3] else - result := @P[2] else - result := @P[1] else - result := pointer(P); - exit; - until false; - inc(Count,4*SizeOf(Value)); - result := pointer(P); - repeat - if PtrUInt(result)>=PtrUInt(Count) then - break; - if result^=Value then - exit else - inc(result); - until false; - result := nil; -end; - -function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean; -begin - if P<>nil then begin - result := true; - Count := PtrInt(@P[Count-4]); - repeat - if PtrUInt(P)>PtrUInt(Count) then - break; - if (P^[0]=Value) or (P^[1]=Value) or (P^[2]=Value) or (P^[3]=Value) then - exit; - P := @P[4]; - until false; - inc(Count,4*SizeOf(Value)); - repeat - if PtrUInt(P)>=PtrUInt(Count) then - break; - if P^[0]=Value then - exit else - P := @P[1]; - until false; - end; - result := false; -end; - -function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char; -var c: cardinal; -begin // FPC is efficient at compiling this code - result := nil; - if Str<>nil then begin - repeat - c := PCardinal(str)^; - if ToByte(c)=0 then - exit else - if ToByte(c)=byte(Chr) then - break; - c := c shr 8; - inc(Str); - if ToByte(c)=0 then - exit else - if ToByte(c)=byte(Chr) then - break; - c := c shr 8; - inc(Str); - if ToByte(c)=0 then - exit else - if ToByte(c)=byte(Chr) then - break; - c := c shr 8; - inc(Str); - if ToByte(c)=0 then - exit else - if ToByte(c)=byte(Chr) then - break; - inc(Str); - until false; - result := Str; - end; -end; - -function CompareMem(P1, P2: Pointer; Length: PtrInt): Boolean; -label zero; -begin // this code compiles well under FPC and Delphi on both 32-bit and 64-bit - Length := PtrInt(@PAnsiChar(P1)[Length-SizeOf(PtrInt)*2]); // = 2*PtrInt end - if Length>=PtrInt(PtrUInt(P1)) then begin - if PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^ then // compare first PtrInt bytes - goto zero; - inc(PPtrInt(P1)); - inc(PPtrInt(P2)); - dec(PtrInt(P2),PtrInt(PtrUInt(P1))); - PtrInt(PtrUInt(P1)) := PtrInt(PtrUInt(P1)) and -SizeOf(PtrInt); // align - inc(PtrInt(P2),PtrInt(PtrUInt(P1))); - if Length>=PtrInt(PtrUInt(P1)) then - repeat // compare 4 aligned PtrInt per loop - if (PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^) or (PPtrIntArray(P1)[1]<>PPtrIntArray(P2)[1]) then - goto zero; - inc(PByte(P1),SizeOf(PtrInt)*2); - inc(PByte(P2),SizeOf(PtrInt)*2); - if LengthPPtrInt(P2)^) or (PPtrIntArray(P1)[1]<>PPtrIntArray(P2)[1]) then - goto zero; - inc(PByte(P1),SizeOf(PtrInt)*2); - inc(PByte(P2),SizeOf(PtrInt)*2); - until Length=SizeOf(PtrInt) then begin - if PPtrInt(PtrUInt(P1))^<>PPtrInt(P2)^ then - goto zero; - inc(PPtrInt(P1)); - inc(PPtrInt(P2)); - dec(Length,SizeOf(PtrInt)); - end; - {$ifdef CPU64} - if Length>=4 then begin - if PCardinal(P1)^<>PCardinal(P2)^ then - goto zero; - inc(PCardinal(P1)); - inc(PCardinal(P2)); - dec(Length,4); - end; - {$endif} - if Length>=2 then begin - if PWord(P1)^<>PWord(P2)^ then - goto zero; - inc(PWord(P1)); - inc(PWord(P2)); - dec(Length,2); - end; - if Length>=1 then - if PByte(P1)^<>PByte(P2)^ then - goto zero; - result := true; - exit; -zero: - result := false; -end; - -{$ifdef HASINLINE} // to use directly the SubStr/S arguments registers -function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt): PtrInt; -begin - result := PosExPas(pointer(SubStr),pointer(S),Offset); -end; -{$endif HASINLINE} - -// from Aleksandr Sharahov's PosEx_Sha_Pas_2() - refactored for cross-platform -function PosExPas(pSub, p: PUTF8Char; Offset: PtrUInt): PtrInt; -var len, lenSub: PtrInt; - ch: AnsiChar; - pStart, pStop: PUTF8Char; -label Loop2, Loop6, TestT, Test0, Test1, Test2, Test3, Test4, - AfterTestT, AfterTest0, Ret, Exit; -begin - result := 0; - if (p=nil) or (pSub=nil) or (PtrInt(Offset)<=0) then - goto Exit; - len := PStrLen(p-_STRLEN)^; - lenSub := PStrLen(pSub-_STRLEN)^-1; - if (len=pStop then goto Exit; - goto Loop2; -Test4: dec(p,2); -Test2: dec(p,2); - goto Test0; -Test3: dec(p,2); -Test1: dec(p,2); -TestT: len := lenSub; - if lenSub<>0 then - repeat - if (psub[len]<>p[len+1]) or (psub[len+1]<>p[len+2]) then - goto AfterTestT; - inc(len,2); - until len>=0; - inc(p,2); - if p<=pStop then goto Ret; - goto Exit; -Test0: len := lenSub; - if lenSub<>0 then - repeat - if (psub[len]<>p[len]) or (psub[len+1]<>p[len+1]) then - goto AfterTest0; - inc(len,2); - until len>=0; - inc(p); -Ret: - result := p-pStart; -Exit: -end; - -function IdemPropNameU(const P1,P2: RawUTF8): boolean; -var L: PtrInt; -begin - L := length(P1); - if length(P2)=L then - result := IdemPropNameUSameLen(pointer(P1),pointer(P2),L) else - result := false; -end; - -function StrIComp(Str1, Str2: pointer): PtrInt; -var C1,C2: byte; // integer/PtrInt are actually slower on FPC - lookupper: PByteArray; // better x86-64 / PIC asm generation -begin - result := PtrInt(PtrUInt(Str2))-PtrInt(PtrUInt(Str1)); - if result<>0 then - if Str1<>nil then - if Str2<>nil then begin - lookupper := @NormToUpperAnsi7Byte; - repeat - C1 := lookupper[PByteArray(Str1)[0]]; - C2 := lookupper[PByteArray(Str1)[result]]; - inc(PByte(Str1)); - until (C1=0) or (C1<>C2); - result := C1-C2; - end else - result := 1 else // Str2='' - result := -1; // Str1='' -end; - -function StrLenPas(S: pointer): PtrInt; -label - _0, _1, _2, _3; // ugly but faster -begin - result := PtrUInt(S); - if S<>nil then begin - while true do - if PAnsiChar(result)[0]=#0 then - goto _0 - else if PAnsiChar(result)[1]=#0 then - goto _1 - else if PAnsiChar(result)[2]=#0 then - goto _2 - else if PAnsiChar(result)[3]=#0 then - goto _3 - else - inc(result, 4); -_3: inc(result); -_2: inc(result); -_1: inc(result); -_0: dec(result,PtrUInt(S)); // return length - end; -end; - -function StrCompFast(Str1, Str2: pointer): PtrInt; -var c: byte; -begin - if Str1<>Str2 then - if Str1<>nil then - if Str2<>nil then begin - c := PByte(Str1)^; - if c=PByte(Str2)^ then - repeat - if c=0 then break; - inc(PByte(Str1)); - inc(PByte(Str2)); - c := PByte(Str1)^; - until c<>PByte(Str2)^; - result := c-PByte(Str2)^; - exit; - end else - result := 1 else // Str2='' - result := -1 else // Str1='' - result := 0; // Str1=Str2 -end; - -procedure YearToPChar(Y: PtrUInt; P: PUTF8Char); -var d100: PtrUInt; - tab: PWordArray; -begin - tab := @TwoDigitLookupW; - d100 := Y div 100; - PWordArray(P)[0] := tab[d100]; - PWordArray(P)[1] := tab[Y-(d100*100)]; -end; - -procedure YearToPChar2(tab: PWordArray; Y: PtrUInt; P: PUTF8Char); {$ifdef HASINLINE}inline;{$endif} -var d100: PtrUInt; -begin - d100 := Y div 100; - PWordArray(P)[0] := tab[d100]; - PWordArray(P)[1] := tab[Y-(d100*100)]; -end; - -function Iso8601ToTimeLog(const S: RawByteString): TTimeLog; -begin - result := Iso8601ToTimeLogPUTF8Char(pointer(S),length(S)); -end; - -function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; -var s: PAnsiChar; - c: byte; - lookupper: PByteArray; // better x86-64 / PIC asm generation -begin - s := pointer(source); - if s<>nil then begin - lookupper := @NormToUpperAnsi7Byte; - repeat - c := lookupper[ord(s^)]; - if c=0 then - break; - dest^ := AnsiChar(c); - inc(s); - inc(dest); - until false; - end; - result := dest; -end; - -function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar; -var s: PByteArray; - i: PtrInt; - lookupper: PByteArray; // better x86-64 / PIC asm generation -begin - s := @source; - lookupper := @NormToUpperAnsi7Byte; - for i := 1 to s[0] do begin - dest^ := AnsiChar(lookupper[s[i]]); - inc(dest); - end; - result := dest; -end; - -function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean; -begin - if source=nil then - result := false else begin - result := IdemPChar(source,searchUp); - source := GotoNextLine(source); - end; -end; - -function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; -var i: PtrInt; -begin - if buf<>nil then - for i := 0 to len-1 do - crc := (crc xor ord(buf[i]))*16777619; - result := crc; -end; - -function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; -var i: PtrInt; -begin - if buf<>nil then - for i := 0 to len-1 do begin - crc := crc*31; - inc(crc,ord(buf[i])); - end; - result := crc; -end; - -procedure crcblockNoSSE42(crc128, data128: PBlock128); -var c: cardinal; - tab: PCrc32tab; -begin - tab := @crc32ctab; - c := crc128^[0] xor data128^[0]; - crc128^[0] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; - c := crc128^[1] xor data128^[1]; - crc128^[1] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; - c := crc128^[2] xor data128^[2]; - crc128^[2] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; - c := crc128^[3] xor data128^[3]; - crc128^[3] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; -end; - -function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; -{$ifdef ABSOLUTEPASCALORNOTINTEL} -var tab: PCrc32tab; -begin // on ARM, we use slicing-by-4 to avoid polluting smaller L1 cache - tab := @crc32ctab; - result := not crc; - if (buf<>nil) and (len>0) then begin - repeat - if PtrUInt(buf) and 3=0 then // align to 4 bytes boundary - break; - result := tab[0,ToByte(result xor ord(buf^))] xor (result shr 8); - dec(len); - inc(buf); - until len=0; - if len>=4 then - repeat - result := result xor PCardinal(buf)^; - inc(buf,4); - dec(len,4); - result := tab[3,ToByte(result)] xor - tab[2,ToByte(result shr 8)] xor - tab[1,ToByte(result shr 16)] xor - tab[0,ToByte(result shr 24)]; - until len<4; - while len>0 do begin - result := tab[0,ToByte(result xor ord(buf^))] xor (result shr 8); - dec(len); - inc(buf); - end; - end; - result := not result; -end; -{$else} -{$ifdef FPC} nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - {$ifndef win64} - mov r8d, len - {$endif} - mov eax, crc - xor ecx, ecx - test buf, buf // buf=rdx/rsi len=r8 - jz @z - neg r8 - jz @z - not eax - lea r9, [rip + crc32ctab] - cmp r8, -8 - jb @head -@sml: mov cl, byte ptr[buf] - inc buf - xor cl, al - shr eax, 8 - xor eax, dword ptr[rcx * 4 + r9] - inc r8 - jnz @sml -@0: not eax -@z: ret -@head: test buf, 7 - jz @align - mov cl, byte ptr[buf] - inc buf - xor cl, al - shr eax, 8 - xor eax, dword ptr[rcx * 4 + r9] - inc r8 - jnz @head - not eax - ret -@align: sub buf, r8 - add r8, 8 - jg @done - xor r11, r11 -@by8: mov r10d, eax - mov rcx, qword ptr[buf + r8 - 8] - xor r10d, ecx - shr rcx, 32 - mov r11b, cl - shr ecx, 8 - mov eax, dword ptr[r11 * 4 + r9 + 1024 * 3] - mov r11b, cl - shr ecx, 8 - xor eax, dword ptr[r11 * 4 + r9 + 1024 * 2] - mov r11b, cl - shr ecx, 8 - xor eax, dword ptr[r11 * 4 + r9 + 1024 * 1] - mov r11b, cl - xor eax, dword ptr[r11 * 4 + r9 + 1024 * 0] - mov ecx, r10d - mov r11b, cl - shr ecx, 8 - xor eax, dword ptr[r11 * 4 + r9 + 1024 * 7] - mov r11b, cl - shr ecx, 8 - xor eax, dword ptr[r11 * 4 + r9 + 1024 * 6] - mov r11b, cl - shr ecx, 8 - xor eax, dword ptr[r11 * 4 + r9 + 1024 * 5] - mov r11b, cl - xor eax, dword ptr[r11 * 4 + r9 + 1024 * 4] - add r8, 8 - jle @by8 -@done: sub r8, 8 - jge @e -@tail: mov cl, byte ptr[buf + r8] - xor cl, al - shr eax, 8 - xor eax, dword ptr[rcx * 4 + r9] - inc r8 - jnz @tail -@e: not eax -end; -{$endif ABSOLUTEPASCALORNOTINTEL} - -function ToVarInt32(Value: PtrInt; Dest: PByte): PByte; -begin // 0=0,1=1,2=-1,3=2,4=-2... - if Value<0 then - // -1->2, -2->4.. - Value := (-Value) shl 1 else - if Value>0 then - // 1->1, 2->3.. - Value := (Value shl 1)-1; - // 0->0 - result := ToVarUInt32(Value,Dest); -end; - -function ToVarUInt32(Value: cardinal; Dest: PByte): PByte; -label _1,_2,_3; // ugly but fast -begin - if Value>$7f then begin - if Value<$80 shl 7 then goto _1 else - if Value<$80 shl 14 then goto _2 else - if Value<$80 shl 21 then goto _3; - Dest^ := (Value and $7F) or $80; - Value := Value shr 7; - inc(Dest); -_3: Dest^ := (Value and $7F) or $80; - Value := Value shr 7; - inc(Dest); -_2: Dest^ := (Value and $7F) or $80; - Value := Value shr 7; - inc(Dest); -_1: Dest^ := (Value and $7F) or $80; - Value := Value shr 7; - inc(Dest); - end; - Dest^ := Value; - inc(Dest); - result := Dest; -end; - -{$ifdef CPUX64} // very efficient branchless asm - rcx/rdi=A rdx/rsi=B -function SortDynArrayInteger(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - mov r8d, dword ptr[A] - mov edx, dword ptr[B] - xor eax, eax - xor ecx, ecx - cmp r8d, edx - setl cl - setg al - sub eax, ecx -end; -function SortDynArrayCardinal(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - mov ecx, dword ptr[A] - mov edx, dword ptr[B] - xor eax, eax - cmp ecx, edx - seta al - sbb eax, 0 -end; -function SortDynArrayInt64(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - mov r8, qword ptr[A] - mov rdx, qword ptr[B] - xor eax, eax - xor ecx, ecx - cmp r8, rdx - setl cl - setg al - sub eax, ecx -end; -function SortDynArrayQWord(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - mov rcx, qword ptr[A] - mov rdx, qword ptr[B] - xor eax, eax - cmp rcx, rdx - seta al - sbb eax, 0 -end; -function SortDynArrayPointer(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - mov rcx, qword ptr[A] - mov rdx, qword ptr[B] - xor eax, eax - cmp rcx, rdx - seta al - sbb eax, 0 -end; -function SortDynArrayDouble(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - movsd xmm0, qword ptr[A] - movsd xmm1, qword ptr[B] - xor eax, eax - xor edx, edx - comisd xmm0, xmm1 - seta al - setb dl - sub eax, edx -end; -function SortDynArraySingle(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - movss xmm0, dword ptr[A] - movss xmm1, dword ptr[B] - xor eax, eax - xor edx, edx - comiss xmm0, xmm1 - seta al - setb dl - sub eax, edx -end; -function SortDynArrayAnsiString(const A,B): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - mov rcx, qword ptr[A] - mov rdx, qword ptr[B] - cmp rcx, rdx // A=B (happens with string refcounting) - je @0 - test rcx, rdx // A^ or B^ may be nil i.e. '' - jz @n1 -@s: mov al, byte ptr[rcx] // by char comparison - cmp al, byte ptr[rdx] - jne @ne - inc rcx - inc rdx - test al, al - jnz @s -@0: xor eax, eax - ret -@n1: test rcx, rcx - jz @less // A='' -> -1 - test rdx, rdx - jnz @s // B='' -> 1 -@1: mov eax, 1 - ret -@ne: jnc @1 -@less: mov eax, -1 -end; // note: SSE4.2 read up to 16 bytes after buffer, this version won't -{$else} -function SortDynArrayInteger(const A,B): integer; -begin - result := ord(integer(A)>integer(B))-ord(integer(A)cardinal(B))-ord(cardinal(A)Int64(B))-ord(Int64(A)QWord(B))-ord(QWord(A)PtrUInt(B))-ord(PtrUInt(A)double(B))-ord(double(A)single(B))-ord(single(A)B)-ord(Ap2 then - if p1<>nil then - if p2<>nil then begin - l1 := PStrLen(PtrUInt(p1)-_STRLEN)^; - l2 := PStrLen(PtrUInt(p2)-_STRLEN)^; - l := l1; - if l20 then - exit; - inc(i); - until i>=l; - result := l1-l2; - end else - result := 1 else // p2='' - result := -1 else // p1='' - result := 0; // p1=p2 -end; - -function SortDynArrayPUTF8Char(const A,B): integer; -begin - result := StrCompFast(pointer(A),pointer(B)); -end; - -{$else PUREPASCAL} - -function IdemPChar(p: PUTF8Char; up: PAnsiChar): boolean; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm - test eax, eax - jz @e // P=nil -> false - test edx, edx - push ebx - jz @t // up=nil -> true - xor ebx, ebx -@1: mov ecx, [edx] // optimized for DWORD aligned read up^ - test cl, cl - mov bl, [eax] - jz @t // up^[0]=#0 -> OK - cmp cl, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[0]] - jne @f - mov bl, [eax + 1] - test ch, ch - jz @t // up^[1]=#0 -> OK - cmp ch, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[1]] - jne @f - shr ecx, 16 // cl=up^[2] ch=up^[3] - mov bl, [eax + 2] - test cl, cl - jz @t // up^[2]=#0 -> OK - cmp cl, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[2]] - jne @f - mov bl, [eax + 3] - add eax, 4 - add edx, 4 - test ch, ch - jz @t // up^[3]=#0 -> OK - cmp ch, byte ptr[ebx + NormToUpperAnsi7] // NormToUpperAnsi7[p^[3]] - je @1 -@f: pop ebx // NormToUpperAnsi7[p^]<>up^ -> FALSE -@e: xor eax, eax - ret -@t: pop ebx // up^=#0 -> TRUE - mov al, 1 -end; - -function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm - push eax - call IntegerScan - pop edx - test eax, eax - jnz @e - dec eax // returns -1 - ret -@e: sub eax, edx - shr eax, 2 -end; - -function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=P, edx=Count, Value=ecx - test eax, eax - jz @ok0 // avoid GPF - cmp edx, 8 - jb @s2 - nop - nop - nop // @s1 loop align -@s1: sub edx, 8 - cmp [eax], ecx - je @ok0 - cmp [eax + 4], ecx - je @ok4 - cmp [eax + 8], ecx - je @ok8 - cmp [eax + 12], ecx - je @ok12 - cmp [eax + 16], ecx - je @ok16 - cmp [eax + 20], ecx - je @ok20 - cmp [eax + 24], ecx - je @ok24 - cmp [eax + 28], ecx - je @ok28 - add eax, 32 - cmp edx, 8 - jae @s1 -@s2: test edx, edx - jz @z - cmp [eax], ecx - je @ok0 - dec edx - jz @z - cmp [eax + 4], ecx - je @ok4 - dec edx - jz @z - cmp [eax + 8], ecx - je @ok8 - dec edx - jz @z - cmp [eax + 12], ecx - je @ok12 - dec edx - jz @z - cmp [eax + 16], ecx - je @ok16 - dec edx - jz @z - cmp [eax + 20], ecx - je @ok20 - dec edx - jz @z - cmp [eax + 24], ecx - je @ok24 -@z: xor eax, eax // return nil if not found - ret -@ok0: rep ret -@ok28: add eax, 28 - ret -@ok24: add eax, 24 - ret -@ok20: add eax, 20 - ret -@ok16: add eax, 16 - ret -@ok12: add eax, 12 - ret -@ok8: add eax, 8 - ret -@ok4: add eax, 4 -end; - -function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=P, edx=Count, Value=ecx - test eax, eax - jz @z // avoid GPF - cmp edx, 8 - jae @s1 - jmp dword ptr[edx * 4 + @Table] -@Table: dd @z, @1, @2, @3, @4, @5, @6, @7 -@s1: // fast search by 8 integers (pipelined instructions) - sub edx, 8 - cmp [eax], ecx - je @ok - cmp [eax + 4], ecx - je @ok - cmp [eax + 8], ecx - je @ok - cmp [eax + 12], ecx - je @ok - cmp [eax + 16], ecx - je @ok - cmp [eax + 20], ecx - je @ok - cmp [eax + 24], ecx - je @ok - cmp [eax + 28], ecx - je @ok - add eax, 32 - cmp edx, 8 - jae @s1 - jmp dword ptr[edx * 4 + @Table] -@7: cmp [eax + 24], ecx - je @ok -@6: cmp [eax + 20], ecx - je @ok -@5: cmp [eax + 16], ecx - je @ok -@4: cmp [eax + 12], ecx - je @ok -@3: cmp [eax + 8], ecx - je @ok -@2: cmp [eax + 4], ecx - je @ok -@1: cmp [eax], ecx - je @ok -@z: xor eax, eax - ret -@ok: mov al, 1 -end; - -function PosChar(Str: PUTF8Char; Chr: AnsiChar): PUTF8Char; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // faster version by AB - eax=Str dl=Chr - test eax, eax - jz @z -@1: mov ecx, dword ptr [eax] - cmp cl, dl - je @z - inc eax - test cl, cl - jz @e - cmp ch, dl - je @z - inc eax - test ch, ch - jz @e - shr ecx, 16 - cmp cl, dl - je @z - inc eax - test cl, cl - jz @e - cmp ch, dl - je @z - inc eax - test ch, ch - jnz @1 -@e: xor eax, eax - ret -@z: db $f3 // rep ret -end; - -function CompareMem(P1, P2: Pointer; Length: PtrInt): Boolean; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=P1 edx=P2 ecx=Length - cmp eax, edx - je @0 // P1=P2 - sub ecx, 8 - jl @small - push ebx - mov ebx, [eax] // Compare First 4 Bytes - cmp ebx, [edx] - jne @setbig - lea ebx, [eax + ecx] // Compare Last 8 Bytes - add edx, ecx - mov eax, [ebx] - cmp eax, [edx] - jne @setbig - mov eax, [ebx + 4] - cmp eax, [edx + 4] - jne @setbig - sub ecx, 4 - jle @true // All Bytes already Compared - neg ecx // ecx=-(Length-12) - add ecx, ebx // DWORD Align Reads - and ecx, -4 - sub ecx, ebx -@loop: mov eax, [ebx + ecx] // Compare 8 Bytes per Loop - cmp eax, [edx + ecx] - jne @setbig - mov eax, [ebx + ecx + 4] - cmp eax, [edx + ecx + 4] - jne @setbig - add ecx, 8 - jl @loop -@true: pop ebx -@0: mov al, 1 - ret -@setbig:pop ebx - setz al - ret -@small: add ecx, 8 // ecx=0..7 - jle @0 // Length <= 0 - neg ecx // ecx=-1..-7 - lea ecx, [@1 + ecx * 8 + 8] // each @#: block below = 8 bytes - jmp ecx -@7: mov cl, [eax + 6] - cmp cl, [edx + 6] - jne @setsml -@6: mov ch, [eax + 5] - cmp ch, [edx + 5] - jne @setsml -@5: mov cl, [eax + 4] - cmp cl, [edx + 4] - jne @setsml -@4: mov ch, [eax + 3] - cmp ch, [edx + 3] - jne @setsml -@3: mov cl, [eax + 2] - cmp cl, [edx + 2] - jne @setsml -@2: mov ch, [eax + 1] - cmp ch, [edx + 1] - jne @setsml -@1: mov al, [eax] - cmp al, [edx] -@setsml:setz al -end; - -function PosEx(const SubStr, S: RawUTF8; Offset: PtrUInt): integer; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=SubStr, edx=S, ecx=Offset - push ebx - push esi - push edx - test eax, eax - jz @notfnd // exit if SubStr='' - test edx, edx - jz @notfnd // exit if S='' - mov esi, ecx - mov ecx, [edx - 4] // length(S) - mov ebx, [eax - 4] // length(SubStr) - add ecx, edx - sub ecx, ebx // ecx = max start pos for full match - lea edx, [edx + esi - 1] // edx = start position - cmp edx, ecx - jg @notfnd // startpos > max start pos - cmp ebx, 1 - jle @onec // optimized loop for length(SubStr)<=1 - push edi - push ebp - lea edi, [ebx - 2] // edi = length(SubStr)-2 - mov esi, eax // esi = SubStr - movzx ebx, byte ptr[eax] // bl = search character - nop; nop -@l: cmp bl, [edx] // compare 2 characters per @l - je @c1fnd -@notc1: cmp bl, [edx + 1] - je @c2fnd -@notc2: add edx, 2 - cmp edx, ecx // next start position <= max start position - jle @l - pop ebp - pop edi -@notfnd:xor eax, eax // returns 0 if not fnd - pop edx - pop esi - pop ebx - ret -@c1fnd: mov ebp, edi // ebp = length(SubStr)-2 -@c1l: movzx eax, word ptr[esi + ebp] - cmp ax, [edx + ebp] // compare 2 chars per @c1l (may include #0) - jne @notc1 - sub ebp, 2 - jnc @c1l - pop ebp - pop edi - jmp @setres -@c2fnd: mov ebp, edi // ebp = length(SubStr)-2 -@c2l: movzx eax, word ptr[esi + ebp] - cmp ax, [edx + ebp + 1] // compare 2 chars per @c2l (may include #0) - jne @notc2 - sub ebp, 2 - jnc @c2l - pop ebp - pop edi - jmp @chkres -@onec: jl @notfnd // needed for zero-length non-nil strings - movzx eax, byte ptr[eax] // search character -@charl: cmp al, [edx] - je @setres - cmp al, [edx + 1] - je @chkres - add edx, 2 - cmp edx, ecx - jle @charl - jmp @notfnd -@chkres:cmp edx, ecx // check within ansistring - jge @notfnd - add edx, 1 -@setres:pop ecx // ecx = S - pop esi - pop ebx - neg ecx - lea eax, [edx + ecx + 1] -end; - -function IdemPropNameU(const P1,P2: RawUTF8): boolean; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=p1, edx=p2 - cmp eax, edx - je @out1 - test eax, edx - jz @maybenil -@notnil:mov ecx, [eax - 4] // compare lengths - cmp ecx, [edx - 4] - jne @out1 - push ebx - lea edx, [edx + ecx - 4] // may include the length for shortest strings - lea ebx, [eax + ecx - 4] - neg ecx - mov eax, [ebx] // compare last 4 chars - xor eax, [edx] - and eax, $dfdfdfdf // case insensitive - jne @out2 -@by4: add ecx, 4 - jns @match - mov eax, [ebx + ecx] - xor eax, [edx + ecx] - and eax, $dfdfdfdf // case insensitive - je @by4 -@out2: pop ebx -@out1: setz al - ret -@match: mov al, 1 - pop ebx - ret -@maybenil: // here we know that eax<>edx - test eax, eax - jz @nil0 // eax=nil and eax<>edx -> edx<>nil -> false - test edx, edx - jnz @notnil - mov al, dl // eax<>nil and edx=nil -> false -@nil0: -end; - -function IdemPropNameUSameLen(P1,P2: PUTF8Char; P1P2Len: PtrInt): boolean; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=p1, edx=p2, ecx=P1P2Len - cmp eax, edx - je @out2 - cmp ecx, 4 - jbe @sml - push ebx - lea edx, [edx + ecx - 4] - lea ebx, [eax + ecx - 4] - neg ecx - mov eax, [ebx] // compare last 4 chars - xor eax, [edx] - and eax, $dfdfdfdf // case insensitive - jne @out1 -@by4: add ecx, 4 - jns @match - mov eax, [ebx + ecx] - xor eax, [edx + ecx] - and eax, $dfdfdfdf // case insensitive - je @by4 -@out1: pop ebx -@out2: setz al - ret - nop - nop -@match: pop ebx - mov al, 1 - ret -@mask: dd 0, $df, $dfdf, $dfdfdf, $dfdfdfdf // compare 1..4 chars -@sml: test ecx, ecx - jz @smlo // p1p2len=0 - mov eax, [eax] - xor eax, [edx] - and eax, dword ptr[@mask + ecx * 4] -@smlo: setz al -end; - -function StrIComp(Str1, Str2: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // faster version by AB, from Agner Fog's original - mov ecx, eax - test eax, edx - jz @n -@ok: sub edx, eax - jz @0 -@10: mov al, [ecx] - cmp al, [ecx + edx] - jne @20 - inc ecx - test al, al - jnz @10 // continue with next byte - // terminating zero found. Strings are equal -@0: xor eax, eax - ret -@20: // bytes are different. check case - xor al, 20H // toggle case - cmp al, [ecx + edx] - jne @30 - // possibly differing only by case. Check if a-z - or al, 20H // upper case - sub al, 'a' - cmp al, 'z' - 'a' - ja @30 // not a-z - // a-z and differing only by case - inc ecx - jmp @10 // continue with next byte -@30: // bytes are different,even after changing case - movzx eax, byte[ecx] // get original value again - sub eax, 'A' - cmp eax, 'Z' - 'A' - ja @40 - add eax, 20H -@40: movzx edx, byte[ecx + edx] - sub edx, 'A' - cmp edx, 'Z' - 'A' - ja @50 - add edx, 20H -@50: sub eax, edx // subtract to get result - ret -@n: cmp eax, edx - je @0 - test eax, eax // Str1='' ? - jz @max - test edx, edx // Str2='' ? - jnz @ok - mov eax, 1 - ret -@max: dec eax -end; - -function StrLenPas(S: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // slower than x86/SSE* StrLen(), but won't read any byte beyond the string - mov edx, eax - test eax, eax - jz @0 - xor eax, eax -@s: cmp byte ptr[eax + edx + 0], 0 - je @0 - cmp byte ptr[eax + edx + 1], 0 - je @1 - cmp byte ptr[eax + edx + 2], 0 - je @2 - cmp byte ptr[eax + edx + 3], 0 - je @3 - add eax, 4 - jmp @s -@1: inc eax - ret -@0: rep ret -@2: add eax, 2 - ret -@3: add eax, 3 -end; - -function StrCompFast(Str1, Str2: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // no branch taken in case of not equal first char - cmp eax, edx - je @zero // same string or both nil - test eax, edx - jz @maynil -@1: mov cl, [eax] - mov ch, [edx] - inc eax - inc edx - test cl, cl - jz @exit - cmp cl, ch - je @1 -@exit: movzx eax, cl - movzx edx, ch - sub eax, edx - ret -@maynil:test eax, eax // Str1='' ? - jz @max - test edx, edx // Str2='' ? - jnz @1 - mov eax, 1 - ret -@max: dec eax - ret -@zero: xor eax, eax -end; - -const - EQUAL_EACH = 8; // see https://msdn.microsoft.com/en-us/library/bb531463 - NEGATIVE_POLARITY = 16; - -function StrCompSSE42(Str1, Str2: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // warning: may read up to 15 bytes beyond the string itself - test eax, edx - jz @n -@ok: sub eax, edx - {$ifdef HASAESNI} - movups xmm0, dqword [edx] - pcmpistri xmm0, dqword [edx + eax], EQUAL_EACH + NEGATIVE_POLARITY // result in ecx - {$else} - db $F3,$0F,$6F,$02 - db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY - {$endif} - ja @1 - jc @2 - xor eax, eax - ret -@1: add edx, 16 - {$ifdef HASAESNI} - movups xmm0, dqword [edx] - pcmpistri xmm0, dqword [edx + eax], EQUAL_EACH + NEGATIVE_POLARITY // result in ecx - {$else} - db $F3,$0F,$6F,$02 - db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY - {$endif} - ja @1 - jc @2 -@0: xor eax, eax // Str1=Str2 - ret -@n: cmp eax, edx - je @0 - test eax, eax // Str1='' ? - jz @max - test edx, edx // Str2='' ? - jnz @ok - mov eax, 1 - ret -@max: dec eax - ret -@2: add eax, edx - movzx eax, byte ptr [eax+ecx] - movzx edx, byte ptr [edx+ecx] - sub eax, edx -end; - -function SortDynArrayAnsiStringSSE42(const A,B): integer; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // warning: may read up to 15 bytes beyond the string itself - mov eax, [eax] - mov edx, [edx] - test eax, edx - jz @n -@ok: sub eax, edx - jz @0 - {$ifdef HASAESNI} - movups xmm0, dqword [edx] // result in ecx - pcmpistri xmm0, dqword [edx+eax], EQUAL_EACH + NEGATIVE_POLARITY - {$else} - db $F3,$0F,$6F,$02 - db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY - {$endif} - ja @1 - jc @2 - xor eax, eax - ret -@1: add edx, 16 - {$ifdef HASAESNI} - movups xmm0, dqword [edx] // result in ecx - pcmpistri xmm0, dqword [edx+eax], EQUAL_EACH + NEGATIVE_POLARITY - {$else} - db $F3,$0F,$6F,$02 - db $66,$0F,$3A,$63,$04,$10,EQUAL_EACH+NEGATIVE_POLARITY - {$endif} - ja @1 - jc @2 -@0: xor eax, eax // Str1=Str2 - ret -@n: cmp eax, edx - je @0 - test eax, eax // Str1='' ? - jz @max - test edx, edx // Str2='' ? - jnz @ok - mov eax, -1 - ret -@max: inc eax - ret -@2: add eax, edx - movzx eax, byte ptr [eax+ecx] - movzx edx, byte ptr [edx+ecx] - sub eax, edx -end; - -function StrLenSSE42(S: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // warning: may read up to 15 bytes beyond the string itself - mov edx, eax // copy pointer - test eax, eax - jz @null // returns 0 if S=nil - xor eax, eax - {$ifdef HASAESNI} - pxor xmm0, xmm0 - pcmpistri xmm0, dqword[edx], EQUAL_EACH // comparison result in ecx - {$else} - db $66, $0F, $EF, $C0 - db $66, $0F, $3A, $63, $02, EQUAL_EACH - {$endif} - jnz @loop - mov eax, ecx - ret - nop // for @loop alignment -@loop: add eax, 16 - {$ifdef HASAESNI} - pcmpistri xmm0, dqword[edx + eax], EQUAL_EACH // comparison result in ecx - {$else} - db $66, $0F, $3A, $63, $04, $10, EQUAL_EACH - {$endif} - jnz @loop -@ok: add eax, ecx - ret -@null: db $f3 // rep ret -end; - -procedure YearToPChar(Y: PtrUInt; P: PUTF8Char); -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=Y, edx=P - push edx - mov ecx, eax - mov edx, 1374389535 // use power of two reciprocal to avoid division - mul edx - shr edx, 5 // now edx=Y div 100 - movzx eax, word ptr[TwoDigitLookup + edx * 2] - imul edx, -200 - movzx edx, word ptr[TwoDigitLookup + ecx * 2 + edx] - pop ecx - shl edx, 16 - or eax, edx - mov [ecx], eax -end; - -function Iso8601ToTimeLog(const S: RawByteString): TTimeLog; -{$ifdef FPC} nostackframe; assembler; {$endif} asm - xor ecx,ecx // ContainsNoTime=nil - test eax,eax // if s='' -> p=nil -> will return 0, whatever L value is - jz Iso8601ToTimeLogPUTF8Char - mov edx,[eax-4] // edx=L -@1: jmp Iso8601ToTimeLogPUTF8Char -end; - -function UpperCopy(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=dest source=edx - test edx, edx - jz @z - push esi - mov esi, offset NormToUpperAnsi7 - xor ecx, ecx -@1: mov cl, [edx] - inc edx - test cl, cl - mov cl, [esi + ecx] - jz @2 - mov [eax], cl - inc eax - jmp @1 -@2: pop esi -@z: -end; - -function UpperCopyShort(dest: PAnsiChar; const source: shortstring): PAnsiChar; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=dest source=edx - push esi - push ebx - movzx ebx, byte ptr[edx] // ebx = length(source) - xor ecx, ecx - test ebx, ebx - mov esi, offset NormToUpperAnsi7 - jz @2 // source='' - inc edx -@1: mov cl, [edx] - inc edx - dec ebx - mov cl, [esi + ecx] - mov [eax], cl - lea eax, [eax + 1] - jnz @1 -@2: pop ebx - pop esi -@z: -end; - -function IdemPCharAndGetNextLine(var source: PUTF8Char; searchUp: PAnsiChar): boolean; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=source edx=searchUp - push eax // save source var - mov eax, [eax] // eax=source - test eax, eax - jz @z - push eax - call IdemPChar - pop ecx // ecx=source - push eax // save result -@1: mov dl, [ecx] // while not (source^ in [#0,#10,#13]) do inc(source) - inc ecx - cmp dl, 13 - ja @1 - je @e - or dl, dl - jz @0 - cmp dl, 10 - jne @1 - jmp @4 -@e: cmp byte ptr[ecx], 10 // jump #13#10 - jne @4 -@3: inc ecx -@4: pop eax // restore result - pop edx // restore source var - mov [edx], ecx // update source var - ret -@0: xor ecx, ecx // set source=nil - jmp @4 -@z: pop edx // ignore source var, result := false -end; - -procedure crcblockNoSSE42(crc128, data128: PBlock128); -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // Delphi is not efficient about compiling above pascal code - push ebp - push edi - push esi - mov ebp, eax // ebp=crc128 edi=data128 - mov edi, edx - mov edx, dword ptr[eax] - mov ecx, dword ptr[eax + 4] - xor edx, dword ptr[edi] - xor ecx, dword ptr[edi + 4] - movzx esi, dl - mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] - movzx esi, dh - shr edx, 16 - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] - movzx esi, dl - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] - movzx esi, dh - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] - mov edx, dword ptr[ebp + 8] - xor edx, dword ptr[edi + 8] - mov dword ptr[ebp], eax - movzx esi, cl - mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] - movzx esi, ch - shr ecx, 16 - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] - movzx esi, cl - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] - movzx esi, ch - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] - mov dword ptr[ebp + 4], eax - mov ecx, dword ptr[ebp + 12] - xor ecx, dword ptr[edi + 12] - movzx esi, dl - mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] - movzx esi, dh - shr edx, 16 - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] - movzx esi, dl - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] - movzx esi, dh - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] - mov dword ptr[ebp + 8], eax - movzx esi, cl - mov eax, dword ptr[esi * 4 + crc32ctab + 1024 * 3] - movzx esi, ch - shr ecx, 16 - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 2] - movzx esi, cl - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 1] - movzx esi, ch - xor eax, dword ptr[esi * 4 + crc32ctab + 1024 * 0] - mov dword ptr[ebp + 12], eax - pop esi - pop edi - pop ebp -end; - -function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // adapted from Aleksandr Sharahov code and Maxim Masiutin remarks - test edx, edx - jz @z - neg ecx - jz @z - not eax - push ebx - push ebp - lea ebp, [crc32ctab] -@head: test dl, 3 - jz @align - movzx ebx, byte ptr[edx] - inc edx - xor bl, al - shr eax, 8 - xor eax, dword ptr[ebx * 4 + ebp] - inc ecx - jnz @head - pop ebp - pop ebx - not eax -@z: ret -@align: sub edx, ecx - add ecx, 8 - jg @done - push esi - push edi - mov edi, edx -@by8: mov edx, eax - mov ebx, [edi + ecx - 4] - xor edx, [edi + ecx - 8] - movzx esi, bl - mov eax, dword ptr[esi * 4 + ebp + 1024 * 3] - movzx esi, bh - xor eax, dword ptr[esi * 4 + ebp + 1024 * 2] - shr ebx, 16 - movzx esi, bl - xor eax, dword ptr[esi * 4 + ebp + 1024 * 1] - movzx esi, bh - xor eax, dword ptr[esi * 4 + ebp + 1024 * 0] - movzx esi, dl - xor eax, dword ptr[esi * 4 + ebp + 1024 * 7] - movzx esi, dh - xor eax, dword ptr[esi * 4 + ebp + 1024 * 6] - shr edx, 16 - movzx esi, dl - xor eax, dword ptr[esi * 4 + ebp + 1024 * 5] - movzx esi, dh - xor eax, dword ptr[esi * 4 + ebp + 1024 * 4] - add ecx, 8 - jle @by8 - mov edx, edi - pop edi - pop esi -@done: sub ecx, 8 - jl @tail - pop ebp - pop ebx - not eax - ret -@tail: movzx ebx, byte[edx + ecx] - xor bl, al - shr eax, 8 - xor eax, dword ptr[ebx * 4 + ebp] - inc ecx - jnz @tail -@e: pop ebp - pop ebx - not eax -end; - -{$ifndef DELPHI5OROLDER} -const - CMP_RANGES = $44; // see https://msdn.microsoft.com/en-us/library/bb531425 - -function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=dest edx=source ecx=sourceLen - test ecx,ecx - jz @z - movups xmm1, dqword ptr [@az] - movups xmm3, dqword ptr [@bits] - cmp ecx, 16 - ja @big - // optimize the common case of sourceLen<=16 - movups xmm2, [edx] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, CMP_RANGES // find in range a-z, return mask in xmm0 - {$else} - db $66, $0F, $3A, $62, $CA, CMP_RANGES - {$endif} - pand xmm0, xmm3 - pxor xmm2, xmm0 - movups [eax], xmm2 - add eax, ecx -@z: ret -@big: push eax - cmp ecx, 240 - jb @ok - mov ecx, 239 -@ok: add [esp], ecx // save to return end position with the exact size - shr ecx, 4 - sub edx, eax - inc ecx -@s: movups xmm2, [edx+eax] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, CMP_RANGES - {$else} - db $66, $0F, $3A, $62, $CA, CMP_RANGES - {$endif} - pand xmm0, xmm3 - pxor xmm2, xmm0 - movups [eax], xmm2 - add eax, 16 - dec ecx - jnz @s - pop eax - ret -@az: db 'azazazazazazazaz' // define range for upper case conversion -@bits: db ' ' // $20 = bit to change when changing case -end; -{$endif DELPHI5OROLDER} - -function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=crc, edx=buf, ecx=len - push ebx - test edx, edx - jz @0 - neg ecx - jz @0 - sub edx, ecx -@1: movzx ebx, byte ptr[edx + ecx] - xor eax, ebx - imul eax, eax, 16777619 - inc ecx - jnz @1 -@0: pop ebx -end; // we tried an unrolled version, but it was slower on our Core i7! - -function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=crc, edx=buf, ecx=len - test ecx, ecx - push edi - push esi - push ebx - push ebp - jz @z - cmp ecx, 4 - jb @s -@8: mov ebx, [edx] // unrolled version reading per dword - add edx, 4 - mov esi, eax - movzx edi, bl - movzx ebp, bh - shr ebx, 16 - shl eax, 5 - sub eax, esi - add eax, edi - mov esi, eax - shl eax, 5 - sub eax, esi - lea esi, [eax + ebp] - add eax, ebp - movzx edi, bl - movzx ebx, bh - shl eax, 5 - sub eax, esi - lea ebp, [eax + edi] - add eax, edi - shl eax, 5 - sub eax, ebp - add eax, ebx - cmp ecx, 8 - lea ecx, [ecx - 4] - jae @8 - test ecx, ecx - jz @z -@s: mov esi, eax -@1: shl eax, 5 - movzx ebx, byte ptr[edx] - inc edx - sub eax, esi - lea esi, [eax + ebx] - add eax, ebx - dec ecx - jnz @1 -@z: pop ebp - pop ebx - pop esi - pop edi -end; - -function ToVarInt32(Value: PtrInt; Dest: PByte): PByte; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm - test eax, eax - jnl @pos - neg eax - add eax, eax - jmp ToVarUInt32 -@pos: jz @zer - lea eax, [eax * 2 - 1] - jmp ToVarUInt32 -@zer: mov [edx], al - lea eax, [edx + 1] -end; - -function ToVarUInt32(Value: PtrUInt; Dest: PByte): PByte; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm - cmp eax, $7f - jbe @0 - cmp eax, $00004000 - jb @1 - cmp eax, $00200000 - jb @2 - cmp eax, $10000000 - jb @3 - mov ecx, eax - shr eax, 7 - and cl, $7f - or cl, $80 - mov [edx], cl - inc edx -@3: mov ecx, eax - shr eax, 7 - and cl, $7f - or cl, $80 - mov [edx], cl - inc edx -@2: mov ecx, eax - shr eax, 7 - and cl, $7f - or cl, $80 - mov [edx], cl - inc edx -@1: mov ecx, eax - shr eax, 7 - and cl, $7f - or cl, $80 - mov [edx], cl - inc edx -@0: mov [edx], al - lea eax, [edx + 1] -end; - -function CompareQWord(A, B: QWord): integer; -begin - {$ifdef FPC_OR_UNICODE} // recent compilers are able to generate correct code - result := ord(A>B)-ord(A returns length(a)-length(b) - pop ebx - ret -@d: bsf ebx, ebx // char differs -> returns pbyte(a)^-pbyte(b)^ - shr ebx, 3 - add ecx, ebx - jns @l - movzx eax, byte ptr[eax + ecx] - movzx edx, byte ptr[edx + ecx] - pop ebx - pop ebx - sub eax, edx - ret -@n1: test eax, eax // a or b may be '' - jz @n0 - test edx, edx - jnz @n2 - cmp [eax - 4], edx - je @0 -@no: jnc @1 - mov eax, -1 - ret -@n0: cmp eax, [edx - 4] - je @0 - jnc @1 - mov eax, -1 - ret -@0: xor eax, eax - ret -@1: mov eax, 1 -end; -function SortDynArrayAnsiStringI(const A,B): integer; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // avoid a call on the stack on x86 platform - mov eax, [eax] - mov edx, [edx] - jmp StrIComp -end; -function SortDynArrayPUTF8Char(const A,B): integer; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // avoid a call on the stack on x86 platform - mov eax, [eax] - mov edx, [edx] - jmp dword ptr[StrComp] -end; -function SortDynArrayDouble(const A,B): integer; -{$ifdef FPC} nostackframe; assembler; {$endif} asm - fld qword ptr[eax] - fcomp qword ptr[edx] - fstsw ax - sahf - jz @0 -@nz: jnb @p - mov eax, -1 - ret -@0: xor eax, eax - ret -@p: mov eax, 1 -end; -function SortDynArraySingle(const A,B): integer; -{$ifdef FPC} nostackframe; assembler; {$endif} asm - fld dword ptr[eax] - fcomp dword ptr[edx] - fstsw ax - sahf - jz @0 -@nz: jnb @p - mov eax, -1 - ret -@0: xor eax, eax - ret -@p: mov eax, 1 -end; -{$endif PUREPASCAL} - -function PosExChar(Chr: AnsiChar; const Str: RawUTF8): PtrInt; -begin - if Str<>'' then - {$ifdef FPC} // will use fast FPC SSE version - result := IndexByte(pointer(Str)^,PStrLen(PtrUInt(Str)-_STRLEN)^,byte(chr))+1 else - {$else} - for result := 1 to PInteger(PtrInt(Str)-sizeof(Integer))^ do - if Str[result]=Chr then - exit; - {$endif FPC} - result := 0; -end; - -function SplitRight(const Str: RawUTF8; SepChar: AnsiChar; LeftStr: PRawUTF8): RawUTF8; -var i: PtrInt; -begin - for i := length(Str) downto 1 do - if Str[i]=SepChar then begin - result := copy(Str,i+1,maxInt); - if LeftStr<>nil then - LeftStr^ := copy(Str,1,i-1); - exit; - end; - result := Str; - if LeftStr<>nil then - LeftStr^ := ''; -end; - -function SplitRights(const Str, SepChar: RawUTF8): RawUTF8; -var i, j, sep: PtrInt; - c: AnsiChar; -begin - sep := length(SepChar); - if sep > 0 then - if sep = 1 then - result := SplitRight(Str,SepChar[1]) else begin - for i := length(Str) downto 1 do begin - c := Str[i]; - for j := 1 to sep do - if c=SepChar[j] then begin - result := copy(Str,i+1,maxInt); - exit; - end; - end; - end; - result := Str; -end; - -function Split(const Str, SepStr: RawUTF8; StartPos: integer): RawUTF8; -var i: integer; -begin -{$ifdef FPC} // to use fast FPC SSE version - if (StartPos=1) and (length(SepStr)=1) then - i := PosExChar(SepStr[1],Str) else -{$endif FPC} - i := PosEx(SepStr,Str,StartPos); - if i>0 then - result := Copy(Str,StartPos,i-StartPos) else - if StartPos=1 then - result := Str else - result := Copy(Str,StartPos,maxInt); -end; - -procedure Split(const Str, SepStr: RawUTF8; var LeftStr, RightStr: RawUTF8; ToUpperCase: boolean); -var i: integer; - tmp: RawUTF8; // may be called as Split(Str,SepStr,Str,RightStr) -begin - {$ifdef FPC} // to use fast FPC SSE version - if length(SepStr)=1 then - i := PosExChar(SepStr[1],Str) else - {$endif FPC} - i := PosEx(SepStr,Str); - if i=0 then begin - LeftStr := Str; - RightStr := ''; - end else begin - tmp := copy(Str,1,i-1); - RightStr := copy(Str,i+length(SepStr),maxInt); - LeftStr := tmp; - end; - if ToUpperCase then begin - UpperCaseSelf(LeftStr); - UpperCaseSelf(RightStr); - end; -end; - -function Split(const Str, SepStr: RawUTF8; var LeftStr: RawUTF8; ToUpperCase: boolean): RawUTF8; -begin - Split(Str,SepStr,LeftStr,result,ToUpperCase); -end; - -function Split(const Str: RawUTF8; const SepStr: array of RawUTF8; - const DestPtr: array of PRawUTF8): PtrInt; -var s,i,j: PtrInt; -begin - j := 1; - result := 0; - s := 0; - if high(SepStr)>=0 then - while result<=high(DestPtr) do begin - i := PosEx(SepStr[s],Str,j); - if i=0 then begin - if DestPtr[result]<>nil then - DestPtr[result]^ := copy(Str,j,MaxInt); - inc(result); - break; - end; - if DestPtr[result]<>nil then - DestPtr[result]^ := copy(Str,j,i-j); - inc(result); - if snil then - DestPtr[i]^ := ''; -end; - -function StringReplaceAllProcess(const S, OldPattern, NewPattern: RawUTF8; - found: integer): RawUTF8; -var oldlen,newlen,i,last,posCount,sharedlen: integer; - pos: TIntegerDynArray; - src,dst: PAnsiChar; -begin - oldlen := length(OldPattern); - newlen := length(NewPattern); - SetLength(pos,64); - pos[0] := found; - posCount := 1; - repeat - found := PosEx(OldPattern,S,found+oldlen); - if found=0 then - break; - AddInteger(pos,posCount,found); - until false; - FastSetString(result,nil,Length(S)+(newlen-oldlen)*posCount); - last := 1; - src := pointer(s); - dst := pointer(result); - for i := 0 to posCount-1 do begin - sharedlen := pos[i]-last; - MoveFast(src^,dst^,sharedlen); - inc(src,sharedlen+oldlen); - inc(dst,sharedlen); - if newlen>0 then begin - MoveSmall(pointer(NewPattern),dst,newlen); - inc(dst,newlen); - end; - last := pos[i]+oldlen; - end; - MoveFast(src^,dst^,length(S)-last+1); -end; - -function StringReplaceAll(const S, OldPattern, NewPattern: RawUTF8): RawUTF8; -var found: integer; -begin - if (S='') or (OldPattern='') or (OldPattern=NewPattern) then - result := S else begin - found := PosEx(OldPattern,S,1); // our PosEx() is faster than Pos() - if found=0 then - result := S else - result := StringReplaceAllProcess(S,OldPattern,NewPattern,found); - end; -end; - -function StringReplaceAll(const S: RawUTF8; const OldNewPatternPairs: array of RawUTF8): RawUTF8; -var n,i: integer; -begin - result := S; - n := high(OldNewPatternPairs); - if (n>0) and (n and 1=1) then - for i := 0 to n shr 1 do - result := StringReplaceAll(result,OldNewPatternPairs[i*2],OldNewPatternPairs[i*2+1]); -end; - -function StringReplaceTabs(const Source,TabText: RawUTF8): RawUTF8; - - procedure Process(S,D,T: PAnsiChar; TLen: integer); - begin - repeat - if S^=#0 then - break else - if S^<>#9 then begin - D^ := S^; - inc(D); - inc(S); - end else begin - if TLen>0 then begin - MoveSmall(T,D,TLen); - inc(D,TLen); - end; - inc(S); - end; - until false; - end; - -var L,i,n,ttl: PtrInt; -begin - ttl := length(TabText); - L := Length(Source); - n := 0; - if ttl<>0 then - for i := 1 to L do - if Source[i]=#9 then - inc(n); - if n=0 then begin - result := Source; - exit; - end; - FastSetString(result,nil,L+n*pred(ttl)); - Process(pointer(Source),pointer(result),pointer(TabText),ttl); -end; - -function strspnpas(s,accept: pointer): integer; -var p: PCardinal; - c: AnsiChar; - d: cardinal; -begin // returns size of initial segment of s which are in accept - result := 0; - repeat - c := PAnsiChar(s)[result]; - if c=#0 then - break; - p := accept; - repeat // stop as soon as we find any character not from accept - d := p^; - inc(p); - if AnsiChar(d)=c then - break else - if AnsiChar(d)=#0 then - exit; - d := d shr 8; - if AnsiChar(d)=c then - break else - if AnsiChar(d)=#0 then - exit; - d := d shr 8; - if AnsiChar(d)=c then - break else - if AnsiChar(d)=#0 then - exit; - d := d shr 8; - if AnsiChar(d)=c then - break else - if AnsiChar(d)=#0 then - exit; - until false; - inc(result); - until false; -end; - -function strcspnpas(s,reject: pointer): integer; -var p: PCardinal; - c: AnsiChar; - d: cardinal; -begin // returns size of initial segment of s which are not in reject - result := 0; - repeat - c := PAnsiChar(s)[result]; - if c=#0 then - break; - p := reject; - repeat // stop as soon as we find any character from reject - d := p^; - inc(p); - if AnsiChar(d)=c then - exit else - if AnsiChar(d)=#0 then - break; - d := d shr 8; - if AnsiChar(d)=c then - exit else - if AnsiChar(d)=#0 then - break; - d := d shr 8; - if AnsiChar(d)=c then - exit else - if AnsiChar(d)=#0 then - break; - d := d shr 8; - if AnsiChar(d)=c then - exit else - if AnsiChar(d)=#0 then - break; - until false; - inc(result); - until false; -end; - -{$ifndef ABSOLUTEPASCAL} -{$ifdef CPUINTEL} -{$ifdef CPUX64} // inspired by Agner Fog's strspn64.asm -function strcspnsse42(s,reject: pointer): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=s, rdx=reject (Linux: rdi,rsi) -{$endif FPC} -{$ifdef win64} - push rdi - push rsi - mov rdi, rcx - mov rsi, rdx -{$endif}mov r8, rsi - xor ecx, ecx -@1: movups xmm2, [rdi] - movups xmm1, [rsi] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, $30 // find in set, invert valid bits, return bit mask in xmm0 - {$else} - db $66,$0F,$3A,$62,$CA,$30 - {$endif} - movd eax, xmm0 - jns @5 -@2: cmp eax, 65535 - jne @3 - add rdi, 16 // first 16 chars matched, continue with next 16 chars - add rcx, 16 - jmp @1 -@3: not eax - bsf eax, eax - add rax, rcx -{$ifdef win64} - pop rsi - pop rdi -{$endif}ret -@4: and eax, edx // accumulate matches -@5: add rsi, 16 // the set is more than 16 bytes - movups xmm1, [rsi] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, $30 - {$else} - db $66,$0F,$3A,$62,$CA,$30 - {$endif} - movd edx, xmm0 - jns @4 - mov rsi, r8 // restore set pointer - and eax, edx // accumulate matches - cmp eax, 65535 - jne @3 - add rdi, 16 - add rcx, 16 - jmp @1 -end; -function strspnsse42(s,accept: pointer): integer; -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=s, rdx=accept (Linux: rdi,rsi) -{$endif FPC} -{$ifdef win64} - push rdi - push rsi - mov rdi, rcx - mov rsi, rdx -{$endif}mov r8, rsi - xor ecx, ecx -@1: movups xmm2, [rdi] - movups xmm1, [rsi] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, $00 // find in set, return bit mask in xmm0 - {$else} - db $66,$0F,$3A,$62,$CA,$00 - {$endif} - movd eax, xmm0 - jns @5 -@2: cmp eax, 65535 - jne @3 - add rdi, 16 // first 16 chars matched, continue with next 16 chars - add rcx, 16 - jmp @1 -@3: not eax - bsf eax, eax - add rax, rcx -{$ifdef win64} - pop rsi - pop rdi -{$endif}ret -@4: or eax, edx // accumulate matches -@5: add rsi, 16 // the set is more than 16 bytes - movups xmm1, [rsi] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, $00 - {$else} - db $66,$0F,$3A,$62,$CA,$00 - {$endif} - movd edx, xmm0 - jns @4 - mov rsi, r8 // restore set pointer - or eax, edx // accumulate matches - cmp eax, 65535 - jne @3 - add rdi, 16 // first 16 chars matched, continue with next 16 chars - add rcx, 16 - jmp @1 -end; -{$endif CPUX64} -{$ifdef CPUX86} -function strcspnsse42(s,reject: pointer): integer; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=s, edx=reject - push edi - push esi - push ebx - mov edi, eax - mov esi, edx - mov ebx, esi - xor ecx, ecx -@1: {$ifdef HASAESNI} - movups xmm2, dqword [edi] - movups xmm1, dqword [esi] - pcmpistrm xmm1, xmm2, $30 // find in set, invert valid bits, return bit mask in xmm0 - movd eax, xmm0 - {$else} - db $F3,$0F,$6F,$17 - db $F3,$0F,$6F,$0E - db $66,$0F,$3A,$62,$CA,$30 - db $66,$0F,$7E,$C0 - {$endif} - jns @5 -@2: cmp eax, 65535 - jne @3 - add edi, 16 // first 16 chars matched, continue with next 16 chars - add ecx, 16 - jmp @1 -@3: not eax - bsf eax, eax - add eax, ecx - pop ebx - pop esi - pop edi - ret -@4: and eax, edx // accumulate matches -@5: add esi, 16 // the set is more than 16 bytes - {$ifdef HASAESNI} - movups xmm1, [esi] - pcmpistrm xmm1, xmm2, $30 - movd edx, xmm0 - {$else} - db $F3,$0F,$6F,$0E - db $66,$0F,$3A,$62,$CA,$30 - db $66,$0F,$7E,$C2 - {$endif} - jns @4 - mov esi, ebx // restore set pointer - and eax, edx // accumulate matches - cmp eax, 65535 - jne @3 - add edi, 16 // first 16 chars matched, continue with next 16 chars - add ecx, 16 - jmp @1 -end; -function strspnsse42(s,accept: pointer): integer; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=s, edx=accept - push edi - push esi - push ebx - mov edi, eax - mov esi, edx - mov ebx, esi - xor ecx, ecx -@1: {$ifdef HASAESNI} - movups xmm2, dqword [edi] - movups xmm1, dqword [esi] - pcmpistrm xmm1, xmm2, $00 // find in set, return bit mask in xmm0 - movd eax, xmm0 - {$else} - db $F3,$0F,$6F,$17 - db $F3,$0F,$6F,$0E - db $66,$0F,$3A,$62,$CA,$00 - db $66,$0F,$7E,$C0 - {$endif} - jns @5 -@2: cmp eax, 65535 - jne @3 - add edi, 16 // first 16 chars matched, continue with next 16 chars - add ecx, 16 - jmp @1 -@3: not eax - bsf eax, eax - add eax, ecx - pop ebx - pop esi - pop edi - ret -@4: or eax, edx // accumulate matches -@5: add esi, 16 // the set is more than 16 bytes - {$ifdef HASAESNI} - movups xmm1, [esi] - pcmpistrm xmm1, xmm2, $00 - movd edx, xmm0 - {$else} - db $F3,$0F,$6F,$0E - db $66,$0F,$3A,$62,$CA,$00 - db $66,$0F,$7E,$C2 - {$endif} - jns @4 - mov esi, ebx // restore set pointer - or eax, edx // accumulate matches - cmp eax, 65535 - jne @3 - add edi, 16 // first 16 chars matched, continue with next 16 chars - add ecx, 16 - jmp @1 -end; -{$ifndef DELPHI5OROLDER} -function StrLenSSE2(S: pointer): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // from GPL strlen32.asm by Agner Fog - www.agner.org/optimize - mov ecx, eax // copy pointer - test eax, eax - jz @null // returns 0 if S=nil - push eax // save start address - pxor xmm0, xmm0 // set to zero - and ecx, 15 // lower 4 bits indicate misalignment - and eax, -16 // align pointer by 16 - // will never read outside a memory page boundary, so won't trigger GPF - movaps xmm1, [eax] // read from nearest preceding boundary - pcmpeqb xmm1, xmm0 // compare 16 bytes with zero - pmovmskb edx, xmm1 // get one bit for each byte result - shr edx, cl // shift out false bits - shl edx, cl // shift back again - bsf edx, edx // find first 1-bit - jnz @A200 // found - // Main loop, search 16 bytes at a time -@A100: add eax, 10H // increment pointer by 16 - movaps xmm1, [eax] // read 16 bytes aligned - pcmpeqb xmm1, xmm0 // compare 16 bytes with zero - pmovmskb edx, xmm1 // get one bit for each byte result - bsf edx, edx // find first 1-bit - // (moving the bsf out of the loop and using test here would be faster - // for long strings on old processors, but we are assuming that most - // strings are short, and newer processors have higher priority) - jz @A100 // loop if not found -@A200: // Zero-byte found. Compute string length - pop ecx // restore start address - sub eax, ecx // subtract start address - add eax, edx // add byte index -@null: -end; -{$endif DELPHI5OROLDER} -{$endif CPUX86} -{$endif CPUINTEL} -{$endif ABSOLUTEPASCAL} - -function IdemPropName(const P1,P2: shortstring): boolean; -begin - if P1[0]=P2[0] then - result := IdemPropNameUSameLen(@P1[1],@P2[1],ord(P2[0])) else - result := false; -end; - -function IdemPropName(const P1: shortstring; P2: PUTF8Char; P2Len: PtrInt): boolean; -begin - if ord(P1[0])=P2Len then - result := IdemPropNameUSameLen(@P1[1],P2,P2Len) else - result := false; -end; - -function IdemPropName(P1,P2: PUTF8Char; P1Len,P2Len: PtrInt): boolean; -begin - if P1Len=P2Len then - result := IdemPropNameUSameLen(P1,P2,P2Len) else - result := false; -end; - -function IdemPropNameU(const P1: RawUTF8; P2: PUTF8Char; P2Len: PtrInt): boolean; -begin - if length(P1)=P2Len then - result := IdemPropNameUSameLen(pointer(P1),P2,P2Len) else - result := false; -end; - -function ToText(os: TOperatingSystem): PShortString; -begin - result := GetEnumName(TypeInfo(TOperatingSystem),ord(os)); -end; - -function ToText(const osv: TOperatingSystemVersion): ShortString; -begin - if osv.os=osWindows then - FormatShort('Windows %', [WINDOWS_NAME[osv.win]], result) else - TrimLeftLowerCaseToShort(ToText(osv.os),result); -end; - -function ToTextOS(osint32: integer): RawUTF8; -var osv: TOperatingSystemVersion absolute osint32; - ost: ShortString; -begin - ost := ToText(osv); - if (osv.os>=osLinux) and (osv.utsrelease[2]<>0) then - result := FormatUTF8('% %.%.%',[ost,osv.utsrelease[2],osv.utsrelease[1],osv.utsrelease[0]]) else - result := ShortStringToUTF8(ost); -end; - -{$ifdef MSWINDOWS} -procedure FileTimeToInt64(const FT: TFileTime; out I64: Int64); -begin - {$ifdef CPU64} - PInt64Rec(@I64)^.Lo := FT.dwLowDateTime; - PInt64Rec(@I64)^.Hi := FT.dwHighDateTime; - {$else} - I64 := PInt64(@FT)^; - {$endif} -end; - -const - // lpMinimumApplicationAddress retrieved from Windows is very low $10000 - // - i.e. maximum number of ID per table would be 65536 in TSQLRecord.GetID - // - so we'll force an higher and almost "safe" value as 1,048,576 - // (real value from runnning Windows is greater than $400000) - MIN_PTR_VALUE = $100000; - - // see http://msdn.microsoft.com/en-us/library/ms724833(v=vs.85).aspx - VER_NT_WORKSTATION = 1; - VER_NT_DOMAIN_CONTROLLER = 2; - VER_NT_SERVER = 3; - SM_SERVERR2 = 89; - PROCESSOR_ARCHITECTURE_AMD64 = 9; - -{$ifndef UNICODE} -function GetVersionEx(var lpVersionInformation: TOSVersionInfoEx): BOOL; stdcall; - external kernel32 name 'GetVersionExA'; -{$endif} - -threadvar // mandatory: GetTickCount seems per-thread on XP :( - LastTickXP: TQWordRec; - -function GetTickCount64ForXP: Int64; stdcall; -var t32: cardinal; - p: PQWordRec; -begin // warning: GetSystemTimeAsFileTime() is fast, but not monotonic! - t32 := Windows.GetTickCount; - p := @LastTickXP; - if t320) or not SwitchToThread then - Windows.Sleep(ms); -end; - -{ TWinRegistry } - -function TWinRegistry.ReadOpen(root: HKEY; const keyname: RawUTF8; - closefirst: boolean): boolean; -var tmp: TSynTempBuffer; -begin - if closefirst then - Close; - tmp.Init(length(keyname)*2); - UTF8ToWideChar(tmp.buf,pointer(keyname)); - key := 0; - result := RegOpenKeyExW(root,tmp.buf,0,KEY_READ,key)=0; - tmp.Done; -end; - -procedure TWinRegistry.Close; -begin - if key<>0 then - RegCloseKey(key); -end; - -function TWinRegistry.ReadString(const entry: SynUnicode; andtrim: boolean): RawUTF8; -var rtype, rsize: DWORD; - tmp: TSynTempBuffer; -begin - result := ''; - if RegQueryValueExW(key,pointer(entry),nil,@rtype,nil,@rsize)<>0 then - exit; - tmp.Init(rsize); - if RegQueryValueExW(key,pointer(entry),nil,nil,tmp.buf,@rsize)=0 then begin - case rtype of - REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ: - RawUnicodeToUtf8(tmp.buf,StrLenW(tmp.buf),result); - end; - if andtrim then - result := Trim(result); - end; - tmp.Done; -end; - -function TWinRegistry.ReadData(const entry: SynUnicode): RawByteString; -var rtype, rsize: DWORD; -begin - result := ''; - if RegQueryValueExW(key,pointer(entry),nil,@rtype,nil,@rsize)<>0 then - exit; - SetLength(result,rsize); - if RegQueryValueExW(key,pointer(entry),nil,nil,pointer(result),@rsize)<>0 then - result := ''; -end; - -function TWinRegistry.ReadDword(const entry: SynUnicode): cardinal; -var rsize: DWORD; -begin - rsize := 4; - if RegQueryValueExW(key,pointer(entry),nil,nil,@result,@rsize)<>0 then - result := 0; -end; - -function TWinRegistry.ReadQword(const entry: SynUnicode): QWord; -var rsize: DWORD; -begin - rsize := 8; - if RegQueryValueExW(key,pointer(entry),nil,nil,@result,@rsize)<>0 then - result := 0; -end; - -function TWinRegistry.ReadEnumEntries: TRawUTF8DynArray; -var count,maxlen,i,len: DWORD; - tmp: TSynTempBuffer; -begin - result := nil; - if (RegQueryInfoKeyW(key,nil,nil,nil,@count,@maxlen,nil,nil,nil,nil,nil,nil)<>0) or - (count=0) then - exit; - SetLength(result,count); - inc(maxlen); - tmp.Init(maxlen*3); - for i := 0 to count-1 do begin - len := maxlen; - if RegEnumKeyExW(key,i,tmp.buf,len,nil,nil,nil,nil)=0 then - RawUnicodeToUtf8(tmp.buf,len,result[i]); - end; - tmp.Done; -end; - - -procedure RetrieveSystemInfo; -var - IsWow64Process: function(Handle: THandle; var Res: BOOL): BOOL; stdcall; - GetNativeSystemInfo: procedure(var SystemInfo: TSystemInfo); stdcall; - wine_get_version: function: PAnsiChar; stdcall; - Res: BOOL; - h: THandle; - P: pointer; - Vers: TWindowsVersion; - cpu, manuf, prod, prodver: RawUTF8; - reg: TWinRegistry; -begin - h := GetModuleHandle(kernel32); - GetTickCount64 := GetProcAddress(h,'GetTickCount64'); - if not Assigned(GetTickCount64) then // WinXP+ - GetTickCount64 := @GetTickCount64ForXP; - GetSystemTimePreciseAsFileTime := GetProcAddress(h,'GetSystemTimePreciseAsFileTime'); - if not Assigned(GetSystemTimePreciseAsFileTime) then // Win8+ - GetSystemTimePreciseAsFileTime := @GetSystemTimeAsFileTime; - IsWow64Process := GetProcAddress(h,'IsWow64Process'); - Res := false; - IsWow64 := Assigned(IsWow64Process) and - IsWow64Process(GetCurrentProcess,Res) and Res; - FillcharFast(SystemInfo,SizeOf(SystemInfo),0); - if IsWow64 then // see http://msdn.microsoft.com/en-us/library/ms724381(v=VS.85).aspx - GetNativeSystemInfo := GetProcAddress(h,'GetNativeSystemInfo') else - @GetNativeSystemInfo := nil; - if Assigned(GetNativeSystemInfo) then - GetNativeSystemInfo(SystemInfo) else - Windows.GetSystemInfo(SystemInfo); - GetMem(P,10); // ensure that using MIN_PTR_VALUE won't break anything - if (PtrUInt(P)>MIN_PTR_VALUE) and - (PtrUInt(SystemInfo.lpMinimumApplicationAddress)<=MIN_PTR_VALUE) then - PtrUInt(SystemInfo.lpMinimumApplicationAddress) := MIN_PTR_VALUE; - Freemem(P); - OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo); - GetVersionEx(OSVersionInfo); - Vers := wUnknown; - with OSVersionInfo do - // see https://msdn.microsoft.com/en-us/library/windows/desktop/ms724833 - case dwMajorVersion of - 5: case dwMinorVersion of - 0: Vers := w2000; - 1: Vers := wXP; - 2: if (wProductType=VER_NT_WORKSTATION) and - (SystemInfo.wProcessorArchitecture=PROCESSOR_ARCHITECTURE_AMD64) then - Vers := wXP_64 else - if GetSystemMetrics(SM_SERVERR2)=0 then - Vers := wServer2003 else - Vers := wServer2003_R2; - end; - 6: case dwMinorVersion of - 0: Vers := wVista; - 1: Vers := wSeven; - 2: Vers := wEight; - 3: Vers := wEightOne; - 4: Vers := wTen; - end; - 10: Vers := wTen; - end; - if Vers>=wVista then begin - if OSVersionInfo.wProductType<>VER_NT_WORKSTATION then begin // Server edition - inc(Vers,2); // e.g. wEight -> wServer2012 - if (Vers=wServer2016) and (OSVersionInfo.dwBuildNumber>=17763) then - Vers := wServer2019_64; // https://stackoverflow.com/q/53393150 - end else if (Vers=wTen) and (OSVersionInfo.dwBuildNumber>=22000) then - Vers := wEleven; // waiting for an official mean of Windows 11 identification - if (SystemInfo.wProcessorArchitecture=PROCESSOR_ARCHITECTURE_AMD64) and - (Vers wEight64 - end; - OSVersion := Vers; - with OSVersionInfo do - if wServicePackMajor=0 then - FormatUTF8('Windows % (%.%.%)',[WINDOWS_NAME[Vers], - dwMajorVersion,dwMinorVersion,dwBuildNumber],OSVersionText) else - FormatUTF8('Windows % SP% (%.%.%)',[WINDOWS_NAME[Vers],wServicePackMajor, - dwMajorVersion,dwMinorVersion,dwBuildNumber],OSVersionText); - OSVersionInt32 := (integer(Vers) shl 8)+ord(osWindows); - if reg.ReadOpen(HKEY_LOCAL_MACHINE,'Hardware\Description\System\CentralProcessor\0') then begin - cpu := reg.ReadString('ProcessorNameString'); - if cpu='' then - cpu := reg.ReadString('Identifier'); - end; - if reg.ReadOpen(HKEY_LOCAL_MACHINE,'Hardware\Description\System\BIOS',true) then begin - manuf := reg.ReadString('SystemManufacturer'); - if manuf<>'' then - manuf := manuf+' '; - prod := reg.ReadString('SystemProductName'); - prodver := reg.ReadString('SystemVersion'); - if prodver='' then - prodver := reg.ReadString('BIOSVersion'); - end; - if (prod='') or (prodver='') then begin - if reg.ReadOpen(HKEY_LOCAL_MACHINE,'Hardware\Description\System',true) then begin - if prod='' then - prod := reg.ReadString('SystemBiosVersion'); - if prodver='' then - prodver := reg.ReadString('VideoBiosVersion'); - end; - end; - reg.Close; - if prodver<>'' then - FormatUTF8('%% %',[manuf,prod,prodver],BiosInfoText) else - FormatUTF8('%%',[manuf,prod],BiosInfoText); - if cpu='' then - cpu := StringToUTF8(GetEnvironmentVariable('PROCESSOR_IDENTIFIER')); - cpu := Trim(cpu); - FormatUTF8('% x % ('+CPU_ARCH_TEXT+')',[SystemInfo.dwNumberOfProcessors,cpu],CpuInfoText); - h := LoadLibrary('ntdll.dll'); - if h>0 then begin - wine_get_version := GetProcAddress(h,'wine_get_version'); - if Assigned(wine_get_version) then - OSVersionInfoEx := trim('Wine '+trim(wine_get_version)); - FreeLibrary(h); - end; - if OSVersionInfoEx<>'' then - OSVersionText := FormatUTF8('% - %', [OSVersionText,OSVersionInfoEx]); -end; - -{$else} - -{$ifndef BSD} -procedure SetLinuxDistrib(const release: RawUTF8); -var - distrib: TOperatingSystem; - dist: RawUTF8; -begin - for distrib := osArch to high(distrib) do begin - dist := UpperCase(TrimLeftLowerCaseShort(ToText(distrib))); - if PosI(pointer(dist),release)>0 then begin - OS_KIND := distrib; - break; - end; - end; -end; -{$endif BSD} - -procedure RetrieveSystemInfo; -var modname, beg: PUTF8Char; - {$ifdef BSD} - temp: shortstring; - {$else} - cpuinfo: PUTF8Char; - proccpuinfo,prod,prodver,release,dist: RawUTF8; - SR: TSearchRec; - {$endif BSD} -begin - modname := nil; - {$ifdef BSD} - fpuname(SystemInfo.uts); - SystemInfo.dwNumberOfProcessors := fpsysctlhwint(HW_NCPU); - Utf8ToRawUTF8(fpsysctlhwstr(HW_MACHINE,temp),BiosInfoText); - modname := fpsysctlhwstr(HW_MODEL,temp); - with SystemInfo.uts do - FormatUTF8('%-% %',[sysname,release,version],OSVersionText); - {$else} - {$ifdef KYLIX3} - uname(SystemInfo.uts); - {$else} - fpuname(SystemInfo.uts); - {$endif KYLIX3} - prod := Trim(StringFromFile('/sys/class/dmi/id/product_name',true)); - if prod<>'' then begin - prodver := Trim(StringFromFile('/sys/class/dmi/id/product_version',true)); - if prodver<>'' then - FormatUTF8('% %',[prod,prodver],BiosInfoText) else - BiosInfoText := prod; - end; - SystemInfo.dwNumberOfProcessors := 0; - proccpuinfo := StringFromFile('/proc/cpuinfo',true); - cpuinfo := pointer(proccpuinfo); - while cpuinfo<>nil do begin - beg := cpuinfo; - cpuinfo := GotoNextLine(cpuinfo); - if IdemPChar(beg,'PROCESSOR') then - if beg^='P' then - modname := beg else // Processor : ARMv7 - inc(SystemInfo.dwNumberOfProcessors) else // processor : 0 - if IdemPChar(beg,'MODEL NAME') then - modname := beg; - end; - modname := PosChar(modname,':'); - if modname<>nil then - modname := GotoNextNotSpace(modname+1); - FindNameValue(StringFromFile('/etc/os-release'),'PRETTY_NAME=',release); - if (release<>'') and (release[1]='"') then - release := copy(release,2,length(release)-2); - release := trim(release); - if release='' then - if FindNameValue(StringFromFile('/etc/lsb-release'),'DISTRIB_DESCRIPTION=',release) and - (release<>'') and (release[1]='"') then - release := copy(release,2,length(release)-2); - if (release='') and (FindFirst('/etc/*-release',faAnyFile,SR)=0) then begin - release := StringToUTF8(SR.Name); // 'redhat-release' 'SuSE-release' - if IdemPChar(pointer(release),'LSB-') and (FindNext(SR)=0) then - release := StringToUTF8(SR.Name); - release := split(release,'-'); - dist := split(trim(StringFromFile('/etc/'+SR.Name)),#10); - if (dist<>'') and (PosExChar('=',dist)=0) and (PosExChar(' ',dist)>0) then - SetLinuxDistrib(dist) // e.g. 'Red Hat Enterprise Linux Server release 6.7 (Santiago)' - else - dist := ''; - FindClose(SR); - end; - if (release<>'') and (OS_KIND=osLinux) then begin - SetLinuxDistrib(release); - if (OS_KIND=osLinux) and (dist<>'') then begin - SetLinuxDistrib(dist); - release := dist; - end; - if (OS_KIND=osLinux) and ((PosEx('RH',release)>0) or (PosEx('Red Hat',release)>0)) then - OS_KIND := osRedHat; - end; - SystemInfo.release := release; - {$endif BSD} - OSVersionInt32 := {$ifdef FPC}integer(KernelRevision shl 8)+{$endif}ord(OS_KIND); - with SystemInfo.uts do - FormatUTF8('% %',[sysname,release],OSVersionText); - if SystemInfo.release<>'' then - OSVersionText := FormatUTF8('% - %',[SystemInfo.release,OSVersionText]); - {$ifdef Android} - OSVersionText := 'Android ('+OSVersionText+')'; - {$endif} - if (SystemInfo.dwNumberOfProcessors>0) and (modname<>nil) then begin - beg := modname; - while not (ord(modname^) in [0,10,13]) do begin - if modname^<' ' then - modname^ := ' '; - inc(modname); - end; - modname^ := #0; - FormatUTF8('% x % ('+CPU_ARCH_TEXT+')',[SystemInfo.dwNumberOfProcessors,beg],CpuInfoText); - end; - if CpuInfoText='' then - CpuInfoText := CPU_ARCH_TEXT; -end; - -{$ifdef KYLIX3} -function FileOpen(const FileName: string; Mode: LongWord): Integer; -const - SHAREMODE: array[0..fmShareDenyNone shr 4] of Byte = ( - 0, // No share mode specified - F_WRLCK, // fmShareExclusive - F_RDLCK, // fmShareDenyWrite - 0); // fmShareDenyNone -var FileHandle, Tvar: Integer; - LockVar: TFlock; - smode: Byte; -begin - result := -1; - if FileExists(FileName) and - ((Mode and 3)<=fmOpenReadWrite) and ((Mode and $F0)<=fmShareDenyNone) then begin - FileHandle := open64(pointer(FileName),(Mode and 3),FileAccessRights); - if FileHandle=-1 then - exit; - smode := Mode and $F0 shr 4; - if SHAREMODE[smode]<>0 then begin - with LockVar do begin - l_whence := SEEK_SET; - l_start := 0; - l_len := 0; - l_type := SHAREMODE[smode]; - end; - Tvar := fcntl(FileHandle,F_SETLK,LockVar); - if Tvar=-1 then begin - __close(FileHandle); - exit; - end; - end; - result := FileHandle; - end; -end; - -function GetTickCount64: Int64; -begin - result := SynKylix.GetTickCount64; -end; -{$endif KYLIX3} - -{$ifdef FPC} -function GetTickCount64: Int64; -begin - result := SynFPCLinux.GetTickCount64; -end; -{$endif FPC} - -{$endif MSWINDOWS} - -function FileOpenSequentialRead(const FileName: string): Integer; -begin - {$ifdef MSWINDOWS} - if OSVersion>=wVista then // don't use the flag on XP - result := CreateFile(pointer(FileName),GENERIC_READ, - FILE_SHARE_READ or FILE_SHARE_WRITE,nil, // same as fmShareDenyNone - OPEN_EXISTING,FILE_FLAG_SEQUENTIAL_SCAN,0) else - result := FileOpen(FileName,fmOpenRead or fmShareDenyNone); - {$else} - // SysUtils.FileOpen = fpOpen + fpFlock - assuming FileName is UTF-8 - result := fpOpen(pointer(FileName), O_RDONLY); - {$endif MSWINDOWS} -end; - -type -{$ifdef DELPHI5ORFPC} // TFileStream doesn't have per-handle constructor like Delphi - TFileStreamFromHandle = class(THandleStream) - public - destructor Destroy; override; - end; - -destructor TFileStreamFromHandle.Destroy; -begin - FileClose(Handle); // otherwise file is still opened -end; -{$else} - TFileStreamFromHandle = TFileStream; -{$endif DELPHI5ORFPC} - -function FileStreamSequentialRead(const FileName: string): THandleStream; -begin - result := TFileStreamFromHandle.Create(FileOpenSequentialRead(FileName)); -end; - -function Elapsed(var PreviousTix: Int64; Interval: Integer): Boolean; -var now: Int64; -begin - if Interval<=0 then - result := false else begin - now := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64; - if now-PreviousTix>Interval then begin - PreviousTix := now; - result := true; - end else - result := false; - end; -end; - -function StrCntDecFree(var refcnt: TStrCnt): boolean; -{$ifdef CPUINTEL} {$ifdef FPC}nostackframe; assembler; {$endif} -asm {$ifdef CPU64DELPHI} .noframe {$endif} - {$ifdef STRCNT32} - lock dec dword ptr[refcnt] - {$else} - lock dec qword ptr[refcnt] - {$endif STRCNT32} - setbe al -end; // we don't check for ismultithread global since lock is cheap on new CPUs -{$else} -begin // fallback to RTL asm e.g. for ARM - {$ifdef STRCNT32} - result := InterLockedDecrement(refcnt)<=0; - {$else} - result := InterLockedDecrement64(refcnt)<=0; - {$endif STRCNT32} -end; -{$endif CPUINTEL} - -function DACntDecFree(var refcnt: TDACnt): boolean; -{$ifdef CPUINTEL} {$ifdef FPC}nostackframe; assembler; {$endif} -asm {$ifdef CPU64DELPHI} .noframe {$endif} - {$ifdef DACNT32} - lock dec dword ptr[refcnt] - {$else} - lock dec qword ptr[refcnt] - {$endif DACNT32} - setbe al -end; // we don't check for ismultithread global since lock is cheap on new CPUs -{$else} -begin // fallback to RTL asm e.g. for ARM - {$ifdef DACNT32} - result := InterLockedDecrement(refcnt)<=0; - {$else} - result := InterLockedDecrement64(refcnt)<=0; - {$endif DACNT32} -end; -{$endif CPUINTEL} - -{$ifndef FPC} // FPC has its built-in InterlockedIncrement/InterlockedDecrement -{$ifdef PUREPASCAL} -function InterlockedIncrement(var I: Integer): Integer; -begin - {$ifdef MSWINDOWS} // AtomicIncrement() may not be available e.g. on Delphi XE2 - result := Windows.InterlockedIncrement(I); - {$else} - result := AtomicIncrement(I); - {$endif} -end; - -function InterlockedDecrement(var I: Integer): Integer; -begin - {$ifdef MSWINDOWS} // AtomicDecrement() may not be available e.g. on Delphi XE2 - result := Windows.InterlockedDecrement(I); - {$else} - result := AtomicDecrement(I); - {$endif} -end; -{$else} -function InterlockedIncrement(var I: Integer): Integer; -asm - mov edx, 1 - xchg eax, edx - lock xadd [edx], eax - inc eax -end; -function InterlockedDecrement(var I: Integer): Integer; -asm - mov edx, -1 - xchg eax, edx - lock xadd [edx], eax - dec eax -end; -{$endif} -{$endif FPC} - -function GetHighUTF8UCS4(var U: PUTF8Char): PtrUInt; -var extra,i: PtrInt; - c: PtrUInt; -begin - result := 0; - c := byte(U^); // here U^>=#80 - inc(U); - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - for i := 1 to extra do begin - if byte(U^) and $c0<>$80 then - exit; // invalid input content - c := c shl 6+byte(U^); - inc(U); - end; - with UTF8_EXTRA[extra] do begin - dec(c,offset); - if c=#80 - inc(U); - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - for i := 1 to extra do begin - if byte(U^) and $c0<>$80 then - exit; // invalid input content - c := c shl 6+byte(U^); - inc(U); - end; - with UTF8_EXTRA[extra] do begin - dec(c,offset); - if c=127) or not(tcWord in TEXT_BYTES[c]); - repeat - V := U; - c := GetNextUTF8Upper(U); - if c=0 then - exit; - until (c<127) and (tcWord in TEXT_BYTES[c]); - result := V; -end; - -{$ifdef USENORMTOUPPER} - -function AnsiICompW(u1, u2: PWideChar): PtrInt; {$ifdef HASINLINE}inline;{$endif} -var C1,C2: PtrInt; - table: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperAnsi7Byte{$else}PNormTableByte{$endif}; -begin - if u1<>u2 then - if u1<>nil then - if u2<>nil then begin - {$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7Byte;{$endif} - repeat - C1 := PtrInt(u1^); - C2 := PtrInt(u2^); - result := C1-C2; - if result<>0 then begin - if (C1>255) or (C2>255) then exit; - result := table[C1]-table[C2]; - if result<>0 then exit; - end; - if (C1=0) or (C2=0) then break; - inc(u1); - inc(u2); - until false; - end else - result := 1 else // u2='' - result := -1 else // u1='' - result := 0; // u1=u2 -end; - - -{$ifdef PUREPASCAL} -function AnsiIComp(Str1, Str2: pointer): PtrInt; -var C1,C2: byte; // integer/PtrInt are actually slower on FPC - lookupper: PByteArray; // better x86-64 / PIC asm generation -begin - result := PtrInt(PtrUInt(Str2))-PtrInt(PtrUInt(Str1)); - if result<>0 then - if Str1<>nil then - if Str2<>nil then begin - lookupper := @NormToUpperByte; - repeat - C1 := lookupper[PByteArray(Str1)[0]]; - C2 := lookupper[PByteArray(Str1)[result]]; - inc(PByte(Str1)); - until (C1=0) or (C1<>C2); - result := C1-C2; - end else - result := 1 else // Str2='' - result := -1; // Str1='' -end; -{$else} -function AnsiIComp(Str1, Str2: pointer): PtrInt; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // fast 8 bits WinAnsi comparison using the NormToUpper[] array - cmp eax, edx - je @2 - test eax, edx // is either of the strings perhaps nil? - jz @3 -@0: push ebx // compare the first character (faster quicksort) - movzx ebx, byte ptr[eax] // ebx=S1[1] - movzx ecx, byte ptr[edx] // ecx=S2[1] - test ebx, ebx - jz @z - cmp ebx, ecx - je @s - mov bl, byte ptr[NormToUpper + ebx] - mov cl, byte ptr[NormToUpper + ecx] - cmp ebx, ecx - je @s - mov eax, ebx - pop ebx - sub eax, ecx // return S1[1]-S2[1] - ret -@2b: pop ebx -@2: xor eax, eax - ret -@3: test eax, eax // S1='' - jz @4 - test edx, edx // S2='' ? - jnz @0 - mov eax, 1 // return 1 (S1>S2) - ret -@s: inc eax - inc edx - mov bl, [eax] // ebx=S1[i] - mov cl, [edx] // ecx=S2[i] - test ebx, ebx - je @z // end of S1 - cmp ebx, ecx - je @s - mov bl, byte ptr[NormToUpper + ebx] - mov cl, byte ptr[NormToUpper + ecx] - cmp ebx, ecx - je @s - mov eax, ebx - pop ebx - sub eax, ecx // return S1[i]-S2[i] - ret -@z: cmp ebx, ecx // S1=S2? - jz @2b - pop ebx -@4: mov eax, -1 // return -1 (S1$80 then - exit else // invalid input content - c := c shl 6+byte(P[i]); - with UTF8_EXTRA[extra] do begin - dec(c,offset); - if cLD then - SetLength(result,LD); -end; - -function LowerCaseU(const S: RawUTF8): RawUTF8; -var LS,LD: integer; -begin - LS := length(S); - FastSetString(result,pointer(S),LS); - LD := ConvertCaseUTF8(pointer(result),NormToLowerByte); - if LS<>LD then - SetLength(result,LD); -end; - -function UTF8IComp(u1, u2: PUTF8Char): PtrInt; -var c2: PtrInt; - table: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperByte{$else}PNormTableByte{$endif}; -begin // fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values - {$ifndef CPUX86NOTPIC}table := @NormToUpperByte;{$endif} - if u1<>u2 then - if u1<>nil then - if u2<>nil then - repeat - result := ord(u1^); - c2 := ord(u2^); - if result<=127 then - if result<>0 then begin - inc(u1); - result := table[result]; - if c2<=127 then begin - if c2=0 then exit; // u1>u2 -> return u1^ - inc(u2); - dec(result,table[c2]); - if result<>0 then exit; - continue; - end; - end else begin // u1^=#0 -> end of u1 reached - if c2<>0 then // end of u2 reached -> u1=u2 -> return 0 - result := -1; // u1u2 -> return u1^ - inc(u2); - dec(result,table[c2]); - if result<>0 then exit; - continue; - end else begin - c2 := GetHighUTF8UCS4Inlined(u2); - if c2<=255 then - dec(result,table[c2]) else // 8 bits to upper - dec(result,c2); // 32-bit widechar returns diff - if result<>0 then exit; - end; - until false else - result := 1 else // u2='' - result := -1 else // u1='' - result := 0; // u1=u2 -end; - -function UTF8ILComp(u1, u2: PUTF8Char; L1,L2: cardinal): PtrInt; -var c2: PtrInt; - extra,i: integer; - table: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperByte{$else}PNormTableByte{$endif}; -label neg,pos; -begin // fast UTF-8 comparison using the NormToUpper[] array for all 8 bits values - {$ifndef CPUX86NOTPIC}table := @NormToUpperByte;{$endif} - if u1<>u2 then - if (u1<>nil) and (L1<>0) then - if (u2<>nil) and (L2<>0) then - repeat - result := ord(u1^); - c2 := ord(u2^); - inc(u1); - dec(L1); - if result<=127 then begin - result := table[result]; - if c2<=127 then begin - dec(result,table[c2]); - dec(L2); - inc(u2); - if result<>0 then - exit else - if L1<>0 then - if L2<>0 then - continue else // L1>0 and L2>0 -> next char - goto pos else // L1>0 and L2=0 -> u1>u2 - if L2<>0 then - goto neg else // L1=0 and L2>0 -> u1 u1=u2 - end; - end else begin - extra := UTF8_EXTRABYTES[result]; - if extra=0 then goto neg; // invalid leading byte - dec(L1,extra); - if Integer(L1)<0 then goto neg; - for i := 0 to extra-1 do - result := result shl 6+PByteArray(u1)[i]; - dec(result,UTF8_EXTRA[extra].offset); - inc(u1,extra); - if result and $ffffff00=0 then - result := table[result]; // 8 bits to upper, 32-bit as is - end; - // here result=NormToUpper[u1^] - inc(u2); - dec(L2); - if c2<=127 then begin - dec(result,table[c2]); - if result<>0 then exit; - end else begin - extra := UTF8_EXTRABYTES[c2]; - if extra=0 then goto pos; - dec(L2,extra); - if integer(L2)<0 then goto pos; - for i := 0 to extra-1 do - c2 := c2 shl 6+PByteArray(u2)[i]; - dec(c2,UTF8_EXTRA[extra].offset); - inc(u2,extra); - if c2 and $ffffff00=0 then - dec(result,table[c2]) else // 8 bits to upper - dec(result,c2); // returns 32-bit diff - if result<>0 then exit; - end; - // here we have result=NormToUpper[u2^]-NormToUpper[u1^]=0 - if L1=0 then // test if we reached end of u1 or end of u2 - if L2=0 then exit // u1=u2 - else goto neg else // u1u2 - until false else -pos: result := 1 else // u2='' or u1>u2 -neg: result := -1 else // u1='' or u1UpperValue^ then break; {$else} - if NormToUpperAnsi7[A^]<>UpperValue^ then break; -{$endif} - inc(UpperValue); - if UpperValue^=#0 then begin - result := true; // UpperValue found! - exit; - end; - inc(A); - if A^=#0 then exit; - until false; - // find beginning of next word - repeat - if A^=#0 then exit else -{$ifdef USENORMTOUPPER} - if not (tcWord in TEXT_CHARS[NormToUpper[A^]]) then break else inc(A); -{$else} if not (tcWord in TEXT_CHARS[A^]) then break else inc(A); {$endif} - until false; - until false; -end; - -function FindUnicode(PW, Upper: PWideChar; UpperLen: PtrInt): boolean; -var Start: PWideChar; - w: PtrUInt; -begin - result := false; - if (PW=nil) or (Upper=nil) then exit; - repeat - // go to beginning of next word - repeat - w := ord(PW^); - if w=0 then exit else - if (w>126) or (tcWord in TEXT_BYTES[w]) then - Break; - inc(PW); - until false; - Start := PW; - // search end of word matching UpperLen characters - repeat - inc(PW); - w := ord(PW^); - until (PW-Start>=UpperLen) or - (w=0) or ((w<126) and (not(tcWord in TEXT_BYTES[w]))); - if PW-Start>=UpperLen then - if CompareStringW(LOCALE_USER_DEFAULT,NORM_IGNORECASE,Start,UpperLen,Upper,UpperLen)=2 then begin - result := true; // match found - exit; - end; - // not found: go to end of current word - repeat - w := ord(PW^); - if w=0 then exit else - if ((w<126) and (not(tcWord in TEXT_BYTES[w]))) then Break; - inc(PW); - until false; - until false; -end; - -function FindUTF8(U: PUTF8Char; UpperValue: PAnsiChar): boolean; -var ValueStart: PAnsiChar; -{$ifdef USENORMTOUPPER} - c: PtrUInt; - FirstChar: AnsiChar; -label Next; -{$else} - ch: AnsiChar; -{$endif} -begin - result := false; - if (U=nil) or (UpperValue=nil) then exit; -{$ifdef USENORMTOUPPER} - // handles 8-bits WinAnsi chars inside UTF-8 encoded data - FirstChar := UpperValue^; - ValueStart := UpperValue+1; - repeat - // test beginning of word - repeat - c := byte(U^); - inc(U); - if c=0 then exit else - if c<=127 then begin - if tcWord in TEXT_BYTES[c] then - if PAnsiChar(@NormToUpper)[c]<>FirstChar then - goto Next else - break; - end else - if c and $20=0 then begin // fast direct process $0..$7ff - c := c shl 6+byte(U^)-$3080; - inc(U); - if c<=255 then begin - c := NormToUpperByte[c]; - if tcWord in TEXT_BYTES[c] then - if AnsiChar(c)<>FirstChar then - goto Next else - break; - end; - end else - if UTF8_EXTRABYTES[c]=0 then - exit else // invalid leading byte - inc(U,UTF8_EXTRABYTES[c]); // just ignore surrogates for soundex - until false; - // here we had the first char match -> check if this word match UpperValue - UpperValue := ValueStart; - repeat - if UpperValue^=#0 then begin - result := true; // UpperValue found! - exit; - end; - c := byte(U^); inc(U); // next chars - if c=0 then exit else - if c<=127 then begin - if PAnsiChar(@NormToUpper)[c]<>UpperValue^ then break; - end else - if c and $20=0 then begin - c := c shl 6+byte(U^)-$3080; - inc(U); - if (c>255) or (PAnsiChar(@NormToUpper)[c]<>UpperValue^) then break; - end else begin - if UTF8_EXTRABYTES[c]=0 then - exit else // invalid leading byte - inc(U,UTF8_EXTRABYTES[c]); - break; - end; - inc(UpperValue); - until false; -Next: // find beginning of next word - U := FindNextUTF8WordBegin(U); - until U=nil; -{$else} - // this tiny version only handles 7-bits ansi chars and ignore all UTF-8 chars - ValueStart := UpperValue; - repeat - // find beginning of word - repeat - if byte(U^)=0 then exit else - if byte(U^)<=127 then - if byte(U^) in IsWord then - break else - inc(U) else - if byte(U^) and $20=0 then - inc(U,2) else - inc(U,3); - until false; - // check if this word is the UpperValue - UpperValue := ValueStart; - repeat - ch := NormToUpperAnsi7[U^]; - if ch<>UpperValue^ then break; - inc(UpperValue); - if UpperValue^=#0 then begin - result := true; // UpperValue found! - exit; - end; - inc(U); - if byte(U^)=0 then exit else - if byte(U^) and $80<>0 then break; // 7 bits char check only - until false; - // find beginning of next word - U := FindNextUTF8WordBegin(U); - until U=nil; -{$endif} -end; - -function HexDisplayToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: integer): boolean; -var b,c: byte; - tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; -begin - result := false; // return false if any invalid char - if (Hex=nil) or (Bin=nil) then - exit; - {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 - if BinBytes>0 then begin - inc(Bin,BinBytes-1); - repeat - b := tab[Ord(Hex[0])]; - c := tab[Ord(Hex[1])]; - if (b>15) or (c>15) then - exit; - b := b shl 4; // better FPC generation code in small explicit steps - b := b or c; - Bin^ := b; - dec(Bin); - inc(Hex,2); - dec(BinBytes); - until BinBytes=0; - end; - result := true; // correct content in Hex -end; - -function HexDisplayToCardinal(Hex: PAnsiChar; out aValue: cardinal): boolean; -begin - result := HexDisplayToBin(Hex,@aValue,SizeOf(aValue)); - if not result then - aValue := 0; -end; - -function HexDisplayToInt64(Hex: PAnsiChar; out aValue: Int64): boolean; -begin - result := HexDisplayToBin(Hex,@aValue,SizeOf(aValue)); - if not result then - aValue := 0; -end; - -function HexDisplayToInt64(const Hex: RawByteString): Int64; -begin - if not HexDisplayToBin(pointer(Hex),@result,SizeOf(result)) then - result := 0; -end; - -function HexToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer): boolean; -var b,c: byte; - tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; -begin - result := false; // return false if any invalid char - if Hex=nil then - exit; - {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 - if BinBytes>0 then - if Bin<>nil then - repeat - b := tab[Ord(Hex[0])]; - c := tab[Ord(Hex[1])]; - if (b>15) or (c>15) then - exit; - inc(Hex,2); - b := b shl 4; - b := b or c; - Bin^ := b; - inc(Bin); - dec(BinBytes); - until BinBytes=0 else - repeat // Bin=nil -> validate Hex^ input - if (tab[Ord(Hex[0])]>15) or (tab[Ord(Hex[1])]>15) then - exit; - inc(Hex,2); - dec(BinBytes); - until BinBytes=0; - result := true; // conversion OK -end; - -procedure HexToBinFast(Hex: PAnsiChar; Bin: PByte; BinBytes: Integer); -var tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; - c: byte; -begin - {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 - if BinBytes>0 then - repeat - c := tab[ord(Hex[0])]; - c := c shl 4; - c := tab[ord(Hex[1])] or c; - Bin^ := c; - inc(Hex,2); - inc(Bin); - dec(BinBytes); - until BinBytes=0; -end; - -function OctToBin(Oct: PAnsiChar; Bin: PByte): PtrInt; -var c, v: byte; -label _nxt; -begin - result := PtrInt(Bin); - if Oct <> nil then - repeat - c := ord(Oct^); - inc(Oct); - if c <> ord('\') then begin - if c = 0 then - break; -_nxt: Bin^ := c; - inc(Bin); - continue; - end; - c := ord(Oct^); - inc(Oct); - if c = ord('\') then - goto _nxt; - dec(c, ord('0')); - if c > 3 then - break; // stop at malformated input (includes #0) - c := c shl 6; - v := c; - c := ord(Oct[0]); - dec(c, ord('0')); - if c > 7 then - break; - c := c shl 3; - v := v or c; - c := ord(Oct[1]); - dec(c, ord('0')); - if c > 7 then - break; - c := c or v; - Bin^ := c; - inc(Bin); - inc(Oct, 2); - until false; - result := PtrInt(Bin)-result; -end; - -function OctToBin(const Oct: RawUTF8): RawByteString; -var tmp: TSynTempBuffer; - L: integer; -begin - tmp.Init(length(Oct)); - try - L := OctToBin(pointer(Oct), tmp.buf); - SetString(result, PAnsiChar(tmp.buf), L); - finally - tmp.Done; - end; -end; - -function IsHex(const Hex: RawByteString; BinBytes: integer): boolean; -begin - result := (length(Hex)=BinBytes*2) and SynCommons.HexToBin(pointer(Hex),nil,BinBytes); -end; - -function HexToCharValid(Hex: PAnsiChar): boolean; -begin - result := (ConvertHexToBin[Ord(Hex[0])]<=15) and - (ConvertHexToBin[Ord(Hex[1])]<=15); -end; - -function HexToChar(Hex: PAnsiChar; Bin: PUTF8Char): boolean; -var B,C: PtrUInt; - tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; -begin - if Hex<>nil then begin - {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 - B := tab[Ord(Hex[0])]; - C := tab[Ord(Hex[1])]; - if (B<=15) and (C<=15) then begin - if Bin<>nil then - Bin^ := AnsiChar(B shl 4+C); - result := true; - exit; - end; - end; - result := false; // return false if any invalid char -end; - -function HexToWideChar(Hex: PAnsiChar): cardinal; -var B: PtrUInt; -begin - result := ConvertHexToBin[Ord(Hex[0])]; - if result<=15 then begin - B := ConvertHexToBin[Ord(Hex[1])]; - if B<=15 then begin - result := result shl 4+B; - B := ConvertHexToBin[Ord(Hex[2])]; - if B<=15 then begin - result := result shl 4+B; - B := ConvertHexToBin[Ord(Hex[3])]; - if B<=15 then begin - result := result shl 4+B; - exit; - end; - end; - end; - end; - result := 0; -end; - -{ --------- Base64 encoding/decoding } - -type - TBase64Enc = array[0..63] of AnsiChar; - PBase64Enc = ^TBase64Enc; - TBase64Dec = array[AnsiChar] of shortint; - PBase64Dec = ^TBase64Dec; -const - b64enc: TBase64Enc = - 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; - b64URIenc: TBase64Enc = - 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_'; -var - /// a conversion table from Base64 text into binary data - // - used by Base64ToBin/IsBase64 functions - // - contains -1 for invalid char, -2 for '=', 0..63 for b64enc[] chars - ConvertBase64ToBin, ConvertBase64URIToBin: TBase64Dec; - -function Base64AnyDecode(const decode: TBase64Dec; sp,rp: PAnsiChar; len: PtrInt): boolean; -var c, ch: PtrInt; -begin - result := false; - while len>=4 do begin - c := decode[sp[0]]; - if c<0 then - exit; - c := c shl 6; - ch := decode[sp[1]]; - if ch<0 then - exit; - c := (c or ch) shl 6; - ch := decode[sp[2]]; - if ch<0 then - exit; - c := (c or ch) shl 6; - ch := decode[sp[3]]; - if ch<0 then - exit; - c := c or ch; - rp[2] := AnsiChar(c); - c := c shr 8; - rp[1] := AnsiChar(c); - c := c shr 8; - rp[0] := AnsiChar(c); - dec(len,4); - inc(rp,3); - inc(sp,4); - end; - if len>=2 then begin - c := decode[sp[0]]; - if c<0 then - exit; - c := c shl 6; - ch := decode[sp[1]]; - if ch<0 then - exit; - if len=2 then - rp[0] := AnsiChar((c or ch) shr 4) else begin - c := (c or ch) shl 6; - ch := decode[sp[2]]; - if ch<0 then - exit; - c := (c or ch) shr 2; - rp[1] := AnsiChar(c); - rp[0] := AnsiChar(c shr 8); - end; - end; - result := true; -end; - -function Base64Decode(sp,rp: PAnsiChar; len: PtrInt): boolean; {$ifdef FPC}inline;{$endif} -var tab: PBase64Dec; // use local register -begin - tab := @ConvertBase64ToBin; - len := len shl 2; // len was the number of 4 chars chunks in sp - if (len>0) and (tab[sp[len-2]]>=0) then - if tab[sp[len-1]]>=0 then else - dec(len) else - dec(len,2); // Base64AnyDecode() algorithm ignores the trailing '=' - result := Base64AnyDecode(tab^,sp,rp,len); -end; - -{$ifdef PUREPASCAL} -function Base64EncodeMain(rp, sp: PAnsiChar; len: cardinal): integer; -var c: cardinal; - enc: PBase64Enc; // use local register -begin - enc := @b64enc; - len := len div 3; - result := len; - if len<>0 then - repeat - c := (ord(sp[0]) shl 16) or (ord(sp[1]) shl 8) or ord(sp[2]); - rp[0] := enc[(c shr 18) and $3f]; - rp[1] := enc[(c shr 12) and $3f]; - rp[2] := enc[(c shr 6) and $3f]; - rp[3] := enc[c and $3f]; - inc(rp,4); - inc(sp,3); - dec(len); - until len=0; -end; -{$else PUREPASCAL} -function Base64EncodeMain(rp, sp: PAnsiChar; len: cardinal): integer; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=rp edx=sp ecx=len - pipeline optimized version by AB - push ebx - push esi - push edi - push ebp - mov ebx, edx - mov esi, eax - mov eax, ecx - mov edx, 1431655766 // faster eax=len div 3 using reciprocal - sar ecx, 31 - imul edx - mov eax, edx - sub eax, ecx - mov edi, offset b64enc - mov ebp, eax - push eax - jz @z - // edi=b64enc[] ebx=sp esi=rp ebp=len div 3 - xor eax, eax -@1: // read 3 bytes from sp - movzx edx, byte ptr[ebx] - shl edx, 16 - mov al, [ebx + 2] - mov ah, [ebx + 1] - add ebx, 3 - or eax, edx - // encode as Base64 - mov ecx, eax - mov edx, eax - shr ecx, 6 - and edx, $3f - and ecx, $3f - mov dh, [edi + edx] - mov dl, [edi + ecx] - mov ecx, eax - shr eax, 12 - shr ecx, 18 - shl edx, 16 - and ecx, $3f - and eax, $3f - mov cl, [edi + ecx] - mov ch, [edi + eax] - or ecx, edx - // write the 4 encoded bytes into rp - mov [esi], ecx - add esi, 4 - dec ebp - jnz @1 -@z: pop eax // result := len div 3 - pop ebp - pop edi - pop esi - pop ebx -end; -{$endif PUREPASCAL} - -procedure Base64EncodeTrailing(rp, sp: PAnsiChar; len: cardinal); - {$ifdef HASINLINE}inline;{$endif} -var c: cardinal; - enc: PBase64Enc; // use local register -begin - enc := @b64enc; - case len of - 1: begin - c := ord(sp[0]) shl 4; - rp[0] := enc[(c shr 6) and $3f]; - rp[1] := enc[c and $3f]; - PWord(rp+2)^ := ord('=')+ord('=') shl 8; - end; - 2: begin - c := (ord(sp[0]) shl 10) or (ord(sp[1]) shl 2); - rp[0] := enc[(c shr 12) and $3f]; - rp[1] := enc[(c shr 6) and $3f]; - rp[2] := enc[c and $3f]; - rp[3] := '='; - end; - end; -end; - -procedure Base64Encode(rp, sp: PAnsiChar; len: cardinal); -var main: cardinal; -begin - main := Base64EncodeMain(rp,sp,len); - Base64EncodeTrailing(rp+main*4,sp+main*3,len-main*3); -end; - -function BinToBase64Length(len: PtrUInt): PtrUInt; -begin - result := ((len+2)div 3)*4; -end; - -function BinToBase64(const s: RawByteString): RawUTF8; -var len: integer; -begin - result := ''; - len := length(s); - if len=0 then - exit; - FastSetString(result,nil,BinToBase64Length(len)); - Base64Encode(pointer(result),pointer(s),len); -end; - -function BinToBase64Short(Bin: PAnsiChar; BinBytes: integer): shortstring; -var destlen: integer; -begin - result := ''; - if BinBytes=0 then - exit; - destlen := BinToBase64Length(BinBytes); - if destlen>255 then - exit; // avoid buffer overflow - result[0] := AnsiChar(destlen); - Base64Encode(@result[1],Bin,BinBytes); -end; - -function BinToBase64Short(const s: RawByteString): shortstring; -begin - result := BinToBase64Short(pointer(s),length(s)); -end; - -function BinToBase64(Bin: PAnsiChar; BinBytes: integer): RawUTF8; -begin - result := ''; - if BinBytes=0 then - exit; - FastSetString(result,nil,BinToBase64Length(BinBytes)); - Base64Encode(pointer(result),Bin,BinBytes); -end; - -function BinToBase64(const data, Prefix, Suffix: RawByteString; WithMagic: boolean): RawUTF8; -var lendata,lenprefix,lensuffix,len: integer; - res: PByteArray absolute result; -begin - result := ''; - lendata := length(data); - lenprefix := length(Prefix); - lensuffix := length(Suffix); - if lendata+lenprefix+lensuffix=0 then - exit; - len := ((lendata+2) div 3)*4+lenprefix+lensuffix; - if WithMagic then - inc(len,3); - FastSetString(result,nil,len); - if lenprefix>0 then - MoveSmall(pointer(Prefix),res,lenprefix); - if WithMagic then begin - PInteger(@res[lenprefix])^ := JSON_BASE64_MAGIC; - inc(lenprefix,3); - end; - Base64Encode(@res[lenprefix],pointer(data),lendata); - if lensuffix>0 then - MoveSmall(pointer(Suffix),@res[len-lensuffix],lensuffix); -end; - -function BinToBase64WithMagic(const data: RawByteString): RawUTF8; -var len: integer; -begin - result := ''; - len := length(data); - if len=0 then - exit; - FastSetString(result,nil,((len+2) div 3)*4+3); - PInteger(pointer(result))^ := JSON_BASE64_MAGIC; - Base64Encode(PAnsiChar(pointer(result))+3,pointer(data),len); -end; - -function BinToBase64WithMagic(Data: pointer; DataLen: integer): RawUTF8; -begin - result := ''; - if DataLen<=0 then - exit; - FastSetString(result,nil,((DataLen+2) div 3)*4+3); - PInteger(pointer(result))^ := JSON_BASE64_MAGIC; - Base64Encode(PAnsiChar(pointer(result))+3,Data,DataLen); -end; - -function IsBase64Internal(sp: PAnsiChar; len: PtrInt; dec: PBase64Dec): boolean; -var i: PtrInt; -begin - result := false; - if (len=0) or (len and 3<>0) then - exit; - for i := 0 to len-5 do - if dec[sp[i]]<0 then - exit; - inc(sp,len-4); - if (dec[sp[0]]=-1) or (dec[sp[1]]=-1) or - (dec[sp[2]]=-1) or (dec[sp[3]]=-1) then - exit; - result := true; // layout seems correct -end; - -function IsBase64(sp: PAnsiChar; len: PtrInt): boolean; -begin - result := IsBase64Internal(sp,len,@ConvertBase64ToBin); -end; - -function IsBase64(const s: RawByteString): boolean; -begin - result := IsBase64Internal(pointer(s),length(s),@ConvertBase64ToBin); -end; - -function Base64ToBinLengthSafe(sp: PAnsiChar; len: PtrInt): PtrInt; -var dec: PBase64Dec; -begin - dec := @ConvertBase64ToBin; - if IsBase64Internal(sp,len,dec) then begin - if dec[sp[len-2]]>=0 then - if dec[sp[len-1]]>=0 then - result := 0 else - result := 1 else - result := 2; - result := (len shr 2)*3-result; - end else - result := 0; -end; - -function Base64ToBinLength(sp: PAnsiChar; len: PtrInt): PtrInt; -var dec: PBase64Dec; -begin - result := 0; - if (len=0) or (len and 3<>0) then - exit; - dec := @ConvertBase64ToBin; - if dec[sp[len-2]]>=0 then - if dec[sp[len-1]]>=0 then - result := 0 else - result := 1 else - result := 2; - result := (len shr 2)*3-result; -end; - -function Base64ToBin(const s: RawByteString): RawByteString; -begin - Base64ToBinSafe(pointer(s),length(s),result); -end; - -function Base64ToBin(sp: PAnsiChar; len: PtrInt): RawByteString; -begin - Base64ToBinSafe(sp,len,result); -end; - -function Base64ToBin(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; -begin - result := Base64ToBinSafe(sp,len,data); -end; - -function Base64ToBinSafe(const s: RawByteString): RawByteString; -begin - Base64ToBinSafe(pointer(s),length(s),result); -end; - -function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt): RawByteString; -begin - Base64ToBinSafe(sp,len,result); -end; - -function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean; -var resultLen: PtrInt; -begin - resultLen := Base64ToBinLength(sp,len); - if resultLen<>0 then begin - SetString(data,nil,resultLen); - if ConvertBase64ToBin[sp[len-2]]>=0 then - if ConvertBase64ToBin[sp[len-1]]>=0 then else - dec(len) else - dec(len,2); // adjust for Base64AnyDecode() algorithm - result := Base64AnyDecode(ConvertBase64ToBin,sp,pointer(data),len); - if not result then - data := ''; - end else begin - result := false; - data := ''; - end; -end; - -function Base64ToBin(sp: PAnsiChar; len: PtrInt; var blob: TSynTempBuffer): boolean; -begin - blob.Init(Base64ToBinLength(sp,len)); - result := (blob.len>0) and Base64Decode(sp,blob.buf,len shr 2); -end; - -function Base64ToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt; - nofullcheck: boolean): boolean; -begin // nofullcheck is just ignored and deprecated - result := (bin<>nil) and (Base64ToBinLength(base64,base64len)=binlen) and - Base64Decode(base64,bin,base64len shr 2); -end; - -function Base64ToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt; - nofullcheck: boolean): boolean; -begin - result := Base64ToBin(pointer(base64),bin,length(base64),binlen,nofullcheck); -end; - -{ --------- Base64 URI encoding/decoding } - -{$ifdef PUREPASCAL} -procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal); -var main, c: cardinal; - enc: PBase64Enc; // faster especially on x86_64 and PIC -begin - enc := @b64URIenc; - main := len div 3; - if main<>0 then begin - dec(len,main*3); // fast modulo - repeat - c := (ord(sp[0]) shl 16) or (ord(sp[1]) shl 8) or ord(sp[2]); - rp[0] := enc[(c shr 18) and $3f]; - rp[1] := enc[(c shr 12) and $3f]; - rp[2] := enc[(c shr 6) and $3f]; - rp[3] := enc[c and $3f]; - inc(rp,4); - inc(sp,3); - dec(main) - until main=0; - end; - case len of - 1: begin - c := ord(sp[0]) shl 4; - rp[0] := enc[(c shr 6) and $3f]; - rp[1] := enc[c and $3f]; - end; - 2: begin - c := (ord(sp[0]) shl 10) or (ord(sp[1]) shl 2); - rp[0] := enc[(c shr 12) and $3f]; - rp[1] := enc[(c shr 6) and $3f]; - rp[2] := enc[c and $3f]; - end; - end; -end; -{$else PUREPASCAL} -function Base64uriEncodeMain(rp, sp: PAnsiChar; len: cardinal): integer; -{$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=rp edx=sp ecx=len - pipeline optimized version by AB - push ebx - push esi - push edi - push ebp - mov ebx, edx - mov esi, eax - mov eax, ecx - mov edx, 1431655766 // faster eax=len div 3 using reciprocal - sar ecx, 31 - imul edx - mov eax, edx - sub eax, ecx - mov edi, offset b64urienc - mov ebp, eax - push eax - jz @z - // edi=b64urienc[] ebx=sp esi=rp ebp=len div 3 - xor eax, eax -@1: // read 3 bytes from sp - movzx edx, byte ptr[ebx] - shl edx, 16 - mov al, [ebx + 2] - mov ah, [ebx + 1] - add ebx, 3 - or eax, edx - // encode as Base64uri - mov ecx, eax - mov edx, eax - shr ecx, 6 - and edx, $3f - and ecx, $3f - mov dh, [edi + edx] - mov dl, [edi + ecx] - mov ecx, eax - shr eax, 12 - shr ecx, 18 - shl edx, 16 - and ecx, $3f - and eax, $3f - mov cl, [edi + ecx] - mov ch, [edi + eax] - or ecx, edx - // write the 4 encoded bytes into rp - mov [esi], ecx - add esi, 4 - dec ebp - jnz @1 -@z: pop eax // result := len div 3 - pop ebp - pop edi - pop esi - pop ebx -end; - -procedure Base64uriEncodeTrailing(rp, sp: PAnsiChar; len: cardinal); - {$ifdef HASINLINE}inline;{$endif} -var c: cardinal; -begin - case len of - 1: begin - c := ord(sp[0]) shl 4; - rp[0] := b64urienc[(c shr 6) and $3f]; - rp[1] := b64urienc[c and $3f]; - end; - 2: begin - c := ord(sp[0]) shl 10 + ord(sp[1]) shl 2; - rp[0] := b64urienc[(c shr 12) and $3f]; - rp[1] := b64urienc[(c shr 6) and $3f]; - rp[2] := b64urienc[c and $3f]; - end; - end; -end; - -procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal); -var main: cardinal; -begin - main := Base64uriEncodeMain(rp,sp,len); - Base64uriEncodeTrailing(rp+main*4,sp+main*3,len-main*3); -end; -{$endif PUREPASCAL} - -function BinToBase64uriLength(len: PtrUInt): PtrUInt; -begin - result := (len div 3)*4; - case len-(result shr 2)*3 of // fast len mod 3 - 1: inc(result,2); - 2: inc(result,3); - end; -end; - -function BinToBase64uri(const s: RawByteString): RawUTF8; -var len: integer; -begin - result := ''; - len := length(s); - if len=0 then - exit; - FastSetString(result,nil,BinToBase64uriLength(len)); - Base64uriEncode(pointer(result),pointer(s),len); -end; - -function BinToBase64uri(Bin: PAnsiChar; BinBytes: integer): RawUTF8; -begin - result := ''; - if BinBytes<=0 then - exit; - FastSetString(result,nil,BinToBase64uriLength(BinBytes)); - Base64uriEncode(pointer(result),Bin,BinBytes); -end; - -function BinToBase64uriShort(Bin: PAnsiChar; BinBytes: integer): shortstring; -var len: integer; -begin - result := ''; - if BinBytes<=0 then - exit; - len := BinToBase64uriLength(BinBytes); - if len>255 then - exit; - byte(result[0]) := len; - Base64uriEncode(@result[1],Bin,BinBytes); -end; - -function Base64uriToBinLength(len: PtrInt): PtrInt; -begin - if len=0 then - result := 0 else begin - result := (len shr 2)*3; - case len and 3 of - 1: result := 0; - 2: inc(result,1); - 3: inc(result,2); - end; - end; -end; - -function Base64uriDecode(sp,rp: PAnsiChar; len: PtrInt): boolean; -begin - result := Base64AnyDecode(ConvertBase64URIToBin,sp,rp,len); -end; - -function Base64uriToBin(sp: PAnsiChar; len: PtrInt): RawByteString; -begin - Base64uriToBin(sp,len,result); -end; - -function Base64uriToBin(const s: RawByteString): RawByteString; -begin - Base64uriToBin(pointer(s),length(s),result); -end; - -procedure Base64uriToBin(sp: PAnsiChar; len: PtrInt; var result: RawByteString); -var resultLen: PtrInt; -begin - resultLen := Base64uriToBinLength(len); - if resultLen<>0 then begin - SetString(result,nil,resultLen); - if Base64AnyDecode(ConvertBase64URIToBin,sp,pointer(result),len) then - exit; - end; - result := ''; -end; - -function Base64uriToBin(sp: PAnsiChar; len: PtrInt; var temp: TSynTempBuffer): boolean; -begin - temp.Init(Base64uriToBinLength(len)); - result := (temp.len>0) and Base64AnyDecode(ConvertBase64URIToBin,sp,temp.buf,len); -end; - -function Base64uriToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt): boolean; -begin - result := Base64uriToBin(pointer(base64),bin,length(base64),binlen); -end; - -function Base64uriToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt): boolean; -var resultLen: PtrInt; -begin - resultLen := Base64uriToBinLength(base64len); - result := (resultLen=binlen) and - Base64AnyDecode(ConvertBase64URIToBin,base64,bin,base64len); -end; - -procedure Base64ToURI(var base64: RawUTF8); -var P: PUTF8Char; -begin - P := UniqueRawUTF8(base64); - if P<>nil then - repeat - case P^ of - #0: break; - '+': P^ := '-'; - '/': P^ := '_'; - '=': begin // trim unsignificant trailing '=' characters - SetLength(base64,P-pointer(base64)); - break; - end; - end; - inc(P); - until false; -end; - - -function BinToSource(const ConstName, Comment: RawUTF8; - Data: pointer; Len, PerLine: integer; const Suffix: RawUTF8): RawUTF8; -var W: TTextWriter; - temp: TTextWriterStackBuffer; -begin - if (Data=nil) or (Len<=0) or (PerLine<=0) then - result := '' else begin - W := TTextWriter.CreateOwnedStream(temp,Len*5+50+length(Comment)+length(Suffix)); - try - BinToSource(W,ConstName,Comment,Data,Len,PerLine); - if Suffix<>'' then begin - W.AddString(Suffix); - W.AddCR; - end; - W.SetText(result); - finally - W.Free; - end; - end; -end; - -procedure BinToSource(Dest: TTextWriter; const ConstName, Comment: RawUTF8; - Data: pointer; Len, PerLine: integer); -var line,i: integer; - P: PByte; -begin - if (Dest=nil) or (Data=nil) or (Len<=0) or (PerLine<=0) then - exit; - Dest.AddShort('const'); - if Comment<>'' then - Dest.Add(#13#10' // %',[Comment]); - Dest.Add(#13#10' %: array[0..%] of byte = (',[ConstName,Len-1]); - P := pointer(Data); - repeat - if len>PerLine then - line := PerLine else - line := Len; - Dest.AddShort(#13#10' '); - for i := 0 to line-1 do begin - Dest.Add('$'); - Dest.AddByteToHex(P^); - inc(P); - Dest.Add(','); - end; - dec(Len,line); - until Len=0; - Dest.CancelLastComma; - Dest.Add(');'#13#10' %_LEN = SizeOf(%);'#13#10,[ConstName,ConstName]); -end; - -{$ifdef KYLIX3} -function UpperCaseUnicode(const S: RawUTF8): RawUTF8; -begin - result := WideStringToUTF8(WideUpperCase(UTF8ToWideString(S))); -end; - -function LowerCaseUnicode(const S: RawUTF8): RawUTF8; -begin - result := WideStringToUTF8(WideLowerCase(UTF8ToWideString(S))); -end; -{$else} -function UpperCaseUnicode(const S: RawUTF8): RawUTF8; -var tmp: TSynTempBuffer; - len: integer; -begin - if S='' then begin - result := ''; - exit; - end; - tmp.Init(length(s)*2); - len := UTF8ToWideChar(tmp.buf,pointer(S),length(S)) shr 1; - RawUnicodeToUtf8(tmp.buf,CharUpperBuffW(tmp.buf,len),result); - tmp.Done; -end; - -function LowerCaseUnicode(const S: RawUTF8): RawUTF8; -var tmp: TSynTempBuffer; - len: integer; -begin - if S='' then begin - result := ''; - exit; - end; - tmp.Init(length(s)*2); - len := UTF8ToWideChar(tmp.buf,pointer(S),length(S)) shr 1; - RawUnicodeToUtf8(tmp.buf,CharLowerBuffW(tmp.buf,len),result); - tmp.Done; -end; -{$endif KYLIX3} - -function IsCaseSensitive(const S: RawUTF8): boolean; -begin - result := IsCaseSensitive(pointer(S),length(S)); -end; - -function IsCaseSensitive(P: PUTF8Char; PLen: PtrInt): boolean; -begin - result := true; - if (P<>nil) and (PLen>0) then - repeat - if ord(P^) in [ord('a')..ord('z'), ord('A')..ord('Z')] then - exit; - inc(P); - dec(PLen); - until PLen=0; - result := false; -end; - -function UpperCase(const S: RawUTF8): RawUTF8; -var L, i: PtrInt; -begin - L := length(S); - FastSetString(Result,pointer(S),L); - for i := 0 to L-1 do - if PByteArray(result)[i] in [ord('a')..ord('z')] then - dec(PByteArray(result)[i],32); -end; - -procedure UpperCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8); -var i: PtrInt; -begin - FastSetString(result,Text,Len); - for i := 0 to Len-1 do - if PByteArray(result)[i] in [ord('a')..ord('z')] then - dec(PByteArray(result)[i],32); -end; - -procedure UpperCaseCopy(const Source: RawUTF8; var Dest: RawUTF8); -var L, i: PtrInt; -begin - L := length(Source); - FastSetString(Dest,pointer(Source),L); - for i := 0 to L-1 do - if PByteArray(Dest)[i] in [ord('a')..ord('z')] then - dec(PByteArray(Dest)[i],32); -end; - -procedure UpperCaseSelf(var S: RawUTF8); -var i: PtrInt; - P: PByteArray; -begin - P := UniqueRawUTF8(S); - for i := 0 to length(S)-1 do - if P[i] in [ord('a')..ord('z')] then - dec(P[i],32); -end; - -function LowerCase(const S: RawUTF8): RawUTF8; -var L, i: PtrInt; -begin - L := length(S); - FastSetString(result,pointer(S),L); - for i := 0 to L-1 do - if PByteArray(result)[i] in [ord('A')..ord('Z')] then - inc(PByteArray(result)[i],32); -end; - -procedure LowerCaseCopy(Text: PUTF8Char; Len: PtrInt; var result: RawUTF8); -var i: PtrInt; -begin - FastSetString(result,Text,Len); - for i := 0 to Len-1 do - if PByteArray(result)[i] in [ord('A')..ord('Z')] then - inc(PByteArray(result)[i],32); -end; - -procedure LowerCaseSelf(var S: RawUTF8); -var i: PtrInt; - P: PByteArray; -begin - P := UniqueRawUTF8(S); - for i := 0 to length(S)-1 do - if P[i] in [ord('A')..ord('Z')] then - inc(P[i],32); -end; - -function TrimLeft(const S: RawUTF8): RawUTF8; -var i, l: PtrInt; -begin - l := Length(S); - i := 1; - while (i <= l) and (S[i] <= ' ') do - Inc(i); - Result := Copy(S, i, Maxint); -end; - -function TrimRight(const S: RawUTF8): RawUTF8; -var i: PtrInt; -begin - i := Length(S); - while (i > 0) and (S[i] <= ' ') do - Dec(i); - FastSetString(result,pointer(S),i); -end; - -procedure TrimCopy(const S: RawUTF8; start, count: PtrInt; - var result: RawUTF8); -var L: PtrInt; -begin - if count>0 then begin - if start<=0 then - start := 1; - L := Length(S); - while (start<=L) and (S[start]<=' ') do begin - inc(start); dec(count); end; - dec(start); - dec(L,start); - if count0 do - if S[start+L]<=' ' then - dec(L) else - break; - if L>0 then begin - FastSetString(result,@PByteArray(S)[start],L); - exit; - end; - end; - result := ''; -end; - -type - TAnsiCharToWord = array[AnsiChar] of word; - TByteToWord = array[byte] of word; -var - /// fast lookup table for converting hexadecimal numbers from 0 to 15 - // into their ASCII equivalence - // - is local for better code generation - TwoDigitsHex: array[byte] of array[1..2] of AnsiChar; - TwoDigitsHexW: TAnsiCharToWord absolute TwoDigitsHex; - TwoDigitsHexWB: array[byte] of word absolute TwoDigitsHex; - /// lowercase hexadecimal lookup table - TwoDigitsHexLower: array[byte] of array[1..2] of AnsiChar; - TwoDigitsHexWLower: TAnsiCharToWord absolute TwoDigitsHexLower; - TwoDigitsHexWBLower: array[byte] of word absolute TwoDigitsHexLower; - -procedure BinToHex(Bin, Hex: PAnsiChar; BinBytes: integer); -{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} -begin - {$ifdef PUREPASCAL}tab := @TwoDigitsHexW;{$endif} - if BinBytes>0 then - repeat - PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexW{$else}tab{$endif}[Bin^]; - inc(Bin); - inc(Hex,2); - dec(BinBytes); - until BinBytes=0; -end; - -function BinToHex(const Bin: RawByteString): RawUTF8; -var L: integer; -begin - L := length(Bin); - FastSetString(result,nil,L*2); - SynCommons.BinToHex(pointer(Bin),pointer(Result),L); -end; - -function BinToHex(Bin: PAnsiChar; BinBytes: integer): RawUTF8; -begin - FastSetString(result,nil,BinBytes*2); - SynCommons.BinToHex(Bin,pointer(Result),BinBytes); -end; - -function HexToBin(const Hex: RawUTF8): RawByteString; -var L: integer; -begin - result := ''; - L := length(Hex); - if L and 1<>0 then - L := 0 else // hexadecimal should be in char pairs - L := L shr 1; - SetLength(result,L); - if not SynCommons.HexToBin(pointer(Hex),pointer(result),L) then - result := ''; -end; - -function ByteToHex(P: PAnsiChar; Value: byte): PAnsiChar; -begin - PWord(P)^ := TwoDigitsHexWB[Value]; - result := P+2; -end; - -function EscapeBuffer(s,d: PAnsiChar; len,max: integer): PAnsiChar; -var i: integer; -begin - if len>max then - len := max; - for i := 1 to len do begin - if s^ in [' '..#126] then begin - d^ := s^; - inc(d); - end else begin - d^ := '$'; - inc(d); - PWord(d)^ := TwoDigitsHexWB[ord(s^)]; - inc(d,2); - end; - inc(s); - end; - if len=max then begin - PCardinal(d)^ := ord('.')+ord('.')shl 8+ord('.')shl 16; - inc(d,3); - end else - d^ := #0; - result := d; -end; - -function LogEscape(source: PAnsiChar; sourcelen: integer; var temp: TLogEscape; - enabled: boolean): PAnsiChar; -begin - if enabled then begin - temp[0] := ' '; - EscapeBuffer(source,@temp[1],sourcelen,LOGESCAPELEN); - end else - temp[0] := #0; - result := @temp; -end; - -function LogEscapeFull(const source: RawByteString): RawUTF8; -begin - result := LogEscapeFull(pointer(source),length(source)); -end; - -function LogEscapeFull(source: PAnsiChar; sourcelen: integer): RawUTF8; -begin - FastSetString(result,nil,sourcelen*3); // worse case - if sourcelen=0 then - exit; - sourcelen := EscapeBuffer(source,pointer(result),sourcelen,length(result))-pointer(result); - SetLength(result,sourcelen); -end; - -function EscapeToShort(source: PAnsiChar; sourcelen: integer): shortstring; -begin - result[0] := AnsiChar(EscapeBuffer(source,@result[1],sourcelen,80)-@result[1]); -end; - -function EscapeToShort(const source: RawByteString): shortstring; overload; -begin - result[0] := AnsiChar(EscapeBuffer(pointer(source),@result[1],length(source),80)-@result[1]); -end; - -procedure BinToHexDisplay(Bin, Hex: PAnsiChar; BinBytes: integer); -{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} -begin - {$ifdef PUREPASCAL}tab := @TwoDigitsHexW;{$endif} - inc(Hex,BinBytes*2); - if BinBytes>0 then - repeat - dec(Hex,2); - PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexW{$else}tab{$endif}[Bin^]; - inc(Bin); - dec(BinBytes); - until BinBytes=0; -end; - -function BinToHexDisplay(Bin: PAnsiChar; BinBytes: integer): RawUTF8; -begin - FastSetString(result,nil,BinBytes*2); - BinToHexDisplay(Bin,pointer(result),BinBytes); -end; - -procedure BinToHexLower(Bin, Hex: PAnsiChar; BinBytes: integer); -{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} -begin - {$ifdef PUREPASCAL}tab := @TwoDigitsHexWLower;{$endif} - if BinBytes>0 then - repeat - PWord(Hex)^ := {$ifndef PUREPASCAL}TwoDigitsHexWLower{$else}tab{$endif}[Bin^]; - inc(Bin); - inc(Hex,2); - dec(BinBytes); - until BinBytes=0; -end; - -function BinToHexLower(const Bin: RawByteString): RawUTF8; -begin - BinToHexLower(pointer(Bin),length(Bin),result); -end; - -procedure BinToHexLower(Bin: PAnsiChar; BinBytes: integer; var result: RawUTF8); -begin - FastSetString(result,nil,BinBytes*2); - BinToHexLower(Bin,pointer(result),BinBytes); -end; - -function BinToHexLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; -begin - BinToHexLower(Bin,BinBytes,result); -end; - -procedure BinToHexDisplayLower(Bin, Hex: PAnsiChar; BinBytes: PtrInt); -{$ifdef PUREPASCAL}var tab: ^TAnsiCharToWord;{$endif} -begin - if (Bin=nil) or (Hex=nil) or (BinBytes<=0) then - exit; - {$ifdef PUREPASCAL}tab := @TwoDigitsHexWLower;{$endif} - inc(Hex,BinBytes*2); - repeat - dec(Hex,2); - PWord(Hex)^ := {$ifdef PUREPASCAL}tab{$else}TwoDigitsHexWLower{$endif}[Bin^]; - inc(Bin); - dec(BinBytes); - until BinBytes=0; -end; - -function BinToHexDisplayLower(Bin: PAnsiChar; BinBytes: integer): RawUTF8; -begin - FastSetString(result,nil,BinBytes*2); - BinToHexDisplayLower(Bin,pointer(result),BinBytes); -end; - -function BinToHexDisplayLowerShort(Bin: PAnsiChar; BinBytes: integer): shortstring; -begin - if BinBytes>127 then - BinBytes := 127; - result[0] := AnsiChar(BinBytes * 2); - BinToHexDisplayLower(Bin,@result[1],BinBytes); -end; - -function BinToHexDisplayLowerShort16(Bin: Int64; BinBytes: integer): TShort16; -begin - if BinBytes>8 then - BinBytes := 8; - result[0] := AnsiChar(BinBytes * 2); - BinToHexDisplayLower(@Bin,@result[1],BinBytes); -end; - -function BinToHexDisplayFile(Bin: PAnsiChar; BinBytes: integer): TFileName; -{$ifdef UNICODE} -var temp: TSynTempBuffer; -begin - temp.Init(BinBytes*2); - BinToHexDisplayLower(Bin,temp.Buf,BinBytes); - Ansi7ToString(PWinAnsiChar(temp.buf),BinBytes*2,string(result)); - temp.Done; -end; -{$else} -begin - SetString(result,nil,BinBytes*2); - BinToHexDisplayLower(Bin,pointer(result),BinBytes); -end; -{$endif UNICODE} - -procedure PointerToHex(aPointer: Pointer; var result: RawUTF8); -begin - FastSetString(result,nil,SizeOf(Pointer)*2); - BinToHexDisplay(@aPointer,pointer(result),SizeOf(Pointer)); -end; - -function PointerToHex(aPointer: Pointer): RawUTF8; -begin - FastSetString(result,nil,SizeOf(aPointer)*2); - BinToHexDisplay(@aPointer,pointer(result),SizeOf(aPointer)); -end; - -function CardinalToHex(aCardinal: Cardinal): RawUTF8; -begin - FastSetString(result,nil,SizeOf(aCardinal)*2); - BinToHexDisplay(@aCardinal,pointer(result),SizeOf(aCardinal)); -end; - -function CardinalToHexLower(aCardinal: Cardinal): RawUTF8; -begin - FastSetString(result,nil,SizeOf(aCardinal)*2); - BinToHexDisplayLower(@aCardinal,pointer(result),SizeOf(aCardinal)); -end; - -function Int64ToHex(aInt64: Int64): RawUTF8; -begin - FastSetString(result,nil,SizeOf(Int64)*2); - BinToHexDisplay(@aInt64,pointer(result),SizeOf(Int64)); -end; - -procedure Int64ToHex(aInt64: Int64; var result: RawUTF8); -begin - FastSetString(result,nil,SizeOf(Int64)*2); - BinToHexDisplay(@aInt64,pointer(result),SizeOf(Int64)); -end; - -function PointerToHexShort(aPointer: Pointer): TShort16; -begin - result[0] := AnsiChar(SizeOf(aPointer)*2); - BinToHexDisplay(@aPointer,@result[1],SizeOf(aPointer)); -end; - -function CardinalToHexShort(aCardinal: Cardinal): TShort16; -begin - result[0] := AnsiChar(SizeOf(aCardinal)*2); - BinToHexDisplay(@aCardinal,@result[1],SizeOf(aCardinal)); -end; - -function Int64ToHexShort(aInt64: Int64): TShort16; -begin - result[0] := AnsiChar(SizeOf(aInt64)*2); - BinToHexDisplay(@aInt64,@result[1],SizeOf(aInt64)); -end; - -procedure Int64ToHexShort(aInt64: Int64; out result: TShort16); -begin - result[0] := AnsiChar(SizeOf(aInt64)*2); - BinToHexDisplay(@aInt64,@result[1],SizeOf(aInt64)); -end; - -function Int64ToHexString(aInt64: Int64): string; -var temp: TShort16; -begin - Int64ToHexShort(aInt64,temp); - Ansi7ToString(@temp[1],ord(temp[0]),result); -end; - -function UInt3DigitsToUTF8(Value: Cardinal): RawUTF8; -begin - FastSetString(result,nil,3); - PWordArray(result)[0] := TwoDigitLookupW[Value div 10]; - PByteArray(result)[2] := (Value mod 10)+48; -end; - -function UInt4DigitsToUTF8(Value: Cardinal): RawUTF8; -begin - FastSetString(result,nil,4); - if Value>9999 then - Value := 9999; - YearToPChar(Value,pointer(result)); -end; - -function UInt4DigitsToShort(Value: Cardinal): TShort4; -begin - result[0] := #4; - if Value>9999 then - Value := 9999; - YearToPChar(Value,@result[1]); -end; - -function UInt3DigitsToShort(Value: Cardinal): TShort4; -begin - if Value>999 then - Value := 999; - YearToPChar(Value,@result[0]); - result[0] := #3; // override first digit -end; - -function UInt2DigitsToShort(Value: byte): TShort4; -begin - result[0] := #2; - if Value>99 then - Value := 99; - PWord(@result[1])^ := TwoDigitLookupW[Value]; -end; - -function UInt2DigitsToShortFast(Value: byte): TShort4; -begin - result[0] := #2; - PWord(@result[1])^ := TwoDigitLookupW[Value]; -end; - -function SameValue(const A, B: Double; DoublePrec: double): Boolean; -var AbsA,AbsB,Res: double; -begin - if PInt64(@DoublePrec)^=0 then begin // Max(Min(Abs(A),Abs(B))*1E-12,1E-12) - AbsA := Abs(A); - AbsB := Abs(B); - Res := 1E-12; - if AbsAB)-ord(AB)-ord(AB)-ord(AB)-ord(A0) and - (PStrLen(PtrUInt(Values^)-_STRLEN)^=ValueLen) and - CompareMemFixed(pointer(PtrInt(Values^)),pointer(Value),ValueLen) then - exit else - inc(Values) else - for result := 0 to ValuesCount do - if (PtrUInt(Values^)<>0) and // StrIComp() won't change length - (PStrLen(PtrUInt(Values^)-_STRLEN)^=ValueLen) and - (StrIComp(pointer(Values^),pointer(Value))=0) then - exit else - inc(Values); - result := -1; -end; - -function FindPropName(Values: PRawUTF8; const Value: RawUTF8; - ValuesCount: integer): integer; -var ValueLen: TStrLen; -begin - dec(ValuesCount); - ValueLen := length(Value); - if ValueLen=0 then - for result := 0 to ValuesCount do - if Values^='' then - exit else - inc(Values) else - for result := 0 to ValuesCount do - if (PtrUInt(Values^)<>0) and - (PStrLen(PtrUInt(Values^)-_STRLEN)^=ValueLen) and - IdemPropNameUSameLen(pointer(Values^),pointer(Value),ValueLen) then - exit else - inc(Values); - result := -1; -end; - -function FindRawUTF8(const Values: TRawUTF8DynArray; const Value: RawUTF8; - CaseSensitive: boolean): integer; -begin - result := FindRawUTF8(pointer(Values),Value,length(Values),CaseSensitive); -end; - -function FindRawUTF8(const Values: array of RawUTF8; const Value: RawUTF8; - CaseSensitive: boolean): integer; -begin - result := high(Values); - if result>=0 then - result := FindRawUTF8(@Values[0],Value,result+1,CaseSensitive); -end; - -function FindPropName(const Names: array of RawUTF8; const Name: RawUTF8): integer; -begin - result := high(Names); - if result>=0 then - result := FindPropName(@Names[0],Name,result+1); -end; - -function AddRawUTF8(var Values: TRawUTF8DynArray; const Value: RawUTF8; - NoDuplicates, CaseSensitive: boolean): boolean; -var i: integer; -begin - if NoDuplicates then begin - i := FindRawUTF8(Values,Value,CaseSensitive); - if i>=0 then begin - result := false; - exit; - end; - end; - i := length(Values); - SetLength(Values,i+1); - Values[i] := Value; - result := true; -end; - -function NextGrow(capacity: integer): integer; -begin // algorithm similar to TFPList.Expand for the increasing ranges - result := capacity; - if result<128 shl 20 then - if result<8 shl 20 then - if result<=128 then - if result>8 then - inc(result,16) else - inc(result,4) else - inc(result,result shr 2) else - inc(result,result shr 3) else - inc(result,16 shl 20); -end; - -procedure AddRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; - const Value: RawUTF8); -var capacity: integer; -begin - capacity := Length(Values); - if ValuesCount=capacity then - SetLength(Values,NextGrow(capacity)); - Values[ValuesCount] := Value; - inc(ValuesCount); -end; - -function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray): boolean; -var n,i: integer; -begin - result := false; - n := length(A); - if n<>length(B) then - exit; - for i := 0 to n-1 do - if A[i]<>B[i] then - exit; - result := true; -end; - -function RawUTF8DynArrayEquals(const A,B: TRawUTF8DynArray; Count: integer): boolean; -var i: integer; -begin - result := false; - for i := 0 to Count - 1 do - if A[i]<>B[i] then - exit; - result := true; -end; - -procedure StringDynArrayToRawUTF8DynArray(const Source: TStringDynArray; - var Result: TRawUTF8DynArray); -var i: Integer; -begin - Finalize(result); - SetLength(Result,length(Source)); - for i := 0 to length(Source)-1 do - StringToUTF8(Source[i],Result[i]); -end; - -procedure StringListToRawUTF8DynArray(Source: TStringList; var Result: TRawUTF8DynArray); -var i: Integer; -begin - Finalize(result); - SetLength(Result,Source.Count); - for i := 0 to Source.Count-1 do - StringToUTF8(Source[i],Result[i]); -end; - -function FindSectionFirstLine(var source: PUTF8Char; search: PAnsiChar): boolean; -{$ifdef PUREPASCAL} -var tab: PTextCharSet; -begin - result := false; - if source=nil then - exit; - repeat - if source^='[' then begin - inc(source); - result := IdemPChar(source,search); - end; - tab := @TEXT_CHARS; - while tcNot01013 in tab[source^] do inc(source); - while tc1013 in tab[source^] do inc(source); - if result then - exit; // found - until source^=#0; - source := nil; -end; -{$else} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=source edx=search - push eax // save source var - mov eax, [eax] // eax=source - test eax, eax - jz @z - push ebx - mov ebx, edx // save search - cmp byte ptr[eax], '[' - lea eax, [eax + 1] - jne @s -@i: push eax - mov edx, ebx // edx=search - call IdemPChar - pop ecx // ecx=source - jmp @1 -@s: mov ecx, eax - xor eax, eax // result := false -@1: mov dl, [ecx] // while not (source^ in [#0,#10,#13]) do inc(source); - inc ecx - cmp dl, 13 - ja @1 - je @e - or dl, dl - jz @0 - cmp dl, 10 - jne @1 - cmp byte[ecx], 13 - jbe @1 - jmp @4 -@e: cmp byte ptr[ecx], 10 // jump #13#10 - jne @4 - inc ecx -@4: test al, al - jnz @x // exit if IdemPChar returned true - cmp byte ptr[ecx], '[' - lea ecx, [ecx + 1] - jne @1 - mov eax, ecx - jmp @i -@0: xor ecx, ecx // set source=nil -@x: pop ebx - pop edx // restore source var - mov [edx], ecx // update source var - ret -@z: pop edx // ignore source var, result := false -end; -{$endif PUREPASCAL} - -{$ifdef USENORMTOUPPER} -{$ifdef PUREPASCAL} -function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; -begin - result := false; - if (p=nil) or (up=nil) then - exit; - while up^<>#0 do begin - if (p^>#255) or (up^<>AnsiChar(NormToUpperByte[ord(p^)])) then - exit; - inc(up); - inc(p); - end; - result := true; -end; -{$else} -function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=p edx=up - test eax, eax - jz @e // P=nil -> false - test edx, edx - push ebx - push esi - jz @z // up=nil -> true - mov esi, offset NormToUpper - xor ebx, ebx - xor ecx, ecx -@1: mov bx, [eax] // bl=p^ - mov cl, [edx] // cl=up^ - test bh, bh // p^ > #255 -> FALSE - jnz @n - test cl, cl - mov bl, [ebx + esi] // bl=NormToUpper[p^] - jz @z // up^=#0 -> OK - inc edx - add eax, 2 - cmp bl, cl - je @1 -@n: pop esi - pop ebx -@e: xor eax, eax - ret -@z: mov al, 1 // up^=#0 -> OK - pop esi - pop ebx -end; -{$endif PUREPASCAL} -{$else} -function IdemPCharW(p: PWideChar; up: PUTF8Char): boolean; -// if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper) -begin - result := false; - if (p=nil) or (up=nil) then - exit; - while up^<>#0 do begin - if (p^>#255) or (up^<>AnsiChar(NormToUpperByteAnsi7[ord(p^)])) then - exit; - inc(up); - inc(p); - end; - result := true; -end; -{$endif USENORMTOUPPER} - -function FindNameValue(P: PUTF8Char; UpperName: PAnsiChar): PUTF8Char; -var - {$ifdef CPUX86NOTPIC} - table: TNormTable absolute NormToUpperAnsi7; - {$else} - table: PNormTable; - {$endif} - c: AnsiChar; - u: PAnsiChar; -label - _0; -begin - if (P = nil) or (UpperName = nil) then - goto _0; - {$ifndef CPUX86NOTPIC} table := @NormToUpperAnsi7; {$endif} - repeat - c := UpperName^; - if table[P^] = c then - begin - inc(P); - u := UpperName + 1; - repeat - c := u^; - inc(u); - if c <> #0 then - begin - if table[P^] <> c then - break; - inc(P); - continue; - end; - result := P; // if found, points just after UpperName - exit; - until false; - end; - repeat - repeat - c := P^; - inc(P); - until c <= #13; - if c = #13 then // most common case is text ending with #13#10 - repeat - c := P^; - if (c <> #10) and (c <> #13) then - break; - inc(P); - until false - else if c <> #10 then - if c <> #0 then - continue // e.g. #9 - else - goto _0 - else - repeat - c := P^; - if c <> #10 then - break; - inc(P); - until false; - if c <> #0 then - break; // check if UpperName is at the begining of the new line -_0: result := nil; // reached P^=#0 -> not found - exit; - until false; - until false; -end; - -function FindNameValue(const NameValuePairs: RawUTF8; UpperName: PAnsiChar; - var Value: RawUTF8): boolean; -var - P: PUTF8Char; - L: PtrInt; -begin - P := FindNameValue(pointer(NameValuePairs), UpperName); - if P <> nil then - begin - while P^ in [#9, ' '] do // trim left - inc(P); - L := 0; - while P[L] > #13 do // end of line/value - inc(L); - while P[L - 1] = ' ' do // trim right - dec(L); - FastSetString(Value, P, L); - result := true; - end - else - begin - {$ifdef FPC} Finalize(Value); {$else} Value := ''; {$endif} - result := false; - end; -end; - -function FindSectionFirstLineW(var source: PWideChar; search: PUTF8Char): boolean; -{$ifdef PUREPASCAL} -begin - result := false; - if source=nil then - exit; - repeat - if source^='[' then begin - inc(source); - result := IdemPCharW(source,search); - end; - while not (cardinal(source^) in [0,10,13]) do inc(source); - while cardinal(source^) in [10,13] do inc(source); - if result then - exit; // found - until source^=#0; - source := nil; -end; -{$else} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=source edx=search - push eax // save source var - mov eax, [eax] // eax=source - test eax, eax - jz @z - push ebx - mov ebx, edx // save search - cmp word ptr[eax], '[' - lea eax, [eax + 2] - jne @s -@i: push eax - mov edx, ebx // edx=search - call IdemPCharW - pop ecx // ecx=source - jmp @1 -@s: mov ecx, eax - xor eax, eax // result := false -@1: mov dx, [ecx] // while not (source^ in [#0,#10,#13]) do inc(source) - add ecx, 2 - cmp dx, 13 - ja @1 - je @e - or dx, dx - jz @0 - cmp dx, 10 - jne @1 - jmp @4 -@e: cmp word ptr[ecx], 10 // jump #13#10 - jne @4 - add ecx, 2 -@4: test al, al - jnz @x // exit if IdemPChar returned true - cmp word ptr[ecx], '[' - lea ecx, [ecx + 2] - jne @1 - mov eax, ecx - jmp @i -@0: xor ecx, ecx // set source=nil -@x: pop ebx - pop edx // restore source var - mov [edx], ecx // update source var - ret -@z: pop edx // ignore source var, result := false -end; -{$endif PUREPASCAL} - -function FindIniNameValue(P: PUTF8Char; UpperName: PAnsiChar): RawUTF8; -var u, PBeg: PUTF8Char; - by4: cardinal; - table: {$ifdef CPUX86NOTPIC}TNormTable absolute NormToUpperAnsi7{$else}PNormTable{$endif}; -begin // expect UpperName as 'NAME=' - if (P<>nil) and (P^<>'[') and (UpperName<>nil) then begin - {$ifndef CPUX86NOTPIC}table := @NormToUpperAnsi7;{$endif} - PBeg := nil; - u := P; - repeat - while u^=' ' do inc(u); // trim left ' ' - if u^=#0 then - break; - if table[u^]=UpperName[0] then - PBeg := u; - repeat - by4 := PCardinal(u)^; - if ToByte(by4)>13 then - if ToByte(by4 shr 8)>13 then - if ToByte(by4 shr 16)>13 then - if ToByte(by4 shr 24)>13 then begin - inc(u,4); - continue; - end else - inc(u,3) else - inc(u,2) else - inc(u); - if u^ in [#0,#10,#13] then - break else - inc(u); - until false; - if PBeg<>nil then begin - inc(PBeg); - P := u; - u := pointer(UpperName+1); - repeat - if u^<>#0 then - if table[PBeg^]<>u^ then - break else begin - inc(u); - inc(PBeg); - end else begin - FastSetString(result,PBeg,P-PBeg); - exit; - end; - until false; - PBeg := nil; - u := P; - end; - if u^=#13 then inc(u); - if u^=#10 then inc(u); - until u^ in [#0,'[']; - end; - result := ''; -end; - -function ExistsIniName(P: PUTF8Char; UpperName: PAnsiChar): boolean; -var table: PNormTable; -begin - result := false; - table := @NormToUpperAnsi7; - if (P<>nil) and (P^<>'[') then - repeat - if P^=' ' then begin - repeat inc(P) until P^<>' '; // trim left ' ' - if P^=#0 then - break; - end; - if IdemPChar2(table,P,UpperName) then begin - result := true; - exit; - end; - repeat - if P[0]>#13 then - if P[1]>#13 then - if P[2]>#13 then - if P[3]>#13 then begin - inc(P,4); - continue; - end else - inc(P,3) else - inc(P,2) else - inc(P); - case P^ of - #0: exit; - #10: begin inc(P); break; end; - #13: begin if P[1]=#10 then inc(P,2) else inc(P); break; end; - else inc(P); - end; - until false; - until P^='['; -end; - -function ExistsIniNameValue(P: PUTF8Char; const UpperName: RawUTF8; - const UpperValues: array of PAnsiChar): boolean; -var PBeg: PUTF8Char; -begin - result := true; - if high(UpperValues)>=0 then - while (P<>nil) and (P^<>'[') do begin - if P^=' ' then repeat inc(P) until P^<>' '; // trim left ' ' - PBeg := P; - if IdemPChar(PBeg,pointer(UpperName)) then begin - inc(PBeg,length(UpperName)); - if IdemPCharArray(PBeg,UpperValues)>=0 then - exit; // found one value - break; - end; - P := GotoNextLine(P); - end; - result := false; -end; - -function GetSectionContent(SectionFirstLine: PUTF8Char): RawUTF8; -var PBeg: PUTF8Char; -begin - PBeg := SectionFirstLine; - while (SectionFirstLine<>nil) and (SectionFirstLine^<>'[') do - SectionFirstLine := GotoNextLine(SectionFirstLine); - if SectionFirstLine=nil then - result := PBeg else - FastSetString(result,PBeg,SectionFirstLine-PBeg); -end; - -function GetSectionContent(const Content, SectionName: RawUTF8): RawUTF8; -var P: PUTF8Char; - UpperSection: array[byte] of AnsiChar; -begin - P := pointer(Content); - PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']'); - if FindSectionFirstLine(P,UpperSection) then - result := GetSectionContent(P) else - result := ''; -end; - -function DeleteSection(var Content: RawUTF8; const SectionName: RawUTF8; - EraseSectionHeader: boolean): boolean; -var P: PUTF8Char; - UpperSection: array[byte] of AnsiChar; -begin - result := false; // no modification - P := pointer(Content); - PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']'); - if FindSectionFirstLine(P,UpperSection) then - result := DeleteSection(P,Content,EraseSectionHeader); -end; - -function DeleteSection(SectionFirstLine: PUTF8Char; var Content: RawUTF8; - EraseSectionHeader: boolean): boolean; -var PEnd: PUTF8Char; - IndexBegin: PtrInt; -begin - result := false; - PEnd := SectionFirstLine; - if EraseSectionHeader then // erase [Section] header line - while (PtrUInt(SectionFirstLine)>PtrUInt(Content)) and (SectionFirstLine^<>'[') do dec(SectionFirstLine); - while (PEnd<>nil) and (PEnd^<>'[') do - PEnd := GotoNextLine(PEnd); - IndexBegin := SectionFirstLine-pointer(Content); - if IndexBegin=0 then - exit; // no modification - if PEnd=nil then - SetLength(Content,IndexBegin) else - delete(Content,IndexBegin+1,PEnd-SectionFirstLine); - result := true; // Content was modified -end; - -procedure ReplaceSection(SectionFirstLine: PUTF8Char; - var Content: RawUTF8; const NewSectionContent: RawUTF8); -var PEnd: PUTF8Char; - IndexBegin: PtrInt; -begin - if SectionFirstLine=nil then - exit; - // delete existing [Section] content - PEnd := SectionFirstLine; - while (PEnd<>nil) and (PEnd^<>'[') do - PEnd := GotoNextLine(PEnd); - IndexBegin := SectionFirstLine-pointer(Content); - if PEnd=nil then - SetLength(Content,IndexBegin) else - delete(Content,IndexBegin+1,PEnd-SectionFirstLine); - // insert section content - insert(NewSectionContent,Content,IndexBegin+1); -end; - -procedure ReplaceSection(var Content: RawUTF8; const SectionName, - NewSectionContent: RawUTF8); -var UpperSection: array[byte] of AnsiChar; - P: PUTF8Char; -begin - P := pointer(Content); - PWord(UpperCopy255(UpperSection,SectionName))^ := ord(']'); - if FindSectionFirstLine(P,UpperSection) then - ReplaceSection(P,Content,NewSectionContent) else - Content := Content+'['+SectionName+']'#13#10+NewSectionContent; -end; - -function FindIniNameValueInteger(P: PUTF8Char; UpperName: PAnsiChar): PtrInt; -begin - result := GetInteger(pointer(FindIniNameValue(P,UpperName))); -end; - -function FindIniEntry(const Content, Section, Name: RawUTF8): RawUTF8; -var P: PUTF8Char; - UpperSection, UpperName: array[byte] of AnsiChar; - // possible GPF if length(Section/Name)>255, but should const in code -begin - result := ''; - P := pointer(Content); - if P=nil then exit; - // UpperName := UpperCase(Name)+'='; - PWord(UpperCopy255(UpperName,Name))^ := ord('='); - if Section='' then - // find the Name= entry before any [Section] - result := FindIniNameValue(P,UpperName) else begin - // find the Name= entry in the specified [Section] - PWord(UpperCopy255(UpperSection,Section))^ := ord(']'); - if FindSectionFirstLine(P,UpperSection) then - result := FindIniNameValue(P,UpperName); - end; -end; - -function FindWinAnsiIniEntry(const Content, Section,Name: RawUTF8): RawUTF8; -begin - result := WinAnsiToUtf8(WinAnsiString(FindIniEntry(Content,Section,Name))); -end; - -function FindIniEntryInteger(const Content,Section,Name: RawUTF8): integer; -begin - result := GetInteger(pointer(FindIniEntry(Content,Section,Name))); -end; - -function FindIniEntryFile(const FileName: TFileName; const Section,Name: RawUTF8): RawUTF8; -var Content: RawUTF8; -begin - Content := StringFromFile(FileName); - if Content='' then - result := '' else - result := FindIniEntry(Content,Section,Name); -end; - -function UpdateIniNameValueInternal(var Content: RawUTF8; - const NewValue, NewValueCRLF: RawUTF8; var P: PUTF8Char; - UpperName: PAnsiChar; UpperNameLength: integer): boolean; -var PBeg: PUTF8Char; - i: integer; -begin - while (P<>nil) and (P^<>'[') do begin - while P^=' ' do inc(P); // trim left ' ' - PBeg := P; - P := GotoNextLine(P); - if IdemPChar(PBeg,UpperName) then begin - // update Name=Value entry - result := true; - inc(PBeg,UpperNameLength); - i := (PBeg-pointer(Content))+1; - if (i=length(NewValue)) and CompareMem(PBeg,pointer(NewValue),i) then - exit; // new Value is identical to the old one -> no change - if P=nil then // avoid last line (P-PBeg) calculation error - SetLength(Content,i-1) else - delete(Content,i,P-PBeg); // delete old Value - insert(NewValueCRLF,Content,i); // set new value - exit; - end; - end; - result := false; -end; - -function UpdateIniNameValue(var Content: RawUTF8; const Name, UpperName, NewValue: RawUTF8): boolean; -var P: PUTF8Char; -begin - if UpperName='' then - result := false else begin - P := pointer(Content); - result := UpdateIniNameValueInternal(Content,NewValue,NewValue+#13#10,P, - pointer(UpperName),length(UpperName)); - if result or (Name='') then - exit; - if Content<>'' then - Content := Content+#13#10; - Content := Content+Name+NewValue; - result := true; - end; -end; - -procedure UpdateIniEntry(var Content: RawUTF8; const Section,Name,Value: RawUTF8); -const CRLF = #13#10; -var P: PUTF8Char; - SectionFound: boolean; - i, UpperNameLength: PtrInt; - V: RawUTF8; - UpperSection, UpperName: array[byte] of AnsiChar; -label Sec; -begin - UpperNameLength := length(Name); - PWord(UpperCopy255Buf(UpperName,pointer(Name),UpperNameLength))^ := ord('='); - inc(UpperNameLength); - V := Value+CRLF; - P := pointer(Content); - // 1. find Section, and try update within it - if Section='' then - goto Sec; // find the Name= entry before any [Section] - SectionFound := false; - PWord(UpperCopy255(UpperSection,Section))^ := ord(']'); - if FindSectionFirstLine(P,UpperSection) then begin -Sec:SectionFound := true; - if UpdateIniNameValueInternal(Content,Value,V,P,@UpperName,UpperNameLength) then - exit; - // we reached next [Section] without having found Name= - end; - // 2. section or Name= entry not found: add Name=Value - V := Name+'='+V; - if not SectionFound then - // create not existing [Section] - V := '['+Section+(']'+CRLF)+V; - // insert Name=Value at P^ (end of file or end of [Section]) - if P=nil then - // insert at end of file - Content := Content+V else begin - // insert at end of [Section] - i := (P-pointer(Content))+1; - insert(V,Content,i); - end; -end; - -procedure UpdateIniEntryFile(const FileName: TFileName; const Section,Name,Value: RawUTF8); -var Content: RawUTF8; -begin - Content := StringFromFile(FileName); - UpdateIniEntry(Content,Section,Name,Value); - FileFromString(Content,FileName); -end; - -function StringFromFile(const FileName: TFileName; HasNoSize: boolean): RawByteString; -var F: THandle; - Read, Size, Chunk: integer; - P: PUTF8Char; - tmp: array[0..$7fff] of AnsiChar; -begin - result := ''; - if FileName='' then - exit; - F := FileOpenSequentialRead(FileName); - if PtrInt(F)>=0 then begin - if HasNoSize then begin - Size := 0; - repeat - Read := FileRead(F,tmp,SizeOf(tmp)); - if Read<=0 then - break; - SetLength(result,Size+Read); // in-place resize - MoveFast(tmp,PByteArray(result)^[Size],Read); - inc(Size,Read); - until false; - end else begin - Size := GetFileSize(F,nil); - if Size>0 then begin - SetLength(result,Size); - P := pointer(result); - repeat - Chunk := Size; - {$ifdef MSWINDOWS} // FILE_FLAG_SEQUENTIAL_SCAN has limits on XP - if Chunk>32 shl 20 then - Chunk := 32 shl 20; // avoid e.g. ERROR_NO_SYSTEM_RESOURCES - {$endif} - Read := FileRead(F,P^,Chunk); - if Read<=0 then begin - result := ''; - break; - end; - inc(P,Read); - dec(Size,Read); - until Size=0; - end; - end; - FileClose(F); - end; -end; - -function FileFromString(const Content: RawByteString; const FileName: TFileName; - FlushOnDisk: boolean; FileDate: TDateTime): boolean; -var F: THandle; - P: PByte; - L,written: integer; -begin - result := false; - if FileName='' then - exit; - F := FileCreate(FileName); - if PtrInt(F)<0 then - exit; - L := length(Content); - P := pointer(Content); - while L>0 do begin - written := FileWrite(F,P^,L); - if written<0 then begin - FileClose(F); - exit; - end; - dec(L,written); - inc(P,written); - end; - if FlushOnDisk then - FlushFileBuffers(F); - {$ifdef MSWINDOWS} - if FileDate<>0 then - FileSetDate(F,DateTimeToFileDate(FileDate)); - FileClose(F); - {$else} - FileClose(F); - if FileDate<>0 then - FileSetDate(FileName,DateTimeToFileDate(FileDate)); - {$endif MSWINDOWS} - result := true; -end; - -type - TTextFileKind = (isUnicode, isUTF8, isAnsi); - -function TextFileKind(const Map: TMemoryMap): TTextFileKind; -begin - result := isAnsi; - if (Map.Buffer<>nil) and (Map.Size>3) then - if PWord(Map.Buffer)^=$FEFF then - result := isUnicode else - if (PWord(Map.Buffer)^=$BBEF) and (PByteArray(Map.Buffer)[2]=$BF) then - result := isUTF8; -end; - -function AnyTextFileToSynUnicode(const FileName: TFileName; ForceUTF8: boolean): SynUnicode; -var Map: TMemoryMap; -begin - result := ''; - if Map.Map(FileName) then - try - if ForceUTF8 then - UTF8ToSynUnicode(PUTF8Char(Map.Buffer),Map.Size,Result) else - case TextFileKind(Map) of - isUnicode: - SetString(result,PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1); - isUTF8: - UTF8ToSynUnicode(PUTF8Char(pointer(PtrUInt(Map.Buffer)+3)),Map.Size-3,Result); - isAnsi: - result := CurrentAnsiConvert.AnsiToUnicodeString(Map.Buffer, Map.Size); - end; - finally - Map.UnMap; - end; -end; - -function AnyTextFileToRawUTF8(const FileName: TFileName; AssumeUTF8IfNoBOM: boolean): RawUTF8; -var Map: TMemoryMap; -begin - result := ''; - if Map.Map(FileName) then - try - case TextFileKind(Map) of - isUnicode: - RawUnicodeToUtf8(PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1,Result); - isUTF8: - FastSetString(result,pointer(PtrUInt(Map.Buffer)+3),Map.Size-3); - isAnsi: - if AssumeUTF8IfNoBOM then - FastSetString(result,Map.Buffer,Map.Size) else - result := CurrentAnsiConvert.AnsiBufferToRawUTF8(Map.Buffer, Map.Size); - end; - finally - Map.UnMap; - end; -end; - -function AnyTextFileToString(const FileName: TFileName; ForceUTF8: boolean): string; -var Map: TMemoryMap; -begin - result := ''; - if Map.Map(FileName) then - try - if ForceUTF8 then -{$ifdef UNICODE} - UTF8DecodeToString(PUTF8Char(Map.Buffer),Map.Size,result) {$else} - result := CurrentAnsiConvert.UTF8BufferToAnsi(PUTF8Char(Map.Buffer),Map.Size) -{$endif} else - case TextFileKind(Map) of -{$ifdef UNICODE} - isUnicode: - SetString(result,PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1); - isUTF8: - UTF8DecodeToString(pointer(PtrUInt(Map.Buffer)+3),Map.Size-3,result); - isAnsi: - result := CurrentAnsiConvert.AnsiToUnicodeString(Map.Buffer,Map.Size); -{$else} - isUnicode: - result := CurrentAnsiConvert.UnicodeBufferToAnsi(PWideChar(PtrUInt(Map.Buffer)+2),(Map.Size-2) shr 1); - isUTF8: - result := CurrentAnsiConvert.UTF8BufferToAnsi(pointer(PtrUInt(Map.Buffer)+3),Map.Size-3); - isAnsi: - SetString(result,PAnsiChar(Map.Buffer),Map.Size); -{$endif UNICODE} - end; - finally - Map.UnMap; - end; -end; - -function StreamToRawByteString(aStream: TStream): RawByteString; -var current, size: Int64; -begin - result := ''; - if aStream=nil then - exit; - current := aStream.Position; - if (current=0) and aStream.InheritsFrom(TRawByteStringStream) then begin - result := TRawByteStringStream(aStream).DataString; // fast COW - exit; - end; - size := aStream.Size-current; - if (size=0) or (size>maxInt) then - exit; - SetLength(result,size); - aStream.Read(pointer(result)^,size); - aStream.Position := current; -end; - -function RawByteStringToStream(const aString: RawByteString): TStream; -begin - result := TRawByteStringStream.Create(aString); -end; - -function ReadStringFromStream(S: TStream; MaxAllowedSize: integer): RawUTF8; -var L: integer; -begin - result := ''; - L := 0; - if (S.Read(L,4)<>4) or (L<=0) or (L>MaxAllowedSize) then - exit; - FastSetString(result,nil,L); - if S.Read(pointer(result)^,L)<>L then - result := ''; -end; - -function WriteStringToStream(S: TStream; const Text: RawUTF8): boolean; -var L: integer; -begin - L := length(Text); - if L=0 then - result := S.Write(L,4)=4 else - {$ifdef FPC} - result := (S.Write(L,4)=4) and (S.Write(pointer(Text)^,L)=L); - {$else} - result := S.Write(pointer(PtrInt(Text)-SizeOf(integer))^,L+4)=L+4; - {$endif FPC} -end; - -function GetFileNameWithoutExt(const FileName: TFileName; - Extension: PFileName): TFileName; -var i, max: PtrInt; -begin - i := length(FileName); - max := i-16; - while (i>0) and not(cardinal(FileName[i]) in [ord('\'),ord('/'),ord('.')]) - and (i>=max) do dec(i); - if (i=0) or (FileName[i]<>'.') then begin - result := FileName; - if Extension<>nil then - Extension^ := ''; - end else begin - result := copy(FileName,1,i-1); - if Extension<>nil then - Extension^ := copy(FileName,i,20); - end; -end; - -function GetFileNameExtIndex(const FileName, CSVExt: TFileName): integer; -var Ext: TFileName; - P: PChar; -begin - result := -1; - P := pointer(CSVExt); - Ext := ExtractFileExt(FileName); - if (P=nil) or (Ext='') or (Ext[1]<>'.') then - exit; - delete(Ext,1,1); - repeat - inc(result); - if SameText(GetNextItemString(P),Ext) then - exit; - until P=nil; - result := -1; -end; - -function FileSize(const FileName: TFileName): Int64; -{$ifdef MSWINDOWS} -var FA: WIN32_FILE_ATTRIBUTE_DATA; -begin // 5 times faster than CreateFile, GetFileSizeEx, CloseHandle - if GetFileAttributesEx(pointer(FileName),GetFileExInfoStandard,@FA) then begin - PInt64Rec(@result)^.Lo := FA.nFileSizeLow; - PInt64Rec(@result)^.Hi := FA.nFileSizeHigh; - end else - result := 0; -end; -{$else} -var f: THandle; - res: Int64Rec absolute result; -begin - result := 0; - f := FileOpen(FileName,fmOpenRead or fmShareDenyNone); - if PtrInt(f)>0 then begin - res.Lo := GetFileSize(f,@res.Hi); // from SynKylix/SynFPCLinux - FileClose(f); - end; -end; -{$endif MSWINDOWS} - -function FileSize(F: THandle): Int64; -var res: Int64Rec absolute result; -begin - result := 0; - if PtrInt(F)>0 then - res.Lo := GetFileSize(F,@res.Hi); // from WinAPI or SynKylix/SynFPCLinux -end; - -function FileInfoByHandle(aFileHandle: THandle; out FileId, FileSize, - LastWriteAccess, FileCreateDateTime: Int64): Boolean; -var - lastreadaccess: TUnixMSTime; - {$ifdef MSWINDOWS} - lp: TByHandleFileInformation; - {$else} - lp: {$ifdef FPC}stat{$else}TStatBuf64{$endif}; - r: integer; - {$endif MSWINDOWS} -begin -{$ifdef MSWINDOWS} - result := GetFileInformationByHandle(aFileHandle,lp); - if not result then - exit; - LastWriteAccess := FileTimeToUnixMSTime(lp.ftLastWriteTime); - FileCreateDateTime := FileTimeToUnixMSTime(lp.ftCreationTime); - lastreadaccess := FileTimeToUnixMSTime(lp.ftLastAccessTime); - PInt64Rec(@FileSize).lo := lp.nFileSizeLow; - PInt64Rec(@FileSize).hi := lp.nFileSizeHigh; - PInt64Rec(@FileId).lo := lp.nFileIndexLow; - PInt64Rec(@FileId).hi := lp.nFileIndexHigh; -{$else} - r := {$ifdef FPC}FpFStat{$else}fstat64{$endif}(aFileHandle, lp); - result := r >= 0; - if not result then - exit; - FileId := lp.st_ino; - FileSize := lp.st_size; - lastreadaccess := lp.st_atime * MSecsPerSec; - LastWriteAccess := lp.st_mtime * MSecsPerSec; - {$ifdef OPENBSD} - if (lp.st_birthtime <> 0) and (lp.st_birthtime < lp.st_ctime) then - lp.st_ctime:= lp.st_birthtime; - {$endif} - FileCreateDateTime := lp.st_ctime * MSecsPerSec; -{$endif MSWINDOWS} - if LastWriteAccess <> 0 then - if (FileCreateDateTime = 0) or (FileCreateDateTime > LastWriteAccess) then - FileCreateDateTime:= LastWriteAccess; - if lastreadaccess <> 0 then - if (FileCreateDateTime = 0) or (FileCreateDateTime > lastreadaccess) then - FileCreateDateTime:= lastreadaccess; -end; - -function FileAgeToDateTime(const FileName: TFileName): TDateTime; -{$ifdef MSWINDOWS} -var FA: WIN32_FILE_ATTRIBUTE_DATA; - ST,LT: TSystemTime; -begin // 5 times faster than CreateFile, GetFileSizeEx, CloseHandle - if GetFileAttributesEx(pointer(FileName),GetFileExInfoStandard,@FA) and - FileTimeToSystemTime(FA.ftLastWriteTime,ST) and - SystemTimeToTzSpecificLocalTime(nil,ST,LT) then - result := SystemTimeToDateTime(LT) else - result := 0; -end; -{$else} -{$ifdef HASNEWFILEAGE} -begin - if not FileAge(FileName,result) then -{$else} -var Age: integer; -begin - Age := FileAge(FileName); - if Age<>-1 then - result := FileDateToDateTime(Age) else -{$endif HASNEWFILEAGE} - result := 0; -end; -{$endif MSWINDOWS} - -function CopyFile(const Source, Target: TFileName; FailIfExists: boolean): boolean; -{$ifdef MSWINDOWS} -begin - result := Windows.CopyFile(pointer(Source),pointer(Target),FailIfExists); -end; -{$else} -var SourceF, DestF: TFileStream; -begin - result := false; - if FailIfExists then - if FileExists(Target) then - exit else - DeleteFile(Target); - try - SourceF := TFileStream.Create(Source,fmOpenRead); - try - DestF := TFileStream.Create(Target,fmCreate); - try - DestF.CopyFrom(SourceF, SourceF.Size); - finally - DestF.Free; - end; - FileSetDateFrom(Target,SourceF.Handle); - finally - SourceF.Free; - end; - result := true; - except - result := false; - end; -end; -{$endif} - -function SearchRecToDateTime(const F: TSearchRec): TDateTime; -begin - {$ifdef ISDELPHIXE} - result := F.Timestamp; - {$else} - result := FileDateToDateTime(F.Time); - {$endif} -end; - -function SearchRecValidFile(const F: TSearchRec): boolean; -begin - {$ifndef DELPHI5OROLDER} - {$WARN SYMBOL_DEPRECATED OFF} // for faVolumeID - {$endif} - result := (F.Name<>'') and (F.Attr and (faDirectory - {$ifdef MSWINDOWS}+faVolumeID+faSysFile+faHidden)=0) and (F.Name[1]<>'.') - {$else})=0){$endif}; - {$ifndef DELPHI5OROLDER} - {$WARN SYMBOL_DEPRECATED ON} - {$endif} -end; - -function SearchRecValidFolder(const F: TSearchRec): boolean; -begin - result := (F.Attr and (faDirectory {$ifdef MSWINDOWS}+faHidden{$endif})=faDirectory) and - (F.Name<>'') and (F.Name<>'.') and (F.Name<>'..'); -end; - -function DirectoryDelete(const Directory: TFileName; const Mask: TFileName; - DeleteOnlyFilesNotDirectory: Boolean; DeletedCount: PInteger): Boolean; -var F: TSearchRec; - Dir: TFileName; - n: integer; -begin - n := 0; - result := true; - if DirectoryExists(Directory) then begin - Dir := IncludeTrailingPathDelimiter(Directory); - if FindFirst(Dir+Mask,faAnyFile-faDirectory,F)=0 then begin - repeat - if SearchRecValidFile(F) then - if DeleteFile(Dir+F.Name) then - inc(n) else - result := false; - until FindNext(F)<>0; - FindClose(F); - end; - if not DeleteOnlyFilesNotDirectory and not RemoveDir(Dir) then - result := false; - end; - if DeletedCount<>nil then - DeletedCount^ := n; -end; - -function DirectoryDeleteOlderFiles(const Directory: TFileName; TimePeriod: TDateTime; - const Mask: TFileName; Recursive: Boolean; TotalSize: PInt64): Boolean; -var F: TSearchRec; - Dir: TFileName; - old: TDateTime; -begin - if not Recursive and (TotalSize<>nil) then - TotalSize^ := 0; - result := true; - if (Directory='') or not DirectoryExists(Directory) then - exit; - Dir := IncludeTrailingPathDelimiter(Directory); - if FindFirst(Dir+Mask,faAnyFile,F)=0 then begin - old := Now - TimePeriod; - repeat - if F.Name[1]<>'.' then - if Recursive and (F.Attr and faDirectory<>0) then - DirectoryDeleteOlderFiles(Dir+F.Name,TimePeriod,Mask,true,TotalSize) else - if SearchRecValidFile(F) and (SearchRecToDateTime(F) < old) then - if not DeleteFile(Dir+F.Name) then - result := false else - if TotalSize<>nil then - inc(TotalSize^,F.Size); - until FindNext(F)<>0; - FindClose(F); - end; -end; - -procedure TFindFiles.FromSearchRec(const Directory: TFileName; const F: TSearchRec); -begin - Name := Directory+F.Name; - {$ifdef MSWINDOWS} - {$ifdef HASINLINE} // FPC or Delphi 2006+ - Size := F.Size; - {$else} // F.Size was limited to 32-bit on older Delphi - PInt64Rec(@Size)^.Lo := F.FindData.nFileSizeLow; - PInt64Rec(@Size)^.Hi := F.FindData.nFileSizeHigh; - {$endif} - {$else} - Size := F.Size; - {$endif} - Attr := F.Attr; - Timestamp := SearchRecToDateTime(F); -end; - -function TFindFiles.ToText: shortstring; -begin - FormatShort('% % %',[Name,KB(Size),DateTimeToFileShort(Timestamp)],result); -end; - -function FindFiles(const Directory,Mask,IgnoreFileName: TFileName; - SortByName,IncludesDir,SubFolder: boolean): TFindFilesDynArray; -var m,count: integer; - dir: TFileName; - da: TDynArray; - masks: TRawUTF8DynArray; - masked: TFindFilesDynArray; - procedure SearchFolder(const folder : TFileName); - var - F: TSearchRec; - ff: TFindFiles; - begin - if FindFirst(dir+folder+Mask,faAnyfile-faDirectory,F)=0 then begin - repeat - if SearchRecValidFile(F) and ((IgnoreFileName='') or - (AnsiCompareFileName(F.Name,IgnoreFileName)<>0)) then begin - if IncludesDir then - ff.FromSearchRec(dir+folder,F) else - ff.FromSearchRec(folder,F); - da.Add(ff); - end; - until FindNext(F)<>0; - FindClose(F); - end; - if SubFolder and (FindFirst(dir+folder+'*',faDirectory,F)=0) then begin - repeat - if SearchRecValidFolder(F) and ((IgnoreFileName='') or - (AnsiCompareFileName(F.Name,IgnoreFileName)<>0)) then - SearchFolder(IncludeTrailingPathDelimiter(folder+F.Name)); - until FindNext(F)<>0; - FindClose(F); - end; - end; -begin - result := nil; - da.Init(TypeInfo(TFindFilesDynArray),result,@count); - if Pos(';',Mask)>0 then - CSVToRawUTF8DynArray(pointer(StringToUTF8(Mask)),masks,';'); - if masks<>nil then begin - if SortByName then - QuickSortRawUTF8(masks,length(masks),nil,{$ifdef MSWINDOWS}@StrIComp{$else}@StrComp{$endif}); - for m := 0 to length(masks)-1 do begin // masks[] recursion - masked := FindFiles(Directory,UTF8ToString(masks[m]), - IgnoreFileName,SortByName,IncludesDir,SubFolder); - da.AddArray(masked); - end; - end else begin - if Directory<>'' then - dir := IncludeTrailingPathDelimiter(Directory); - SearchFolder(''); - if SortByName and (da.Count>0) then - da.Sort(SortDynArrayFileName); - end; - da.Capacity := count; // trim result[] -end; - -function FindFilesDynArrayToFileNames(const Files: TFindFilesDynArray): TFileNameDynArray; -var i,n: PtrInt; -begin - Finalize(result); - n := length(Files); - SetLength(result,n); - for i := 0 to n-1 do - result[i] := Files[i].Name; -end; - -function SynchFolders(const Reference, Dest: TFileName; - SubFolder,ByContent,WriteFileNameToConsole: boolean): integer; -var ref,dst: TFileName; - fref,fdst: TSearchRec; - reftime: TDateTime; - s: RawByteString; -begin - result := 0; - ref := IncludeTrailingPathDelimiter(Reference); - dst := IncludeTrailingPathDelimiter(Dest); - if DirectoryExists(ref) and (FindFirst(dst+FILES_ALL,faAnyFile,fdst)=0) then begin - repeat - if SearchRecValidFile(fdst) then begin - if ByContent then - reftime := FileAgeToDateTime(ref+fdst.Name) else - if FindFirst(ref+fdst.Name,faAnyFile,fref)=0 then begin - reftime := SearchRecToDateTime(fref); - if (fdst.Size=fref.Size) and (SearchRecToDateTime(fdst)=reftime) then - reftime := 0; - FindClose(fref); - end else - reftime := 0; // "continue" trigger unexpected warning on Delphi - if reftime=0 then - continue; // skip if no reference file to copy from - s := StringFromFile(ref+fdst.Name); - if (s='') or (ByContent and (length(s)=fdst.Size) and - (DefaultHasher(0,pointer(s),fdst.Size)=HashFile(dst+fdst.Name))) then - continue; - FileFromString(s,dst+fdst.Name,false,reftime); - inc(result); - if WriteFileNameToConsole then - {$I-} writeln('synched ',dst,fdst.name); {$I+} - end else if SubFolder and SearchRecValidFolder(fdst) then - inc(result,SynchFolders(ref+fdst.Name,dst+fdst.Name,SubFolder,ByContent,WriteFileNameToConsole)); - until FindNext(fdst)<>0; - FindClose(fdst); - end; -end; - -function EnsureDirectoryExists(const Directory: TFileName; - RaiseExceptionOnCreationFailure: boolean): TFileName; -begin - result := IncludeTrailingPathDelimiter(ExpandFileName(Directory)); - if not DirectoryExists(result) then - if not CreateDir(result) then - if not RaiseExceptionOnCreationFailure then - result := '' else - raise ESynException.CreateUTF8('Impossible to create folder %',[result]); -end; - -var - TemporaryFileNameRandom: integer; - -function TemporaryFileName: TFileName; -var folder: TFileName; -begin // fast cross-platform implementation - folder := GetSystemPath(spTempFolder); - if TemporaryFileNameRandom=0 then - TemporaryFileNameRandom := Random32gsl; - repeat // thread-safe unique file name generation - FormatString('%%_%.tmp',[folder,ExeVersion.ProgramName, - CardinalToHexShort(InterlockedIncrement(TemporaryFileNameRandom))],string(result)); - until not FileExists(result); -end; - -function IsDirectoryWritable(const Directory: TFileName): boolean; -var fn: TFileName; -begin - fn := ExcludeTrailingPathDelimiter(Directory); - result := {$ifndef DELPHI5OROLDER}not FileIsReadOnly{$else}DirectoryExists{$endif}(fn); - if not result then - exit; - fn := FormatString('%%.%%',[fn,PathDelim,CardinalToHexShort(integer(GetCurrentThreadID)), - BinToBase64uriShort(@ExeVersion.Hash,SizeOf(ExeVersion.Hash))]); - result := FileFromString('tobedeleted',fn); // actually try to write something - DeleteFile(fn); -end; - -{$ifdef DELPHI5OROLDER} - -function DirectoryExists(const Directory: string): boolean; -var Code: Integer; -begin - Code := GetFileAttributes(pointer(Directory)); - result := (Code<>-1) and (FILE_ATTRIBUTE_DIRECTORY and Code<>0); -end; - -function SameFileName(const S1, S2: TFileName): Boolean; -begin - result := AnsiCompareFileName(S1,S2)=0; -end; - -function GetEnvironmentVariable(const Name: string): string; -var Len: Integer; - Buffer: array[0..1023] of Char; -begin - Result := ''; - Len := Windows.GetEnvironmentVariable(pointer(Name),@Buffer,SizeOf(Buffer)); - if Len 0 then - Error := EOSError.CreateFmt('System Error. Code: %d.'#13#10'%s', - [LastError,SysErrorMessage(LastError)]) else - Error := EOSError.Create('A call to an OS function failed'); - Error.ErrorCode := LastError; - raise Error; -end; - -{$endif DELPHI5OROLDER} - -{$ifdef DELPHI6OROLDER} -procedure VarCastError; -begin - raise EVariantError.Create('Variant Type Cast Error'); -end; -{$endif} - -{$ifdef MSWINDOWS} -function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean; -var FileTime: TFileTime; - D: THandle; -begin - D := FileOpen(Dest,fmOpenWrite); - if D<>THandle(-1) then begin - result := GetFileTime(SourceHandle,nil,nil,@FileTime) and - SetFileTime(D,nil,nil,@FileTime); - FileClose(D); - end else - result := false; -end; -{$else} -function FileSetDateFrom(const Dest: TFileName; SourceHandle: integer): boolean; -begin - result := FileSetDate(Dest,FileGetDate(SourceHandle))=0; -end; -{$endif} - -{$IFDEF PUREPASCAL} -{$IFNDEF HASCODEPAGE} -function Pos(const substr, str: RawUTF8): Integer; overload; -begin // the RawByteString version is fast enough - Result := PosEx(substr,str,1); -end; -{$ENDIF} -{$ENDIF} - -function FindObjectEntry(const Content, Name: RawUTF8): RawUTF8; -var L: integer; -begin - result := Trim(FindIniEntry(Content,'',Name+' ')); // 'Name = Value' format - if (result<>'') and (result[1]='''') then begin - L := length(result); - if result[L]='''' then - result := copy(result,2,L-2); // 'testDI6322.IAS' -> testDI6322.IAS - end; -end; - -function FindObjectEntryWithoutExt(const Content, Name: RawUTF8): RawUTF8; -begin - result := RawUTF8(GetFileNameWithoutExt( - ExtractFileName(TFileName(FindObjectEntry(Content,Name))))); -end; - - -function Int64ScanExists(P: PInt64Array; Count: PtrInt; const Value: Int64): boolean; -begin - if P<>nil then begin - result := true; - Count := PtrInt(@P[Count-4]); - repeat - if PtrUInt(P)>PtrUInt(Count) then - break; - if (P^[0]=Value) or (P^[1]=Value) or (P^[2]=Value) or (P^[3]=Value) then - exit; - P := @P[4]; - until false; - inc(Count,4*SizeOf(Value)); - repeat - if PtrUInt(P)>=PtrUInt(Count) then - break; - if P^[0]=Value then - exit else - P := @P[1]; - until false; - end; - result := false; -end; - -function Int64Scan(P: PInt64Array; Count: PtrInt; const Value: Int64): PInt64; -begin - result := nil; - if P=nil then - exit; - Count := PtrInt(@P[Count-4]); - repeat - if PtrUInt(P)>PtrUInt(Count) then - break; - if P^[0]<>Value then - if P^[1]<>Value then - if P^[2]<>Value then - if P^[3]<>Value then begin - P := @P[4]; - continue; - end else - result := @P[3] else - result := @P[2] else - result := @P[1] else - result := pointer(P); - exit; - until false; - inc(Count,4*SizeOf(Value)); - result := pointer(P); - repeat - if PtrUInt(result)>=PtrUInt(Count) then - break; - if result^=Value then - exit else - inc(result); - until false; - result := nil; -end; - -function AddInteger(var Values: TIntegerDynArray; Value: integer; - NoDuplicates: boolean): boolean; -var n: PtrInt; -begin - n := Length(Values); - if NoDuplicates and IntegerScanExists(pointer(Values),n,Value) then begin - result := false; - exit; - end; - SetLength(Values,n+1); - Values[n] := Value; - result := true -end; - -procedure AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; - Value: integer); -begin - if ValuesCount=length(Values) then - SetLength(Values,NextGrow(ValuesCount)); - Values[ValuesCount] := Value; - inc(ValuesCount); -end; - -function AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; - Value: integer; NoDuplicates: boolean): boolean; -begin - if NoDuplicates and IntegerScanExists(pointer(Values),ValuesCount,Value) then begin - result := false; - exit; - end; - if ValuesCount=length(Values) then - SetLength(Values,NextGrow(ValuesCount)); - Values[ValuesCount] := Value; - inc(ValuesCount); - result := true; -end; - -function AddInteger(var Values: TIntegerDynArray; const Another: TIntegerDynArray): PtrInt; -var v,a: PtrInt; -begin - v := length(Values); - a := length(Another); - if a>0 then begin - SetLength(Values,v+a); - MoveFast(Another[0],Values[v],a*SizeOf(Integer)); - end; - result := v+a; -end; - -function AddWord(var Values: TWordDynArray; var ValuesCount: integer; Value: Word): PtrInt; -begin - result := ValuesCount; - if result=length(Values) then - SetLength(Values,NextGrow(result)); - Values[result] := Value; - inc(ValuesCount); -end; - -function AddInt64(var Values: TInt64DynArray; var ValuesCount: integer; Value: Int64): PtrInt; -begin - result := ValuesCount; - if result=length(Values) then - SetLength(Values,NextGrow(result)); - Values[result] := Value; - inc(ValuesCount); -end; - -function AddInt64(var Values: TInt64DynArray; Value: Int64): PtrInt; -begin - result := length(Values); - SetLength(Values,result+1); - Values[result] := Value; -end; - -function AddInt64(var Values: TInt64DynArray; const Another: TInt64DynArray): PtrInt; -var v,a: PtrInt; -begin - v := length(Values); - a := length(Another); - if a>0 then begin - SetLength(Values,v+a); - MoveFast(Another[0],Values[v],a*SizeOf(Int64)); - end; - result := v+a; -end; - -procedure AddInt64Sorted(var Values: TInt64DynArray; Value: Int64); -var last: integer; -begin - last := high(Values); - if FastFindInt64Sorted(pointer(Values),last,Value)<0 then begin - inc(last); - SetLength(Values,last+1); - Values[last] := Value; - QuickSortInt64(pointer(Values),0,last); - end; -end; - -function AddInt64Once(var Values: TInt64DynArray; Value: Int64): PtrInt; -begin - result := Int64ScanIndex(pointer(Values),length(Values),Value); - if result<0 then - result := AddInt64(Values,Value); -end; - -procedure DynArrayMakeUnique(Values: PPointer; TypeInfo: pointer); -var da: TDynArray; - n: PtrInt; -begin // caller ensured that Values<>nil, Values^<>nil and RefCnt>1 - da.Init(TypeInfo,Values^); - n := PDALen(PPtrUInt(Values)^-_DALEN)^{$ifdef FPC}+1{$endif}; - da.InternalSetLength(n,n); // make copy -end; - -procedure DeleteWord(var Values: TWordDynArray; Index: PtrInt); -var n: PtrInt; -begin - n := Length(Values); - if PtrUInt(Index)>=PtrUInt(n) then - exit; // wrong Index - dec(n); - if n>Index then begin - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TWordDynArray)); - MoveFast(Values[Index+1],Values[Index],(n-Index)*SizeOf(Word)); - end; - SetLength(Values,n); -end; - -procedure DeleteInteger(var Values: TIntegerDynArray; Index: PtrInt); -var n: PtrInt; -begin - n := Length(Values); - if PtrUInt(Index)>=PtrUInt(n) then - exit; // wrong Index - dec(n); - if n>Index then begin - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); - MoveFast(Values[Index+1],Values[Index],(n-Index)*SizeOf(Integer)); - end; - SetLength(Values,n); -end; - -procedure DeleteInteger(var Values: TIntegerDynArray; var ValuesCount: Integer; Index: PtrInt); -var n: PtrInt; -begin - n := ValuesCount; - if PtrUInt(Index)>=PtrUInt(n) then - exit; // wrong Index - dec(n,Index+1); - if n>0 then begin - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); - MoveFast(Values[Index+1],Values[Index],n*SizeOf(Integer)); - end; - dec(ValuesCount); -end; - -procedure DeleteInt64(var Values: TInt64DynArray; Index: PtrInt); -var n: PtrInt; -begin - n := Length(Values); - if PtrUInt(Index)>=PtrUInt(n) then - exit; // wrong Index - dec(n); - if n>Index then begin - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TInt64DynArray)); - MoveFast(Values[Index+1],Values[Index],(n-Index)*SizeOf(Int64)); - end; - SetLength(Values,n); -end; - -procedure DeleteInt64(var Values: TInt64DynArray; var ValuesCount: Integer; Index: PtrInt); -var n: PtrInt; -begin - n := ValuesCount; - if PtrUInt(Index)>=PtrUInt(n) then - exit; // wrong Index - dec(n,Index+1); - if n>0 then begin - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TInt64DynArray)); - MoveFast(Values[Index+1],Values[Index],n*SizeOf(Int64)); - end; - dec(ValuesCount); -end; - -procedure ExcludeInteger(var Values, Excluded: TIntegerDynArray; ExcludedSortSize: integer); -var i,v,x,n: PtrInt; -begin - if (Values=nil) or (Excluded=nil) then - exit; // nothing to exclude - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); - if PDACnt(PtrUInt(Excluded)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Excluded,TypeInfo(TIntegerDynArray)); - v := length(Values); - n := 0; - x := Length(Excluded); - if (x>ExcludedSortSize) or (v>ExcludedSortSize) then begin // sort if worth it - dec(x); - QuickSortInteger(pointer(Excluded),0,x); - for i := 0 to v-1 do - if FastFindIntegerSorted(pointer(Excluded),x,Values[i])<0 then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - end else - for i := 0 to v-1 do - if not IntegerScanExists(pointer(Excluded),x,Values[i]) then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - if n<>v then - SetLength(Values,n); -end; - -procedure IncludeInteger(var Values, Included: TIntegerDynArray; - IncludedSortSize: Integer); -var i,v,x,n: PtrInt; -begin - if (Values=nil) or (Included=nil) then begin - Values := nil; - exit; - end; - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TIntegerDynArray)); - if PDACnt(PtrUInt(Included)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Included,TypeInfo(TIntegerDynArray)); - v := length(Values); - n := 0; - x := Length(Included); - if (x>IncludedSortSize) or (v>IncludedSortSize) then begin // sort if worth it - dec(x); - QuickSortInteger(pointer(Included),0,x); - for i := 0 to v-1 do - if FastFindIntegerSorted(pointer(Included),x,Values[i])>=0 then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - end else - for i := 0 to v-1 do - if IntegerScanExists(pointer(Included),x,Values[i]) then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - if n<>v then - SetLength(Values,n); -end; - -procedure ExcludeInt64(var Values, Excluded: TInt64DynArray; ExcludedSortSize: Integer); -var i,v,x,n: PtrInt; -begin - if (Values=nil) or (Excluded=nil) then - exit; // nothing to exclude - v := length(Values); - n := 0; - x := Length(Excluded); - if (x>ExcludedSortSize) or (v>ExcludedSortSize) then begin // sort if worth it - dec(x); - QuickSortInt64(pointer(Excluded),0,x); - for i := 0 to v-1 do - if FastFindInt64Sorted(pointer(Excluded),x,Values[i])<0 then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - end else - for i := 0 to v-1 do - if not Int64ScanExists(pointer(Excluded),x,Values[i]) then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - if n<>v then - SetLength(Values,n); -end; - -procedure IncludeInt64(var Values, Included: TInt64DynArray; - IncludedSortSize: integer); -var i,v,x,n: PtrInt; -begin - if (Values=nil) or (Included=nil) then begin - Values := nil; - exit; - end; - v := length(Values); - n := 0; - x := Length(Included); - if (x>IncludedSortSize) or (v>IncludedSortSize) then begin // sort if worth it - dec(x); - QuickSortInt64(pointer(Included),0,x); - for i := 0 to v-1 do - if FastFindInt64Sorted(pointer(Included),x,Values[i])>=0 then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - end else - for i := 0 to v-1 do - if Int64ScanExists(pointer(Included),x,Values[i]) then begin - if n<>i then - Values[n] := Values[i]; - inc(n); - end; - if n<>v then - SetLength(Values,n); -end; - -procedure DeduplicateInteger(var Values: TIntegerDynArray); -begin - DeduplicateInteger(Values, length(Values)); -end; - -function DeduplicateIntegerSorted(val: PIntegerArray; last: PtrInt): PtrInt; -var i: PtrInt; -begin // sub-function for better code generation - i := 0; - repeat // here last>0 so ilast then - continue; - result := i; - exit; - until false; - result := i; - inc(i); - if i<>last then begin - repeat - if val[i]<>val[i+1] then begin - val[result] := val[i]; - inc(result); - end; - inc(i); - until i=last; - val[result] := val[i]; - end; -end; - -function DeduplicateInteger(var Values: TIntegerDynArray; Count: integer): integer; -begin - result := Count; - dec(Count); - if Count>0 then begin - QuickSortInteger(pointer(Values),0,Count); - result := DeduplicateIntegerSorted(pointer(Values),Count)+1; - end; - if result<>length(Values) then - SetLength(Values,result); -end; - -procedure DeduplicateInt64(var Values: TInt64DynArray); -begin - DeduplicateInt64(Values, length(Values)); -end; - -function DeduplicateInt64Sorted(val: PInt64Array; last: PtrInt): PtrInt; -var i: PtrInt; -begin // sub-function for better code generation - i := 0; - repeat // here last>0 so ilast then - continue; - result := i; - exit; - until false; - result := i; - inc(i); - if i<>last then begin - repeat - if val[i]<>val[i+1] then begin - val[result] := val[i]; - inc(result); - end; - inc(i); - until i=last; - val[result] := val[i]; - end; -end; - -function DeduplicateInt64(var Values: TInt64DynArray; Count: integer): integer; -begin - result := Count; - dec(Count); - if Count>0 then begin - QuickSortInt64(pointer(Values),0,Count); - result := DeduplicateInt64Sorted(pointer(Values),Count)+1; - end; - if result<>length(Values) then - SetLength(Values,result); -end; - -procedure CopyInteger(const Source: TIntegerDynArray; out Dest: TIntegerDynArray); -var n: integer; -begin - n := length(Source); - SetLength(Dest,n); - MoveFast(Source[0],Dest[0],n*SizeOf(Integer)); -end; - -procedure CopyInt64(const Source: TInt64DynArray; out Dest: TInt64DynArray); -var n: integer; -begin - n := length(Source); - SetLength(Dest,n); - MoveFast(Source[0],Dest[0],n*SizeOf(Int64)); -end; - -function MaxInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt; MaxStart: integer): Integer; -var i: PtrInt; - v: integer; -begin - result := MaxStart; - for i := 0 to ValuesCount-1 do begin - v := Values[i]; - if v>result then - result := v; // branchless opcode on FPC - end; -end; - -function SumInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt): Integer; -var i: PtrInt; -begin - result := 0; - for i := 0 to ValuesCount-1 do - inc(result,Values[i]); -end; - -procedure Reverse(const Values: TIntegerDynArray; ValuesCount: PtrInt; - Reversed: PIntegerArray); -var i: PtrInt; -begin - i := 0; - if ValuesCount>=4 then begin - dec(ValuesCount,4); - while i0 then - if StartValue=0 then - for i := 0 to Count-1 do - Values[i] := i else - for i := 0 to Count-1 do begin - Values[i] := StartValue; - inc(StartValue); - end; -end; - -procedure Int64ToUInt32(Values64: PInt64Array; Values32: PCardinalArray; Count: PtrInt); -var i: PtrInt; -begin - for i := 0 to Count-1 do - Values32[i] := Values64[i]; -end; - -procedure CSVToIntegerDynArray(CSV: PUTF8Char; var Result: TIntegerDynArray; Sep: AnsiChar); -begin - while CSV<>nil do begin - SetLength(Result,length(Result)+1); - Result[high(Result)] := GetNextItemInteger(CSV,Sep); - end; -end; - -procedure CSVToInt64DynArray(CSV: PUTF8Char; var Result: TInt64DynArray; Sep: AnsiChar); -begin - while CSV<>nil do begin - SetLength(Result,length(Result)+1); - Result[high(Result)] := GetNextItemInt64(CSV,Sep); - end; -end; - -function CSVToInt64DynArray(CSV: PUTF8Char; Sep: AnsiChar): TInt64DynArray; -begin - Finalize(result); - while CSV<>nil do begin - SetLength(Result,length(Result)+1); - Result[high(Result)] := GetNextItemInt64(CSV,Sep); - end; -end; - -function IntegerDynArrayToCSV(Values: PIntegerArray; ValuesCount: integer; - const Prefix, Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; -type - TInts16 = packed array[word] of string[15]; // shortstring are faster (no heap allocation) -var i, L, Len: PtrInt; - tmp: array[0..15] of AnsiChar; - ints: ^TInts16; - P: PAnsiChar; - tmpbuf: TSynTempBuffer; -begin - result := ''; - if ValuesCount=0 then - exit; - if InlinedValue then - Len := 4*ValuesCount else - Len := 0; - tmpbuf.Init(ValuesCount*SizeOf(ints[0])+Len); // faster than a dynamic array - try - ints := tmpbuf.buf; - // compute whole result length at once - dec(ValuesCount); - inc(Len,length(Prefix)+length(Suffix)); - tmp[15] := ','; - for i := 0 to ValuesCount do begin - P := StrInt32(@tmp[15],Values[i]); - L := @tmp[15]-P; - if i'' then begin - L := length(Prefix); - MoveSmall(pointer(Prefix),P,L); - inc(P,L); - end; - for i := 0 to ValuesCount do begin - if InlinedValue then begin - PWord(P)^ := ord(':')+ord('(')shl 8; - inc(P,2); - end; - L := ord(ints[i][0]); - MoveSmall(@ints[i][1],P,L); - inc(P,L); - if InlinedValue then begin - PWord(P)^ := ord(')')+ord(':')shl 8; - inc(P,2); - end; - end; - if Suffix<>'' then - MoveSmall(pointer(Suffix),P,length(Suffix)); - finally - tmpbuf.Done; - end; -end; - -function Int64DynArrayToCSV(Values: PInt64Array; ValuesCount: integer; - const Prefix, Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; -type - TInt = packed record - Len: byte; - Val: array[0..19] of AnsiChar; // Int64: 19 digits, then - sign - end; -var i, L, Len: PtrInt; - int: ^TInt; - P: PAnsiChar; - tmp: TSynTempBuffer; -begin - result := ''; - if ValuesCount=0 then - exit; - if InlinedValue then - Len := 4*ValuesCount else - Len := 0; - int := tmp.Init(ValuesCount*SizeOf(TInt)+Len); // faster than a dynamic array - try - // compute whole result length at once - dec(ValuesCount); - inc(Len,length(Prefix)+length(Suffix)); - for i := 0 to ValuesCount do begin - P := StrInt64(PAnsiChar(int)+21,Values[i]); - L := PAnsiChar(int)+21-P; - int^.Len := L; - if i'' then begin - L := length(Prefix); - MoveSmall(pointer(Prefix),P,L); - inc(P,L); - end; - int := tmp.buf; - repeat - if InlinedValue then begin - PWord(P)^ := ord(':')+ord('(')shl 8; - inc(P,2); - end; - L := int^.Len; - MoveSmall(PAnsiChar(int)+21-L,P,L); - inc(P,L); - if InlinedValue then begin - PWord(P)^ := ord(')')+ord(':')shl 8; - inc(P,2); - end; - if ValuesCount=0 then - break; - inc(int); - P^ := ','; - inc(P); - dec(ValuesCount); - until false; - if Suffix<>'' then - MoveSmall(pointer(Suffix),P,length(Suffix)); - finally - tmp.Done; - end; -end; - -function IntegerDynArrayToCSV(const Values: TIntegerDynArray; - const Prefix, Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; -begin - result := IntegerDynArrayToCSV(pointer(Values),length(Values),Prefix,Suffix,InlinedValue); -end; - -function Int64DynArrayToCSV(const Values: TInt64DynArray; - const Prefix: RawUTF8; const Suffix: RawUTF8; InlinedValue: boolean): RawUTF8; -begin - result := Int64DynArrayToCSV(pointer(Values),length(Values),Prefix,Suffix,InlinedValue); -end; - -function Int64ScanIndex(P: PInt64Array; Count: PtrInt; const Value: Int64): PtrInt; -begin - result := 0; - dec(Count,8); - if P<>nil then begin - repeat - if result>Count then - break; - if P^[result]<>Value then - if P^[result+1]<>Value then - if P^[result+2]<>Value then - if P^[result+3]<>Value then - if P^[result+4]<>Value then - if P^[result+5]<>Value then - if P^[result+6]<>Value then - if P^[result+7]<>Value then begin - inc(result,8); - continue; - end else - inc(result,7) else - inc(result,6) else - inc(result,5) else - inc(result,4) else - inc(result,3) else - inc(result,2) else - inc(result); - exit; - until false; - inc(Count,8); - repeat - if result>=Count then - break; - if P^[result]=Value then - exit else - inc(result); - until false; - end; - result := -1; -end; - -function QWordScanIndex(P: PQWordArray; Count: PtrInt; const Value: QWord): PtrInt; -begin - result := Int64ScanIndex(pointer(P),Count,Value); // this is the very same code -end; - -function PtrUIntScan(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): pointer; -{$ifdef HASINLINE} -begin - result := {$ifdef CPU64}Int64Scan{$else}IntegerScan{$endif}(pointer(P),Count,Value); -end; -{$else} -asm - jmp IntegerScan -end; -{$endif HASINLINE} - -function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean; -{$ifdef HASINLINE} -begin - result := {$ifdef CPU64}Int64ScanExists{$else}IntegerScanExists{$endif}(pointer(P),Count,Value); -end; -{$else} -asm - jmp IntegerScanExists; -end; -{$endif HASINLINE} - -function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt; -{$ifdef HASINLINE} -begin - result := {$ifdef CPU64}Int64ScanIndex{$else}IntegerScanIndex{$endif}(pointer(P),Count,Value); -end; -{$else} -asm // identical to IntegerScanIndex() asm stub - push eax - call IntegerScan - pop edx - test eax, eax - jnz @e - dec eax // returns -1 - ret -@e: sub eax, edx - shr eax, 2 -end; -{$endif HASINLINE} - -function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: Byte): PtrInt; -begin -{$ifdef FPC} - result := IndexByte(P^,Count,Value); // will use fast FPC SSE version -{$else} - result := 0; - if P<>nil then - repeat - if result>=Count then - break; - if P^[result]=Value then - exit else - inc(result); - until false; - result := -1; -{$endif FPC} -end; - -function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): PtrInt; -begin -{$ifdef FPC} - result := IndexWord(P^,Count,Value); // will use fast FPC SSE version -{$else} - result := 0; - if P<>nil then - repeat - if result>=Count then - break; - if P^[result]=Value then - exit else - inc(result); - until false; - result := -1; -{$endif FPC} -end; - -function AnyScanIndex(P,Elem: pointer; Count,ElemSize: PtrInt): PtrInt; -begin - case ElemSize of - // optimized versions for arrays of byte,word,integer,Int64,Currency,Double - 1: result := ByteScanIndex(P,Count,PByte(Elem)^); - 2: result := WordScanIndex(P,Count,PWord(Elem)^); - 4: result := IntegerScanIndex(P,Count,PInteger(Elem)^); - 8: result := Int64ScanIndex(P,Count,PInt64(Elem)^); - // small ElemSize version (=0; - 2: result := WordScanIndex(P,Count,PInteger(Elem)^)>=0; - 4: result := IntegerScanExists(P,Count,PInteger(Elem)^); - 8: result := Int64ScanExists(P,Count,PInt64(Elem)^); - // small ElemSize version (0 then - repeat - if CompareMemSmall(P,Elem,ElemSize) then - exit; - inc(PByte(P),ElemSize); - dec(Count); - until Count=0; - result := false; - end; - else begin // generic binary comparison (fast with leading 64-bit comparison) - result := true; - if Count>0 then - repeat - if (PInt64(P)^=PInt64(Elem)^) and - CompareMemSmall(PAnsiChar(P)+8,PAnsiChar(Elem)+8,ElemSize-8) then - exit; - inc(PByte(P),ElemSize); - dec(Count); - until Count=0; - result := false; - end; - end; -end; - - -procedure QuickSortInteger(ID: PIntegerArray; L,R: PtrInt); -var I, J, P: PtrInt; - tmp: integer; -begin - if L=tmp; - if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; - if I <= J then begin - tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortInteger(ID, L, J); - L := I; - end else begin - if I < R then - QuickSortInteger(ID, I, R); - R := J; - end; - until L >= R; -end; - -procedure QuickSortInteger(var ID: TIntegerDynArray); -begin - QuickSortInteger(pointer(ID),0,high(ID)); -end; - -procedure QuickSortInteger(ID,CoValues: PIntegerArray; L,R: PtrInt); -var I, J, P: PtrInt; - tmp: integer; -begin - if L=tmp; - if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; - if I <= J then begin - tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; - tmp := CoValues[J]; CoValues[J] := CoValues[I]; CoValues[I] := tmp; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortInteger(ID, CoValues, L, J); - L := I; - end else begin - if I < R then - QuickSortInteger(ID, CoValues, I, R); - R := J; - end; - until L >= R; -end; - -procedure QuickSortWord(ID: PWordArray; L, R: PtrInt); -var I, J, P: PtrInt; - tmp: word; -begin - if L=tmp; - if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; - if I <= J then begin - tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortWord(ID, L, J); - L := I; - end else begin - if I < R then - QuickSortWord(ID, I, R); - R := J; - end; - until L >= R; -end; - -procedure QuickSortInt64(ID: PInt64Array; L, R: PtrInt); -var I, J, P: PtrInt; - tmp: Int64; -begin - if L=tmp; - if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; - {$else} - while ID[I]ID[P] do dec(J); - {$endif} - if I <= J then begin - tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortInt64(ID, L, J); - L := I; - end else begin - if I < R then - QuickSortInt64(ID, I, R); - R := J; - end; - until L >= R; -end; - -procedure QuickSortQWord(ID: PQWordArray; L, R: PtrInt); -var I, J, P: PtrInt; - tmp: QWord; -begin - if L0 do dec(J); - {$else} - tmp := ID[P]; - if ID[I]=tmp; - if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; - {$endif} - if I <= J then begin - tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortQWord(ID, L, J); - L := I; - end else begin - if I < R then - QuickSortQWord(ID, I, R); - R := J; - end; - until L >= R; -end; - -procedure QuickSortInt64(ID,CoValues: PInt64Array; L, R: PtrInt); -var I, J, P: PtrInt; - tmp: Int64; -begin - if L=tmp; - if ID[J]>tmp then repeat dec(J) until ID[J]<=tmp; - {$else} - while ID[I]ID[P] do dec(J); - {$endif} - if I <= J then begin - tmp := ID[J]; ID[J] := ID[I]; ID[I] := tmp; - tmp := CoValues[J]; CoValues[J] := CoValues[I]; CoValues[I] := tmp; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortInt64(ID, CoValues, L, J); - L := I; - end else begin - if I < R then - QuickSortInt64(ID, CoValues, I, R); - R := J; - end; - until L >= R; -end; - -procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt); -begin - {$ifdef CPU64} - QuickSortInt64(PInt64Array(P),L,R); - {$else} - QuickSortInteger(PIntegerArray(P),L,R); - {$endif} -end; - -function FastFindPtrIntSorted(P: PPtrIntArray; R: PtrInt; Value: PtrInt): PtrInt; -begin - {$ifdef CPU64} - result := FastFindInt64Sorted(PInt64Array(P),R,Value); - {$else} - result := FastFindIntegerSorted(PIntegerArray(P),R,Value); - {$endif} -end; - -procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt); -begin - {$ifdef CPU64} - QuickSortInt64(PInt64Array(P),L,R); - {$else} - QuickSortInteger(PIntegerArray(P),L,R); - {$endif} -end; - -function FastFindPointerSorted(P: PPointerArray; R: PtrInt; Value: pointer): PtrInt; -begin - {$ifdef CPU64} - result := FastFindInt64Sorted(PInt64Array(P),R,Int64(Value)); - {$else} - result := FastFindIntegerSorted(PIntegerArray(P),R,integer(Value)); - {$endif} -end; - -procedure NotifySortedIntegerChanges(old, new: PIntegerArray; oldn, newn: PtrInt; - const added, deleted: TOnNotifySortedIntegerChange; const sender); -var o, n: PtrInt; -begin - o := 0; - n := 0; - repeat - while (n=newn) or (old[o]=oldn) or (new[n]=oldn) and (n>=newn); -end; - -procedure CopyAndSortInteger(Values: PIntegerArray; ValuesCount: integer; - var Dest: TIntegerDynArray); -begin - if ValuesCount>length(Dest) then - SetLength(Dest,ValuesCount); - MoveFast(Values^[0],Dest[0],ValuesCount*SizeOf(Integer)); - QuickSortInteger(pointer(Dest),0,ValuesCount-1); -end; - -procedure CopyAndSortInt64(Values: PInt64Array; ValuesCount: integer; - var Dest: TInt64DynArray); -begin - if ValuesCount>length(Dest) then - SetLength(Dest,ValuesCount); - MoveFast(Values^[0],Dest[0],ValuesCount*SizeOf(Int64)); - QuickSortInt64(pointer(Dest),0,ValuesCount-1); -end; - -function FastFindIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt; -{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8d/edx -{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif} - xor r9, r9 // r9=L rax=result - test R, R - jl @ko - lea rax, [r9 + R] -{$ifdef FPC} align 8 {$else} .align 8 {$endif} -@s: shr rax, 1 - lea r10, qword ptr[rax - 1] // efficient branchless binary search - lea r11, qword ptr[rax + 1] - cmp Value, dword ptr[P + rax * 4] - je @ok - cmovl R, r10 - cmovg r9, r11 - lea rax, [r9 + R] - cmp r9, R - jle @s -@ko: or rax, -1 -@ok: -end; -{$else} -var L: PtrInt; - cmp: integer; -begin - L := 0; - if 0<=R then - repeat - result := (L + R) shr 1; - cmp := P^[result]-Value; - if cmp=0 then - exit; - if cmp<0 then begin - L := result+1; - if L<=R then - continue; - break; - end; - R := result-1; - if L<=R then - continue; - break; - until false; - result := -1 -end; -{$endif CPUX64} - - -function FastFindIntegerSorted(const Values: TIntegerDynArray; Value: integer): PtrInt; -begin - result := FastFindIntegerSorted(pointer(Values),length(Values)-1,Value); -end; - -function FastFindInt64Sorted(P: PInt64Array; R: PtrInt; const Value: Int64): PtrInt; -{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8d/edx -{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif} - xor r9, r9 // r9=L rax=result - test R, R - jl @ko - lea rax, [r9 + R] -{$ifdef FPC} align 8 {$else} .align 8 {$endif} -@s: shr rax, 1 - lea r10, qword ptr[rax - 1] // efficient branchless binary search - lea r11, qword ptr[rax + 1] - cmp Value, qword ptr[P + rax * 8] - je @ok - cmovl R, r10 - cmovg r9, r11 - lea rax, [r9 + R] - cmp r9, R - jle @s -@ko: or rax, -1 -@ok: -end; -{$else} -var L: PtrInt; - {$ifdef CPUX86} - cmp: Integer; - {$endif} -begin - L := 0; - if 0<=R then - repeat - result := (L + R) shr 1; - {$ifndef CPUX86} - if P^[result]=Value then - exit else - if P^[result] R; - while (i>=0) and (P^[i]>=Value) do dec(i); - result := i+1; // return the index where to insert - end; -end; - -function AddSortedInteger(var Values: TIntegerDynArray; var ValuesCount: integer; - Value: integer; CoValues: PIntegerDynArray): PtrInt; -begin - result := FastLocateIntegerSorted(pointer(Values),ValuesCount-1,Value); - if result>=0 then // if Value exists -> fails - result := InsertInteger(Values,ValuesCount,Value,result,CoValues); -end; - -function AddSortedInteger(var Values: TIntegerDynArray; - Value: integer; CoValues: PIntegerDynArray): PtrInt; -var ValuesCount: integer; -begin - ValuesCount := length(Values); - result := FastLocateIntegerSorted(pointer(Values),ValuesCount-1,Value); - if result>=0 then begin // if Value exists -> fails - SetLength(Values,ValuesCount+1); // manual size increase - result := InsertInteger(Values,ValuesCount,Value,result,CoValues); - end; -end; - -function TSortedIntegerArray.Add(aValue: Integer): PtrInt; -begin - result := Count; // optimistic check of perfectly increasing aValue - if (result>0) and (aValue<=Values[result-1]) then - result := FastLocateIntegerSorted(pointer(Values),result-1,aValue); - if result<0 then // aValue already exists in Values[] -> fails - exit; - if Count=length(Values) then - SetLength(Values,NextGrow(Count)); - if resultnil then - SetLength(CoValues^,n); - end; - n := ValuesCount; - if PtrUInt(result)nil then - MoveFast(CoValues^[result],CoValues^[result+1],n); - end else - result := n; - Values[result] := Value; - inc(ValuesCount); -end; - -function TIntegerDynArrayFrom(const Values: array of integer): TIntegerDynArray; -var i: PtrInt; -begin - Finalize(result); - SetLength(result,length(Values)); - for i := 0 to high(Values) do - result[i] := Values[i]; -end; - -function TIntegerDynArrayFrom64(const Values: TInt64DynArray; - raiseExceptionOnOverflow: boolean): TIntegerDynArray; -var i: PtrInt; -const MinInt = -MaxInt-1; -begin - Finalize(result); - SetLength(result,length(Values)); - for i := 0 to length(Values)-1 do - if Values[i]>MaxInt then - if raiseExceptionOnOverflow then - raise ESynException.CreateUTF8('TIntegerDynArrayFrom64: Values[%]=%>%', - [i,Values[i],MaxInt]) else - result[i] := MaxInt else - if Values[i]ord(' ') then - break; - inc(P); - c := byte(P^); - until false; - if c=ord('-') then begin - minus := true; - repeat inc(P); c := byte(P^); until c<>ord(' '); - end else begin - minus := false; - if c=ord('+') then - repeat inc(P); c := byte(P^); until c<>ord(' '); - end; - dec(c,48); - if c>9 then - exit; - result := c; - repeat - inc(P); - c := byte(P^); - dec(c,48); - if c>9 then - break; - result := result*10+PtrInt(c); - until false; - if minus then - result := -result; -end; - -function GetInteger(P,PEnd: PUTF8Char): PtrInt; -var c: byte; - minus: boolean; -begin - result := 0; - if (P=nil) or (P>=PEnd) then - exit; - c := byte(P^); - repeat - if c=0 then - exit; - if c>ord(' ') then - break; - inc(P); - if P=PEnd then - exit; - c := byte(P^); - until false; - if c=ord('-') then begin - minus := true; - repeat inc(P); if P=PEnd then exit; c := byte(P^); until c<>ord(' '); - end else begin - minus := false; - if c=ord('+') then - repeat inc(P); if P=PEnd then exit; c := byte(P^); until c<>ord(' '); - end; - dec(c,48); - if c>9 then - exit; - result := c; - repeat - inc(P); - if P=PEnd then - break; - c := byte(P^); - dec(c,48); - if c>9 then - break; - result := result*10+PtrInt(c); - until false; - if minus then - result := -result; -end; - -function GetInteger(P: PUTF8Char; var err: integer): PtrInt; -var c: byte; - minus: boolean; -begin - result := 0; - err := 1; // don't return the exact index, just 1 as error flag - if P=nil then - exit; - c := byte(P^); - repeat - if c=0 then - exit; - if c>ord(' ') then - break; - inc(P); - c := byte(P^); - until false; - if c=ord('-') then begin - minus := true; - repeat inc(P); c := byte(P^); until c<>ord(' '); - end else begin - minus := false; - if c=ord('+') then - repeat inc(P); c := byte(P^); until c<>ord(' '); - end; - dec(c,48); - if c>9 then - exit; - result := c; - repeat - inc(P); - c := byte(P^); - dec(c,48); - if c<=9 then - result := result*10+PtrInt(c) else - if c<>256-48 then - exit else - break; - until false; - err := 0; // success - if minus then - result := -result; -end; - -function GetIntegerDef(P: PUTF8Char; Default: PtrInt): PtrInt; -var err: integer; -begin - result := GetInteger(P,err); - if err<>0 then - result := Default; -end; - -function UTF8ToInteger(const value: RawUTF8; Default: PtrInt=0): PtrInt; -var err: integer; -begin - result := GetInteger(pointer(value),err); - if err<>0 then - result := Default; -end; - -function UTF8ToInteger(const value: RawUTF8; Min,max: PtrInt; Default: PtrInt=0): PtrInt; -var err: integer; -begin - result := GetInteger(pointer(value),err); - if (err<>0) or (resultmax) then - result := Default; -end; - -function ToInteger(const text: RawUTF8; out value: integer): boolean; -var err: integer; -begin - value := GetInteger(pointer(text),err); - result := err=0; -end; - -function ToCardinal(const text: RawUTF8; out value: cardinal; minimal: cardinal): boolean; -begin - value := GetCardinalDef(pointer(text),cardinal(-1)); - result := (value<>cardinal(-1)) and (value>=minimal); -end; - -function ToInt64(const text: RawUTF8; out value: Int64): boolean; -var err: integer; -begin - value := GetInt64(pointer(text),err); - result := err=0; -end; - -function ToDouble(const text: RawUTF8; out value: double): boolean; -var err: integer; -begin - value := GetExtended(pointer(text),err); - result := err=0; -end; - -function UTF8ToInt64(const text: RawUTF8; const default: Int64): Int64; -var err: integer; -begin - result := GetInt64(pointer(text),err); - if err<>0 then - result := default; -end; - -function GetBoolean(P: PUTF8Char): boolean; -begin - if P<>nil then - case PInteger(P)^ of - TRUE_LOW: result := true; - FALSE_LOW: result := false; - else result := PWord(P)^<>ord('0'); - end else - result := false; -end; - -function GetCardinalDef(P: PUTF8Char; Default: PtrUInt): PtrUInt; -var c: byte; -begin - result := Default; - if P=nil then - exit; - c := byte(P^); - repeat - if c=0 then - exit; - if c>ord(' ') then - break; - inc(P); - c := byte(P^); - until false; - dec(c,48); - if c>9 then - exit; - result := c; - repeat - inc(P); - c := byte(P^)-48; - if c>9 then - break; - result := result*10+PtrUInt(c); - until false; -end; - -function GetCardinal(P: PUTF8Char): PtrUInt; -var c: byte; -begin - result := 0; - if P=nil then - exit; - c := byte(P^); - repeat - if c=0 then - exit; - if c>ord(' ') then - break; - inc(P); - c := byte(P^); - until false; - dec(c,48); - if c>9 then - exit; - result := c; - repeat - inc(P); - c := byte(P^); - dec(c,48); - if c>9 then - break; - result := result*10+PtrUInt(c); - until false; -end; - -function GetCardinalW(P: PWideChar): PtrUInt; -var c: PtrUInt; -begin - result := 0; - if P=nil then - exit; - c := ord(P^); - repeat - if c=0 then - exit; - if c>ord(' ') then - break; - inc(P); - c := ord(P^); - until false; - dec(c,48); - if c>9 then - exit; - result := c; - repeat - inc(P); - c := ord(P^); - dec(c,48); - if c>9 then - break; - result := result*10+c; - until false; -end; - -{$ifdef CPU64} -procedure SetInt64(P: PUTF8Char; var result: Int64); -begin // PtrInt is already int64 -> call PtrInt version - result := GetInteger(P); -end; -{$else} -procedure SetInt64(P: PUTF8Char; var result: Int64); -var c: cardinal; - minus: boolean; -begin - result := 0; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - if P^='-' then begin - minus := true; - repeat inc(P) until P^<>' '; - end else begin - minus := false; - if P^='+' then - repeat inc(P) until P^<>' '; - end; - c := byte(P^)-48; - if c>9 then - exit; - PCardinal(@result)^ := c; - inc(P); - repeat // fast 32-bit loop - c := byte(P^)-48; - if c>9 then - break else - PCardinal(@result)^ := PCardinal(@result)^*10+c; - inc(P); - if PCardinal(@result)^>=high(cardinal)div 10 then begin - repeat // 64-bit loop - c := byte(P^)-48; - if c>9 then - break; - result := result shl 3+result+result; // fast result := result*10 - inc(result,c); - inc(P); - until false; - break; - end; - until false; - if minus then - result := -result; -end; -{$endif} - -{$ifdef CPU64} -procedure SetQWord(P: PUTF8Char; var result: QWord); -begin // PtrUInt is already QWord -> call PtrUInt version - result := GetCardinal(P); -end; -{$else} -procedure SetQWord(P: PUTF8Char; var result: QWord); -var c: cardinal; -begin - result := 0; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - if P^='+' then - repeat inc(P) until P^<>' '; - c := byte(P^)-48; - if c>9 then - exit; - PCardinal(@result)^ := c; - inc(P); - repeat // fast 32-bit loop - c := byte(P^)-48; - if c>9 then - break else - PCardinal(@result)^ := PCardinal(@result)^*10+c; - inc(P); - if PCardinal(@result)^>=high(cardinal)div 10 then begin - repeat // 64-bit loop - c := byte(P^)-48; - if c>9 then - break; - result := result shl 3+result+result; // fast result := result*10 - inc(result,c); - inc(P); - until false; - break; - end; - until false; -end; -{$endif} - -{$ifdef CPU64} -function GetInt64(P: PUTF8Char): Int64; -begin // PtrInt is already int64 -> call previous version - result := GetInteger(P); -end; -{$else} -function GetInt64(P: PUTF8Char): Int64; -begin - SetInt64(P,result); -end; -{$endif} - -function GetInt64Def(P: PUTF8Char; const Default: Int64): Int64; -var err: integer; -begin - result := GetInt64(P,err); - if err>0 then - result := Default; -end; - -{$ifdef CPU64} -function GetInt64(P: PUTF8Char; var err: integer): Int64; -begin // PtrInt is already int64 -> call previous version - result := GetInteger(P,err); -end; -{$else} -function GetInt64(P: PUTF8Char; var err: integer): Int64; -var c: cardinal; - minus: boolean; -begin - err := 0; - result := 0; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - if P^='-' then begin - minus := true; - repeat inc(P) until P^<>' '; - end else begin - minus := false; - if P^='+' then - repeat inc(P) until P^<>' '; - end; - inc(err); - c := byte(P^)-48; - if c>9 then - exit; - PCardinal(@result)^ := c; - inc(P); - repeat // fast 32-bit loop - c := byte(P^); - if c<>0 then begin - dec(c,48); - inc(err); - if c>9 then - exit; - PCardinal(@result)^ := PCardinal(@result)^*10+c; - inc(P); - if PCardinal(@result)^>=high(cardinal)div 10 then begin - repeat // 64-bit loop - c := byte(P^); - if c=0 then begin - err := 0; // conversion success without error - break; - end; - dec(c,48); - inc(err); - if c>9 then - exit else - {$ifdef CPU32DELPHI} - result := result shl 3+result+result; - {$else} - result := result*10; - {$endif} - inc(result,c); - if result<0 then - exit; // overflow (>$7FFFFFFFFFFFFFFF) - inc(P); - until false; - break; - end; - end else begin - err := 0; // reached P^=#0 -> conversion success without error - break; - end; - until false; - if minus then - result := -result; -end; -{$endif} - -function GetQWord(P: PUTF8Char; var err: integer): QWord; -var c: PtrUInt; -begin - err := 1; // error - result := 0; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - c := byte(P^)-48; - if c>9 then - exit; - {$ifdef CPU64} - result := c; - inc(P); - repeat - c := byte(P^); - if c=0 then - break; - dec(c,48); - if c>9 then - exit; - result := result*10+c; - inc(P); - until false; - err := 0; // success - {$else} - PByte(@result)^ := c; - inc(P); - repeat // fast 32-bit loop - c := byte(P^); - if c<>0 then begin - dec(c,48); - inc(err); - if c>9 then - exit; - PCardinal(@result)^ := PCardinal(@result)^*10+c; - inc(P); - if PCardinal(@result)^>=high(cardinal)div 10 then begin - repeat // 64-bit loop - c := byte(P^); - if c=0 then begin - err := 0; // conversion success without error - break; - end; - dec(c,48); - inc(err); - if c>9 then - exit else - {$ifdef CPU32DELPHI} - result := result shl 3+result+result; - {$else} - result := result*10; - {$endif} - inc(result,c); - inc(P); - until false; - break; - end; - end else begin - err := 0; // reached P^=#0 -> conversion success without error - break; - end; - until false; - {$endif CPU64} -end; - -function GetExtended(P: PUTF8Char): TSynExtended; -var err: integer; -begin - result := GetExtended(P,err); - if err<>0 then - result := 0; -end; - -const POW10: array[-31..33] of TSynExtended = ( - 1E-31,1E-30,1E-29,1E-28,1E-27,1E-26,1E-25,1E-24,1E-23,1E-22,1E-21,1E-20, - 1E-19,1E-18,1E-17,1E-16,1E-15,1E-14,1E-13,1E-12,1E-11,1E-10,1E-9,1E-8,1E-7, - 1E-6,1E-5,1E-4,1E-3,1E-2,1E-1,1E0,1E1,1E2,1E3,1E4,1E5,1E6,1E7,1E8,1E9,1E10, - 1E11,1E12,1E13,1E14,1E15,1E16,1E17,1E18,1E19,1E20,1E21,1E22,1E23,1E24,1E25, - 1E26,1E27,1E28,1E29,1E30,1E31,0,-1); - -function HugePower10(exponent: integer): TSynExtended; {$ifdef HASINLINE}inline;{$endif} -var e: TSynExtended; -begin - result := POW10[0]; - if exponent<0 then begin - e := POW10[-1]; - exponent := -exponent; - end else - e := POW10[1]; - repeat - while exponent and 1=0 do begin - exponent := exponent shr 1; - e := sqr(e); - end; - result := result*e; - dec(exponent); - until exponent=0; -end; - -function GetExtended(P: PUTF8Char; out err: integer): TSynExtended; -{$ifndef CPU32DELPHI} -var digit: byte; - frac, exp: PtrInt; - c: AnsiChar; - flags: set of (fNeg, fNegExp, fValid); - v: Int64; // allows 64-bit resolution for the digits -label e; -begin - byte(flags) := 0; - v := 0; - frac := 0; - if P=nil then - goto e; - c := P^; - if c=' ' then - repeat - inc(P); - c := P^; - until c<>' '; // trailing spaces - if c='+' then begin - inc(P); - c := P^; - end else - if c='-' then begin - inc(P); - c := P^; - include(flags,fNeg); - end; - digit := 18; // max Int64 resolution - repeat - inc(P); - if (c>='0') and (c<='9') then begin - if digit <> 0 then begin - dec(c,ord('0')); - {$ifdef CPU64} - v := v*10; - {$else} - v := v shl 3+v+v; - {$endif} - inc(v,byte(c)); - dec(digit); // over-required digits are just ignored - include(flags,fValid); - if frac<>0 then - dec(frac); - end else - if frac>=0 then - inc(frac); // handle #############00000 - c := P^; - continue; - end; - if c<>'.' then - break; - if frac>0 then - goto e; - dec(frac); - c := P^; - until false; - if frac<0 then - inc(frac); - if (c='E') or (c='e') then begin - exp := 0; - exclude(flags,fValid); - c := P^; - if c='+' then - inc(P) else - if c='-' then begin - inc(P); - include(flags,fNegExp); - end; - repeat - c := P^; - inc(P); - if (c<'0') or (c>'9') then - break; - dec(c,ord('0')); - exp := (exp*10)+byte(c); - include(flags,fValid); - until false; - if fNegExp in flags then - dec(frac,exp) else - inc(frac,exp); - end; - if (fValid in flags) and (c=#0) then - err := 0 else -e: err := 1; // return the (partial) value even if not ended with #0 - if (frac>=-31) and (frac<=31) then - result := POW10[frac] else - result := HugePower10(frac); - if fNeg in flags then - result := result*POW10[33]; // *-1 - result := result*v; -end; -{$else} -const Ten: double = 10.0; -asm // in: eax=text, edx=@err out: st(0)=result - push ebx // save used registers - push esi - push edi - mov esi, eax // string pointer - push eax // save for error condition - xor ebx, ebx - push eax // allocate local storage for loading fpu - test esi, esi - jz @nil // nil string -@trim: movzx ebx, byte ptr[esi] // strip leading spaces - inc esi - cmp bl, ' ' - je @trim - xor ecx, ecx // clear sign flag - fld qword[Ten] // load 10 into fpu - xor eax, eax // zero number of decimal places - fldz // zero result in fpu - cmp bl, '0' - jl @chksig // check for sign character -@dig1: xor edi, edi // zero exponent value -@digl: sub bl, '0' - cmp bl, 9 - ja @frac // non-digit - mov cl, 1 // set digit found flag - mov [esp], ebx // store for fpu use - fmul st(0), st(1) // multply by 10 - fiadd dword ptr[esp] // add next digit - movzx ebx, byte ptr[esi] // get next char - inc esi - test bl, bl // end reached? - jnz @digl // no,get next digit - jmp @finish // yes,finished -@chksig:cmp bl, '-' - je @minus - cmp bl, '+' - je @sigset -@gdig1: test bl, bl - jz @error // no digits found - jmp @dig1 -@minus: mov ch, 1 // set sign flag -@sigset:movzx ebx, byte ptr[esi] // get next char - inc esi - jmp @gdig1 -@frac: cmp bl, '.' - '0' - jne @exp // no decimal point - movzx ebx, byte ptr[esi] // get next char - test bl, bl - jz @dotend // string ends with '.' - inc esi -@fracl: sub bl, '0' - cmp bl, 9 - ja @exp // non-digit - mov [esp], ebx - dec eax // -(number of decimal places) - fmul st(0), st(1) // multply by 10 - fiadd dword ptr[esp] // add next digit - movzx ebx, byte ptr[esi] // get next char - inc esi - test bl, bl // end reached? - jnz @fracl // no, get next digit - jmp @finish // yes, finished (no exponent) -@dotend:test cl, cl // any digits found before '.'? - jnz @finish // yes, valid - jmp @error // no,invalid -@exp: or bl, $20 - cmp bl, 'e' - '0' - jne @error // not 'e' or 'e' - movzx ebx, byte ptr[esi] // get next char - inc esi - mov cl, 0 // clear exponent sign flag - cmp bl, '-' - je @minexp - cmp bl, '+' - je @expset - jmp @expl -@minexp:mov cl, 1 // set exponent sign flag -@expset:movzx ebx, byte ptr[esi] // get next char - inc esi -@expl: sub bl, '0' - cmp bl, 9 - ja @error // non-digit - lea edi, [edi + edi * 4]// multiply by 10 - add edi, edi - add edi, ebx // add next digit - movzx ebx, byte ptr[esi] // get next char - inc esi - test bl, bl // end reached? - jnz @expl // no, get next digit -@endexp:test cl, cl // positive exponent? - jz @finish // yes, keep exponent value - neg edi // no, negate exponent value -@finish:add eax, edi // exponent value - number of decimal places - mov [edx], ebx // result code = 0 - jz @pow // no call to _pow10 needed - mov edi, ecx // save decimal sign flag - call System.@Pow10 // raise to power of 10 - mov ecx, edi // restore decimal sign flag -@pow: test ch, ch // decimal sign flag set? - jnz @negate // yes, negate value -@ok: add esp, 8 // dump local storage and string pointer -@exit: ffree st(1) // remove ten value from fpu - pop edi // restore used registers - pop esi - pop ebx - ret // finished -@negate:fchs // negate result in fpu - jmp @ok -@nil: inc esi // force result code = 1 - fldz // result value = 0 -@error: pop ebx // dump local storage - pop eax // string pointer - sub esi, eax // error offset - mov [edx], esi // set result code - test ch, ch // decimal sign flag set? - jz @exit // no,exit - fchs // yes. negate result in fpu - jmp @exit // exit setting result code -end; -{$endif CPU32DELPHI} - -function FloatStrCopy(s, d: PUTF8Char): PUTF8Char; -var c: AnsiChar; -begin - while s^=' ' do inc(s); - c := s^; - if (c='+') or (c='-') then begin - inc(s); - d^ := c; - inc(d); - c := s^; - end; - if c='.' then begin - PCardinal(d)^ := ord('0')+ord('.')shl 8; // '.5' -> '0.5' - inc(d,2); - inc(s); - c := s^; - end; - if (c>='0') and (c<='9') then - repeat - inc(s); - d^ := c; - inc(d); - c := s^; - if ((c>='0') and (c<='9')) or (c='.') then - continue; - if (c<>'e') and (c<>'E') then - break; - inc(s); - d^ := c; // 1.23e120 or 1.23e-45 - inc(d); - c := s^; - if c='-' then begin - inc(s); - d^ := c; - inc(d); - c := s^; - end; - while (c>='0') and (c<='9') do begin - inc(s); - d^ := c; - inc(d); - c := s^; - end; - break; - until false; - result := d; -end; - -function GetUTF8Char(P: PUTF8Char): cardinal; -begin - if P<>nil then begin - result := ord(P[0]); - if result and $80<>0 then begin - result := GetHighUTF8UCS4(P); - if result>$ffff then - result := ord('?'); // do not handle surrogates now - end; - end else - result := PtrUInt(P); -end; - -function NextUTF8UCS4(var P: PUTF8Char): cardinal; -begin - if P<>nil then begin - result := byte(P[0]); - if result<=127 then - inc(P) else begin - if result and $20=0 then begin - result := result shl 6+byte(P[1])-$3080; // fast direct process $0..$7ff - inc(P,2); - end else - result := GetHighUTF8UCS4(P); // handle even surrogates - end; - end else - result := 0; -end; - -function ContainsUTF8(p, up: PUTF8Char): boolean; -var u: PByte; -begin - if (p<>nil) and (up<>nil) and (up^<>#0) then begin - result := true; - repeat - u := pointer(up); - repeat - if GetNextUTF8Upper(p)<>u^ then - break else - inc(u); - if u^=0 then - exit; // up^ was found inside p^ - until false; - p := FindNextUTF8WordBegin(p); - until p=nil; - end; - result := false; -end; - -function IdemFileExt(p: PUTF8Char; extup: PAnsiChar; sepChar: AnsiChar): Boolean; -var ext: PUTF8Char; -begin - if (p<>nil) and (extup<>nil) then begin - ext := nil; - repeat - if p^=sepChar then - ext := p; // get last '.' position from p into ext - inc(p); - until p^=#0; - result := IdemPChar(ext,extup); - end else - result := false; -end; - -function IdemFileExts(p: PUTF8Char; const extup: array of PAnsiChar; - sepChar: AnsiChar): integer; -var ext: PUTF8Char; -begin - result := -1; - if (p<>nil) and (high(extup)>0) then begin - ext := nil; - repeat - if p^=sepChar then - ext := p; // get last '.' position from p into ext - inc(p); - until p^=#0; - if ext<>nil then - result := IdemPCharArray(ext,extup); - end; -end; - -function IdemPCharWithoutWhiteSpace(p: PUTF8Char; up: PAnsiChar): boolean; -begin - result := False; - if p=nil then - exit; - if up<>nil then - while up^<>#0 do begin - while p^<=' ' do // trim white space - if p^=#0 then - exit else - inc(p); - if up^<>NormToUpperAnsi7[p^] then - exit; - inc(up); - inc(p); - end; - result := true; -end; - -function IdemPCharArray(p: PUTF8Char; const upArray: array of PAnsiChar): integer; -var w: word; - tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperAnsi7{$else}PNormTableByte{$endif}; - up: ^PAnsiChar; -begin - if p<>nil then begin - {$ifndef CPUX86NOTPIC}tab := @NormToUpperAnsi7;{$endif} // faster on PIC and x86_64 - w := tab[ord(p[0])]+tab[ord(p[1])]shl 8; - up := @upArray[0]; - for result := 0 to high(upArray) do - if (PWord(up^)^=w) and - {$ifdef CPUX86NOTPIC}IdemPChar({$else}IdemPChar2(pointer(tab),{$endif}p+2,up^+2) then - exit else - inc(up); - end; - result := -1; -end; - -function IdemPCharArray(p: PUTF8Char; const upArrayBy2Chars: RawUTF8): integer; -var w: word; -begin - if p<>nil then begin - w := NormToUpperAnsi7Byte[ord(p[0])]+NormToUpperAnsi7Byte[ord(p[1])]shl 8; - for result := 0 to pred(length(upArrayBy2Chars) shr 1) do - if PWordArray(upArrayBy2Chars)[result]=w then - exit; - end; - result := -1; -end; - -function IdemPCharU(p, up: PUTF8Char): boolean; -begin - result := false; - if (p=nil) or (up=nil) then - exit; - while up^<>#0 do begin - if GetNextUTF8Upper(p)<>ord(up^) then - exit; - inc(up); - end; - result := true; -end; - -function EndWith(const text, upText: RawUTF8): boolean; -var o: PtrInt; -begin - o := length(text)-length(upText); - result := (o>=0) and IdemPChar(PUTF8Char(pointer(text))+o,pointer(upText)); -end; - -function EndWithArray(const text: RawUTF8; const upArray: array of RawUTF8): integer; -var t,o: PtrInt; -begin - t := length(text); - if t>0 then - for result := 0 to high(upArray) do begin - o := t-length(UpArray[result]); - if (o>=0) and IdemPChar(PUTF8Char(pointer(text))+o,pointer(upArray[result])) then - exit; - end; - result := -1; -end; - -function UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PAnsiChar; -begin - if source<>'' then - result := UpperCopy255Buf(dest,pointer(source),PStrLen(PtrUInt(source)-_STRLEN)^) else - result := dest; -end; - -function UpperCopy255BufPas(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; -var i,c,d{$ifdef CPU64},_80,_61,_7b{$endif}: PtrUInt; -begin - if sourceLen>0 then begin - if sourceLen>248 then - sourceLen := 248; // avoid buffer overflow - // we allow to copy up to 3/7 more chars in Dest^ since its size is 255 - {$ifdef CPU64} // unbranched uppercase conversion of 8 chars blocks - _80 := PtrUInt($8080808080808080); // use registers for constants - _61 := $6161616161616161; - _7b := $7b7b7b7b7b7b7b7b; - for i := 0 to (sourceLen-1) shr 3 do begin - c := PPtrUIntArray(source)^[i]; - d := c or _80; - PPtrUIntArray(dest)^[i] := c-((d-PtrUInt(_61)) and not(d-_7b)) and - ((not c) and _80)shr 2; - end; - {$else} // unbranched uppercase conversion of 4 chars blocks - for i := 0 to (sourceLen-1) shr 2 do begin - c := PPtrUIntArray(source)^[i]; - d := c or PtrUInt($80808080); - PPtrUIntArray(dest)^[i] := c-((d-PtrUInt($61616161)) and not(d-PtrUInt($7b7b7b7b))) and - ((not c) and PtrUInt($80808080))shr 2; - end; - {$endif} - result := dest+sourceLen; // but we always return the exact size - end else - result := dest; -end; - -function UpperCopyWin255(dest: PWinAnsiChar; const source: RawUTF8): PWinAnsiChar; -var i, L: PtrInt; - tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute NormToUpperByte{$else}PNormTableByte{$endif}; -begin - if source='' then - result := dest else begin - L := PStrLen(PtrUInt(source)-_STRLEN)^; - if L>250 then - L := 250; // avoid buffer overflow - result := dest+L; - {$ifndef CPUX86NOTPIC}tab := @NormToUpperByte;{$endif} // faster on PIC and x86_64 - for i := 0 to L-1 do - dest[i] := AnsiChar(tab[PByteArray(source)[i]]); - end; -end; - -function UTF8UpperCopy(Dest, Source: PUTF8Char; SourceChars: Cardinal): PUTF8Char; -var c: cardinal; - endSource, endSourceBy4, up: PUTF8Char; - extra,i: PtrInt; -label By1, By4, set1; // ugly but faster -begin - if (Source<>nil) and (Dest<>nil) then begin - // first handle trailing 7 bit ASCII chars, by quad (Sha optimization) - endSource := Source+SourceChars; - endSourceBy4 := endSource-4; - up := @NormToUpper; - if (PtrUInt(Source) and 3=0) and (Source<=endSourceBy4) then - repeat - By4:c := PCardinal(Source)^; - if c and $80808080<>0 then - goto By1; // break on first non ASCII quad - inc(Source,4); - Dest[0] := up[ToByte(c)]; - Dest[1] := up[ToByte(c shr 8)]; - Dest[2] := up[ToByte(c shr 16)]; - Dest[3] := up[ToByte(c shr 24)]; - inc(Dest,4); - until Source>endSourceBy4; - // generic loop, handling one UCS4 char per iteration - if SourceendSource) then break; - for i := 0 to extra-1 do - c := c shl 6+byte(Source[i]); - with UTF8_EXTRA[extra] do begin - dec(c,offset); - if c0 - just copy UTF-8 input untouched - inc(Dest); - Dest^ := Source^; - inc(Source); - dec(extra); - if extra=0 then - goto Set1; - until false; - end; - until false; - end; - result := Dest; -end; - -function UTF8UpperCopy255(dest: PAnsiChar; const source: RawUTF8): PUTF8Char; -var L: integer; -begin - L := length(source); - if L>0 then begin - if L>250 then - L := 250; // avoid buffer overflow - result := UTF8UpperCopy(pointer(dest),pointer(source),L); - end else - result := pointer(dest); -end; - -function UpperCopy255W(dest: PAnsiChar; const source: SynUnicode): PAnsiChar; -var c: cardinal; - i,L: integer; -begin - L := length(source); - if L>0 then begin - if L>250 then - L := 250; // avoid buffer overflow - result := dest+L; - for i := 0 to L-1 do begin - c := PWordArray(source)[i]; - if c<255 then - dest[i] := AnsiChar(NormToUpperAnsi7Byte[c]) else - dest[i] := '?'; - end; - end else - result := dest; -end; - -function UpperCopy255W(dest: PAnsiChar; source: PWideChar; L: integer): PAnsiChar; -var c: cardinal; - i: integer; -begin - if L>0 then begin - if L>250 then - L := 250; // avoid buffer overflow - result := dest+L; - for i := 0 to L-1 do begin - c := PWordArray(source)[i]; - if c<255 then - dest[i] := AnsiChar(NormToUpperAnsi7Byte[c]) else - dest[i] := '?'; - end; - end else - result := dest; -end; - -function GetNextLine(source: PUTF8Char; out next: PUTF8Char; andtrim: boolean): RawUTF8; -var beg: PUTF8Char; -begin - if source=nil then begin - {$ifdef FPC}Finalize(result){$else}result := ''{$endif}; - next := source; - exit; - end; - if andtrim then // optional trim left - while source^ in [#9,' '] do inc(source); - beg := source; - repeat // just here to avoid a goto - if source[0]>#13 then - if source[1]>#13 then - if source[2]>#13 then - if source[3]>#13 then begin - inc(source,4); // fast process 4 chars per loop - continue; - end else - inc(source,3) else - inc(source,2) else - inc(source); - case source^ of - #0: next := nil; - #10: next := source+1; - #13: if source[1]=#10 then next := source+2 else next := source+1; - else begin - inc(source); - continue; - end; - end; - if andtrim then // optional trim right - while (source>beg) and (source[-1] in [#9,' ']) do dec(source); - FastSetString(result,beg,source-beg); - exit; - until false; -end; - -{$ifdef UNICODE} -function GetNextLineW(source: PWideChar; out next: PWideChar): string; -begin - next := source; - if source=nil then begin - result := ''; - exit; - end; - while not (cardinal(source^) in [0,10,13]) do inc(source); - SetString(result,PChar(next),source-next); - if source^=#13 then inc(source); - if source^=#10 then inc(source); - if source^=#0 then - next := nil else - next := source; -end; - -function FindIniNameValueW(P: PWideChar; UpperName: PUTF8Char): string; -var PBeg: PWideChar; - L: PtrInt; -begin - while (P<>nil) and (P^<>'[') do begin - PBeg := P; - while not (cardinal(P^) in [0,10,13]) do inc(P); - while cardinal(P^) in [10,13] do inc(P); - if P^=#0 then P := nil; - if PBeg^=' ' then repeat inc(PBeg) until PBeg^<>' '; // trim left ' ' - if IdemPCharW(PBeg,UpperName) then begin - inc(PBeg,StrLen(UpperName)); - L := 0; while PBeg[L]>=' ' do inc(L); // get line length - SetString(result,PBeg,L); - exit; - end; - end; - result := ''; -end; - -function FindIniEntryW(const Content: string; const Section, Name: RawUTF8): string; -var P: PWideChar; - UpperSection, UpperName: array[byte] of AnsiChar; - // possible GPF if length(Section/Name)>255, but should const in code -begin - result := ''; - P := pointer(Content); - if P=nil then exit; - // UpperName := UpperCase(Name)+'='; - PWord(UpperCopy255(UpperName,Name))^ := ord('='); - if Section='' then - // find the Name= entry before any [Section] - result := FindIniNameValueW(P,UpperName) else begin - // find the Name= entry in the specified [Section] - PWord(UpperCopy255(UpperSection,Section))^ := ord(']'); - if FindSectionFirstLineW(P,UpperSection) then - result := FindIniNameValueW(P,UpperName); - end; -end; -{$endif UNICODE} - -function IdemPCharAndGetNextItem(var source: PUTF8Char; const searchUp: RawUTF8; - var Item: RawUTF8; Sep: AnsiChar): boolean; -begin - if source=nil then - result := false else begin - result := IdemPChar(source,Pointer(searchUp)); - if result then begin - inc(source,Length(searchUp)); - GetNextItem(source,Sep,Item); - end; - end; -end; - -function GotoNextLine(source: PUTF8Char): PUTF8Char; -label - _z, _0, _1, _2, _3; // ugly but faster -var - c: AnsiChar; -begin - if source<>nil then - repeat - if source[0]<#13 then - goto _0 - else if source[1]<#13 then - goto _1 - else if source[2]<#13 then - goto _2 - else if source[3]<#13 then - goto _3 - else begin - inc(source, 4); - continue; - end; -_3: inc(source); -_2: inc(source); -_1: inc(source); -_0: c := source^; - if c=#13 then begin - if source[1]=#10 then begin - result := source+2; // most common case is text ending with #13#10 - exit; - end; - end else - if c=#0 then - goto _z else - if c<>#10 then begin - inc(source); - continue; // e.g. #9 - end; - result := source+1; - exit; - until false; -_z: result := nil; -end; - -function BufferLineLength(Text, TextEnd: PUTF8Char): PtrInt; -{$ifdef CPUX64} -{$ifdef FPC} nostackframe; assembler; asm {$else} asm .noframe {$endif} -{$ifdef MSWINDOWS} // Win64 ABI to System-V ABI - push rsi - push rdi - mov rdi, rcx - mov rsi, rdx -{$endif}mov r8, rsi - sub r8, rdi // rdi=Text, rsi=TextEnd, r8=TextLen - jz @fail - mov ecx, edi - movaps xmm0, [rip + @for10] - movaps xmm1, [rip + @for13] - and rdi, -16 // check first aligned 16 bytes - and ecx, 15 // lower cl 4 bits indicate misalignment - movaps xmm2, [rdi] - movaps xmm3, xmm2 - pcmpeqb xmm2, xmm0 - pcmpeqb xmm3, xmm1 - por xmm3, xmm2 - pmovmskb eax, xmm3 - shr eax, cl // shift out unaligned bytes - test eax, eax - jz @main - bsf eax, eax - add rax, rcx - add rax, rdi - sub rax, rsi - jae @fail // don't exceed TextEnd - add rax, r8 // rax = TextFound - TextEnd + (TextEnd - Text) = offset -{$ifdef MSWINDOWS} - pop rdi - pop rsi -{$endif}ret -@main: add rdi, 16 - sub rdi, rsi - jae @fail - jmp @by16 -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@for10: dq $0a0a0a0a0a0a0a0a - dq $0a0a0a0a0a0a0a0a -@for13: dq $0d0d0d0d0d0d0d0d - dq $0d0d0d0d0d0d0d0d -@by16: movaps xmm2, [rdi + rsi] // check 16 bytes per loop - movaps xmm3, xmm2 - pcmpeqb xmm2, xmm0 - pcmpeqb xmm3, xmm1 - por xmm3, xmm2 - pmovmskb eax, xmm3 - test eax, eax - jnz @found - add rdi, 16 - jnc @by16 -@fail: mov rax, r8 // returns TextLen if no CR/LF found -{$ifdef MSWINDOWS} - pop rdi - pop rsi -{$endif}ret -@found: bsf eax, eax - add rax, rdi - jc @fail - add rax, r8 -{$ifdef MSWINDOWS} - pop rdi - pop rsi -{$endif} -end; -{$else} -begin - result := PtrUInt(Text)-1; - repeat - inc(result); - if PtrUInt(result)13) or ((PByte(result)^<>10) and (PByte(result)^<>13)) then - continue; - break; - until false; - dec(result,PtrInt(Text)); // returns length -end; -{$endif CPUX64} - -function GetLineSize(P, PEnd: PUTF8Char): PtrUInt; -var c: byte; -begin - {$ifdef CPUX64} - if PEnd <> nil then begin - result := BufferLineLength(P,PEnd); // use branchless SSE2 on x86_64 - exit; - end; - result := PtrUInt(P)-1; - {$else} - result := PtrUInt(P)-1; - if PEnd<>nil then - repeat // inlined BufferLineLength() - inc(result); - if PtrUInt(result)13) or ((c<>10) and (c<>13)) then - continue; - end; - break; - until false else - {$endif CPUX64} - repeat // inlined BufferLineLength() ending at #0 for PEnd=nil - inc(result); - c := PByte(result)^; - if (c>13) or ((c<>0) and (c<>10) and (c<>13)) then - continue; - break; - until false; - dec(result,PtrUInt(P)); // returns length -end; - -function GetNextItem(var P: PUTF8Char; Sep: AnsiChar): RawUTF8; -begin - GetNextItem(P,Sep,result); -end; - -procedure GetNextItem(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); -var S: PUTF8Char; -begin - if P=nil then - result := '' else begin - S := P; - while (S^<>#0) and (S^<>Sep) do - inc(S); - FastSetString(result,P,S-P); - if S^<>#0 then - P := S+1 else - P := nil; - end; -end; - -procedure GetNextItem(var P: PUTF8Char; Sep, Quote: AnsiChar; var result: RawUTF8); -begin - if P=nil then - result := '' - else if P^=Quote then begin - P := UnQuoteSQLStringVar(P,result); - if P=nil then - result := '' - else if P^<>#0 then - inc(P); - end else - GetNextItem(P,Sep,result); -end; - -procedure GetNextItemTrimed(var P: PUTF8Char; Sep: AnsiChar; var result: RawUTF8); -var S,E: PUTF8Char; -begin - if (P=nil) or (Sep<=' ') then - result := '' else begin - while (P^<=' ') and (P^<>#0) do inc(P); // trim left - S := P; - while (S^<>#0) and (S^<>Sep) do - inc(S); - E := S; - while (E>P) and (E[-1] in [#1..' ']) do dec(E); // trim right - FastSetString(result,P,E-P); - if S^<>#0 then - P := S+1 else - P := nil; - end; -end; - -procedure GetNextItemTrimedCRLF(var P: PUTF8Char; var result: RawUTF8); -var S,E: PUTF8Char; -begin - if P=nil then - result := '' else begin - S := P; - while (S^<>#0) and (S^<>#10) do - inc(S); - E := S; - if (E>P) and (E[-1]=#13) then - dec(E); - FastSetString(result,P,E-P); - if S^<>#0 then - P := S+1 else - P := nil; - end; -end; - -function GetNextItemString(var P: PChar; Sep: Char): string; -// this function will compile into AnsiString or UnicodeString, depending -// of the compiler version -var S: PChar; -begin - if P=nil then - result := '' else begin - S := P; - while (S^<>#0) and (S^<>Sep) do - inc(S); - SetString(result,P,S-P); - if S^<>#0 then - P := S+1 else - P := nil; - end; -end; - -function GetNextStringLineToRawUnicode(var P: PChar): RawUnicode; -var S: PChar; -begin - if P=nil then - result := '' else begin - S := P; - while S^>=' ' do - inc(S); - result := StringToRawUnicode(P,S-P); - while (S^<>#0) and (S^<' ') do inc(S); // ignore e.g. #13 or #10 - if S^<>#0 then - P := S else - P := nil; - end; -end; - -procedure AppendCSVValues(const CSV: string; const Values: array of string; - var Result: string; const AppendBefore: string); -var Caption: string; - i, bool: integer; - P: PChar; - first: Boolean; -begin - P := pointer(CSV); - if P=nil then - exit; - first := True; - for i := 0 to high(Values) do begin - Caption := GetNextItemString(P); - if Values[i]<>'' then begin - if first then begin - Result := Result+#13#10; - first := false; - end else - Result := Result+AppendBefore; - bool := FindCSVIndex('0,-1',RawUTF8(Values[i])); - Result := Result+Caption+': '; - if bool<0 then - Result := Result+Values[i] else - Result := Result+GetCSVItemString(pointer(GetNextItemString(P)),bool,'/'); - end; - end; -end; - -procedure GetNextItemShortString(var P: PUTF8Char; out Dest: ShortString; Sep: AnsiChar); -var S: PUTF8Char; - len: PtrInt; -begin - S := P; - if S<>nil then begin - while (S^<=' ') and (S^<>#0) do inc(S); - P := S; - if (S^<>#0) and (S^<>Sep) then - repeat - inc(S); - until (S^=#0) or (S^=Sep); - len := S-P; - repeat - dec(len); - until (len<0) or not(P[len] in [#1..' ']); // trim right spaces - if len>=255 then - len := 255 else - inc(len); - Dest[0] := AnsiChar(len); - MoveSmall(P,@Dest[1],Len); - if S^<>#0 then - P := S+1 else - P := nil; - end else - Dest[0] := #0; -end; - -function GetNextItemHexDisplayToBin(var P: PUTF8Char; Bin: PByte; BinBytes: integer; - Sep: AnsiChar): boolean; -var S: PUTF8Char; - len: integer; -begin - result := false; - FillCharFast(Bin^,BinBytes,0); - if P=nil then - exit; - if P^=' ' then repeat inc(P) until P^<>' '; - S := P; - if Sep=#0 then - while S^>' ' do - inc(S) else - while (S^<>#0) and (S^<>Sep) do - inc(S); - len := S-P; - while (P[len-1] in [#1..' ']) and (len>0) do dec(len); // trim right spaces - if len<>BinBytes*2 then - exit; - if not HexDisplayToBin(PAnsiChar(P),Bin,BinBytes) then - FillCharFast(Bin^,BinBytes,0) else begin - if S^=#0 then - P := nil else - if Sep<>#0 then - P := S+1 else - P := S; - result := true; - end; -end; - -function GetNextItemCardinal(var P: PUTF8Char; Sep: AnsiChar): PtrUInt; -var c: PtrUInt; -begin - if P=nil then begin - result := 0; - exit; - end; - if P^=' ' then repeat inc(P) until P^<>' '; - c := byte(P^)-48; - if c>9 then - result := 0 else begin - result := c; - inc(P); - repeat - c := byte(P^)-48; - if c>9 then - break else - result := result*10+c; - inc(P); - until false; - end; - if Sep<>#0 then - while (P^<>#0) and (P^<>Sep) do // go to end of CSV item (ignore any decimal) - inc(P); - if P^=#0 then - P := nil else - if Sep<>#0 then - inc(P); -end; - -function GetNextItemCardinalStrict(var P: PUTF8Char): PtrUInt; -var c: PtrUInt; -begin - if P=nil then begin - result := 0; - exit; - end; - c := byte(P^)-48; - if c>9 then - result := 0 else begin - result := c; - inc(P); - repeat - c := byte(P^)-48; - if c>9 then - break else - result := result*10+c; - inc(P); - until false; - end; - if P^=#0 then - P := nil; -end; - -function CSVOfValue(const Value: RawUTF8; Count: cardinal; const Sep: RawUTF8): RawUTF8; -var ValueLen, SepLen: cardinal; - i: cardinal; - P: PAnsiChar; -begin // CSVOfValue('?',3)='?,?,?' - result := ''; - if Count=0 then - exit; - ValueLen := length(Value); - SepLen := Length(Sep); - FastSetString(result,nil,ValueLen*Count+SepLen*pred(Count)); - P := pointer(result); - i := 1; - repeat - if ValueLen>0 then begin - MoveSmall(Pointer(Value),P,ValueLen); - inc(P,ValueLen); - end; - if i=Count then - break; - if SepLen>0 then begin - MoveSmall(Pointer(Sep),P,SepLen); - inc(P,SepLen); - end; - inc(i); - until false; -// assert(P-pointer(result)=length(result)); -end; - -procedure SetBitCSV(var Bits; BitsCount: integer; var P: PUTF8Char); -var bit,last: cardinal; -begin - while P<>nil do begin - bit := GetNextItemCardinalStrict(P)-1; // '0' marks end of list - if bit>=cardinal(BitsCount) then - break; // avoid GPF - if (P=nil) or (P^=',') then - SetBitPtr(@Bits,bit) else - if P^='-' then begin - inc(P); - last := GetNextItemCardinalStrict(P)-1; // '0' marks end of list - if last>=Cardinal(BitsCount) then - exit; - while bit<=last do begin - SetBitPtr(@Bits,bit); - inc(bit); - end; - end; - if (P<>nil) and (P^=',') then - inc(P); - end; - if (P<>nil) and (P^=',') then - inc(P); -end; - -function GetBitCSV(const Bits; BitsCount: integer): RawUTF8; -var i,j: integer; -begin - result := ''; - i := 0; - while i9 then - result := 0 else begin - result := c; - inc(P); - repeat - c := word(P^)-48; - if c>9 then - break else - result := result*10+c; - inc(P); - until false; - end; - while (P^<>#0) and (P^<>Sep) do // go to end of CSV item (ignore any decimal) - inc(P); - if P^=#0 then - P := nil else - inc(P); -end; - -function GetNextItemInteger(var P: PUTF8Char; Sep: AnsiChar): PtrInt; -var minus: boolean; -begin - if P=nil then begin - result := 0; - exit; - end; - if P^=' ' then repeat inc(P) until P^<>' '; - if (P^ in ['+','-']) then begin - minus := P^='-'; - inc(P); - end else - minus := false; - result := PtrInt(GetNextItemCardinal(P,Sep)); - if minus then - result := -result; -end; - -function GetNextTChar64(var P: PUTF8Char; Sep: AnsiChar; out Buf: TChar64): PtrInt; -var S: PUTF8Char; - c: AnsiChar; -begin - result := 0; - S := P; - if S=nil then - exit; - if Sep=#0 then - repeat // store up to next whitespace - c := S[result]; - if c<=' ' then break; - Buf[result] := c; - inc(result); - if result>=SizeOf(Buf) then - exit; // avoid buffer overflow - until false else - repeat // store up to Sep or end of string - c := S[result]; - if (c=#0) or (c=Sep) then break; - Buf[result] := c; - inc(result); - if result>=SizeOf(Buf) then - exit; // avoid buffer overflow - until false; - Buf[result] := #0; // make asciiz - inc(S,result); // S[result]=Sep or #0 - if S^=#0 then - P := nil else - if Sep=#0 then - P := S else - P := S+1; -end; - -function GetNextItemInt64(var P: PUTF8Char; Sep: AnsiChar): Int64; -{$ifdef CPU64} -begin - result := GetNextItemInteger(P,Sep); // PtrInt=Int64 -end; -{$else} -var tmp: TChar64; -begin - if GetNextTChar64(P,Sep,tmp)>0 then - SetInt64(tmp,result) else - result := 0; -end; -{$endif} - -function GetNextItemQWord(var P: PUTF8Char; Sep: AnsiChar): QWord; -{$ifdef CPU64} -begin - result := GetNextItemCardinal(P,Sep); // PtrUInt=QWord -end; -{$else} -var tmp: TChar64; -begin - if GetNextTChar64(P,Sep,tmp)>0 then - SetQWord(tmp,result) else - result := 0; -end; -{$endif} - -function GetNextItemHexa(var P: PUTF8Char; Sep: AnsiChar): QWord; -var tmp: TChar64; - L: integer; -begin - result := 0; - L := GetNextTChar64(P,Sep,tmp); - if (L>0) and (L and 1=0) then - if not HexDisplayToBin(@tmp,@result,L shr 1) then - result := 0; -end; - -function GetNextItemDouble(var P: PUTF8Char; Sep: AnsiChar): double; -var tmp: TChar64; - err: integer; -begin - if GetNextTChar64(P,Sep,tmp)>0 then begin - result := GetExtended(tmp,err); - if err<>0 then - result := 0; - end else - result := 0; -end; - -function GetNextItemCurrency(var P: PUTF8Char; Sep: AnsiChar): currency; -begin - GetNextItemCurrency(P,result,Sep); -end; - -procedure GetNextItemCurrency(var P: PUTF8Char; out result: currency; Sep: AnsiChar); -var tmp: TChar64; -begin - if GetNextTChar64(P,Sep,tmp)>0 then - PInt64(@result)^ := StrToCurr64(tmp) else - result := 0; -end; - -function GetCSVItem(P: PUTF8Char; Index: PtrUInt; Sep: AnsiChar): RawUTF8; -var i: PtrUInt; -begin - if P=nil then - result := '' else - for i := 0 to Index do - GetNextItem(P,Sep,result); -end; - -function GetUnQuoteCSVItem(P: PUTF8Char; Index: PtrUInt; Sep, Quote: AnsiChar): RawUTF8; -var i: PtrUInt; -begin - if P=nil then - result := '' else - for i := 0 to Index do - GetNextItem(P,Sep,Quote,result); -end; - -function GetLastCSVItem(const CSV: RawUTF8; Sep: AnsiChar): RawUTF8; -var i: integer; -begin - for i := length(CSV) downto 1 do - if CSV[i]=Sep then begin - result := copy(CSV,i+1,maxInt); - exit; - end; - result := CSV; -end; - -function GetCSVItemString(P: PChar; Index: PtrUInt; Sep: Char): string; -var i: PtrUInt; -begin - if P=nil then - result := '' else - for i := 0 to Index do - result := GetNextItemString(P,Sep); -end; - -function FindCSVIndex(CSV: PUTF8Char; const Value: RawUTF8; Sep: AnsiChar; - CaseSensitive,TrimValue: boolean): integer; -var s: RawUTF8; -begin - result := 0; - while CSV<>nil do begin - GetNextItem(CSV,Sep,s); - if TrimValue then - s := trim(s); - if CaseSensitive then begin - if s=Value then - exit; - end else - if SameTextU(s,Value) then - exit; - inc(result); - end; - result := -1; // not found -end; - -procedure CSVToRawUTF8DynArray(CSV: PUTF8Char; var Result: TRawUTF8DynArray; - Sep: AnsiChar; TrimItems, AddVoidItems: boolean); -var s: RawUTF8; - n: integer; -begin - n := length(Result); - while CSV<>nil do begin - if TrimItems then - GetNextItemTrimed(CSV,Sep,s) else - GetNextItem(CSV,Sep,s); - if (s<>'') or AddVoidItems then - AddRawUTF8(Result,n,s); - end; - if n<>length(Result) then - SetLength(Result,n); -end; - -procedure CSVToRawUTF8DynArray(const CSV,Sep,SepEnd: RawUTF8; var Result: TRawUTF8DynArray); -var offs,i: integer; -begin - offs := 1; - while offs<=length(CSV) do begin - SetLength(Result,length(Result)+1); - i := PosEx(Sep,CSV,offs); - if i=0 then begin - i := PosEx(SepEnd,CSV,offs); - if i=0 then - i := MaxInt else - dec(i,offs); - Result[high(Result)] := Copy(CSV,offs,i); - exit; - end; - Result[high(Result)] := Copy(CSV,offs,i-offs); - offs := i+length(sep); - end; -end; - -function AddPrefixToCSV(CSV: PUTF8Char; const Prefix: RawUTF8; Sep: AnsiChar): RawUTF8; -var s: RawUTF8; -begin - GetNextItem(CSV,Sep,result); - if result='' then - exit; - result := Prefix+result; - while CSV<>nil do begin - GetNextItem(CSV,Sep,s); - if s<>'' then - result := result+','+Prefix+s; - end; -end; - -procedure AddToCSV(const Value: RawUTF8; var CSV: RawUTF8; const Sep: RawUTF8); -begin - if CSV='' then - CSV := Value else - CSV := CSV+Sep+Value; -end; - -function RenameInCSV(const OldValue, NewValue: RawUTF8; var CSV: RawUTF8; - const Sep: RawUTF8): boolean; -var pattern: RawUTF8; - i,j: integer; -begin - result := OldValue=NewValue; - i := length(OldValue); - if result or (length(Sep)<>1) or (length(CSV)0) or (PosEx(Sep,NewValue)>0) then - exit; - if CompareMem(pointer(OldValue),pointer(CSV),i) and // first (or unique) item - ((CSV[i+1]=Sep[1]) or (CSV[i+1]=#0)) then - i := 1 else begin - j := 1; - pattern := Sep+OldValue; - repeat - i := PosEx(pattern,CSV,j); - if i=0 then - exit; - j := i+length(pattern); - until (CSV[j]=Sep[1]) or (CSV[j]=#0); - inc(i); - end; - delete(CSV,i,length(OldValue)); - insert(NewValue,CSV,i); - result := true; -end; - -function RawUTF8ArrayToCSV(const Values: array of RawUTF8; const Sep: RawUTF8): RawUTF8; -var i, len, seplen, L: Integer; - P: PAnsiChar; -begin - result := ''; - if high(Values)<0 then - exit; - seplen := length(Sep); - len := seplen*high(Values); - for i := 0 to high(Values) do - inc(len,length(Values[i])); - FastSetString(result,nil,len); - P := pointer(result); - i := 0; - repeat - L := length(Values[i]); - if L>0 then begin - MoveFast(pointer(Values[i])^,P^,L); - inc(P,L); - end; - if i=high(Values) then - Break; - if seplen>0 then begin - MoveSmall(pointer(Sep),P,seplen); - inc(P,seplen); - end; - inc(i); - until false; -end; - -function RawUTF8ArrayToQuotedCSV(const Values: array of RawUTF8; const Sep: RawUTF8; - Quote: AnsiChar): RawUTF8; -var i: integer; - tmp: TRawUTF8DynArray; -begin - SetLength(tmp,length(Values)); - for i := 0 to High(Values) do - tmp[i] := QuotedStr(Values[i],Quote); - result := RawUTF8ArrayToCSV(tmp,Sep); -end; - -function TRawUTF8DynArrayFrom(const Values: array of RawUTF8): TRawUTF8DynArray; -var i: integer; -begin - Finalize(result); - SetLength(result,length(Values)); - for i := 0 to high(Values) do - result[i] := Values[i]; -end; - -{$ifdef HASCODEPAGE} -function LStringCodePage(info: PTypeInfo): integer; inline; -begin // caller checked that info^.kind=tkLString - result := PWord({$ifdef FPC}AlignTypeData{$endif}(pointer(PtrUInt(info)+info^.NameLen+2)))^; -end; -{$endif HASCODEPAGE} - -function IsRawUTF8DynArray(typeinfo: pointer): boolean; -var nfo: PTypeInfo; -begin - if typeinfo=System.TypeInfo(TRawUTF8DynArray) then - result := true else begin - nfo := GetTypeInfo(typeinfo,tkDynArray); - if (nfo<>nil) and (nfo^.elSize=SizeOf(pointer)) and - (nfo^.elType<>nil) then begin - nfo := DeRef(nfo^.elType); - result := (nfo^.kind=tkLString) - {$ifdef HASCODEPAGE}and (LStringCodePage(nfo)=CP_UTF8){$endif}; - end else - result := false; - end; -end; - -procedure AddArrayOfConst(var Dest: TTVarRecDynArray; const Values: array of const); -var i,n: Integer; -begin - n := length(Dest); - SetLength(Dest,n+length(Values)); - for i := 0 to high(Values) do - Dest[i+n] := Values[i]; -end; - -var - DefaultTextWriterTrimEnum: boolean; - -function ObjectToJSON(Value: TObject; Options: TTextWriterWriteObjectOptions): RawUTF8; -var temp: TTextWriterStackBuffer; -begin - if Value=nil then - result := NULL_STR_VAR else - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - include(fCustomOptions,twoForceJSONStandard); - WriteObject(Value,Options); - SetText(result); - finally - Free; - end; -end; - -function ObjectsToJSON(const Names: array of RawUTF8; const Values: array of TObject; - Options: TTextWriterWriteObjectOptions): RawUTF8; -var i,n: integer; - temp: TTextWriterStackBuffer; -begin - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - n := length(Names); - Add('{'); - for i := 0 to high(Values) do - if Values[i]<>nil then begin - if i0) and (n and 1=1) then begin - for A := 0 to n shr 1 do begin - VarRecToUTF8(NameValuePairs[A*2],name); - if not IsUrlValid(pointer(name)) then - continue; // just skip invalid names - with NameValuePairs[A*2+1] do - if VType=vtObject then - value := ObjectToJSON(VObject,[]) else - VarRecToUTF8(NameValuePairs[A*2+1],value); - result := result+'&'+name+'='+UrlEncode(value); - end; - result[1] := '?'; - end; -end; - -function IsUrlValid(P: PUTF8Char): boolean; -var tab: PTextCharSet; -begin - result := false; - if P=nil then - exit; - tab := @TEXT_CHARS; - repeat // cf. rfc3986 2.3. Unreserved Characters - if tcURIUnreserved in tab[P^] then - inc(P) else - exit; - until P^=#0; - result := true; -end; - -function AreUrlValid(const Url: array of RawUTF8): boolean; -var i: integer; -begin - result := false; - for i := 0 to high(Url) do - if not IsUrlValid(pointer(Url[i])) then - exit; - result := true; -end; - -function IncludeTrailingURIDelimiter(const URI: RawByteString): RawByteString; -begin - if (URI<>'') and (URI[length(URI)]<>'/') then - result := URI+'/' else - result := URI; -end; - -function UrlEncodeJsonObject(const URIName: RawUTF8; ParametersJSON: PUTF8Char; - const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean): RawUTF8; -var i,j: integer; - sep: AnsiChar; - Params: TNameValuePUTF8CharDynArray; - temp: TTextWriterStackBuffer; -begin - if ParametersJSON=nil then - result := URIName else - with TTextWriter.CreateOwnedStream(temp) do - try - AddString(URIName); - if (JSONDecode(ParametersJSON,Params,true)<>nil) and (Params<>nil) then begin - sep := '?'; - for i := 0 to length(Params)-1 do - with Params[i] do begin - for j := 0 to high(PropNamesToIgnore) do - if IdemPropNameU(PropNamesToIgnore[j],Name,NameLen) then begin - NameLen := 0; - break; - end; - if NameLen=0 then - continue; - if IncludeQueryDelimiter then - Add(sep); - AddNoJSONEscape(Name,NameLen); - Add('='); - AddString(UrlEncode(Value)); - sep := '&'; - IncludeQueryDelimiter := true; - end; - end; - SetText(result); - finally - Free; - end; -end; - -function UrlEncodeJsonObject(const URIName, ParametersJSON: RawUTF8; - const PropNamesToIgnore: array of RawUTF8; IncludeQueryDelimiter: Boolean): RawUTF8; -var temp: TSynTempBuffer; -begin - temp.Init(ParametersJSON); - try - result := UrlEncodeJsonObject(URIName,temp.buf,PropNamesToIgnore,IncludeQueryDelimiter); - finally - temp.Done; - end; -end; - -function UrlDecode(const s: RawUTF8; i,len: PtrInt): RawUTF8; -var L: PtrInt; - P: PUTF8Char; - tmp: TSynTempBuffer; -begin - result := ''; - L := PtrInt(s); - if L=0 then - exit; - L := PStrLen(L-_STRLEN)^; - if len<0 then - len := L; - if i>L then - exit; - dec(i); - if len=i then - exit; - P := tmp.Init(len-i); // reserve enough space for result - while inil then begin - // compute resulting length of value - Beg := U; - len := 0; - while (U^<>#0) and (U^<>'&') do begin - if (U^='%') and HexToCharValid(PAnsiChar(U+1)) then - inc(U,3) else - inc(U); - inc(len); - end; - // decode value content - if len<>0 then begin - FastSetString(Value,nil,len); - V := pointer(Value); - U := Beg; - repeat - if (U^='%') and HexToChar(PAnsiChar(U+1),V) then begin - inc(V); - inc(U,3); - end else begin - if U^='+' then - V^ := ' ' else - V^ := U^; - inc(V); - inc(U); - end; - dec(len); - until len=0; - end; - end; - result := U; -end; - -function UrlDecodeNextName(U: PUTF8Char; out Name: RawUTF8): PUTF8Char; -var Beg, V: PUTF8Char; - len: PtrInt; -begin - result := nil; - if U=nil then - exit; - // compute resulting length of name - Beg := U; - len := 0; - repeat - case U^ of - #0: exit; - '=': begin - result := U+1; - break; - end; - '%': if (U[1]='3') and (U[2] in ['D','d']) then begin - result := U+3; - break; // %3d means = according to the RFC - end else - if HexToCharValid(PAnsiChar(U+1)) then - inc(U,3) else - inc(U); - else inc(U); - end; - inc(len); - until false; - if len=0 then - exit; - // decode name content - FastSetString(Name,nil,len); - V := pointer(Name); - U := Beg; - repeat - if (U^='%') and HexToChar(PAnsiChar(U+1),V) then begin - inc(V); - inc(U,3); - end else begin - if U^='+' then - V^ := ' ' else - V^ := U^; - inc(V); - inc(U); - end; - dec(len); - until len=0; -end; - -function UrlDecodeNextNameValue(U: PUTF8Char; var Name,Value: RawUTF8): PUTF8Char; -begin - result := nil; - if U=nil then - exit; - U := UrlDecodeNextName(U,Name); - if U=nil then - exit; - U := UrlDecodeNextValue(U,Value); - if U^=#0 then - result := U else - result := U+1; // jump '&' to let decode the next name=value pair -end; - -function UrlDecodeValue(U: PUTF8Char; const Upper: RawUTF8; var Value: RawUTF8; - Next: PPUTF8Char): boolean; -begin - // UrlDecodeValue('select=%2A&where=LastName%3D%27M%C3%B4net%27','SELECT=',V,@U) - // -> U^='where=...' and V='*' - result := false; // mark value not modified by default - if U=nil then begin - if Next<>nil then - Next^ := U; - exit; - end; - if IdemPChar(U,pointer(Upper)) then begin - result := true; - inc(U,length(Upper)); - U := UrlDecodeNextValue(U,Value); - end; - if Next=nil then - exit; - while not(U^ in [#0,'&']) do inc(U); - if U^=#0 then - Next^ := nil else - Next^ := U+1; // jump '&' -end; - -function UrlDecodeInteger(U: PUTF8Char; const Upper: RawUTF8; - var Value: integer; Next: PPUTF8Char): boolean; -var V: PtrInt; - SignNeg: boolean; -begin - // UrlDecodeInteger('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) - // -> Next^='where=...' and O=20 - result := false; // mark value not modified by default - if U=nil then begin - if Next<>nil then - Next^ := U; - exit; - end; - if IdemPChar(U,pointer(Upper)) then begin - inc(U,length(Upper)); - if U^='-' then begin - SignNeg := True; - Inc(U); - end else - SignNeg := false; - if U^ in ['0'..'9'] then begin - V := 0; - repeat - V := (V*10)+ord(U^)-48; - inc(U); - until not (U^ in ['0'..'9']); - if SignNeg then - Value := -V else - Value := V; - result := true; - end; - end; - if Next=nil then - exit; - while not(U^ in [#0,'&']) do inc(U); - if U^=#0 then - Next^ := nil else - Next^ := U+1; // jump '&' -end; - -function UrlDecodeCardinal(U: PUTF8Char; const Upper: RawUTF8; - var Value: Cardinal; Next: PPUTF8Char): boolean; -var V: PtrInt; -begin - // UrlDecodeInteger('offset=20&where=LastName%3D%27M%C3%B4net%27','OFFSET=',O,@Next) - // -> Next^='where=...' and O=20 - result := false; // mark value not modified by default - if U=nil then begin - if Next<>nil then - Next^ := U; - exit; - end; - if IdemPChar(U,pointer(Upper)) then begin - inc(U,length(Upper)); - if U^ in ['0'..'9'] then begin - V := 0; - repeat - V := (V*10)+ord(U^)-48; - inc(U); - until not (U^ in ['0'..'9']); - Value := V; - result := true; - end; - end; - if Next=nil then - exit; - while not(U^ in [#0,'&']) do inc(U); - if U^=#0 then - Next^ := nil else - Next^ := U+1; // jump '&' -end; - -function UrlDecodeInt64(U: PUTF8Char; const Upper: RawUTF8; - var Value: Int64; Next: PPUTF8Char): boolean; -var tmp: RawUTF8; -begin - result := UrlDecodeValue(U,Upper,tmp,Next); - if result then - SetInt64(pointer(tmp),Value); -end; - -function UrlDecodeExtended(U: PUTF8Char; const Upper: RawUTF8; - var Value: TSynExtended; Next: PPUTF8Char): boolean; -var tmp: RawUTF8; - err: integer; -begin - result := UrlDecodeValue(U,Upper,tmp,Next); - if result then begin - Value := GetExtended(pointer(tmp),err); - if err<>0 then - result := false; - end; -end; - -function UrlDecodeDouble(U: PUTF8Char; const Upper: RawUTF8; var Value: double; - Next: PPUTF8Char): boolean; -var tmp: RawUTF8; - err: integer; -begin - result := UrlDecodeValue(U,Upper,tmp,Next); - if result then begin - Value := GetExtended(pointer(tmp),err); - if err<>0 then - result := false; - end; -end; - -function UrlDecodeNeedParameters(U, CSVNames: PUTF8Char): boolean; -var tmp: array[byte] of AnsiChar; - L: integer; - Beg: PUTF8Char; -// UrlDecodeNeedParameters('price=20.45&where=LastName%3D','price,where') will -// return TRUE -begin - result := (CSVNames=nil); - if result then - exit; // no parameter to check -> success - if U=nil then - exit; // no input data -> error - repeat - L := 0; - while (CSVNames^<>#0) and (CSVNames^<>',') do begin - tmp[L] := NormToUpper[CSVNames^]; - if L=high(tmp) then - exit else // invalid CSV parameter - inc(L); - inc(CSVNames); - end; - if L=0 then - exit; // invalid CSV parameter - PWord(@tmp[L])^ := ord('='); - Beg := U; - repeat - if IdemPChar(U,tmp) then - break; - while not(U^ in [#0,'&']) do inc(U); - if U^=#0 then - exit else // didn't find tmp in U - inc(U); // Jump & - until false; - U := Beg; - if CSVNames^=#0 then - Break else // no more parameter to check - inc(CSVNames); // jump & - until false; - result := true; // all parameters found -end; - -function CSVEncode(const NameValuePairs: array of const; - const KeySeparator, ValueSeparator: RawUTF8): RawUTF8; -var i: integer; - temp: TTextWriterStackBuffer; -begin - if length(NameValuePairs)<2 then - result := '' else - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - for i := 1 to length(NameValuePairs) shr 1 do begin - Add(NameValuePairs[i*2-2],twNone); - AddNoJSONEscape(pointer(KeySeparator),length(KeySeparator)); - Add(NameValuePairs[i*2-1],twNone); - AddNoJSONEscape(pointer(ValueSeparator),length(ValueSeparator)); - end; - SetText(result); - finally - Free; - end; -end; - -function ArrayOfConstValueAsText(const NameValuePairs: array of const; - const aName: RawUTF8): RawUTF8; -var i: integer; - name: RawUTF8; -begin - for i := 1 to length(NameValuePairs) shr 1 do - if VarRecToUTF8IsString(NameValuePairs[i*2-2],name) and - IdemPropNameU(name,aName) then begin - VarRecToUTF8(NameValuePairs[i*2-1],result); - exit; - end; - result := ''; -end; - -function IsZero(P: pointer; Length: integer): boolean; -var i: integer; -begin - result := false; - for i := 1 to Length shr 4 do // 16 bytes (4 DWORD) by loop - aligned read - {$ifdef CPU64} - if (PInt64Array(P)^[0]<>0) or (PInt64Array(P)^[1]<>0) then - {$else} - if (PCardinalArray(P)^[0]<>0) or (PCardinalArray(P)^[1]<>0) or - (PCardinalArray(P)^[2]<>0) or (PCardinalArray(P)^[3]<>0) then - {$endif} - exit else - inc(PByte(P),16); - for i := 1 to (Length shr 2)and 3 do // 4 bytes (1 DWORD) by loop - if PCardinal(P)^<>0 then - exit else - inc(PByte(P),4); - for i := 1 to Length and 3 do // remaining content - if PByte(P)^<>0 then - exit else - inc(PByte(P)); - result := true; -end; - -function IsZeroSmall(P: pointer; Length: PtrInt): boolean; -begin - result := false; - repeat - if PByte(P)^<>0 then - exit; - inc(PByte(P)); - dec(Length); - if Length=0 then - break; - until false; - result := true; -end; - -function IsZero(const Values: TRawUTF8DynArray): boolean; -var i: integer; -begin - result := false; - for i := 0 to length(Values)-1 do - if Values[i]<>'' then - exit; - result := true; -end; - -function IsZero(const Values: TIntegerDynArray): boolean; -var i: integer; -begin - result := false; - for i := 0 to length(Values)-1 do - if Values[i]<>0 then - exit; - result := true; -end; - -function IsZero(const Values: TInt64DynArray): boolean; -var i: integer; -begin - result := false; - for i := 0 to length(Values)-1 do - if Values[i]<>0 then - exit; - result := true; -end; - -procedure FillZero(var Values: TRawUTF8DynArray); -var i: integer; -begin - for i := 0 to length(Values)-1 do - {$ifdef FPC}Finalize(Values[i]){$else}Values[i] := ''{$endif}; -end; - -procedure FillZero(var Values: TIntegerDynArray); -begin - FillCharFast(Values[0],length(Values)*SizeOf(integer),0); -end; - -procedure FillZero(var Values: TInt64DynArray); -begin - FillCharFast(Values[0],length(Values)*SizeOf(Int64),0); -end; - - -function crc16(Data: PAnsiChar; Len: integer): cardinal; -var i, j: Integer; -begin - result := $ffff; - for i := 0 to Len-1 do begin - result := result xor (ord(Data[i]) shl 8); - for j := 1 to 8 do - if result and $8000<>0 then - result := (result shl 1) xor $1021 else - result := result shl 1; - end; - result := result and $ffff; -end; - -function Hash32(const Text: RawByteString): cardinal; -begin - result := Hash32(pointer(Text),length(Text)); -end; - -function Hash32(Data: PCardinalArray; Len: integer): cardinal; -{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; -asm {$else} asm .noframe {$endif} // rcx/rdi=Data edx/esi=Len - xor eax, eax - xor r9d, r9d - test Data, Data - jz @z - {$ifdef win64} - mov r8, rdx - shr r8, 4 - {$else} - mov edx, esi - shr esi, 4 - {$endif} - jz @by4 - {$ifdef FPC} align 16 {$else} .align 16 {$endif} -@by16: add eax, dword ptr[Data] - add r9d, eax - add eax, dword ptr[Data+4] - add r9d, eax - add eax, dword ptr[Data+8] - add r9d, eax - add eax, dword ptr[Data+12] - add r9d, eax - add Data, 16 - {$ifdef win64} - dec r8d - {$else} - dec esi - {$endif} - jnz @by16 -@by4: mov dh, dl - and dl, 15 - jz @0 - shr dl, 2 - jz @rem -@4: add eax, dword ptr[Data] - add r9d, eax - add Data, 4 - dec dl - jnz @4 -@rem: and dh, 3 - jz @0 - dec dh - jz @1 - dec dh - jz @2 - mov ecx, dword ptr[Data] - and ecx, $ffffff - jmp @e -@2: movzx ecx, word ptr[Data] - jmp @e -@1: movzx ecx, byte ptr[Data] -@e: add eax, ecx -@0: add r9d, eax - shl r9d, 16 - xor eax, r9d -@z: -end; -{$else} -{$ifdef PUREPASCAL} -var s1,s2: cardinal; - i: integer; -begin - if Data<>nil then begin - s1 := 0; - s2 := 0; - for i := 1 to Len shr 4 do begin // 16 bytes (128-bit) loop - aligned read - inc(s1,Data[0]); - inc(s2,s1); - inc(s1,Data[1]); - inc(s2,s1); - inc(s1,Data[2]); - inc(s2,s1); - inc(s1,Data[3]); - inc(s2,s1); - Data := @Data[4]; - end; - for i := 1 to (Len shr 2)and 3 do begin // 4 bytes (DWORD) by loop - inc(s1,Data[0]); - inc(s2,s1); - Data := @Data[1]; - end; - case Len and 3 of // remaining 0..3 bytes - 1: inc(s1,PByte(Data)^); - 2: inc(s1,PWord(Data)^); - 3: inc(s1,PWord(Data)^ or (PByteArray(Data)^[2] shl 16)); - end; - inc(s2,s1); - result := s1 xor (s2 shl 16); - end else - result := 0; -end; -{$else} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=Data edx=Len - push esi - push edi - mov cl, dl - mov ch, dl - xor esi, esi - xor edi, edi - test eax, eax - jz @z - shr edx, 4 - jz @by4 - nop -@by16: add esi, dword ptr[eax] - add edi, esi - add esi, dword ptr[eax+4] - add edi, esi - add esi, dword ptr[eax+8] - add edi, esi - add esi, dword ptr[eax+12] - add edi, esi - add eax, 16 - dec edx - jnz @by16 -@by4: and cl, 15 - jz @0 - shr cl, 2 - jz @rem -@4: add esi, dword ptr[eax] - add edi, esi - add eax, 4 - dec cl - jnz @4 -@rem: and ch, 3 - jz @0 - dec ch - jz @1 - dec ch - jz @2 - mov eax, dword ptr[eax] - and eax, $ffffff - jmp @e -@2: movzx eax, word ptr[eax] - jmp @e -@1: movzx eax, byte ptr[eax] -@e: add esi, eax -@0: add edi, esi - mov eax, esi - shl edi, 16 - xor eax, edi -@z: pop edi - pop esi -end; -{$endif PUREPASCAL} -{$endif CPUX64} - -procedure OrMemory(Dest,Source: PByteArray; size: PtrInt); -begin - while size>=SizeOf(PtrInt) do begin - dec(size,SizeOf(PtrInt)); - PPtrInt(Dest)^ := PPtrInt(Dest)^ or PPtrInt(Source)^; - inc(PPtrInt(Dest)); - inc(PPtrInt(Source)); - end; - while size>0 do begin - dec(size); - Dest[size] := Dest[size] or Source[size]; - end; -end; - -procedure XorMemory(Dest,Source: PByteArray; size: PtrInt); -begin - while size>=SizeOf(PtrInt) do begin - dec(size,SizeOf(PtrInt)); - PPtrInt(Dest)^ := PPtrInt(Dest)^ xor PPtrInt(Source)^; - inc(PPtrInt(Dest)); - inc(PPtrInt(Source)); - end; - while size>0 do begin - dec(size); - Dest[size] := Dest[size] xor Source[size]; - end; -end; - -procedure XorMemory(Dest,Source1,Source2: PByteArray; size: PtrInt); -begin - while size>=SizeOf(PtrInt) do begin - dec(size,SizeOf(PtrInt)); - PPtrInt(Dest)^ := PPtrInt(Source1)^ xor PPtrInt(Source2)^; - inc(PPtrInt(Dest)); - inc(PPtrInt(Source1)); - inc(PPtrInt(Source2)); - end; - while size>0 do begin - dec(size); - Dest[size] := Source1[size] xor Source2[size]; - end; -end; - -procedure AndMemory(Dest,Source: PByteArray; size: PtrInt); -begin - while size>=SizeOf(PtrInt) do begin - dec(size,SizeOf(PtrInt)); - PPtrInt(Dest)^ := PPtrInt(Dest)^ and PPtrInt(Source)^; - inc(PPtrInt(Dest)); - inc(PPtrInt(Source)); - end; - while size>0 do begin - dec(size); - Dest[size] := Dest[size] and Source[size]; - end; -end; - -{$ifdef CPUINTEL} // use optimized x86/x64 asm versions for xxHash32 - -{$ifdef CPUX86} -function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm - xchg edx, ecx - push ebp - push edi - lea ebp, [ecx+edx] - push esi - push ebx - sub esp, 8 - mov ebx, eax - mov dword ptr [esp], edx - lea eax, [ebx+165667B1H] - cmp edx, 15 - jbe @2 - lea eax, [ebp-10H] - lea edi, [ebx+24234428H] - lea esi, [ebx-7A143589H] - mov dword ptr [esp+4H], ebp - mov edx, eax - lea eax, [ebx+61C8864FH] - mov ebp, edx -@1: mov edx, dword ptr [ecx] - imul edx, -2048144777 - add edi, edx - rol edi, 13 - imul edi, -1640531535 - mov edx, dword ptr [ecx+4] - imul edx, -2048144777 - add esi, edx - rol esi, 13 - imul esi, -1640531535 - mov edx, dword ptr [ecx+8] - imul edx, -2048144777 - add ebx, edx - rol ebx, 13 - imul ebx, -1640531535 - mov edx, dword ptr [ecx+12] - lea ecx, [ecx+16] - imul edx, -2048144777 - add eax, edx - rol eax, 13 - imul eax, -1640531535 - cmp ebp, ecx - jnc @1 - rol edi, 1 - rol esi, 7 - rol ebx, 12 - add esi, edi - mov ebp, dword ptr [esp+4H] - ror eax, 14 - add ebx, esi - add eax, ebx -@2: lea esi, [ecx+4H] - add eax, dword ptr [esp] - cmp ebp, esi - jc @4 - mov ebx, esi - nop -@3: imul edx, dword ptr [ebx-4H], -1028477379 - add ebx, 4 - add eax, edx - ror eax, 15 - imul eax, 668265263 - cmp ebp, ebx - jnc @3 - lea edx, [ebp-4H] - sub edx, ecx - mov ecx, edx - and ecx, 0FFFFFFFCH - add ecx, esi -@4: cmp ebp, ecx - jbe @6 -@5: movzx edx, byte ptr [ecx] - add ecx, 1 - imul edx, 374761393 - add eax, edx - rol eax, 11 - imul eax, -1640531535 - cmp ebp, ecx - jnz @5 - nop -@6: mov edx, eax - add esp, 8 - shr edx, 15 - xor eax, edx - imul eax, -2048144777 - pop ebx - pop esi - mov edx, eax - shr edx, 13 - xor eax, edx - imul eax, -1028477379 - pop edi - pop ebp - mov edx, eax - shr edx, 16 - xor eax, edx -end; -{$endif CPUX86} - -{$ifdef CPUX64} -function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe{$endif} - {$ifdef LINUX} // crc=rdi P=rsi len=rdx - mov r8, rdi - mov rcx, rsi - {$else} // crc=r8 P=rcx len=rdx - mov r10, r8 - mov r8, rcx - mov rcx, rdx - mov rdx, r10 - push rsi // Win64 expects those registers to be preserved - push rdi - {$endif} - // P=r8 len=rcx crc=rdx - push r12 - push rbx - mov r12d, -1640531535 - lea r10, [rcx+rdx] - lea eax, [r8+165667B1H] - cmp rdx, 15 - jbe @2 - lea rsi, [r10-10H] - lea ebx, [r8+24234428H] - lea edi, [r8-7A143589H] - lea eax, [r8+61C8864FH] -@1: imul r9d, dword ptr [rcx], -2048144777 - add rcx, 16 - imul r11d, dword ptr [rcx-0CH], -2048144777 - add ebx, r9d - lea r9d, [r11+rdi] - rol ebx, 13 - rol r9d, 13 - imul ebx, r12d - imul edi, r9d, -1640531535 - imul r9d, dword ptr [rcx-8H], -2048144777 - add r8d, r9d - imul r9d, dword ptr [rcx-4H], -2048144777 - rol r8d, 13 - imul r8d, r12d - add eax, r9d - rol eax, 13 - imul eax, r12d - cmp rsi, rcx - jnc @1 - rol edi, 7 - rol ebx, 1 - rol r8d, 12 - mov r9d, edi - ror eax, 14 - add r9d, ebx - add r8d, r9d - add eax, r8d -@2: lea r9, [rcx+4H] - add eax, edx - cmp r10, r9 - jc @4 - mov r8, r9 -@3: imul edx, dword ptr [r8-4H], -1028477379 - add r8, 4 - add eax, edx - ror eax, 15 - imul eax, 668265263 - cmp r10, r8 - jnc @3 - lea rdx, [r10-4H] - sub rdx, rcx - mov rcx, rdx - and rcx, 0FFFFFFFFFFFFFFFCH - add rcx, r9 -@4: cmp r10, rcx - jbe @6 -@5: movzx edx, byte ptr [rcx] - add rcx, 1 - imul edx, 374761393 - add eax, edx - rol eax, 11 - imul eax, r12d - cmp r10, rcx - jnz @5 -@6: mov edx, eax - shr edx, 15 - xor eax, edx - imul eax, -2048144777 - mov edx, eax - shr edx, 13 - xor eax, edx - imul eax, -1028477379 - mov edx, eax - shr edx, 16 - xor eax, edx - pop rbx - pop r12 - {$ifndef LINUX} - pop rdi - pop rsi - {$endif} -end; -{$endif CPUX64} - -{$else not CPUINTEL} - -const - PRIME32_1 = 2654435761; - PRIME32_2 = 2246822519; - PRIME32_3 = 3266489917; - PRIME32_4 = 668265263; - PRIME32_5 = 374761393; - -{$ifdef FPC} // RolDWord is an intrinsic function under FPC :) -function Rol13(value: cardinal): cardinal; inline; -begin - result := RolDWord(value, 13); -end; -{$else} -{$ifdef HASINLINENOTX86} -function RolDWord(value: cardinal; count: integer): cardinal; inline; -begin - result := (value shl count) or (value shr (32-count)); -end; - -function Rol13(value: cardinal): cardinal; inline; -begin - result := (value shl 13) or (value shr 19); -end; -{$else} -function RolDWord(value: cardinal; count: integer): cardinal; -asm - mov cl, dl - rol eax, cl -end; - -function Rol13(value: cardinal): cardinal; -asm - rol eax, 13 -end; -{$endif HASINLINENOTX86} -{$endif FPC} - -function xxHash32(crc: cardinal; P: PAnsiChar; len: integer): cardinal; -var c1, c2, c3, c4: cardinal; - PLimit, PEnd: PAnsiChar; -begin - PEnd := P + len; - if len >= 16 then begin - PLimit := PEnd - 16; - c3 := crc; - c2 := c3 + PRIME32_2; - c1 := c2 + PRIME32_1; - c4 := c3 - PRIME32_1; - repeat - c1 := PRIME32_1 * Rol13(c1 + PRIME32_2 * PCardinal(P)^); - c2 := PRIME32_1 * Rol13(c2 + PRIME32_2 * PCardinal(P+4)^); - c3 := PRIME32_1 * Rol13(c3 + PRIME32_2 * PCardinal(P+8)^); - c4 := PRIME32_1 * Rol13(c4 + PRIME32_2 * PCardinal(P+12)^); - inc(P, 16); - until not (P <= PLimit); - result := RolDWord(c1, 1) + RolDWord(c2, 7) + RolDWord(c3, 12) + RolDWord(c4, 18); - end else - result := crc + PRIME32_5; - inc(result, len); - while P + 4 <= PEnd do begin - inc(result, PCardinal(P)^ * PRIME32_3); - result := RolDWord(result, 17) * PRIME32_4; - inc(P, 4); - end; - while P < PEnd do begin - inc(result, PByte(P)^ * PRIME32_5); - result := RolDWord(result, 11) * PRIME32_1; - inc(P); - end; - result := result xor (result shr 15); - result := result * PRIME32_2; - result := result xor (result shr 13); - result := result * PRIME32_3; - result := result xor (result shr 16); -end; - -{$endif CPUINTEL} - -type - TRegisters = record - eax,ebx,ecx,edx: cardinal; - end; - -{$ifdef CPUINTEL} -{$ifdef CPU64} -procedure GetCPUID(Param: Cardinal; var Registers: TRegisters); -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // ecx=param, rdx=Registers (Linux: edi,rsi) -{$endif FPC} - mov eax, Param - mov r9, Registers - mov r10, rbx // preserve rbx - xor ebx, ebx - xor ecx, ecx - xor edx, edx - cpuid - mov TRegisters(r9).&eax, eax - mov TRegisters(r9).&ebx, ebx - mov TRegisters(r9).&ecx, ecx - mov TRegisters(r9).&edx, edx - mov rbx, r10 -end; - -{$ifndef ABSOLUTEPASCAL} -const - CMP_RANGES = $44; // see https://msdn.microsoft.com/en-us/library/bb531425 - _UpperCopy255BufSSE42: array[0..31] of AnsiChar = - 'azazazazazazazaz '; - -function UpperCopy255BufSSE42(dest: PAnsiChar; source: PUTF8Char; sourceLen: PtrInt): PAnsiChar; -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=dest, rdx=source, r8=len (Linux: rdi,rsi,rdx) -{$endif FPC} - {$ifdef win64} - mov rax, rcx - mov r9, rdx - mov rdx, r8 - {$else} - mov rax, rdi - mov r9, rsi - {$endif} - lea rcx, [rip + _UpperCopy255BufSSE42] - test rdx, rdx - jz @z - movups xmm1, dqword ptr [rcx] - movups xmm3, dqword ptr [rcx + 16] - cmp rdx, 16 - ja @big - // optimize the common case of sourceLen<=16 - movups xmm2, [r9] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, CMP_RANGES // find in range a-z, return mask in xmm0 - {$else} - db $66, $0F, $3A, $62, $CA, CMP_RANGES - {$endif} - pand xmm0, xmm3 - pxor xmm2, xmm0 - movups [rax], xmm2 - add rax, rdx -@z: ret -@big: mov rcx, rax - cmp rdx, 240 - jb @ok - mov rdx, 239 -@ok: add rax, rdx // return end position with the exact size - shr rdx, 4 - sub r9, rcx - add rdx, 1 -{$ifdef FPC} align 16 {$else} .align 16{$endif} -@s: movups xmm2, [r9 + rcx] - {$ifdef HASAESNI} - pcmpistrm xmm1, xmm2, CMP_RANGES - {$else} - db $66, $0F, $3A, $62, $CA, CMP_RANGES - {$endif} - pand xmm0, xmm3 - pxor xmm2, xmm0 - movups [rcx], xmm2 - add rcx, 16 - dec rdx - jnz @s -end; - -{$ifdef HASAESNI} -const - EQUAL_EACH = 8; // see https://msdn.microsoft.com/en-us/library/bb531463 - NEGATIVE_POLARITY = 16; - -function StrLenSSE42(S: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - xor rax, rax - mov rdx, S - test S, S - jz @null - xor rcx, rcx - pxor xmm0, xmm0 - pcmpistri xmm0, [rdx], EQUAL_EACH // result in ecx - jnz @L - mov eax, ecx -@null: ret -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@L: add rax, 16 // add before comparison flag - pcmpistri xmm0, [rdx + rax], EQUAL_EACH // result in ecx - jnz @L - add rax, rcx -end; - -function StrCompSSE42(Str1, Str2: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=Str1, rdx=Str2 (Linux: rdi,rsi) -{$endif FPC} - {$ifdef win64} - mov rax, rcx - test rcx, rdx - {$else} - mov rax, rdi - mov rdx, rsi - test rdi, rsi // is one of Str1/Str2 nil ? - {$endif} - jz @n -@ok: sub rax, rdx - xor rcx, rcx - movups xmm0, dqword [rdx] - pcmpistri xmm0, dqword [rdx + rax], EQUAL_EACH + NEGATIVE_POLARITY // result in rcx - ja @1 - jc @2 - xor rax, rax - ret -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@1: add rdx, 16 - movups xmm0, dqword [rdx] - pcmpistri xmm0, dqword [rdx + rax], EQUAL_EACH + NEGATIVE_POLARITY - ja @1 - jc @2 -@0: xor rax, rax // Str1=Str2 - ret -@n: cmp rax, rdx - je @0 - test rax, rax // Str1='' ? - jz @max - test rdx, rdx // Str2='' ? - jnz @ok - mov rax, 1 - ret -@max: dec rax // returns -1 - ret -@2: add rax, rdx - movzx rax, byte ptr [rax + rcx] - movzx rdx, byte ptr [rdx + rcx] - sub rax, rdx -end; -{$endif HASAESNI} -{$endif ABSOLUTEPASCAL} - -function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // ecx=crc, rdx=buf, r8=len (Linux: edi,rsi,edx) -{$endif FPC} - mov eax, crc - not eax - test len, len - jz @0 - test buf, buf - jz @0 - jmp @align -@7: crc32 eax, byte ptr[buf] - inc buf - dec len - jz @0 -@align: test buf, 7 - jnz @7 - mov ecx, len - shr len, 3 - jnz @s -@2: test cl, 4 - jz @3 - crc32 eax, dword ptr[buf] - add buf, 4 -@3: test cl, 2 - jz @1 - crc32 eax, word ptr[buf] - add buf, 2 -@1: test cl, 1 - jz @0 - crc32 eax, byte ptr[buf] -@0: not eax - ret -{$ifdef FPC} align 16 -@s: crc32 rax, qword [buf] // hash 8 bytes per loop -{$else} .align 16 -@s: db $F2,$48,$0F,$38,$F1,$02 // circumvent Delphi inline asm compiler bug -{$endif}add buf, 8 - dec len - jnz @s - jmp @2 -end; - -function StrLenSSE2(S: pointer): PtrInt; -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=S (Linux: rdi) -{$endif FPC} // from GPL strlen64.asm by Agner Fog - www.agner.org/optimize - {$ifdef win64} - mov rax, rcx // get pointer to string from rcx - mov r8, rcx // copy pointer - test rcx, rcx - {$else} - mov rax, rdi - mov ecx, edi - test rdi, rdi - {$endif} - jz @null // returns 0 if S=nil - // rax=s,ecx=32-bit of s - pxor xmm0, xmm0 // set to zero - and ecx, 15 // lower 4 bits indicate misalignment - and rax, -16 // align pointer by 16 - // will never read outside a memory page boundary, so won't trigger GPF - movaps xmm1, [rax] // read from nearest preceding boundary - pcmpeqb xmm1, xmm0 // compare 16 bytes with zero - pmovmskb edx, xmm1 // get one bit for each byte result - shr edx, cl // shift out false bits - shl edx, cl // shift back again - bsf edx, edx // find first 1-bit - jnz @L2 // found - // Main loop, search 16 bytes at a time -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@L1: add rax, 10H // increment pointer by 16 - movaps xmm1, [rax] // read 16 bytes aligned - pcmpeqb xmm1, xmm0 // compare 16 bytes with zero - pmovmskb edx, xmm1 // get one bit for each byte result - bsf edx, edx // find first 1-bit - // (moving the bsf out of the loop and using test here would be faster - // for long strings on old processors, but we are assuming that most - // strings are short, and newer processors have higher priority) - jz @L1 // loop if not found -@L2: // Zero-byte found. Compute string length - {$ifdef win64} - sub rax, r8 // subtract start address - {$else} - sub rax, rdi - {$endif} - add rax, rdx // add byte index -@null: -end; - -{$endif CPU64} - -procedure crcblockssse42(crc128, data128: PBlock128; count: integer); -{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe {$endif FPC} - test count, count - jle @z - mov rax, data128 - {$ifdef win64} - mov rdx, rcx - mov ecx, r8d - {$else} - mov ecx, edx - mov rdx, rdi - {$endif win64} - mov r8d, dword ptr [rdx] // we can't use qword ptr here - mov r9d, dword ptr [rdx + 4] - mov r10d, dword ptr [rdx + 8] - mov r11d, dword ptr [rdx + 12] -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@s: crc32 r8d, dword ptr [rax] - crc32 r9d, dword ptr [rax + 4] - crc32 r10d, dword ptr [rax + 8] - crc32 r11d, dword ptr [rax + 12] - add rax, 16 - dec ecx - jnz @s - mov dword ptr [rdx], r8d - mov dword ptr [rdx + 4], r9d - mov dword ptr [rdx + 8], r10d - mov dword ptr [rdx + 12], r11d -@z: -end; -{$else} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // eax=crc128 edx=data128 ecx=count - push ebx - push esi - push edi - push ebp - test count, count - jle @z - mov ebp, count - mov esi, crc128 - mov edi, data128 - mov eax, dword ptr[esi] - mov ebx, dword ptr[esi + 4] - mov ecx, dword ptr[esi + 8] - mov edx, dword ptr[esi + 12] -{$ifdef FPC_X86ASM} align 8 -@s: crc32 eax, dword ptr[edi] - crc32 ebx, dword ptr[edi + 4] - crc32 ecx, dword ptr[edi + 8] - crc32 edx, dword ptr[edi + 12] -{$else}@s:db $F2, $0F, $38, $F1, $07 - db $F2, $0F, $38, $F1, $5F, $04 - db $F2, $0F, $38, $F1, $4F, $08 - db $F2, $0F, $38, $F1, $57, $0C -{$endif} add edi, 16 - dec ebp - jnz @s - mov dword ptr[esi], eax - mov dword ptr[esi + 4], ebx - mov dword ptr[esi + 8], ecx - mov dword ptr[esi + 12], edx -@z: pop ebp - pop edi - pop esi - pop ebx -end; -{$endif CPUX64} -{$endif CPUINTEL} - -procedure crcblocksfast(crc128, data128: PBlock128; count: integer); -{$ifdef PUREPASCAL} // efficient registers use on 64-bit, ARM or PIC -var c: cardinal; - tab: PCrc32tab; -begin - tab := @crc32ctab; - if count>0 then - repeat - c := crc128^[0] xor data128^[0]; - crc128^[0] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; - c := crc128^[1] xor data128^[1]; - crc128^[1] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; - c := crc128^[2] xor data128^[2]; - crc128^[2] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; - c := crc128^[3] xor data128^[3]; - crc128^[3] := tab[3,ToByte(c)] xor tab[2,ToByte(c shr 8)] - xor tab[1,ToByte(c shr 16)] xor tab[0,ToByte(c shr 24)]; - inc(data128); - dec(count); - until count=0; -end; -{$else} // call optimized x86 asm within the loop -begin - while count>0 do begin - crcblockNoSSE42(crc128,data128); - inc(data128); - dec(count); - end; -end; -{$endif PUREPASCAL} - -{$ifdef CPUINTEL} -function crc32cBy4SSE42(crc, value: cardinal): cardinal; -{$ifdef CPU64} {$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe {$endif FPC} - mov eax, crc - crc32 eax, value -end; -{$else} {$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=crc, edx=value - {$ifdef FPC_X86ASM} - crc32 eax, edx - {$else} - db $F2, $0F, $38, $F1, $C2 - {$endif} -end; -{$endif CPU64} - -procedure crcblockSSE42(crc128, data128: PBlock128); -{$ifdef CPU64} {$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=crc128, rdx=data128 (Linux: rdi,rsi) -{$endif FPC} - mov eax, dword ptr[crc128] // we can't use two qword ptr here - mov r8d, dword ptr[crc128 + 4] - mov r9d, dword ptr[crc128 + 8] - mov r10d, dword ptr[crc128 + 12] - crc32 eax, dword ptr[data128] - crc32 r8d, dword ptr[data128 + 4] - crc32 r9d, dword ptr[data128 + 8] - crc32 r10d, dword ptr[data128 + 12] - mov dword ptr[crc128], eax - mov dword ptr[crc128 + 4], r8d - mov dword ptr[crc128 + 8], r9d - mov dword ptr[crc128 + 12], r10d -end; -{$else} {$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=crc128, edx=data128 - mov ecx, eax - {$ifdef FPC_X86ASM} - mov eax, dword ptr[ecx] - crc32 eax, dword ptr[edx] - mov dword ptr[ecx], eax - mov eax, dword ptr[ecx + 4] - crc32 eax, dword ptr[edx + 4] - mov dword ptr[ecx + 4], eax - mov eax, dword ptr[ecx + 8] - crc32 eax, dword ptr[edx + 8] - mov dword ptr[ecx + 8], eax - mov eax, dword ptr[ecx + 12] - crc32 eax, dword ptr[edx + 12] - mov dword ptr[ecx + 12], eax - {$else} - mov eax, dword ptr[ecx] - db $F2, $0F, $38, $F1, $02 - mov dword ptr[ecx], eax - mov eax, dword ptr[ecx + 4] - db $F2, $0F, $38, $F1, $42, $04 - mov dword ptr[ecx + 4], eax - mov eax, dword ptr[ecx + 8] - db $F2, $0F, $38, $F1, $42, $08 - mov dword ptr[ecx + 8], eax - mov eax, dword ptr[ecx + 12] - db $F2, $0F, $38, $F1, $42, $0C - mov dword ptr[ecx + 12], eax - {$endif FPC_OR_UNICODE} -end; -{$endif CPU64} -{$endif CPUINTEL} - -function crc32cBy4fast(crc, value: cardinal): cardinal; -var tab: PCrc32tab; -begin - tab := @crc32ctab; - result := crc xor value; - result := tab[3,ToByte(result)] xor - tab[2,ToByte(result shr 8)] xor - tab[1,ToByte(result shr 16)] xor - tab[0,ToByte(result shr 24)]; -end; - -function crc32cinlined(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; -{$ifdef HASINLINE} -var tab: PCrc32tab; -begin - result := not crc; - if len>0 then begin - tab := @crc32ctab; - repeat - result := tab[0,ToByte(result) xor ord(buf^)] xor (result shr 8); - inc(buf); - dec(len); - until len=0; - end; - result := not result; -end; -{$else} -begin - result := crc32c(crc,buf,len); -end; -{$endif} - -{$ifdef CPUX86} -procedure GetCPUID(Param: Cardinal; var Registers: TRegisters); -{$ifdef FPC}nostackframe; assembler;{$endif} -asm - push esi - push edi - mov esi, edx - mov edi, eax - pushfd - pop eax - mov edx, eax - xor eax, $200000 - push eax - popfd - pushfd - pop eax - xor eax, edx - jz @nocpuid - push ebx - mov eax, edi - xor ecx, ecx - {$ifdef DELPHI5OROLDER} - db $0f, $a2 - {$else} - cpuid - {$endif} - mov TRegisters(esi).&eax, eax - mov TRegisters(esi).&ebx, ebx - mov TRegisters(esi).&ecx, ecx - mov TRegisters(esi).&edx, edx - pop ebx -@nocpuid: - pop edi - pop esi -end; - -function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; -{$ifdef FPC}nostackframe; assembler;{$endif} -asm // eax=crc, edx=buf, ecx=len - not eax - test ecx, ecx - jz @0 - test edx, edx - jz @0 - jmp @align - db $8D, $0B4, $26, $00, $00, $00, $00 // manual @by8 align 16 -@a: {$ifdef FPC_X86ASM} - crc32 eax, byte ptr[edx] - {$else} - db $F2, $0F, $38, $F0, $02 - {$endif} - inc edx - dec ecx - jz @0 -@align: test dl, 3 - jnz @a - push ecx - shr ecx, 3 - jnz @by8 -@rem: pop ecx - test cl, 4 - jz @4 - {$ifdef FPC_X86ASM} - crc32 eax, dword ptr[edx] - {$else} - db $F2, $0F, $38, $F1, $02 - {$endif} - add edx, 4 -@4: test cl, 2 - jz @2 - {$ifdef FPC_X86ASM} - crc32 eax, word ptr[edx] - {$else} - db $66, $F2, $0F, $38, $F1, $02 - {$endif} - add edx, 2 -@2: test cl, 1 - jz @0 - {$ifdef FPC_X86ASM} - crc32 eax, byte ptr[edx] - {$else} - db $F2, $0F, $38, $F0, $02 - {$endif} -@0: not eax - ret -@by8: {$ifdef FPC_X86ASM} - crc32 eax, dword ptr[edx] - crc32 eax, dword ptr[edx + 4] - {$else} - db $F2, $0F, $38, $F1, $02 - db $F2, $0F, $38, $F1, $42, $04 - {$endif} - add edx, 8 - dec ecx - jnz @by8 - jmp @rem -end; -{$endif CPUX86} - -function crc32cUTF8ToHex(const str: RawUTF8): RawUTF8; -begin - result := CardinalToHex(crc32c(0,pointer(str),length(str))); -end; - -function crc64c(buf: PAnsiChar; len: cardinal): Int64; -var hilo: Int64Rec absolute result; -begin - hilo.Lo := crc32c(0,buf,len); - hilo.Hi := crc32c(hilo.Lo,buf,len); -end; - -function crc63c(buf: PAnsiChar; len: cardinal): Int64; -var hilo: Int64Rec absolute result; -begin - hilo.Lo := crc32c(0,buf,len); - hilo.Hi := crc32c(hilo.Lo,buf,len) and $7fffffff; -end; - -procedure crc128c(buf: PAnsiChar; len: cardinal; out crc: THash128); -var h: THash128Rec absolute crc; - h1,h2: cardinal; -begin // see https://goo.gl/Pls5wi - h1 := crc32c(0,buf,len); - h2 := crc32c(h1,buf,len); - h.i0 := h1; inc(h1,h2); - h.i1 := h1; inc(h1,h2); - h.i2 := h1; inc(h1,h2); - h.i3 := h1; -end; - -function IsZero(const dig: THash128): boolean; -var a: TPtrIntArray absolute dig; -begin - result := a[0] or a[1] {$ifndef CPU64}or a[2] or a[3]{$endif} = 0; -end; - -function IsEqual(const A,B: THash128): boolean; -var a_: TPtrIntArray absolute A; - b_: TPtrIntArray absolute B; -begin // uses anti-forensic time constant "xor/or" pattern - result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) - {$ifndef CPU64} or (a_[2] xor b_[2]) or (a_[3] xor b_[3]){$endif})=0; -end; - -procedure FillZero(out dig: THash128); -var d: TInt64Array absolute dig; -begin - d[0] := 0; - d[1] := 0; -end; - -function Hash128Index(P: PHash128Rec; Count: integer; h: PHash128Rec): integer; -{$ifdef CPU64} -var _0, _1: PtrInt; -begin - if P<>nil then begin - _0 := h^.Lo; - _1 := h^.Hi; - for result := 0 to Count-1 do - if (P^.Lo=_0) and (P^.Hi=_1) then - exit else - inc(P); - end; - result := -1; // not found -end; -{$else} -begin // fast O(n) brute force search - if P<>nil then - for result := 0 to Count-1 do - if (P^.i0=h^.i0) and (P^.i1=h^.i1) and (P^.i2=h^.i2) and (P^.i3=h^.i3) then - exit else - inc(P); - result := -1; // not found -end; -{$endif CPU64} - -function IP4Text(ip4: cardinal): shortstring; -var b: array[0..3] of byte absolute ip4; -begin - if ip4=0 then - result := '' else - FormatShort('%.%.%.%',[b[0],b[1],b[2],b[3]],result); -end; - -procedure IP6Text(ip6: PHash128; result: PShortString); -var i: integer; - p: PByte; - {$ifdef PUREPASCAL}tab: ^TByteToWord;{$endif} -begin - if IsZero(ip6^) then - result^ := '' else begin - result^[0] := AnsiChar(39); - p := @result^[1]; - {$ifdef PUREPASCAL}tab := @TwoDigitsHexWBLower;{$endif} - for i := 0 to 7 do begin - PWord(p)^ := {$ifdef PUREPASCAL}tab{$else}TwoDigitsHexWBLower{$endif}[ip6^[0]]; inc(p,2); - PWord(p)^ := {$ifdef PUREPASCAL}tab{$else}TwoDigitsHexWBLower{$endif}[ip6^[1]]; inc(p,2); - inc(PWord(ip6)); - p^ := ord(':'); inc(p); - end; - end; -end; - -function IP6Text(ip6: PHash128): shortstring; -begin - IP6Text(ip6, @result); -end; - -function IsZero(const dig: THash160): boolean; -var a: TIntegerArray absolute dig; -begin - result := a[0] or a[1] or a[2] or a[3] or a[4] = 0; -end; - -function IsEqual(const A,B: THash160): boolean; -var a_: TIntegerArray absolute A; - b_: TIntegerArray absolute B; -begin // uses anti-forensic time constant "xor/or" pattern - result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or - (a_[3] xor b_[3]) or (a_[4] xor b_[4]))=0; -end; - -procedure FillZero(out dig: THash160); -begin - PInt64Array(@dig)^[0] := 0; - PInt64Array(@dig)^[1] := 0; - PIntegerArray(@dig)^[4] := 0; -end; - -procedure crc256c(buf: PAnsiChar; len: cardinal; out crc: THash256); -var h: THash256Rec absolute crc; - h1,h2: cardinal; -begin // see https://goo.gl/Pls5wi - h1 := crc32c(0,buf,len); - h2 := crc32c(h1,buf,len); - h.i0 := h1; inc(h1,h2); - h.i1 := h1; inc(h1,h2); - h.i2 := h1; inc(h1,h2); - h.i3 := h1; inc(h1,h2); - h.i4 := h1; inc(h1,h2); - h.i5 := h1; inc(h1,h2); - h.i6 := h1; inc(h1,h2); - h.i7 := h1; -end; - -function IsZero(const dig: THash256): boolean; -var a: TPtrIntArray absolute dig; -begin - result := a[0] or a[1] or a[2] or a[3] - {$ifndef CPU64} or a[4] or a[5] or a[6] or a[7]{$endif} = 0; -end; - -function IsEqual(const A,B: THash256): boolean; -var a_: TPtrIntArray absolute A; - b_: TPtrIntArray absolute B; -begin // uses anti-forensic time constant "xor/or" pattern - result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or - (a_[2] xor b_[2]) or (a_[3] xor b_[3]) - {$ifndef CPU64} or (a_[4] xor b_[4]) or (a_[5] xor b_[5]) - or (a_[6] xor b_[6]) or (a_[7] xor b_[7]) {$endif})=0; -end; - -function Hash256Index(P: PHash256Rec; Count: integer; h: PHash256Rec): integer; -{$ifdef CPU64} -var _0, _1: PtrInt; -begin // fast O(n) brute force search - if P<>nil then begin - _0 := h^.d0; - _1 := h^.d1; - for result := 0 to Count-1 do - if (P^.d0=_0) and (P^.d1=_1) and (P^.d2=h^.d2) and (P^.d3=h^.d3) then - exit else - inc(P); - end; - result := -1; // not found -end; -{$else} -begin - if P<>nil then - for result := 0 to Count-1 do - if (P^.i0=h^.i0) and (P^.i1=h^.i1) and (P^.i2=h^.i2) and (P^.i3=h^.i3) and - (P^.i4=h^.i4) and (P^.i5=h^.i5) and (P^.i6=h^.i6) and (P^.i7=h^.i7) then - exit else - inc(P); - result := -1; // not found -end; -{$endif CPU64} - -procedure FillZero(out dig: THash256); -var d: TInt64Array absolute dig; -begin - d[0] := 0; - d[1] := 0; - d[2] := 0; - d[3] := 0; -end; - -function IsZero(const dig: THash384): boolean; -var a: TPtrIntArray absolute dig; -begin - result := a[0] or a[1] or a[2] or a[3] or a[4] or a[5] - {$ifndef CPU64} or a[6] or a[7] or a[8] or a[9] or a[10] or a[11] {$endif} = 0; -end; - -function IsEqual(const A,B: THash384): boolean; -var a_: TPtrIntArray absolute A; - b_: TPtrIntArray absolute B; -begin // uses anti-forensic time constant "xor/or" pattern - result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or - (a_[2] xor b_[2]) or (a_[3] xor b_[3]) or - (a_[4] xor b_[4]) or (a_[5] xor b_[5]) - {$ifndef CPU64} or (a_[6] xor b_[6]) or (a_[7] xor b_[7]) - or (a_[8] xor b_[8]) or (a_[9] xor b_[9]) - or (a_[10] xor b_[10]) or (a_[11] xor b_[11]) {$endif})=0; -end; - -procedure FillZero(out dig: THash384); -var d: TInt64Array absolute dig; -begin - d[0] := 0; - d[1] := 0; - d[2] := 0; - d[3] := 0; - d[4] := 0; - d[5] := 0; -end; - -function IsZero(const dig: THash512): boolean; -var a: TPtrIntArray absolute dig; -begin - result := a[0] or a[1] or a[2] or a[3] or a[4] or a[5] or a[6] or a[7] {$ifndef CPU64} - or a[8] or a[9] or a[10] or a[11] or a[12] or a[13] or a[14] or a[15] {$endif} = 0; -end; - -function IsEqual(const A,B: THash512): boolean; -var a_: TPtrIntArray absolute A; - b_: TPtrIntArray absolute B; -begin // uses anti-forensic time constant "xor/or" pattern - result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or - (a_[2] xor b_[2]) or (a_[3] xor b_[3]) or - (a_[4] xor b_[4]) or (a_[5] xor b_[5]) or - (a_[6] xor b_[6]) or (a_[7] xor b_[7]) - {$ifndef CPU64} or (a_[8] xor b_[8]) or (a_[9] xor b_[9]) - or (a_[10] xor b_[10]) or (a_[11] xor b_[11]) - or (a_[12] xor b_[12]) or (a_[13] xor b_[13]) - or (a_[14] xor b_[14]) or (a_[15] xor b_[15]) {$endif})=0; -end; - -procedure FillZero(out dig: THash512); -var d: TInt64Array absolute dig; -begin - d[0] := 0; - d[1] := 0; - d[2] := 0; - d[3] := 0; - d[4] := 0; - d[5] := 0; - d[6] := 0; - d[7] := 0; -end; - -procedure crc512c(buf: PAnsiChar; len: cardinal; out crc: THash512); -var h: THash512Rec absolute crc; - h1,h2: cardinal; -begin // see https://goo.gl/Pls5wi - h1 := crc32c(0,buf,len); - h2 := crc32c(h1,buf,len); - h.i0 := h1; inc(h1,h2); - h.i1 := h1; inc(h1,h2); - h.i2 := h1; inc(h1,h2); - h.i3 := h1; inc(h1,h2); - h.i4 := h1; inc(h1,h2); - h.i5 := h1; inc(h1,h2); - h.i6 := h1; inc(h1,h2); - h.i7 := h1; inc(h1,h2); - h.i8 := h1; inc(h1,h2); - h.i9 := h1; inc(h1,h2); - h.i10 := h1; inc(h1,h2); - h.i11 := h1; inc(h1,h2); - h.i12 := h1; inc(h1,h2); - h.i13 := h1; inc(h1,h2); - h.i14 := h1; inc(h1,h2); - h.i15 := h1; -end; - -procedure FillZero(var secret: RawByteString); -begin - if secret<>'' then - with PStrRec(Pointer(PtrInt(secret)-STRRECSIZE))^ do - if refCnt=1 then // avoid GPF if const - FillCharFast(pointer(secret)^,length,0); -end; - -procedure FillZero(var secret: RawUTF8); -begin - if secret<>'' then - with PStrRec(Pointer(PtrInt(secret)-STRRECSIZE))^ do - if refCnt=1 then // avoid GPF if const - FillCharFast(pointer(secret)^,length,0); -end; - -procedure mul64x64(const left, right: QWord; out product: THash128Rec); -{$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx/rdi=left, rdx/rsi=right r8/rdx=product -{$endif}{$ifdef WIN64} - mov rax, rcx - mul rdx // uses built-in 64-bit -> 128-bit multiplication -{$else} mov r8, rdx - mov rax, rdi - mul rsi -{$endif}mov qword ptr [r8], rax - mov qword ptr [r8+8], rdx -end; -{$else} -{$ifdef CPUX86} {$ifdef FPC} nostackframe; assembler; {$endif} -asm // adapted from FPC compiler output, which is much better than Delphi's here - {$ifdef FPC} - push ebp - mov ebp, esp - {$endif FPC} - mov ecx, eax - mov eax, dword ptr [ebp+8H] - mul dword ptr [ebp+10H] - mov dword ptr [ecx], eax - mov dword ptr [ebp-4H], edx - mov eax, dword ptr [ebp+8H] - mul dword ptr [ebp+14H] - add eax, dword ptr [ebp-4H] - adc edx, 0 - mov dword ptr [ebp-10H], eax - mov dword ptr [ebp-0CH], edx - mov eax, dword ptr [ebp+0CH] - mul dword ptr [ebp+10H] - add eax, dword ptr [ebp-10H] - adc edx, 0 - mov dword ptr [ecx+4H], eax - mov dword ptr [ebp-14H], edx - mov eax, dword ptr [ebp+0CH] - mul dword ptr [ebp+14H] - add eax, dword ptr [ebp-0CH] - adc edx, 0 - add eax, dword ptr [ebp-14H] - adc edx, 0 - mov dword ptr [ecx+8H], eax - mov dword ptr [ecx+0CH], edx - {$ifdef FPC} - pop ebp - {$endif FPC} -end; -{$else} // CPU-neutral implementation -var l: TQWordRec absolute left; - r: TQWordRec absolute right; - t1,t2,t3: TQWordRec; -begin - t1.V := QWord(l.L)*r.L; - t2.V := QWord(l.H)*r.L+t1.H; - t3.V := QWord(l.L)*r.H+t2.L; - product.H := QWord(l.H)*r.H+t2.H+t3.H; - product.L := t3.V shl 32 or t1.L; -end; -{$endif CPUX86} -{$endif CPUX64} - -{$ifndef ABSOLUTEPASCAL} -{$ifdef CPUX64} -const - // non-temporal writes should bypass the cache when the size is bigger than - // half the size of the largest level cache - we assume low 1MB cache here - CPUCACHEX64 = 512*1024; - -{ - regarding benchmark numbers from TTestLowLevelCommon.CustomRTL - -> FillCharFast/MoveFast are faster, especially for small lengths (strings) - -> Delphi RTL is lower than FPC's, and it doesn't support AVX assembly yet - -> cpuERMS - of little benefit - is disabled, unless WITH_ERMS is defined - http://blog.synopse.info/post/2020/02/17/New-move/fillchar-optimized-sse2/avx-asm-version -} - -// these stand-alone functions will use CPUIDX64 to adjust the algorithm -procedure MoveFast(const src; var dst; cnt: PtrInt); -{$ifdef FPC}nostackframe; assembler; -asm {$else} asm .noframe {$endif} // rcx/rdi=src rdx/rsi=dst r8/rdx=cnt - {$ifdef WIN64} - mov rax, r8 - {$else} - mov rax, rdx // rax=r8=cnt - mov r8, rdx - {$endif} - lea r10, [rip+@jmptab] - cmp src, dst - je @equal - cmp cnt, 32 - ja @lrg // >32 or <0 - sub rax, 8 - jg @sml // 9..32 - jmp qword ptr[r10 + 64 + rax * 8] // 0..8 -@equal: ret -{$ifdef FPC} align 8 {$else} .align 8 {$endif} -@jmptab:dq @exit, @01, @02, @03, @04, @05, @06, @07, @08 -@sml: mov r8, qword ptr[src + rax] // last 8 - mov r9, qword ptr[src] // first 8 - cmp al, 8 - jle @sml16 - mov r10, qword ptr[src + 8] // second 8 - cmp al, 16 - jle @sml24 - mov r11, qword ptr[src + 16] // third 8 - mov qword ptr[dst + 16], r11 // third 8 -@sml24: mov qword ptr[dst + 8], r10 // second 8 -@sml16: mov qword ptr[dst], r9 // first 8 - mov qword ptr[dst + rax], r8 // last 8 (may be overlapping) - ret -@02: movzx eax, word ptr[src] // use small size moves as code alignment - mov word ptr[dst], ax - ret -@04: mov eax, [src] - mov dword ptr[dst], eax - ret -@08: mov rax, [src] - mov [dst], rax -@exit: ret -@lrg: jng @exit // cnt < 0 - cmp src, dst - ja @lrgfwd - sub dst, rax - cmp src, dst - lea dst, [dst + rax] - ja @lrgbwd -@lrgfwd:{$ifdef WITH_ERMS} - test byte ptr[rip+CPUIDX64], 1 shl cpuERMS - jz @nofwe - cmp rax, 2048 - jb @nofwe - cld -@repmov:{$ifdef WIN64} - push rsi - push rdi - mov rsi, src - mov rdi, dst - mov rcx, r8 - rep movsb - pop rdi - pop rsi - {$else} - mov rax, dst // dst=rsi and src=rdi -> rax to swap - mov rsi, src - mov rdi, rax - mov rcx, r8 - rep movsb - {$endif} - ret -@nofwe: {$endif WITH_ERMS} - mov r9, dst - {$ifdef FPC} // no AVX asm on Delphi :( - cmp rax, 256 // vzeroupper penaly for cnt>255 - jb @fsse2 - test byte ptr[rip+CPUIDX64], 1 shl cpuAVX - jnz @fwdavx - {$endif FPC} -@fsse2: movups xmm2, oword ptr[src] // first 16 - lea src, [src + rax - 16] - lea rax, [rax + dst - 16] - movups xmm1, oword ptr[src] // last 16 - mov r10, rax - neg rax - and dst, -16 // 16-byte aligned writes - lea rax, [rax + dst + 16] - cmp r8, CPUCACHEX64 - ja @fwdnv // bypass cache for cnt>512KB -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@fwd: movups xmm0, oword ptr[src + rax] // regular loop - movaps [r10 + rax], xmm0 - add rax, 16 - jl @fwd -@fwdend:movups [r10], xmm1 // last 16 - movups [r9], xmm2 // first 16 - ret -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@fwdnv: movups xmm0, oword ptr[src + rax] // non-temporal loop - movntdq [r10 + rax], xmm0 - add rax, 16 - jl @fwdnv - sfence - jmp @fwdend -{$ifdef FPC} -@fwdavx:vmovups ymm2, oword ptr[src] // first 32 - lea src, [src + rax - 32] - lea rax, [rax + dst - 32] - vmovups ymm1, oword ptr[src] // last 32 - mov r10, rax - neg rax - and dst, -32 // 32-byte aligned writes - lea rax, [rax + dst + 32] - cmp r8, CPUCACHEX64 - ja @favxn // bypass cache for cnt>512KB - align 16 -@favxr: vmovups ymm0, oword ptr[src + rax] // regular loop - vmovaps [r10 + rax], ymm0 - add rax, 32 - jl @favxr -@favxe: vmovups [r10], ymm1 // last 32 - vmovups [r9], ymm2 // first 32 -// https://software.intel.com/en-us/articles/avoiding-avx-sse-transition-penalties - vzeroupper - ret - align 16 -@favxn: vmovups ymm0, oword ptr[src + rax] // non-temporal loop - vmovntps [r10 + rax], ymm0 - add rax, 32 - jl @favxn - sfence - jmp @favxe -{$endif FPC} -@lrgbwd:{$ifdef WITH_ERMS} // backward move - test byte ptr[rip+CPUIDX64], 1 shl cpuERMS - jz @nobwe - cmp rax, 2048 - jb @nobwe - std - lea src, [src + rax - 1] - lea dst, [dst + rax - 1] - jmp @repmov -@nobwe: {$endif WITH_ERMS} - {$ifdef FPC} - cmp rax, 256 - jb @bsse2 - test byte ptr[rip+CPUIDX64], 1 shl cpuAVX - jnz @bwdavx - {$endif FPC} -@bsse2: sub rax, 16 - mov r9, rax - movups xmm2, oword ptr[src + rax] // last 16 - movups xmm1, oword ptr[src] // first 16 - add rax, dst - and rax, -16 // 16-byte aligned writes - sub rax, dst - cmp r8, CPUCACHEX64 - ja @bwdnv // bypass cache for cnt>512KB -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@bwd: movups xmm0, oword ptr[src + rax] // regular loop - movaps oword ptr[dst + rax], xmm0 - sub rax, 16 - jg @bwd -@bwdend:movups oword ptr[dst], xmm1 // first 16 - movups oword ptr[dst + r9], xmm2 // last 16 - ret -@01: mov al, byte ptr[src] - mov byte ptr[dst], al - ret -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@bwdnv: movups xmm0, oword ptr[src + rax] // non-temporal loop - movntdq oword ptr[dst + rax], xmm0 - sub rax, 16 - jg @bwdnv - sfence - jmp @bwdend -{$ifdef FPC} -@bwdavx:sub rax, 32 - mov r9, rax - vmovups ymm2, oword ptr[src + rax] // last 32 - vmovups ymm1, oword ptr[src] // first 32 - add rax, dst - and rax, -32 // 32-byte aligned writes - sub rax, dst - cmp r8, CPUCACHEX64 - ja @bavxn // bypass cache for cnt>512KB - align 16 -@bavxr: vmovups ymm0, oword ptr[src + rax] // regular loop - vmovaps oword ptr[dst + rax], ymm0 - sub rax, 32 - jg @bavxr -@bavxe: vmovups oword ptr[dst], ymm1 // first 32 - vmovups oword ptr[dst + r9], ymm2 // last 32 - vzeroupper - ret - align 16 -@bavxn: vmovups ymm0, oword ptr[src + rax] // non-temporal loop - vmovntps oword ptr[dst + rax], ymm0 - sub rax, 32 - jg @bavxn - sfence - jmp @bavxe -{$endif FPC} -@03: movzx eax, word ptr[src] - mov cl, byte ptr[src + 2] - mov word ptr[dst], ax - mov byte ptr[dst + 2], cl - ret -@05: mov eax, dword ptr[src] - mov cl, byte ptr[src + 4] - mov dword ptr[dst], eax - mov byte ptr[dst + 4], cl - ret -@06: mov eax, dword ptr[src] - mov cx, word ptr[src + 4] - mov dword ptr[dst], eax - mov word ptr[dst + 4], cx - ret -@07: mov r8d, dword ptr[src] // faster with no overlapping - mov ax, word ptr[src + 4] - mov cl, byte ptr[src + 6] - mov dword ptr[dst], r8d - mov word ptr[dst + 4], ax - mov byte ptr[dst + 6], cl -end; - -procedure FillCharFast(var dst; cnt: PtrInt; value: byte); -{$ifdef FPC}nostackframe; assembler; -asm {$else} asm .noframe {$endif} // rcx/rdi=dst rdx/rsi=cnt r8b/dl=val - mov r9, $0101010101010101 - lea r10, [rip+@jmptab] - {$ifdef WIN64} - movzx eax, r8b - {$else} - movzx eax, dl - mov rdx, rsi // rdx=cnt - {$endif} - imul rax, r9 // broadcast value into all bytes of rax (in 1 cycle) - cmp cnt, 32 - ja @abv32 // >32 or <0 - sub rdx, 8 - jg @sml // small 9..32 - jmp qword ptr[r10 + 64 + rdx*8] // tiny 0..8 bytes -{$ifdef FPC} align 8 {$else} .align 8 {$endif} -@jmptab:dq @00, @01, @02, @03, @04, @05, @06, @07, @08 -@sml: cmp dl, 8 // 9..32 bytes - jle @sml16 - cmp dl, 16 - jle @sml24 - mov qword ptr[dst+16], rax -@sml24: mov qword ptr[dst+8], rax -@sml16: mov qword ptr[dst+rdx], rax // last 8 (may be overlapping) -@08: mov qword ptr[dst], rax -@00: ret -@07: mov dword ptr[dst+3], eax -@03: mov word ptr[dst+1], ax -@01: mov byte ptr[dst], al - ret -@06: mov dword ptr[dst+2], eax -@02: mov word ptr[dst], ax - ret -@05: mov byte ptr[dst+4], al -@04: mov dword ptr[dst], eax - ret -{$ifdef FPC} align 8{$else} .align 8{$endif} -@abv32: jng @00 // < 0 - movd xmm0, eax - lea r8, [dst+cnt] // r8 point to end - pshufd xmm0, xmm0, 0 // broadcast value into all bytes of xmm0 - mov r10, rdx // save rdx=cnt - {$ifdef FPC} // Delphi doesn't support avx, and erms is slower - cmp rdx, 256 - jae @abv256 // try erms or avx if cnt>255 (vzeroupper penalty) - {$endif FPC} -@sse2: movups oword ptr[dst], xmm0 // first unaligned 16 bytes - lea rdx, [dst+rdx-1] - and rdx, -16 - add dst, 16 - and dst, -16 // dst is 16-bytes aligned - sub dst, rdx - jnb @last - cmp r10, CPUCACHEX64 - ja @nv // bypass cache for cnt>512KB -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@reg: movaps oword ptr[rdx+dst], xmm0 // regular loop - add dst, 16 - jnz @reg -@last: movups oword ptr[r8-16], xmm0 // last unaligned 16 bytes - ret -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@nv: movntdq [rdx+dst], xmm0 // non-temporal loop - add dst, 16 - jnz @nv - sfence - movups oword ptr[r8-16], xmm0 - ret -{$ifdef FPC} -@abv256:{$ifdef WITH_ERMS} - mov r9b, byte ptr[rip+CPUIDX64] - test r9b, 1 shl cpuERMS - jz @noerms - cmp rdx, 2048 // ERMS is worth it for cnt>2KB - jb @noerms - cmp rdx, CPUCACHEX64 // non-temporal moves are still faster - jae @noerms - cld -{$ifdef WIN64} - mov r8, rdi - mov rdi, dst - mov rcx, cnt - rep stosb - mov rdi, r8 -{$else} mov rcx, cnt - rep stosb -{$endif}ret -@noerms:test r9b, 1 shl cpuAVX -{$else} test byte ptr[rip+CPUIDX64], 1 shl cpuAVX - {$endif WITH_ERMS} - jz @sse2 - movups oword ptr[dst], xmm0 // first unaligned 1..16 bytes - add dst, 16 - and dst, -16 - movaps oword ptr[dst], xmm0 // aligned 17..32 bytes - vinsertf128 ymm0,ymm0,xmm0,1 - add dst, 16 - and dst, -32 // dst is 32-bytes aligned - mov rdx, r8 - and rdx, -32 - sub dst, rdx - cmp r10, CPUCACHEX64 - ja @avxnv - align 16 -@avxreg:vmovaps ymmword ptr[rdx+dst], ymm0 // regular loop - add dst, 32 - jnz @avxreg -@avxok: vmovups oword ptr[r8-32], ymm0 // last unaligned 32 bytes - vzeroupper - ret - align 16 -@avxnv: vmovntps oword ptr [rdx+dst], ymm0 // non-temporal loop - add dst, 32 - jnz @avxnv - sfence - jmp @avxok -{$endif FPC} -end; -{$endif CPUX64} -{$endif ABSOLUTEPASCAL} - -procedure SymmetricEncrypt(key: cardinal; var data: RawByteString); -var i,len: integer; - d: PCardinal; - tab: PCrc32tab; -begin - if data='' then - exit; // nothing to cypher - tab := @crc32ctab; - {$ifdef FPC} - UniqueString(data); // @data[1] won't call UniqueString() under FPC :( - {$endif} - d := @data[1]; - len := length(data); - key := key xor cardinal(len); - for i := 0 to (len shr 2)-1 do begin - key := key xor tab[0,(cardinal(i) xor key)and 1023]; - d^ := d^ xor key; - inc(d); - end; - for i := 0 to (len and 3)-1 do - PByteArray(d)^[i] := PByteArray(d)^[i] xor key xor tab[0,17 shl i]; -end; - -function UnixTimeToDateTime(const UnixTime: TUnixTime): TDateTime; -begin - result := UnixTime / SecsPerDay + UnixDateDelta; -end; - -function DateTimeToUnixTime(const AValue: TDateTime): TUnixTime; -begin - result := Round((AValue - UnixDateDelta) * SecsPerDay); -end; - -const - UnixFileTimeDelta = 116444736000000000; // from year 1601 to 1970 - DateFileTimeDelta = 94353120000000000; // from year 1601 to 1899 - -{$ifdef MSWINDOWS} -function FileTimeToUnixTime(const FT: TFileTime): TUnixTime; -{$ifdef CPU64}var nano100: Int64;{$endif} -begin - {$ifdef CPU64} - FileTimeToInt64(ft,nano100); - result := (nano100-UnixFileTimeDelta) div 10000000; - {$else} // use PInt64 to avoid URW699 with Delphi 6 / Kylix - result := (PInt64(@ft)^-UnixFileTimeDelta) div 10000000; - {$endif} -end; - -function FileTimeToUnixMSTime(const FT: TFileTime): TUnixMSTime; -{$ifdef CPU64}var nano100: Int64;{$endif} -begin - {$ifdef CPU64} - FileTimeToInt64(ft,nano100); - result := (nano100-UnixFileTimeDelta) div 10000; - {$else} // use PInt64 to avoid URW699 with Delphi 6 / Kylix - result := (PInt64(@ft)^-UnixFileTimeDelta) div 10000; - {$endif} -end; - -function UnixTimeUTC: TUnixTime; -var ft: TFileTime; -begin - GetSystemTimeAsFileTime(ft); // very fast, with 100 ns unit - result := FileTimeToUnixTime(ft); -end; - -function UnixMSTimeUTC: TUnixMSTime; -var ft: TFileTime; -begin - GetSystemTimePreciseAsFileTime(ft); // slower, but try to achieve ms resolution - result := FileTimeToUnixMSTime(ft); -end; - -function UnixMSTimeUTCFast: TUnixMSTime; -var ft: TFileTime; -begin - GetSystemTimeAsFileTime(ft); // faster, but with HW interupt resolution - result := FileTimeToUnixMSTime(ft); -end; -{$else MSWINDOWS} -function UnixTimeUTC: TUnixTime; -begin - result := GetUnixUTC; // direct retrieval from UNIX API -end; - -function UnixMSTimeUTC: TUnixMSTime; -begin - result := GetUnixMSUTC; // direct retrieval from UNIX API -end; - -function UnixMSTimeUTCFast: TUnixMSTime; -begin - result := GetUnixMSUTC; // direct retrieval from UNIX API -end; -{$endif MSWINDOWS} - -function DaysToIso8601(Days: cardinal; Expanded: boolean): RawUTF8; -var Y,M: cardinal; -begin - Y := 0; - while Days>365 do begin - dec(Days,366); - inc(Y); - end; - M := 0; - if Days>31 then begin - inc(M); - while Days>MonthDays[false][M] do begin - dec(Days,MonthDays[false][M]); - inc(M); - end; - end; - result := DateToIso8601(Y,M,Days,Expanded); -end; - -function UnixTimeToString(const UnixTime: TUnixTime; Expanded: boolean; - FirstTimeChar: AnsiChar): RawUTF8; -begin // inlined UnixTimeToDateTime - result := DateTimeToIso8601(UnixTime/SecsPerDay+UnixDateDelta,Expanded, - FirstTimeChar,false); -end; - -function DateTimeToFileShort(const DateTime: TDateTime): TShort16; -begin - DateTimeToFileShort(DateTime,result); -end; - -procedure DateTimeToFileShort(const DateTime: TDateTime; out result: TShort16); -var T: TSynSystemTime; - tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; -begin // use 'YYMMDDHHMMSS' format - if DateTime<=0 then begin - PWord(@result[0])^ := 1+ord('0') shl 8; - exit; - end; - T.FromDate(DateTime); - if T.Year > 1999 then - if T.Year < 2100 then - dec(T.Year,2000) else - T.Year := 99 else - T.Year := 0; - T.FromTime(DateTime); - {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} - result[0] := #12; - PWord(@result[1])^ := tab[T.Year]; - PWord(@result[3])^ := tab[T.Month]; - PWord(@result[5])^ := tab[T.Day]; - PWord(@result[7])^ := tab[T.Hour]; - PWord(@result[9])^ := tab[T.Minute]; - PWord(@result[11])^ := tab[T.Second]; -end; - -procedure UnixTimeToFileShort(const UnixTime: TUnixTime; out result: TShort16); -begin // use 'YYMMDDHHMMSS' format - if UnixTime<=0 then - PWord(@result[0])^ := 1+ord('0') shl 8 else - DateTimeToFileShort(UnixTime/SecsPerDay+UnixDateDelta, result); -end; - -function UnixTimeToFileShort(const UnixTime: TUnixTime): TShort16; -begin - UnixTimeToFileShort(UnixTime, result); -end; - -function UnixMSTimeToFileShort(const UnixMSTime: TUnixMSTime): TShort16; -begin - UnixTimeToFileShort(UnixMSTime div MSecsPerSec, result); -end; - -function UnixTimePeriodToString(const UnixTime: TUnixTime; FirstTimeChar: AnsiChar): RawUTF8; -begin - if UnixTime0; - end else - result := false; -end; - -function Char2ToByte(P: PUTF8Char; out Value: Cardinal): Boolean; -var B: PtrUInt; -begin - B := ConvertHexToBin[ord(P[0])]; - if B<=9 then begin - Value := B; - B := ConvertHexToBin[ord(P[1])]; - if B<=9 then begin - Value := Value*10+B; - result := false; - exit; - end; - end; - result := true; // error -end; - -function Char3ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; -var B: PtrUInt; -begin - B := ConvertHexToBin[ord(P[0])]; - if B<=9 then begin - Value := B; - B := ConvertHexToBin[ord(P[1])]; - if B<=9 then begin - Value := Value*10+B; - B := ConvertHexToBin[ord(P[2])]; - if B<=9 then begin - Value := Value*10+B; - result := false; - exit; - end; - end; - end; - result := true; // error -end; - -function Char4ToWord(P: PUTF8Char; out Value: Cardinal): Boolean; -var B: PtrUInt; -begin - B := ConvertHexToBin[ord(P[0])]; - if B<=9 then begin - Value := B; - B := ConvertHexToBin[ord(P[1])]; - if B<=9 then begin - Value := Value*10+B; - B := ConvertHexToBin[ord(P[2])]; - if B<=9 then begin - Value := Value*10+B; - B := ConvertHexToBin[ord(P[3])]; - if B<=9 then begin - Value := Value*10+B; - result := false; - exit; - end; - end; - end; - end; - result := true; // error -end; - -procedure Iso8601ToDateTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); -var B: cardinal; - Y,M,D, H,MI,SS,MS: cardinal; - d100: TDiv100Rec; - tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; -// expect 'YYYYMMDDThhmmss[.sss]' format but handle also 'YYYY-MM-DDThh:mm:ss[.sss]' -begin - unaligned(result) := 0; - if P=nil then - exit; - if L=0 then - L := StrLen(P); - if L<4 then - exit; // we need 'YYYY' at least - if (P[0]='''') and (P[L-1]='''') then begin // unquote input - inc(P); - dec(L, 2); - if L<4 then exit; - end; - if P[0]='T' then begin - dec(P,8); - inc(L,8); - end else begin - {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC and x86_64 - B := tab[ord(P[0])]; // first digit - if B>9 then exit else Y := B; // fast check '0'..'9' - B := tab[ord(P[1])]; - if B>9 then exit else Y := Y*10+B; - B := tab[ord(P[2])]; - if B>9 then exit else Y := Y*10+B; - B := tab[ord(P[3])]; - if B>9 then exit else Y := Y*10+B; - if P[4] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD - D := 1; - if L>=6 then begin // YYYYMM - M := ord(P[4])*10+ord(P[5])-(48+480); - if (M=0) or (M>12) then exit; - if P[6] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD - if L>=8 then begin // YYYYMMDD - if (L>8) and not(P[8] in [#0,' ','T']) then - exit; // invalid date format - D := ord(P[6])*10+ord(P[7])-(48+480); - if (D=0) or (D>MonthDays[true][M]) then exit; // worse is leap year=true - end; - end else - M := 1; - if M>2 then // inlined EncodeDate(Y,M,D) - dec(M,3) else - if M>0 then begin - inc(M,9); - dec(Y); - end; - if Y>9999 then - exit; // avoid integer overflow e.g. if '0000' is an invalid date - Div100(Y,d100); - unaligned(result) := (146097*d100.d) shr 2 + (1461*d100.m) shr 2 + - (153*M+2) div 5+D; - unaligned(result) := unaligned(result)-693900; // as float: avoid sign issue - if L<15 then - exit; // not enough space to retrieve the time - end; - H := ord(P[9])*10+ord(P[10])-(48+480); - if P[11]=':' then begin inc(P); dec(L); end;// allow hh:mm:ss - MI := ord(P[11])*10+ord(P[12])-(48+480); - if P[13]=':' then begin inc(P); dec(L); end; // allow hh:mm:ss - SS := ord(P[13])*10+ord(P[14])-(48+480); - if (L>16) and (P[15]='.') then begin - // one or more digits representing a decimal fraction of a second - MS := ord(P[16])*100-4800; - if L>17 then MS := MS+ord(P[17])*10-480; - if L>18 then MS := MS+ord(P[18])-48; - if MS>1000 then - MS := 0; - end else - MS := 0; - if (H<24) and (MI<60) and (SS<60) then // inlined EncodeTime() - result := result+(H*(MinsPerHour*SecsPerMin*MSecsPerSec)+ - MI*(SecsPerMin*MSecsPerSec)+SS*MSecsPerSec+MS)/MSecsPerDay; -end; - -function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer): TDateTime; -begin - Iso8601ToTimePUTF8CharVar(P,L,result); -end; - -procedure Iso8601ToTimePUTF8CharVar(P: PUTF8Char; L: integer; var result: TDateTime); -var H,MI,SS,MS: cardinal; -begin - if Iso8601ToTimePUTF8Char(P,L,H,MI,SS,MS) then - result := (H*(MinsPerHour*SecsPerMin*MSecsPerSec)+ - MI*(SecsPerMin*MSecsPerSec)+SS*MSecsPerSec+MS)/MSecsPerDay else - result := 0; -end; - -function Iso8601ToTimePUTF8Char(P: PUTF8Char; L: integer; var H,M,S,MS: cardinal): boolean; -begin - result := false; // error - if P=nil then - exit; - if L=0 then - L := StrLen(P); - if L<6 then - exit; // we need 'hhmmss' at least - H := ord(P[0])*10+ord(P[1])-(48+480); - if P[2]=':' then begin inc(P); dec(L); end; // allow hh:mm:ss - M := ord(P[2])*10+ord(P[3])-(48+480); - if P[4]=':' then begin inc(P); dec(L); end; // allow hh:mm:ss - S := ord(P[4])*10+ord(P[5])-(48+480); - if (L>6) and (P[6]='.') then begin - // one or more digits representing a decimal fraction of a second - MS := ord(P[7])*100-4800; - if L>7 then MS := MS+ord(P[8])*10-480; - if L>8 then MS := MS+ord(P[9])-48; - end else - MS := 0; - if (H<24) and (M<60) and (S<60) and (MS<1000) then - result := true; -end; - -function Iso8601ToDatePUTF8Char(P: PUTF8Char; L: integer; var Y,M,D: cardinal): boolean; -begin - result := false; // error - if P=nil then - exit; - if L=0 then - L := StrLen(P); - if (L<8) or not (P[0] in ['0'..'9']) or not (P[1] in ['0'..'9']) or - not (P[2] in ['0'..'9']) or not (P[3] in ['0'..'9']) then - exit; // we need 'YYYYMMDD' at least - Y := ord(P[0])*1000+ord(P[1])*100+ord(P[2])*10+ord(P[3])-(48+480+4800+48000); - if (Y<1000) or (Y>2999) then - exit; - if P[4] in ['-','/'] then inc(P); // allow YYYY-MM-DD - M := ord(P[4])*10+ord(P[5])-(48+480); - if (M=0) or (M>12) then - exit; - if P[6] in ['-','/'] then inc(P); - D := ord(P[6])*10+ord(P[7])-(48+480); - if (D<>0) and (D<=MonthDays[true][M]) then - result := true; -end; - -function IntervalTextToDateTime(Text: PUTF8Char): TDateTime; -begin - IntervalTextToDateTimeVar(Text,result); -end; - -procedure IntervalTextToDateTimeVar(Text: PUTF8Char; var result: TDateTime); -var negative: boolean; - Time: TDateTime; -begin // e.g. IntervalTextToDateTime('+0 06:03:20') - result := 0; - if Text=nil then - exit; - if Text^ in ['+','-'] then begin - negative := (Text^='-'); - result := GetNextItemDouble(Text,' '); - end else - negative := false; - Iso8601ToTimePUTF8CharVar(Text,0,Time); - if negative then - result := result-Time else - result := result+Time; -end; - -function Iso8601ToDateTime(const S: RawByteString): TDateTime; -begin - result := Iso8601ToDateTimePUTF8Char(pointer(S),length(S)); -end; - -function TimeLogToDateTime(const Timestamp: TTimeLog): TDateTime; -begin - result := PTimeLogBits(@Timestamp)^.ToDateTime; -end; - -function TimeLogToUnixTime(const Timestamp: TTimeLog): TUnixTime; -begin - result := PTimeLogBits(@Timestamp)^.ToUnixTime; -end; - -function DateToIso8601PChar(P: PUTF8Char; Expanded: boolean; Y,M,D: PtrUInt): PUTF8Char; -// use 'YYYYMMDD' format if not Expanded, 'YYYY-MM-DD' format if Expanded -var tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; -begin - {$ifdef CPUX86NOTPIC} - YearToPChar(Y,P); - {$else} - tab := @TwoDigitLookupW; - YearToPChar2(tab,Y,P); - {$endif} - inc(P,4); - if Expanded then begin - P^ := '-'; - inc(P); - end; - PWord(P)^ := tab[M]; - inc(P,2); - if Expanded then begin - P^ := '-'; - inc(P); - end; - PWord(P)^ := tab[D]; - result := P+2; -end; - -function TimeToIso8601PChar(P: PUTF8Char; Expanded: boolean; H,M,S,MS: PtrUInt; - FirstChar: AnsiChar; WithMS: boolean): PUTF8Char; -var tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; -begin // use Thhmmss[.sss] format - if FirstChar<>#0 then begin - P^ := FirstChar; - inc(P); - end; - {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} - PWord(P)^ := tab[H]; - inc(P,2); - if Expanded then begin - P^ := ':'; - inc(P); - end; - PWord(P)^ := tab[M]; - inc(P,2); - if Expanded then begin - P^ := ':'; - inc(P); - end; - PWord(P)^ := tab[S]; - inc(P,2); - if WithMS then begin - {$ifdef CPUX86NOTPIC}YearToPChar(MS{$else}YearToPChar2(tab,MS{$endif},P); - P^ := '.'; // override first '0' digit - inc(P,4); - end; - result := P; -end; - -function DateToIso8601PChar(Date: TDateTime; P: PUTF8Char; Expanded: boolean): PUTF8Char; -var T: TSynSystemTime; -begin // use YYYYMMDD / YYYY-MM-DD date format - T.FromDate(Date); - result := DateToIso8601PChar(P,Expanded,T.Year,T.Month,T.Day); -end; - -function DateToIso8601Text(Date: TDateTime): RawUTF8; -begin // into 'YYYY-MM-DD' date format - if Date=0 then - result := '' else begin - FastSetString(result,nil,10); - DateToIso8601PChar(Date,pointer(result),True); - end; -end; - -function TimeToIso8601PChar(Time: TDateTime; P: PUTF8Char; Expanded: boolean; - FirstChar: AnsiChar; WithMS: boolean): PUTF8Char; -var T: TSynSystemTime; -begin - T.FromTime(Time); - result := TimeToIso8601PChar(P,Expanded,T.Hour,T.Minute,T.Second,T.MilliSecond,FirstChar,WithMS); -end; - -function DateTimeToIso8601(P: PUTF8Char; D: TDateTime; Expanded: boolean; - FirstChar: AnsiChar; WithMS: boolean; QuotedChar: AnsiChar): integer; -var S: PUTF8Char; -begin - S := P; - if QuotedChar<>#0 then begin - P^ := QuotedChar; - inc(P); - end; - P := DateToIso8601PChar(D,P,Expanded); - P := TimeToIso8601PChar(D,P,Expanded,FirstChar,WithMS); - if QuotedChar<>#0 then begin - P^ := QuotedChar; - inc(P); - end; - result := P-S; -end; - -function DateTimeToIso8601(D: TDateTime; Expanded: boolean; - FirstChar: AnsiChar; WithMS: boolean; QuotedChar: AnsiChar): RawUTF8; -var tmp: array[0..31] of AnsiChar; -begin // D=0 is handled in DateTimeToIso8601Text() - FastSetString(result,@tmp,DateTimeToIso8601(@tmp,D,Expanded,FirstChar,WithMS,QuotedChar)); -end; - -function DateToIso8601(Date: TDateTime; Expanded: boolean): RawUTF8; -// use YYYYMMDD / YYYY-MM-DD date format -begin - FastSetString(result,nil,8+2*integer(Expanded)); - DateToIso8601PChar(Date,pointer(result),Expanded); -end; - -function DateToIso8601(Y,M,D: cardinal; Expanded: boolean): RawUTF8; -// use 'YYYYMMDD' format if not Expanded, 'YYYY-MM-DD' format if Expanded -begin - FastSetString(result,nil,8+2*integer(Expanded)); - DateToIso8601PChar(pointer(result),Expanded,Y,M,D); -end; - -function TimeToIso8601(Time: TDateTime; Expanded: boolean; FirstChar: AnsiChar; - WithMS: boolean): RawUTF8; -// use Thhmmss[.sss] / Thh:mm:ss[.sss] format -begin - FastSetString(result,nil,7+2*integer(Expanded)+4*integer(WithMS)); - TimeToIso8601PChar(Time,pointer(result),Expanded,FirstChar,WithMS); -end; - -function DateTimeToIso8601Text(DT: TDateTime; FirstChar: AnsiChar; - WithMS: boolean): RawUTF8; -begin - DateTimeToIso8601TextVar(DT,FirstChar,result,WithMS); -end; - -procedure DateTimeToIso8601TextVar(DT: TDateTime; FirstChar: AnsiChar; - var result: RawUTF8; WithMS: boolean); -begin - if DT=0 then - result := '' else - if frac(DT)=0 then - result := DateToIso8601(DT,true) else - if trunc(DT)=0 then - result := TimeToIso8601(DT,true,FirstChar,WithMS) else - result := DateTimeToIso8601(DT,true,FirstChar,WithMS); -end; - -procedure DateTimeToIso8601StringVar(DT: TDateTime; FirstChar: AnsiChar; - var result: string; WithMS: boolean); -var tmp: RawUTF8; -begin - DateTimeToIso8601TextVar(DT,FirstChar,tmp,WithMS); - Ansi7ToString(Pointer(tmp),length(tmp),result); -end; - -function DateTimeToIso8601ExpandedPChar(const Value: TDateTime; Dest: PUTF8Char; - FirstChar: AnsiChar; WithMS: boolean): PUTF8Char; -begin - if Value<>0 then begin - if trunc(Value)<>0 then - Dest := DateToIso8601PChar(Value,Dest,true); - if frac(Value)<>0 then - Dest := TimeToIso8601PChar(Value,Dest,true,FirstChar,WithMS); - end; - Dest^ := #0; - result := Dest; -end; - -function Iso8601ToTimeLogPUTF8Char(P: PUTF8Char; L: integer; ContainsNoTime: PBoolean): TTimeLog; -// bits: S=0..5 M=6..11 H=12..16 D=17..21 M=22..25 Y=26..40 -// i.e. S<64 M<64 H<32 D<32 M<16 Y<9999: power of 2 -> use fast shl/shr -var V,B: PtrUInt; - tab: {$ifdef CPUX86NOTPIC}TNormTableByte absolute ConvertHexToBin{$else}PNormTableByte{$endif}; -begin - result := 0; - if P=nil then - exit; - if L=0 then - L := StrLen(P); - if L<4 then - exit; // we need 'YYYY' at least - if P[0]='T' then - dec(P,8) else begin // 'YYYY' -> year decode - {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} // faster on PIC/x86_64 - V := tab[ord(P[0])]; - if V>9 then exit; - B := tab[ord(P[1])]; - if B>9 then exit else V := V*10+B; - B := tab[ord(P[2])]; - if B>9 then exit else V := V*10+B; - B := tab[ord(P[3])]; - if B>9 then exit else V := V*10+B; - result := Int64(V) shl 26; // store YYYY - if P[4] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD - if L>=6 then begin // YYYYMM - V := ord(P[4])*10+ord(P[5])-(48+480+1); // Month 1..12 -> 0..11 - if V<=11 then - inc(result,V shl 22) else begin - result := 0; - exit; - end; - if P[6] in ['-','/'] then begin inc(P); dec(L); end; // allow YYYY-MM-DD - if L>=8 then begin // YYYYMMDD - V := ord(P[6])*10+ord(P[7])-(48+480+1); // Day 1..31 -> 0..30 - if (V<=30) and ((L=8) or (P[8] in [#0,' ','T'])) then - inc(result,V shl 17) else begin - result := 0; - exit; - end; - end; - end; - if L<15 then begin // not enough place to retrieve a time - if ContainsNoTime<>nil then - ContainsNoTime^ := true; - exit; - end; - end; - if ContainsNoTime<>nil then - ContainsNoTime^ := false; - B := ord(P[9])*10+ord(P[10])-(48+480); - if B<=23 then V := B shl 12 else exit; - if P[11]=':' then inc(P); // allow hh:mm:ss - B := ord(P[11])*10+ord(P[12])-(48+480); - if B<=59 then inc(V,B shl 6) else exit; - if P[13]=':' then inc(P); // allow hh:mm:ss - B := ord(P[13])*10+ord(P[14])-(48+480); - if B<=59 then inc(result,PtrUInt(V+B)); -end; - -function IsIso8601(P: PUTF8Char; L: integer): boolean; -begin - result := Iso8601ToTimeLogPUTF8Char(P,L)<>0; -end; - -function DateTimeToi18n(const DateTime: TDateTime): string; -begin - if Assigned(i18nDateTimeText) then - result := i18nDateTimeText(DateTime) else - result := {$ifdef UNICODE}Ansi7ToString{$endif}(DateTimeToIso8601(DateTime,true,' ',true)); -end; - - -{ TTimeLogBits } - -// bits: S=0..5 M=6..11 H=12..16 D=17..21 M=22..25 Y=26..40 -// size: S=6 M=6 H=5 D=5 M=4 Y=12 -// i.e. S<64 M<64 H<32 D<32 M<16 Y<=9999: power of 2 -> use fast shl/shr - -procedure TTimeLogBits.From(Y, M, D, HH, MM, SS: cardinal); -begin - inc(HH,D shl 5+M shl 10+Y shl 14-(1 shl 5+1 shl 10)); - Value := SS+MM shl 6+Int64(HH) shl 12; -end; - -procedure TTimeLogBits.From(P: PUTF8Char; L: integer); -begin - Value := Iso8601ToTimeLogPUTF8Char(P,L); -end; - -procedure TTimeLogBits.Expand(out Date: TSynSystemTime); -var V: PtrUInt; -begin - V := PPtrUint(@Value)^; - Date.Year := {$ifdef CPU32}Value{$else}V{$endif} shr (6+6+5+5+4); - Date.Month := 1+(V shr (6+6+5+5)) and 15; - Date.DayOfWeek := 0; - Date.Day := 1+(V shr (6+6+5)) and 31; - Date.Hour := (V shr (6+6)) and 31; - Date.Minute := (V shr 6) and 63; - Date.Second := V and 63; -end; - -procedure TTimeLogBits.From(const S: RawUTF8); -begin - Value := Iso8601ToTimeLogPUTF8Char(pointer(S),length(S)); -end; - -procedure TTimeLogBits.From(FileDate: integer); -begin -{$ifdef MSWINDOWS} - From(PInt64Rec(@FileDate)^.Hi shr 9+1980, - PInt64Rec(@FileDate)^.Hi shr 5 and 15, - PInt64Rec(@FileDate)^.Hi and 31, - PInt64Rec(@FileDate)^.Lo shr 11, - PInt64Rec(@FileDate)^.Lo shr 5 and 63, - PInt64Rec(@FileDate)^.Lo and 31 shl 1); -{$else} // FileDate depends on the running OS - From(FileDateToDateTime(FileDate)); -{$endif} -end; - -procedure TTimeLogBits.From(DateTime: TDateTime; DateOnly: Boolean); -var T: TSynSystemTime; - V: PtrInt; -begin - T.FromDate(DateTime); - if DateOnly then - T.Hour := 0 else - T.FromTime(DateTime); - V := T.Day shl 5+T.Month shl 10+T.Year shl 14-(1 shl 5+1 shl 10); - Value := V; // circumvent C1093 error on Delphi 5 - Value := Value shl 12; - if not DateOnly then begin - V := T.Second+T.Minute shl 6+T.Hour shl 12; - Value := Value+V; - end; -end; - -procedure TTimeLogBits.FromUnixTime(const UnixTime: TUnixTime); -begin - From(UnixTimeToDateTime(UnixTime)); -end; - -procedure TTimeLogBits.FromUnixMSTime(const UnixMSTime: TUnixMSTime); -begin - From(UnixMSTimeToDateTime(UnixMSTime)); -end; - -procedure TTimeLogBits.From(Time: PSynSystemTime); -var V: PtrInt; -begin - V := Time^.Hour+Time^.Day shl 5+Time^.Month shl 10+Time^.Year shl 14-(1 shl 5+1 shl 10); - Value := V; // circumvent C1093 error on Delphi 5 - V := Time^.Second+Time^.Minute shl 6; - Value := (Value shl 12)+V; -end; - -var // GlobalTime[LocalTime] cache protected using RCU128() - GlobalTime: array[boolean] of record - time: TSystemTime; - clock: PtrInt; // avoid slower API call with 8-16ms loss of precision - end; - -{$ifndef FPC}{$ifdef CPUINTEL} // intrinsic in FPC -procedure ReadBarrier; -asm - {$ifdef CPUX86} - lock add dword ptr [esp], 0 - {$else} - lfence // lfence requires an SSE CPU, which is OK on x86-64 - {$endif} -end; -{$endif}{$endif} - -procedure RCU32(var src,dst); -begin - repeat - Integer(dst) := Integer(src); - ReadBarrier; - until Integer(dst)=Integer(src); -end; - -procedure RCU64(var src,dst); -begin - repeat - Int64(dst) := Int64(src); - ReadBarrier; - until Int64(dst)=Int64(src); -end; - -procedure RCUPtr(var src,dst); -begin - repeat - PtrInt(dst) := PtrInt(src); - ReadBarrier; - until PtrInt(dst)=PtrInt(src); -end; - -procedure RCU128(var src,dst); -var s: THash128Rec absolute src; - d: THash128Rec absolute dst; -begin - repeat - d := s; - ReadBarrier; - until (d.L=s.L) and (d.H=s.H); -end; - -procedure RCU(var src,dst; len: integer); -begin - if len>0 then - repeat - MoveSmall(@src,@dst,len); // per-byte inlined copy - ReadBarrier; - until CompareMemSmall(@src,@dst,len); -end; - -procedure FromGlobalTime(LocalTime: boolean; out NewTime: TSynSystemTime); -var tix: PtrInt; - newtimesys: TSystemTime absolute NewTime; -begin - with GlobalTime[LocalTime] do begin - tix := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 - {$ifndef MSWINDOWS}shr 3{$endif}; // Linux: 8ms refresh - if clock<>tix then begin // Windows: typically in range of 10-16 ms - clock := tix; - NewTime.Clear; - if LocalTime then - GetLocalTime(newtimesys) else - {$ifdef MSWINDOWS}GetSystemTime{$else}GetNowUTCSystem{$endif}(newtimesys); - RCU128(newtimesys,time); - end else - RCU128(time,NewTime); - end; - {$ifndef MSWINDOWS} // those TSystemTime fields are inverted in datih.inc :( - tix := newtimesys.DayOfWeek; - NewTime.Day := newtimesys.Day; - NewTime.DayOfWeek := tix; - {$endif} -end; - -procedure TTimeLogBits.FromUTCTime; -var now: TSynSystemTime; -begin - FromGlobalTime(false,now); - From(@now); -end; - -procedure TTimeLogBits.FromNow; -var now: TSynSystemTime; -begin - FromGlobalTime(true,now); - From(@now); -end; - -function TTimeLogBits.ToTime: TDateTime; -var lo: PtrUInt; -begin - lo := {$ifdef CPU64}Value{$else}PCardinal(@Value)^{$endif}; - if lo and (1 shl (6+6+5)-1)=0 then - result := 0 else - result := EncodeTime((lo shr(6+6))and 31, (lo shr 6)and 63, lo and 63, 0); -end; - -function IsLeapYear(Year: cardinal): boolean; -var d100: TDiv100Rec; -begin - if Year and 3 = 0 then begin - Div100(Year,d100); - result := ((d100.M <> 0) or // (Year mod 100 > 0) - (Year - ((d100.D shr 2) * 400) = 0)); // (Year mod 400 = 0)) - end else - result := false; -end; - -function TryEncodeDate(Year, Month, Day: cardinal; out Date: TDateTime): Boolean; -var d100: TDiv100Rec; -begin // faster version by AB - result := False; - if (Year>0) and (Year<10000) and (Month>0) and (Month<13) and (Day>0) and - (Day <= MonthDays[IsLeapYear(Year)][Month]) then begin - if Month>2 then - dec(Month,3) else - if (Month>0) then begin - inc(Month,9); - dec(Year); - end - else exit; // Month <= 0 - Div100(Year,d100); - Date := (146097*d100.D) shr 2+(1461*d100.M) shr 2+ - (153*Month+2) div 5+Day; - Date := Date-693900; // should be separated to avoid sign issues - result := true; - end; -end; - -function TTimeLogBits.ToDate: TDateTime; -var Y, lo: PtrUInt; -begin - {$ifdef CPU64} - lo := Value; - Y := lo shr (6+6+5+5+4); - {$else} - Y := Value shr (6+6+5+5+4); - lo := PCardinal(@Value)^; - {$endif} - if (Y=0) or not TryEncodeDate(Y,1+(lo shr(6+6+5+5))and 15,1+(lo shr(6+6+5))and 31,result) then - result := 0; -end; - -function TTimeLogBits.ToDateTime: TDateTime; -var Y, lo: PtrUInt; - Time: TDateTime; -begin - {$ifdef CPU64} - lo := Value; - Y := lo shr (6+6+5+5+4); - {$else} - Y := Value shr (6+6+5+5+4); - lo := PCardinal(@Value)^; - {$endif} - if (Y=0) or not TryEncodeDate(Y,1+(lo shr(6+6+5+5))and 15,1+(lo shr(6+6+5))and 31,result) then - result := 0; - if (lo and (1 shl(6+6+5)-1)<>0) and TryEncodeTime((lo shr(6+6)) and 31, - (lo shr 6)and 63, lo and 63, 0, Time) then - result := result+Time; -end; - -function TTimeLogBits.Year: Integer; -begin - result := Value shr (6+6+5+5+4); -end; - -function TTimeLogBits.Month: Integer; -begin - result := 1+(PCardinal(@Value)^ shr (6+6+5+5)) and 15; -end; - -function TTimeLogBits.Day: Integer; -begin - result := 1+(PCardinal(@Value)^ shr (6+6+5)) and 31; -end; - -function TTimeLogBits.Hour: Integer; -begin - result := (PCardinal(@Value)^ shr (6+6)) and 31; -end; - -function TTimeLogBits.Minute: Integer; -begin - result := (PCardinal(@Value)^ shr 6) and 63; -end; - -function TTimeLogBits.Second: Integer; -begin - result := PCardinal(@Value)^ and 63; -end; - -function TTimeLogBits.ToUnixTime: TUnixTime; -begin - result := DateTimeToUnixTime(ToDateTime); -end; - -function TTimeLogBits.ToUnixMSTime: TUnixMSTime; -begin - result := DateTimeToUnixMSTime(ToDateTime); -end; - -function TTimeLogBits.Text(Dest: PUTF8Char; Expanded: boolean; FirstTimeChar: AnsiChar): integer; -var lo: PtrUInt; - S: PUTF8Char; -begin - if Value=0 then begin - result := 0; - exit; - end; - S := Dest; - lo := {$ifdef CPU64}Value{$else}PCardinal(@Value)^{$endif}; - if lo and (1 shl (6+6+5)-1)=0 then - // no Time: just convert date - result := DateToIso8601PChar(Dest, Expanded, - {$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5+5+4), - 1+(lo shr (6+6+5+5)) and 15, 1+(lo shr (6+6+5)) and 31)-S else - if {$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5)=0 then - // no Date: just convert time - result := TimeToIso8601PChar(Dest, Expanded, (lo shr (6+6)) and 31, - (lo shr 6) and 63, lo and 63, 0, FirstTimeChar)-S else begin - // convert time and date - Dest := DateToIso8601PChar(Dest, Expanded, - {$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5+5+4), - 1+(lo shr (6+6+5+5)) and 15, 1+(lo shr (6+6+5)) and 31); - result := TimeToIso8601PChar(Dest, Expanded, (lo shr (6+6)) and 31, - (lo shr 6) and 63, lo and 63, 0, FirstTimeChar)-S; - end; -end; - -function TTimeLogBits.Text(Expanded: boolean; FirstTimeChar: AnsiChar): RawUTF8; -var tmp: array[0..31] of AnsiChar; -begin - if Value=0 then - result := '' else - FastSetString(result,@tmp,Text(tmp,Expanded,FirstTimeChar)); -end; - -function TTimeLogBits.FullText(Dest: PUTF8Char; Expanded: boolean; - FirstTimeChar,QuotedChar: AnsiChar): PUTF8Char; -var lo: PtrUInt; -begin // convert full time and date - if QuotedChar<>#0 then begin - Dest^ := QuotedChar; - inc(Dest); - end; - lo := {$ifdef CPU64}Value{$else}PCardinal(@Value)^{$endif}; - Dest := DateToIso8601PChar(Dest, Expanded, - {$ifdef CPU64}lo{$else}Value{$endif} shr (6+6+5+5+4), - 1+(lo shr (6+6+5+5)) and 15, 1+(lo shr (6+6+5)) and 31); - Dest := TimeToIso8601PChar(Dest, Expanded, (lo shr (6+6)) and 31, - (lo shr 6) and 63, lo and 63, 0, FirstTimeChar); - if QuotedChar<>#0 then begin - Dest^ := QuotedChar; - inc(Dest); - end; - result := Dest; -end; - -function TTimeLogBits.FullText(Expanded: boolean; FirstTimeChar,QuotedChar: AnsiChar): RawUTF8; -var tmp: array[0..31] of AnsiChar; -begin - FastSetString(result,@tmp,FullText(tmp,Expanded,FirstTimeChar,QuotedChar)-@tmp); -end; - -function TTimeLogBits.i18nText: string; -begin - if Assigned(i18nDateText) then - result := i18nDateText(Value) else - result := {$ifdef UNICODE}Ansi7ToString{$endif}(Text(true,' ')); -end; - -function TimeLogNow: TTimeLog; -begin - PTimeLogBits(@result)^.FromNow; -end; - -function TimeLogNowUTC: TTimeLog; -begin - PTimeLogBits(@result)^.FromUTCTime; -end; - -function NowToString(Expanded: boolean; FirstTimeChar: AnsiChar): RawUTF8; -var I: TTimeLogBits; -begin - I.FromNow; - result := I.Text(Expanded,FirstTimeChar); -end; - -function NowUTCToString(Expanded: boolean; FirstTimeChar: AnsiChar): RawUTF8; -var I: TTimeLogBits; -begin - I.FromUTCTime; - result := I.Text(Expanded,FirstTimeChar); -end; - -const - DTMS_FMT: array[boolean] of RawUTF8 = ('%%%%%%%%%', '%-%-%%%:%:%.%%'); - -function DateTimeMSToString(DateTime: TDateTime; Expanded: boolean; - FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8; -var T: TSynSystemTime; -begin // 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format - if DateTime=0 then - result := '' else begin - T.FromDateTime(DateTime); - result := DateTimeMSToString(T.Hour,T.Minute,T.Second,T.MilliSecond, - T.Year,T.Month,T.Day,Expanded,FirstTimeChar,TZD); - end; -end; - -function DateTimeMSToString(HH,MM,SS,MS,Y,M,D: cardinal; Expanded: boolean; - FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8; -begin // 'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format - FormatUTF8(DTMS_FMT[Expanded], [UInt4DigitsToShort(Y),UInt2DigitsToShortFast(M), - UInt2DigitsToShortFast(D),FirstTimeChar,UInt2DigitsToShortFast(HH), - UInt2DigitsToShortFast(MM),UInt2DigitsToShortFast(SS),UInt3DigitsToShort(MS),TZD], result); -end; - -function DateTimeToHTTPDate(dt: TDateTime; const tz: RawUTF8): RawUTF8; -var T: TSynSystemTime; -begin - if dt=0 then - result := '' else begin - T.FromDateTime(dt); - T.ToHTTPDate(result,tz); - end; -end; - -function TimeToString: RawUTF8; -var I: TTimeLogBits; -begin - I.FromNow; - I.Value := I.Value and (1 shl (6+6+5)-1); // keep only time - result := I.Text(true,' '); -end; - -function TimeLogFromFile(const FileName: TFileName): TTimeLog; -var Date: TDateTime; -begin - Date := FileAgeToDateTime(FileName); - if Date=0 then - result := 0 else - PTimeLogBits(@result)^.From(Date); -end; - -function TimeLogFromDateTime(const DateTime: TDateTime): TTimeLog; -begin - PTimeLogBits(@result)^.From(DateTime); -end; - -function TimeLogFromUnixTime(const UnixTime: TUnixTime): TTimeLog; -begin - PTimeLogBits(@result)^.FromUnixTime(UnixTime); -end; - - -{ TSynDate } - -procedure TSynDate.Clear; -begin - PInt64(@self)^ := 0; -end; - -procedure TSynDate.SetMax; -begin - PInt64(@self)^ := $001F0000000C270F; // 9999 + 12 shl 16 + 31 shl 48 -end; - -function TSynDate.IsZero: boolean; -begin - result := PInt64(@self)^=0; -end; - -function TSynDate.ParseFromText(var P: PUTF8Char): boolean; -var L: PtrInt; - Y,M,D: cardinal; -begin - result := false; - if P=nil then - exit; - while P^ in [#9,' '] do inc(P); - L := 0; - while P[L] in ['0'..'9','-','/'] do inc(L); - if not Iso8601ToDatePUTF8Char(P,L,Y,M,D) then - exit; - Year := Y; - Month := M; - DayOfWeek := 0; - Day := D; - inc(P,L); // move P^ just after the date - result := true; -end; - -procedure TSynDate.FromNow(localtime: boolean); -var dt: TSynSystemTime; -begin - FromGlobalTime(localtime,dt); - self := PSynDate(@dt)^; // 4 first fields of TSynSystemTime do match -end; - -procedure TSynDate.FromDate(date: TDate); -var dt: TSynSystemTime; -begin - dt.FromDate(date); // faster than DecodeDate - self := PSynDate(@dt)^; -end; - -function TSynDate.IsEqual({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean; -begin - result := (PCardinal(@Year)^=PCardinal(@TSynDate(another).Year)^) and (Day=TSynDate(another).Day); -end; - -function TSynDate.Compare({$ifdef FPC}constref{$else}const{$endif} another{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): integer; -begin - result := Year-TSynDate(another).Year; - if result=0 then begin - result := Month-TSynDate(another).Month; - if result=0 then - result := Day-TSynDate(another).Day; - end; -end; - -procedure TSynDate.ComputeDayOfWeek; -var d: TDateTime; - i: PtrInt; -begin - if not TryEncodeDate(Year,Month,Day,d) then begin - DayOfWeek := 0; - exit; - end; - i := ((trunc(d)-1) mod 7)+1; // sunday is day 1 - if i<=0 then - DayOfWeek := i+7 else - DayOfWeek := i; -end; - -function TSynDate.ToDate: TDate; -begin - if not TryEncodeDate(Year,Month,Day,PDateTime(@result)^) then - result := 0; -end; - -function TSynDate.ToText(Expanded: boolean): RawUTF8; -begin - if PInt64(@self)^=0 then - result := '' else - result := DateToIso8601(Year,Month,Day,Expanded); -end; - - -{ TSynSystemTime } - -function TryEncodeDayOfWeekInMonth(AYear, AMonth, ANthDayOfWeek, ADayOfWeek: integer; - out AValue: TDateTime): Boolean; -var LStartOfMonth, LDay: integer; -begin // adapted from DateUtils - result := TryEncodeDate(AYear,AMonth,1,aValue); - if not result then - exit; - LStartOfMonth := (DateTimeToTimestamp(aValue).Date-1)mod 7+1; - if LStartOfMonth<=ADayOfWeek then - dec(ANthDayOfWeek); - LDay := (ADayOfWeek-LStartOfMonth+1)+7*ANthDayOfWeek; - result := TryEncodeDate(AYear,AMonth,LDay,AValue); -end; - -function TSynSystemTime.EncodeForTimeChange(const aYear: word): TDateTime; -var dow,d: word; -begin - if DayOfWeek=0 then - dow := 7 else // Delphi Sunday = 7 - dow := DayOfWeek; - // Encoding the day of change - d := Day; - while not TryEncodeDayOfWeekInMonth(aYear,Month,d,dow,Result) do begin - // if Day = 5 then try it and if needed decrement to find the last - // occurence of the day in this month - if d=0 then begin - TryEncodeDayOfWeekInMonth(aYear,Month,1,7,Result); - break; - end; - dec(d); - end; - // finally add the time when change is due - result := result+EncodeTime(Hour,Minute,Second,MilliSecond); -end; - -procedure TSynSystemTime.Clear; -begin - PInt64Array(@self)[0] := 0; - PInt64Array(@self)[1] := 0; -end; - -function TSynSystemTime.IsZero: boolean; -begin - result := (PInt64Array(@self)[0]=0) and (PInt64Array(@self)[1]=0); -end; - -function TSynSystemTime.IsEqual(const another{$ifndef DELPHI5OROLDER}: TSynSystemTime{$endif}): boolean; -begin - result := (PInt64Array(@self)[0]=PInt64Array(@another)[0]) and - (PInt64Array(@self)[1]=PInt64Array(@another)[1]); -end; - -function TSynSystemTime.IsDateEqual(const date{$ifndef DELPHI5OROLDER}: TSynDate{$endif}): boolean; -begin - result := (PCardinal(@Year)^=PCardinal(@TSynDate(date).Year)^) and - (Day=TSynDate(date).Day); -end; - -procedure TSynSystemTime.FromNowUTC; -begin - FromGlobalTime(false,self); -end; - -procedure TSynSystemTime.FromNowLocal; -begin - FromGlobalTime(true,self); -end; - -procedure TSynSystemTime.FromDateTime(const dt: TDateTime); -begin - FromDate(dt); - FromTime(dt); -end; - -procedure TSynSystemTime.FromDate(const dt: TDateTime); -var t,t2,t3: PtrUInt; -begin - t := Trunc(dt); - t := (t+693900)*4-1; - if PtrInt(t)>=0 then begin - t3 := t div 146097; - t2 := (t-t3*146097) and not 3; - t := PtrUInt(t2+3) div 1461; // PtrUInt() needed for FPC i386 - Year := t3*100+t; - t2 := ((t2+7-t*1461)shr 2)*5; - t3 := PtrUInt(t2-3) div 153; - Day := PtrUInt(t2+2-t3*153) div 5; - if t3<10 then - inc(t3,3) else begin - dec(t3,9); - inc(Year); - end; - Month := t3; - DayOfWeek := 0; // not set by default - end else - PInt64(@Year)^ := 0; -end; - -procedure TSynSystemTime.FromTime(const dt: TDateTime); -begin - FromMS(QWord(round(abs(dt)*MSecsPerDay)) mod MSecsPerDay); -end; - -procedure TSynSystemTime.FromMS(ms: PtrUInt); -var t: PtrUInt; -begin - t := ms div 3600000; - Hour := t; - dec(ms,t*3600000); - t := ms div 60000; - Minute := t; - dec(ms,t*60000); - t := ms div 1000; - Second := t; - dec(ms,t*1000); - MilliSecond := ms; -end; - -procedure TSynSystemTime.FromSec(s: PtrUInt); -var t: PtrUInt; -begin - t := s div 3600; - Hour := t; - dec(s,t*3600); - t := s div 60; - Minute := t; - dec(s,t*60); - Second := s; - MilliSecond := 0; -end; - -function TSynSystemTime.FromText(const iso: RawUTF8): boolean; -var t: TTimeLogBits; -begin - t.From(iso); - if t.Value=0 then - result := false else begin - t.Expand(self); // TTimeLogBits is faster than FromDateTime() - result := true; - end; -end; - -function TSynSystemTime.ToText(Expanded: boolean; - FirstTimeChar: AnsiChar; const TZD: RawUTF8): RawUTF8; -begin - result := DateTimeMSToString(Hour,Minute,Second,MilliSecond,Year,Month,Day, - Expanded,FirstTimeChar,TZD); -end; - -procedure TSynSystemTime.AddLogTime(WR: TTextWriter); -var y,d100: PtrUInt; - P: PUTF8Char; - tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; -begin - if WR.BEnd-WR.B<=18 then - WR.FlushToStream; - {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} - y := Year; - d100 := y div 100; - P := WR.B+1; - PWord(P)^ := tab[d100]; - PWord(P+2)^ := tab[y-(d100*100)]; - PWord(P+4)^ := tab[Month]; - PWord(P+6)^ := tab[Day]; - P[8] := ' '; - PWord(P+9)^ := tab[Hour]; - PWord(P+11)^ := tab[Minute]; - PWord(P+13)^ := tab[Second]; - y := Millisecond; - PWord(P+15)^ := tab[y shr 4]; - inc(WR.B,17); -end; - -const - HTML_WEEK_DAYS: array[1..7] of string[3] = - ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); - HTML_MONTH_NAMES: array[1..12] of string[3] = - ('Jan','Feb','Mar','Apr','May','Jun', 'Jul','Aug','Sep','Oct','Nov','Dec'); - -function TSynSystemTime.ToNCSAText(P: PUTF8Char): PtrInt; -var y,d100: PtrUInt; - tab: {$ifdef CPUX86NOTPIC}TWordArray absolute TwoDigitLookupW{$else}PWordArray{$endif}; -begin - {$ifndef CPUX86NOTPIC}tab := @TwoDigitLookupW;{$endif} - PWord(P)^ := tab[Day]; - PCardinal(P+2)^ := PCardinal(@HTML_MONTH_NAMES[Month])^; - P[2] := '/'; // overwrite HTML_MONTH_NAMES[][0] - P[6] := '/'; - y := Year; - d100 := y div 100; - PWord(P+7)^ := tab[d100]; - PWord(P+9)^ := tab[y-(d100*100)]; - P[11] := ':'; - PWord(P+12)^ := tab[Hour]; - P[14] := ':'; - PWord(P+15)^ := tab[Minute]; - P[17] := ':'; - PWord(P+18)^ := tab[Second]; - P[20] := ' '; - result := 21; -end; - -procedure TSynSystemTime.ToHTTPDate(out text: RawUTF8; const tz: RawUTF8); -begin - if DayOfWeek=0 then - PSynDate(@self)^.ComputeDayOfWeek; // first 4 fields do match - FormatUTF8('%, % % % %:%:% %', [HTML_WEEK_DAYS[DayOfWeek], - UInt2DigitsToShortFast(Day),HTML_MONTH_NAMES[Month],UInt4DigitsToShort(Year), - UInt2DigitsToShortFast(Hour),UInt2DigitsToShortFast(Minute), - UInt2DigitsToShortFast(Second),tz],text); -end; - -procedure TSynSystemTime.ToIsoDateTime(out text: RawUTF8; const FirstTimeChar: AnsiChar); -begin - FormatUTF8('%-%-%%%:%:%', [UInt4DigitsToShort(Year),UInt2DigitsToShortFast(Month), - UInt2DigitsToShortFast(Day),FirstTimeChar,UInt2DigitsToShortFast(Hour), - UInt2DigitsToShortFast(Minute),UInt2DigitsToShortFast(Second)],text); -end; - -procedure TSynSystemTime.ToIsoDate(out text: RawUTF8); -begin - FormatUTF8('%-%-%', [UInt4DigitsToShort(Year),UInt2DigitsToShortFast(Month), - UInt2DigitsToShortFast(Day)],text); -end; - -procedure TSynSystemTime.ToIsoTime(out text: RawUTF8; const FirstTimeChar: RawUTF8); -begin - FormatUTF8('%%:%:%', [FirstTimeChar,UInt2DigitsToShortFast(Hour), - UInt2DigitsToShortFast(Minute),UInt2DigitsToShortFast(Second)],text); -end; - -procedure TSynSystemTime.AddNCSAText(WR: TTextWriter); -begin - if WR.BEnd-WR.B<=21 then - WR.FlushToStream; - inc(WR.B,ToNCSAText(WR.B+1)); -end; - -function TSynSystemTime.ToDateTime: TDateTime; -var time: TDateTime; -begin - if TryEncodeDate(Year,Month,Day,result) then - if TryEncodeTime(Hour,Minute,Second,MilliSecond,time) then - result := result+time else - result := 0 else - result := 0; -end; - -procedure TSynSystemTime.ToSynDate(out date: TSynDate); -begin - date := PSynDate(@self)^; // first 4 fields do match -end; - -procedure TSynSystemTime.ComputeDayOfWeek; -begin - PSynDate(@self)^.ComputeDayOfWeek; // first 4 fields do match -end; - -procedure TSynSystemTime.IncrementMS(ms: integer); -begin - inc(MilliSecond, ms); - if MilliSecond >= 1000 then - repeat - dec(MilliSecond, 1000); - if Second < 60 then - inc(Second) - else begin - Second := 0; - if Minute < 60 then - inc(Minute) - else begin - Minute := 0; - if Hour < 24 then - inc(Hour) - else begin - Hour := 0; - if Day < MonthDays[false, Month] then - inc(Day) - else begin - Day := 1; - if Month < 12 then - inc(Month) - else begin - Month := 1; - inc(Year); - end; - end; - end; - end; - end; - until MilliSecond < 1000; -end; - -procedure AppendToTextFile(aLine: RawUTF8; const aFileName: TFileName; - aMaxSize: Int64; aUTCTimeStamp: boolean); -var F: THandle; - Old: TFileName; - Date: array[1..22] of AnsiChar; - size: Int64; - i: integer; - now: TSynSystemTime; -begin - if aFileName='' then - exit; - F := FileOpen(aFileName,fmOpenWrite or fmShareDenyNone); - if PtrInt(F)<0 then begin - F := FileCreate(aFileName); - if PtrInt(F)<0 then - exit; // you may not have write access to this folder - end; - // append to end of file - size := FileSeek64(F,0,soFromEnd); - if (aMaxSize>0) and (size>aMaxSize) then begin - // rotate log file if too big - FileClose(F); - Old := aFileName+'.bak'; // '.log.bak' - DeleteFile(Old); // rotate once - RenameFile(aFileName,Old); - F := FileCreate(aFileName); - if PtrInt(F)<0 then - exit; - end; - PWord(@Date)^ := 13+10 shl 8; // first go to next line - if aUTCTimeStamp then - now.FromNowUTC else - now.FromNowLocal; - DateToIso8601PChar(@Date[3],true,Now.Year,Now.Month,Now.Day); - TimeToIso8601PChar(@Date[13],true,Now.Hour,Now.Minute,Now.Second,0,' '); - Date[22] := ' '; - FileWrite(F,Date,SizeOf(Date)); - for i := 1 to length(aLine) do - if aLine[i]<' ' then - aLine[i] := ' '; // avoid line feed in text log file - FileWrite(F,pointer(aLine)^,length(aLine)); - FileClose(F); -end; - -procedure LogToTextFile(Msg: RawUTF8); -begin - if Msg='' then begin - StringToUTF8(SysErrorMessage(GetLastError),Msg); - if Msg='' then - exit; - end; - AppendToTextFile(Msg,{$ifndef MSWINDOWS}ExtractFileName{$endif} - (ChangeFileExt(ExeVersion.ProgramFileName,'.log'))); -end; - -function IsEqualGUID(const guid1, guid2: TGUID): Boolean; -begin - result := (PHash128Rec(@guid1).L=PHash128Rec(@guid2).L) and - (PHash128Rec(@guid1).H=PHash128Rec(@guid2).H); -end; - -function IsEqualGUID(guid1, guid2: PGUID): Boolean; -begin - result := (PHash128Rec(guid1).L=PHash128Rec(guid2).L) and - (PHash128Rec(guid1).H=PHash128Rec(guid2).H); -end; - -function IsEqualGUIDArray(const guid: TGUID; const guids: array of TGUID): integer; -begin - result := Hash128Index(@guids[0],length(guids),@guid); -end; - -function IsNullGUID({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): Boolean; -var a: TPtrIntArray absolute guid; -begin - result := (a[0]=0) and (a[1]=0) {$ifndef CPU64} and (a[2]=0) and (a[3]=0){$endif}; -end; - -function AddGUID(var guids: TGUIDDynArray; const guid: TGUID; - NoDuplicates: boolean): integer; -begin - if NoDuplicates then begin - result := Hash128Index(pointer(guids),length(guids),@guid); - if result>=0 then - exit; - end; - result := length(guids); - SetLength(guids,result+1); - guids[result] := guid; -end; - -function GUIDToText(P: PUTF8Char; guid: PByteArray): PUTF8Char; -var i: integer; -begin // encode as '3F2504E0-4F89-11D3-9A0C-0305E82C3301' - for i := 3 downto 0 do begin - PWord(P)^ := TwoDigitsHexWB[guid[i]]; - inc(P,2); - end; - inc(PByte(guid),4); - for i := 1 to 2 do begin - P[0] := '-'; - PWord(P+1)^ := TwoDigitsHexWB[guid[1]]; - PWord(P+3)^ := TwoDigitsHexWB[guid[0]]; - inc(PByte(guid),2); - inc(P,5); - end; - P[0] := '-'; - PWord(P+1)^ := TwoDigitsHexWB[guid[0]]; - PWord(P+3)^ := TwoDigitsHexWB[guid[1]]; - P[5] := '-'; - inc(PByte(guid),2); - inc(P,6); - for i := 0 to 5 do begin - PWord(P)^ := TwoDigitsHexWB[guid[i]]; - inc(P,2); - end; - result := P; -end; - -function HexaToByte(P: PUTF8Char; var Dest: byte): boolean; {$ifdef HASINLINE}inline;{$endif} -var B,C: PtrUInt; -begin - B := ConvertHexToBin[Ord(P[0])]; - if B<=15 then begin - C := ConvertHexToBin[Ord(P[1])]; - if C<=15 then begin - Dest := B shl 4+C; - result := true; - exit; - end; - end; - result := false; // mark error -end; - -function TextToGUID(P: PUTF8Char; guid: PByteArray): PUTF8Char; -var i: integer; -begin // decode from '3F2504E0-4F89-11D3-9A0C-0305E82C3301' - result := nil; - for i := 3 downto 0 do begin - if not HexaToByte(P,guid[i]) then - exit; - inc(P,2); - end; - inc(PByte(guid),4); - for i := 1 to 2 do begin - if (P^<>'-') or not HexaToByte(P+1,guid[1]) or not HexaToByte(P+3,guid[0]) then - exit; - inc(P,5); - inc(PByte(guid),2); - end; - if (P[0]<>'-') or (P[5]<>'-') or - not HexaToByte(P+1,guid[0]) or not HexaToByte(P+3,guid[1]) then - exit; - inc(PByte(guid),2); - inc(P,6); - for i := 0 to 5 do - if HexaToByte(P,guid[i]) then - inc(P,2) else - exit; - result := P; -end; - -function GUIDToRawUTF8({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): RawUTF8; -var P: PUTF8Char; -begin - FastSetString(result,nil,38); - P := pointer(result); - P^ := '{'; - GUIDToText(P+1,@guid)^ := '}'; -end; - -function GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): TGUIDShortString; -begin - GUIDToShort(guid,result); -end; - -procedure GUIDToShort({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID; - out dest: TGUIDShortString); -begin - dest[0] := #38; - dest[1] := '{'; - dest[38] := '}'; - GUIDToText(@dest[2],@guid); -end; - -function GUIDToString({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID): string; -{$ifdef UNICODE} -var tmp: array[0..35] of AnsiChar; - i: integer; -begin - GUIDToText(tmp,@guid); - SetString(result,nil,38); - PWordArray(result)[0] := ord('{'); - for i := 1 to 36 do - PWordArray(result)[i] := ord(tmp[i-1]); // no conversion for 7 bit Ansi - PWordArray(result)[37] := ord('}'); -end; -{$else} -begin - result := GUIDToRawUTF8(guid); -end; -{$endif} - -{$ifdef CPUINTEL} /// NIST SP 800-90A compliant RDRAND Intel x86/x64 opcode -function RdRand32: cardinal; {$ifdef CPU64} -{$ifdef FPC}nostackframe; assembler; asm{$else} asm .noframe {$endif FPC} {$else} -{$ifdef FPC}nostackframe; assembler;{$endif} asm {$endif} - // rdrand eax: same opcodes for x86 and x64 - db $0f, $c7, $f0 - // returns in eax, ignore carry flag (eax=0 won't hurt) -end; -{$endif CPUINTEL} - -threadvar - _Lecuyer: TLecuyer; // uses only 16 bytes per thread - -procedure TLecuyer.Seed(entropy: PByteArray; entropylen: PtrInt); -var time, crc: THash128Rec; - i, j: PtrInt; -begin - repeat - QueryPerformanceCounter(time.Lo); - time.Hi := UnixMSTimeUTCFast xor PtrUInt(GetCurrentThreadID); - crcblock(@crc.b,@time.b); - crcblock(@crc.b,@ExeVersion.Hash.b); - if entropy<>nil then - for i := 0 to entropylen-1 do begin - j := i and 15; - crc.b[j] := crc.b[j] xor entropy^[i]; - end; - rs1 := rs1 xor crc.c0; - rs2 := rs2 xor crc.c1; - rs3 := rs3 xor crc.c2; - {$ifdef CPUINTEL} - if cfRAND in CpuFeatures then begin // won't hurt e.g. from Random32gsl - rs1 := rs1 xor RdRand32; - rs2 := rs2 xor RdRand32; - rs3 := rs3 xor RdRand32; - end; - {$endif CPUINTEL} - until (rs1>1) and (rs2>7) and (rs3>15); - seedcount := 1; - for i := 1 to crc.i3 and 15 do - Next; // warm up -end; - -function TLecuyer.Next: cardinal; -begin - if word(seedcount)=0 then // reseed after 256KB of output - Seed(nil,0) else - inc(seedcount); - result := rs1; - rs1 := ((result and -2)shl 12) xor (((result shl 13)xor result)shr 19); - result := rs2; - rs2 := ((result and -8)shl 4) xor (((result shl 2)xor result)shr 25); - result := rs3; - rs3 := ((result and -16)shl 17) xor (((result shl 3)xor result)shr 11); - result := rs1 xor rs2 xor result; -end; - -function TLecuyer.Next(max: cardinal): cardinal; -begin - result := (QWord(Next)*max)shr 32; -end; - -procedure Random32Seed(entropy: pointer; entropylen: PtrInt); -begin - _Lecuyer.Seed(entropy,entropylen); -end; - -function Random32: cardinal; -begin - {$ifdef CPUINTEL} - if cfRAND in CpuFeatures then begin - result := RdRand32; - if ((integer(result)<>-1) and (result<>0)) or (RdRand32<>result) then - exit; // ensure not affected by old AMD bug after suspend to RAM - exclude(CpuFeatures,cfRAND); // disable if weakness detected - end; - {$endif CPUINTEL} - result := _Lecuyer.Next; -end; - -function Random32(max: cardinal): cardinal; -begin - result := (QWord(Random32)*max)shr 32; -end; - -function Random32gsl: cardinal; -begin - result := _Lecuyer.Next; -end; - -function Random32gsl(max: cardinal): cardinal; -begin - result := (QWord(_Lecuyer.Next)*max)shr 32; -end; - -procedure FillRandom(Dest: PCardinalArray; CardinalCount: integer; forcegsl: boolean); -var i: PtrInt; - c: cardinal; - seed: TQWordRec; - lecuyer: ^TLecuyer; -begin - if CardinalCount<=0 then - exit; - {$ifdef CPUINTEL} - if (cfRAND in CpuFeatures) and not forcegsl then - lecuyer := nil else - {$endif CPUINTEL} - lecuyer := @_Lecuyer; - QueryPerformanceCounter(PInt64(@seed)^); - c := crc32cBy4(seed.L,seed.H); - for i := 0 to CardinalCount-1 do begin - {$ifdef CPUINTEL} - if lecuyer=nil then - c := crc32cBy4(c,RdRand32) else // never trust plain Intel values - {$endif CPUINTEL} - c := c xor lecuyer^.Next; - Dest^[i] := Dest^[i] xor c; - end; -end; - -function RandomGUID: TGUID; -begin - FillRandom(@result,SizeOf(TGUID) shr 2,{forcegsl=}true); -end; - -procedure RandomGUID(out result: TGUID); -begin - FillRandom(@result,SizeOf(TGUID) shr 2,{forcegsl=}true); -end; - -procedure FillZero(var result: TGUID); -begin - FillZero(PHash128(@result)^); -end; - -function RawUTF8ToGUID(const text: RawByteString): TGUID; -begin - if (length(text)<>38) or (text[1]<>'{') or (text[38]<>'}') or - (TextToGUID(@text[2],@result)=nil) then - FillZero(PHash128(@result)^); -end; - -function StringToGUID(const text: string): TGUID; -{$ifdef UNICODE} -var tmp: array[0..35] of byte; - i: integer; -{$endif} -begin - if (length(text)=38) and (text[1]='{') and (text[38]='}') then begin - {$ifdef UNICODE} - for i := 0 to 35 do - tmp[i] := PWordArray(text)[i+1]; - if TextToGUID(@tmp,@result)<>nil then - {$else} - if TextToGUID(@text[2],@result)<>nil then - {$endif} - exit; // conversion OK - end; - FillZero(PHash128(@result)^); -end; - -function StrCurr64(P: PAnsiChar; const Value: Int64): PAnsiChar; -var c: QWord; - d: cardinal; - {$ifndef CPU64}c64: Int64Rec absolute c;{$endif} -begin - if Value=0 then begin - result := P-1; - result^ := '0'; - exit; - end; - if Value<0 then - c := -Value else - c := Value; - if {$ifdef CPU64}c<10000{$else}(c64.Hi=0) and (c64.Lo<10000){$endif} then begin - result := P-6; // only decimals -> append '0.xxxx' - PWord(result)^ := ord('0')+ord('.')shl 8; - YearToPChar(c,PUTF8Char(P)-4); - end else begin - result := StrUInt64(P-1,c); - d := PCardinal(P-5)^; // in two explit steps for CPUARM (alf) - PCardinal(P-4)^ := d; - P[-5] := '.'; // insert '.' just before last 4 decimals - end; - if Value<0 then begin - dec(result); - result^ := '-'; - end; -end; - -procedure Curr64ToStr(const Value: Int64; var result: RawUTF8); -var tmp: array[0..31] of AnsiChar; - P: PAnsiChar; - Decim, L: Cardinal; -begin - if Value=0 then - result := SmallUInt32UTF8[0] else begin - P := StrCurr64(@tmp[31],Value); - L := @tmp[31]-P; - if L>4 then begin - Decim := PCardinal(P+L-SizeOf(cardinal))^; // 4 last digits = 4 decimals - if Decim=ord('0')+ord('0')shl 8+ord('0')shl 16+ord('0')shl 24 then - dec(L,5) else // no decimal - if Decim and $ffff0000=ord('0')shl 16+ord('0')shl 24 then - dec(L,2); // 2 decimals - end; - FastSetString(result,P,L); - end; -end; - -function Curr64ToStr(const Value: Int64): RawUTF8; -begin - Curr64ToStr(Value,result); -end; - -function CurrencyToStr(Value: currency): RawUTF8; -begin - result := Curr64ToStr(PInt64(@Value)^); -end; - -function Curr64ToPChar(const Value: Int64; Dest: PUTF8Char): PtrInt; -var tmp: array[0..31] of AnsiChar; - P: PAnsiChar; - Decim: Cardinal; -begin - P := StrCurr64(@tmp[31],Value); - result := @tmp[31]-P; - if result>4 then begin - Decim := PCardinal(P+result-SizeOf(cardinal))^; // 4 last digits = 4 decimals - if Decim=ord('0')+ord('0')shl 8+ord('0')shl 16+ord('0')shl 24 then - dec(result,5) else // no decimal - if Decim and $ffff0000=ord('0')shl 16+ord('0')shl 24 then - dec(result,2); // 2 decimals - end; - MoveSmall(P,Dest,result); -end; - -function StrToCurr64(P: PUTF8Char; NoDecimal: PBoolean): Int64; -var c: cardinal; - minus: boolean; - Dec: cardinal; -begin - result := 0; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - if P^='-' then begin - minus := true; - repeat inc(P) until P^<>' '; - end else begin - minus := false; - if P^='+' then - repeat inc(P) until P^<>' '; - end; - if P^='.' then begin // '.5' -> 500 - Dec := 2; - inc(P); - end else - Dec := 0; - c := byte(P^)-48; - if c>9 then - exit; - PCardinal(@result)^ := c; - inc(P); - repeat - if P^<>'.' then begin - c := byte(P^)-48; - if c>9 then - break; - {$ifdef CPU32DELPHI} - result := result shl 3+result+result; - {$else} - result := result*10; - {$endif} - inc(result,c); - inc(P); - if Dec<>0 then begin - inc(Dec); - if Dec<5 then continue else break; - end; - end else begin - inc(Dec); - inc(P); - end; - until false; - if NoDecimal<>nil then - if Dec=0 then begin - NoDecimal^ := true; - if minus then - result := -result; - exit; - end else - NoDecimal^ := false; - if Dec<>5 then // Dec=5 most of the time - case Dec of - 0,1: result := result*10000; - {$ifdef CPU32DELPHI} - 2: result := result shl 10-result shl 4-result shl 3; - 3: result := result shl 6+result shl 5+result shl 2; - 4: result := result shl 3+result+result; - {$else} - 2: result := result*1000; - 3: result := result*100; - 4: result := result*10; - {$endif} - end; - if minus then - result := -result; -end; - -function StrToCurrency(P: PUTF8Char): currency; -begin - PInt64(@result)^ := StrToCurr64(P,nil); -end; - -function TruncTo2Digits(Value: Currency): Currency; -var V64: Int64 absolute Value; // to avoid any floating-point precision issues -begin - dec(V64,V64 mod 100); - result := Value; -end; - -procedure TruncTo2DigitsCurr64(var Value: Int64); -begin - dec(Value,Value mod 100); -end; - -function TruncTo2Digits64(Value: Int64): Int64; -begin - result := Value-Value mod 100; -end; - -function SimpleRoundTo2Digits(Value: Currency): Currency; -var V64: Int64 absolute Value; // to avoid any floating-point precision issues -begin - SimpleRoundTo2DigitsCurr64(V64); - result := Value; -end; - -procedure SimpleRoundTo2DigitsCurr64(var Value: Int64); -var Spare: PtrInt; -begin - Spare := Value mod 100; - if Spare<>0 then - if Spare>50 then - inc(Value,100-Spare) else - if Spare<-50 then - dec(Value,100+Spare) else - dec(Value,Spare); -end; - -function TrimLeftLowerCase(const V: RawUTF8): PUTF8Char; -begin - result := Pointer(V); - if result<>nil then begin - while result^ in ['a'..'z'] do - inc(result); - if result^=#0 then - result := Pointer(V); - end; -end; - -function TrimLeftLowerCaseToShort(V: PShortString): ShortString; -begin - TrimLeftLowerCaseToShort(V,result); -end; - -procedure TrimLeftLowerCaseToShort(V: PShortString; out result: ShortString); -var P: PAnsiChar; - L: integer; -begin - L := length(V^); - P := @V^[1]; - while (L>0) and (P^ in ['a'..'z']) do begin - inc(P); - dec(L); - end; - if L=0 then - result := V^ else - SetString(result,P,L); -end; - -{$ifdef FPC_OR_PUREPASCAL} -function TrimLeftLowerCaseShort(V: PShortString): RawUTF8; -var P: PAnsiChar; - L: integer; -begin - L := length(V^); - P := @V^[1]; - while (L>0) and (P^ in ['a'..'z']) do begin - inc(P); - dec(L); - end; - if L=0 then - FastSetString(result,@V^[1],length(V^)) else - FastSetString(result,P,L); -end; -{$else} -function TrimLeftLowerCaseShort(V: PShortString): RawUTF8; -asm // eax=V - xor ecx, ecx - push edx // save result RawUTF8 - test eax, eax - jz @2 // avoid GPF - lea edx, [eax + 1] - mov cl, [eax] -@1: mov ch, [edx] // edx=source cl=length - sub ch, 'a' - sub ch, 'z' - 'a' - ja @2 // not a lower char -> create a result string starting at edx - inc edx - dec cl - jnz @1 - mov cl, [eax] - lea edx, [eax + 1] // no UpperCase -> retrieve full text (result := V^) -@2: pop eax - movzx ecx, cl -{$ifdef UNICODE} - push CP_UTF8 // UTF-8 code page for Delphi 2009+ + call below, not jump - call System.@LStrFromPCharLen // eax=Dest edx=Source ecx=Length - rep ret // we need a call just above for right push CP_UTF8 retrieval -{$else} jmp System.@LStrFromPCharLen // eax=dest edx=source ecx=length(source) -{$endif} -end; -{$endif FPC_OR_PUREPASCAL} - -function UnCamelCase(const S: RawUTF8): RawUTF8; -var tmp: TSynTempBuffer; - destlen: PtrInt; -begin - if S='' then - result := '' else begin - destlen := UnCamelCase(tmp.Init(length(S)*2),pointer(S)); - tmp.Done(PAnsiChar(tmp.buf)+destlen,result); - end; -end; - -function UnCamelCase(D, P: PUTF8Char): integer; -var Space, SpaceBeg, DBeg: PUTF8Char; - CapitalCount: integer; - Number: boolean; -label Next; -begin - DBeg := D; - if (D<>nil) and (P<>nil) then begin // avoid GPF - Space := D; - SpaceBeg := D; - repeat - CapitalCount := 0; - Number := P^ in ['0'..'9']; - if Number then - repeat - inc(CapitalCount); - D^ := P^; - inc(P); - inc(D); - until not (P^ in ['0'..'9']) else - repeat - inc(CapitalCount); - D^ := P^; - inc(P); - inc(D); - until not (P^ in ['A'..'Z']); - if P^=#0 then break; // no lowercase conversion of last fully uppercased word - if (CapitalCount > 1) and not Number then begin - dec(P); - dec(D); - end; - while P^ in ['a'..'z'] do begin - D^ := P^; - inc(D); - inc(P); - end; - if P^='_' then - if P[1]='_' then begin - D^ := ':'; - inc(P); - inc(D); - goto Next; - end else begin - PWord(D)^ := ord(' ')+ord('-')shl 8; - inc(D,2); - Next: if Space=SpaceBeg then - SpaceBeg := D+1; - inc(P); - Space := D+1; - end else - Space := D; - if P^=#0 then break; - D^ := ' '; - inc(D); - until false; - if Space>DBeg then - dec(Space); - while Space>SpaceBeg do begin - if Space^ in ['A'..'Z'] then - if not (Space[1] in ['A'..'Z',' ']) then - inc(Space^,32); // lowercase conversion of not last fully uppercased word - dec(Space); - end; - end; - result := D-DBeg; -end; - -procedure CamelCase(P: PAnsiChar; len: PtrInt; var s: RawUTF8; - const isWord: TSynByteSet); -var i: PtrInt; - d: PAnsiChar; - tmp: array[byte] of AnsiChar; -begin - if len > SizeOf(tmp) then - len := SizeOf(tmp); - for i := 0 to len-1 do - if not(ord(P[i]) in isWord) then begin - if i>0 then begin - MoveSmall(P,@tmp,i); - inc(P,i); - dec(len,i); - end; - d := @tmp[i]; - while len > 0 do begin - while (len > 0) and not (ord(P^) in isWord) do begin - inc(P); - dec(len); - end; - if len = 0 then - break; - d^ := NormToUpperAnsi7[P^]; - inc(d); - repeat - inc(P); - dec(len); - if not (ord(P^) in isWord) then - break; - d^ := P^; - inc(d); - until len = 0; - end; - P := @tmp; - len := d-tmp; - break; - end; - FastSetString(s,P,len); -end; - -procedure CamelCase(const text: RawUTF8; var s: RawUTF8; const isWord: TSynByteSet); -begin - CamelCase(pointer(text), length(text), s, isWord); -end; - -procedure GetCaptionFromPCharLen(P: PUTF8Char; out result: string); -var Temp: array[byte] of AnsiChar; -begin // "out result" parameter definition already made result := '' - if P=nil then - exit; -{$ifdef UNICODE} - // property and enumeration names are UTF-8 encoded with Delphi 2009+ - UTF8DecodeToUnicodeString(Temp,UnCamelCase(@Temp,P),result); -{$else} - SetString(result,Temp,UnCamelCase(@Temp,P)); -{$endif} -{$ifndef LVCL} // LVCL system.pas doesn't implement LoadResStringTranslate() - if Assigned(LoadResStringTranslate) then - LoadResStringTranslate(result); -{$endif} -end; - -function GetDisplayNameFromClass(C: TClass): RawUTF8; -var DelphiName: PShortString; - TrimLeft: integer; -begin - if C=nil then begin - result := ''; - exit; - end; - DelphiName := ClassNameShort(C); - TrimLeft := 0; - if DelphiName^[0]>#4 then - case PInteger(@DelphiName^[1])^ and $DFDFDFDF of - // fast case-insensitive compare - ord('T')+ord('S')shl 8+ord('Q')shl 16+ord('L')shl 24: - if (DelphiName^[0]<=#10) or - (PInteger(@DelphiName^[5])^ and $DFDFDFDF<> // fast case-insensitive compare - ord('R')+ord('E')shl 8+ord('C')shl 16+ord('O')shl 24) or - (PWord(@DelphiName^[9])^ and $DFDF<>ord('R')+ord('D')shl 8) then - TrimLeft := 4 else - TrimLeft := 10; - ord('T')+ord('S')shl 8+ord('Y')shl 16+ord('N')shl 24: - TrimLeft := 4; - end; - if (Trimleft=0) and (DelphiName^[1]='T') then - Trimleft := 1; - FastSetString(result,@DelphiName^[TrimLeft+1],ord(DelphiName^[0])-TrimLeft); -end; - -function GetPublishedMethods(Instance: TObject; out Methods: TPublishedMethodInfoDynArray; - aClass: TClass): integer; - procedure AddParentsFirst(C: TClass); - type - TMethodInfo = packed record - {$ifdef FPC} - Name: PShortString; - Addr: Pointer; - {$else} - Len: Word; - Addr: Pointer; - Name: ShortString; - {$endif} - end; - var Table: {$ifdef FPC}PCardinalArray{$else}PWordArray{$endif}; - M: ^TMethodInfo; - i: integer; - begin - if C=nil then - exit; - AddParentsFirst(GetClassParent(C)); // put children published methods afterward - Table := PPointer(PtrUInt(C)+PtrUInt(vmtMethodTable))^; - if Table=nil then - exit; - SetLength(Methods,result+Table^[0]); - M := @Table^[1]; - for i := 1 to Table^[0] do // Table^[0] = methods count - with Methods[result] do begin - ShortStringToAnsi7String(M^.Name{$ifdef FPC}^{$endif},Name); - Method.Data := Instance; - Method.Code := M^.Addr; - {$ifdef FPC} - inc(M); - {$else} - inc(PByte(M),M^.Len); - {$endif} - inc(result); - end; - end; -begin - result := 0; - if aClass <> nil then - AddParentsFirst(aClass) - else if Instance<>nil then - AddParentsFirst(PPointer(Instance)^); // use recursion for adding -end; - -function GetCaptionFromClass(C: TClass): string; -var tmp: RawUTF8; - P: PUTF8Char; -begin - if C=nil then - result := '' else begin - ToText(C,tmp); - P := pointer(tmp); - if IdemPChar(P,'TSQL') or IdemPChar(P,'TSYN') then - inc(P,4) else - if P^='T' then - inc(P); - GetCaptionFromPCharLen(P,result); - end; -end; - -function GetCaptionFromEnum(aTypeInfo: pointer; aIndex: integer): string; -begin - GetCaptionFromTrimmed(GetEnumName(aTypeInfo,aIndex),result); -end; - -function CharSetToCodePage(CharSet: integer): cardinal; -begin - case CharSet of - SHIFTJIS_CHARSET: result := 932; - HANGEUL_CHARSET: result := 949; - GB2312_CHARSET: result := 936; - HEBREW_CHARSET: result := 1255; - ARABIC_CHARSET: result := 1256; - GREEK_CHARSET: result := 1253; - TURKISH_CHARSET: result := 1254; - VIETNAMESE_CHARSET: result := 1258; - THAI_CHARSET: result := 874; - EASTEUROPE_CHARSET: result := 1250; - RUSSIAN_CHARSET: result := 1251; - BALTIC_CHARSET: result := 1257; - else result := CODEPAGE_US; // default is ANSI_CHARSET = iso-8859-1 = windows-1252 - end; -end; - -function CodePageToCharSet(CodePage: Cardinal): Integer; -begin - case CodePage of - 932: result := SHIFTJIS_CHARSET; - 949: result := HANGEUL_CHARSET; - 936: result := GB2312_CHARSET; - 1255: result := HEBREW_CHARSET; - 1256: result := ARABIC_CHARSET; - 1253: result := GREEK_CHARSET; - 1254: result := TURKISH_CHARSET; - 1258: result := VIETNAMESE_CHARSET; - 874: result := THAI_CHARSET; - 1250: result := EASTEUROPE_CHARSET; - 1251: result := RUSSIAN_CHARSET; - 1257: result := BALTIC_CHARSET; - else result := ANSI_CHARSET; // default is iso-8859-1 = windows-1252 - end; -end; - -function GetMimeContentTypeFromBuffer(Content: Pointer; Len: PtrInt; - const DefaultContentType: RawUTF8): RawUTF8; -begin // see http://www.garykessler.net/library/file_sigs.html for magic numbers - result := DefaultContentType; - if (Content<>nil) and (Len>4) then - case PCardinal(Content)^ of - $04034B50: result := 'application/zip'; // 50 4B 03 04 - $46445025: result := 'application/pdf'; // 25 50 44 46 2D 31 2E - $21726152: result := 'application/x-rar-compressed'; // 52 61 72 21 1A 07 00 - $AFBC7A37: result := 'application/x-7z-compressed'; // 37 7A BC AF 27 1C - $694C5153: result := 'application/x-sqlite3'; // SQlite format 3 = 53 51 4C 69 - $75B22630: result := 'audio/x-ms-wma'; // 30 26 B2 75 8E 66 - $9AC6CDD7: result := 'video/x-ms-wmv'; // D7 CD C6 9A 00 00 - $474E5089: result := 'image/png'; // 89 50 4E 47 0D 0A 1A 0A - $38464947: result := 'image/gif'; // 47 49 46 38 - $46464F77: result := 'application/font-woff'; // wOFF in BigEndian - $A3DF451A: result := 'video/webm'; // 1A 45 DF A3 MKV Matroska stream file - $002A4949, $2A004D4D, $2B004D4D: - result := 'image/tiff'; // 49 49 2A 00 or 4D 4D 00 2A or 4D 4D 00 2B - $46464952: if Len>16 then // RIFF - case PCardinalArray(Content)^[2] of - $50424557: result := 'image/webp'; - $20495641: if PCardinalArray(Content)^[3]=$5453494C then - result := 'video/x-msvideo'; // Windows Audio Video Interleave file - end; - $E011CFD0: // Microsoft Office applications D0 CF 11 E0=DOCFILE - if Len>600 then - case PWordArray(Content)^[256] of // at offset 512 - $A5EC: result := 'application/msword'; // EC A5 C1 00 - $FFFD: // FD FF FF - case PByteArray(Content)^[516] of - $0E,$1C,$43: result := 'application/vnd.ms-powerpoint'; - $10,$1F,$20,$22,$23,$28,$29: result := 'application/vnd.ms-excel'; - end; - end; - $5367674F: - if Len>14 then // OggS - if (PCardinalArray(Content)^[1]=$00000200) and - (PCardinalArray(Content)^[2]=$00000000) and - (PWordArray(Content)^[6]=$0000) then - result := 'video/ogg'; - $1C000000: - if Len>12 then - if PCardinalArray(Content)^[1]=$70797466 then // ftyp - case PCardinalArray(Content)^[2] of - $6D6F7369, // isom: ISO Base Media file (MPEG-4) v1 - $3234706D: // mp42: MPEG-4 video/QuickTime file - result := 'video/mp4'; - $35706733: // 3gp5: MPEG-4 video files - result := 'video/3gpp'; - end; - else - case PCardinal(Content)^ and $00ffffff of - $685A42: result := 'application/bzip2'; // 42 5A 68 - $088B1F: result := 'application/gzip'; // 1F 8B 08 - $492049: result := 'image/tiff'; // 49 20 49 - $FFD8FF: result := JPEG_CONTENT_TYPE; // FF D8 FF DB/E0/E1/E2/E3/E8 - else - case PWord(Content)^ of - $4D42: result := 'image/bmp'; // 42 4D - end; - end; - end; -end; - -function GetMimeContentType(Content: Pointer; Len: PtrInt; - const FileName: TFileName): RawUTF8; -begin - if FileName<>'' then begin // file extension is more precise -> check first - result := LowerCase(StringToAnsi7(ExtractFileExt(FileName))); - case PosEx(copy(result,2,4), - 'png,gif,tiff,jpg,jpeg,bmp,doc,htm,html,css,js,ico,wof,txt,svg,'+ - // 1 5 9 14 18 23 27 31 35 40 44 47 51 55 59 - 'atom,rdf,rss,webp,appc,mani,docx,xml,json,woff,ogg,ogv,mp4,m2v,'+ - // 63 68 72 76 81 86 91 96 100 105 110 114 118 122 - 'm2p,mp3,h264,text,log,gz,webm,mkv,rar,7z') of - // 126 130 134 139 144 148 151 156 160 164 - 1: result := 'image/png'; - 5: result := 'image/gif'; - 9: result := 'image/tiff'; - 14,18: result := JPEG_CONTENT_TYPE; - 23: result := 'image/bmp'; - 27,91: result := 'application/msword'; - 31,35: result := HTML_CONTENT_TYPE; - 40: result := 'text/css'; - 44: result := 'application/javascript'; - // text/javascript and application/x-javascript are obsolete (RFC 4329) - 47: result := 'image/x-icon'; - 51,105: result := 'application/font-woff'; - 55,139,144: result := TEXT_CONTENT_TYPE; - 59: result := 'image/svg+xml'; - 63,68,72,96: result := XML_CONTENT_TYPE; - 76: result := 'image/webp'; - 81,86: result := 'text/cache-manifest'; - 100: result := JSON_CONTENT_TYPE_VAR; - 110,114: result := 'video/ogg'; // RFC 5334 - 118: result := 'video/mp4'; // RFC 4337 6381 - 122,126: result := 'video/mp2'; - 130: result := 'audio/mpeg'; // RFC 3003 - 134: result := 'video/H264'; // RFC 6184 - 148: result := 'application/gzip'; - 151,156: result := 'video/webm'; - 160: result := 'application/x-rar-compressed'; - 164: result := 'application/x-7z-compressed'; - else - result := GetMimeContentTypeFromBuffer(Content,Len,'application/'+copy(result,2,20)); - end; - end else - result := GetMimeContentTypeFromBuffer(Content,Len,BINARY_CONTENT_TYPE); -end; - -function GetMimeContentTypeHeader(const Content: RawByteString; - const FileName: TFileName): RawUTF8; -begin - result := HEADER_CONTENT_TYPE+ - GetMimeContentType(Pointer(Content),length(Content),FileName); -end; - -function IsContentCompressed(Content: Pointer; Len: PtrInt): boolean; -begin // see http://www.garykessler.net/library/file_sigs.html - result := false; - if (Content<>nil) and (Len>8) then - case PCardinal(Content)^ of - $002a4949, $2a004d4d, $2b004d4d, // 'image/tiff' - $04034b50, // 'application/zip' = 50 4B 03 04 - $184d2204, // LZ4 stream format = 04 22 4D 18 - $21726152, // 'application/x-rar-compressed' = 52 61 72 21 1A 07 00 - $28635349, // cab = 49 53 63 28 - $38464947, // 'image/gif' = 47 49 46 38 - $43614c66, // FLAC = 66 4C 61 43 00 00 00 22 - $4643534d, // cab = 4D 53 43 46 [MSCF] - $46464952, // avi,webp,wav = 52 49 46 46 [RIFF] - $46464f77, // 'application/font-woff' = wOFF in BigEndian - $474e5089, // 'image/png' = 89 50 4E 47 0D 0A 1A 0A - $4d5a4cff, // LZMA = FF 4C 5A 4D 41 00 - $72613c21, // .ar/.deb files = '!' (assuming compressed) - $75b22630, // 'audio/x-ms-wma' = 30 26 B2 75 8E 66 - $766f6f6d, // mov = 6D 6F 6F 76 [....moov] - $89a8275f, // jar = 5F 27 A8 89 - $9ac6cdd7, // 'video/x-ms-wmv' = D7 CD C6 9A 00 00 - $a5a5a5a5, // .mab file = MAGIC_MAB in SynLog.pas - $a5aba5a5, // .data = TSQLRESTSTORAGEINMEMORY_MAGIC in mORMot.pas - $aba51051, // .log.synlz = LOG_MAGIC in SynLog.pas - $aba5a5ab, // .dbsynlz = SQLITE3_MAGIC in SynSQLite3.pas - $afbc7a37, // 'application/x-7z-compressed' = 37 7A BC AF 27 1C - $b7010000, $ba010000, // mpeg = 00 00 01 Bx - $cececece, // jceks = CE CE CE CE - $dbeeabed, // .rpm package file - $e011cfd0: // msi = D0 CF 11 E0 A1 B1 1A E1 - result := true; - else - case PCardinal(Content)^ and $00ffffff of - $088b1f, // 'application/gzip' = 1F 8B 08 - $334449, // mp3 = 49 44 33 [ID3] - $492049, // 'image/tiff' = 49 20 49 - $535746, // swf = 46 57 53 [FWS] - $535743, // swf = 43 57 53 [zlib] - $53575a, // zws/swf = 5A 57 53 [FWS] - $564c46, // flv = 46 4C 56 [FLV] - $685a42, // 'application/bzip2' = 42 5A 68 - $ffd8ff: // JPEG_CONTENT_TYPE = FF D8 FF DB/E0/E1/E2/E3/E8 - result := true; - else - case PCardinalArray(Content)^[1] of // 4 byte offset - 1{TAlgoSynLZ.AlgoID}: // crc32 01 00 00 00 crc32 = Compress() header - result := PCardinalArray(Content)^[0]<>PCardinalArray(Content)^[2]; - $70797466, // mp4,mov = 66 74 79 70 [33 67 70 35/4D 53 4E 56..] - $766f6f6d: // mov = 6D 6F 6F 76 - result := true; - end; - end; - end; -end; - -function GetJpegSize(jpeg: PAnsiChar; len: PtrInt; out Height, Width: integer): boolean; -var je: PAnsiChar; -begin // see https://en.wikipedia.org/wiki/JPEG#Syntax_and_structure - result := false; - if (jpeg=nil) or (len<100) or (PWord(jpeg)^<>$d8ff) then // SOI - exit; - je := jpeg+len-1; - inc(jpeg,2); - while jpeg#$ff then - exit; - inc(jpeg); - case ord(jpeg^) of - $c0..$c3,$c5..$c7,$c9..$cb,$cd..$cf: begin // SOF - Height := swap(PWord(jpeg+4)^); - Width := swap(PWord(jpeg+6)^); - result := (Height>0) and (Height<20000) and (Width>0) and (Width<20000); - exit; - end; - $d0..$d8,$01: inc(jpeg); // RST, SOI - $d9: break; // EOI - $ff: ; // padding - else inc(jpeg,swap(PWord(jpeg+1)^)+1); - end; - end; -end; - -function GetJpegSize(const jpeg: TFileName; out Height, Width: integer): boolean; -var map: TMemoryMap; -begin - if map.Map(jpeg) then - try - result := GetJpegSize(map.Buffer,map.Size,Height,Width); - finally - map.UnMap; - end else - result := false; -end; - -function IsHTMLContentTypeTextual(Headers: PUTF8Char): Boolean; -begin - result := ExistsIniNameValue(Headers,HEADER_CONTENT_TYPE_UPPER, - [JSON_CONTENT_TYPE_UPPER,'TEXT/','APPLICATION/XML','APPLICATION/JAVASCRIPT', - 'APPLICATION/X-JAVASCRIPT','IMAGE/SVG+XML']); -end; - -function MultiPartFormDataDecode(const MimeType,Body: RawUTF8; - var MultiPart: TMultiPartDynArray): boolean; -var boundary,endBoundary: RawUTF8; - i,j: integer; - P: PUTF8Char; - part: TMultiPart; -begin - result := false; - i := PosEx('boundary=',MimeType); - if i=0 then - exit; - TrimCopy(MimeType,i+9,200,boundary); - if (boundary<>'') and (boundary[1]='"') then - boundary := copy(boundary,2,length(boundary)-2); // "boundary" -> boundary - boundary := '--'+boundary; - endBoundary := boundary+'--'+#13#10; - boundary := boundary+#13#10; - i := PosEx(boundary,Body); - if i<>0 then - repeat - inc(i,length(boundary)); - if i=length(body) then - exit; // reached the end - P := PUTF8Char(Pointer(Body))+i-1; - Finalize(part); - repeat - if IdemPChar(P,'CONTENT-DISPOSITION: ') then begin - inc(P,21); - if IdemPCharAndGetNextItem(P,'FORM-DATA; NAME="',part.Name,'"') then - IdemPCharAndGetNextItem(P,'; FILENAME="',part.FileName,'"') else - IdemPCharAndGetNextItem(P,'FILE; FILENAME="',part.FileName,'"') - end else - if not IdemPCharAndGetNextItem(P,'CONTENT-TYPE: ',part.ContentType) then - IdemPCharAndGetNextItem(P,'CONTENT-TRANSFER-ENCODING: ',part.Encoding); - P := GotoNextLine(P); - if P=nil then - exit; - until PWord(P)^=13+10 shl 8; - i := P-PUTF8Char(Pointer(Body))+3; // i = just after header - j := PosEx(boundary,Body,i); - if j=0 then begin - j := PosEx(endboundary,Body,i); // try last boundary - if j=0 then - exit; - end; - part.Content := copy(Body,i,j-i-2); // -2 to ignore latest #13#10 - if (part.ContentType='') or (PosEx('-8',part.ContentType)>0) then begin - part.ContentType := TEXT_CONTENT_TYPE; - {$ifdef HASCODEPAGE} - SetCodePage(part.Content,CP_UTF8,false); // ensure raw field value is UTF-8 - {$endif} - end; - if IdemPropNameU(part.Encoding,'base64') then - part.Content := Base64ToBin(part.Content); - // note: "quoted-printable" not yet handled here - SetLength(MultiPart,length(MultiPart)+1); - MultiPart[high(MultiPart)] := part; - result := true; - i := j; - until false; -end; - -function MultiPartFormDataEncode(const MultiPart: TMultiPartDynArray; - var MultiPartContentType, MultiPartContent: RawUTF8): boolean; -var len, boundcount, filescount, i: integer; - boundaries: array of RawUTF8; - bound: RawUTF8; - W: TTextWriter; - temp: TTextWriterStackBuffer; - procedure NewBound; - var random: array[1..3] of cardinal; - begin - FillRandom(@random,3,{forcegsl=}true); - bound := BinToBase64(@random,SizeOf(Random)); - SetLength(boundaries,boundcount+1); - boundaries[boundcount] := bound; - inc(boundcount); - end; -begin - result := false; - len := length(MultiPart); - if len=0 then - exit; - boundcount := 0; - filescount := 0; - W := TTextWriter.CreateOwnedStream(temp); - try - // header - see https://www.w3.org/Protocols/rfc1341/7_2_Multipart.html - NewBound; - MultiPartContentType := 'Content-Type: multipart/form-data; boundary='+bound; - for i := 0 to len-1 do - with MultiPart[i] do begin - if FileName='' then - W.Add('--%'#13#10'Content-Disposition: form-data; name="%"'#13#10+ - 'Content-Type: %'#13#10#13#10'%'#13#10'--%'#13#10, - [bound,Name,ContentType,Content,bound]) else begin - // if this is the first file, create the header for files - if filescount=0 then begin - if i>0 then - NewBound; - W.Add('Content-Disposition: form-data; name="files"'#13#10+ - 'Content-Type: multipart/mixed; boundary=%'#13#10#13#10,[bound]); - end; - inc(filescount); - W.Add('--%'#13#10'Content-Disposition: file; filename="%"'#13#10+ - 'Content-Type: %'#13#10,[bound,FileName,ContentType]); - if Encoding<>'' then - W.Add('Content-Transfer-Encoding: %'#13#10,[Encoding]); - W.AddCR; - W.AddString(MultiPart[i].Content); - W.Add(#13#10'--%'#13#10,[bound]); - end; - end; - // footer multipart - for i := boundcount-1 downto 0 do - W.Add('--%--'#13#10, [boundaries[i]]); - W.SetText(MultiPartContent); - result := True; - finally - W.Free; - end; -end; - -function MultiPartFormDataAddFile(const FileName: TFileName; - var MultiPart: TMultiPartDynArray; const Name: RawUTF8): boolean; -var part: TMultiPart; - newlen: integer; - content: RawByteString; -begin - result := false; - content := StringFromFile(FileName); - if content='' then - exit; - newlen := length(MultiPart)+1; - if Name='' then - FormatUTF8('File%',[newlen],part.Name) else - part.Name := Name; - part.FileName := StringToUTF8(ExtractFileName(FileName)); - part.ContentType := GetMimeContentType(pointer(content),length(content),FileName); - part.Encoding := 'base64'; - part.Content := BinToBase64(content); - SetLength(MultiPart,newlen); - MultiPart[newlen-1] := part; - result := true; -end; - -function MultiPartFormDataAddField(const FieldName, FieldValue: RawUTF8; - var MultiPart: TMultiPartDynArray): boolean; -var - part: TMultiPart; - newlen: integer; -begin - result := false; - if FieldName='' then - exit; - newlen := length(MultiPart)+1; - part.Name := FieldName; - part.ContentType := GetMimeContentTypeFromBuffer( - pointer(FieldValue),length(FieldValue),'text/plain'); - part.Content := FieldValue; - SetLength(MultiPart,newlen); - MultiPart[newlen-1] := part; - result := true; -end; - -function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; -begin - result := FastLocatePUTF8CharSorted(P,R,Value,TUTF8Compare(@StrComp)); -end; - -function FastLocatePUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; - Compare: TUTF8Compare): PtrInt; -var L,i,cmp: PtrInt; -begin // fast O(log(n)) binary search - if not Assigned(Compare) or (R<0) then - result := 0 else - if Compare(P^[R],Value)<0 then // quick return if already sorted - result := R+1 else begin - L := 0; - result := -1; // return -1 if found - repeat - i := (L + R) shr 1; - cmp := Compare(P^[i],Value); - if cmp=0 then - exit; - if cmp<0 then - L := i + 1 else - R := i - 1; - until (L > R); - while (i>=0) and (Compare(P^[i],Value)>=0) do dec(i); - result := i+1; // return the index where to insert - end; -end; - -function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char; - Compare: TUTF8Compare): PtrInt; -var L, cmp: PtrInt; -begin // fast O(log(n)) binary search - L := 0; - if Assigned(Compare) and (R>=0) then - repeat - result := (L+R) shr 1; - cmp := Compare(P^[result],Value); - if cmp=0 then - exit; - if cmp<0 then begin - L := result+1; - if L<=R then - continue; - break; - end; - R := result-1; - if L<=R then - continue; - break; - until false; - result := -1; -end; - -function FastFindPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; Value: PUTF8Char): PtrInt; -{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8/rdx -{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif} - {$ifdef win64} - push rdi - mov rdi, P // P=rdi - {$endif} - push r12 - push r13 - xor r9, r9 // L=r9 - test R, R - jl @err - test Value, Value - jz @void - mov cl, byte ptr[Value] // to check first char (likely diverse) -@s: lea rax, qword ptr[r9 + R] - shr rax, 1 - lea r12, qword ptr[rax - 1] // branchless main loop - lea r13, qword ptr[rax + 1] - mov r10, qword ptr[rdi + rax * 8] - test r10, r10 - jz @lt - cmp cl, byte ptr[r10] - je @eq - cmovc R, r12 - cmovnc r9, r13 -@nxt: cmp r9, R - jle @s -@err: or rax, -1 -@found: pop r13 - pop r12 - {$ifdef win64} - pop rdi - {$endif} - ret -@lt: mov r9, r13 // very unlikely P[rax]=nil - jmp @nxt -@eq: mov r11, Value -@sub: mov cl, byte ptr[r10] - inc r10 - inc r11 - test cl, cl - jz @found - mov cl, byte ptr[r11] - cmp cl, byte ptr[r10] - je @sub - mov cl, byte ptr[Value] // reset first char - cmovc R, r12 - cmovnc r9, r13 - cmp r9, R - jle @s - jmp @err -@void: or rax, -1 - cmp qword ptr[P], 0 - cmove rax, Value - jmp @found -end; -{$else} -var L: PtrInt; - c: byte; - piv,val: PByte; -begin // fast O(log(n)) binary search using inlined StrCompFast() - if R>=0 then - if Value<>nil then begin - L := 0; - repeat - result := (L+R) shr 1; - piv := pointer(P^[result]); - if piv<>nil then begin - val := pointer(Value); - c := piv^; - if c=val^ then - repeat - if c=0 then - exit; // StrComp(P^[result],Value)=0 - inc(piv); - inc(val); - c := piv^; - until c<>val^; - if c>val^ then begin - R := result-1; // StrComp(P^[result],Value)>0 - if L<=R then - continue; - break; - end; - end; - L := result+1; // StrComp(P^[result],Value)<0 - if L<=R then - continue; - break; - until false; - end else - if P^[0]=nil then begin // '' should be in lowest P[] slot - result := 0; - exit; - end; - result := -1; -end; -{$endif CPUX64} - -function FastFindUpperPUTF8CharSorted(P: PPUTF8CharArray; R: PtrInt; - Value: PUTF8Char; ValueLen: PtrInt): PtrInt; -var tmp: array[byte] of AnsiChar; -begin - UpperCopy255Buf(@tmp,Value,ValueLen)^ := #0; - result := FastFindPUTF8CharSorted(P,R,@tmp); -end; - -function FastFindIndexedPUTF8Char(P: PPUTF8CharArray; R: PtrInt; - var SortedIndexes: TCardinalDynArray; Value: PUTF8Char; - ItemComp: TUTF8Compare): PtrInt; -var L, cmp: PtrInt; -begin // fast O(log(n)) binary search - L := 0; - if 0<=R then - repeat - result := (L + R) shr 1; - cmp := ItemComp(P^[SortedIndexes[result]],Value); - if cmp=0 then begin - result := SortedIndexes[result]; - exit; - end; - if cmp<0 then begin - L := result+1; - if L<=R then - continue; - break; - end; - R := result-1; - if L<=R then - continue; - break; - until false; - result := -1; -end; - -function AddSortedRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; - const Value: RawUTF8; CoValues: PIntegerDynArray; ForcedIndex: PtrInt; - Compare: TUTF8Compare): PtrInt; -var n: PtrInt; -begin - if ForcedIndex>=0 then - result := ForcedIndex else begin - if not Assigned(Compare) then - Compare := @StrComp; - result := FastLocatePUTF8CharSorted(pointer(Values),ValuesCount-1,pointer(Value),Compare); - if result<0 then - exit; // Value exists -> fails - end; - n := Length(Values); - if ValuesCount=n then begin - n := NextGrow(n); - SetLength(Values,n); - if CoValues<>nil then - SetLength(CoValues^,n); - end; - n := ValuesCount; - if resultnil then begin - {$ifdef CPU64}n := n shr 1;{$endif} // 64-bit pointer size is twice an integer - MoveFast(CoValues^[result],CoValues^[result+1],n); - end; - end else - result := n; - Values[result] := Value; - inc(ValuesCount); -end; - - -type - /// used internaly for faster quick sort - TQuickSortRawUTF8 = object - Values: PPointerArray; - Compare: TUTF8Compare; - CoValues: PIntegerArray; - pivot: pointer; - procedure Sort(L,R: PtrInt); - end; - -procedure TQuickSortRawUTF8.Sort(L, R: PtrInt); -var I, J, P: PtrInt; - Tmp: Pointer; - TmpInt: integer; -begin - if L0 do Dec(J); - if I <= J then begin - Tmp := Values^[J]; - Values^[J] := Values^[I]; - Values^[I] := Tmp; - if CoValues<>nil then begin - TmpInt := CoValues^[J]; - CoValues^[J] := CoValues^[I]; - CoValues^[I] := TmpInt; - end; - if P = I then P := J else if P = J then P := I; - Inc(I); Dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - Sort(L, J); - L := I; - end else begin - if I < R then - Sort(I, R); - R := J; - end; - until L >= R; -end; - -procedure QuickSortRawUTF8(var Values: TRawUTF8DynArray; ValuesCount: integer; - CoValues: PIntegerDynArray; Compare: TUTF8Compare); -var QS: TQuickSortRawUTF8; -begin - QS.Values := pointer(Values); - if Assigned(Compare) then - QS.Compare := Compare else - QS.Compare := @StrComp; - if CoValues=nil then - QS.CoValues := nil else - QS.CoValues := pointer(CoValues^); - QS.Sort(0,ValuesCount-1); -end; - -function DeleteRawUTF8(var Values: TRawUTF8DynArray; Index: integer): boolean; -var n: integer; -begin - n := length(Values); - if cardinal(Index)>=cardinal(n) then - result := false else begin - dec(n); - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TRawUTF8DynArray)); - Values[Index] := ''; // avoid GPF - if n>Index then begin - MoveFast(pointer(Values[Index+1]),pointer(Values[Index]),(n-Index)*SizeOf(pointer)); - PtrUInt(Values[n]) := 0; // avoid GPF - end; - SetLength(Values,n); - result := true; - end; -end; - -function DeleteRawUTF8(var Values: TRawUTF8DynArray; var ValuesCount: integer; - Index: integer; CoValues: PIntegerDynArray): boolean; -var n: integer; -begin - n := ValuesCount; - if cardinal(Index)>=cardinal(n) then - result := false else begin - dec(n); - ValuesCount := n; - if PDACnt(PtrUInt(Values)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@Values,TypeInfo(TRawUTF8DynArray)); - Values[Index] := ''; // avoid GPF - dec(n,Index); - if n>0 then begin - if CoValues<>nil then - MoveFast(CoValues^[Index+1],CoValues^[Index],n*SizeOf(Integer)); - MoveFast(pointer(Values[Index+1]),pointer(Values[Index]),n*SizeOf(pointer)); - PtrUInt(Values[ValuesCount]) := 0; // avoid GPF - end; - result := true; - end; -end; - -function ToText(const aIntelCPUFeatures: TIntelCpuFeatures; const Sep: RawUTF8): RawUTF8; -var f: TIntelCpuFeature; - List: PShortString; - MaxValue: integer; -begin - result := ''; - List := GetEnumInfo(TypeInfo(TIntelCpuFeature),MaxValue); - if List<>nil then - for f := low(f) to high(f) do begin - if (f in aIntelCPUFeatures) and (List^[3]<>'_') then begin - if result<>'' then - result := result+Sep; - result := result+RawUTF8(copy(List^,3,10)); - end; - inc(PByte(List),PByte(List)^+1); // next - end; -end; - -{$ifdef MSWINDOWS} - -// wrapper around some low-level Windows-specific API - -{$ifdef DELPHI6OROLDER} -function GetFileVersion(const FileName: TFileName): cardinal; -var Size, Size2: DWord; - Pt: Pointer; - Info: ^TVSFixedFileInfo; - tmp: TFileName; -begin - result := cardinal(-1); - if FileName='' then - exit; - // GetFileVersionInfo modifies the filename parameter data while parsing - // Copy the string const into a local variable to create a writeable copy - SetString(tmp,PChar(FileName),length(FileName)); - Size := GetFileVersionInfoSize(pointer(tmp), Size2); - if Size>0 then begin - GetMem(Pt, Size); - try - GetFileVersionInfo(pointer(FileName), 0, Size, Pt); - if VerQueryValue(Pt, '\', pointer(Info), Size2) then - result := Info^.dwFileVersionMS; - finally - Freemem(Pt); - end; - end; -end; -{$endif DELPHI6OROLDER} - -function WndProcMethod(Hwnd: HWND; Msg,wParam,lParam: integer): integer; stdcall; -var obj: TObject; - dsp: TMessage; -begin - {$ifdef CPU64} - obj := pointer(GetWindowLongPtr(HWnd,GWLP_USERDATA)); - {$else} - obj := pointer(GetWindowLong(HWnd,GWL_USERDATA)); // faster than GetProp() - {$endif CPU64} - if not Assigned(obj) then - result := DefWindowProc(HWnd,Msg,wParam,lParam) else begin - dsp.msg := Msg; - dsp.wParam := WParam; - dsp.lParam := lParam; - dsp.result := 0; - obj.Dispatch(dsp); - result := dsp.result; - end; -end; - -function CreateInternalWindow(const aWindowName: string; aObject: TObject): HWND; -var TempClass: TWndClass; -begin - result := 0; - if GetClassInfo(HInstance, pointer(aWindowName), TempClass) then - exit; // class name already registered -> fail - FillCharFast(TempClass,SizeOf(TempClass),0); - TempClass.hInstance := HInstance; - TempClass.lpfnWndProc := @DefWindowProc; - TempClass.lpszClassName := pointer(aWindowName); - Windows.RegisterClass(TempClass); - result := CreateWindowEx(WS_EX_TOOLWINDOW, pointer(aWindowName), - '', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil); - if result=0 then - exit; // impossible to create window -> fail - {$ifdef CPU64} - SetWindowLongPtr(result,GWLP_USERDATA,PtrInt(aObject)); - SetWindowLongPtr(result,GWLP_WNDPROC,PtrInt(@WndProcMethod)); - {$else} - SetWindowLong(result,GWL_USERDATA,PtrInt(aObject)); // faster than SetProp() - SetWindowLong(result,GWL_WNDPROC,PtrInt(@WndProcMethod)); - {$endif CPU64} -end; - -function ReleaseInternalWindow(var aWindowName: string; var aWindow: HWND): boolean; -begin - if (aWindow<>0) and (aWindowName<>'') then begin - {$ifdef CPU64} - SetWindowLongPtr(aWindow,GWLP_WNDPROC,PtrInt(@DefWindowProc)); - {$else} - SetWindowLong(aWindow,GWL_WNDPROC,PtrInt(@DefWindowProc)); - {$endif CPU64} - DestroyWindow(aWindow); - Windows.UnregisterClass(pointer(aWindowName),HInstance); - aWindow := 0; - aWindowName := ''; - result := true; - end else - result := false; -end; - -var - LastAppUserModelID: string; - -function SetAppUserModelID(const AppUserModelID: string): boolean; -var shell32: THandle; - id: SynUnicode; - SetCurrentProcessExplicitAppUserModelID: function(appID: PWidechar): HResult; stdcall; -begin - if AppUserModelID=LastAppUserModelID then begin - result := true; - exit; // nothing to set - end; - result := false; - shell32 := GetModuleHandle('shell32.dll'); - if shell32=0 then - exit; - SetCurrentProcessExplicitAppUserModelID := GetProcAddress( - shell32,'SetCurrentProcessExplicitAppUserModelID'); - if not Assigned(SetCurrentProcessExplicitAppUserModelID) then - exit; // API available since Windows Seven / Server 2008 R2 - StringToSynUnicode(AppUserModelID,id); - if Pos('.',AppUserModelID)=0 then - id := id+'.'+id; // at least CompanyName.ProductName - if SetCurrentProcessExplicitAppUserModelID(pointer(id))<>S_OK then - exit; - result := true; - LastAppUserModelID := AppUserModelID; -end; - -{$endif MSWINDOWS} - -{ TFileVersion } - -constructor TFileVersion.Create(const aFileName: TFileName; - aMajor,aMinor,aRelease,aBuild: integer); -var M,D: word; -{$ifdef MSWINDOWS} - Size, Size2: DWord; - Pt, StrPt, StrValPt: Pointer; - LanguageInfo: RawUTF8; - Info: ^TVSFixedFileInfo; - FileTime: TFILETIME; - SystemTime: TSYSTEMTIME; - tmp: TFileName; - function ReadResourceByName(const From: RawUTF8): RawUTF8; - var sz: DWord; - begin - VerQueryValueA(Pt,PAnsiChar('\StringFileInfo\'+LanguageInfo+'\'+From),StrValPt,sz); - if sz>0 then - FastSetString(Result,StrValPt,sz) - end; -{$else} -{$ifdef FPCUSEVERSIONINFO} - VI: TVersionInfo; - LanguageInfo: String; - TI, I: Integer; -{$endif} -{$endif MSWINDOWS} -begin - fFileName := aFileName; - {$ifdef MSWINDOWS} - if aFileName<>'' then begin - // GetFileVersionInfo modifies the filename parameter data while parsing. - // Copy the string const into a local variable to create a writeable copy. - SetString(tmp,PChar(aFileName),length(aFileName)); - Size := GetFileVersionInfoSize(pointer(tmp), Size2); - if Size>0 then begin - GetMem(Pt, Size); - try - GetFileVersionInfo(pointer(aFileName), 0, Size, Pt); - VerQueryValue(Pt, '\', pointer(Info), Size2); - with Info^ do begin - if Version32=0 then begin - aMajor := dwFileVersionMS shr 16; - aMinor := word(dwFileVersionMS); - aRelease := dwFileVersionLS shr 16; - end; - aBuild := word(dwFileVersionLS); - if (dwFileDateLS<>0) and (dwFileDateMS<>0) then begin - FileTime.dwLowDateTime:= dwFileDateLS; // built date from version info - FileTime.dwHighDateTime:= dwFileDateMS; - FileTimeToSystemTime(FileTime, SystemTime); - fBuildDateTime := EncodeDate( - SystemTime.wYear,SystemTime.wMonth,SystemTime.wDay); - end; - end; - VerQueryValue(Pt, '\VarFileInfo\Translation', StrPt, Size2); - if Size2 >= 4 then begin - LanguageInfo := BinToHexDisplay(PAnsiChar(StrPt), 2) + BinToHexDisplay(PAnsiChar(StrPt)+2, 2); - CompanyName := ReadResourceByName('CompanyName'); - FileDescription := ReadResourceByName('FileDescription'); - FileVersion := ReadResourceByName('FileVersion'); - InternalName := ReadResourceByName('InternalName'); - LegalCopyright := ReadResourceByName('LegalCopyright'); - OriginalFilename := ReadResourceByName('OriginalFilename'); - ProductName := ReadResourceByName('ProductName'); - ProductVersion := ReadResourceByName('ProductVersion'); - Comments := ReadResourceByName('Comments'); - end - finally - Freemem(Pt); - end; - end; - end; - {$else MSWINDOWS} - {$ifdef FPCUSEVERSIONINFO} // FPC 3.0+ if enabled in Synopse.inc / project options - if aFileName<>'' then - try - VI := TVersionInfo.Create; - try - if (aFileName<>ExeVersion.ProgramFileName) and (aFileName<>ParamStr(0)) then - VI.Load(aFileName) else - VI.Load(HInstance); // load info for currently running program - aMajor := VI.FixedInfo.FileVersion[0]; - aMinor := VI.FixedInfo.FileVersion[1]; - aRelease := VI.FixedInfo.FileVersion[2]; - aBuild := VI.FixedInfo.FileVersion[3]; - //fBuildDateTime := TDateTime(VI.FixedInfo.FileDate); << need to find out how to convert this before uncommenting - // detect translation. - if VI.VarFileInfo.Count>0 then - with VI.VarFileInfo.Items[0] do - LanguageInfo := Format('%.4x%.4x',[language,codepage]); - if LanguageInfo='' then begin - // take first language - Ti := 0; - if VI.StringFileInfo.Count>0 then - LanguageInfo := VI.StringFileInfo.Items[0].Name - end else begin - // look for index of language - TI := VI.StringFileInfo.Count-1; - while (TI>=0) and (CompareText(VI.StringFileInfo.Items[TI].Name,LanguageInfo)<>0) do - dec(TI); - if (TI < 0) then begin - TI := 0; // revert to first translation - LanguageInfo := VI.StringFileInfo.Items[TI].Name; - end; - end; - with VI.StringFileInfo.Items[TI] do begin - CompanyName := Values['CompanyName']; - FileDescription := Values['FileDescription']; - FileVersion := Values['FileVersion']; - InternalName := Values['InternalName']; - LegalCopyright := Values['LegalCopyright']; - OriginalFilename := Values['OriginalFilename']; - ProductName := Values['ProductName']; - ProductVersion := Values['ProductVersion']; - Comments := Values['Comments']; - end; - finally - VI.Free; - end; - except - // just ignore if version information resource is missing - end; - {$endif FPCUSEVERSIONINFO} - {$endif MSWINDOWS} - SetVersion(aMajor,aMinor,aRelease,aBuild); - if fBuildDateTime=0 then // get build date from file age - fBuildDateTime := FileAgeToDateTime(aFileName); - if fBuildDateTime<>0 then - DecodeDate(fBuildDateTime,BuildYear,M,D); -end; - -function TFileVersion.Version32: integer; -begin - result := Major shl 16+Minor shl 8+Release; -end; - -procedure TFileVersion.SetVersion(aMajor,aMinor,aRelease,aBuild: integer); -begin - Major := aMajor; - Minor := aMinor; - Release := aRelease; - Build := aBuild; - Main := IntToString(Major)+'.'+IntToString(Minor); - fDetailed := Main+ '.'+IntToString(Release)+'.'+IntToString(Build); -end; - -function TFileVersion.BuildDateTimeString: string; -begin - DateTimeToIso8601StringVar(fBuildDateTime,' ',result); -end; - -function TFileVersion.DetailedOrVoid: string; -begin - if (self=nil) or (Major or Minor or Release or Build=0) then - result := '' else - result := fDetailed; -end; - -function TFileVersion.VersionInfo: RawUTF8; -begin - FormatUTF8('% % (%)',[ExtractFileName(fFileName),DetailedOrVoid,BuildDateTimeString],result); -end; - -function TFileVersion.UserAgent: RawUTF8; -begin - if self=nil then - result := '' else - FormatUTF8('%/%%',[GetFileNameWithoutExt(ExtractFileName(fFileName)), - DetailedOrVoid,OS_INITIAL[OS_KIND]],result); - {$ifdef MSWINDOWS} - if OSVersion in WINDOWS_32 then - result := result+'32'; - {$endif MSWINDOWS} -end; - -class function TFileVersion.GetVersionInfo(const aFileName: TFileName): RawUTF8; -begin - with Create(aFileName,0,0,0,0) do - try - result := VersionInfo; - finally - Free; - end; -end; - -procedure SetExecutableVersion(const aVersionText: RawUTF8); -var P: PUTF8Char; - i: integer; - ver: array[0..3] of integer; -begin - P := pointer(aVersionText); - for i := 0 to 3 do - ver[i] := GetNextItemCardinal(P,'.'); - SetExecutableVersion(ver[0],ver[1],ver[2],ver[3]); -end; - -procedure SetExecutableVersion(aMajor,aMinor,aRelease,aBuild: integer); -var {$ifdef MSWINDOWS} - tmp: array[byte] of WideChar; - tmpsize: cardinal; - {$else} - tmp: string; - {$endif} -begin - with ExeVersion do begin - if Version=nil then begin - {$ifdef MSWINDOWS} - ProgramFileName := paramstr(0); - {$else} - ProgramFileName := GetModuleName(HInstance); - if ProgramFileName='' then - ProgramFileName := ExpandFileName(paramstr(0)); - {$endif MSWINDOWS} - ProgramFilePath := ExtractFilePath(ProgramFileName); - if IsLibrary then - InstanceFileName := GetModuleName(HInstance) else - InstanceFileName := ProgramFileName; - ProgramName := StringToUTF8(GetFileNameWithoutExt(ExtractFileName(ProgramFileName))); - {$ifdef MSWINDOWS} - tmpsize := SizeOf(tmp); - GetComputerNameW(tmp,tmpsize); - RawUnicodeToUtf8(@tmp,StrLenW(tmp),Host); - tmpsize := SizeOf(tmp); - GetUserNameW(tmp,tmpsize); - RawUnicodeToUtf8(@tmp,StrLenW(tmp),User); - {$else} - StringToUTF8(GetHostName,Host); - if Host='' then - StringToUTF8(GetEnvironmentVariable('HOSTNAME'),Host); - tmp := GetEnvironmentVariable('LOGNAME'); // POSIX - if tmp='' then - tmp := GetEnvironmentVariable('USER'); - {$ifdef KYLIX3} - if tmp='' then - User := LibC.getpwuid(LibC.getuid)^.pw_name else - {$endif} - StringToUTF8(tmp,User); - {$endif MSWINDOWS} - if Host='' then - Host := 'unknown'; - if User='' then - User := 'unknown'; - GarbageCollectorFreeAndNil(Version, - TFileVersion.Create(InstanceFileName,aMajor,aMinor,aRelease,aBuild)); - end else - Version.SetVersion(aMajor,aMinor,aRelease,aBuild); - FormatUTF8('% % (%)',[ProgramFileName,Version.Detailed, - DateTimeToIso8601(Version.BuildDateTime,True,' ')],ProgramFullSpec); - Hash.c0 := Version.Version32; - {$ifdef CPUINTEL} - Hash.c0 := crc32c(Hash.c0,@CpuFeatures,SizeOf(CpuFeatures)); - {$endif} - Hash.c0 := crc32c(Hash.c0,pointer(Host),length(Host)); - Hash.c1 := crc32c(Hash.c0,pointer(User),length(User)); - Hash.c2 := crc32c(Hash.c1,pointer(ProgramFullSpec),length(ProgramFullSpec)); - Hash.c3 := crc32c(Hash.c2,pointer(InstanceFileName),length(InstanceFileName)); - end; -end; - -{$ifdef MSWINDOWS} -// avoid unneeded reference to ShlObj.pas -function SHGetFolderPath(hwnd: HWND; csidl: Integer; hToken: THandle; - dwFlags: DWord; pszPath: PChar): HRESULT; stdcall; external 'SHFolder.dll' - name {$ifdef UNICODE}'SHGetFolderPathW'{$else}'SHGetFolderPathA'{$endif}; - -var - _SystemPath: array[TSystemPath] of TFileName; - -function GetSystemPath(kind: TSystemPath): TFileName; -const - CSIDL_PERSONAL = $0005; - CSIDL_LOCAL_APPDATA = $001C; // local non roaming user folder - CSIDL_COMMON_APPDATA = $0023; - CSIDL_COMMON_DOCUMENTS = $002E; - CSIDL: array[TSystemPath] of integer = ( - // spCommonData, spUserData, spCommonDocuments - CSIDL_COMMON_APPDATA, CSIDL_LOCAL_APPDATA, CSIDL_COMMON_DOCUMENTS, - // spUserDocuments, spTempFolder, spLog - CSIDL_PERSONAL, 0, CSIDL_LOCAL_APPDATA); - ENV: array[TSystemPath] of TFileName = ( - 'ALLUSERSAPPDATA', 'LOCALAPPDATA', '', '', 'TEMP', 'LOCALAPPDATA'); -var tmp: array[0..MAX_PATH] of char; -begin - if _SystemPath[kind]='' then - if (kind=spLog) and IsDirectoryWritable(ExeVersion.ProgramFilePath) then - _SystemPath[kind] := EnsureDirectoryExists(ExeVersion.ProgramFilePath+'log') else - if (CSIDL[kind]<>0) and (SHGetFolderPath(0,CSIDL[kind],0,0,@tmp)=S_OK) then - _SystemPath[kind] := IncludeTrailingPathDelimiter(tmp) else begin - _SystemPath[kind] := GetEnvironmentVariable(ENV[kind]); - if _SystemPath[kind]='' then - _SystemPath[kind] := GetEnvironmentVariable('APPDATA'); - _SystemPath[kind] := IncludeTrailingPathDelimiter(_SystemPath[kind]); - end; - result := _SystemPath[kind]; -end; -{$else MSWINDOWS} -var - _HomePath, _TempPath, _UserPath, _LogPath: TFileName; - -function GetSystemPath(kind: TSystemPath): TFileName; -begin - case kind of - spLog: begin - if _LogPath='' then - if IsDirectoryWritable('/var/log') then - _LogPath := '/var/log/' else // may not be writable by not root on POSIX - if IsDirectoryWritable(ExeVersion.ProgramFilePath) then - _LogPath := ExeVersion.ProgramFilePath else - _LogPath := GetSystemPath(spUserData); - result := _LogPath; - end; - spUserData: begin - if _UserPath='' then begin // ~/.cache/appname - _UserPath := GetEnvironmentVariable('XDG_CACHE_HOME'); - if (_UserPath='') or not IsDirectoryWritable(_UserPath) then - _UserPath := EnsureDirectoryExists(GetSystemPath(spUserDocuments)+'.cache'); - _UserPath := EnsureDirectoryExists(_UserPath+UTF8ToString(ExeVersion.ProgramName)); - end; - result := _UserPath; - end; - spTempFolder: begin - if _TempPath='' then begin - _TempPath := GetEnvironmentVariable('TMPDIR'); // POSIX - if _TempPath='' then - _TempPath := GetEnvironmentVariable('TMP'); - if _TempPath='' then - if DirectoryExists('/tmp') then - _TempPath := '/tmp' else - _TempPath := '/var/tmp'; - _TempPath := IncludeTrailingPathDelimiter(_TempPath); - end; - result := _TempPath; - end else begin - if _HomePath='' then // POSIX requires a value for $HOME - _HomePath := IncludeTrailingPathDelimiter(GetEnvironmentVariable('HOME')); - result := _HomePath; - end; - end; -end; -{$endif MSWINDOWS} - -procedure PatchCode(Old,New: pointer; Size: integer; Backup: pointer; - LeaveUnprotected: boolean); -{$ifdef MSWINDOWS} -var RestoreProtection, Ignore: DWORD; - i: integer; -begin - if VirtualProtect(Old, Size, PAGE_EXECUTE_READWRITE, RestoreProtection) then - begin - if Backup<>nil then - for i := 0 to Size-1 do // do not use Move() here - PByteArray(Backup)^[i] := PByteArray(Old)^[i]; - for i := 0 to Size-1 do // do not use Move() here - PByteArray(Old)^[i] := PByteArray(New)^[i]; - if not LeaveUnprotected then - VirtualProtect(Old, Size, RestoreProtection, Ignore); - FlushInstructionCache(GetCurrentProcess, Old, Size); - if not CompareMemFixed(Old,New,Size) then - raise ESynException.Create('PatchCode?'); - end; -end; -{$else} -var PageSize: PtrUInt; - AlignedAddr: pointer; - i: PtrInt; - ProtectedResult: boolean; - ProtectedMemory: boolean; -begin - if Backup<>nil then - for i := 0 to Size-1 do // do not use Move() here - PByteArray(Backup)^[i] := PByteArray(Old)^[i]; - PageSize := SystemInfo.dwPageSize; - AlignedAddr := Pointer((PtrUInt(Old) DIV SystemInfo.dwPageSize) * SystemInfo.dwPageSize); - while PtrUInt(Old)+PtrUInt(Size)>=PtrUInt(AlignedAddr)+PageSize do - Inc(PageSize,SystemInfo.dwPageSize); - ProtectedResult := SynMProtect(AlignedAddr,PageSize,PROT_READ or PROT_WRITE or PROT_EXEC) = 0; - ProtectedMemory := not ProtectedResult; - if ProtectedMemory then - ProtectedResult := SynMProtect(AlignedAddr,PageSize,PROT_READ or PROT_WRITE) = 0; - if ProtectedResult then - try - for i := 0 to Size-1 do // do not use Move() here - PByteArray(Old)^[i] := PByteArray(New)^[i]; - if not LeaveUnprotected and ProtectedMemory then - SynMProtect(AlignedAddr,PageSize,PROT_READ or PROT_EXEC); - except - end; -end; -{$endif MSWINDOWS} - -procedure PatchCodePtrUInt(Code: PPtrUInt; Value: PtrUInt; - LeaveUnprotected: boolean); -begin - PatchCode(Code,@Value,SizeOf(Code^),nil,LeaveUnprotected); -end; - -{$ifdef CPUINTEL} - -procedure RedirectCode(Func, RedirectFunc: Pointer; Backup: PPatchCode); -var NewJump: packed record - Code: byte; // $e9 = jmp {relative} - Distance: integer; // relative jump is 32-bit even on CPU64 - end; -begin - if (Func=nil) or (RedirectFunc=nil) then - exit; // nothing to redirect to - assert(SizeOf(TPatchCode)=SizeOf(NewJump)); - NewJump.Code := $e9; - NewJump.Distance := integer(PtrUInt(RedirectFunc)-PtrUInt(Func)-SizeOf(NewJump)); - PatchCode(Func,@NewJump,SizeOf(NewJump),Backup); - {$ifndef LVCL} - assert(pByte(Func)^=$e9); - {$endif} -end; - -procedure RedirectCodeRestore(Func: pointer; const Backup: TPatchCode); -begin - PatchCode(Func,@Backup,SizeOf(TPatchCode)); -end; - -{$endif CPUINTEL} - -{$ifndef LVCL} -{$ifndef FPC} -{$ifndef UNICODE} - -const - MemoryDelta = $8000; // 32 KB granularity (must be a power of 2) - -function THeapMemoryStream.Realloc(var NewCapacity: longint): Pointer; -// allocates memory from Delphi heap (FastMM4/SynScaleMM) and not windows.Global*() -// and uses bigger growing size -> a lot faster -var i: PtrInt; -begin - if NewCapacity>0 then begin - i := Seek(0,soFromCurrent); // no direct access to fSize -> use Seek() trick - if NewCapacity=Seek(0,soFromEnd) then begin // avoid ReallocMem() if just truncate - result := Memory; - Seek(i,soBeginning); - exit; - end; - NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1); - Seek(i,soBeginning); - end; - Result := Memory; - if NewCapacity <> Capacity then begin - if NewCapacity = 0 then begin - FreeMem(Memory); - Result := nil; - end else begin - if Capacity = 0 then - GetMem(Result, NewCapacity) else - if NewCapacity > Capacity then // only realloc if necessary (grow up) - ReallocMem(Result, NewCapacity) else - NewCapacity := Capacity; // same capacity as before - if Result = nil then - raise EStreamError.Create('THeapMemoryStream'); // memory allocation bug - end; - end; -end; - -{$endif UNICODE} -{$endif FPC} -{$endif LVCL} - - -{ TSortedWordArray } - -function FastLocateWordSorted(P: PWordArray; R: integer; Value: word): PtrInt; -var L,cmp: PtrInt; -begin - if R<0 then - result := 0 else begin - L := 0; - repeat - result := (L + R) shr 1; - cmp := P^[result]-Value; - if cmp=0 then begin - result := -result-1; // return -(foundindex+1) if already exists - exit; - end; - if cmp<0 then - L := result + 1 else - R := result - 1; - until (L > R); - while (result>=0) and (P^[result]>=Value) do dec(result); - result := result+1; // return the index where to insert - end; -end; - -function FastFindWordSorted(P: PWordArray; R: PtrInt; Value: Word): PtrInt; -{$ifdef CPUX64} // P=rcx/rdi R=rdx/rsi Value=r8w/dx -{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif} - {$ifdef win64} - push rdi - mov rdi, P // rdi=P - {$endif} - xor r9, r9 // r9=L rax=result - test R, R - jl @ko -{$ifdef FPC} align 8 {$else} .align 8 {$endif} -@s: lea rax, [r9 + R] - shr rax, 1 - lea r10, qword ptr[rax - 1] // branchless loop - lea r11, qword ptr[rax + 1] - movzx ecx, word ptr[rdi + rax * 2] - {$ifdef win64} - cmp ecx, r8d - {$else} - cmp ecx, edx // 'cmp cx,Value' is silently rejected by Darwin asm - {$endif win64} - je @ok - cmovg R, r10 - cmovl r9, r11 - cmp r9, R - jle @s -@ko: or rax, -1 -@ok: {$ifdef win64} - pop rdi - {$endif} -end; -{$else} -var L: PtrInt; - cmp: integer; -begin - L := 0; - if 0<=R then - repeat - result := (L + R) shr 1; - cmp := P^[result]-Value; - if cmp=0 then - exit; - if cmp<0 then begin - L := result+1; - if L<=R then - continue; - break; - end; - R := result-1; - if L<=R then - continue; - break; - until false; - result := -1 -end; -{$endif CPUX64} - -function TSortedWordArray.Add(aValue: Word): PtrInt; -begin - result := Count; // optimistic check of perfectly increasing aValue - if (result>0) and (aValue<=Values[result-1]) then - result := FastLocateWordSorted(pointer(Values),result-1,aValue); - if result<0 then // aValue already exists in Values[] -> fails - exit; - if Count=length(Values) then - SetLength(Values,NextGrow(Count)); - if result J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortCompare(OnCompare, Index, L, J); - L := I; - end else begin - if I < R then - QuickSortCompare(OnCompare, Index, I, R); - R := J; - end; - until L >= R; -end; - -procedure Exchg32(var A,B: integer); {$ifdef HASINLINE}inline;{$endif} -var tmp: integer; -begin - tmp := A; - A := B; - B := tmp; -end; - -function MedianQuickSelectInteger(Values: PIntegerArray; n: integer): integer; -var low, high, median, middle, ll, hh: PtrInt; -begin - if n=0 then begin - result := 0; - exit; - end; - if n=1 then begin - result := Values[0]; - exit; - end; - low := 0; - high := n-1; - median := high shr 1; - repeat - if high<=low then begin // one item left - result := Values[median]; - exit; - end; - if high=low+1 then begin // two items -> return the smallest (not average) - if Values[low]>Values[high] then - Exchg32(Values[low],Values[high]); - result := Values[median]; - exit; - end; - // find median of low, middle and high items; swap into position low - middle := (low+high) shr 1; - if Values[middle]>Values[high] then - Exchg32(Values[middle],Values[high]); - if Values[low]>Values[high] then - Exchg32(Values[low],Values[high]); - if Values[middle]>Values[low] then - Exchg32(Values[middle],Values[low]); - // swap low item (now in position middle) into position (low+1) - Exchg32(Values[middle],Values[low+1]); - // nibble from each end towards middle, swapping items when stuck - ll := low+1; - hh := high; - repeat - repeat - inc(ll); - until not (Values[low]>Values[ll]); - repeat - dec(hh); - until not (Values[hh]>Values[low]); - if hh=median then - high := hh-1; - until false; -end; - -function MedianQuickSelect(const OnCompare: TOnValueGreater; n: integer; - var TempBuffer: TSynTempBuffer): integer; -var low, high, middle, median, ll, hh: PtrInt; - tmp: integer; - ndx: PIntegerArray; -begin - if n<=1 then begin - TempBuffer.buf := nil; // avoid GPF in TempBuffer.Done - result := 0; - exit; - end; - low := 0; - high := n-1; - ndx := TempBuffer.InitIncreasing(n*4); // no heap alloacation until n>1024 - median := high shr 1; - repeat - if high<=low then begin // one item left - result := ndx[median]; - TempBuffer.Done; - exit; - end; - if high=low+1 then begin // two items -> return the smallest (not average) - if OnCompare(ndx[low],ndx[high]) then - Exchg32(ndx[low],ndx[high]); - result := ndx[median]; - TempBuffer.Done; - exit; - end; - // find median of low, middle and high items; swap into position low - middle := (low+high) shr 1; - if OnCompare(ndx[middle],ndx[high]) then - Exchg32(ndx[middle],ndx[high]); - if OnCompare(ndx[low],ndx[high]) then - Exchg32(ndx[low],ndx[high]); - if OnCompare(ndx[middle],ndx[low]) then - Exchg32(ndx[middle],ndx[low]); - // swap low item (now in position middle) into position (low+1) - Exchg32(ndx[middle],ndx[low+1]); - // nibble from each end towards middle, swapping items when stuck - ll := low+1; - hh := high; - repeat - tmp := ndx[low]; - repeat - inc(ll); - until not OnCompare(tmp,ndx[ll]); - repeat - dec(hh); - until not OnCompare(ndx[hh],tmp); - if hh=median then - high := hh-1; - until false; -end; - -function gcd(a, b: cardinal): cardinal; -begin - while a <> b do - if a > b then - dec(a, b) else - dec(b, a); - result := a; -end; - -function ToVarUInt32Length(Value: PtrUInt): PtrUInt; -begin - if Value<=$7f then - result := 1 else - if Value<$80 shl 7 then - result := 2 else - if Value<$80 shl 14 then - result := 3 else - if Value <$80 shl 21 then - result := 4 else - result := 5; -end; - -function ToVarUInt32LengthWithData(Value: PtrUInt): PtrUInt; -begin - if Value<=$7f then - result := Value+1 else - if Value<$80 shl 7 then - result := Value+2 else - if Value<$80 shl 14 then - result := Value+3 else - if Value<$80 shl 21 then - result := Value+4 else - result := Value+5; -end; - -{$ifdef HASINLINE} -function FromVarUInt32(var Source: PByte): cardinal; -begin - result := Source^; - inc(Source); - if result>$7f then - result := (result and $7F) or FromVarUInt32Up128(Source); -end; - -function FromVarUInt32Big(var Source: PByte): cardinal; -{$else} -function FromVarUInt32Big(var Source: PByte): cardinal; -asm - jmp FromVarUInt32 -end; - -function FromVarUInt32(var Source: PByte): cardinal; -{$endif} -var c: cardinal; - p: PByte; -begin - p := Source; - result := p^; - inc(p); - if result>$7f then begin // Values between 128 and 16256 - c := p^; - c := c shl 7; - result := result and $7F or c; - inc(p); - if c>$7f shl 7 then begin // Values between 16257 and 2080768 - c := p^; - c := c shl 14; - inc(p); - result := result and $3FFF or c; - if c>$7f shl 14 then begin // Values between 2080769 and 266338304 - c := p^; - c := c shl 21; - inc(p); - result := result and $1FFFFF or c; - if c>$7f shl 21 then begin - c := p^; - c := c shl 28; - inc(p); - result := result and $FFFFFFF or c; - end; - end; - end; - end; - Source := p; -end; - -function FromVarUInt32Up128(var Source: PByte): cardinal; -var c: cardinal; - p: PByte; -begin // Values above 128 - p := Source; - result := p^ shl 7; - inc(p); - if result>$7f shl 7 then begin // Values above 16257 - c := p^; - c := c shl 14; - inc(p); - result := result and $3FFF or c; - if c>$7f shl 14 then begin - c := p^; - c := c shl 21; - inc(p); - result := result and $1FFFFF or c; - if c>$7f shl 21 then begin - c := p^; - c := c shl 28; - inc(p); - result := result and $FFFFFFF or c; - end; - end; - end; - Source := p; -end; - -function FromVarUInt32(var Source: PByte; SourceMax: PByte; out Value: cardinal): boolean; -begin - if SourceMax=nil then begin - Value := FromVarUInt32(Source); - result := true; - end else begin - Source := FromVarUInt32Safe(Source,SourceMax,Value); - result := Source<>nil; - end; -end; - -function FromVarUInt32Safe(Source, SourceMax: PByte; out Value: cardinal): PByte; -var c: cardinal; -begin - result := nil; // error - if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; - c := Source^; - inc(Source); - Value := c; - if c>$7f then begin // Values between 128 and 16256 - if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; - c := Source^; - c := c shl 7; - Value := Value and $7F or c; - inc(Source); - if c>$7f shl 7 then begin // Values between 16257 and 2080768 - if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; - c := Source^; - c := c shl 14; - inc(Source); - Value := Value and $3FFF or c; - if c>$7f shl 14 then begin // Values between 2080769 and 266338304 - if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; - c := Source^; - c := c shl 21; - inc(Source); - Value := Value and $1FFFFF or c; - if c>$7f shl 21 then begin - if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; - c := Source^; - c := c shl 28; - inc(Source); - Value := Value and $FFFFFFF or c; - end; - end; - end; - end; - result := Source; // safely decoded -end; - -function FromVarInt32(var Source: PByte): integer; -var c: cardinal; - p: PByte; -begin // fast stand-alone function with no FromVarUInt32 call - p := Source; - result := p^; - inc(p); - if result>$7f then begin - c := p^; - c := c shl 7; - result := result and $7F or integer(c); - inc(p); - if c>$7f shl 7 then begin - c := p^; - c := c shl 14; - inc(p); - result := result and $3FFF or integer(c); - if c>$7f shl 14 then begin - c := p^; - c := c shl 21; - inc(p); - result := result and $1FFFFF or integer(c); - if c>$7f shl 21 then begin - c := p^; - c := c shl 28; - inc(p); - result := result and $FFFFFFF or integer(c); - end; - end; - end; - end; - Source := p; - // 0=0,1=1,2=-1,3=2,4=-2... - if result and 1<>0 then - // 1->1, 3->2.. - result := result shr 1+1 else - // 0->0, 2->-1, 4->-2.. - result := -(result shr 1); -end; - -function FromVarUInt32High(var Source: PByte): cardinal; -var c: cardinal; -begin - result := Source^; - inc(Source); - c := Source^ shl 7; - inc(Source); - result := result and $7F or c; - if c<=$7f shl 7 then - exit; - c := Source^ shl 14; - inc(Source); - result := result and $3FFF or c; - if c<=$7f shl 14 then - exit; - c := Source^ shl 21; - inc(Source); - result := result and $1FFFFF or c; - if c<=$7f shl 21 then - exit; - c := Source^ shl 28; - inc(Source); - result := result and $FFFFFFF or c; -end; - -function ToVarInt64(Value: Int64; Dest: PByte): PByte; -begin // 0=0,1=1,2=-1,3=2,4=-2... - {$ifdef CPU32} - if Value<=0 then - // 0->0, -1->2, -2->4.. - result := ToVarUInt64((-Value) shl 1,Dest) else - // 1->1, 2->3.. - result := ToVarUInt64((Value shl 1)-1,Dest); - {$else} - if Value<=0 then - // 0->0, -1->2, -2->4.. - Value := (-Value) shl 1 else - // 1->1, 2->3.. - Value := (Value shl 1)-1; - result := ToVarUInt64(Value,Dest); - {$endif} -end; - -function ToVarUInt64(Value: QWord; Dest: PByte): PByte; -label _1,_2,_4; // ugly but fast -var c: cardinal; -begin - repeat - c := Value; - if {$ifdef CPU32}PInt64Rec(@Value)^.Hi=0{$else}Value shr 32=0{$endif} then begin - if c>$7f then begin // inlined result := ToVarUInt32(Value,Dest); - if c<$80 shl 7 then goto _1 else - if c<$80 shl 14 then goto _2 else - if c>=$80 shl 21 then goto _4; - Dest^ := (c and $7F) or $80; - c := c shr 7; - inc(Dest); - _2: Dest^ := (c and $7F) or $80; - c := c shr 7; - inc(Dest); - _1: Dest^ := (c and $7F) or $80; - c := c shr 7; - inc(Dest); - end; - Dest^ := c; - inc(Dest); - result := Dest; - exit; - end; -_4: PCardinal(Dest)^ := (c and $7F) or (((c shr 7)and $7F)shl 8) or - (((c shr 14)and $7F)shl 16) or (((c shr 21)and $7F)shl 24) or $80808080; - inc(Dest,4); - Value := Value shr 28; - until false; -end; - -function FromVarUInt64(var Source: PByte): QWord; -var c,n: PtrUInt; - p: PByte; -begin - p := Source; - {$ifdef CPU64} - result := p^; - if result>$7f then begin - result := result and $7F; - {$else} - if p^>$7f then begin - result := PtrUInt(p^) and $7F; - {$endif} - n := 0; - inc(p); - repeat - c := p^; - inc(n,7); - if c<=$7f then - break; - result := result or (QWord(c and $7f) shl n); - inc(p); - until false; - result := result or (QWord(c) shl n); - end{$ifndef CPU64} else - result := p^{$endif}; - inc(p); - Source := p; -end; - -function FromVarUInt64Safe(Source, SourceMax: PByte; out Value: QWord): PByte; -var c,n: PtrUInt; -begin - result := nil; // error - if PAnsiChar(Source)>=PAnsiChar(SourceMax) then exit; - c := Source^; - inc(Source); - if c>$7f then begin - Value := c and $7F; - n := 7; - repeat - if PAnsiChar(Source)>=PAnsiChar(SourceMax) then - exit; - c := Source^; - inc(Source); - if c<=$7f then - break; - c := c and $7f; - Value := Value or (QWord(c) shl n); - inc(n,7); - until false; - Value := Value or (QWord(c) shl n); - end else - Value := c; - result := Source; // safely decoded -end; - -function FromVarUInt64(var Source: PByte; SourceMax: PByte; out Value: QWord): boolean; -begin - if SourceMax=nil then begin - Value := FromVarUInt64(Source); - result := true; - end else begin - Source := FromVarUInt64Safe(Source,SourceMax,Value); - result := Source<>nil; - end; -end; - -function FromVarInt64(var Source: PByte): Int64; -var c,n: PtrUInt; -begin // 0=0,1=1,2=-1,3=2,4=-2... - {$ifdef CPU64} - result := Source^; - if result>$7f then begin - result := result and $7F; - n := 0; - inc(Source); - repeat - c := Source^; - inc(n,7); - if c<=$7f then - break; - result := result or (Int64(c and $7f) shl n); - inc(Source); - until false; - result := result or (Int64(c) shl n); - end; - if result and 1<>0 then - // 1->1, 3->2.. - result := result shr 1+1 else - // 0->0, 2->-1, 4->-2.. - result := -(result shr 1); - {$else} - c := Source^; - if c>$7f then begin - result := c and $7F; - n := 0; - inc(Source); - repeat - c := Source^; - inc(n,7); - if c<=$7f then - break; - result := result or (Int64(c and $7f) shl n); - inc(Source); - until false; - result := result or (Int64(c) shl n); - if PCardinal(@result)^ and 1<>0 then - // 1->1, 3->2.. - result := result shr 1+1 else - // 0->0, 2->-1, 4->-2.. - result := -(result shr 1); - end else begin - if c=0 then - result := 0 else - if c and 1=0 then - // 0->0, 2->-1, 4->-2.. - result := -Int64(c shr 1) else - // 1->1, 3->2.. - result := (c shr 1)+1; - end; - {$endif} - inc(Source); -end; - -function FromVarInt64Value(Source: PByte): Int64; -{$ifdef DELPHI5OROLDER} -begin // try to circumvent Internal Error C1093 on Delphi 5 :( - result := FromVarInt64(Source); -end; -{$else} -var c,n: PtrUInt; -begin // 0=0,1=1,2=-1,3=2,4=-2... - c := Source^; - if c>$7f then begin - result := c and $7F; - n := 0; - inc(Source); - repeat - c := Source^; - inc(n,7); - if c<=$7f then - break; - result := result or (Int64(c and $7f) shl n); - inc(Source); - until false; - result := result or (Int64(c) shl n); - if {$ifdef CPU64}result{$else}PCardinal(@result)^{$endif} and 1<>0 then - // 1->1, 3->2.. - result := result shr 1+1 else - // 0->0, 2->-1, 4->-2.. - result := -Int64(result shr 1); - end else - if c=0 then - result := 0 else - if c and 1=0 then - // 0->0, 2->-1, 4->-2.. - result := -Int64(c shr 1) else - // 1->1, 3->2.. - result := (c shr 1)+1; -end; -{$endif DELPHI5OROLDER} - -function GotoNextVarInt(Source: PByte): pointer; -begin - if Source<>nil then begin - if Source^>$7f then - repeat - inc(Source) - until Source^<=$7f; - inc(Source); - end; - result := Source; -end; - -function ToVarString(const Value: RawUTF8; Dest: PByte): PByte; -var Len: integer; -begin - Len := Length(Value); - Dest := ToVarUInt32(Len,Dest); - if Len>0 then begin - MoveFast(pointer(Value)^,Dest^,Len); - result := pointer(PAnsiChar(Dest)+Len); - end else - result := Dest; -end; - -function GotoNextVarString(Source: PByte): pointer; -begin - result := Pointer(PtrUInt(Source)+FromVarUInt32(Source)); -end; - -function FromVarString(var Source: PByte): RawUTF8; -var len: PtrUInt; -begin - len := FromVarUInt32(Source); - FastSetStringCP(Result,Source,len,CP_UTF8); - inc(Source,len); -end; - -function FromVarString(var Source: PByte; SourceMax: PByte): RawUTF8; -var len: cardinal; -begin - Source := FromVarUInt32Safe(Source,SourceMax,len); - if (Source=nil) or (PAnsiChar(Source)+len>PAnsiChar(SourceMax)) then - len := 0; - FastSetStringCP(Result,Source,len,CP_UTF8); - inc(Source,len); -end; - -procedure FromVarString(var Source: PByte; var Value: TSynTempBuffer); -var len: integer; -begin - len := FromVarUInt32(Source); - Value.Init(Source,len); - PByteArray(Value.buf)[len] := 0; // include trailing #0 - inc(Source,len); -end; - -function FromVarString(var Source: PByte; SourceMax: PByte; - var Value: TSynTempBuffer): boolean; -var len: cardinal; -begin - if SourceMax=nil then - len := FromVarUInt32(Source) else begin - Source := FromVarUInt32Safe(Source,SourceMax,len); - if (Source=nil) or (PAnsiChar(Source)+len>PAnsiChar(SourceMax)) then begin - result := false; - exit; - end; - end; - Value.Init(Source,len); - PByteArray(Value.buf)[len] := 0; // include trailing #0 - inc(Source,len); - result := true; -end; - -procedure FromVarString(var Source: PByte; var Value: RawByteString; - CodePage: integer); -var Len: PtrUInt; -begin - Len := FromVarUInt32(Source); - FastSetStringCP(Value,Source,Len,CodePage); - inc(Source,Len); -end; - -function FromVarString(var Source: PByte; SourceMax: PByte; - var Value: RawByteString; CodePage: integer): boolean; -var len: cardinal; -begin - if SourceMax=nil then - len := FromVarUInt32(Source) else begin - Source := FromVarUInt32Safe(Source,SourceMax,len); - if (Source=nil) or (PAnsiChar(Source)+len>PAnsiChar(SourceMax)) then begin - result := false; - exit; - end; - end; - FastSetStringCP(Value,Source,len,CodePage); - inc(Source,len); - result := true; -end; - -function FromVarBlob(Data: PByte): TValueResult; -begin - Result.Len := FromVarUInt32(Data); - Result.Ptr := pointer(Data); -end; - - -{ ************ low-level RTTI types and conversion routines } - -{$ifdef FPC} - -{$ifdef FPC_OLDRTTI} -function OldRTTIFirstManagedField(info: PTypeInfo): PFieldInfo; -var fieldtype: PTypeInfo; - i: integer; -begin - result := @info^.ManagedFields[0]; - for i := 1 to info^.ManagedCount do begin - fieldtype := DeRef(result^.TypeInfo); - if (fieldtype<>nil) and (fieldtype^.Kind in tkManagedTypes) then - exit; - inc(result); - end; - result := nil; -end; - -function OldRTTIManagedSize(typeInfo: Pointer): SizeInt; inline; -begin - case PTypeKind(typeInfo)^ of // match tkManagedTypes - tkLString,tkLStringOld,tkWString,tkUString, tkInterface,tkDynarray: - result := SizeOf(Pointer); - {$ifndef NOVARIANTS} - tkVariant: result := SizeOf(TVarData); - {$endif} - tkArray: with GetTypeInfo(typeInfo)^ do - result := arraySize{$ifdef VER2_6}*elCount{$endif}; - tkObject,tkRecord: result := GetTypeInfo(typeInfo)^.recSize; - else raise ESynException.CreateUTF8('OldRTTIManagedSize unhandled % (%)', - [ToText(PTypeKind(typeInfo)^)^,PByte(typeInfo)^]); - end; -end; - -procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); -begin // external name 'FPC_COPY' does not work as we need - FPCFinalize(@Dest,TypeInfo); - Move(Source,Dest,OldRTTIManagedSize(TypeInfo)); - FPCRecordAddRef(Dest,TypeInfo); -end; -{$else} -procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); -begin - FPCRecordCopy(Source,Dest,TypeInfo); -end; -{$endif FPC_OLDRTTI} - -procedure RecordClear(var Dest; TypeInfo: pointer); -begin - FPCFinalize(@Dest,TypeInfo); -end; - -{$else FPC} - -procedure CopyArray(dest, source, typeInfo: Pointer; cnt: PtrUInt); -asm -{$ifdef CPU64} - .noframe - jmp System.@CopyArray -{$else} push dword ptr[EBP + 8] - call System.@CopyArray // RTL is fast enough for this -{$endif} -end; - -procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer); -asm - {$ifdef CPU64} - .noframe - {$endif} - jmp System.@DynArrayClear -end; - -procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: PtrUInt); -asm - {$ifdef CPU64} - .noframe - {$endif} - jmp System.@FinalizeArray -end; - -procedure _Finalize(Data: Pointer; TypeInfo: Pointer); -asm -{$ifdef CPU64} - .noframe - mov r8, 1 // rcx=p rdx=typeInfo r8=ElemCount - jmp System.@FinalizeArray -{$else} // much faster than FinalizeArray(Data,TypeInfo,1) - movzx ecx, byte ptr[edx] // eax=ptr edx=typeinfo ecx=datatype - sub cl, tkLString - {$ifdef UNICODE} - cmp cl, tkUString - tkLString + 1 - {$else} - cmp cl, tkDynArray - tkLString + 1 - {$endif} - jnb @@err - jmp dword ptr[@@Tab + ecx * 4] - nop - nop // for @@Tab alignment -@@Tab: dd System.@LStrClr -{$IFDEF LINUX} // under Linux, WideString are refcounted as AnsiString - dd System.@LStrClr -{$else} dd System.@WStrClr -{$endif LINUX} -{$ifdef LVCL} - dd @@err -{$else} dd System.@VarClr -{$endif LVCL} - dd @@ARRAY - dd RecordClear - dd System.@IntfClear - dd @@err - dd System.@DynArrayClear - {$ifdef UNICODE} - dd System.@UStrClr - {$endif} -@@err: mov al, reInvalidPtr - {$ifdef DELPHI5OROLDER} - jmp System.@RunError - {$else} - jmp System.Error - {$endif} -@@array:movzx ecx, [edx].TTypeInfo.NameLen - add ecx, edx - mov edx, dword ptr[ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^ - mov ecx, [ecx].TTypeInfo.ManagedCount - mov edx, [edx] - jmp System.@FinalizeArray -{$endif CPU64} -end; -{$endif FPC} - -procedure RecordZero(var Dest; TypeInfo: pointer); -var info: PTypeInfo; -begin - info := GetTypeInfo(TypeInfo,tkRecordKinds); - if info<>nil then begin // record/object only - RecordClear(Dest,TypeInfo); - FillCharFast(Dest,info^.recSize,0); - end; -end; - -procedure RawUTF8DynArrayClear(var Value: TRawUTF8DynArray); -begin - FastDynArrayClear(@Value,TypeInfo(RawUTF8)); -end; - -function ArrayItemType(var info: PTypeInfo; out len: integer): PTypeInfo; - {$ifdef HASINLINE}inline;{$endif} -begin - {$ifdef HASALIGNTYPEDATA} // inlined info := GetTypeInfo(info) - info := FPCTypeInfoOverName(info); - {$else} - info := @PAnsiChar(info)[info^.NameLen]; - {$endif} - result := nil; - if (info=nil) or (info^.dimCount<>1) then begin - len := 0; - info := nil; // supports single dimension static array only - end else begin - len := info^.arraySize{$ifdef VER2_6}*info^.elCount{$endif}; - {$ifdef HASDIRECTTYPEINFO} // inlined result := DeRef(info^.arrayType) - result := info^.arrayType; - {$else} - if info^.arrayType=nil then - exit; - result := info^.arrayType^; - {$endif} - {$ifdef FPC} - if (result<>nil) and not(result^.Kind in tkManagedTypes) then - result := nil; // as with Delphi - {$endif} - end; -end; - -function ManagedTypeCompare(A,B: PAnsiChar; info: PTypeInfo): integer; -// returns -1 if info was not handled, 0 if A^<>B^, or SizeOf(A^) if A^=B^ -var i,arraysize: integer; - itemtype: PTypeInfo; - {$ifndef DELPHI5OROLDER} // do not know why this compiler does not like it - DynA, DynB: TDynArray; - {$endif} -begin // info is expected to come from a DeRef() if retrieved from RTTI - result := 0; // A^<>B^ - case info^.Kind of // should match tkManagedTypes - tkLString{$ifdef FPC},tkLStringOld{$endif}: - if PRawByteString(A)^=PRawByteString(B)^ then - result := SizeOf(pointer); - tkWString: - if PWideString(A)^=PWideString(B)^ then - result := SizeOf(pointer); - {$ifdef HASVARUSTRING} - tkUString: - if PUnicodeString(A)^=PUnicodeString(B)^ then - result := SizeOf(pointer); - {$endif} - tkRecord{$ifdef FPC},tkObject{$endif}: - if not RecordEquals(A^,B^,info,@result) then - result := 0; // A^<>B^ - {$ifndef NOVARIANTS} - tkVariant: // slightly more optimized than PVariant(A)^=PVariant(B)^ - if SortDynArrayVariantComp(PVarData(A)^,PVarData(B)^,false)=0 then - result := SizeOf(variant); - {$endif} - {$ifndef DELPHI5OROLDER} - tkDynArray: begin - DynA.Init(info,A^); - DynB.Init(info,B^); - if DynA.Equals(DynB) then - result := SizeOf(pointer); - end; - {$endif} - tkInterface: - if PPointer(A)^=PPointer(B)^ then - result := SizeOf(pointer); - tkArray: begin - itemtype := ArrayItemType(info,arraysize); - if info=nil then - result := -1 else - if itemtype=nil then - if CompareMemFixed(A,B,arraysize) then - result := arraysize else - result := 0 else begin - for i := 1 to info^.elCount do begin // only compare managed fields - result := ManagedTypeCompare(A,B,itemtype); - if result<=0 then - exit; // invalid (-1) or not equals (0) - inc(A,result); - inc(B,result); - end; - result := arraysize; - end; - end; - else - result := -1; // Unhandled field - end; -end; - -function ManagedTypeSaveLength(data: PAnsiChar; info: PTypeInfo; - out len: integer): integer; -// returns 0 on error, or saved bytes + len=data^ length -var DynArray: TDynArray; - itemtype: PTypeInfo; - itemsize,size,i: integer; - P: PPtrUInt absolute data; -begin // info is expected to come from a DeRef() if retrieved from RTTI - case info^.Kind of // should match tkManagedTypes - tkLString{$ifdef FPC},tkLStringOld{$endif}: begin - len := SizeOf(pointer); - if P^=0 then - result := 1 else - result := ToVarUInt32LengthWithData(PStrLen(P^-_STRLEN)^); - end; - tkWString: begin // PStrRec doesn't match on Widestring for FPC - len := SizeOf(pointer); - result := ToVarUInt32LengthWithData(length(PWideString(P)^)*2); - end; - {$ifdef HASVARUSTRING} - tkUString: begin - len := SizeOf(pointer); - if P^=0 then - result := 1 else - result := ToVarUInt32LengthWithData(PStrLen(P^-_STRLEN)^*2); - end; - {$endif} - tkRecord{$ifdef FPC},tkObject{$endif}: - result := RecordSaveLength(data^,info,@len); - tkArray: begin - itemtype := ArrayItemType(info,len); - result := 0; - if info<>nil then - if itemtype=nil then - result := len else - for i := 1 to info^.elCount do begin - size := ManagedTypeSaveLength(data,itemtype,itemsize); - if size=0 then begin - result := 0; - exit; - end; - inc(result,size); - inc(data,itemsize); - end; - end; - {$ifndef NOVARIANTS} - tkVariant: begin - len := SizeOf(variant); - result := VariantSaveLength(PVariant(data)^); - end; - {$endif} - tkDynArray: begin - DynArray.Init(info,data^); - len := SizeOf(pointer); - result := DynArray.SaveToLength; - end; - tkInterface: begin - len := SizeOf(Int64); // consume 64-bit even on CPU32 - result := SizeOf(PtrUInt); - end; - else - result := 0; // invalid/unhandled record content - end; -end; - -function ManagedTypeSave(data, dest: PAnsiChar; info: PTypeInfo; - out len: integer): PAnsiChar; -// returns nil on error, or final dest + len=data^ length -var DynArray: TDynArray; - itemtype: PTypeInfo; - itemsize,i: integer; - P: PPtrUInt absolute data; -begin // info is expected to come from a DeRef() if retrieved from RTTI - case info^.Kind of - tkLString {$ifdef HASVARUSTRING},tkUString{$endif} {$ifdef FPC},tkLStringOld{$endif}: begin - if P^=0 then begin - dest^ := #0; - result := dest+1; - end else begin - itemsize := PStrLen(P^-_STRLEN)^; - {$ifdef HASVARUSTRING} // UnicodeString length in WideChars - if info^.Kind=tkUString then - itemsize := itemsize*2; - {$endif} - result := pointer(ToVarUInt32(itemsize,pointer(dest))); - MoveFast(pointer(P^)^,result^,itemsize); - inc(result,itemsize); - end; - len := SizeOf(PtrUInt); // size of tkLString/tkUString in record - end; - tkWString: begin - itemsize := length(PWideString(P)^)*2; // PStrRec doesn't match on FPC - result := pointer(ToVarUInt32(itemsize,pointer(dest))); - MoveFast(pointer(P^)^,result^,itemsize); - inc(result,itemsize); - len := SizeOf(PtrUInt); - end; - tkRecord{$ifdef FPC},tkObject{$endif}: - result := RecordSave(data^,dest,info,len); - tkArray: begin - itemtype := ArrayItemType(info,len); - if info=nil then - result := nil else - if itemtype=nil then begin - MoveSmall(data,dest,len); - result := dest+len; - end else begin - for i := 1 to info^.elCount do begin - dest := ManagedTypeSave(data,dest,itemtype,itemsize); - if dest=nil then - break; // invalid/unhandled content - inc(data,itemsize) - end; - result := dest; - end; - end; - {$ifndef NOVARIANTS} - tkVariant: begin - result := VariantSave(PVariant(data)^,dest); - len := SizeOf(Variant); // size of tkVariant in record - end; - {$endif} - tkDynArray: begin - DynArray.Init(info,data^); - result := DynArray.SaveTo(dest); - len := SizeOf(PtrUInt); // size of tkDynArray in record - end; - {$ifndef DELPHI5OROLDER} - tkInterface: begin - PIInterface(dest)^ := PIInterface(data)^; // with proper refcount - result := dest+SizeOf(Int64); // consume 64-bit even on CPU32 - len := SizeOf(PtrUInt); - end; - {$endif} - else - result := nil; // invalid/unhandled record content - end; -end; - -function ManagedTypeLoad(data: PAnsiChar; var source: PAnsiChar; - info: PTypeInfo; sourceMax: PAnsiChar): integer; -// returns source=nil on error, or final source + result=data^ length -var DynArray: TDynArray; - itemtype: PTypeInfo; - itemsize: cardinal; - i: PtrInt; -begin // info is expected to come from a DeRef() if retrieved from RTTI - result := SizeOf(PtrUInt); // size of most items - if info^.Kind in [tkLString{$ifdef FPC},tkLStringOld{$endif},tkWString - {$ifdef HASVARUSTRING},tkUString{$endif}] then - if sourceMax<>nil then begin - source := pointer(FromVarUInt32Safe(PByte(source),PByte(sourceMax),itemsize)); - if source=nil then - exit; - if source+itemsize>sourceMax then begin - source := nil; - exit; // avoid buffer overflow - end; - end else - itemsize := FromVarUInt32(PByte(source)); // in source buffer bytes - case info^.Kind of - tkLString{$ifdef FPC}, tkLStringOld{$endif}: begin - {$ifdef HASCODEPAGE} - FastSetStringCP(data^,source,itemsize,LStringCodePage(info)); - {$else} - SetString(PRawUTF8(data)^,source,itemsize); - {$endif HASCODEPAGE} - inc(source,itemsize); - end; - tkWString: begin - SetString(PWideString(data)^,PWideChar(source),itemsize shr 1); - inc(source,itemsize); - end; - {$ifdef HASVARUSTRING} - tkUString: begin - SetString(PUnicodeString(data)^,PWideChar(source),itemsize shr 1); - inc(source,itemsize); - end; - {$endif} - tkRecord{$ifdef FPC},tkObject{$endif}: - source := RecordLoad(data^,source,info,@result,sourceMax); - tkArray: begin - itemtype := ArrayItemType(info,result); - if info=nil then - source := nil else - if itemtype=nil then - if (sourceMax<>nil) and (source+result>sourceMax) then - source := nil else begin - MoveSmall(source,data,result); - inc(source,result); - end else - for i := 1 to info^.elCount do begin - inc(data,ManagedTypeLoad(data,source,itemtype,sourceMax)); - if source=nil then - exit; - end; - end; - {$ifndef NOVARIANTS} - tkVariant: begin - source := VariantLoad(PVariant(data)^,source,@JSON_OPTIONS[true]); - result := SizeOf(Variant); // size of tkVariant in record - end; - {$endif NOVARIANTS} - tkDynArray: begin - DynArray.Init(info,data^); - source := DynArray.LoadFrom(source,nil,{nohash=}true,sourceMax); - end; - {$ifndef DELPHI5OROLDER} - tkInterface: begin - if (sourceMax<>nil) and (source+SizeOf(Int64)>sourceMax) then begin - source := nil; - exit; - end; - PIInterface(data)^ := PIInterface(source)^; // with proper refcount - inc(source,SizeOf(Int64)); // consume 64-bit even on CPU32 - end; - {$endif DELPHI5OROLDER} - else - source := nil; // notify error for unexpected input type - end; -end; - -function GetManagedFields(info: PTypeInfo; out firstfield: PFieldInfo): integer; -{$ifdef HASINLINE}inline;{$endif} -{$ifdef FPC_NEWRTTI} -var - recInitData: PFPCRecInitData; // low-level type redirected from SynFPCTypInfo - aPointer:pointer; -begin - if Assigned(info^.RecInitInfo) then - recInitData := PFPCRecInitData(AlignTypeDataClean(PTypeInfo(info^.RecInitInfo+2+PByte(info^.RecInitInfo+1)^))) - else begin - aPointer:=@info^.RecInitInfo; - {$ifdef FPC_PROVIDE_ATTR_TABLE} - dec(PByte(aPointer),SizeOf(Pointer)); - {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} - {$ifdef CPUARM} - dec(PByte(aPointer),SizeOf(Pointer)); - {$endif CPUARM} - {$endif} - {$endif} - recInitData := PFPCRecInitData(aPointer); - end; - firstfield := PFieldInfo(PtrUInt(@recInitData^.ManagedFieldCount)); - inc(PByte(firstfield),SizeOf(recInitData^.ManagedFieldCount)); - firstfield := AlignPTypeInfo(firstfield); - result := recInitData^.ManagedFieldCount; -{$else} -begin - firstfield := @info^.ManagedFields[0]; - result := info^.ManagedCount; -{$endif FPC_NEWRTTI} -end; - -function RecordEquals(const RecA, RecB; TypeInfo: pointer; - PRecSize: PInteger): boolean; -var info,fieldinfo: PTypeInfo; - F, offset: PtrInt; - field: PFieldInfo; - A, B: PAnsiChar; -begin - A := @RecA; - B := @RecB; - result := false; - info := GetTypeInfo(TypeInfo,tkRecordKinds); - if info=nil then - exit; // raise Exception.CreateUTF8('% is not a record',[Typ^.Name]); - if PRecSize<>nil then - PRecSize^ := info^.recSize; - if A=B then begin // both nil or same pointer - result := true; - exit; - end; - offset := 0; - for F := 1 to GetManagedFields(info,field) do begin - fieldinfo := DeRef(field^.TypeInfo); - {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields - if not (fieldinfo^.Kind in tkManagedTypes) then begin - inc(field); - continue; // as with Delphi - end; - {$endif} - offset := integer(field^.Offset)-offset; - if offset<>0 then begin - if not CompareMemFixed(A,B,offset) then - exit; // binary block not equal - inc(A,offset); - inc(B,offset); - end; - offset := ManagedTypeCompare(A,B,fieldinfo); - if offset<=0 then - if offset=0 then // A^<>B^ - exit else // Diff=-1 for unexpected type - raise ESynException.CreateUTF8('RecordEquals: unexpected %', - [ToText(fieldinfo^.Kind)^]); - inc(A,offset); - inc(B,offset); - inc(offset,field^.Offset); - inc(field); - end; - if CompareMemFixed(A,B,integer(info^.recSize)-offset) then - result := true; -end; - -function RecordSaveLength(const Rec; TypeInfo: pointer; Len: PInteger): integer; -var info,fieldinfo: PTypeInfo; - F, recsize,saved: integer; - field: PFieldInfo; - R: PAnsiChar; -begin - R := @Rec; - info := GetTypeInfo(TypeInfo,tkRecordKinds); - if (R=nil) or (info=nil) then begin - result := 0; // should have been checked before - exit; - end; - result := info^.recSize; - if Len<>nil then - Len^ := result; - for F := 1 to GetManagedFields(info,field) do begin - fieldinfo := DeRef(field^.TypeInfo); - {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields! :) - if not (fieldinfo^.Kind in tkManagedTypes) then begin - inc(field); - continue; // as with Delphi - end; - {$endif}; - saved := ManagedTypeSaveLength(R+field^.Offset,fieldinfo,recsize); - if saved=0 then begin - result := 0; // invalid type - exit; - end; - inc(result,saved-recsize); // extract recsize from info^.recSize - inc(field); - end; -end; - -function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer; - out Len: integer): PAnsiChar; -var info,fieldinfo: PTypeInfo; - F, offset: integer; - field: PFieldInfo; - R: PAnsiChar; -begin - R := @Rec; - info := GetTypeInfo(TypeInfo,tkRecordKinds); - if (R=nil) or (info=nil) then begin - result := nil; // should have been checked before - exit; - end; - Len := info^.recSize; - offset := 0; - for F := 1 to GetManagedFields(info,field) do begin - {$ifdef HASDIRECTTYPEINFO} // inlined DeRef() - fieldinfo := field^.TypeInfo; - {$else} - {$ifdef CPUINTEL} - fieldinfo := PPointer(field^.TypeInfo)^; - {$else} - fieldinfo := DeRef(field^.TypeInfo); - {$endif} - {$endif} - {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields! :) - if not (fieldinfo^.Kind in tkManagedTypes) then begin - inc(field); - continue; // as with Delphi - end; - {$endif}; - offset := integer(field^.Offset)-offset; - if offset>0 then begin - MoveFast(R^,Dest^,offset); - inc(R,offset); - inc(Dest,offset); - end; - Dest := ManagedTypeSave(R,Dest,fieldinfo,offset); - if Dest=nil then begin - result := nil; // invalid/unhandled record content - exit; - end; - inc(R,offset); - inc(offset,field.Offset); - inc(field); - end; - offset := integer(info^.recSize)-offset; - if offset<0 then - raise ESynException.Create('RecordSave offset<0') else - if offset<>0 then begin - MoveFast(R^,Dest^,offset); - result := Dest+offset; - end else - result := Dest; -end; - -function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: pointer): PAnsiChar; -var dummylen: integer; -begin - result := RecordSave(Rec,Dest,TypeInfo,dummylen); -end; - -function RecordSave(const Rec; TypeInfo: pointer): RawByteString; -var destlen,dummylen: integer; - dest: PAnsiChar; -begin - destlen := RecordSaveLength(Rec,TypeInfo); - SetString(result,nil,destlen); - if destlen<>0 then begin - dest := RecordSave(Rec,pointer(result),TypeInfo,dummylen); - if (dest=nil) or (dest-pointer(result)<>destlen) then // paranoid check - raise ESynException.CreateUTF8('RecordSave % len=%<>%', - [TypeInfoToShortString(TypeInfo)^,dest-pointer(result),destlen]); - end; -end; - -function RecordSaveBytes(const Rec; TypeInfo: pointer): TBytes; -var destlen,dummylen: integer; - dest: PAnsiChar; -begin - destlen := RecordSaveLength(Rec,TypeInfo); - result := nil; // don't reallocate TBytes data from a previous call - SetLength(result,destlen); - if destlen<>0 then begin - dest := RecordSave(Rec,pointer(result),TypeInfo,dummylen); - if (dest=nil) or (dest-pointer(result)<>destlen) then // paranoid check - raise ESynException.CreateUTF8('RecordSave % len=%<>%', - [TypeInfoToShortString(TypeInfo)^,dest-pointer(result),destlen]); - end; -end; - -procedure RecordSave(const Rec; var Dest: TSynTempBuffer; TypeInfo: pointer); -var dummylen: integer; - P: PAnsiChar; -begin - Dest.Init(RecordSaveLength(Rec,TypeInfo)); - P := RecordSave(Rec,Dest.buf,TypeInfo,dummylen); - if (P=nil) or (P-Dest.buf<>Dest.len) then begin // paranoid check - Dest.Done; - raise ESynException.CreateUTF8('RecordSave TSynTempBuffer %',[TypeInfoToShortString(TypeInfo)^]); - end; -end; - -function RecordSaveBase64(const Rec; TypeInfo: pointer; UriCompatible: boolean): RawUTF8; -var len,dummy: integer; - temp: TSynTempBuffer; -begin - result := ''; - len := RecordSaveLength(Rec,TypeInfo); - if len=0 then - exit; - temp.Init(len+4); - RecordSave(Rec,PAnsiChar(temp.buf)+4,TypeInfo,dummy); - PCardinal(temp.buf)^ := crc32c(0,PAnsiChar(temp.buf)+4,len); - if UriCompatible then - result := BinToBase64uri(temp.buf,temp.len) else - result := BinToBase64(temp.buf,temp.len); - temp.Done; -end; - -function RecordLoadBase64(Source: PAnsiChar; Len: PtrInt; var Rec; - TypeInfo: pointer; UriCompatible: boolean): boolean; -var temp: TSynTempBuffer; -begin - result := false; - if Len<=6 then - exit; - if UriCompatible then - result := Base64uriToBin(Source,Len,temp) else - result := Base64ToBin(Source,Len,temp); - result := result and (temp.len>=4) and - (crc32c(0,PAnsiChar(temp.buf)+4,temp.len-4)=PCardinal(temp.buf)^) and - (RecordLoad(Rec,PAnsiChar(temp.buf)+4,TypeInfo,nil,PAnsiChar(temp.buf)+temp.len)<>nil); - temp.Done; -end; - -function RecordLoad(var Rec; Source: PAnsiChar; TypeInfo: pointer; - Len: PInteger; SourceMax: PAnsiChar): PAnsiChar; -var info,fieldinfo: PTypeInfo; - n, F: integer; - offset: PtrInt; - field: PFieldInfo; - R: PAnsiChar; -begin - result := nil; // indicates error - R := @Rec; - info := GetTypeInfo(TypeInfo,tkRecordKinds); - if (R=nil) or (info=nil) then // should have been checked before - exit; - if Len<>nil then - Len^ := info^.recSize; - n := GetManagedFields(info,field); - if Source=nil then begin // inline RecordClear() function - for F := 1 to n do begin - {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(R+field^.Offset,Deref(field^.TypeInfo)); - inc(field); - end; - exit; - end; - offset := 0; - for F := 1 to n do begin - {$ifdef HASDIRECTTYPEINFO} // inlined DeRef() - fieldinfo := field^.TypeInfo; - {$else} - {$ifdef CPUINTEL} - fieldinfo := PPointer(field^.TypeInfo)^; - {$else} - fieldinfo := DeRef(field^.TypeInfo); - {$endif} - {$endif} - {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields! :) - if not (fieldinfo^.Kind in tkManagedTypes) then begin - inc(field); - continue; // as with Delphi - end; - {$endif}; - offset := integer(field^.Offset)-offset; - if offset<>0 then begin - if (SourceMax<>nil) and (Source+offset>SourceMax) then - exit; - MoveFast(Source^,R^,offset); - inc(Source,offset); - inc(R,offset); - end; - offset := ManagedTypeLoad(R,Source,fieldinfo,SourceMax); - if Source=nil then - exit; // error at loading - inc(R,offset); - inc(offset,field^.Offset); - inc(field); - end; - offset := integer(info^.recSize)-offset; - if offset<0 then - raise ESynException.Create('RecordLoad offset<0') else - if offset<>0 then begin - if (SourceMax<>nil) and (Source+offset>SourceMax) then - exit; - MoveFast(Source^,R^,offset); - result := Source+offset; - end else - result := Source; -end; - -function RecordLoad(var Res; const Source: RawByteString; TypeInfo: pointer): boolean; -var P: PAnsiChar; -begin - P := pointer(Source); - P := RecordLoad(Res,P,TypeInfo,nil,P+length(Source)); - result := (P<>nil) and (P-pointer(Source)=length(Source)); -end; - -{$ifndef FPC} - - {$ifdef USEPACKAGES} - {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} - {$endif} - {$ifdef DELPHI5OROLDER} - {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} - {$endif} - {$ifdef PUREPASCAL} - {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} - {$endif} - {$ifndef DOPATCHTRTL} - {$define EXPECTSDELPHIRTLRECORDCOPYCLEAR} - {$endif} - -{$ifdef EXPECTSDELPHIRTLRECORDCOPYCLEAR} -procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); -asm // same params than _CopyRecord{ dest, source, typeInfo: Pointer } - {$ifdef CPU64} - .noframe - {$endif} - jmp System.@CopyRecord -end; - -procedure RecordClear(var Dest; TypeInfo: pointer); -asm - {$ifdef CPU64} - .noframe - {$endif} - jmp System.@FinalizeRecord -end; -{$endif EXPECTSDELPHIRTLRECORDCOPYCLEAR} - - -{$ifdef DOPATCHTRTL} - -function SystemRecordCopyAddress: Pointer; -asm - {$ifdef CPU64} - mov rax,offset System.@CopyRecord - {$else} - mov eax,offset System.@CopyRecord - {$endif} -end; - -function SystemFinalizeRecordAddress: Pointer; -asm - {$ifdef CPU64} - mov rax,offset System.@FinalizeRecord - {$else} - mov eax,offset System.@FinalizeRecord - {$endif} -end; - -function SystemInitializeRecordAddress: Pointer; -asm - {$ifdef CPU64} - mov rax,offset System.@InitializeRecord - {$else} - mov eax,offset System.@InitializeRecord - {$endif} -end; - -{$ifdef CPUX86} -procedure _InitializeRecord(P: Pointer; TypeInfo: Pointer); -asm // faster version by AB - { -> EAX pointer to record to be finalized } - { EDX pointer to type info } -(* // this TObject.Create-like initialization sounds slower - movzx ecx,byte ptr [edx].TTypeInfo.NameLen - mov edx,[edx+ecx].TTypeInfo.Size - xor ecx,ecx - jmp dword ptr [FillCharFast] *) - movzx ecx, byte ptr[edx].TTypeInfo.NameLen - push ebx - mov ebx, eax - push esi - push edi - mov edi, [edx + ecx].TTypeInfo.ManagedCount - lea esi, [edx + ecx].TTypeInfo.ManagedFields - test edi, edi - jz @end -@loop: mov edx, [esi].TFieldInfo.TypeInfo - mov eax, [esi].TFieldInfo.&Offset - mov edx, [edx] - add esi, 8 - movzx ecx, [edx].TTypeInfo.Kind - add eax, ebx // eax=data to be initialized - jmp dword ptr[@tab + ecx * 4 - tkLString * 4] -@tab: dd @ptr, @ptr, @varrec, @array, @array, @ptr, @ptr, @ptr, @ptr -@ptr: mov dword ptr[eax], 0 // pointer initialization - dec edi - jg @loop -@end: pop edi - pop esi - pop ebx - ret -@varrec:xor ecx, ecx - mov dword ptr[eax], ecx - mov dword ptr[eax + 4], ecx - mov dword ptr[eax + 8], ecx - mov dword ptr[eax + 12], ecx - dec edi - jg @loop - pop edi - pop esi - pop ebx - ret -@array: mov ecx, 1 // here eax=data edx=typeinfo - call System.@InitializeArray - dec edi - jg @loop - pop edi - pop esi - pop ebx -end; - -{$ifndef UNICODE} // TMonitor.Destroy is not available ! -> apply to D2007 only -procedure TObjectCleanupInstance; -asm // faster version by AB - push ebx - mov ebx, eax -@loop: mov ebx, [ebx] // handle three VMT levels per iteration - mov edx, [ebx].vmtInitTable - mov ebx, [ebx].vmtParent - test edx, edx - jnz @clr - test ebx, ebx - jz @end - mov ebx, [ebx] - mov edx, [ebx].vmtInitTable - mov ebx, [ebx].vmtParent - test edx, edx - jnz @clr - test ebx, ebx - jz @end - mov ebx, [ebx] - mov edx, [ebx].vmtInitTable - mov ebx, [ebx].vmtParent - test edx, edx - jnz @clr - test ebx, ebx - jnz @loop -@end: pop ebx - ret -@clr: push offset @loop // TObject has no vmtInitTable -> safe - jmp RecordClear // eax=self edx=typeinfo -end; -{$endif} - -procedure RecordClear(var Dest; TypeInfo: pointer); -asm // faster version by AB (direct call to finalization procedures) - { -> EAX pointer to record to be finalized } - { EDX pointer to type info } - { <- EAX pointer to record to be finalized } - movzx ecx, byte ptr[edx].TTypeInfo.NameLen - push ebx - mov ebx, eax - push esi - push edi - mov edi, [edx + ecx].TTypeInfo.ManagedCount - lea esi, [edx + ecx].TTypeInfo.ManagedFields - test edi, edi - jz @end -@loop: mov edx, [esi].TFieldInfo.TypeInfo - mov eax, [esi].TFieldInfo.&Offset - mov edx, [edx] - add esi, 8 - movzx ecx, [edx].TTypeInfo.Kind - add eax, ebx // eax=data to be initialized - sub cl, tkLString -{$ifdef UNICODE} - cmp cl, tkUString - tkLString + 1 -{$else} cmp cl, tkDynArray - tkLString + 1 -{$endif} - jnb @err - call dword ptr[@Tab + ecx * 4] - dec edi - jg @loop -@end: mov eax, ebx // keep eax at return (see e.g. TObject.CleanupInstance) - pop edi - pop esi - pop ebx - ret - nop - nop - nop // align @Tab -@Tab: dd System.@LStrClr -{$IFDEF LINUX} // under Linux, WideString are refcounted as AnsiString - dd System.@LStrClr -{$else} dd System.@WStrClr -{$endif} -{$ifdef LVCL} - dd @err -{$else} dd System.@VarClr -{$endif} - dd @array - dd RecordClear - dd System.@IntfClear - dd @err - dd System.@DynArrayClear - {$ifdef UNICODE} - dd System.@UStrClr - {$endif} -@err: mov al, reInvalidPtr - pop edi - pop esi - pop ebx - jmp System.Error -@array: movzx ecx, [edx].TTypeInfo.NameLen - add ecx, edx - mov edx, dword ptr[ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^ - mov ecx, [ecx].TTypeInfo.ManagedCount - mov edx, [edx] - call System.@FinalizeArray - // we made Call @Array -> ret to continue -end; - -procedure RecordCopy(var Dest; const Source; TypeInfo: pointer); -asm // faster version of _CopyRecord{dest, source, typeInfo: Pointer} by AB - { -> EAX pointer to dest } - { EDX pointer to source } - { ECX pointer to typeInfo } - push ebp - push ebx - push esi - push edi - movzx ebx, byte ptr[ecx].TTypeInfo.NameLen - mov esi, edx // esi = source - mov edi, eax // edi = dest - add ebx, ecx // ebx = TFieldTable - xor eax, eax // eax = current offset - mov ebp, [ebx].TTypeInfo.ManagedCount // ebp = TFieldInfo count - mov ecx, [ebx].TTypeInfo.recSize - test ebp, ebp - jz @fullcopy - push ecx // SizeOf(record) on stack - add ebx, offset TTypeInfo.ManagedFields[0] // ebx = first TFieldInfo -@next: mov ecx, [ebx].TFieldInfo.&Offset - mov edx, [ebx].TFieldInfo.TypeInfo - sub ecx, eax - mov edx, [edx] - jle @nomov - add esi, ecx - add edi, ecx - neg ecx -@mov1: mov al, [esi + ecx] // fast copy not destructable data - mov [edi + ecx], al - inc ecx - jnz @mov1 -@nomov: mov eax, edi - movzx ecx, [edx].TTypeInfo.Kind - cmp ecx, tkLString - je @LString - jb @err -{$ifdef UNICODE} - cmp ecx, tkUString - je @UString -{$else} cmp ecx, tkDynArray - je @dynaray -{$endif} ja @err - jmp dword ptr[ecx * 4 + @tab - tkWString * 4] - -@Tab: dd @WString, @variant, @array, @record, @interface, @err -{$ifdef UNICODE} - dd @dynaray -{$endif} -@errv: mov al, reVarInvalidOp - jmp @err2 -@err: mov al, reInvalidPtr -@err2: pop edi - pop esi - pop ebx - pop ebp - jmp System.Error - nop // all functions below have esi=source edi=dest -@array: movzx ecx, byte ptr[edx].TTypeInfo.NameLen - push dword ptr[edx + ecx].TTypeInfo.recSize - push dword ptr[edx + ecx].TTypeInfo.ManagedCount - mov ecx, dword ptr[edx + ecx].TTypeInfo.ManagedFields[0] // Fields[0].TypeInfo^ - mov ecx, [ecx] - mov edx, esi - call System.@CopyArray - pop eax // restore SizeOf(Array) - jmp @finish -@record:movzx ecx, byte ptr[edx].TTypeInfo.NameLen - mov ecx, [edx + ecx].TTypeInfo.recSize - push ecx - mov ecx, edx - mov edx, esi - call RecordCopy - pop eax // restore SizeOf(Record) - jmp @finish - nop - nop - nop -@variant: -{$ifdef NOVARCOPYPROC} - mov edx, esi - call System.@VarCopy -{$else} mov edx, esi - cmp dword ptr[VarCopyProc], 0 - jz @errv - call [VarCopyProc] -{$endif} - mov eax, 16 - jmp @finish -{$ifdef DELPHI6OROLDER} - nop - nop -{$endif} -@interface: - mov edx, [esi] - call System.@IntfCopy - jmp @fin4 - nop - nop - nop -@dynaray: - mov ecx, edx // ecx=TypeInfo - mov edx, [esi] - call System.@DynArrayAsg - jmp @fin4 -@WString: -{$ifndef LINUX} - mov edx, [esi] - call System.@WStrAsg - jmp @fin4 -{$endif} -@LString: - mov edx, [esi] - call System.@LStrAsg -{$ifdef UNICODE} - jmp @fin4 - nop - nop -@UString: - mov edx, [esi] - call System.@UStrAsg -{$endif} -@fin4: mov eax, 4 -@finish: - add esi, eax - add edi, eax - add eax, [ebx].TFieldInfo.&Offset - add ebx, 8 - dec ebp // any other TFieldInfo? - jnz @next - pop ecx // ecx= SizeOf(record) -@fullcopy: - mov edx, edi - sub ecx, eax - mov eax, esi - jle @nomov2 - call dword ptr[MoveFast] -@nomov2: pop edi - pop esi - pop ebx - pop ebp -end; - -{$endif CPUX86} -{$endif DOPATCHTRTL} - -{$ifndef CPUARM} - -function SystemFillCharAddress: Pointer; -asm - {$ifdef CPU64} - mov rax,offset System.@FillChar - {$else} - mov eax,offset System.@FillChar - {$endif} -end; - -{$ifndef CPU64} - -{$ifndef PUREPASCAL} - -procedure FillCharX87; -asm // eax=Dest edx=Count cl=Value - // faster version by John O'Harrow (Code Size = 153 Bytes) - mov ch, cl // copy value into both bytes of cx - cmp edx, 32 - jl @small - mov [eax], cx // fill first 8 bytes - mov [eax + 2], cx - mov [eax + 4], cx - mov [eax + 6], cx - sub edx, 16 - fld qword ptr[eax] - fst qword ptr[eax + edx] // fill last 16 bytes - fst qword ptr[eax + edx + 8] - mov ecx, eax - and ecx, 7 // 8-byte align writes - sub ecx, 8 - sub eax, ecx - add edx, ecx - add eax, edx - neg edx -@loop: fst qword ptr[eax + edx] // fill 16 bytes per loop - fst qword ptr[eax + edx + 8] - add edx, 16 - jl @loop - ffree st(0) - fincstp - ret - nop -@small: test edx, edx - jle @done - mov [eax + edx - 1], cl // fill last byte - and edx, -2 // no. of words to fill - neg edx - lea edx, [@fill + 60 + edx * 2] - jmp edx - nop // align jump destinations - nop -@fill: mov [eax + 28], cx - mov [eax + 26], cx - mov [eax + 24], cx - mov [eax + 22], cx - mov [eax + 20], cx - mov [eax + 18], cx - mov [eax + 16], cx - mov [eax + 14], cx - mov [eax + 12], cx - mov [eax + 10], cx - mov [eax + 8], cx - mov [eax + 6], cx - mov [eax + 4], cx - mov [eax + 2], cx - mov [eax], cx - ret // for 4-bytes @fill alignment -@done: db $f3 // rep ret AMD trick here -end; - -/// faster implementation of Move() for Delphi versions with no FastCode inside -procedure MoveX87; -asm // eax=source edx=dest ecx=count - // original code by John O'Harrow - included since delphi 2007 - cmp eax, edx - jz @exit // exit if source=dest - cmp ecx, 32 - ja @lrg // count > 32 or count < 0 - sub ecx, 8 - jg @sml // 9..32 byte move - jmp dword ptr[@table + 32 + ecx * 4] // 0..8 byte move -@sml: fild qword ptr[eax + ecx] // load last 8 - fild qword ptr[eax] // load first 8 - cmp ecx, 8 - jle @sml16 - fild qword ptr[eax + 8] // load second 8 - cmp ecx, 16 - jle @sml24 - fild qword ptr[eax + 16] // load third 8 - fistp qword ptr[edx + 16] // save third 8 -@sml24: fistp qword ptr[edx + 8] // save second 8 -@sml16: fistp qword ptr[edx] // save first 8 - fistp qword ptr[edx + ecx] // save last 8 - ret -@exit: rep ret -@table: dd @exit, @m01, @m02, @m03, @m04, @m05, @m06, @m07, @m08 -@lrgfwd:push edx - fild qword ptr[eax] // first 8 - lea eax, [eax + ecx - 8] - lea ecx, [ecx + edx - 8] - fild qword ptr[eax] // last 8 - push ecx - neg ecx - and edx, -8 // 8-byte align writes - lea ecx, [ecx + edx + 8] - pop edx -@fwd: fild qword ptr[eax + ecx] - fistp qword ptr[edx + ecx] - add ecx, 8 - jl @fwd - fistp qword ptr[edx] // last 8 - pop edx - fistp qword ptr[edx] // first 8 - ret -@lrg: jng @exit // count < 0 - cmp eax, edx - ja @lrgfwd - sub edx, ecx - cmp eax, edx - lea edx, [edx + ecx] - jna @lrgfwd - sub ecx, 8 // backward move - push ecx - fild qword ptr[eax + ecx] // last 8 - fild qword ptr[eax] // first 8 - add ecx, edx - and ecx, -8 // 8-byte align writes - sub ecx, edx -@bwd: fild qword ptr[eax + ecx] - fistp qword ptr[edx + ecx] - sub ecx, 8 - jg @bwd - pop ecx - fistp qword ptr[edx] // first 8 - fistp qword ptr[edx + ecx] // last 8 - ret -@m01: movzx ecx, byte ptr[eax] - mov [edx], cl - ret -@m02: movzx ecx, word ptr[eax] - mov [edx], cx - ret -@m03: mov cx, [eax] - mov al, [eax + 2] - mov [edx], cx - mov [edx + 2], al - ret -@m04: mov ecx, [eax] - mov [edx], ecx - ret -@m05: mov ecx, [eax] - mov al, [eax + 4] - mov [edx], ecx - mov [edx + 4], al - ret -@m06: mov ecx, [eax] - mov ax, [eax + 4] - mov [edx], ecx - mov [edx + 4], ax - ret -@m07: mov ecx, [eax] - mov eax, [eax + 3] - mov [edx], ecx - mov [edx + 3], eax - ret -@m08: mov ecx, [eax] - mov eax, [eax + 4] - mov [edx], ecx - mov [edx + 4], eax -end; - -{$ifdef WITH_ERMS} -procedure FillCharERMSB; // Ivy Bridge+ Enhanced REP MOVSB/STOSB CPUs -asm // eax=Dest edx=Count cl=Value - test edx, edx - jle @none - cld - push edi - mov edi, eax - mov al, cl - mov ecx, edx - rep stosb - pop edi -@none: -end; - -procedure MoveERMSB; // Ivy Bridge+ Enhanced REP MOVSB/STOSB CPUs -asm // eax=source edx=dest ecx=count - test ecx, ecx - jle @none - push esi - push edi - cmp edx, eax - ja @down - mov esi, eax - mov edi, edx - cld - rep movsb - 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; -{$endif WITH_ERMS} - -function StrLenX86(S: pointer): PtrInt; -// pure x86 function (if SSE2 not available) - faster than SysUtils' version -asm - test eax, eax - jz @0 - cmp byte ptr[eax + 0], 0 - je @0 - cmp byte ptr[eax + 1], 0 - je @1 - cmp byte ptr[eax + 2], 0 - je @2 - cmp byte ptr[eax + 3], 0 - je @3 - push eax - and eax, -4 { DWORD Align Reads } -@Loop: add eax, 4 - mov edx, [eax] { 4 Chars per Loop } - lea ecx, [edx - $01010101] - not edx - and edx, ecx - and edx, $80808080 { Set Byte to $80 at each #0 Position } - jz @Loop { Loop until any #0 Found } - pop ecx - bsf edx, edx { Find First #0 Position } - shr edx, 3 { Byte Offset of First #0 } - add eax, edx { Address of First #0 } - sub eax, ecx { Returns Length } - ret -@0: xor eax, eax - ret -@1: mov eax, 1 - ret -@2: mov eax, 2 - ret -@3: mov eax, 3 -end; - -{$ifndef DELPHI5OROLDER} // need SSE2 asm instruction set - -procedure FillCharSSE2; -asm // Dest=eax Count=edx Value=cl - mov ch, cl {copy value into both bytes of cx} - cmp edx, 32 - jl @small - sub edx, 16 - movd xmm0, ecx - pshuflw xmm0, xmm0, 0 - pshufd xmm0, xmm0, 0 - movups [eax], xmm0 {fill first 16 bytes} - movups [eax + edx], xmm0 {fill last 16 bytes} - mov ecx, eax {16-byte align writes} - and ecx, 15 - sub ecx, 16 - sub eax, ecx - add edx, ecx - add eax, edx - neg edx - cmp edx, - 512 * 1024 - jb @large -@loop: movaps [eax + edx], xmm0 {fill 16 bytes per loop} - add edx, 16 - jl @loop - ret -@large: movntdq [eax + edx], xmm0 {fill 16 bytes per loop} - add edx, 16 - jl @large - ret -@small: test edx, edx - jle @done - mov [eax + edx - 1], cl {fill last byte} - and edx, -2 {no. of words to fill} - neg edx - lea edx, [@smallfill + 60 + edx * 2] - jmp edx - nop {align jump destinations} - nop -@smallfill: - mov [eax + 28], cx - mov [eax + 26], cx - mov [eax + 24], cx - mov [eax + 22], cx - mov [eax + 20], cx - mov [eax + 18], cx - mov [eax + 16], cx - mov [eax + 14], cx - mov [eax + 12], cx - mov [eax + 10], cx - mov [eax + 8], cx - mov [eax + 6], cx - mov [eax + 4], cx - mov [eax + 2], cx - mov [eax], cx - ret {do not remove - this is for alignment} -@done: -end; - -{$endif DELPHI5OROLDER} - -{$endif PUREPASCAL} -{$endif CPU64} -{$endif CPUARM} - -{$endif FPC} - - -{ ************ Custom record / dynamic array JSON serialization } - -procedure SaveJSON(const Value; TypeInfo: pointer; - Options: TTextWriterOptions; var result: RawUTF8); -var temp: TTextWriterStackBuffer; -begin - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - fCustomOptions := fCustomOptions+Options; - AddTypedJSON(TypeInfo,Value); - SetText(result); - finally - Free; - end; -end; - -function SaveJSON(const Value; TypeInfo: pointer; EnumSetsAsText: boolean): RawUTF8; -var options: TTextWriterOptions; -begin - if EnumSetsAsText then - options := [twoEnumSetsAsTextInRecord,twoFullSetsAsStar] else - options := [twoFullSetsAsStar]; - SaveJSON(Value,TypeInfo,options,result); -end; - -type - /// information about one customized JSON serialization - TJSONCustomParserRegistration = record - RecordTypeName: RawUTF8; - RecordTextDefinition: RawUTF8; - DynArrayTypeInfo: pointer; - RecordTypeInfo: pointer; - Reader: TDynArrayJSONCustomReader; - Writer: TDynArrayJSONCustomWriter; - RecordCustomParser: TJSONRecordAbstract; - end; - PJSONCustomParserRegistration = ^TJSONCustomParserRegistration; - TJSONCustomParserRegistrations = array of TJSONCustomParserRegistration; - - PTJSONCustomParserAbstract = ^TJSONRecordAbstract; - - /// used internally to manage custom record / dynamic array JSON serialization - // - e.g. used by TTextWriter.RegisterCustomJSONSerializer*() - TJSONCustomParsers = class - protected - fLastDynArrayIndex: integer; - fLastRecordIndex: integer; - fParser: TJSONCustomParserRegistrations; - fParsersCount: Integer; - fParsers: TDynArrayHashed; - {$ifndef NOVARIANTS} - fVariants: array of record - TypeClass: TCustomVariantType; - Reader: TDynArrayJSONCustomReader; - Writer: TDynArrayJSONCustomWriter; - end; - function VariantSearch(aClass: TCustomVariantType): PtrInt; - procedure VariantWrite(aClass: TCustomVariantType; - aWriter: TTextWriter; const aValue: variant; Escape: TTextWriterKind); - {$endif} - function TryToGetFromRTTI(aDynArrayTypeInfo, aRecordTypeInfo: pointer): integer; - function Search(aTypeInfo: pointer; var Reg: TJSONCustomParserRegistration; - AddIfNotExisting: boolean): integer; - function DynArraySearch(aDynArrayTypeInfo, aRecordTypeInfo: pointer; - AddIfNotExisting: boolean=true): integer; overload; - function RecordSearch(aRecordTypeInfo: pointer; - AddIfNotExisting: boolean=true): integer; overload; - function RecordSearch(aRecordTypeInfo: pointer; - out Reader: TDynArrayJSONCustomReader): boolean; overload; - function RecordSearch(aRecordTypeInfo: pointer; - out Writer: TDynArrayJSONCustomWriter; PParser: PTJSONCustomParserAbstract): boolean; overload; - function RecordSearch(const aTypeName: RawUTF8): integer; overload; - function RecordRTTITextHash(aRecordTypeInfo: pointer; var crc: cardinal; - out recsize: integer): boolean; - public - constructor Create; - procedure RegisterCallbacks(aTypeInfo: pointer; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); - function RegisterFromText(aTypeInfo: pointer; - const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; - {$ifndef NOVARIANTS} - procedure RegisterCallbacksVariant(aClass: TCustomVariantType; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); - {$endif} - property Parser: TJSONCustomParserRegistrations read fParser; - property ParsersCount: Integer read fParsersCount; - end; - -var - GlobalJSONCustomParsers: TJSONCustomParsers; - -constructor TJSONCustomParsers.Create; -begin - fParsers.InitSpecific(TypeInfo(TJSONCustomParserRegistrations), - fParser,djRawUTF8,@fParsersCount,true); - GarbageCollectorFreeAndNil(GlobalJSONCustomParsers,self); -end; - -function TJSONCustomParsers.TryToGetFromRTTI(aDynArrayTypeInfo, - aRecordTypeInfo: pointer): integer; -var Reg: TJSONCustomParserRegistration; - RegRoot: TJSONCustomParserRTTI; - {$ifdef ISDELPHI2010} - info: PTypeInfo; - {$endif} - added: boolean; - ndx, len: integer; - name: PShortString; -begin - result := -1; - Reg.RecordTypeInfo := aRecordTypeInfo; - Reg.DynArrayTypeInfo := aDynArrayTypeInfo; - TypeInfoToName(Reg.RecordTypeInfo,Reg.RecordTypeName); - if Reg.RecordTypeName='' then begin - name := TypeInfoToShortString(Reg.DynArrayTypeInfo); - if name=nil then - exit; // we need a type name! - len := length(name^); // try to guess from T*DynArray or T*s names - if (len>12) and (IdemPropName('DynArray',@name^[len-7],8)) then - FastSetString(Reg.RecordTypeName,@name^[1],len-8) else - if (len>3) and (name^[len]='s') then - FastSetString(Reg.RecordTypeName,@name^[1],len-1) else - exit; - end; - RegRoot := TJSONCustomParserRTTI.CreateFromTypeName('',Reg.RecordTypeName); - {$ifdef ISDELPHI2010} - if RegRoot=nil then begin - info := GetTypeInfo(aRecordTypeInfo,tkRecordKinds); - if info=nil then - exit; // not enough RTTI - inc(PByte(info),info^.ManagedCount*SizeOf(TFieldInfo)-SizeOf(TFieldInfo)); - inc(PByte(info),info^.NumOps*SizeOf(pointer)); // jump RecOps[] - if info^.AllCount=0 then - exit; // not enough RTTI -> avoid exception in constructor below - end; - {$else} - if RegRoot=nil then - exit; // not enough RTTI for older versions of Delphi - {$endif} - Reg.RecordCustomParser := TJSONRecordRTTI.Create(Reg.RecordTypeInfo,RegRoot); - Reg.Reader := Reg.RecordCustomParser.CustomReader; - Reg.Writer := Reg.RecordCustomParser.CustomWriter; - if self=nil then - if GlobalJSONCustomParsers<>nil then // may have been set just above - self := GlobalJSONCustomParsers else - self := TJSONCustomParsers.Create; - ndx := fParsers.FindHashedForAdding(Reg.RecordTypeName,added); - if not added then - exit; // name should be unique - fParser[ndx] := Reg; - result := ndx; -end; - -function TJSONCustomParsers.DynArraySearch(aDynArrayTypeInfo,aRecordTypeInfo: pointer; - AddIfNotExisting: boolean): Integer; -var threadsafe: integer; - parser: PJSONCustomParserRegistration; -begin // O(n) brute force is fast enough, since n remains small (mostly<64) - if self<>nil then - if (aDynArrayTypeInfo<>nil) and (fParsersCount<>0) then begin - threadsafe := fLastDynArrayIndex; - if (cardinal(threadsafe)=0 then - fLastRecordIndex := result; - end else - result := -1; -end; - -function TJSONCustomParsers.RecordSearch(aRecordTypeInfo: pointer; - AddIfNotExisting: boolean): integer; -begin - if aRecordTypeInfo=nil then begin - result := -1; - exit; - end; - if self<>nil then - if (cardinal(fLastRecordIndex)=0 then - fLastRecordIndex := result; - end else - result := -1; -end; - -function TJSONCustomParsers.RecordSearch(const aTypeName: RawUTF8): integer; -begin - if self=nil then - result := -1 else - if (cardinal(fLastRecordIndex)=0 then - fLastRecordIndex := result; - end; -end; - -function TJSONCustomParsers.RecordSearch(aRecordTypeInfo: pointer; - out Reader: TDynArrayJSONCustomReader): boolean; -var ndx: integer; -begin - ndx := RecordSearch(aRecordTypeInfo); - if (ndx>=0) and Assigned(fParser[ndx].Reader) then begin - Reader := fParser[ndx].Reader; - result := true; - end else - result := false; -end; - -function TJSONCustomParsers.RecordRTTITextHash(aRecordTypeInfo: pointer; - var crc: cardinal; out recsize: integer): boolean; -var ndx: integer; -begin - if (self<>nil) and (aRecordTypeInfo<>nil) then - for ndx := 0 to fParsersCount-1 do - with fParser[ndx] do - if RecordTypeInfo=aRecordTypeInfo then begin - if RecordTextDefinition='' then - break; - crc := crc32c(crc,pointer(RecordTextDefinition),length(RecordTextDefinition)); - recsize := RecordTypeInfoSize(aRecordTypeInfo); - result := true; - exit; - end; - result := false; -end; - -function TJSONCustomParsers.RecordSearch(aRecordTypeInfo: pointer; - out Writer: TDynArrayJSONCustomWriter; PParser: PTJSONCustomParserAbstract): boolean; -var ndx: integer; -begin - result := false; - ndx := RecordSearch(aRecordTypeInfo); - if (ndx>=0) and Assigned(fParser[ndx].Writer) then begin - Writer := fParser[ndx].Writer; - if PParser<>nil then - PParser^ := fParser[ndx].RecordCustomParser; - result := true; - end; -end; - -function TJSONCustomParsers.Search(aTypeInfo: pointer; - var Reg: TJSONCustomParserRegistration; AddIfNotExisting: boolean): integer; -var added: boolean; -begin - if (aTypeInfo=nil) or (self=nil) then - raise ESynException.CreateUTF8('%.Search(%)',[self,aTypeInfo]); - FillCharFast(Reg,SizeOf(Reg),0); - case PTypeKind(aTypeInfo)^ of - tkDynArray: begin - Reg.DynArrayTypeInfo := aTypeInfo; - Reg.RecordTypeInfo := DynArrayTypeInfoToRecordInfo(aTypeInfo); - result := DynArraySearch(Reg.DynArrayTypeInfo,Reg.RecordTypeInfo,false); - end; - tkRecord{$ifdef FPC},tkObject{$endif}: begin - Reg.DynArrayTypeInfo := nil; - Reg.RecordTypeInfo := aTypeInfo; - result := RecordSearch(Reg.RecordTypeInfo,false); - end; - else raise ESynException.CreateUTF8('%.Search: % not a tkDynArray/tkRecord', - [self,ToText(PTypeKind(aTypeInfo)^)^]); - end; - if not AddIfNotExisting then - exit; - TypeInfoToName(Reg.RecordTypeInfo,Reg.RecordTypeName); - if Reg.RecordTypeName='' then - TypeInfoToName(Reg.DynArrayTypeInfo,Reg.RecordTypeName); - if Reg.RecordTypeName='' then - raise ESynException.CreateUTF8('%.Search(%) has no type name',[self,aTypeInfo]); - if result<0 then - result := fParsers.FindHashedForAdding(Reg.RecordTypeName,added); -end; - -{$ifndef NOVARIANTS} -function TJSONCustomParsers.VariantSearch(aClass: TCustomVariantType): PtrInt; -begin - if self<>nil then - for result := 0 to length(fVariants)-1 do - if fVariants[result].TypeClass=aClass then - exit; - result := -1; -end; - -procedure TJSONCustomParsers.VariantWrite(aClass: TCustomVariantType; - aWriter: TTextWriter; const aValue: variant; Escape: TTextWriterKind); -var ndx: PtrInt; - temp: string; -begin - ndx := VariantSearch(aClass); - if (ndx>=0) and Assigned(fVariants[ndx].Writer) then - fVariants[ndx].Writer(aWriter,aValue) else begin - temp := aValue; // fallback to JSON string from variant-to-string conversion - if Escape=twJSONEscape then - aWriter.Add('"'); - {$ifdef UNICODE} - aWriter.AddW(pointer(temp),length(temp),Escape); - {$else} - aWriter.AddAnsiString(temp,Escape); - {$endif} - if Escape=twJSONEscape then - aWriter.Add('"'); - end; -end; - -procedure TJSONCustomParsers.RegisterCallbacksVariant(aClass: TCustomVariantType; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); -var ndx: PtrInt; -begin - if self=nil then - self := TJSONCustomParsers.Create; - ndx := VariantSearch(aClass); - if ndx<0 then begin - ndx := length(fVariants); - SetLength(fVariants,ndx+1); - fVariants[ndx].TypeClass := aClass; - end; - fVariants[ndx].Writer := aWriter; - fVariants[ndx].Reader := aReader; -end; -{$endif} - -procedure TJSONCustomParsers.RegisterCallbacks(aTypeInfo: pointer; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); -var Reg: TJSONCustomParserRegistration; - ForAdding: boolean; - ndx: integer; -begin - if self=nil then - self := TJSONCustomParsers.Create; - ForAdding := Assigned(aReader) or Assigned(aWriter); - ndx := Search(aTypeInfo,Reg,ForAdding); - if ForAdding then begin - Reg.Writer := aWriter; - Reg.Reader := aReader; - fParser[ndx] := Reg; - end else - if ndx>=0 then begin - fParsers.Delete(ndx); - fParsers.ReHash; - end; -end; - -function TJSONCustomParsers.RegisterFromText(aTypeInfo: pointer; - const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; -var Reg: TJSONCustomParserRegistration; - ForAdding: boolean; - ndx: integer; -begin - if self=nil then - self := TJSONCustomParsers.Create; - ForAdding := aRTTIDefinition<>''; - ndx := Search(aTypeInfo,Reg,ForAdding); - if ForAdding then begin - result := TJSONRecordTextDefinition.FromCache(Reg.RecordTypeInfo,aRTTIDefinition); - Reg.RecordTextDefinition := aRTTIDefinition; - Reg.Reader := result.CustomReader; - Reg.Writer := result.CustomWriter; - Reg.RecordCustomParser := result; - fParser[ndx] := Reg; - end else begin - result := nil; - if ndx>=0 then begin - fParsers.Delete(ndx); - fParsers.ReHash; - end; - end; -end; - -function ManagedTypeSaveRTTIHash(info: PTypeInfo; var crc: cardinal): integer; -var itemtype: PTypeInfo; - i, unmanagedsize: integer; - field: PFieldInfo; - dynarray: TDynArray; -begin // info is expected to come from a DeRef() if retrieved from RTTI - result := 0; - if info=nil then - exit; - {$ifdef FPC} // storage binary layout as Delphi's ordinal value - crc := crc32c(crc,@FPCTODELPHI[info^.Kind],1); - {$else} - crc := crc32c(crc,@info^.Kind,1); // hash RTTI kind, but not name - {$endif} - case info^.Kind of // handle nested RTTI - tkLString,{$ifdef FPC}tkLStringOld,{$endif}{$ifdef HASVARUSTRING}tkUString,{$endif} - tkWString,tkInterface: - result := SizeOf(pointer); - {$ifndef NOVARIANTS} - tkVariant: - result := SizeOf(variant); - {$endif} - tkRecord{$ifdef FPC},tkObject{$endif}: // first search from custom RTTI text - if not GlobalJSONCustomParsers.RecordRTTITextHash(info,crc,result) then begin - itemtype := GetTypeInfo(info,tkRecordKinds); - if itemtype<>nil then begin - unmanagedsize := itemtype^.recsize; - for i := 1 to GetManagedFields(itemtype,field) do begin - info := DeRef(field^.TypeInfo); - {$ifdef FPC_OLDRTTI} // old FPC did include RTTI for unmanaged fields - if info^.Kind in tkManagedTypes then // as with Delphi - {$endif} - dec(unmanagedsize,ManagedTypeSaveRTTIHash(info,crc)); - inc(field); - end; - crc := crc32c(crc,@unmanagedsize,4); - result := itemtype^.recSize; - end; - end; - tkArray: begin - itemtype := ArrayItemType(info,result); - if info=nil then - exit; - unmanagedsize := result; - if itemtype<>nil then - for i := 1 to info^.elCount do - dec(unmanagedsize,ManagedTypeSaveRTTIHash(itemtype,crc)); - crc := crc32c(crc,@unmanagedsize,4); - end; - tkDynArray: begin - dynarray.Init(info,field); // fake void array pointer - crc := dynarray.SaveToTypeInfoHash(crc); - result := SizeOf(pointer); - end; - end; -end; - -function TypeInfoToHash(aTypeInfo: pointer): cardinal; -begin - result := 0; - ManagedTypeSaveRTTIHash(aTypeInfo,result); -end; - -function RecordSaveJSON(const Rec; TypeInfo: pointer; EnumSetsAsText: boolean): RawUTF8; -begin - result := SaveJSON(Rec,TypeInfo,EnumSetsAsText); -end; - -const - NULCHAR: AnsiChar = #0; - -function RecordLoadJSON(var Rec; JSON: PUTF8Char; TypeInfo: pointer; EndOfObject: PUTF8Char - {$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; -var wasString, wasValid: boolean; - Reader: TDynArrayJSONCustomReader; - FirstChar,EndOfObj: AnsiChar; - Val: PUTF8Char; - ValLen: integer; -begin // code below must match TTextWriter.AddRecordJSON - result := nil; // indicates error - if JSON=nil then - exit; - if (@Rec=nil) or (TypeInfo=nil) then - raise ESynException.CreateUTF8('Invalid RecordLoadJSON(%) call',[TypeInfo]); - if JSON^=' ' then repeat inc(JSON); if JSON^=#0 then exit; until JSON^<>' '; - if PCardinal(JSON)^=JSON_BASE64_MAGIC_QUOTE then begin - if not (PTypeKind(TypeInfo)^ in tkRecordTypes) then - raise ESynException.CreateUTF8('RecordLoadJSON(%/%)', - [PShortString(@PTypeInfo(TypeInfo).NameLen)^,ToText(PTypeKind(TypeInfo)^)^]); - Val := GetJSONField(JSON,JSON,@wasString,@EndOfObj,@ValLen); - if (Val=nil) or not wasString or (ValLen<3) or - (PInteger(Val)^ and $00ffffff<>JSON_BASE64_MAGIC) or - not RecordLoad(Rec,Base64ToBin(PAnsiChar(Val)+3,ValLen-3),TypeInfo) then - exit; // invalid content - end else begin - if not GlobalJSONCustomParsers.RecordSearch(TypeInfo,Reader) then - exit; - FirstChar := JSON^; - JSON := Reader(JSON,Rec,wasValid{$ifndef NOVARIANTS},CustomVariantOptions{$endif}); - if not wasValid then - exit; - if JSON<>nil then - JSON := GotoNextNotSpace(JSON); - if (JSON<>nil) and (JSON^<>#0) then - if FirstChar='"' then // special case e.g. for TGUID string - EndOfObj := FirstChar else begin - EndOfObj := JSON^; - inc(JSON); - end else - EndOfObj := #0; - end; - if JSON=nil then // end reached, but valid content decoded - result := @NULCHAR else - result := JSON; - if EndOfObject<>nil then - EndOfObject^ := EndOfObj; -end; - -function RecordLoadJSON(var Rec; const JSON: RawUTF8; TypeInfo: pointer{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): boolean; -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); // make private copy before in-place decoding - try - result := RecordLoadJSON(Rec,tmp.buf,TypeInfo,nil - {$ifndef NOVARIANTS},CustomVariantOptions{$endif})<>nil; - finally - tmp.Done; - end; -end; - - -{ TJSONCustomParserCustom } - -constructor TJSONCustomParserCustom.Create(const aPropertyName, aCustomTypeName: RawUTF8); -begin - inherited Create(aPropertyName,ptCustom); - fCustomTypeName := aCustomTypeName; -end; - -procedure TJSONCustomParserCustom.FinalizeItem(Data: Pointer); -begin // nothing to be done by default -end; - - -{ TJSONCustomParserCustomSimple } - -constructor TJSONCustomParserCustomSimple.Create( - const aPropertyName, aCustomTypeName: RawUTF8; aCustomType: pointer); -var info: PTypeInfo; - kind: TTypeKind; -begin - inherited Create(aPropertyName,aCustomTypeName); - fCustomTypeInfo := aCustomType; - if IdemPropNameU(aCustomTypeName,'TGUID') then begin - fKnownType := ktGUID; - fDataSize := SizeOf(TGUID); - end else - if fCustomTypeInfo<>nil then begin - TypeInfoToName(fCustomTypeInfo,fCustomTypeName,aCustomTypeName); - kind := PTypeKind(fCustomTypeInfo)^; - info := GetTypeInfo(fCustomTypeInfo,[tkEnumeration,tkSet,tkArray,tkDynArray]); - fTypeData := info; - if info<>nil then - case kind of - tkEnumeration, tkSet: begin - fDataSize := ORDTYPE_SIZE[info^.EnumType]; - if kind=tkEnumeration then - fKnownType := ktEnumeration else - fKnownType := ktSet; - exit; // success - end; - tkArray: begin - if info^.dimCount<>1 then - raise ESynException.CreateUTF8('%.Create("%") supports only single '+ - 'dimension static array)',[self,fCustomTypeName]); - fKnownType := ktStaticArray; - {$ifdef VER2_6} - fFixedSize := info^.arraySize; // is elSize in fact - fDataSize := fFixedSize*info^.elCount; - {$else} - fDataSize := info^.arraySize; - fFixedSize := fDataSize div info^.elCount; - {$endif} - fNestedArray := TJSONCustomParserRTTI.CreateFromRTTI( - '',Deref(info^.arrayType),fFixedSize); - exit; // success - end; - tkDynArray: begin - fKnownType := ktDynamicArray; - exit; // success - end; - end; - raise ESynException.CreateUTF8('%.Create("%") unsupported type: % (%)', - [self,fCustomTypeName,ToText(kind)^,ord(kind)]); - end; -end; - -constructor TJSONCustomParserCustomSimple.CreateFixedArray( - const aPropertyName: RawUTF8; aFixedSize: cardinal); -begin - inherited Create(aPropertyName,FormatUTF8('Fixed%Byte',[aFixedSize])); - fKnownType := ktFixedArray; - fFixedSize := aFixedSize; - fDataSize := aFixedSize; -end; - -constructor TJSONCustomParserCustomSimple.CreateBinary( - const aPropertyName: RawUTF8; aDataSize, aFixedSize: cardinal); -begin - inherited Create(aPropertyName,FormatUTF8('BinHex%Byte',[aFixedSize])); - fKnownType := ktBinary; - fFixedSize := aFixedSize; - fDataSize := aDataSize; -end; - -destructor TJSONCustomParserCustomSimple.Destroy; -begin - inherited; - fNestedArray.Free; -end; - -procedure TJSONCustomParserCustomSimple.CustomWriter( - const aWriter: TTextWriter; const aValue); -var i: integer; - V: PByte; -begin - case fKnownType of - ktStaticArray: begin - aWriter.Add('['); - V := @aValue; - for i := 1 to PTypeInfo(fTypeData)^.elCount do begin - fNestedArray.WriteOneLevel(aWriter,V,[]); - aWriter.Add(','); - end; - aWriter.CancelLastComma; - aWriter.Add(']'); - end; - ktEnumeration, ktSet: - aWriter.AddTypedJSON(fCustomTypeInfo,aValue); - ktDynamicArray: - raise ESynException.CreateUTF8('%.CustomWriter("%"): unsupported', - [self,fCustomTypeName]); - ktBinary: - if (fFixedSize<=SizeOf(QWord)) and IsZero(@aValue,fFixedSize) then - aWriter.AddShort('""') else // 0 -> "" - aWriter.AddBinToHexDisplayQuoted(@aValue,fFixedSize); - else begin // encoded as JSON strings - aWriter.Add('"'); - case fKnownType of - ktGUID: - aWriter.Add(TGUID(aValue)); - ktFixedArray: - aWriter.AddBinToHex(@aValue,fFixedSize); - end; - aWriter.Add('"'); - end; - end; -end; - -function TJSONCustomParserCustomSimple.CustomReader(P: PUTF8Char; var aValue; - out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; -var PropValue: PUTF8Char; - i, PropValueLen, i32: integer; - u64: QWord; - wasString: boolean; - Val: PByte; -begin - result := nil; // indicates error - case fKnownType of - ktStaticArray: begin - if P^<>'[' then - exit; // we expect a true array here - P := GotoNextNotSpace(P+1); - if JSONArrayCount(P)<>PTypeInfo(fTypeData)^.elCount then - exit; // invalid number of items - Val := @aValue; - for i := 1 to PTypeInfo(fTypeData)^.elCount do - if not fNestedArray.ReadOneLevel( - P,Val,[]{$ifndef NOVARIANTS},CustomVariantOptions{$endif}) then - exit else - if P=nil then - exit; - P := GotoNextNotSpace(P); - EndOfObject := P^; - if P^ in [',','}'] then - inc(P); - result := P; - end; - ktDynamicArray: - raise ESynException.CreateUTF8('%.CustomReader("%"): unsupported', - [self,fCustomTypeName]); - ktSet: begin - i32 := GetSetNameValue(fCustomTypeInfo,P,EndOfObject); - MoveSmall(@i32,@aValue,fDataSize); - result := P; - end; - else begin // encoded as JSON strings or number - PropValue := GetJSONField(P,P,@wasString,@EndOfObject,@PropValueLen); - if PropValue=nil then - exit; // not a JSON string or number - if P=nil then // result=nil=error + caller may dec(P); P^:=EndOfObject; - P := PropValue+PropValueLen; - case fKnownType of - ktGUID: - if wasString and (TextToGUID(PropValue,@aValue)<>nil) then - result := P; - ktEnumeration: begin - if wasString then - i32 := GetEnumNameValue(fCustomTypeInfo,PropValue,PropValueLen,true) else - i32 := GetCardinal(PropValue); - if i32<0 then - exit; - MoveSmall(@i32,@aValue,fDataSize); - result := P; - end; - ktFixedArray: - if wasString and (PropValueLen=fFixedSize*2) and - SynCommons.HexToBin(PAnsiChar(PropValue),@aValue,fFixedSize) then - result := P; - ktBinary: - if wasString then begin // default hexa serialization - FillCharFast(aValue,fDataSize,0); - if (PropValueLen=0) or ((PropValueLen=fFixedSize*2) and - HexDisplayToBin(PAnsiChar(PropValue),@aValue,fFixedSize)) then - result := P; - end else - if fFixedSize<=SizeOf(u64) then begin // allow integer serialization - SetQWord(PropValue,u64); - MoveSmall(@u64,@aValue,fDataSize); - result := P; - end; - end; - end; - end; -end; - - -{ TJSONCustomParserCustomRecord } - -constructor TJSONCustomParserCustomRecord.Create( - const aPropertyName: RawUTF8; aCustomTypeIndex: integer); -begin - fCustomTypeIndex := aCustomTypeIndex; - with GlobalJSONCustomParsers.fParser[fCustomTypeIndex] do begin - inherited Create(aPropertyName,RecordTypeName); - fCustomTypeInfo := RecordTypeInfo; - fCustomTypeName := RecordTypeName; - end; - fDataSize := RecordTypeInfoSize(fCustomTypeInfo); -end; - -function TJSONCustomParserCustomRecord.GetJSONCustomParserRegistration: pointer; -begin - result := nil; - if GlobalJSONCustomParsers<>nil then begin - if (Cardinal(fCustomTypeIndex)>=Cardinal(GlobalJSONCustomParsers.fParsersCount)) or - not IdemPropNameU(fCustomTypeName, - GlobalJSONCustomParsers.fParser[fCustomTypeIndex].RecordTypeName) then - fCustomTypeIndex := GlobalJSONCustomParsers.RecordSearch(fCustomTypeInfo); - if fCustomTypeIndex>=0 then - result := @GlobalJSONCustomParsers.fParser[fCustomTypeIndex]; - end; - if result=nil then - raise ESynException.CreateUTF8( - '%: [%] type should not have been un-registered',[self,fCustomTypeName]); -end; - -procedure TJSONCustomParserCustomRecord.CustomWriter( - const aWriter: TTextWriter; const aValue); -var parser: PJSONCustomParserRegistration; -begin - parser := GetJSONCustomParserRegistration; - parser^.Writer(aWriter,aValue); -end; - -function TJSONCustomParserCustomRecord.CustomReader(P: PUTF8Char; var aValue; - out EndOfObject: AnsiChar{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; -var valid: boolean; - callback: PJSONCustomParserRegistration; // D5/D6 Internal error: C3890 -begin - callback := GetJSONCustomParserRegistration; - result := callback^.Reader(P,aValue,valid{$ifndef NOVARIANTS},CustomVariantOptions{$endif}); - if not valid then - result := nil; - if result=nil then - exit; - EndOfObject := result^; - if result^ in [',','}',']'] then - inc(result); -end; - -procedure TJSONCustomParserCustomRecord.FinalizeItem(Data: Pointer); -begin - RecordClear(Data^,fCustomTypeInfo); -end; - - -{ TJSONCustomParserRTTI } - -type - TJSONSerializerFromTextSimple = record - TypeInfo: pointer; - BinaryDataSize, BinaryFieldSize: integer; - end; - TJSONSerializerFromTextSimpleDynArray = array of TJSONSerializerFromTextSimple; -var // RawUTF8/TJSONSerializerFromTextSimpleDynArray - GlobalCustomJSONSerializerFromTextSimpleType: TSynDictionary; - -procedure JSONSerializerFromTextSimpleTypeAdd(aTypeName: RawUTF8; - aTypeInfo: pointer; aDataSize, aFieldSize: integer); -var simple: TJSONSerializerFromTextSimple; -begin - if aTypeName='' then - TypeInfoToName(aTypeInfo,aTypeName); - if aDataSize<>0 then - if aFieldSize>aDataSize then - raise ESynException.CreateUTF8('JSONSerializerFromTextSimpleTypeAdd(%) fieldsize=%>%', - [aTypeName,aFieldSize,aDataSize]) else - if aFieldSize=0 then - aFieldSize := aDataSize; // not truncated - simple.TypeInfo := aTypeInfo; - simple.BinaryDataSize := aDataSize; - simple.BinaryFieldSize := aFieldSize; - UpperCaseSelf(aTypeName); - if GlobalCustomJSONSerializerFromTextSimpleType.Add(aTypeName,simple)<0 then - raise ESynException.CreateUTF8('JSONSerializerFromTextSimpleTypeAdd(%) duplicated', [aTypeName]); -end; - -/// if defined, will try to mimic the default record alignment -// -> is buggy, and compiler revision specific -> we would rather use packed records -{.$define ALIGNCUSTOMREC} - -constructor TJSONCustomParserRTTI.Create(const aPropertyName: RawUTF8; - aPropertyType: TJSONCustomParserRTTIType); -begin - fPropertyName := aPropertyName; - fPropertyType := aPropertyType; -end; - -class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType(TypeName: PUTF8Char; - TypeNameLen: PtrInt; ItemTypeName: PRawUTF8): TJSONCustomParserRTTIType; -const - SORTEDMAX = {$ifdef NOVARIANTS}32{$else}33{$endif}{$ifdef HASVARUSTRING}+1{$endif}; - SORTEDNAMES: array[0..SORTEDMAX] of PUTF8Char = - ('ARRAY','BOOLEAN','BYTE','CARDINAL','CURRENCY', - 'DOUBLE','EXTENDED','INT64','INTEGER','PTRINT','PTRUINT','QWORD', - 'RAWBYTESTRING','RAWJSON','RAWUTF8','RECORD','SINGLE', - 'STRING','SYNUNICODE','TCREATETIME','TDATETIME','TDATETIMEMS','TGUID', - 'TID','TMODTIME','TRECORDREFERENCE','TRECORDREFERENCETOBEDELETED', - 'TRECORDVERSION','TSQLRAWBLOB','TTIMELOG',{$ifdef HASVARUSTRING}'UNICODESTRING',{$endif} - 'UTF8STRING',{$ifndef NOVARIANTS}'VARIANT',{$endif} - 'WIDESTRING','WORD'); - // warning: recognized types should match at binary storage level! - SORTEDTYPES: array[0..SORTEDMAX] of TJSONCustomParserRTTIType = - (ptArray,ptBoolean,ptByte,ptCardinal,ptCurrency, - ptDouble,ptExtended,ptInt64,ptInteger,ptPtrInt,ptPtrUInt,ptQWord, - ptRawByteString,ptRawJSON,ptRawUTF8,ptRecord,ptSingle, - ptString,ptSynUnicode,ptTimeLog,ptDateTime,ptDateTimeMS,ptGUID, - ptID,ptTimeLog,ptInt64,ptInt64,ptInt64,ptRawByteString,ptTimeLog, - {$ifdef HASVARUSTRING}ptUnicodeString,{$endif}ptRawUTF8, - {$ifndef NOVARIANTS}ptVariant,{$endif} - ptWideString,ptWord); -var ndx: integer; - up: PUTF8Char; - tmp: array[byte] of AnsiChar; // avoid unneeded memory allocation -begin - if ItemTypeName<>nil then begin - UpperCaseCopy(TypeName,TypeNameLen,ItemTypeName^); - up := pointer(ItemTypeName^); - end else begin - UpperCopy255Buf(@tmp,TypeName,TypeNameLen)^ := #0; - up := @tmp; - end; -//for ndx := 1 to SORTEDMAX do assert(StrComp(SORTEDNAMES[ndx],SORTEDNAMES[ndx-1])>0,SORTEDNAMES[ndx]); - ndx := FastFindPUTF8CharSorted(@SORTEDNAMES,SORTEDMAX,up); - if ndx>=0 then - result := SORTEDTYPES[ndx] else - result := ptCustom; -end; - -class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( - const TypeName: RawUTF8): TJSONCustomParserRTTIType; -begin - if TypeName='' then - result := ptCustom else - result := TypeNameToSimpleRTTIType(Pointer(TypeName),length(TypeName),nil); -end; - -class function TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( - TypeName: PShortString): TJSONCustomParserRTTIType; -begin - if TypeName=nil then - result := ptCustom else - result := TypeNameToSimpleRTTIType(@TypeName^[1],ord(TypeName^[0]),nil); -end; - -class function TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(Info: pointer): TJSONCustomParserRTTIType; -begin - result := ptCustom; // e.g. for tkRecord - if Info=nil then - exit; - case PTypeKind(Info)^ of // FPC and Delphi will use a fast jmp table - tkLString{$ifdef FPC},tkLStringOld{$endif}: result := ptRawUTF8; - tkWString: result := ptWideString; - {$ifdef HASVARUSTRING}tkUString: result := ptUnicodeString;{$endif} - {$ifdef FPC_OR_UNICODE} - tkClassRef,tkPointer{$ifdef UNICODE},tkProcedure{$endif}: result := ptPtrInt; - {$endif} - {$ifndef NOVARIANTS} - tkVariant: result := ptVariant; - {$endif} - tkDynArray: result := ptArray; - tkChar: result := ptByte; - tkWChar: result := ptWord; - tkClass, tkMethod, tkInterface: result := ptPtrInt; - tkInteger: - case GetTypeInfo(Info)^.IntegerType of - otSByte,otUByte: result := ptByte; - otSWord,otUWord: result := ptWord; - otSLong: result := ptInteger; - otULong: result := ptCardinal; - {$ifdef FPC_NEWRTTI} - otSQWord: result := ptInt64; - otUQWord: result := ptQWord; - {$endif} - end; - tkInt64: - {$ifndef FPC} if Info=TypeInfo(QWord) then result := ptQWord else - {$ifdef UNICODE}with GetTypeInfo(Info)^ do // detect QWord/UInt64 - if MinInt64Value>MaxInt64Value then result := ptQWord else{$endif}{$endif} - result := ptInt64; - {$ifdef FPC} - tkQWord: result := ptQWord; - tkBool: result := ptBoolean; - {$else} - tkEnumeration: // other enumerates (or tkSet) use TJSONCustomParserCustomSimple - if Info=TypeInfo(boolean) then - result := ptBoolean; - {$endif} - tkFloat: - case GetTypeInfo(Info)^.FloatType of - ftSingle: result := ptSingle; - ftDoub: result := ptDouble; - ftCurr: result := ptCurrency; - ftExtended: result := ptExtended; - // ftComp: not implemented yet - end; - end; -end; - -function TypeInfoToRttiType(aTypeInfo: pointer): TJSONCustomParserRTTIType; -begin // first by known name, then from RTTI - result := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( - PUTF8Char(@PTypeInfo(aTypeInfo)^.NameLen)+1,PTypeInfo(aTypeInfo)^.NameLen,nil); - if result=ptCustom then - result := TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(aTypeInfo); -end; - -class function TJSONCustomParserRTTI.TypeNameToSimpleBinary(const aTypeName: RawUTF8; - out aDataSize, aFieldSize: integer): boolean; -var simple: ^TJSONSerializerFromTextSimple; -begin - simple := GlobalCustomJSONSerializerFromTextSimpleType.FindValue(aTypeName); - if (simple<>nil) and (simple^.BinaryFieldSize<>0) then begin - aDataSize := simple^.BinaryDataSize; - aFieldSize := simple^.BinaryFieldSize; - result := true; - end else - result := false; -end; - -class function TJSONCustomParserRTTI.CreateFromRTTI( - const PropertyName: RawUTF8; Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; -var Item: PTypeInfo absolute Info; - ItemType: TJSONCustomParserRTTIType; - ItemTypeName: RawUTF8; - ndx: integer; -begin - if Item=nil then // no RTTI -> stored as hexa string - result := TJSONCustomParserCustomSimple.CreateFixedArray(PropertyName,ItemSize) else begin - ItemType := TypeNameToSimpleRTTIType(PUTF8Char(@Item.NameLen)+1,Item.NameLen,@ItemTypeName); - if ItemType=ptCustom then - ItemType := TypeInfoToSimpleRTTIType(Info); - if ItemType=ptCustom then - if Item^.kind in [tkEnumeration,tkArray,tkDynArray,tkSet] then - result := TJSONCustomParserCustomSimple.Create( - PropertyName,ItemTypeName,Item) else begin - ndx := GlobalJSONCustomParsers.RecordSearch(Item); - if ndx<0 then - ndx := GlobalJSONCustomParsers.RecordSearch(ItemTypeName); - if ndx<0 then - raise ESynException.CreateUTF8('%.CreateFromRTTI("%") unsupported %', - [self,ItemTypeName,ToText(Item^.kind)^]); - result := TJSONCustomParserCustomRecord.Create(PropertyName,ndx); - end else - result := TJSONCustomParserRTTI.Create(PropertyName,ItemType); - end; - if ItemSize<>0 then - result.fDataSize := ItemSize; -end; - -class function TJSONCustomParserRTTI.CreateFromTypeName( - const aPropertyName, aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; -var ndx: integer; - simple: ^TJSONSerializerFromTextSimple; -begin - simple := GlobalCustomJSONSerializerFromTextSimpleType.FindValue(aCustomRecordTypeName); - if simple<>nil then - if simple^.BinaryFieldSize<>0 then - result := TJSONCustomParserCustomSimple.CreateBinary( - aPropertyName,simple^.BinaryDataSize,simple^.BinaryFieldSize) else - result := TJSONCustomParserCustomSimple.Create( - aPropertyName,aCustomRecordTypeName,simple^.TypeInfo) else begin - ndx := GlobalJSONCustomParsers.RecordSearch(aCustomRecordTypeName); - if ndx<0 then - result := nil else - result := TJSONCustomParserCustomRecord.Create(aPropertyName,ndx); - end; -end; - -procedure TJSONCustomParserRTTI.ComputeFullPropertyName; -var i: PtrInt; -begin - for i := 0 to length(NestedProperty)-1 do begin - NestedProperty[i].ComputeFullPropertyName; - if fFullPropertyName<>'' then - NestedProperty[i].fFullPropertyName := - fFullPropertyName+'.'+NestedProperty[i].fPropertyName; - end; -end; - -procedure TJSONCustomParserRTTI.ComputeNestedDataSize; -var i: PtrInt; -begin - assert(fNestedDataSize=0); - fNestedDataSize := 0; - for i := 0 to length(NestedProperty)-1 do begin - NestedProperty[i].ComputeDataSizeAfterAdd; - inc(fNestedDataSize,NestedProperty[i].fDataSize); - if fFullPropertyName<>'' then - NestedProperty[i].fFullPropertyName := - fFullPropertyName+'.'+NestedProperty[i].fPropertyName; - end; -end; - -procedure TJSONCustomParserRTTI.ComputeDataSizeAfterAdd; -const // binary size (in bytes) of each kind of property - 0 for ptRecord/ptCustom - JSONRTTI_SIZE: array[TJSONCustomParserRTTIType] of byte = ( - SizeOf(PtrUInt),SizeOf(Boolean),SizeOf(Byte),SizeOf(Cardinal),SizeOf(Currency), - SizeOf(Double),SizeOf(Extended),SizeOf(Int64),SizeOf(Integer),SizeOf(QWord), - SizeOf(RawByteString),SizeOf(RawJSON),SizeOf(RawUTF8),0,SizeOf(Single), - SizeOf(String),SizeOf(SynUnicode),SizeOf(TDateTime),SizeOf(TDateTimeMS), - SizeOf(TGUID),SizeOf(Int64),SizeOf(TTimeLog), - {$ifdef HASVARUSTRING}SizeOf(UnicodeString),{$endif} - {$ifndef NOVARIANTS}SizeOf(Variant),{$endif} - SizeOf(WideString),SizeOf(Word),0); -var i: PtrInt; -begin - if fFullPropertyName='' then begin - fFullPropertyName := fPropertyName; - ComputeFullPropertyName; - end; - if fDataSize=0 then begin - ComputeNestedDataSize; - case PropertyType of - ptRecord: - for i := 0 to length(NestedProperty)-1 do - inc(fDataSize,NestedProperty[i].fDataSize); - //ptCustom: fDataSize already set in TJSONCustomParserCustom.Create() - else - fDataSize := JSONRTTI_SIZE[PropertyType]; - end; - {$ifdef ALIGNCUSTOMREC} - inc(fDataSize,fDataSize and 7); - {$endif} - end; -end; - -procedure TJSONCustomParserRTTI.FinalizeNestedRecord(var Data: PByte); -var j: PtrInt; -begin - for j := 0 to length(NestedProperty)-1 do begin - case NestedProperty[j].PropertyType of - ptRawByteString, - ptRawJSON, - ptRawUTF8: {$ifdef FPC}Finalize(PRawByteString(Data)^){$else}PRawByteString(Data)^ := ''{$endif}; - ptString: PString(Data)^ := ''; - ptSynUnicode: PSynUnicode(Data)^ := ''; - {$ifdef HASVARUSTRING} - ptUnicodeString: PUnicodeString(Data)^ := ''; - {$endif} - ptWideString: PWideString(Data)^ := ''; - ptArray: NestedProperty[j].FinalizeNestedArray(PPtrUInt(Data)^); - {$ifndef NOVARIANTS} - ptVariant: VarClear(PVariant(Data)^); - {$endif} - ptRecord: begin - NestedProperty[j].FinalizeNestedRecord(Data); - continue; - end; - ptCustom: - TJSONCustomParserCustom(NestedProperty[j]).FinalizeItem(Data); - end; - inc(Data,NestedProperty[j].fDataSize); - end; -end; - -procedure TJSONCustomParserRTTI.FinalizeNestedArray(var Data: PtrUInt); -var i: integer; - p: PDynArrayRec; - ItemData: PByte; -begin - if Data=0 then - exit; - ItemData := pointer(Data); - p := pointer(Data); - dec(p); - Data := 0; - if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin - for i := 1 to p^.length do - FinalizeNestedRecord(ItemData); - FreeMem(p); - end; -end; - -procedure TJSONCustomParserRTTI.AllocateNestedArray(var Data: PtrUInt; - NewLength: integer); -begin - FinalizeNestedArray(Data); - if NewLength<=0 then - exit; - pointer(Data) := AllocMem(SizeOf(TDynArrayRec)+fNestedDataSize*NewLength); - PDynArrayRec(Data)^.refCnt := 1; - PDynArrayRec(Data)^.length := NewLength; - inc(Data,SizeOf(TDynArrayRec)); -end; - -procedure TJSONCustomParserRTTI.ReAllocateNestedArray(var Data: PtrUInt; - NewLength: integer); -var OldLength: integer; - p: PDynArrayRec; -begin - p := pointer(Data); - if p=nil then - raise ESynException.CreateUTF8('%.ReAllocateNestedArray(nil)',[self]); - dec(p); - ReAllocMem(p,SizeOf(p^)+fNestedDataSize*NewLength); - OldLength := p^.length; - if NewLength>OldLength then - FillCharFast(PByteArray(p)[SizeOf(p^)+fNestedDataSize*OldLength], - fNestedDataSize*(NewLength-OldLength),0); - p^.length := NewLength; - inc(p); - Data := PtrUInt(p); -end; - -function TJSONCustomParserRTTI.ReadOneLevel(var P: PUTF8Char; var Data: PByte; - Options: TJSONCustomParserSerializationOptions{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): boolean; -var EndOfObject: AnsiChar; - function ProcessValue(const Prop: TJSONCustomParserRTTI; var P: PUTF8Char; - var Data: PByte): boolean; - var DynArray: PByte; - ArrayLen, ArrayCapacity, n, PropValueLen: integer; - wasString: boolean; - PropValue, ptr: PUTF8Char; - label Error; - begin - result := false; - P := GotoNextNotSpace(P); - case Prop.PropertyType of - ptRecord: begin - if not Prop.ReadOneLevel( - P,Data,Options{$ifndef NOVARIANTS},CustomVariantOptions{$endif}) then - exit; - EndOfObject := P^; - if P^ in [',','}'] then - inc(P); - result := true; - exit; - end; - ptArray: - if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin - P := GotoNextNotSpace(P+4); - EndOfObject := P^; - if P^<>#0 then //if P^=',' then - inc(P); - Prop.FinalizeNestedArray(PPtrUInt(Data)^); // null -> void array - end else begin - if P^<>'[' then - exit; // we expect a true array here - repeat inc(P) until P^<>' '; - // try to allocate nested array at once (if not too slow) - ArrayLen := JSONArrayCount(P,P+131072); // parse up to 128 KB here - if ArrayLen<0 then // mostly JSONArrayCount()=nil due to PMax - ArrayCapacity := 512 else - ArrayCapacity := ArrayLen; - Prop.AllocateNestedArray(PPtrUInt(Data)^,ArrayCapacity); - // read array content - if ArrayLen=0 then begin - if not NextNotSpaceCharIs(P,']') then - exit; - end else begin - n := 0; - DynArray := PPointer(Data)^; - repeat - inc(n); - if (ArrayLen<0) and (n>ArrayCapacity) then begin - ArrayCapacity := NextGrow(ArrayCapacity); - Prop.ReAllocateNestedArray(PPtrUInt(Data)^,ArrayCapacity); - DynArray := PPointer(Data)^; - inc(DynArray,pred(n)*Prop.fNestedDataSize); - end; - if Prop.NestedProperty[0].PropertyName='' then begin - // array of simple type - ptr := P; - if not ProcessValue(Prop.NestedProperty[0],ptr,DynArray) or (ptr=nil) then - goto Error; - P := ptr; - end else begin - // array of record - ptr := P; - if not Prop.ReadOneLevel(ptr,DynArray,Options{$ifndef NOVARIANTS}, - CustomVariantOptions{$endif}) or (ptr=nil) then - goto Error; - P := GotoNextNotSpace(ptr); - EndOfObject := P^; - if not(P^ in [',',']']) then - goto Error; - inc(P); - end; - case EndOfObject of - ',': continue; - ']': begin - if ArrayLen<0 then - Prop.ReAllocateNestedArray(PPtrUInt(Data)^,n) else - if n<>ArrayLen then - goto Error; - break; // we reached end of array - end; - else begin -Error: Prop.FinalizeNestedArray(PPtrUInt(Data)^); - exit; - end; - end; - until false; - end; - if P=nil then - exit; - P := GotoNextNotSpace(P); - EndOfObject := P^; - if P^<>#0 then //if P^=',' then - inc(P); - end; - ptCustom: begin - ptr := TJSONCustomParserCustom(Prop).CustomReader(P,Data^,EndOfObject - {$ifndef NOVARIANTS},CustomVariantOptions{$endif}); - if ptr=nil then - exit; - P := ptr; - end; - {$ifndef NOVARIANTS} - ptVariant: - P := VariantLoadJSON(PVariant(Data)^,P,@EndOfObject, - @JSON_OPTIONS[soCustomVariantCopiedByReference in Options]); - {$endif} - ptRawByteString: begin - PropValue := GetJSONField(P,ptr,@wasString,@EndOfObject,@PropValueLen); - if PropValue=nil then // null -> Blob='' - PRawByteString(Data)^ := '' else - if not Base64MagicCheckAndDecode(PropValue,PropValueLen,PRawByteString(Data)^) then - exit; - P := ptr; - end; - ptRawJSON: - GetJSONItemAsRawJSON(P,PRawJSON(Data)^,@EndOfObject); - else begin - PropValue := GetJSONField(P,ptr,@wasString,@EndOfObject,@PropValueLen); - if (PropValue<>nil) and // PropValue=nil for null - (wasString<>(Prop.PropertyType in [ptRawUTF8,ptString,ptSynUnicode, - {$ifdef HASVARUSTRING}ptUnicodeString,{$endif} - ptDateTime,ptDateTimeMS,ptGUID,ptWideString])) then - exit; - P := ptr; - case Prop.PropertyType of - ptBoolean: PBoolean(Data)^ := GetBoolean(PropValue); - ptByte: PByte(Data)^ := GetCardinal(PropValue); - ptCardinal: PCardinal(Data)^ := GetCardinal(PropValue); - ptCurrency: PInt64(Data)^ := StrToCurr64(PropValue); - ptDouble: unaligned(PDouble(Data)^) := GetExtended(PropValue); - ptExtended: PExtended(Data)^ := GetExtended(PropValue); - ptInt64,ptID,ptTimeLog: SetInt64(PropValue,PInt64(Data)^); - ptQWord: SetQWord(PropValue,PQWord(Data)^); - ptInteger: PInteger(Data)^ := GetInteger(PropValue); - ptSingle: PSingle(Data)^ := GetExtended(PropValue); - ptRawUTF8: FastSetString(PRawUTF8(Data)^,PropValue,PropValueLen); - ptString: UTF8DecodeToString(PropValue,PropValueLen,PString(Data)^); - ptSynUnicode:UTF8ToSynUnicode(PropValue,PropValueLen,PSynUnicode(Data)^); - {$ifdef HASVARUSTRING} - ptUnicodeString:UTF8DecodeToUnicodeString(PropValue,PropValueLen,PUnicodeString(Data)^); - {$endif} - ptDateTime, ptDateTimeMS: Iso8601ToDateTimePUTF8CharVar( - PropValue,PropValueLen,PDateTime(Data)^); - ptWideString:UTF8ToWideString(PropValue,PropValueLen,PWideString(Data)^); - ptWord: PWord(Data)^ := GetCardinal(PropValue); - ptGUID: TextToGUID(PropValue,pointer(Data)); - end; - end; - end; - inc(Data,Prop.fDataSize); - result := true; - end; -var i,j: integer; - PropName: shortstring; - ptr: PUTF8Char; - Values: array of PUTF8Char; -begin - result := false; - if P=nil then - exit; - P := GotoNextNotSpace(P); - if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin - P := GotoNextNotSpace(P+4); // a record stored as null - inc(Data,fDataSize); - result := true; - exit; - end; - EndOfObject := #0; - if not (PropertyType in [ptRecord,ptArray]) then begin - ptr := P; - result := ProcessValue(Self,P,Data); - exit; - end; - if P^<>'{' then - exit; // we expect a true object here - repeat inc(P) until (P^>' ') or (P^=#0); - if P^='}' then begin - inc(Data,fDataSize); - EndOfObject := '}'; - inc(P); - end else - for i := 0 to length(NestedProperty)-1 do begin - ptr := P; - GetJSONPropName(ptr,PropName); - if PropName='' then - exit; // invalid JSON content - P := ptr; - if IdemPropNameU(NestedProperty[i].PropertyName,@PropName[1],ord(PropName[0])) then begin - // O(1) optimistic search - if not ProcessValue(NestedProperty[i],P,Data) then - exit; - if EndOfObject='}' then begin // ignore missing properties - for j := i+1 to length(NestedProperty)-1 do - inc(Data,NestedProperty[j].fDataSize); - break; - end; - end else begin - SetLength(Values,length(NestedProperty)); // pessimistic check through all properties - repeat - for j := i to length(NestedProperty)-1 do - if (Values[j]=nil) and - IdemPropNameU(NestedProperty[j].PropertyName,@PropName[1],ord(PropName[0])) then begin - Values[j] := P; - PropName := ''; - break; - end; - if (PropName<>'') and not(soReadIgnoreUnknownFields in Options) then - exit; // unexpected property - ptr := GotoNextJSONItem(P,1,@EndOfObject); - if ptr=nil then - exit; - P := ptr; - if EndOfObject='}' then - break; - GetJSONPropName(ptr,PropName); // next name - if PropName='' then - exit; // invalid JSON content - P := ptr; - until false; - for j := i to length(NestedProperty)-1 do - if Values[j]=nil then // ignore missing properties - inc(Data,NestedProperty[j].fDataSize) else - if not ProcessValue(NestedProperty[j],Values[j],Data) then - exit; - EndOfObject := '}'; // ProcessValue() did update EndOfObject - break; - end; - end; - if (P<>nil) and (EndOfObject=',') and (soReadIgnoreUnknownFields in Options) then begin - ptr := GotoNextJSONObjectOrArray(P,'}'); - if ptr=nil then - exit; - P := ptr; - end else - if EndOfObject<>'}' then - exit; - if P<>nil then - P := GotoNextNotSpace(P); - result := true; -end; - -function Plural(const itemname: shortstring; itemcount: cardinal): shortstring; -var len,L: PtrInt; -begin - len := (AppendUInt32ToBuffer(@result[1],itemcount)-PUTF8Char(@result[1]))+1; - result[len] := ' '; - L := ord(itemname[0]); - if L in [1..240] then begin // avoid buffer overflow - MoveSmall(@itemname[1],@result[len+1],L); - inc(len,L); - if itemcount>1 then begin - inc(len); - result[len] := 's'; - end; - end; - result[0] := AnsiChar(len); -end; - -function TJSONCustomParserRTTI.IfDefaultSkipped(var Value: PByte): boolean; -begin - case PropertyType of - ptBoolean: result := not PBoolean(Value)^; - ptByte: result := PByte(Value)^=0; - ptWord: result := PWord(Value)^=0; - ptInteger,ptCardinal,ptSingle: - result := PInteger(Value)^=0; - ptCurrency,ptDouble,ptInt64,ptQWord,ptID,ptTimeLog,ptDateTime,ptDateTimeMS: - result := PInt64(Value)^=0; - ptExtended: result := PExtended(Value)^=0; - {$ifndef NOVARIANTS} - ptVariant: result := integer(PVarData(Value)^.VType)<=varNull; - {$endif} - ptRawJSON,ptRawByteString,ptRawUTF8,ptString,ptSynUnicode,ptWideString, - {$ifdef HASVARUSTRING}ptUnicodeString,{$endif}ptArray: - result := PPointer(Value)^=nil; - ptGUID: result := IsNullGUID(PGUID(Value)^); - ptRecord: result := IsZero(Value,fDataSize); - else result := false; - end; - if result then - inc(Value,fDataSize); -end; - -procedure TJSONCustomParserRTTI.WriteOneSimpleValue(aWriter: TTextWriter; var Value: PByte; - Options: TJSONCustomParserSerializationOptions); -var DynArray: PByte; - j: integer; -begin - case PropertyType of - ptBoolean: aWriter.Add(PBoolean(Value)^); - ptByte: aWriter.AddU(PByte(Value)^); - ptCardinal: aWriter.AddU(PCardinal(Value)^); - ptCurrency: aWriter.AddCurr64(PInt64(Value)^); - ptDouble: aWriter.AddDouble(unaligned(PDouble(Value)^)); - ptExtended: aWriter.Add(PExtended(Value)^,EXTENDED_PRECISION); - ptInt64,ptID,ptTimeLog: - aWriter.Add(PInt64(Value)^); - ptQWord: aWriter.AddQ(PQWord(Value)^); - ptInteger: aWriter.Add(PInteger(Value)^); - ptSingle: aWriter.AddSingle(PSingle(Value)^); - ptWord: aWriter.AddU(PWord(Value)^); - {$ifndef NOVARIANTS} - ptVariant: aWriter.AddVariant(PVariant(Value)^,twJSONEscape); - {$endif} - ptRawJSON: aWriter.AddRawJSON(PRawJSON(Value)^); - ptRawByteString: - aWriter.WrBase64(PPointer(Value)^,length(PRawByteString(Value)^),{withMagic=}true); - ptRawUTF8, ptString, ptSynUnicode,{$ifdef HASVARUSTRING}ptUnicodeString,{$endif} - ptDateTime, ptDateTimeMS, ptGUID, ptWideString: begin - aWriter.Add('"'); - case PropertyType of - ptRawUTF8: aWriter.AddJSONEscape(PPointer(Value)^); - ptString: aWriter.AddJSONEscapeString(PString(Value)^); - ptSynUnicode,{$ifdef HASVARUSTRING}ptUnicodeString,{$endif} - ptWideString: aWriter.AddJSONEscapeW(PPointer(Value)^); - ptDateTime: aWriter.AddDateTime(unaligned(PDateTime(Value)^),{withms=}false); - ptDateTimeMS: aWriter.AddDateTime(unaligned(PDateTime(Value)^),true); - ptGUID: aWriter.Add(PGUID(Value)^); - end; - aWriter.Add('"'); - end; - ptArray: begin - aWriter.Add('['); - inc(aWriter.fHumanReadableLevel); - DynArray := PPointer(Value)^; - if DynArray<>nil then - for j := 1 to DynArrayLength(DynArray) do begin - if soWriteHumanReadable in Options then - aWriter.AddCRAndIndent; - if NestedProperty[0].PropertyName='' then // array of simple - NestedProperty[0].WriteOneSimpleValue(aWriter,DynArray,Options) else - WriteOneLevel(aWriter,DynArray,Options); // array of record - aWriter.Add(','); - {$ifdef ALIGNCUSTOMREC} - if PtrUInt(DynArray)and 7<>0 then - inc(DynArray,8-(PtrUInt(DynArray)and 7)); - {$endif} - end; - aWriter.CancelLastComma; - aWriter.Add(']'); - dec(aWriter.fHumanReadableLevel); - end; - ptRecord: begin - WriteOneLevel(aWriter,Value,Options); - exit; - end; - ptCustom: - TJSONCustomParserCustom(self).CustomWriter(aWriter,Value^); - end; - inc(Value,fDataSize); -end; - -procedure TJSONCustomParserRTTI.WriteOneLevel(aWriter: TTextWriter; var P: PByte; - Options: TJSONCustomParserSerializationOptions); -var i: integer; - SubProp: TJSONCustomParserRTTI; -begin - if P=nil then begin - aWriter.AddShort('null'); - exit; - end; - if not (PropertyType in [ptRecord,ptArray]) then begin - WriteOneSimpleValue(aWriter,P,Options); - exit; - end; - aWriter.Add('{'); - Inc(aWriter.fHumanReadableLevel); - for i := 0 to length(NestedProperty)-1 do begin - SubProp := NestedProperty[i]; - if soWriteIgnoreDefault in Options then - if SubProp.IfDefaultSkipped(P) then - continue; - if soWriteHumanReadable in Options then - aWriter.AddCRAndIndent; - aWriter.AddFieldName(SubProp.PropertyName); - if soWriteHumanReadable in Options then - aWriter.Add(' '); - SubProp.WriteOneSimpleValue(aWriter,P,Options); - aWriter.Add(','); - end; - aWriter.CancelLastComma; - dec(aWriter.fHumanReadableLevel); - if soWriteHumanReadable in Options then - aWriter.AddCRAndIndent; - aWriter.Add('}'); -end; - - -{ TJSONRecordAbstract } - -constructor TJSONRecordAbstract.Create; -begin - fItems := TSynObjectList.Create; -end; - -function TJSONRecordAbstract.AddItem(const aPropertyName: RawUTF8; - aPropertyType: TJSONCustomParserRTTIType; - const aCustomRecordTypeName: RawUTF8): TJSONCustomParserRTTI; -begin - if aPropertyType=ptCustom then begin - result := TJSONCustomParserRTTI.CreateFromTypeName( - aPropertyName,aCustomRecordTypeName); - if result=nil then - raise ESynException.CreateUTF8('Unregistered ptCustom for %.AddItem(%: %)', - [self,aPropertyName,aCustomRecordTypeName]); - end else - result := TJSONCustomParserRTTI.Create(aPropertyName,aPropertyType); - fItems.Add(result); -end; - -function TJSONRecordAbstract.CustomReader(P: PUTF8Char; var aValue; - out aValid: Boolean{$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; -var Data: PByte; - EndOfObject: AnsiChar; -begin - if Root.PropertyType=ptCustom then begin - result := TJSONCustomParserCustom(Root).CustomReader(P,aValue,EndOfObject - {$ifndef NOVARIANTS},CustomVariantOptions{$endif}); - aValid := result<>nil; - if (EndOfObject<>#0) and aValid then begin - dec(result); - result^ := EndOfObject; // emulates simple read - end; - exit; - end; - Data := @aValue; - aValid := Root.ReadOneLevel(P,Data,Options{$ifndef NOVARIANTS},CustomVariantOptions{$endif}); - result := P; -end; - -procedure TJSONRecordAbstract.CustomWriter(const aWriter: TTextWriter; const aValue); -var P: PByte; - o: TJSONCustomParserSerializationOptions; -begin - P := @aValue; - o := Options; - if twoIgnoreDefaultInRecord in aWriter.CustomOptions then - include(o,soWriteIgnoreDefault); - Root.WriteOneLevel(aWriter,P,o); -end; - -destructor TJSONRecordAbstract.Destroy; -begin - FreeAndNil(fItems); - inherited; -end; - - -{ TJSONRecordTextDefinition } - -var - JSONCustomParserCache: TRawUTF8List; - -class function TJSONRecordTextDefinition.FromCache(aTypeInfo: pointer; - const aDefinition: RawUTF8): TJSONRecordTextDefinition; -begin - if JSONCustomParserCache=nil then - GarbageCollectorFreeAndNil(JSONCustomParserCache, - TRawUTF8List.Create([fObjectsOwned,fNoDuplicate,fCaseSensitive])); - result := JSONCustomParserCache.GetObjectFrom(aDefinition); - if result<>nil then - exit; - result := TJSONRecordTextDefinition.Create(aTypeInfo,aDefinition); - JSONCustomParserCache.AddObjectUnique(aDefinition,@result); -end; - -constructor TJSONRecordTextDefinition.Create(aRecordTypeInfo: pointer; - const aDefinition: RawUTF8); -var P: PUTF8Char; - recordInfoSize: integer; -begin - inherited Create; - fDefinition := aDefinition; - fRoot := TJSONCustomParserRTTI.Create('',ptRecord); - TypeInfoToName(aRecordTypeInfo,fRoot.fCustomTypeName); - fItems.Add(fRoot); - P := pointer(aDefinition); - Parse(fRoot,P,eeNothing); - fRoot.ComputeDataSizeAfterAdd; - recordInfoSize := RecordTypeInfoSize(aRecordTypeInfo); - if (recordInfoSize<>0) and (fRoot.fDataSize<>recordInfoSize) then - raise ESynException.CreateUTF8('%.Create: % text definition is not accurate,'+ - ' or the type has not been defined as PACKED record: RTTI size is %'+ - ' bytes but text definition covers % bytes', - [self,fRoot.fCustomTypeName,recordInfoSize,fRoot.fDataSize]); -end; - -function DynArrayItemTypeLen(const aDynArrayTypeName: RawUTF8): PtrInt; -begin - result := length(aDynArrayTypeName); - if (result>12) and IdemPropName('DynArray',@PByteArray(aDynArrayTypeName)[result-8],8) then - dec(result,8) else - if (result>3) and (aDynArrayTypeName[result] in ['s','S']) then - dec(result) else - result := 0; -end; - -function DynArrayItemTypeIsSimpleBinary(const aDynArrayTypeName: RawUTF8): boolean; -var itemLen,dataSize,fieldSize: integer; -begin - itemLen := DynArrayItemTypeLen(aDynArrayTypeName); - result := (itemLen>0) and TJSONCustomParserRTTI.TypeNameToSimpleBinary( - copy(aDynArrayTypeName,1,itemLen),dataSize,fieldSize); -end; - -procedure TJSONRecordTextDefinition.Parse(Props: TJSONCustomParserRTTI; - var P: PUTF8Char; PEnd: TJSONCustomParserRTTIExpectedEnd); - function GetNextFieldType(var P: PUTF8Char; - var TypIdent: RawUTF8): TJSONCustomParserRTTIType; - begin - if GetNextFieldProp(P,TypIdent) then - result := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( - pointer(TypIdent),length(TypIdent),@TypIdent) else - raise ESynException.CreateUTF8('%.Parse: missing field type',[self]); - end; -var PropsName: TRawUTF8DynArray; - PropsMax, ndx, len, firstNdx: cardinal; - Typ, ArrayTyp: TJSONCustomParserRTTIType; - TypIdent, ArrayTypIdent: RawUTF8; - Item: TJSONCustomParserRTTI; - ExpectedEnd: TJSONCustomParserRTTIExpectedEnd; -begin - SetLength(PropsName,16); - PropsMax := 0; - while (P<>nil) and (P^<>#0) do begin - // fill Props[] - if P^ in ['''','"'] then begin // parse identifier as SQL string (e.g. "@field0") - P := UnQuoteSQLStringVar(P,PropsName[PropsMax]); - if P=nil then - break; - end else // regular object pascal identifier (i.e. 0..9,a..z,A..Z,_) - if not GetNextFieldProp(P,PropsName[PropsMax]) then - break; - case P^ of - ',': begin - inc(P); - inc(PropsMax); - if PropsMax=cardinal(length(PropsName)) then - SetLength(PropsName,PropsMax+16); - continue; // several properties defined with the same type - end; - ':': P := GotoNextNotSpace(P+1); - end; - // identify type - ArrayTyp := ptRecord; - if P^='{' then begin - Typ := ptRecord; - ExpectedEnd := eeCurly; - repeat inc(P) until (P^>' ') or (P^=#0); - end else - if P^='[' then begin - Typ := ptArray; - ExpectedEnd := eeSquare; - repeat inc(P) until (P^>' ') or (P^=#0); - end else begin - Typ := GetNextFieldType(P,TypIdent); - case Typ of - ptArray: begin - if IdemPChar(P,'OF') then begin - P := GotoNextNotSpace(P+2); - ArrayTyp := GetNextFieldType(P,ArrayTypIdent); - if ArrayTyp=ptArray then - P := nil; - end else - P := nil; - if P=nil then - raise ESynException.CreateUTF8('%.Parse: expected syntax is '+ - '"array of record" or "array of SimpleType"',[self]); - if ArrayTyp=ptRecord then - ExpectedEnd := eeEndKeyWord else - ExpectedEnd := eeNothing; - end; - ptRecord: - ExpectedEnd := eeEndKeyWord; - ptCustom: begin - len := DynArrayItemTypeLen(TypIdent); - if len>0 then begin - ArrayTyp := TJSONCustomParserRTTI.TypeNameToSimpleRTTIType( - @PByteArray(TypIdent)[1],len-1,@ArrayTypIdent); // TByteDynArray -> byte - if ArrayTyp=ptCustom then begin // TMyTypeDynArray/TMyTypes -> TMyType - FastSetString(ArrayTypIdent,pointer(TypIdent),len); - if GlobalCustomJSONSerializerFromTextSimpleType.Find(ArrayTypIdent)>=0 then - Typ := ptArray; - end else - Typ := ptArray; - end; - ExpectedEnd := eeNothing; - end; - else ExpectedEnd := eeNothing; - end; - end; - // add elements - firstNdx := length(Props.fNestedProperty); - SetLength(Props.fNestedProperty,firstNdx+PropsMax+1); - for ndx := 0 to PropsMax do begin - Item := AddItem(PropsName[ndx],Typ,TypIdent); - Props.fNestedProperty[firstNdx+ndx] := Item; - if (Typ=ptArray) and (ArrayTyp<>ptRecord) then begin - SetLength(Item.fNestedProperty,1); - Item.fNestedProperty[0] := AddItem('',ArrayTyp,ArrayTypIdent); - end else - if Typ in [ptArray,ptRecord] then - if ndx=0 then // only parse once multiple fields nested type - Parse(Item,P,ExpectedEnd) else - Item.fNestedProperty := Props.fNestedProperty[firstNdx].fNestedProperty; - Item.ComputeDataSizeAfterAdd; - end; - // validate expected end - while P^ in [#1..' ',';'] do inc(P); - case PEnd of - eeEndKeyWord: - if IdemPChar(P,'END') then begin - inc(P,3); - while P^ in [#1..' ',';'] do inc(P); - break; - end; - eeSquare: - if P^=']' then begin - inc(P); - break; - end; - eeCurly: - if P^='}' then begin - inc(P); - break; - end; - end; - PropsMax := 0; - end; -end; - - -{ TJSONRecordRTTI } - -constructor TJSONRecordRTTI.Create(aRecordTypeInfo: pointer; - aRoot: TJSONCustomParserRTTI); -begin - inherited Create; - fRecordTypeInfo := aRecordTypeInfo; - fRoot := aRoot; - if fRoot=nil then begin - {$ifdef ISDELPHI2010} - fRoot := TJSONCustomParserRTTI.Create('',ptRecord); - FromEnhancedRTTI(fRoot,aRecordTypeInfo); - if fRoot.fNestedDataSize<>RecordTypeInfoSize(aRecordTypeInfo) then - raise ESynException.CreateUTF8( - '%.Create: error when retrieving enhanced RTTI for %', - [self,fRoot.CustomTypeName]); - {$else} - raise ESynException.CreateUTF8('%.Create with no enhanced RTTI for %', - [self,PShortString(@PTypeInfo(aRecordTypeInfo).NameLen)^]); - {$endif} - end; - fItems.Add(fRoot); - GarbageCollector.Add(self); -end; - -function TJSONRecordRTTI.AddItemFromRTTI( - const PropertyName: RawUTF8; Info: pointer; ItemSize: integer): TJSONCustomParserRTTI; -begin - result := TJSONCustomParserRTTI.CreateFromRTTI(PropertyName,Info,ItemSize); - fItems.Add(result); -end; - -{$ifdef ISDELPHI2010} - -procedure TJSONRecordRTTI.FromEnhancedRTTI( - Props: TJSONCustomParserRTTI; Info: pointer); -var FieldTable: PTypeInfo; - i: integer; - FieldSize: cardinal; - RecField: PEnhancedFieldInfo; - ItemFields: array of PEnhancedFieldInfo; - ItemField: PTypeInfo; - ItemFieldName: RawUTF8; - ItemFieldSize: cardinal; - Item, ItemArray: TJSONCustomParserRTTI; -begin // only tkRecord is needed here - FieldTable := GetTypeInfo(Info,tkRecord); - if FieldTable=nil then - raise ESynException.CreateUTF8('%.FromEnhancedRTTI(%=record?)',[self,Info]); - FieldSize := FieldTable^.recSize; - inc(PByte(FieldTable),FieldTable^.ManagedCount*SizeOf(TFieldInfo)-SizeOf(TFieldInfo)); - inc(PByte(FieldTable),FieldTable^.NumOps*SizeOf(pointer)); // jump RecOps[] - if FieldTable^.AllCount=0 then - exit; // not enough RTTI -> will raise an error in Create() - TypeInfoToName(Info,Props.fCustomTypeName); - RecField := @FieldTable^.AllFields[0]; - SetLength(ItemFields,FieldTable^.AllCount); - for i := 0 to FieldTable^.AllCount-1 do begin - ItemFields[i] := RecField; - inc(PByte(RecField),RecField^.NameLen); // Delphi: no AlignPtr() needed - inc(RecField); - inc(PByte(RecField),PWord(RecField)^); - end; - SetLength(Props.fNestedProperty,FieldTable^.AllCount); - for i := 0 to FieldTable^.AllCount-1 do begin - if i=FieldTable^.AllCount-1 then - ItemFieldSize := FieldSize-ItemFields[i].Offset else - ItemFieldSize := ItemFields[i+1].Offset-ItemFields[i].Offset; - ItemField := Deref(ItemFields[i]^.TypeInfo); - FastSetString(ItemFieldName,PAnsiChar(@ItemFields[i]^.NameLen)+1,ItemFields[i]^.NameLen); - Item := AddItemFromRTTI(ItemFieldName,ItemField,ItemFieldSize); - Props.fNestedProperty[i] := Item; - case Item.PropertyType of - ptArray: begin - inc(PByte(ItemField),ItemField^.NameLen); - ItemArray := AddItemFromRTTI('',Deref(ItemField^.elType2), - ItemField^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}); - if (ItemArray.PropertyType=ptCustom) and - (ItemArray.ClassType=TJSONCustomParserRTTI) then - FromEnhancedRTTI(Item,Deref(ItemField^.elType2)) else begin - SetLength(Item.fNestedProperty,1); - Item.fNestedProperty[0] := ItemArray; - Item.ComputeNestedDataSize; - end; - end; - ptCustom: - if (ItemField<>nil) and (Item.ClassType=TJSONCustomParserRTTI) then - FromEnhancedRTTI(Item,ItemField); - end; - end; - Props.ComputeNestedDataSize; -end; - -{$endif ISDELPHI2010} - - -{ ************ variant-based process, including JSON/BSON document content } - -{$ifndef LVCL} - -procedure RawByteStringToVariant(Data: PByte; DataLen: Integer; var Value: variant); -begin - ClearVariantForString(Value); - if (Data=nil) or (DataLen<=0) then - TVarData(Value).VType := varNull else - SetString(RawByteString(TVarData(Value).VAny),PAnsiChar(Data),DataLen); -end; - -procedure RawByteStringToVariant(const Data: RawByteString; var Value: variant); -begin - ClearVariantForString(Value); - if Data='' then - TVarData(Value).VType := varNull else - RawByteString(TVarData(Value).VAny) := Data; -end; - -procedure VariantToRawByteString(const Value: variant; var Dest: RawByteString); -begin - case integer(TVarData(Value).VType) of - varEmpty, varNull: - Dest := ''; - varString: - Dest := RawByteString(TVarData(Value).VAny); - else // not from RawByteStringToVariant() -> conversion to string - Dest := {$ifdef UNICODE}RawByteString{$else}string{$endif}(Value); - end; -end; - -procedure SetVariantNull(var Value: variant); -begin // slightly faster than Value := Null - VarClear(Value); - TVarData(Value).VType := varNull; -end; - -{$endif LVCL} - -function VarDataIsEmptyOrNull(VarData: pointer): Boolean; -var vt: cardinal; -begin - repeat - vt := PVarData(VarData)^.VType; - if vt<>varVariant or varByRef then - break; - VarData := PVarData(VarData)^.VPointer; - if VarData=nil then begin - result := true; - exit; - end; - until false; - result := (vt<=varNull) or (vt=varNull or varByRef); -end; - -function VarIsEmptyOrNull(const V: Variant): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function VarIs(const V: Variant; const VTypes: TVarDataTypes): Boolean; -var VD: PVarData; - vt: cardinal; -begin - VD := @V; - repeat - vt := VD^.VType; - if vt<>varVariant or varByRef then - break; - VD := VD^.VPointer; - if VD=nil then begin - result := false; - exit; - end; - until false; - result := vt in VTypes; -end; - -function VarIsVoid(const V: Variant): boolean; -var vt: cardinal; -begin - vt := TVarData(V).VType; - with TVarData(V) do - case vt of - varEmpty,varNull: - result := true; - varBoolean: - result := not VBoolean; - varString,varOleStr{$ifdef HASVARUSTRING},varUString{$endif}: - result := VAny=nil; - varDate: - result := VInt64=0; - else - if vt=varVariant or varByRef then - result := VarIsVoid(PVariant(VPointer)^) else - if (vt=varByRef or varString) or (vt=varByRef or varOleStr) - {$ifdef HASVARUSTRING} or (vt=varByRef or varUString) {$endif} then - result := PPointer(VAny)^=nil else - {$ifndef NOVARIANTS} - if vt=cardinal(DocVariantVType) then - result := TDocVariantData(V).Count=0 else - {$endif} - result := false; - end; -end; - -function VarStringOrNull(const v: RawUTF8): variant; -begin - if v='' then - SetVariantNull(result) else - {$ifdef NOVARIANTS} result := v {$else} RawUTF8ToVariant(v,result) {$endif}; -end; - -{$ifndef NOVARIANTS} - -/// internal method used by VariantLoadJSON(), GetVariantFromJSON() and -// TDocVariantData.InitJSONInPlace() -procedure GetJSONToAnyVariant(var Value: variant; var JSON: PUTF8Char; - EndOfObject: PUTF8Char; Options: PDocVariantOptions; AllowDouble: boolean); forward; - -procedure SetVariantByRef(const Source: Variant; var Dest: Variant); -var vt: cardinal; -begin - VarClear(Dest); - vt := TVarData(Source).VType; - if ((vt and varByRef)<>0) or (vt in [varEmpty..varDate,varBoolean,varShortInt..varWord64]) then - TVarData(Dest) := TVarData(Source) else - if not SetVariantUnRefSimpleValue(Source,TVarData(Dest)) then begin - TVarData(Dest).VType := varVariant or varByRef; - TVarData(Dest).VPointer := @Source; - end; -end; - -procedure SetVariantByValue(const Source: Variant; var Dest: Variant); -var s: PVarData; - d: TVarData absolute Dest; - vt: cardinal; -begin - s := @Source; - VarClear(Dest); - vt := s^.VType; - if vt=varVariant or varByRef then begin - s := s^.VPointer; - vt := s^.VType; - end; - case vt of - varEmpty..varDate,varBoolean,varShortInt..varWord64: begin - d.VType := vt; - d.VInt64 := s^.VInt64; - end; - varString: begin - d.VType := varString; - d.VAny := nil; - RawByteString(d.VAny) := RawByteString(s^.VAny); - end; - varByRef or varString: begin - d.VType := varString; - d.VAny := nil; - RawByteString(d.VAny) := PRawByteString(s^.VAny)^; - end; - {$ifdef HASVARUSTRING} varUString, varByRef or varUString, {$endif} - varOleStr, varByRef or varOleStr: begin - d.VType := varString; - d.VAny := nil; - VariantToUTF8(PVariant(s)^,RawUTF8(d.VAny)); // store a RawUTF8 instance - end; - else - if not SetVariantUnRefSimpleValue(PVariant(s)^,d) then - if vt=cardinal(DocVariantVType) then - DocVariantType.CopyByValue(d,s^) else - Dest := PVariant(s)^; - end; -end; - -procedure ZeroFill(Value: PVarData); -begin // slightly faster than FillChar(Value,SizeOf(Value),0); - PInt64Array(Value)^[0] := 0; - PInt64Array(Value)^[1] := 0; - {$ifdef CPU64} - //assert(SizeOf(TVarData)=24); - PInt64Array(Value)^[2] := 0; - {$endif} -end; - -procedure FillZero(var value: variant); -begin - with TVarData(Value) do - if cardinal(VType)=varString then - FillZero(RawByteString(VString)); - VarClear(Value); -end; - -procedure RawUTF8ToVariant(Txt: PUTF8Char; TxtLen: integer; var Value: variant); -begin - ClearVariantForString(Value); - FastSetString(RawUTF8(TVarData(Value).VString), Txt, TxtLen); -end; - -procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: variant); -begin - ClearVariantForString(Value); - if Txt='' then - exit; - RawByteString(TVarData(Value).VString) := Txt; - {$ifdef HASCODEPAGE} // force explicit UTF-8 - SetCodePage(RawByteString(TVarData(Value).VAny),CP_UTF8,false); - {$endif HASCODEPAGE} -end; - -procedure FormatUTF8ToVariant(const Fmt: RawUTF8; const Args: array of const; - var Value: variant); -begin - RawUTF8ToVariant(FormatUTF8(Fmt,Args),Value); -end; - -function RawUTF8ToVariant(const Txt: RawUTF8): variant; -begin - RawUTF8ToVariant(Txt,result); -end; - -procedure RawUTF8ToVariant(const Txt: RawUTF8; var Value: TVarData; - ExpectedValueType: cardinal); -begin - if ExpectedValueType=varString then begin - RawUTF8ToVariant(Txt,variant(Value)); - exit; - end; - VarClear(variant(Value)); - Value.VType := ExpectedValueType; - Value.VAny := nil; // avoid GPF below - if Txt<>'' then - case ExpectedValueType of - varOleStr: - UTF8ToWideString(Txt,WideString(Value.VAny)); - {$ifdef HASVARUSTRING} - varUString: - UTF8DecodeToUnicodeString(pointer(Txt),length(Txt),UnicodeString(Value.VAny)); - {$endif} - else raise ESynException.CreateUTF8('RawUTF8ToVariant(ExpectedValueType=%)', - [ExpectedValueType]); - end; -end; - -function VariantSave(const Value: variant; Dest: PAnsiChar): PAnsiChar; - procedure ComplexType; - begin - try - Dest := pointer(ToVarString(VariantSaveJSON(Value),PByte(Dest))); - except - on Exception do - Dest := nil; // notify invalid/unhandled variant content - end; - end; -var LenBytes: integer; - tmp: TVarData; -begin - with TVarData(Value) do - if VType and varByRef<>0 then - if VType=varVariant or varByRef then begin - result := VariantSave(PVariant(VPointer)^,Dest); - exit; - end else - if SetVariantUnRefSimpleValue(Value,tmp) then begin - result := VariantSave(variant(tmp),Dest-SizeOf(VType)); - exit; - end; - with TVarData(Value) do begin - PWord(Dest)^ := VType; - inc(Dest,SizeOf(VType)); - case VType of - varNull, varEmpty: ; - varShortInt, varByte: begin - Dest^ := AnsiChar(VByte); - inc(Dest); - end; - varSmallint, varWord, varBoolean: begin - PWord(Dest)^ := VWord; - inc(Dest,SizeOf(VWord)); - end; - varSingle, varLongWord, varInteger: begin - PInteger(Dest)^ := VInteger; - inc(Dest,SizeOf(VInteger)); - end; - varInt64, varWord64, varDouble, varDate, varCurrency:begin - PInt64(Dest)^ := VInt64; - inc(Dest,SizeOf(VInt64)); - end; - varString, varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin - if PtrUInt(VAny)=0 then - LenBytes := 0 else begin - LenBytes := PStrLen(PtrUInt(VAny)-_STRLEN)^; - {$ifdef HASVARUSTRING} - if VType=varUString then - LenBytes := LenBytes*2; // stored length is in bytes, not (wide)chars - {$endif} - end; - Dest := pointer(ToVarUInt32(LenBytes,pointer(Dest))); - if LenBytes>0 then begin // direct raw copy - MoveFast(PPtrUInt(VAny)^,Dest^,LenBytes); - inc(Dest,LenBytes); - end; - end; - else ComplexType; // complex types are stored as JSON - end; - end; - result := Dest; -end; - -function VariantSaveLength(const Value: variant): integer; -var tmp: TVarData; - v: TVarData absolute Value; -begin // match VariantSave() storage - if v.VType and varByRef<>0 then - if v.VType=varVariant or varByRef then begin - result := VariantSaveLength(PVariant(v.VPointer)^); - exit; - end else - if SetVariantUnRefSimpleValue(Value,tmp) then begin - result := VariantSaveLength(variant(tmp)); - exit; - end; - case v.VType of - varEmpty, varNull: - result := SizeOf(tmp.VType); - varShortInt, varByte: - result := SizeOf(tmp.VByte)+SizeOf(tmp.VType); - varSmallint, varWord, varBoolean: - result := SizeOf(tmp.VSmallint)+SizeOf(tmp.VType); - varSingle, varLongWord, varInteger: - result := SizeOf(tmp.VInteger)+SizeOf(tmp.VType); - varInt64, varWord64, varDouble, varDate, varCurrency: - result := SizeOf(tmp.VInt64)+SizeOf(tmp.VType); - varString, varOleStr: - if PtrUInt(v.VAny)=0 then - result := 1+SizeOf(tmp.VType) else - result := ToVarUInt32LengthWithData( - PStrLen(PtrUInt(v.VAny)-_STRLEN)^)+SizeOf(tmp.VType); - {$ifdef HASVARUSTRING} - varUString: - if PtrUInt(v.VAny)=0 then // stored length is in bytes, not (wide)chars - result := 1+SizeOf(tmp.VType) else - result := ToVarUInt32LengthWithData( - PStrLen(PtrUInt(v.VAny)-_STRLEN)^*2)+SizeOf(tmp.VType); - {$endif} - else - try // complex types will be stored as JSON - result := ToVarUInt32LengthWithData(VariantSaveJSONLength(Value))+SizeOf(tmp.VType); - except - on Exception do - result := 0; // notify invalid/unhandled variant content - end; - end; -end; - -function VariantSave(const Value: variant): RawByteString; -var P: PAnsiChar; -begin - SetString(result,nil,VariantSaveLength(Value)); - P := VariantSave(Value,pointer(result)); - if P-pointer(result)<>length(result) then - raise ESynException.Create('VariantSave length'); -end; - -function VariantLoad(const Bin: RawByteString; - CustomVariantOptions: PDocVariantOptions): variant; -begin - if VariantLoad(result,Pointer(Bin),CustomVariantOptions, - PAnsiChar(pointer(Bin))+length(Bin))=nil then - VarClear(result); -end; - -function VariantLoad(var Value: variant; Source: PAnsiChar; - CustomVariantOptions: PDocVariantOptions; SourceMax: PAnsiChar): PAnsiChar; -var JSON: PUTF8Char; - n: cardinal; - tmp: TSynTempBuffer; // GetJSON*() does in-place unescape -> private copy -begin - result := nil; // error - VarClear(Value); - if (SourceMax<>nil) and (Source+2>SourceMax) then exit; - TVarData(Value).VType := PWord(Source)^; - inc(Source,SizeOf(TVarData(Value).VType)); - case TVarData(Value).VType of - varNull, varEmpty: ; - varShortInt, varByte: begin - if (SourceMax<>nil) and (Source>=SourceMax) then exit; - TVarData(Value).VByte := byte(Source^); - inc(Source); - end; - varSmallint, varWord, varBoolean: begin - if (SourceMax<>nil) and (Source+2>SourceMax) then exit; - TVarData(Value).VWord := PWord(Source)^; - inc(Source,SizeOf(Word)); - end; - varSingle, varLongWord, varInteger: begin - if (SourceMax<>nil) and (Source+4>SourceMax) then exit; - TVarData(Value).VInteger := PInteger(Source)^; - inc(Source,SizeOf(Integer)); - end; - varInt64, varWord64, varDouble, varDate, varCurrency: begin - if (SourceMax<>nil) and (Source+8>SourceMax) then exit; - TVarData(Value).VInt64 := PInt64(Source)^; - inc(Source,SizeOf(Int64)); - end; - varString, varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin - TVarData(Value).VAny := nil; // avoid GPF below when assigning a string variable to VAny - if not FromVarUInt32(PByte(Source),PByte(SourceMax),n) or - ((SourceMax<>nil) and (Source+n>SourceMax)) then - exit; - case TVarData(Value).VType of - varString: - FastSetString(RawUTF8(TVarData(Value).VString),Source,n); // explicit RawUTF8 - varOleStr: - SetString(WideString(TVarData(Value).VAny),PWideChar(Source),n shr 1); - {$ifdef HASVARUSTRING} - varUString: - SetString(UnicodeString(TVarData(Value).VAny),PWideChar(Source),n shr 1); - {$endif} - end; - inc(Source,n); - end; - else - if CustomVariantOptions<>nil then begin - try // expected format for complex type is JSON (VType may differ) - if FromVarString(PByte(Source),PByte(SourceMax),tmp) then - try - JSON := tmp.buf; - TVarData(Value).VType := varEmpty; // avoid GPF below - GetJSONToAnyVariant(Value,JSON,nil,CustomVariantOptions,false); - finally - tmp.Done; - end else - exit; - except - on Exception do - exit; // notify invalid/unhandled variant content - end; - end else - exit; - end; - result := Source; -end; - -procedure FromVarVariant(var Source: PByte; var Value: variant; - CustomVariantOptions: PDocVariantOptions); -begin - Source := PByte(VariantLoad(Value,PAnsiChar(Source),CustomVariantOptions)); -end; - -function VariantLoadJSON(var Value: variant; JSON: PUTF8Char; EndOfObject: PUTF8Char; - TryCustomVariants: PDocVariantOptions; AllowDouble: boolean): PUTF8Char; -var wasString: boolean; - Val: PUTF8Char; -begin - result := JSON; - if JSON=nil then - exit; - if TryCustomVariants<>nil then begin - if dvoJSONObjectParseWithinString in TryCustomVariants^ then begin - JSON := GotoNextNotSpace(JSON); - if JSON^='"' then begin - Val := GetJSONField(result,result,@wasString,EndOfObject); - GetJSONToAnyVariant(Value,Val,EndOfObject,TryCustomVariants,AllowDouble); - end else - GetJSONToAnyVariant(Value,result,EndOfObject,TryCustomVariants,AllowDouble); - end else - GetJSONToAnyVariant(Value,result,EndOfObject,TryCustomVariants,AllowDouble); - end else begin - Val := GetJSONField(result,result,@wasString,EndOfObject); - GetVariantFromJSON(Val,wasString,Value,nil,AllowDouble); - end; - if result=nil then - result := @NULCHAR; // reached end, but not invalid input -end; - -procedure VariantLoadJSON(var Value: Variant; const JSON: RawUTF8; - TryCustomVariants: PDocVariantOptions; AllowDouble: boolean); -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); // temp copy before in-place decoding - try - VariantLoadJSON(Value,tmp.buf,nil,TryCustomVariants,AllowDouble); - finally - tmp.Done; - end; -end; - -function VariantLoadJSON(const JSON: RawUTF8; TryCustomVariants: PDocVariantOptions; - AllowDouble: boolean): variant; -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); - try - VariantLoadJSON(result,tmp.buf,nil,TryCustomVariants,AllowDouble); - finally - tmp.Done; - end; -end; - -function VariantSaveJSON(const Value: variant; Escape: TTextWriterKind): RawUTF8; -begin - VariantSaveJSON(Value,Escape,result); -end; - -procedure VariantSaveJSON(const Value: variant; Escape: TTextWriterKind; - var result: RawUTF8); -var temp: TTextWriterStackBuffer; -begin // not very optimized, but fast enough in practice, and creates valid JSON - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - AddVariant(Value,Escape); // may encounter TObjectVariant -> WriteObject - SetText(result); - finally - Free; - end; -end; - -function VariantSaveJSONLength(const Value: variant; Escape: TTextWriterKind): integer; -var Fake: TFakeWriterStream; - temp: TTextWriterStackBuffer; -begin // will avoid most memory allocations - Fake := TFakeWriterStream.Create; - try - with DefaultTextWriterSerializer.Create(Fake,@temp,SizeOf(temp)) do - try - AddVariant(Value,Escape); - FlushFinal; - result := fTotalFileSize; - finally - Free; - end; - finally - Fake.Free; - end; -end; - -procedure VariantToVarRec(const V: variant; var result: TVarRec); -begin - result.VType := vtVariant; - if TVarData(V).VType=varByRef or varVariant then - result.VVariant := TVarData(V).VPointer else - result.VVariant := @V; -end; - -function VarRecToVariant(const V: TVarRec): variant; -begin - VarRecToVariant(V,result); -end; - -procedure VarRecToVariant(const V: TVarRec; var result: variant); -begin - VarClear(result); - with TVarData(result) do - case V.VType of - vtPointer: - VType := varNull; - vtBoolean: begin - VType := varBoolean; - VBoolean := V.VBoolean; - end; - vtInteger: begin - VType := varInteger; - VInteger := V.VInteger; - end; - vtInt64: begin - VType := varInt64; - VInt64 := V.VInt64^; - end; - {$ifdef FPC} - vtQWord: begin - VType := varQWord; - VQWord := V.VQWord^; - end; - {$endif} - vtCurrency: begin - VType := varCurrency; - VCurrency := V.VCurrency^; - end; - vtExtended: begin - VType := varDouble; - VDouble := V.VExtended^; - end; - vtVariant: - result := V.VVariant^; - vtAnsiString: begin - VType := varString; - VAny := nil; - RawByteString(VAny) := RawByteString(V.VAnsiString); - end; - vtString, {$ifdef HASVARUSTRING}vtUnicodeString,{$endif} - vtPChar, vtChar, vtWideChar, vtWideString, vtClass: begin - VType := varString; - VString := nil; // avoid GPF on next line - VarRecToUTF8(V,RawUTF8(VString)); // convert to a new RawUTF8 instance - end; - vtObject: // class instance will be serialized as a TDocVariant - ObjectToVariant(V.VObject,result,[woDontStoreDefault]); - else raise ESynException.CreateUTF8('Unhandled TVarRec.VType=%',[V.VType]); - end; -end; - - -{ TSynInvokeableVariantType } - -function TSynInvokeableVariantType.IterateCount(const V: TVarData): integer; -begin - result := -1; // this is not an array -end; - -procedure TSynInvokeableVariantType.Iterate(var Dest: TVarData; const V: TVarData; - Index: integer); -begin // do nothing -end; - -{$ifndef FPC} -{$ifndef DELPHI6OROLDER} -function TSynInvokeableVariantType.FixupIdent(const AText: string): string; -begin - result := AText; // NO uppercased identifier for our custom types! -end; -{$endif DELPHI6OROLDER} -{$endif FPC} - -function TSynInvokeableVariantType.IntGet(var Dest: TVarData; const Instance: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; -begin - raise ESynException.CreateUTF8('Unexpected %.IntGet(%): this kind of '+ - 'custom variant does not support sub-fields',[self,Name]); -end; - -function TSynInvokeableVariantType.IntSet(const Instance, Value: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; -begin - raise ESynException.CreateUTF8('Unexpected %.IntSet(%): this kind of '+ - 'custom variant is read-only',[self,Name]); -end; - - -function TSynInvokeableVariantType.GetProperty(var Dest: TVarData; - const V: TVarData; const Name: String): Boolean; -{$ifdef UNICODE} var Buf: array[byte] of AnsiChar; {$endif} -begin - IntGet(Dest,V,{$ifdef UNICODE}Buf,RawUnicodeToUtf8(Buf,SizeOf(Buf), - pointer(Name),length(Name),[]){$else}pointer(Name),length(Name){$endif}); - result := true; // IntGet=false+Dest=null e.g. if dvoReturnNullForUnknownProperty -end; - -{$ifdef FPC_VARIANTSETVAR} // see http://mantis.freepascal.org/view.php?id=26773 -function TSynInvokeableVariantType.SetProperty(var V: TVarData; - const Name: string; const Value: TVarData): Boolean; -{$else} -function TSynInvokeableVariantType.SetProperty(const V: TVarData; - const Name: string; const Value: TVarData): Boolean; -{$endif} -var ValueSet: TVarData; - PropName: PAnsiChar; - Unicode: pointer; - PropNameLen, UnicodeLen: PtrInt; - vt: cardinal; -{$ifdef UNICODE} - Buf: array[byte] of AnsiChar; // to avoid heap allocation -{$endif} -begin -{$ifdef UNICODE} - PropNameLen := RawUnicodeToUtf8(Buf,SizeOf(Buf),pointer(Name),length(Name),[]); - PropName := @Buf[0]; -{$else} - PropName := pointer(Name); - PropNameLen := length(Name); -{$endif} - vt := Value.VType; - if vt=varByRef or varOleStr then begin - Unicode := PPointer(Value.VAny)^; - UnicodeLen := length(WideString(Unicode)); - end else - if vt=varOleStr then begin - Unicode := Value.VAny; - UnicodeLen := length(WideString(Unicode)); - end else - {$ifdef HASVARUSTRING} - if vt=varByRef or varUString then begin - Unicode := PPointer(Value.VAny)^; - UnicodeLen := length(UnicodeString(Unicode)); - end else - if vt=varUString then begin - Unicode := Value.VAny; - UnicodeLen := length(UnicodeString(Unicode)); - end else - {$endif} - if SetVariantUnRefSimpleValue(variant(Value),ValueSet) then begin - result := IntSet(V,ValueSet,PropName,PropNameLen); - exit; - end else begin - result := IntSet(V,Value,PropName,PropNameLen); - exit; - end; - try // unpatched RTL does not like Unicode values :( -> use a temp RawUTF8 - ValueSet.VType := varString; - ValueSet.VString := nil; // to avoid GPF in next line - RawUnicodeToUtf8(Unicode,UnicodeLen,RawUTF8(ValueSet.VString)); - result := IntSet(V,ValueSet,PropName,PropNameLen); - finally - RawUTF8(ValueSet.VString) := ''; // avoid memory leak - end; -end; - -procedure TSynInvokeableVariantType.Clear(var V: TVarData); -begin - ZeroFill(@V); // will set V.VType := varEmpty -end; - -procedure TSynInvokeableVariantType.Copy(var Dest: TVarData; - const Source: TVarData; const Indirect: Boolean); -begin - if Indirect then - SimplisticCopy(Dest,Source,true) else begin - VarClear(variant(Dest)); // Dest may be a complex type - Dest := Source; - end; -end; - -procedure TSynInvokeableVariantType.CopyByValue(var Dest: TVarData; const Source: TVarData); -begin - Copy(Dest,Source,false); -end; - -function TSynInvokeableVariantType.TryJSONToVariant(var JSON: PUTF8Char; - var Value: variant; EndOfObject: PUTF8Char): boolean; -begin - result := false; -end; - -procedure TSynInvokeableVariantType.ToJSON(W: TTextWriter; const Value: variant; - Escape: TTextWriterKind); -begin - raise ESynException.CreateUTF8('%.ToJSON: unimplemented variant type',[self]); -end; - -function TSynInvokeableVariantType.IsOfType(const V: variant): boolean; -var vt: cardinal; - vd: PVarData; -begin - if self<>nil then begin - vd := @V; - repeat - vt := vd^.VType; - if vt<>varByRef or varVariant then - break; - vd := vd^.VPointer; - until false; - result := vt=VarType; - end else - result := false; -end; - -var // owned by Variants.pas as TInvokeableVariantType/TCustomVariantType - SynVariantTypes: array of TSynInvokeableVariantType; - -function FindSynVariantTypeFromVType(aVarType: cardinal): TSynInvokeableVariantType; - {$ifdef HASINLINE}inline;{$endif} -var i: integer; - t: ^TSynInvokeableVariantType; -begin - t := pointer(SynVariantTypes); - for i := 1 to length(TObjectDynArray(t)) do begin - result := t^; - if result.VarType=aVarType then - exit; - inc(t); - end; - result := nil; -end; - -function TSynInvokeableVariantType.FindSynVariantType(aVarType: Word; - out CustomType: TSynInvokeableVariantType): boolean; -begin - if aVarType=VarType then - CustomType := self else - CustomType := FindSynVariantTypeFromVType(VarType); - result := CustomType<>nil; -end; - -procedure TSynInvokeableVariantType.Lookup(var Dest: TVarData; const Instance: TVarData; - FullName: PUTF8Char); -var handler: TSynInvokeableVariantType; - v, tmp: TVarData; // PVarData wouldn't store e.g. RowID/count - vt: cardinal; - itemName: ShortString; -begin - PInteger(@Dest)^ := varEmpty; // left to Unassigned if not found - v := Instance; - repeat - vt := v.VType; - if vt<>varByRef or varVariant then - break; - v := PVarData(v.VPointer)^; - until false; - repeat - if vt<=varString then - exit; // we need a complex type to lookup - GetNextItemShortString(FullName,itemName,'.'); - if itemName[0] in [#0,#255] then - exit; - itemName[ord(itemName[0])+1] := #0; // ensure is ASCIIZ - if vt=VarType then - handler := self else begin - handler := FindSynVariantTypeFromVType(vt); - if handler=nil then - exit; - end; - tmp := v; // v will be modified in-place - PInteger(@v)^ := varEmpty; // IntGet() would clear it otherwise! - if not handler.IntGet(v,tmp,@itemName[1],ord(itemName[0])) then - exit; // property not found - repeat - vt := v.VType; - if vt<>varByRef or varVariant then - break; - v := PVarData(v.VPointer)^; - until false; - if (vt=cardinal(DocVariantVType)) and (TDocVariantData(v).VCount=0) then - v.VType := varNull; // recognize void TDocVariant as null - until FullName=nil; - Dest := v; -end; - -procedure GetJSONToAnyVariant(var Value: variant; var JSON: PUTF8Char; - EndOfObject: PUTF8Char; Options: PDocVariantOptions; AllowDouble: boolean); -// internal method used by VariantLoadJSON(), GetVariantFromJSON() and -// TDocVariantData.InitJSON() - procedure ProcessField; - var val: PUTF8Char; - wasString: boolean; - begin - val := GetJSONField(JSON,JSON,@wasString,EndOfObject); - GetVariantFromJSON(val,wasString,Value,nil,AllowDouble); - if JSON=nil then - JSON := @NULCHAR; - end; -var i: integer; - t: ^TSynInvokeableVariantType; - ToBeParsed: PUTF8Char; - wasParsedWithinString: boolean; - wasString: boolean; -begin - VarClear(Value); - if (Options<>nil) and (dvoAllowDoubleValue in Options^) then - AllowDouble := true; // for ProcessField() above - if EndOfObject<>nil then - EndOfObject^ := ' '; - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - if (Options=nil) or (JSON^ in ['-','0'..'9']) or (PInteger(JSON)^=NULL_LOW) or - (PInteger(JSON)^=TRUE_LOW) or (PInteger(JSON)^=FALSE_LOW) then begin - ProcessField; // obvious simple type - exit; - end; - wasParsedWithinString := false; - if JSON^='"' then - if dvoJSONObjectParseWithinString in Options^ then begin - ToBeParsed := GetJSONField(JSON,JSON,@wasString,EndOfObject); - EndOfObject := nil; // already set just above - wasParsedWithinString := true; - end else begin - ProcessField; - exit; - end else - ToBeParsed := JSON; - t := pointer(SynVariantTypes); - if (t<>nil) and not(dvoJSONParseDoNotTryCustomVariants in Options^) then - for i := {$ifdef FPC}0{$else}1{$endif} to PDALen(PtrUInt(t)-_DALEN)^ do - if t^.TryJSONToVariant(ToBeParsed,Value,EndOfObject) then begin - if not wasParsedWithinString then - JSON := ToBeParsed; - exit; - end else - inc(t); - if ToBeParsed^ in ['[','{'] then begin - // default JSON parsing and conversion to TDocVariant instance - ToBeParsed := TDocVariantData(Value).InitJSONInPlace(ToBeParsed,Options^,EndOfObject); - if ToBeParsed=nil then begin - TDocVariantData(Value).Clear; - exit; // eror parsing - end; - if not wasParsedWithinString then - JSON := ToBeParsed; - end else - // back to simple variant types - if wasParsedWithinString then - GetVariantFromJSON(ToBeParsed,wasString,Value,nil,AllowDouble) else - ProcessField; -end; - -function TextToVariantNumberTypeNoDouble(json: PUTF8Char): cardinal; -var start: PUTF8Char; - c: AnsiChar; -begin - result := varString; - c := json[0]; - if (jcDigitFirstChar in JSON_CHARS[c]) and - (((c>='1') and (c<='9')) or // is first char numeric? - ((c='0') and ((json[1]='.') or (json[1]=#0))) or // '012' excluded by JSON - ((c='-') and (json[1]>='0') and (json[1]<='9'))) then begin - start := json; - repeat inc(json) until (json^<'0') or (json^>'9'); // check digits - case json^ of - '.': - if (json[1]>='0') and (json[1]<='9') and (json[2] in [#0,'0'..'9']) then - if (json[2]=#0) or (json[3]=#0) or - ((json[3]>='0') and (json[3]<='9') and (json[4]=#0) or - ((json[4]>='0') and (json[4]<='9') and (json[5]=#0))) then - result := varCurrency; // currency ###.1234 number - #0: - if json-start<=19 then // signed Int64 precision - result := varInt64; - end; - end; -end; - -function TextToVariantNumberType(json: PUTF8Char): cardinal; -var start: PUTF8Char; - exp: PtrInt; - c: AnsiChar; -label exponent; -begin - result := varString; - c := json[0]; - if (jcDigitFirstChar in JSON_CHARS[c]) and - (((c>='1') and (c<='9')) or // is first char numeric? - ((c='0') and ((json[1]='.') or (json[1]=#0))) or // '012' excluded by JSON - ((c='-') and (json[1]>='0') and (json[1]<='9'))) then begin - start := json; - repeat inc(json) until (json^<'0') or (json^>'9'); // check digits - case json^ of - #0: - if json-start<=19 then // signed Int64 precision - result := varInt64 else - result := varDouble; // we may lost precision, but still a number - '.': - if (json[1]>='0') and (json[1]<='9') and (json[2] in [#0,'e','E','0'..'9']) then - if (json[2]=#0) or (json[3]=#0) or - ((json[3]>='0') and (json[3]<='9') and (json[4]=#0) or - ((json[4]>='0') and (json[4]<='9') and (json[5]=#0))) then - result := varCurrency // currency ###.1234 number - else begin - repeat // more than 4 decimals - inc(json) - until (json^<'0') or (json^>'9'); - case json^ of - #0: - result := varDouble; - 'e','E': begin -exponent: inc(json); // inlined custom GetInteger() - start := json; - c := json^; - if (c='-') or (c='+') then begin - inc(json); - c := json^; - end; - inc(json); - dec(c,48); - if c>#9 then - exit; - exp := ord(c); - c := json^; - dec(c,48); - if c<=#9 then begin - inc(json); - exp := exp*10+ord(c); - c := json^; - dec(c,48); - if c<=#9 then begin - inc(json); - exp := exp*10+ord(c); - end; - end; - if json^<>#0 then - exit; - if start^='-' then - exp := -exp; - if (exp>-324) and (exp<308) then - result := varDouble; // 5.0 x 10^-324 .. 1.7 x 10^308 - end; - end; - end; - 'e','E': - goto exponent; - end; - end; -end; - -function GetNumericVariantFromJSON(JSON: PUTF8Char; var Value: TVarData; - AllowVarDouble: boolean): boolean; -var err: integer; - typ: cardinal; -label dbl; -begin - if JSON<>nil then begin - if AllowVarDouble then - typ := TextToVariantNumberType(JSON) else - typ := TextToVariantNumberTypeNoDouble(JSON); - with Value do - case typ of - varInt64: begin - VInt64 := GetInt64(JSON,err); - if err<>0 then // overflow (>$7FFFFFFFFFFFFFFF) -> try floating point - if AllowVarDouble then - goto dbl else begin - result:= false; - exit; - end; - if (VInt64<=high(integer)) and (VInt64>=low(integer)) then - VType := varInteger else - VType := varInt64; - result := true; - exit; - end; - varCurrency: begin - VInt64 := StrToCurr64(JSON); - VType := varCurrency; - result := true; - exit; - end; - varDouble: begin -dbl: VDouble := GetExtended(JSON,err); - if err=0 then begin - VType := varDouble; - result := true; - exit; - end; - end; - end; - end; - result := false; -end; - -procedure JSONToVariantInPlace(var Value: variant; JSON: PUTF8Char; - Options: TDocVariantOptions; AllowDouble: boolean); -begin - if (JSON<>nil) and (JSON^<>#0) then - GetJSONToAnyVariant(Value,JSON,nil,@Options,AllowDouble) else - VarClear(Value); -end; - -function JSONToVariant(const JSON: RawUTF8; Options: TDocVariantOptions; - AllowDouble: boolean): variant; -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); // temp copy before in-place decoding - try - JSONToVariantInPlace(result,tmp.buf,Options,AllowDouble); - finally - tmp.Done; - end; -end; - -procedure TextToVariant(const aValue: RawUTF8; AllowVarDouble: boolean; - out aDest: variant); -begin - if not GetNumericVariantFromJSON(pointer(aValue),TVarData(aDest),AllowVarDouble) then - RawUTF8ToVariant(aValue,aDest); -end; - -function GetNextItemToVariant(var P: PUTF8Char; out Value: Variant; - Sep: AnsiChar; AllowDouble: boolean): boolean; -var temp: RawUTF8; -begin - if P=nil then - result := false else begin - GetNextItem(P,Sep,temp); - if not GetNumericVariantFromJSON(pointer(temp),TVarData(Value),AllowDouble) then - RawUTF8ToVariant(temp,Value); - result := true; - end; -end; - -function GetVariantFromNotStringJSON(JSON: PUTF8Char; var Value: TVarData; - AllowDouble: boolean): boolean; -begin - if JSON<>nil then - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - if (JSON=nil) or - ((PInteger(JSON)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[JSON[4]])) then - Value.VType := varNull else - if (PInteger(JSON)^=FALSE_LOW) and (JSON[4]='e') and - (jcEndOfJSONValueField in JSON_CHARS[JSON[5]]) then begin - Value.VType := varBoolean; - Value.VBoolean := false; - end else - if (PInteger(JSON)^=TRUE_LOW) and (jcEndOfJSONValueField in JSON_CHARS[JSON[4]]) then begin - Value.VType := varBoolean; - Value.VBoolean := true; - end else - if not GetNumericVariantFromJSON(JSON,Value,AllowDouble) then begin - result := false; - exit; - end; - result := true; -end; - -procedure GetVariantFromJSON(JSON: PUTF8Char; wasString: Boolean; var Value: variant; - TryCustomVariants: PDocVariantOptions; AllowDouble: boolean); -begin - // first handle any strict-JSON syntax objects or arrays into custom variants - // (e.g. when called directly from TSQLPropInfoRTTIVariant.SetValue) - if (TryCustomVariants<>nil) and (JSON<>nil) then - if (GotoNextNotSpace(JSON)^ in ['{','[']) and not wasString then begin - GetJSONToAnyVariant(Value,JSON,nil,TryCustomVariants,AllowDouble); - exit; - end else - AllowDouble := dvoAllowDoubleValue in TryCustomVariants^; - // handle simple text or numerical values - VarClear(Value); - if not wasString and GetVariantFromNotStringJSON(JSON,TVarData(Value),AllowDouble) then - exit; - with TVarData(Value) do begin - // found no numerical value -> return a string in the expected format - VType := varString; - VString := nil; // avoid GPF below when assigning a string variable to VAny - FastSetString(RawUTF8(VString),JSON,StrLen(JSON)); - end; -end; - -{$ifndef FPC} // better not try it with FPC - rely on the current implementation - -function ParseParamPointer(P: pointer; aType: cardinal; var Value: TVarData): pointer; -var Size: Cardinal; - ByRef: Boolean; - V: Variant absolute Value; -const TYPE_BYREF = 128; - TYPE_BYREF_MASK = TYPE_BYREF-1; -begin // this code should copy parameters without any reference count handling - ZeroFill(@Value); // TVarData is expected to be bulk stack: no VarClear needed - ByRef := (aType and TYPE_BYREF)<>0; - Size := SizeOf(pointer); - case aType and TYPE_BYREF_MASK of - varShortInt, varSmallint, varInteger, varByte, varWord, varLongWord, varSingle: begin - if ByRef then - P := pointer(P^); - Value.VType := aType and TYPE_BYREF_MASK; - Value.VInteger := PInteger(P)^; - {$ifdef CPU64} - if not ByRef then - Size := SizeOf(Integer); - {$endif} - end; - varDouble, varCurrency, varDate, varInt64, varWord64, varOleStr: begin - if ByRef then - P := pointer(P^); - Value.VType := aType and TYPE_BYREF_MASK; - Value.VInt64 := PInt64(P)^; - {$ifndef CPU64} - if not ByRef then - Size := SizeOf(Int64); - {$endif} - end; - varStrArg: begin - if ByRef then - P := pointer(P^); - Value.VType := varString; - Value.VString := PPointer(P)^; - end; - {$ifdef HASVARUSTRARG} - varUStrArg: begin - if ByRef then - P := pointer(P^); - Value.VType := varUString; - Value.VUString := PPointer(P)^; - end; - {$endif} - varBoolean: - if ByRef then - V := PWordBool(pointer(P^))^ else - V := PWordBool(P)^; - varVariant: - {$ifdef CPU64} // circumvent Delphi x64 compiler oddiness - Value := PVarData(pointer(P^))^ - {$else} - if ByRef then - Value := PVarData(pointer(P^))^ else begin - Value := PVarData(P)^; - Size := SizeOf(Value); - end; - {$endif} - else - raise EInvalidCast.CreateFmt('ParseParamPointer: Invalid VarType=%d', - [aType and TYPE_BYREF_MASK]); - end; - result := PAnsiChar(P)+Size; -end; - -var - LastDispInvokeType: TSynInvokeableVariantType; - -procedure SynVarDispProc(Result: PVarData; const Instance: TVarData; - CallDesc: PCallDesc; Params: Pointer); cdecl; -const DO_PROP = 1; GET_PROP = 2; SET_PROP = 4; -var Value: TVarData; - Handler: TSynInvokeableVariantType; - CacheDispInvokeType: TSynInvokeableVariantType; // to be thread-safe -begin - if Instance.VType=varByRef or varVariant then // handle By Ref variants - SynVarDispProc(Result,PVarData(Instance.VPointer)^,CallDesc,Params) else begin - if Result<>nil then - VarClear(Variant(Result^)); - case Instance.VType of - varDispatch, varDispatch or varByRef, - varUnknown, varUnknown or varByRef, varAny: - // process Ole Automation variants - if Assigned(VarDispProc) then - VarDispProc(pointer(Result),Variant(Instance),CallDesc,@Params); - else begin - // first we check for our own TSynInvokeableVariantType types - if SynVariantTypes<>nil then begin - // simple cache for the latest type: most gets are grouped - CacheDispInvokeType := LastDispInvokeType; - if (CacheDispInvokeType<>nil) and - (CacheDispInvokeType.VarType=TVarData(Instance).VType) and - (CallDesc^.CallType in [GET_PROP, DO_PROP]) and - (Result<>nil) and (CallDesc^.ArgCount=0) then begin - CacheDispInvokeType.IntGet(Result^,Instance, - @CallDesc^.ArgTypes[0],StrLen(@CallDesc^.ArgTypes[0])); - exit; - end; - end; - // handle any custom variant type - if FindCustomVariantType(Instance.VType,TCustomVariantType(Handler)) then begin - if Handler.InheritsFrom(TSynInvokeableVariantType) then - case CallDesc^.CallType of - GET_PROP, DO_PROP: // fast direct call of our IntGet() virtual method - if (Result<>nil) and (CallDesc^.ArgCount=0) then begin - Handler.IntGet(Result^,Instance, - @CallDesc^.ArgTypes[0],StrLen(@CallDesc^.ArgTypes[0])); - LastDispInvokeType := Handler; // speed up in loop - exit; - end; - SET_PROP: // fast direct call of our IntSet() virtual method - if (Result=nil) and (CallDesc^.ArgCount=1) then begin - ParseParamPointer(@Params,CallDesc^.ArgTypes[0],Value); - Handler.IntSet(Instance,Value, - @CallDesc^.ArgTypes[1],StrLen(@CallDesc^.ArgTypes[1])); - exit; - end; - end; - // here we call the default code handling custom types - Handler.DispInvoke({$ifdef DELPHI6OROLDER}Result^{$else}Result{$endif}, - Instance,CallDesc,@Params) - end else - raise EInvalidOp.CreateFmt('Invalid variant type %d invoke',[Instance.VType]); - end; - end; - end; -end; - -function VariantsDispInvokeAddress: pointer; -asm - {$ifdef CPU64} - mov rax,offset Variants.@DispInvoke - {$else} - mov eax,offset Variants.@DispInvoke - {$endif} -end; - -{$ifdef DOPATCHTRTL} - {$define DOPATCHDISPINVOKE} // much faster late-binding process for our types -{$endif} -{$ifdef CPU64} - {$define DOPATCHDISPINVOKE} - // we NEED our patched DispInvoke to circumvent some Delphi bugs on Win64 -{$endif} -{$ifdef DELPHI6OROLDER} - {$define DOPATCHDISPINVOKE} - // to circumvent LIdent := Uppercase() in TInvokeableVariantType.DispInvoke() -{$endif} - -{$endif FPC} - -function SynRegisterCustomVariantType(aClass: TSynInvokeableVariantTypeClass): TSynInvokeableVariantType; -var i: PtrInt; -{$ifdef DOPATCHDISPINVOKE} -{$ifdef NOVARCOPYPROC} - VarMgr: TVariantManager; -{$endif} -{$endif} -begin - {$ifdef DOPATCHDISPINVOKE} - if SynVariantTypes=nil then begin - {$ifndef CPU64} // we NEED our patched RTL on Win64 - if DebugHook=0 then // patch VCL/RTL only outside debugging - {$endif} begin - {$ifdef NOVARCOPYPROC} - GetVariantManager(VarMgr); - VarMgr.DispInvoke := @SynVarDispProc; - SetVariantManager(VarMgr); - {$else} - RedirectCode(VariantsDispInvokeAddress,@SynVarDispProc); - {$endif NOVARCOPYPROC} - end; - end else - {$endif DOPATCHDISPINVOKE} - for i := 0 to length(SynVariantTypes)-1 do - if PPointer(SynVariantTypes[i])^=pointer(aClass) then begin - result := SynVariantTypes[i]; // returns already registered instance - exit; - end; - result := aClass.Create; // register variant type - ObjArrayAdd(SynVariantTypes,result); -end; - - -function VariantDynArrayToJSON(const V: TVariantDynArray): RawUTF8; -var tmp: TDocVariantData; -begin - tmp.InitArrayFromVariants(V); - result := tmp.ToJSON; -end; - -function JSONToVariantDynArray(const JSON: RawUTF8): TVariantDynArray; -var tmp: TDocVariantData; -begin - tmp.InitJSON(JSON,JSON_OPTIONS_FAST); - result := tmp.VValue; -end; - -function ValuesToVariantDynArray(const items: array of const): TVariantDynArray; -var tmp: TDocVariantData; -begin - tmp.InitArray(items,JSON_OPTIONS_FAST); - result := tmp.VValue; -end; - - -{ TDocVariantData } - -function TDocVariantData.GetKind: TDocVariantKind; -var opt: TDocVariantOptions; -begin - opt := VOptions; - if dvoIsArray in opt then - result := dvArray else - if dvoIsObject in opt then - result := dvObject else - result := dvUndefined; -end; - -function DocVariantData(const DocVariant: variant): PDocVariantData; -var docv,vt: integer; -begin - result := @DocVariant; - docv := DocVariantVType; - vt := result^.VType; - if vt=docv then - exit else - if vt=varByRef or varVariant then begin - result := PVarData(result)^.VPointer; - if integer(result^.VType)=docv then - exit; - end; - raise EDocVariant.CreateUTF8('DocVariantType.Data(%<>TDocVariant)',[ord(result^.VType)]); -end; - -function _Safe(const DocVariant: variant): PDocVariantData; -{$ifdef FPC_OR_PUREPASCAL} -var docv,vt: integer; -begin - result := @DocVariant; - docv := DocVariantVType; - vt := result^.VType; - if vt=docv then - exit else - if vt=varByRef or varVariant then begin - result := PVarData(result)^.VPointer; - if integer(result^.VType)=docv then - exit; - end; - result := @DocVariantDataFake; -end; -{$else} -asm - mov ecx,DocVariantVType - movzx edx,word ptr [eax].TVarData.VType - cmp edx,ecx - jne @by - ret -@ptr: mov eax,[eax].TVarData.VPointer - movzx edx,word ptr [eax].TVarData.VType - cmp edx,ecx - je @ok -@by: cmp edx,varByRef or varVariant - je @ptr - lea eax,[DocVariantDataFake] -@ok: -end; -{$endif} - -function _Safe(const DocVariant: variant; ExpectedKind: TDocVariantKind): PDocVariantData; -var o: TDocVariantOptions; -begin - result := _Safe(DocVariant); - o := result^.VOptions; - if dvoIsArray in o then begin - if ExpectedKind=dvArray then - exit; - end else if (dvoIsObject in o) and (ExpectedKind=dvObject) then - exit; - raise EDocVariant.CreateUTF8('_Safe(%)?',[ToText(ExpectedKind)^]); -end; - -function _CSV(const DocVariantOrString: variant): RawUTF8; -begin - with _Safe(DocVariantOrString)^ do - if dvoIsArray in VOptions then - result := ToCSV else - if (dvoIsObject in VOptions) or (TDocVariantData(DocVariantOrString).VType<=varNull) or - not VariantToUTF8(DocVariantOrString,result) then - result := ''; // VariantToUTF8() returns 'null' for empty/null -end; - -function TDocVariantData.GetValueIndex(const aName: RawUTF8): integer; -begin - result := GetValueIndex(Pointer(aName),Length(aName),dvoNameCaseSensitive in VOptions); -end; - -function TDocVariantData.GetCapacity: integer; -begin - result := length(VValue); -end; - -function TDocVariant.InternNames: TRawUTF8Interning; -begin - if fInternNames=nil then - fInternNames := TRawUTF8Interning.Create; - result := fInternNames; -end; - -function TDocVariant.InternValues: TRawUTF8Interning; -begin - if fInternValues=nil then - fInternValues := TRawUTF8Interning.Create; - result := fInternValues; -end; - -procedure TDocVariantData.SetOptions(const opt: TDocVariantOptions); -begin - VOptions := (opt-[dvoIsArray,dvoIsObject])+(VOptions*[dvoIsArray,dvoIsObject]); -end; - -procedure TDocVariantData.Init(aOptions: TDocVariantOptions; aKind: TDocVariantKind); -begin - aOptions := aOptions-[dvoIsArray,dvoIsObject]; - case aKind of - dvArray: include(aOptions,dvoIsArray); - dvObject: include(aOptions,dvoIsObject); - end; - ZeroFill(@self); - VType := DocVariantVType; - VOptions := aOptions; -end; - -procedure TDocVariantData.InitFast; -begin - ZeroFill(@self); - VType := DocVariantVType; - VOptions := JSON_OPTIONS_FAST; -end; - -procedure TDocVariantData.InitFast(InitialCapacity: integer; aKind: TDocVariantKind); -begin - InitFast; - case aKind of - dvArray: include(VOptions,dvoIsArray); - dvObject: include(VOptions,dvoIsObject); - end; - if aKind=dvObject then - SetLength(VName,InitialCapacity); - SetLength(VValue,InitialCapacity); -end; - -procedure TDocVariantData.InitObject(const NameValuePairs: array of const; - aOptions: TDocVariantOptions=[]); -begin - Init(aOptions,dvObject); - AddNameValuesToObject(NameValuePairs); -end; - -procedure TDocVariantData.AddNameValuesToObject(const NameValuePairs: array of const); -var n,arg: PtrInt; - tmp: variant; -begin - n := length(NameValuePairs); - if (n=0) or (n and 1=1) or (dvoIsArray in VOptions) then - exit; // nothing to add - include(VOptions,dvoIsObject); - n := n shr 1; - if length(VValue)=0 then begin - VCount := length(Items); - SetLength(VValue,VCount); - if dvoValueCopiedByReference in VOptions then - for arg := 0 to high(Items) do - VarRecToVariant(Items[arg],VValue[arg]) else - for arg := 0 to high(Items) do begin - VarRecToVariant(Items[arg],tmp); - SetVariantByValue(tmp,VValue[arg]); - end; - end; -end; - -procedure TDocVariantData.InitArrayFromVariants(const Items: TVariantDynArray; - aOptions: TDocVariantOptions; ItemsCopiedByReference: boolean); -begin - if Items=nil then - VType := varNull else begin - Init(aOptions,dvArray); - VCount := length(Items); - VValue := Items; // fast by-reference copy of VValue[] - if not ItemsCopiedByReference then - InitCopy(variant(self),aOptions); - end; -end; - -procedure TDocVariantData.InitArrayFromObjArray(const ObjArray; - aOptions: TDocVariantOptions; aWriterOptions: TTextWriterWriteObjectOptions); -var ndx: integer; - Items: TObjectDynArray absolute ObjArray; -begin - if Items=nil then - VType := varNull else begin - Init(aOptions,dvArray); - VCount := length(Items); - SetLength(VValue,VCount); - for ndx := 0 to VCount-1 do - ObjectToVariant(Items[ndx],VValue[ndx],aWriterOptions); - end; -end; - -procedure TDocVariantData.InitArrayFrom(const Items: TRawUTF8DynArray; - aOptions: TDocVariantOptions); -var ndx: integer; -begin - if Items=nil then - VType := varNull else begin - Init(aOptions,dvArray); - VCount := length(Items); - SetLength(VValue,VCount); - for ndx := 0 to VCount-1 do - RawUTF8ToVariant(Items[ndx],VValue[ndx]); - end; -end; - -procedure TDocVariantData.InitArrayFrom(const Items: TIntegerDynArray; - aOptions: TDocVariantOptions); -var ndx: integer; -begin - if Items=nil then - VType := varNull else begin - Init(aOptions,dvArray); - VCount := length(Items); - SetLength(VValue,VCount); - for ndx := 0 to VCount-1 do - VValue[ndx] := Items[ndx]; - end; -end; - -procedure TDocVariantData.InitArrayFrom(const Items: TInt64DynArray; - aOptions: TDocVariantOptions); -var ndx: integer; -begin - if Items=nil then - VType := varNull else begin - Init(aOptions,dvArray); - VCount := length(Items); - SetLength(VValue,VCount); - for ndx := 0 to VCount-1 do - VValue[ndx] := Items[ndx]; - end; -end; - -procedure TDocVariantData.InitFromTypeInfo(const aValue; aTypeInfo: pointer; - aEnumSetsAsText: boolean; aOptions: TDocVariantOptions); -var tmp: RawUTF8; -begin - tmp := SaveJSON(aValue,aTypeInfo,aEnumSetsAsText); - InitJSONInPlace(pointer(tmp),aOptions); -end; - -procedure TDocVariantData.InitObjectFromVariants(const aNames: TRawUTF8DynArray; - const aValues: TVariantDynArray; aOptions: TDocVariantOptions); -begin - if (aNames=nil) or (aValues=nil) or (length(aNames)<>length(aValues)) then - VType := varNull else begin - Init(aOptions,dvObject); - VCount := length(aNames); - VName := aNames; // fast by-reference copy of VName[] and VValue[] - VValue := aValues; - end; -end; - -procedure TDocVariantData.InitObjectFromPath(const aPath: RawUTF8; const aValue: variant; - aOptions: TDocVariantOptions); -var right: RawUTF8; -begin - if aPath='' then - VType := varNull else begin - Init(aOptions,dvObject); - VCount := 1; - SetLength(VName,1); - SetLength(VValue,1); - split(aPath,'.',VName[0],right); - if right='' then - VValue[0] := aValue else - PDocVariantData(@VValue[0])^.InitObjectFromPath(right,aValue,aOptions); - end; -end; - -function TDocVariantData.InitJSONInPlace(JSON: PUTF8Char; - aOptions: TDocVariantOptions; aEndOfObject: PUTF8Char): PUTF8Char; -var EndOfObject: AnsiChar; - Name: PUTF8Char; - NameLen, n: integer; - intnames, intvalues: TRawUTF8Interning; -begin - Init(aOptions); - result := nil; - if JSON=nil then - exit; - if dvoInternValues in VOptions then - intvalues := DocVariantType.InternValues else - intvalues := nil; - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - case JSON^ of - '[': begin - repeat inc(JSON); if JSON^=#0 then exit; until JSON^>' '; - n := JSONArrayCount(JSON); // may be slow if JSON is huge (not very common) - if n<0 then - exit; // invalid content - include(VOptions,dvoIsArray); - if n>0 then begin - SetLength(VValue,n); - repeat - if VCount>=n then - exit; // unexpected array size means invalid JSON - GetJSONToAnyVariant(VValue[VCount],JSON,@EndOfObject,@VOptions,false); - if JSON=nil then - if EndOfObject=']' then // valid array end - JSON := @NULCHAR else - exit; // invalid input - if intvalues<>nil then - intvalues.UniqueVariant(VValue[VCount]); - inc(VCount); - until EndOfObject=']'; - end else - if JSON^=']' then // n=0 - repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else - exit; - end; - '{': begin - repeat inc(JSON); if JSON^=#0 then exit; until JSON^>' '; - n := JSONObjectPropCount(JSON); // may be slow if JSON is huge (not very common) - if n<0 then - exit; // invalid content - include(VOptions,dvoIsObject); - if dvoInternNames in VOptions then - intnames := DocVariantType.InternNames else - intnames := nil; - if n>0 then begin - SetLength(VValue,n); - SetLength(VName,n); - repeat - if VCount>=n then - exit; // unexpected object size means invalid JSON - // see http://docs.mongodb.org/manual/reference/mongodb-extended-json - Name := GetJSONPropName(JSON,@NameLen); - if Name=nil then - exit; - FastSetString(VName[VCount],Name,NameLen); - if intnames<>nil then - intnames.UniqueText(VName[VCount]); - GetJSONToAnyVariant(VValue[VCount],JSON,@EndOfObject,@VOptions,false); - if JSON=nil then - if EndOfObject='}' then // valid object end - JSON := @NULCHAR else - exit; // invalid input - if intvalues<>nil then - intvalues.UniqueVariant(VValue[VCount]); - inc(VCount); - until EndOfObject='}'; - end else - if JSON^='}' then // n=0 - repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else - exit; - end; - 'n','N': begin - if IdemPChar(JSON+1,'ULL') then begin - include(VOptions,dvoIsObject); - result := GotoNextNotSpace(JSON+4); - end; - exit; - end; - else exit; - end; - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - if aEndOfObject<>nil then - aEndOfObject^ := JSON^; - if JSON^<>#0 then - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - result := JSON; // indicates successfully parsed -end; - -function TDocVariantData.InitJSON(const JSON: RawUTF8; - aOptions: TDocVariantOptions): boolean; -var tmp: TSynTempBuffer; -begin - if JSON='' then - result := false else begin - tmp.Init(JSON); - try - result := InitJSONInPlace(tmp.buf,aOptions)<>nil; - finally - tmp.Done; - end; - end; -end; - -function TDocVariantData.InitJSONFromFile(const JsonFile: TFileName; - aOptions: TDocVariantOptions; RemoveComments: boolean): boolean; -var content: RawUTF8; -begin - content := AnyTextFileToRawUTF8(JsonFile,true); - if RemoveComments then - RemoveCommentsFromJSON(pointer(content)); - result := InitJSONInPlace(pointer(content),aOptions)<>nil; -end; - -procedure TDocVariantData.InitCSV(CSV: PUTF8Char; aOptions: TDocVariantOptions; - NameValueSep, ItemSep: AnsiChar; DoTrim: boolean); -var n,v: RawUTF8; - val: variant; -begin - Init(aOptions,dvObject); - while CSV<>nil do begin - GetNextItem(CSV,NameValueSep,n); - if ItemSep=#10 then - GetNextItemTrimedCRLF(CSV,v) else - GetNextItem(CSV,ItemSep,v); - if DoTrim then - v := trim(v); - if n='' then - break; - RawUTF8ToVariant(v,val); - AddValue(n,val); - end; -end; - -procedure TDocVariantData.InitCSV(const CSV: RawUTF8; aOptions: TDocVariantOptions; - NameValueSep, ItemSep: AnsiChar; DoTrim: boolean); -begin - InitCSV(pointer(CSV),aOptions,NameValueSep,ItemSep,DoTrim); -end; - -procedure TDocVariantData.InitCopy(const SourceDocVariant: variant; - aOptions: TDocVariantOptions); -var ndx,vt: integer; - Source: PDocVariantData; - SourceVValue: TVariantDynArray; - Handler: TCustomVariantType; - v: PVarData; -begin - with TVarData(SourceDocVariant) do - if integer(VType)=varByRef or varVariant then - Source := VPointer else - Source := @SourceDocVariant; - if integer(Source^.VType)<>DocVariantVType then - raise ESynException.CreateUTF8('No TDocVariant for InitCopy(%)',[ord(Source.VType)]); - SourceVValue := Source^.VValue; // local fast per-reference copy - if Source<>@self then begin - VType := Source^.VType; - VCount := Source^.VCount; - pointer(VName) := nil; // avoid GPF - pointer(VValue) := nil; - aOptions := aOptions-[dvoIsArray,dvoIsObject]; // may not be same as Source - if dvoIsArray in Source^.VOptions then - include(aOptions,dvoIsArray) else - if dvoIsObject in Source^.VOptions then begin - include(aOptions,dvoIsObject); - SetLength(VName,VCount); - for ndx := 0 to VCount-1 do - VName[ndx] := Source^.VName[ndx]; // manual copy is needed - if dvoInternNames in aOptions then - with DocVariantType.InternNames do - for ndx := 0 to VCount-1 do - UniqueText(VName[ndx]); - end; - VOptions := aOptions; - end else begin - SetOptions(aOptions); - VariantDynArrayClear(VValue); // full copy of all values - end; - if VCount>0 then begin - SetLength(VValue,VCount); - for ndx := 0 to VCount-1 do begin - v := @SourceVValue[ndx]; - repeat - vt := v^.VType; - if vt<>varByRef or varVariant then - break; - v := v^.VPointer; - until false; - if vt<=varNativeString then // simple string/number types copy - VValue[ndx] := variant(v^) else - if vt=DocVariantVType then // direct recursive copy for TDocVariant - TDocVariantData(VValue[ndx]).InitCopy(variant(v^),VOptions) else - if FindCustomVariantType(vt,Handler) then - if Handler.InheritsFrom(TSynInvokeableVariantType) then - TSynInvokeableVariantType(Handler).CopyByValue(TVarData(VValue[ndx]),v^) else - Handler.Copy(TVarData(VValue[ndx]),v^,false) else - VValue[ndx] := variant(v^); // default copy - end; - if dvoInternValues in VOptions then - with DocVariantType.InternValues do - for ndx := 0 to VCount-1 do - UniqueVariant(VValue[ndx]); - end; - VariantDynArrayClear(SourceVValue); -end; - -procedure TDocVariantData.Clear; -begin - if integer(VType)=DocVariantVType then begin - PInteger(@VType)^ := 0; - RawUTF8DynArrayClear(VName); - VariantDynArrayClear(VValue); - VCount := 0; - end else - VarClear(variant(self)); -end; - -procedure TDocVariantData.Reset; -var backup: TDocVariantOptions; -begin - if VCount=0 then - exit; - backup := VOptions-[dvoIsArray,dvoIsObject]; - DocVariantType.Clear(TVarData(self)); - VType := DocVariantVType; - VOptions := backup; -end; - -procedure TDocVariantData.FillZero; -var ndx: integer; -begin - for ndx := 0 to VCount-1 do - SynCommons.FillZero(VValue[ndx]); - Reset; -end; - -procedure TDocVariantData.SetCount(aCount: integer); -begin - VCount := aCount; -end; - -function TDocVariantData.InternalAdd(const aName: RawUTF8): integer; -var len: integer; -begin - if aName<>'' then begin - if dvoIsArray in VOptions then - raise EDocVariant.CreateUTF8('Add: Unexpected [%] object property in an array',[aName]); - if not(dvoIsObject in VOptions) then begin - VType := DocVariantVType; // may not be set yet - include(VOptions,dvoIsObject); - end; - end else begin - if dvoIsObject in VOptions then - raise EDocVariant.Create('Add: Unexpected array item in an object'); - if not(dvoIsArray in VOptions) then begin - VType := DocVariantVType; // may not be set yet - include(VOptions,dvoIsArray); - end; - end; - len := length(VValue); - if VCount>=len then begin - len := NextGrow(VCount); - SetLength(VValue,len); - end; - if aName<>'' then begin - if Length(VName)<>len then - SetLength(VName,len); - if dvoInternNames in VOptions then begin // inlined InternNames method - if DocVariantType.fInternNames=nil then - DocVariantType.fInternNames := TRawUTF8Interning.Create; - DocVariantType.fInternNames.Unique(VName[VCount],aName); - end else - VName[VCount] := aName; - end; - result := VCount; - inc(VCount); -end; - -procedure TDocVariantData.SetCapacity(aValue: integer); -begin - if dvoIsObject in VOptions then - SetLength(VName,aValue); - SetLength(VValue,aValue); -end; - -function TDocVariantData.AddValue(const aName: RawUTF8; - const aValue: variant; aValueOwned: boolean): integer; -begin - if dvoCheckForDuplicatedNames in VOptions then begin - result := GetValueIndex(aName); - if result>=0 then - raise EDocVariant.CreateUTF8('AddValue: Duplicated [%] name',[aName]); - end; - result := InternalAdd(aName); - if aValueOwned then - VValue[result] := aValue else - SetVariantByValue(aValue,VValue[result]); - if dvoInternValues in VOptions then - DocVariantType.InternValues.UniqueVariant(VValue[result]); -end; - -function TDocVariantData.AddValue(aName: PUTF8Char; aNameLen: integer; - const aValue: variant; aValueOwned: boolean): integer; -var tmp: RawUTF8; -begin - FastSetString(tmp,aName,aNameLen); - result := AddValue(tmp,aValue,aValueOwned); -end; - -function TDocVariantData.AddValueFromText(const aName,aValue: RawUTF8; - Update, AllowVarDouble: boolean): integer; -begin - if aName='' then begin - result := -1; - exit; - end; - result := GetValueIndex(aName); - if not Update and (dvoCheckForDuplicatedNames in VOptions) and (result>=0) then - raise EDocVariant.CreateUTF8('AddValueFromText: Duplicated [%] name',[aName]); - if result<0 then - result := InternalAdd(aName); - VarClear(VValue[result]); - if not GetNumericVariantFromJSON(pointer(aValue),TVarData(VValue[result]),AllowVarDouble) then - if dvoInternValues in VOptions then - DocVariantType.InternValues.UniqueVariant(VValue[result],aValue) else - RawUTF8ToVariant(aValue,VValue[result]); -end; - -procedure TDocVariantData.AddByPath(const aSource: TDocVariantData; - const aPaths: array of RawUTF8); -var p,added: integer; - v: TVarData; -begin - if (aSource.Count=0) or not(dvoIsObject in aSource.VOptions) or - (dvoIsArray in VOptions) then - exit; - for p := 0 to High(aPaths) do begin - DocVariantType.Lookup(v,TVarData(aSource),pointer(aPaths[p])); - if integer(v.VType)=0) and VariantEquals(VValue[result],aPropValue,aPropValueCaseSensitive) then - exit; - end else - if dvoIsArray in VOptions then - for result := 0 to VCount-1 do - with _Safe(VValue[result])^ do - if dvoIsObject in VOptions then begin - ndx := GetValueIndex(aPropName); - if (ndx>=0) and VariantEquals(VValue[ndx],aPropValue,aPropValueCaseSensitive) then - exit; - end; - result := -1; -end; - -function TDocVariantData.SearchItemByProp(const aPropNameFmt: RawUTF8; - const aPropNameArgs: array of const; const aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean): integer; -var name: RawUTF8; -begin - FormatUTF8(aPropNameFmt,aPropNameArgs,name); - result := SearchItemByProp(name,aPropValue,aPropValueCaseSensitive); -end; - -function TDocVariantData.SearchItemByValue(const aValue: Variant; - CaseInsensitive: boolean; StartIndex: integer): integer; -begin - for result := StartIndex to VCount-1 do - if SortDynArrayVariantComp(TVarData(VValue[result]),TVarData(aValue),CaseInsensitive)=0 then - exit; - result := -1; -end; - -type - TQuickSortDocVariant = object - names: PPointerArray; - values: PVariantArray; - nameCompare: TUTF8Compare; - valueCompare: TVariantCompare; - procedure SortByName(L, R: PtrInt); - procedure SortByValue(L, R: PtrInt); - end; - -procedure TQuickSortDocVariant.SortByName(L, R: PtrInt); -var I, J, P: PtrInt; - pivot: pointer; -begin - if L0 do Dec(J); - if I <= J then begin - if I <> J then begin - ExchgPointer(@names[I],@names[J]); - ExchgVariant(@values[I],@values[J]); - end; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - SortByName(L,J); - L := I; - end else begin - if I < R then - SortByName(I,R); - R := J; - end; - until L >= R; -end; - -procedure TQuickSortDocVariant.SortByValue(L, R: PtrInt); -var I, J, P: PtrInt; - pivot: PVariant; -begin - if L0 do Dec(J); - if I <= J then begin - if I <> J then begin - if names<>nil then - ExchgPointer(@names[I],@names[J]); - ExchgVariant(@values[I],@values[J]); - end; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - SortByValue(L,J); - L := I; - end else begin - if I < R then - SortByValue(I,R); - R := J; - end; - until L >= R; -end; - -procedure TDocVariantData.SortByName(Compare: TUTF8Compare); -var qs: TQuickSortDocVariant; -begin - if not(dvoIsObject in VOptions) or (VCount<=0) then - exit; - if Assigned(Compare) then - qs.nameCompare := Compare else - qs.nameCompare := @StrIComp; - qs.names := pointer(VName); - qs.values := pointer(VValue); - qs.SortByName(0,VCount-1); -end; - -procedure TDocVariantData.SortByValue(Compare: TVariantCompare); -var qs: TQuickSortDocVariant; -begin - if VCount<=0 then - exit; - if Assigned(Compare) then - qs.valueCompare := Compare else - qs.valueCompare := @VariantCompare; - qs.names := pointer(VName); - qs.values := pointer(VValue); - qs.SortByValue(0,VCount-1); -end; - -type - {$ifdef USERECORDWITHMETHODS}TQuickSortDocVariantValuesByField = record - {$else}TQuickSortDocVariantValuesByField = object{$endif} - Lookup: array of PVariant; - Compare: TVariantCompare; - Doc: PDocVariantData; - Reverse: boolean; - procedure Sort(L, R: PtrInt); - end; - -procedure TQuickSortDocVariantValuesByField.Sort(L, R: PtrInt); -var I, J, P: PtrInt; - pivot: PVariant; -begin - if L0 do Dec(J); - end - else begin - while Compare(Lookup[I]^,pivot^)>0 do Inc(I); - while Compare(Lookup[J]^,pivot^)<0 do Dec(J); - end; - if I <= J then begin - if I <> J then begin - if Doc.VName<>nil then - ExchgPointer(@Doc.VName[I],@Doc.VName[J]); - ExchgVariant(@Doc.VValue[I],@Doc.VValue[J]); - pivot := Lookup[I]; - Lookup[I] := Lookup[J]; - Lookup[J] := pivot; - end; - if P = I then P := J else if P = J then P := I; - inc(I); dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - Sort(L,J); - L := I; - end else begin - if I < R then - Sort(I,R); - R := J; - end; - until L >= R; -end; - -procedure TDocVariantData.SortArrayByField(const aItemPropName: RawUTF8; - aValueCompare: TVariantCompare; aValueCompareReverse: boolean; aNameSortedCompare: TUTF8Compare); -var - QS: TQuickSortDocVariantValuesByField; - p: pointer; - row: PtrInt; -begin - if (VCount<=0) or (aItemPropName='') or not (dvoIsArray in VOptions) then - exit; - if not Assigned(aValueCompare) then - QS.Compare := VariantCompare else - QS.Compare := aValueCompare; - QS.Reverse := aValueCompareReverse; - SetLength(QS.Lookup,VCount); - for row := 0 to VCount-1 do begin // resolve GetPVariantByName(aIdemPropName) once - p := _Safe(VValue[row])^.GetVarData(aItemPropName,aNameSortedCompare); - if p = nil then - p := @NullVarData; - QS.Lookup[row] := p; - end; - QS.Doc := @self; - QS.Sort(0,VCount-1); -end; - -procedure TDocVariantData.Reverse; -var arr: TDynArray; -begin - if VCount=0 then - exit; - if VName<>nil then begin - SetLength(VName,VCount); - arr.Init(TypeInfo(TRawUTF8DynArray),VName); - arr.Reverse; - end; - if VValue<>nil then begin - SetLength(VValue,VCount); - arr.Init(TypeInfo(TVariantDynArray),VValue); - arr.Reverse; - end; -end; - -function TDocVariantData.Reduce(const aPropNames: array of RawUTF8; - aCaseSensitive,aDoNotAddVoidProp: boolean): variant; -begin - VarClear(result); - Reduce(aPropNames,aCaseSensitive,PDocVariantData(@result)^,aDoNotAddVoidProp); -end; - -procedure TDocVariantData.Reduce(const aPropNames: array of RawUTF8; - aCaseSensitive: boolean; out result: TDocVariantData; aDoNotAddVoidProp: boolean); -var ndx,j: integer; - reduced: TDocVariantData; -begin - result.InitFast; - if (VCount=0) or (high(aPropNames)<0) then - exit; - if dvoIsObject in VOptions then begin - if aCaseSensitive then begin - for j := 0 to high(aPropNames) do - for ndx := 0 to VCount-1 do - if VName[ndx]=aPropNames[j] then begin - if not aDoNotAddVoidProp or not VarIsVoid(VValue[ndx]) then - result.AddValue(VName[ndx],VValue[ndx]); - break; - end; - end else - for j := 0 to high(aPropNames) do - for ndx := 0 to VCount-1 do - if IdemPropNameU(VName[ndx],aPropNames[j]) then begin - if not aDoNotAddVoidProp or not VarIsVoid(VValue[ndx]) then - result.AddValue(VName[ndx],VValue[ndx]); - break; - end; - end else - if dvoIsArray in VOptions then - for ndx := 0 to VCount-1 do begin - _Safe(VValue[ndx])^.Reduce(aPropNames,aCaseSensitive,reduced,aDoNotAddVoidProp); - if dvoIsObject in reduced.VOptions then - result.AddItem(variant(reduced)); - end; -end; - -function TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; - OnReduce: TOnReducePerItem): variant; -begin - VarClear(result); - ReduceAsArray(aPropName,PDocVariantData(@result)^,OnReduce); -end; - -procedure TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; - out result: TDocVariantData; OnReduce: TOnReducePerItem); -var ndx,j: integer; - item: PDocVariantData; -begin - result.InitFast; - if (VCount=0) or (aPropName='') or not(dvoIsArray in VOptions) then - exit; - for ndx := 0 to VCount-1 do begin - item := _Safe(VValue[ndx]); - j := item^.GetValueIndex(aPropName); - if j>=0 then - if not Assigned(OnReduce) or OnReduce(item) then - result.AddItem(item^.VValue[j]); - end; -end; - -function TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; - OnReduce: TOnReducePerValue): variant; -begin - VarClear(result); - ReduceAsArray(aPropName,PDocVariantData(@result)^,OnReduce); -end; - -procedure TDocVariantData.ReduceAsArray(const aPropName: RawUTF8; - out result: TDocVariantData; OnReduce: TOnReducePerValue); -var ndx,j: integer; - item: PDocVariantData; - v: PVariant; -begin - result.InitFast; - if (VCount=0) or (aPropName='') or not(dvoIsArray in VOptions) then - exit; - for ndx := 0 to VCount-1 do begin - item := _Safe(VValue[ndx]); - j := item^.GetValueIndex(aPropName); - if j>=0 then begin - v := @item^.VValue[j]; - if not Assigned(OnReduce) or OnReduce(v^) then - result.AddItem(v^); - end; - end; -end; - -function TDocVariantData.Rename(const aFromPropName, aToPropName: TRawUTF8DynArray): integer; -var n, p, ndx: integer; -begin - result := 0; - n := length(aFromPropName); - if length(aToPropName)=n then - for p := 0 to n-1 do begin - ndx := GetValueIndex(aFromPropName[p]); - if ndx>=0 then begin - VName[ndx] := aToPropName[p]; - inc(result); - end; - end; -end; - -function TDocVariantData.FlattenAsNestedObject(const aObjectPropName: RawUTF8): boolean; -var ndx,len: integer; - Up: array[byte] of AnsiChar; - nested: TDocVariantData; -begin // {"p.a1":5,"p.a2":"dfasdfa"} -> {"p":{"a1":5,"a2":"dfasdfa"}} - result := false; - if (VCount=0) or (aObjectPropName='') or not(dvoIsObject in VOptions) then - exit; - PWord(UpperCopy255(Up,aObjectPropName))^ := ord('.'); // e.g. 'P.' - for ndx := 0 to Count-1 do - if not IdemPChar(pointer(VName[ndx]),Up) then - exit; // all fields should match "p.####" - len := length(aObjectPropName)+1; - for ndx := 0 to Count-1 do - system.delete(VName[ndx],1,len); - nested := self; - Clear; - InitObject([aObjectPropName,variant(nested)]); - result := true; -end; - -function TDocVariantData.Delete(Index: integer): boolean; -begin - if cardinal(Index)>=cardinal(VCount) then - result := false else begin - dec(VCount); - if VName<>nil then begin - if PDACnt(PtrUInt(VName)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@VName,TypeInfo(TRawUTF8DynArray)); - VName[Index] := ''; - end; - if PDACnt(PtrUInt(VValue)-_DAREFCNT)^>1 then - DynArrayMakeUnique(@VValue,TypeInfo(TVariantDynArray)); - VarClear(VValue[Index]); - if Indexnil then begin - MoveFast(VName[Index+1],VName[Index],(VCount-Index)*SizeOf(pointer)); - PtrUInt(VName[VCount]) := 0; // avoid GPF - end; - MoveFast(VValue[Index+1],VValue[Index],(VCount-Index)*SizeOf(variant)); - TVarData(VValue[VCount]).VType := varEmpty; // avoid GPF - end; - result := true; - end; -end; - -function TDocVariantData.Delete(const aName: RawUTF8): boolean; -begin - result := Delete(GetValueIndex(aName)); -end; - -function TDocVariantData.DeleteByProp(const aPropName,aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean): boolean; -var ndx: integer; -begin - ndx := SearchItemByProp(aPropName,aPropValue,aPropValueCaseSensitive); - if ndx<0 then - result := false else - result := Delete(ndx); -end; - -function TDocVariantData.DeleteByValue(const aValue: Variant; - CaseInsensitive: boolean): integer; -var ndx: PtrInt; -begin - result := 0; - if VarIsEmptyOrNull(aValue) then begin - for ndx := VCount-1 downto 0 do - if VarDataIsEmptyOrNull(@VValue[ndx]) then begin - Delete(ndx); - inc(result); - end; - end else - for ndx := VCount-1 downto 0 do - if SortDynArrayVariantComp(TVarData(VValue[ndx]),TVarData(aValue),CaseInsensitive)=0 then begin - Delete(ndx); - inc(result); - end; -end; - -function TDocVariantData.DeleteByStartName(aStartName: PUTF8Char; aStartNameLen: integer): integer; -var ndx: integer; - upname: array[byte] of AnsiChar; -begin - result := 0; - if aStartNameLen=0 then - aStartNameLen := StrLen(aStartName); - if (VCount=0) or not(dvoIsObject in VOptions) or (aStartNameLen=0) then - exit; - UpperCopy255Buf(upname,aStartName,aStartNameLen)^ := #0; - for ndx := Count-1 downto 0 do - if IdemPChar(pointer(names[ndx]),upname) then begin - Delete(ndx); - inc(result); - end; -end; - -function FindNonVoidRawUTF8(n: PPtrInt; name: PUTF8Char; len: TStrLen; count: PtrInt): PtrInt; -begin // FPC does proper inlining in this loop - for result := 0 to count-1 do // all VName[]<>'' so n^<>0 - if (PStrLen(n^-_STRLEN)^=len) and CompareMemFixed(pointer(n^),name,len) then - exit else - inc(n); - result := -1; -end; - -function FindNonVoidRawUTF8I(n: PPtrInt; name: PUTF8Char; len: TStrLen; count: PtrInt): PtrInt; -begin - for result := 0 to count-1 do - if (PStrLen(n^-_STRLEN)^=len) and IdemPropNameUSameLen(pointer(n^),name,len) then - exit else - inc(n); - result := -1; -end; - -function TDocVariantData.GetValueIndex(aName: PUTF8Char; aNameLen: PtrInt; - aCaseSensitive: boolean): integer; -var err: integer; -begin - if (integer(VType)=DocVariantVType) and (VCount>0) and (aName<>nil) and(aNameLen>0) then - if dvoIsArray in VOptions then begin // try index text in array document - result := GetInteger(aName,err); - if (err<>0) or (cardinal(result)>=cardinal(VCount)) then - result := -1; - end else - // O(n) lookup for object names -> efficient brute force sub-functions - if aCaseSensitive then - result := FindNonVoidRawUTF8(pointer(VName),aName,aNameLen,VCount) else - result := FindNonVoidRawUTF8I(pointer(VName),aName,aNameLen,VCount) else - result := -1; -end; - -function TDocVariantData.GetValueOrRaiseException(const aName: RawUTF8): variant; -begin - RetrieveValueOrRaiseException(pointer(aName),length(aName), - dvoNameCaseSensitive in VOptions,result,false); -end; - -function TDocVariantData.GetValueOrDefault(const aName: RawUTF8; - const aDefault: variant): variant; -var ndx: integer; -begin - if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then - result := aDefault else begin - ndx := GetValueIndex(aName); - if ndx>=0 then - result := VValue[ndx] else - result := aDefault; - end; -end; - -function TDocVariantData.GetValueOrNull(const aName: RawUTF8): variant; -var ndx: integer; -begin - if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then - SetVariantNull(result) else begin - ndx := GetValueIndex(aName); - if ndx>=0 then - result := VValue[ndx] else - SetVariantNull(result); - end; -end; - -function TDocVariantData.GetValueOrEmpty(const aName: RawUTF8): variant; -var ndx: integer; -begin - VarClear(result); - if (integer(VType)=DocVariantVType) and (dvoIsObject in VOptions) then begin - ndx := GetValueIndex(aName); - if ndx>=0 then - result := VValue[ndx]; - end; -end; - -function TDocVariantData.GetAsBoolean(const aName: RawUTF8; out aValue: boolean; - aSortedCompare: TUTF8Compare): Boolean; -var found: PVarData; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := false else - result := VariantToBoolean(PVariant(found)^,aValue) -end; - -function TDocVariantData.GetAsInteger(const aName: RawUTF8; out aValue: integer; - aSortedCompare: TUTF8Compare): Boolean; -var found: PVarData; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := false else - result := VariantToInteger(PVariant(found)^,aValue); -end; - -function TDocVariantData.GetAsInt64(const aName: RawUTF8; out aValue: Int64; - aSortedCompare: TUTF8Compare): Boolean; -var found: PVarData; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := false else - result := VariantToInt64(PVariant(found)^,aValue) -end; - -function TDocVariantData.GetAsDouble(const aName: RawUTF8; out aValue: double; - aSortedCompare: TUTF8Compare): Boolean; -var found: PVarData; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := false else - result := VariantToDouble(PVariant(found)^,aValue); -end; - -function TDocVariantData.GetAsRawUTF8(const aName: RawUTF8; out aValue: RawUTF8; - aSortedCompare: TUTF8Compare): Boolean; -var found: PVarData; - wasString: boolean; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := false else begin - if integer(found^.VType)>varNull then // default VariantToUTF8(null)='null' - VariantToUTF8(PVariant(found)^,aValue,wasString); - result := true; - end; -end; - -function TDocVariantData.GetValueEnumerate(const aName: RawUTF8; - aTypeInfo: pointer; out aValue; aDeleteFoundEntry: boolean): boolean; -var text: RawUTF8; - ndx, ord: integer; -begin - result := false; - ndx := GetValueIndex(aName); - if ndx<0 then - exit; - VariantToUTF8(Values[ndx],text); - ord := GetEnumNameValue(aTypeInfo,text,true); - if ord<0 then - exit; - byte(aValue) := ord; - if aDeleteFoundEntry then - Delete(ndx); - result := true; -end; - -function TDocVariantData.GetAsDocVariant(const aName: RawUTF8; out aValue: PDocVariantData; - aSortedCompare: TUTF8Compare): boolean; -var found: PVarData; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := false else begin - aValue := _Safe(PVariant(found)^); - result := aValue<>@DocVariantDataFake; - end; -end; - -function TDocVariantData.GetAsDocVariantSafe(const aName: RawUTF8; - aSortedCompare: TUTF8Compare): PDocVariantData; -var found: PVarData; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := @DocVariantDataFake else - result := _Safe(PVariant(found)^); -end; - -function TDocVariantData.GetAsPVariant(const aName: RawUTF8; out aValue: PVariant; - aSortedCompare: TUTF8Compare): boolean; -begin - aValue := pointer(GetVarData(aName,aSortedCompare)); - result := aValue<>nil; -end; - -function TDocVariantData.GetAsPVariant(aName: PUTF8Char; aNameLen: PtrInt): PVariant; -var ndx: integer; -begin - ndx := GetValueIndex(aName,aNameLen,dvoNameCaseSensitive in VOptions); - if ndx>=0 then - result := @VValue[ndx] else - result := nil; -end; - -function TDocVariantData.GetVarData(const aName: RawUTF8; - aSortedCompare: TUTF8Compare): PVarData; -var ndx: integer; -begin - if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) or - (VCount=0) or (aName='') then - result := nil else begin - if Assigned(aSortedCompare) then - if @aSortedCompare=@StrComp then // to use branchless asm for StrComp() - ndx := FastFindPUTF8CharSorted(pointer(VName),VCount-1,pointer(aName)) else - ndx := FastFindPUTF8CharSorted(pointer(VName),VCount-1,pointer(aName),aSortedCompare) else - if dvoNameCaseSensitive in VOptions then - ndx := FindNonVoidRawUTF8(pointer(VName),pointer(aName),length(aName),VCount) else - ndx := FindNonVoidRawUTF8I(pointer(VName),pointer(aName),length(aName),VCount); - if ndx>=0 then - result := @VValue[ndx] else - result := nil; - end; -end; - -function TDocVariantData.GetVarData(const aName: RawUTF8; - var aValue: TVarData; aSortedCompare: TUTF8Compare): boolean; -var found: PVarData; -begin - found := GetVarData(aName,aSortedCompare); - if found=nil then - result := false else begin - aValue := found^; - result := true; - end; -end; - -function TDocVariantData.GetValueByPath(const aPath: RawUTF8): variant; -var Dest: TVarData; -begin - VarClear(result); - if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then - exit; - DocVariantType.Lookup(Dest,TVarData(self),pointer(aPath)); - if integer(Dest.VType)>=varNull then - result := variant(Dest); // copy -end; - -function TDocVariantData.GetValueByPath(const aPath: RawUTF8; out aValue: variant): boolean; -var Dest: TVarData; -begin - result := false; - if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) then - exit; - DocVariantType.Lookup(Dest,TVarData(self),pointer(aPath)); - if Dest.VType=varEmpty then - exit; - aValue := variant(Dest); // copy - result := true; -end; - -function TDocVariantData.GetPVariantByPath(const aPath: RawUTF8): PVariant; -var p: PUTF8Char; - item: RawUTF8; - par: PVariant; -begin - result := nil; - if (integer(VType)<>DocVariantVType) or (aPath='') or - not(dvoIsObject in VOptions) or (Count=0) then - exit; - par := @self; - P := pointer(aPath); - repeat - GetNextItem(P,'.',item); - if _Safe(par^).GetAsPVariant(item,result) then - par := result else begin - result := nil; - exit; - end; - until P=nil; - // if we reached here, we have par=result=found item -end; - -function TDocVariantData.GetDocVariantByPath(const aPath: RawUTF8; - out aValue: PDocVariantData): boolean; -var v: PVariant; -begin - v := GetPVariantByPath(aPath); - if v<>nil then begin - aValue := _Safe(v^); - result := integer(aValue^.VType)>varNull; - end else - result := false; -end; - -function TDocVariantData.GetValueByPath(const aDocVariantPath: array of RawUTF8): variant; -var found,res: PVarData; - vt,P: integer; -begin - VarClear(result); - if (integer(VType)<>DocVariantVType) or not(dvoIsObject in VOptions) or - (high(aDocVariantPath)<0) then - exit; - found := @self; - P := 0; - repeat - found := PDocVariantData(found).GetVarData(aDocVariantPath[P]); - if found=nil then - exit; - if P=high(aDocVariantPath) then - break; // we found the item! - inc(P); - // if we reached here, we should try for the next scope within Dest - repeat - vt := found^.VType; - if vt<>varByRef or varVariant then - break; - found := found^.VPointer; - until false; - if vt=VType then - continue; - exit; - until false; - res := found; - while integer(res^.VType)=varByRef or varVariant do - res := res^.VPointer; - if (integer(res^.VType)=VType) and (PDocVariantData(res)^.VCount=0) then - // return void TDocVariant as null - TVarData(result).VType := varNull else - // copy found value - result := PVariant(found)^; -end; - -function TDocVariantData.GetItemByProp(const aPropName,aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean; var Dest: variant; DestByRef: boolean): boolean; -var ndx: integer; -begin - result := false; - if not(dvoIsArray in VOptions) then - exit; - ndx := SearchItemByProp(aPropName,aPropValue,aPropValueCaseSensitive); - if ndx<0 then - exit; - RetrieveValueOrRaiseException(ndx,Dest,DestByRef); - result := true; -end; - -function TDocVariantData.GetDocVariantByProp(const aPropName,aPropValue: RawUTF8; - aPropValueCaseSensitive: boolean; out Dest: PDocVariantData): boolean; -var ndx: integer; -begin - result := false; - if not(dvoIsArray in VOptions) then - exit; - ndx := SearchItemByProp(aPropName,aPropValue,aPropValueCaseSensitive); - if ndx<0 then - exit; - Dest := _Safe(VValue[ndx]); - result := Dest^.VType>varNull; -end; - -function TDocVariantData.GetJsonByStartName(const aStartName: RawUTF8): RawUTF8; -var Up: array[byte] of AnsiChar; - temp: TTextWriterStackBuffer; - ndx: integer; - W: TTextWriter; -begin - if not(dvoIsObject in VOptions) or (VCount=0) then begin - result := NULL_STR_VAR; - exit; - end; - UpperCopy255(Up,aStartName)^ := #0; - W := DefaultTextWriterSerializer.CreateOwnedStream(temp); - try - W.Add('{'); - for ndx := 0 to VCount-1 do - if IdemPChar(Pointer(VName[ndx]),Up) then begin - if (dvoSerializeAsExtendedJson in VOptions) and - JsonPropNameValid(pointer(VName[ndx])) then begin - W.AddNoJSONEscape(pointer(VName[ndx]),Length(VName[ndx])); - end else begin - W.Add('"'); - W.AddJSONEscape(pointer(VName[ndx])); - W.Add('"'); - end; - W.Add(':'); - W.AddVariant(VValue[ndx],twJSONEscape); - W.Add(','); - end; - W.CancelLastComma; - W.Add('}'); - W.SetText(result); - finally - W.Free; - end; -end; - -function TDocVariantData.GetValuesByStartName(const aStartName: RawUTF8; - TrimLeftStartName: boolean): variant; -var Up: array[byte] of AnsiChar; - ndx: integer; - name: RawUTF8; -begin - if aStartName='' then begin - result := Variant(self); - exit; - end; - if not(dvoIsObject in VOptions) or (VCount=0) then begin - SetVariantNull(result); - exit; - end; - TDocVariant.NewFast(result); - UpperCopy255(Up,aStartName)^ := #0; - for ndx := 0 to VCount-1 do - if IdemPChar(Pointer(VName[ndx]),Up) then begin - name := VName[ndx]; - if TrimLeftStartName then - system.delete(name,1,length(aStartName)); - TDocVariantData(result).AddValue(name,VValue[ndx]); - end; -end; - -procedure TDocVariantData.SetValueOrRaiseException(Index: integer; const NewValue: variant); -begin - if cardinal(Index)>=cardinal(VCount) then - raise EDocVariant.CreateUTF8('Out of range Values[%] (count=%)',[Index,VCount]) else - VValue[Index] := NewValue; -end; - -procedure TDocVariantData.RetrieveNameOrRaiseException(Index: integer; - var Dest: RawUTF8); -begin - if (cardinal(Index)>=cardinal(VCount)) or (VName=nil) then - if dvoReturnNullForUnknownProperty in VOptions then - Dest := '' else - raise EDocVariant.CreateUTF8('Out of range Names[%] (count=%)',[Index,VCount]) else - Dest := VName[Index]; -end; - -procedure TDocVariantData.RetrieveValueOrRaiseException(Index: integer; - var Dest: variant; DestByRef: boolean); -var Source: PVariant; -begin - if cardinal(Index)>=cardinal(VCount) then - if dvoReturnNullForUnknownProperty in VOptions then - SetVariantNull(Dest) else - raise EDocVariant.CreateUTF8('Out of range Values[%] (count=%)',[Index,VCount]) else - if DestByRef then - SetVariantByRef(VValue[Index],Dest) else begin - Source := @VValue[Index]; - while PVarData(Source)^.VType=varVariant or varByRef do - Source := PVarData(Source)^.VPointer; - Dest := Source^; - end; -end; - -function TDocVariantData.RetrieveValueOrRaiseException( - aName: PUTF8Char; aNameLen: integer; aCaseSensitive: boolean; - var Dest: variant; DestByRef: boolean): boolean; -var ndx: Integer; -begin - ndx := GetValueIndex(aName,aNameLen,aCaseSensitive); - if ndx<0 then - if dvoReturnNullForUnknownProperty in VOptions then - SetVariantNull(Dest) else - raise EDocVariant.CreateUTF8('[%] property not found',[aName]) else - RetrieveValueOrRaiseException(ndx,Dest,DestByRef); - result := ndx>=0; -end; - -function TDocVariantData.GetValueOrItem(const aNameOrIndex: variant): variant; -var wasString: boolean; - Name: RawUTF8; -begin - if dvoIsArray in VOptions then // fast index lookup e.g. for Value[1] - RetrieveValueOrRaiseException(VariantToIntegerDef(aNameOrIndex,-1),result,true) else begin - VariantToUTF8(aNameOrIndex,Name,wasString); // by name lookup e.g. for Value['abc'] - if wasString then - RetrieveValueOrRaiseException(pointer(Name),length(Name), - dvoNameCaseSensitive in VOptions,result,true) else - RetrieveValueOrRaiseException(GetIntegerDef(pointer(Name),-1),result,true); - end; -end; - -procedure TDocVariantData.SetValueOrItem(const aNameOrIndex, aValue: variant); -var wasString: boolean; - ndx: integer; - Name: RawUTF8; -begin - if dvoIsArray in VOptions then // fast index lookup e.g. for Value[1] - SetValueOrRaiseException(VariantToIntegerDef(aNameOrIndex,-1),aValue) else begin - VariantToUTF8(aNameOrIndex,Name,wasString); // by name lookup e.g. for Value['abc'] - if wasString then begin - ndx := GetValueIndex(Name); - if ndx<0 then - ndx := InternalAdd(Name); - SetVariantByValue(aValue,VValue[ndx]); - if dvoInternValues in VOptions then - DocVariantType.InternValues.UniqueVariant(VValue[ndx]); - end else - SetValueOrRaiseException(VariantToIntegerDef(aNameOrIndex,-1),aValue); - end; -end; - -function TDocVariantData.AddOrUpdateValue(const aName: RawUTF8; - const aValue: variant; wasAdded: PBoolean; OnlyAddMissing: boolean): integer; -begin - if dvoIsArray in VOptions then - raise EDocVariant.CreateUTF8('AddOrUpdateValue("%") on an array',[aName]); - result := GetValueIndex(aName); - if result<0 then begin - result := InternalAdd(aName); - if wasAdded<>nil then - wasAdded^ := true; - end else begin - if wasAdded<>nil then - wasAdded^ := false; - if OnlyAddMissing then - exit; - end; - SetVariantByValue(aValue,VValue[result]); - if dvoInternValues in VOptions then - DocVariantType.InternValues.UniqueVariant(VValue[result]); -end; - -function TDocVariantData.ToJSON(const Prefix, Suffix: RawUTF8; - Format: TTextWriterJSONFormat): RawUTF8; -var W: TTextWriter; - temp: TTextWriterStackBuffer; -begin - if (integer(VType)<>DocVariantVType) and (VType>varNull) then begin - result := ''; // null -> 'null' - exit; - end; - W := DefaultTextWriterSerializer.CreateOwnedStream(temp); - try - W.AddString(Prefix); - DocVariantType.ToJSON(W,variant(self),twJSONEscape); - W.AddString(Suffix); - W.SetText(result, Format); - finally - W.Free; - end; -end; - -function TDocVariantData.ToNonExpandedJSON: RawUTF8; -var fields: TRawUTF8DynArray; - fieldsCount: integer; - W: TTextWriter; - r,f: integer; - row: PDocVariantData; - temp: TTextWriterStackBuffer; -begin - fields := nil; // to please Kylix - fieldsCount := 0; - if not(dvoIsArray in VOptions) then begin - result := ''; - exit; - end; - if VCount=0 then begin - result := '[]'; - exit; - end; - with _Safe(VValue[0])^ do - if dvoIsObject in VOptions then begin - fields := VName; - fieldsCount := VCount; - end; - if fieldsCount=0 then - raise EDocVariant.Create('ToNonExpandedJSON: Value[0] is not an object'); - W := DefaultTextWriterSerializer.CreateOwnedStream(temp); - try - W.Add('{"fieldCount":%,"rowCount":%,"values":[',[fieldsCount,VCount]); - for f := 0 to fieldsCount-1 do begin - W.Add('"'); - W.AddJSONEscape(pointer(fields[f])); - W.Add('"',','); - end; - for r := 0 to VCount-1 do begin - row := _Safe(VValue[r]); - if (r>0) and (not(dvoIsObject in row^.VOptions) or (row^.VCount<>fieldsCount)) then - raise EDocVariant.CreateUTF8('ToNonExpandedJSON: Value[%] not expected object',[r]); - for f := 0 to fieldsCount-1 do - if (r>0) and not IdemPropNameU(row^.VName[f],fields[f]) then - raise EDocVariant.CreateUTF8('ToNonExpandedJSON: Value[%] field=% expected=%', - [r,row^.VName[f],fields[f]]) else begin - W.AddVariant(row^.VValue[f],twJSONEscape); - W.Add(','); - end; - end; - W.CancelLastComma; - W.Add(']','}'); - W.SetText(result); - finally - W.Free; - end; -end; - -procedure TDocVariantData.ToRawUTF8DynArray(out Result: TRawUTF8DynArray); -var ndx: integer; - wasString: boolean; -begin - if dvoIsObject in VOptions then - raise EDocVariant.Create('ToRawUTF8DynArray expects a dvArray'); - if dvoIsArray in VOptions then begin - SetLength(Result,VCount); - for ndx := 0 to VCount-1 do - VariantToUTF8(VValue[ndx],Result[ndx],wasString); - end; -end; - -function TDocVariantData.ToRawUTF8DynArray: TRawUTF8DynArray; -begin - ToRawUTF8DynArray(result); -end; - -function TDocVariantData.ToCSV(const Separator: RawUTF8): RawUTF8; -var tmp: TRawUTF8DynArray; // fast enough in practice -begin - ToRawUTF8DynArray(tmp); - result := RawUTF8ArrayToCSV(tmp,Separator); -end; - -procedure TDocVariantData.ToTextPairsVar(out result: RawUTF8; - const NameValueSep, ItemSep: RawUTF8; escape: TTextWriterKind); -var ndx: integer; - temp: TTextWriterStackBuffer; -begin - if dvoIsArray in VOptions then - raise EDocVariant.Create('ToTextPairs expects a dvObject'); - if (VCount>0) and (dvoIsObject in VOptions) then - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - ndx := 0; - repeat - AddString(VName[ndx]); - AddString(NameValueSep); - AddVariant(VValue[ndx],escape); - inc(ndx); - if ndx=VCount then - break; - AddString(ItemSep); - until false; - SetText(result); - finally - Free; - end; -end; - -function TDocVariantData.ToTextPairs(const NameValueSep: RawUTF8; - const ItemSep: RawUTF8; Escape: TTextWriterKind): RawUTF8; -begin - ToTextPairsVar(result,NameValueSep,ItemSep,escape); -end; - -procedure TDocVariantData.ToArrayOfConst(out Result: TTVarRecDynArray); -var ndx: integer; -begin - if dvoIsObject in VOptions then - raise EDocVariant.Create('ToArrayOfConst expects a dvArray'); - if dvoIsArray in VOptions then begin - SetLength(Result,VCount); - for ndx := 0 to VCount-1 do begin - Result[ndx].VType := vtVariant; - Result[ndx].VVariant := @VValue[ndx]; - end; - end; -end; - -function TDocVariantData.ToArrayOfConst: TTVarRecDynArray; -begin - ToArrayOfConst(result); -end; - -function TDocVariantData.ToUrlEncode(const UriRoot: RawUTF8): RawUTF8; -var json: RawUTF8; // temporary in-place modified buffer -begin - VariantSaveJSON(variant(self),twJSONEscape,json); - result := UrlEncodeJsonObject(UriRoot,Pointer(json),[]); -end; - -function TDocVariantData.GetOrAddIndexByName(const aName: RawUTF8): integer; -begin - result := GetValueIndex(aName); - if result<0 then - result := InternalAdd(aName); -end; - -function TDocVariantData.GetOrAddPVariantByName(const aName: RawUTF8): PVariant; -var ndx: integer; -begin - ndx := GetValueIndex(aName); - if ndx<0 then - ndx := InternalAdd(aName); - result := @VValue[ndx]; -end; - -function TDocVariantData.GetPVariantByName(const aName: RawUTF8): PVariant; -var ndx: Integer; -begin - ndx := GetValueIndex(aName); - if ndx<0 then - if dvoReturnNullForUnknownProperty in VOptions then - result := @DocVariantDataFake else - raise EDocVariant.CreateUTF8('[%] property not found',[aName]) else - result := @VValue[ndx]; -end; - -function TDocVariantData.GetInt64ByName(const aName: RawUTF8): Int64; -begin - if not VariantToInt64(GetPVariantByName(aName)^,result) then - result := 0; -end; - -function TDocVariantData.GetRawUTF8ByName(const aName: RawUTF8): RawUTF8; -var wasString: boolean; - v: PVariant; -begin - v := GetPVariantByName(aName); - if PVarData(v)^.VType<=varNull then // default VariantToUTF8(null)='null' - result := '' else - VariantToUTF8(v^,result,wasString); -end; - -function TDocVariantData.GetStringByName(const aName: RawUTF8): string; -begin - result := VariantToString(GetPVariantByName(aName)^); -end; - -procedure TDocVariantData.SetInt64ByName(const aName: RawUTF8; - const aValue: Int64); -begin - GetOrAddPVariantByName(aName)^ := aValue; -end; - -procedure TDocVariantData.SetRawUTF8ByName(const aName, aValue: RawUTF8); -begin - RawUTF8ToVariant(aValue,GetOrAddPVariantByName(aName)^); -end; - -procedure TDocVariantData.SetStringByName(const aName: RawUTF8; const aValue: string); -begin - RawUTF8ToVariant(StringToUTF8(aValue),GetOrAddPVariantByName(aName)^); -end; - -function TDocVariantData.GetBooleanByName(const aName: RawUTF8): Boolean; -begin - if not VariantToBoolean(GetPVariantByName(aName)^,result) then - result := false; -end; - -procedure TDocVariantData.SetBooleanByName(const aName: RawUTF8; aValue: Boolean); -begin - GetOrAddPVariantByName(aName)^ := aValue; -end; - -function TDocVariantData.GetDoubleByName(const aName: RawUTF8): Double; -begin - if not VariantToDouble(GetPVariantByName(aName)^,result) then - result := 0; -end; - -procedure TDocVariantData.SetDoubleByName(const aName: RawUTF8; - const aValue: Double); -begin - GetOrAddPVariantByName(aName)^ := aValue; -end; - -function TDocVariantData.GetDocVariantExistingByName(const aName: RawUTF8; - aNotMatchingKind: TDocVariantKind): PDocVariantData; -begin - result := GetAsDocVariantSafe(aName); - if result^.Kind=aNotMatchingKind then - result := @DocVariantDataFake; -end; - -function TDocVariantData.GetDocVariantOrAddByName(const aName: RawUTF8; - aKind: TDocVariantKind): PDocVariantData; -var ndx: integer; -begin - ndx := GetOrAddIndexByName(aName); - result := _Safe(VValue[ndx]); - if result^.Kind<>aKind then begin - result := @VValue[ndx]; - VarClear(PVariant(result)^); - result^.Init(JSON_OPTIONS_FAST,aKind); - end; -end; - -function TDocVariantData.GetObjectExistingByName(const aName: RawUTF8): PDocVariantData; -begin - result := GetDocVariantExistingByName(aName,dvArray); -end; - -function TDocVariantData.GetObjectOrAddByName(const aName: RawUTF8): PDocVariantData; -begin - result := GetDocVariantOrAddByName(aName,dvObject); -end; - -function TDocVariantData.GetArrayExistingByName(const aName: RawUTF8): PDocVariantData; -begin - result := GetDocVariantExistingByName(aName,dvObject); -end; - -function TDocVariantData.GetArrayOrAddByName(const aName: RawUTF8): PDocVariantData; -begin - result := GetDocVariantOrAddByName(aName,dvArray); -end; - -function TDocVariantData.GetAsDocVariantByIndex(aIndex: integer): PDocVariantData; -begin - if cardinal(aIndex)4) and (Name[0]='_') and - IntGetPseudoProp(IdemPCharArray(@Name[1],['COUNT','KIND','JSON']),dv,variant(Dest)) then - result := true else - result := dv.RetrieveValueOrRaiseException(pointer(Name),NameLen, - dvoNameCaseSensitive in dv.VOptions,PVariant(@Dest)^,{byref=}true); -end; - -function TDocVariant.IntSet(const Instance, Value: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; -var ndx: Integer; - aName: RawUTF8; - dv: TDocVariantData absolute Instance; -begin - result := true; - if (dvoIsArray in dv.VOptions) and (PWord(Name)^=ord('_')) then begin - ndx := dv.InternalAdd(''); - SetVariantByValue(variant(Value),dv.VValue[ndx]); - if dvoInternValues in dv.VOptions then - DocVariantType.InternValues.UniqueVariant(dv.VValue[ndx]); - exit; - end; - ndx := dv.GetValueIndex(pointer(Name),NameLen,dvoNameCaseSensitive in dv.VOptions); - if ndx<0 then begin - FastSetString(aName,Name,NameLen); - ndx := dv.InternalAdd(aName); - end; - SetVariantByValue(variant(Value),dv.VValue[ndx]); - if dvoInternValues in dv.VOptions then - DocVariantType.InternValues.UniqueVariant(dv.VValue[ndx]); -end; - -function TDocVariant.IterateCount(const V: TVarData): integer; -var Data: TDocVariantData absolute V; -begin - if dvoIsArray in Data.VOptions then - result := Data.VCount else - result := -1; -end; - -procedure TDocVariant.Iterate(var Dest: TVarData; const V: TVarData; Index: integer); -var Data: TDocVariantData absolute V; -begin - if (dvoIsArray in Data.VOptions) and (cardinal(Index) read/only - 0: if SameText(Name,'Clear') then begin - Data^.VCount := 0; - Data^.VOptions := Data^.VOptions-[dvoIsObject,dvoIsArray]; - exit; - end; {$endif FPC} - 1: {$ifndef FPC} if SameText(Name,'Add') then begin - ndx := Data^.InternalAdd(''); - SetVariantByValue(variant(Arguments[0]),Data^.VValue[ndx]); - if dvoInternValues in Data^.VOptions then - DocVariantType.InternValues.UniqueVariant(Data^.VValue[ndx]); - exit; - end else - if SameText(Name,'Delete') then begin - SetTempFromFirstArgument; - Data^.Delete(Data^.GetValueIndex(temp)); - exit; - end else {$endif FPC} - if SameText(Name,'Exists') then begin - SetTempFromFirstArgument; - variant(Dest) := Data^.GetValueIndex(temp)>=0; - exit; - end else - if SameText(Name,'NameIndex') then begin - SetTempFromFirstArgument; - variant(Dest) := Data^.GetValueIndex(temp); - exit; - end else - if VariantToInteger(variant(Arguments[0]),ndx) then begin - if (Name='_') or SameText(Name,'Value') then begin - Data^.RetrieveValueOrRaiseException(ndx,variant(Dest),true); - exit; - end else - if SameText(Name,'Name') then begin - Data^.RetrieveNameOrRaiseException(ndx,temp); - RawUTF8ToVariant(temp,variant(Dest)); - exit; - end; - end else - if (Name='_') or SameText(Name,'Value') then begin - SetTempFromFirstArgument; - Data^.RetrieveValueOrRaiseException(pointer(temp),length(temp), - dvoNameCaseSensitive in Data^.VOptions,variant(Dest),true); - exit; - end; - 2:{$ifndef FPC} if SameText(Name,'Add') then begin - SetTempFromFirstArgument; - ndx := Data^.InternalAdd(temp); - SetVariantByValue(variant(Arguments[1]),Data^.VValue[ndx]); - if dvoInternValues in Data^.VOptions then - DocVariantType.InternValues.UniqueVariant(Data^.VValue[ndx]); - exit; - end; {$endif FPC} - end; - result := false; -end; - -procedure TDocVariant.ToJSON(W: TTextWriter; const Value: variant; - escape: TTextWriterKind); -var ndx: integer; - vt: cardinal; - forced: TTextWriterOptions; - checkExtendedPropName: boolean; -begin - vt := TDocVariantData(Value).VType; - if vt>varNull then - if vt=cardinal(DocVariantVType) then - with TDocVariantData(Value) do - if [dvoIsArray,dvoIsObject]*VOptions=[] then - W.AddShort('null') else begin - if [twoForceJSONExtended,twoForceJSONStandard]*W.CustomOptions=[] then begin - if dvoSerializeAsExtendedJson in VOptions then - forced := [twoForceJSONExtended] else - forced := [twoForceJSONStandard]; - W.CustomOptions := W.CustomOptions+forced; - end else - forced := []; - if dvoIsObject in VOptions then begin - checkExtendedPropName := twoForceJSONExtended in W.CustomOptions; - W.Add('{'); - for ndx := 0 to VCount-1 do begin - if checkExtendedPropName and JsonPropNameValid(pointer(VName[ndx])) then begin - W.AddNoJSONEscape(pointer(VName[ndx]),Length(VName[ndx])); - end else begin - W.Add('"'); - W.AddJSONEscape(pointer(VName[ndx])); - W.Add('"'); - end; - W.Add(':'); - W.AddVariant(VValue[ndx],twJSONEscape); - W.Add(','); - end; - W.CancelLastComma; - W.Add('}'); - end else begin - W.Add('['); - for ndx := 0 to VCount-1 do begin - W.AddVariant(VValue[ndx],twJSONEscape); - W.Add(','); - end; - W.CancelLastComma; - W.Add(']'); - end; - if forced<>[] then - W.CustomOptions := W.CustomOptions-forced; - end else - raise ESynException.CreateUTF8('Unexpected variant type %',[vt]) else - W.AddShort('null'); -end; - -procedure TDocVariant.Clear(var V: TVarData); -var dv: TDocVariantData absolute V; -begin - //Assert(V.VType=DocVariantVType); - RawUTF8DynArrayClear(dv.VName); - VariantDynArrayClear(dv.VValue); - ZeroFill(@V); // will set V.VType := varEmpty and VCount=0 -end; - -procedure TDocVariant.Copy(var Dest: TVarData; const Source: TVarData; - const Indirect: Boolean); -begin - //Assert(Source.VType=DocVariantVType); - if Indirect then - SimplisticCopy(Dest,Source,true) else - if dvoValueCopiedByReference in TDocVariantData(Source).Options then begin - VarClear(variant(Dest)); // Dest may be a complex type - pointer(TDocVariantData(Dest).VName) := nil; // avoid GPF - pointer(TDocVariantData(Dest).VValue) := nil; - TDocVariantData(Dest) := TDocVariantData(Source); // copy whole record - end else - CopyByValue(Dest,Source); -end; - -procedure TDocVariant.CopyByValue(var Dest: TVarData; const Source: TVarData); -var S: TDocVariantData absolute Source; - D: TDocVariantData absolute Dest; - i: integer; -begin - //Assert(Source.VType=DocVariantVType); - VarClear(variant(Dest)); // Dest may be a complex type - D.VType := S.VType; - D.VOptions := S.VOptions; // copies also Kind - D.VCount := S.VCount; - pointer(D.VName) := nil; // avoid GPF - pointer(D.VValue) := nil; - if S.VCount=0 then - exit; // no data to copy - D.VName := S.VName; // names can always be safely copied - // slower but safe by-value copy - SetLength(D.VValue,S.VCount); - for i := 0 to S.VCount-1 do - D.VValue[i] := S.VValue[i]; -end; - -procedure TDocVariant.Cast(var Dest: TVarData; const Source: TVarData); -begin - CastTo(Dest,Source,VarType); -end; - -procedure TDocVariant.CastTo(var Dest: TVarData; - const Source: TVarData; const AVarType: TVarType); -var Tmp: RawUTF8; - wasString: boolean; -begin - if AVarType=VarType then begin - VariantToUTF8(Variant(Source),Tmp,wasString); - if wasString then begin - VarClear(variant(Dest)); - variant(Dest) := _JSONFast(Tmp); // convert from JSON text - exit; - end; - RaiseCastError; - end else begin - if Source.VType<>VarType then - RaiseCastError; - VariantSaveJSON(variant(Source),twJSONEscape,tmp); - RawUTF8ToVariant(Tmp,Dest,AVarType); // convert to JSON text - end; -end; - -procedure TDocVariant.Compare(const Left, Right: TVarData; - var Relationship: TVarCompareResult); -var res: integer; - LeftU,RightU: RawUTF8; -begin - VariantSaveJSON(variant(Left),twJSONEscape,LeftU); - VariantSaveJSON(variant(Right),twJSONEscape,RightU); - if LeftU=RightU then - Relationship := crEqual else begin - res := StrComp(pointer(LeftU),pointer(RightU)); - if res<0 then - Relationship := crLessThan else - if res>0 then - Relationship := crGreaterThan else - Relationship := crEqual; - end; -end; - -class procedure TDocVariant.New(out aValue: variant; - aOptions: TDocVariantOptions); -begin - TDocVariantData(aValue).Init(aOptions); -end; - -class procedure TDocVariant.NewFast(out aValue: variant); -begin - TDocVariantData(aValue).InitFast; -end; - -class procedure TDocVariant.IsOfTypeOrNewFast(var aValue: variant); -begin - if DocVariantType.IsOfType(aValue) then - exit; - VarClear(aValue); - TDocVariantData(aValue).InitFast; -end; - -class procedure TDocVariant.NewFast(const aValues: array of PDocVariantData); -var i: integer; -begin - for i := 0 to high(aValues) do - aValues[i]^.InitFast; -end; - -class function TDocVariant.New(Options: TDocVariantOptions): Variant; -begin - VarClear(result); - TDocVariantData(result).Init(Options); -end; - -class function TDocVariant.NewObject(const NameValuePairs: array of const; - Options: TDocVariantOptions): variant; -begin - VarClear(result); - TDocVariantData(result).InitObject(NameValuePairs,Options); -end; - -class function TDocVariant.NewArray(const Items: array of const; - Options: TDocVariantOptions): variant; -begin - VarClear(result); - TDocVariantData(result).InitArray(Items,Options); -end; - -class function TDocVariant.NewArray(const Items: TVariantDynArray; - Options: TDocVariantOptions): variant; -begin - VarClear(result); - TDocVariantData(result).InitArrayFromVariants(Items,Options); -end; - -class function TDocVariant.NewJSON(const JSON: RawUTF8; - Options: TDocVariantOptions): variant; -begin - _Json(JSON,result,Options); -end; - -class function TDocVariant.NewUnique(const SourceDocVariant: variant; - Options: TDocVariantOptions): variant; -begin - VarClear(result); - TDocVariantData(result).InitCopy(SourceDocVariant,Options); -end; - -class procedure TDocVariant.GetSingleOrDefault(const docVariantArray, default: variant; - var result: variant); -var vt: integer; -begin - vt := TVarData(DocVariantArray).VType; - if vt=varByRef or varVariant then - GetSingleOrDefault(PVariant(TVarData(DocVariantArray).VPointer)^,default,result) else - if (vt<>DocVariantVType) or (TDocVariantData(DocVariantArray).Count<>1) or - not(dvoIsArray in TDocVariantData(DocVariantArray).VOptions) then - result := default else - result := TDocVariantData(DocVariantArray).Values[0]; -end; - -function ToText(kind: TDocVariantKind): PShortString; -begin - result := GetEnumName(TypeInfo(TDocVariantKind),ord(kind)); -end; - -function _Obj(const NameValuePairs: array of const; - Options: TDocVariantOptions): variant; -begin - VarClear(result); - TDocVariantData(result).InitObject(NameValuePairs,Options); -end; - -function _Arr(const Items: array of const; - Options: TDocVariantOptions): variant; -begin - VarClear(result); - TDocVariantData(result).InitArray(Items,Options); -end; - -procedure _ObjAddProps(const NameValuePairs: array of const; var Obj: variant); -var o: PDocVariantData; -begin - o := _Safe(Obj); - if not(dvoIsObject in o^.VOptions) then begin // create new object - VarClear(Obj); - TDocVariantData(Obj).InitObject(NameValuePairs,JSON_OPTIONS_FAST); - end else begin // append new names/values to existing object - TVarData(Obj) := PVarData(o)^; // ensure not stored by reference - o^.AddNameValuesToObject(NameValuePairs); - end; -end; - -procedure _ObjAddProps(const Document: variant; var Obj: variant); -var ndx: integer; - d,o: PDocVariantData; -begin - d := _Safe(Document); - o := _Safe(Obj); - if dvoIsObject in d.VOptions then - if not(dvoIsObject in o.VOptions) then - Obj := Document else - for ndx := 0 to d^.VCount-1 do - o^.AddOrUpdateValue(d^.VName[ndx],d^.VValue[ndx]); -end; - -function _ObjFast(const NameValuePairs: array of const): variant; -begin - VarClear(result); - TDocVariantData(result).InitObject(NameValuePairs,JSON_OPTIONS_FAST); -end; - -function _ObjFast(aObject: TObject; aOptions: TTextWriterWriteObjectOptions): variant; -begin - VarClear(result); - if TDocVariantData(result).InitJSONInPlace( - pointer(ObjectToJson(aObject,aOptions)),JSON_OPTIONS_FAST)=nil then - VarClear(result); -end; - -function _ArrFast(const Items: array of const): variant; -begin - VarClear(result); - TDocVariantData(result).InitArray(Items,JSON_OPTIONS_FAST); -end; - -function _Json(const JSON: RawUTF8; Options: TDocVariantOptions): variant; -begin - _Json(JSON,result,Options); -end; - -function _JsonFast(const JSON: RawUTF8): variant; -begin - _Json(JSON,result,JSON_OPTIONS_FAST); -end; - -function _JsonFastFloat(const JSON: RawUTF8): variant; -begin - _Json(JSON,result,JSON_OPTIONS_FAST_FLOAT); -end; - -function _JsonFastExt(const JSON: RawUTF8): variant; -begin - _Json(JSON,result,JSON_OPTIONS_FAST_EXTENDED); -end; - -function _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; - Options: TDocVariantOptions): variant; -begin - _JsonFmt(Format,Args,Params,Options,result); -end; - -procedure _JsonFmt(const Format: RawUTF8; const Args,Params: array of const; - Options: TDocVariantOptions; out result: variant); -var temp: RawUTF8; -begin - temp := FormatUTF8(Format,Args,Params,true); - if TDocVariantData(result).InitJSONInPlace(pointer(temp),Options)=nil then - TDocVariantData(result).Clear; -end; - -function _JsonFastFmt(const Format: RawUTF8; const Args,Params: array of const): variant; -begin - _JsonFmt(Format,Args,Params,JSON_OPTIONS_FAST,result); -end; - -function _Json(const JSON: RawUTF8; var Value: variant; - Options: TDocVariantOptions): boolean; -begin - VarClear(Value); - if not TDocVariantData(Value).InitJSON(JSON,Options) then begin - VarClear(Value); - result := false; - end else - result := true; -end; - -procedure _Unique(var DocVariant: variant); -begin // TDocVariantData(DocVariant): InitCopy() will check the DocVariant type - TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS[false]); -end; - -procedure _UniqueFast(var DocVariant: variant); -begin // TDocVariantData(DocVariant): InitCopy() will check the DocVariant type - TDocVariantData(DocVariant).InitCopy(DocVariant,JSON_OPTIONS_FAST); -end; - -function _Copy(const DocVariant: variant): variant; -begin - result := TDocVariant.NewUnique(DocVariant,JSON_OPTIONS[false]); -end; - -function _CopyFast(const DocVariant: variant): variant; -begin - result := TDocVariant.NewUnique(DocVariant,JSON_OPTIONS_FAST); -end; - -function _ByRef(const DocVariant: variant; Options: TDocVariantOptions): variant; -begin - VarClear(result); - TDocVariantData(result) := _Safe(DocVariant)^; // fast byref copy - TDocVariantData(result).SetOptions(Options); -end; - -procedure _ByRef(const DocVariant: variant; out Dest: variant; - Options: TDocVariantOptions); -begin - TDocVariantData(Dest) := _Safe(DocVariant)^; // fast byref copy - TDocVariantData(Dest).SetOptions(Options); -end; - -function ObjectToVariant(Value: TObject; EnumSetsAsText: boolean): variant; -const OPTIONS: array[boolean] of TTextWriterWriteObjectOptions = ( - [woDontStoreDefault],[woDontStoreDefault,woEnumSetsAsText]); -begin - VarClear(result); - ObjectToVariant(Value,result,OPTIONS[EnumSetsAsText]); -end; - -procedure ObjectToVariant(Value: TObject; out Dest: variant); -begin - ObjectToVariant(Value,Dest,[woDontStoreDefault]); -end; - -procedure ObjectToVariant(Value: TObject; var result: variant; - Options: TTextWriterWriteObjectOptions); -var json: RawUTF8; -begin - json := ObjectToJSON(Value,Options); - PDocVariantData(@result)^.InitJSONInPlace(pointer(json),JSON_OPTIONS_FAST); -end; - -{$endif NOVARIANTS} - - -{ ****************** TDynArray wrapper } - -{$ifndef DELPHI5OROLDER} // do not know why Delphi 5 compiler does not like CopyFrom() -procedure DynArrayCopy(var Dest; const Source; SourceMaxElem: integer; - TypeInfo: pointer); -var DestDynArray: TDynArray; -begin - DestDynArray.Init(TypeInfo,Dest); - DestDynArray.CopyFrom(Source,SourceMaxElem); -end; -{$endif DELPHI5OROLDER} - -function DynArrayLoad(var Value; Source: PAnsiChar; TypeInfo: pointer): PAnsiChar; -var DynArray: TDynArray; -begin - DynArray.Init(TypeInfo,Value); - result := DynArray.LoadFrom(Source); -end; - -function DynArraySave(var Value; TypeInfo: pointer): RawByteString; -var DynArray: TDynArray; -begin - DynArray.Init(TypeInfo,Value); - result := DynArray.SaveTo; -end; - -function DynArrayLoadJSON(var Value; JSON: PUTF8Char; TypeInfo: pointer; - EndOfObject: PUTF8Char): PUTF8Char; -var DynArray: TDynArray; -begin - DynArray.Init(TypeInfo,Value); - result := DynArray.LoadFromJSON(JSON,EndOfObject); -end; - -function DynArrayLoadJSON(var Value; const JSON: RawUTF8; TypeInfo: pointer): boolean; -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); // make private copy before in-place decoding - try - result := DynArrayLoadJSON(Value,tmp.buf,TypeInfo)<>nil; - finally - tmp.Done; - end; -end; - -function DynArraySaveJSON(const Value; TypeInfo: pointer; - EnumSetsAsText: boolean): RawUTF8; -begin - result := SaveJSON(Value,TypeInfo,EnumSetsAsText); -end; - -{$ifndef DELPHI5OROLDER} -function DynArrayEquals(TypeInfo: pointer; var Array1, Array2; - Array1Count, Array2Count: PInteger): boolean; -var DA1, DA2: TDynArray; -begin - DA1.Init(TypeInfo,Array1,Array1Count); - DA2.Init(TypeInfo,Array2,Array2Count); - result := DA1.Equals(DA2); -end; -{$endif DELPHI5OROLDER} - -function DynArrayBlobSaveJSON(TypeInfo, BlobValue: pointer): RawUTF8; -var DynArray: TDynArray; - Value: pointer; // store the temporary dynamic array - temp: TTextWriterStackBuffer; -begin - Value := nil; - DynArray.Init(TypeInfo,Value); - try - if DynArray.LoadFrom(BlobValue)=nil then - result := '' else begin - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - AddDynArrayJSON(TypeInfo,Value); - SetText(result); - finally - Free; - end; - end; - finally - DynArray.SetCount(0); - end; -end; - -function DynArrayElementTypeName(TypeInfo: pointer; ElemTypeInfo: PPointer; - ExactType: boolean): RawUTF8; -var DynArray: TDynArray; - VoidArray: pointer; -const KNOWNTYPE_ITEMNAME: array[TDynArrayKind] of RawUTF8 = ('', - 'boolean','byte','word','integer','cardinal','single','Int64','QWord', - 'double','currency','TTimeLog','TDateTime','TDateTimeMS', - 'RawUTF8','WinAnsiString','string','RawByteString','WideString','SynUnicode', - 'THash128','THash256','THash512','IInterface',{$ifndef NOVARIANTS}'variant',{$endif}''); -begin - VoidArray := nil; - DynArray.Init(TypeInfo,VoidArray); - result := ''; - if ElemTypeInfo<>nil then - ElemTypeInfo^ := DynArray.ElemType; - if DynArray.ElemType<>nil then - TypeInfoToName(ElemTypeInfo,result) else - result := KNOWNTYPE_ITEMNAME[DynArray.GuessKnownType(ExactType)]; -end; - -procedure RawRecordDynArrayClear(v: PAnsiChar; info: PTypeInfo; n: integer); -var fields,f: PFieldInfo; - nfields,i: integer; -begin - info := GetTypeInfo(info); - nfields := GetManagedFields(info,fields); // inlined RecordClear() - if nfields>0 then - repeat - f := fields; - i := nfields; - repeat - {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(v+f^.Offset, - {$ifdef HASDIRECTTYPEINFO}f^.TypeInfo{$else}PPointer(f^.TypeInfo)^{$endif}); - inc(f); - dec(i); - until i=0; - inc(v,info^.recSize); - dec(n); - until n=0; -end; - -procedure RawAnsiStringDynArrayClear(v: PPointer; n: PtrInt); -var p: PStrRec; -begin - repeat - p := v^; - if p<>nil then begin - v^ := nil; - dec(p); - if (p^.refCnt>=0) and StrCntDecFree(p^.refCnt) then - freemem(p); - end; - inc(v); - dec(n); - until n=0; -end; - -procedure FastFinalizeArray(v: PPointer; ElemTypeInfo: pointer; n: integer); -begin // caller ensured ElemTypeInfo<>nil and n>0 - case PTypeKind(ElemTypeInfo)^ of - tkRecord{$ifdef FPC},tkObject{$endif}: - RawRecordDynArrayClear(pointer(v),ElemTypeinfo,n); - {$ifndef NOVARIANTS} - tkVariant: - RawVariantDynArrayClear(pointer(v),n); - {$endif} - tkLString{$ifdef FPC},tkLStringOld{$endif}: - RawAnsiStringDynArrayClear(pointer(v),n); - tkWString: - repeat - if v^<>nil then - {$ifdef FPC}Finalize(WideString(v^)){$else}WideString(v^) := ''{$endif}; - inc(v); - dec(n); - until n=0; - {$ifdef HASVARUSTRING} - tkUString: - repeat - if v^<>nil then - {$ifdef FPC}Finalize(UnicodeString(v^)){$else}UnicodeString(v^) := ''{$endif}; - inc(v); - dec(n); - until n=0; - {$endif} - {$ifndef DELPHI5OROLDER} - tkInterface: - repeat - if v^<>nil then - {$ifdef FPC}Finalize(IInterface(v^)){$else}IInterface(v^) := nil{$endif}; - inc(v); - dec(n); - until n=0; - {$endif} - tkDynArray: begin - ElemTypeInfo := Deref(GetTypeInfo(ElemTypeInfo)^.elType); - repeat - if v^<>nil then - FastDynArrayClear(v,ElemTypeInfo); - inc(v); - dec(n); - until n=0; - end; - else // fallback to regular finalization code for less common types - {$ifdef FPC}FPCFinalizeArray{$else}_FinalizeArray{$endif}(v,ElemTypeInfo,n); - end; -end; - -procedure FastDynArrayClear(Value: PPointer; ElemTypeInfo: pointer); -var p: PDynArrayRec; -begin - if Value<>nil then begin - p := Value^; - if p<>nil then begin - dec(p); - if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin - if ElemTypeInfo<>nil then - FastFinalizeArray(Value^,ElemTypeInfo,p^.length); - Freemem(p); - end; - Value^ := nil; - end; - end; -end; - -{$ifdef FPC_X64} -procedure _dynarray_decr_ref_free(p: PDynArrayRec; info: pointer); -begin - info := Deref(GetTypeInfo(info)^.elType); - if info <> nil then - FastFinalizeArray(pointer(PAnsiChar(p) + SizeOf(p^)), info, p^.length); - Freemem(p); -end; -{$endif FPC_X64} - -function SortDynArrayBoolean(const A,B): integer; -begin - if boolean(A) then // normalize (seldom used, anyway) - if boolean(B) then - result := 0 else - result := 1 else - if boolean(B) then - result := -1 else - result := 0; -end; - -function SortDynArrayByte(const A,B): integer; -begin - result := byte(A)-byte(B); -end; - -function SortDynArraySmallint(const A,B): integer; -begin - result := smallint(A)-smallint(B); -end; - -function SortDynArrayShortint(const A,B): integer; -begin - result := shortint(A)-shortint(B); -end; - -function SortDynArrayWord(const A,B): integer; -begin - result := word(A)-word(B); -end; - -function SortDynArrayPUTF8CharI(const A,B): integer; -begin - result := StrIComp(PUTF8Char(A),PUTF8Char(B)); -end; - -function SortDynArrayString(const A,B): integer; -begin - {$ifdef UNICODE} - result := StrCompW(PWideChar(A),PWideChar(B)); - {$else} - result := StrComp(PUTF8Char(A),PUTF8Char(B)); - {$endif} -end; - -function SortDynArrayStringI(const A,B): integer; -begin - {$ifdef UNICODE} - result := AnsiICompW(PWideChar(A),PWideChar(B)); - {$else} - result := StrIComp(PUTF8Char(A),PUTF8Char(B)); - {$endif} -end; - -function SortDynArrayFileName(const A,B): integer; -var Aname, Aext, Bname, Bext: TFileName; -begin // code below is not very fast, but is correct ;) - AName := GetFileNameWithoutExt(string(A),@Aext); - BName := GetFileNameWithoutExt(string(B),@Bext); - result := AnsiCompareFileName(Aext,Bext); - if result=0 then // if both extensions matches, compare by filename - result := AnsiCompareFileName(Aname,Bname); -end; - -function SortDynArrayUnicodeString(const A,B): integer; -begin // works for tkWString and tkUString - result := StrCompW(PWideChar(A),PWideChar(B)); -end; - -function SortDynArrayUnicodeStringI(const A,B): integer; -begin - result := AnsiICompW(PWideChar(A),PWideChar(B)); -end; - -function SortDynArray128(const A,B): integer; -begin - if THash128Rec(A).LoTHash128Rec(B).Lo then - result := 1 else - if THash128Rec(A).HiTHash128Rec(B).Hi then - result := 1 else - result := 0; -end; - -function SortDynArray256(const A,B): integer; -begin - result := SortDynArray128(THash256Rec(A).Lo,THash256Rec(B).Lo); - if result = 0 then - result := SortDynArray128(THash256Rec(A).Hi,THash256Rec(B).Hi); -end; - -function SortDynArray512(const A,B): integer; -begin - result := SortDynArray128(THash512Rec(A).c0,THash512Rec(B).c0); - if result = 0 then begin - result := SortDynArray128(THash512Rec(A).c1,THash512Rec(B).c1); - if result = 0 then begin - result := SortDynArray128(THash512Rec(A).c2,THash512Rec(B).c2); - if result = 0 then - result := SortDynArray128(THash512Rec(A).c3,THash512Rec(B).c3); - end; - end; -end; - -{$ifndef NOVARIANTS} - -function VariantCompare(const V1,V2: variant): PtrInt; -begin - result := SortDynArrayVariantComp(TVarData(V1), TVarData(V2), false); -end; - -function VariantCompareI(const V1,V2: variant): PtrInt; -begin - result := SortDynArrayVariantComp(TVarData(V1), TVarData(V2), true); -end; - -function SortDynArrayVariantCompareAsString(const A,B: variant): integer; -var UA,UB: RawUTF8; - wasString: boolean; -begin - VariantToUTF8(A,UA,wasString); - VariantToUTF8(B,UB,wasString); - result := StrComp(pointer(UA),pointer(UB)); -end; - -function SortDynArrayVariantCompareAsStringI(const A,B: variant): integer; -var UA,UB: RawUTF8; - wasString: boolean; -begin - VariantToUTF8(A,UA,wasString); - VariantToUTF8(B,UB,wasString); - result := StrIComp(pointer(UA),pointer(UB)); -end; - -function SortDynArrayZero(const A,B): integer; -begin - result := 0; -end; - -function SortDynArrayVariantComp(const A,B: TVarData; caseInsensitive: boolean): integer; -type - TSortDynArrayVariantComp = function(const A,B: variant): integer; -const - CMP: array[boolean] of TSortDynArrayVariantComp = ( - SortDynArrayVariantCompareAsString,SortDynArrayVariantCompareAsStringI); - ICMP: array[TVariantRelationship] of integer = (0,-1,1,1); - SORT1: array[varEmpty..varDate] of TDynArraySortCompare = ( - SortDynArrayZero, SortDynArrayZero, SortDynArraySmallInt, SortDynArrayInteger, - SortDynArraySingle, SortDynArrayDouble, SortDynArrayInt64, SortDynArrayDouble); - SORT2: array[varShortInt..varWord64] of TDynArraySortCompare = ( - SortDynArrayShortInt, SortDynArrayByte, SortDynArrayWord, SortDynArrayCardinal, - SortDynArrayInt64, SortDynArrayQWord); -var AT,BT: integer; -begin - AT := integer(A.VType); - BT := integer(B.VType); - if AT=varVariant or varByRef then - result := SortDynArrayVariantComp(PVarData(A.VPointer)^,B,caseInsensitive) else - if BT=varVariant or varByRef then - result := SortDynArrayVariantComp(A,PVarData(B.VPointer)^,caseInsensitive) else - if AT=BT then - case AT of // optimized comparison if A and B share the same type - low(SORT1)..high(SORT1): - result := SORT1[AT](A.VAny,B.VAny); - low(SORT2)..high(SORT2): - result := SORT2[AT](A.VAny,B.VAny); - varString: // RawUTF8 most of the time (e.g. from TDocVariant) - if caseInsensitive then - result := StrIComp(A.VAny,B.VAny) else - result := StrComp(A.VAny,B.VAny); - varBoolean: - if A.VBoolean then // normalize - if B.VBoolean then - result := 0 else - result := 1 else - if B.VBoolean then - result := -1 else - result := 0; - varOleStr{$ifdef HASVARUSTRING},varUString{$endif}: - if caseInsensitive then - result := AnsiICompW(A.VAny,B.VAny) else - result := StrCompW(A.VAny,B.VAny); - else - if ATvarNull)-ord(BT>varNull) else - if (AT0 then - result := PInteger(result)^ else begin - result := PtrUInt(fValue); - if result<>0 then begin - result := PPtrInt(result)^; - if result<>0 then - result := PDALen(result-_DALEN)^{$ifdef FPC}+1{$endif}; - end; - end; -end; - -procedure TDynArray.ElemCopy(const A; var B); -begin - if ElemType=nil then - MoveFast(A,B,ElemSize) else begin - {$ifdef FPC} - {$ifdef FPC_OLDRTTI} - FPCFinalize(@B,ElemType); // inlined CopyArray() - Move(A,B,ElemSize); - FPCRecordAddRef(B,ElemType); - {$else} - FPCRecordCopy(A,B,ElemType); // works for any kind of ElemTyp - {$endif FPC_OLDRTTI} - {$else} - CopyArray(@B,@A,ElemType,1); - {$endif FPC} - end; -end; - -function TDynArray.Add(const Elem): PtrInt; -var p: PtrUInt; -begin - result := GetCount; - if fValue=nil then - exit; // avoid GPF if void - SetCount(result+1); - p := PtrUInt(fValue^)+PtrUInt(result)*ElemSize; - if ElemType=nil then - MoveFast(Elem,pointer(p)^,ElemSize) else - {$ifdef FPC} - FPCRecordCopy(Elem,pointer(p)^,ElemType); - {$else} - CopyArray(pointer(p),@Elem,ElemType,1); - {$endif} -end; - -function TDynArray.New: integer; -begin - result := GetCount; - if fValue=nil then - exit; // avoid GPF if void - SetCount(result+1); -end; - -function TDynArray.Peek(var Dest): boolean; -var index: PtrInt; -begin - index := GetCount-1; - result := index>=0; - if result then - ElemCopy(pointer(PtrUInt(fValue^)+PtrUInt(index)*ElemSize)^,Dest); -end; - -function TDynArray.Pop(var Dest): boolean; -var index: integer; -begin - index := GetCount-1; - result := index>=0; - if result then begin - ElemMoveTo(index,Dest); - SetCount(index); - end; -end; - -procedure TDynArray.Insert(Index: PtrInt; const Elem); -var n: PtrInt; - P: PByteArray; -begin - if fValue=nil then - exit; // avoid GPF if void - n := GetCount; - SetCount(n+1); - if PtrUInt(Index)nil then // avoid GPF in ElemCopy() below - FillCharFast(P^,ElemSize,0); - end else - // Index>=Count -> add at the end - P := pointer(PtrUInt(fValue^)+PtrUInt(n)*ElemSize); - ElemCopy(Elem,P^); -end; - -procedure TDynArray.Clear; -begin - SetCount(0); -end; - -function TDynArray.ClearSafe: boolean; -begin - try - SetCount(0); - result := true; - except // weak code, but may be a good idea in a destructor - result := false; - end; -end; - -function TDynArray.GetIsObjArray: boolean; -begin - result := (fIsObjArray=oaTrue) or ((fIsObjArray=oaUnknown) and ComputeIsObjArray); -end; - -function TDynArray.Delete(aIndex: PtrInt): boolean; -var n, len: PtrInt; - P: PAnsiChar; -begin - result := false; - if fValue=nil then - exit; // avoid GPF if void - n := GetCount; - if PtrUInt(aIndex)>=PtrUInt(n) then - exit; // out of range - if PDACnt(PtrUInt(fValue^)-_DAREFCNT)^>1 then - InternalSetLength(n,n); // unique - dec(n); - P := pointer(PtrUInt(fValue^)+PtrUInt(aIndex)*ElemSize); - if ElemType<>nil then - {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(P,ElemType) else - if (fIsObjArray=oaTrue) or ((fIsObjArray=oaUnknown) and ComputeIsObjArray) then - FreeAndNil(PObject(P)^); - if n>aIndex then begin - len := PtrUInt(n-aIndex)*ElemSize; - MoveFast(P[ElemSize],P[0],len); - FillCharFast(P[len],ElemSize,0); - end else - FillCharFast(P^,ElemSize,0); - SetCount(n); - result := true; -end; - -function TDynArray.ElemPtr(index: PtrInt): pointer; -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 - MoveFast(p^,Dest,ElemSize) else - {$ifdef FPC} - FPCRecordCopy(p^,Dest,ElemType); // works for any kind of ElemTyp - {$else} - CopyArray(@Dest,p,ElemType,1); - {$endif} -end; - -procedure TDynArray.ElemMoveTo(index: PtrInt; var Dest); -var p: pointer; -begin - p := ElemPtr(index); - if (p=nil) or (@Dest=nil) then - exit; - ElemClear(Dest); - MoveFast(p^,Dest,ElemSize); - FillCharFast(p^,ElemSize,0); // ElemType=nil for ObjArray -end; - -procedure TDynArray.ElemCopyFrom(const Source; index: PtrInt; ClearBeforeCopy: boolean); -var p: pointer; -begin - p := ElemPtr(index); - if p<>nil then - if ElemType=nil then - MoveFast(Source,p^,ElemSize) else begin - if ClearBeforeCopy then // safer if Source is a copy of p^ - {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(p,ElemType); - {$ifdef FPC} - FPCRecordCopy(Source,p^,ElemType); - {$else} - CopyArray(p,@Source,ElemType,1); - {$endif} - end; -end; - -procedure TDynArray.Reverse; -var n, siz: PtrInt; - P1, P2: PAnsiChar; - c: AnsiChar; - i32: integer; - i64: Int64; -begin - n := GetCount-1; - if n>0 then begin - siz := ElemSize; - P1 := fValue^; - case siz of - 1: begin // optimized version for TByteDynArray and such - P2 := P1+n; - while P1MemStream.Size then - MemStream.Size := PosiEnd; - if SaveTo(PAnsiChar(MemStream.Memory)+Posi)-MemStream.Memory<>PosiEnd then - raise EStreamError.Create('TDynArray.SaveToStream: SaveTo'); - MemStream.Seek(PosiEnd,soBeginning); - end else begin - tmp := SaveTo; - if Stream.Write(pointer(tmp)^,length(tmp))<>length(tmp) then - raise EStreamError.Create('TDynArray.SaveToStream: Write error'); - end; -end; - -procedure TDynArray.LoadFromStream(Stream: TCustomMemoryStream); -var P: PAnsiChar; -begin - P := PAnsiChar(Stream.Memory)+Stream.Seek(0,soCurrent); - Stream.Seek(LoadFrom(P,nil,false,PAnsiChar(Stream.Memory)+Stream.Size)-P,soCurrent); -end; - -function TDynArray.SaveToTypeInfoHash(crc: cardinal): cardinal; -begin - if ElemType=nil then // hash fElemSize only if no pointer within - result := crc32c(crc,@fElemSize,4) else begin - result := crc; - ManagedTypeSaveRTTIHash(ElemType,result); - end; -end; - -function TDynArray.SaveTo(Dest: PAnsiChar): PAnsiChar; -var i, n, LenBytes: integer; - P: PAnsiChar; -begin - if fValue=nil then begin - result := Dest; - exit; // avoid GPF if void - end; - // store the element size+type to check for the format (name='' mostly) - Dest := PAnsiChar(ToVarUInt32(ElemSize,pointer(Dest))); - if ElemType=nil then - Dest^ := #0 else - {$ifdef FPC} - Dest^ := AnsiChar(FPCTODELPHI[PTypeKind(ElemType)^]); - {$else} - Dest^ := PAnsiChar(ElemType)^; - {$endif} - inc(Dest); - // store dynamic array count - n := GetCount; - Dest := PAnsiChar(ToVarUInt32(n,pointer(Dest))); - if n=0 then begin - result := Dest; - exit; - end; - inc(Dest,SizeOf(Cardinal)); // leave space for Hash32 checksum - result := Dest; - // store dynamic array elements content - P := fValue^; - if ElemType=nil then // FPC: nil also if not Kind in tkManagedTypes - if GetIsObjArray then - raise ESynException.CreateUTF8('TDynArray.SaveTo(%) is a T*ObjArray', - [ArrayTypeShort^]) else begin - n := n*integer(ElemSize); // binary types: store as one - MoveFast(P^,Dest^,n); - inc(Dest,n); - end else - if PTypeKind(ElemType)^ in tkRecordTypes then - for i := 1 to n do begin - Dest := RecordSave(P^,Dest,ElemType,LenBytes); - inc(P,LenBytes); - end else - for i := 1 to n do begin - Dest := ManagedTypeSave(P,Dest,ElemType,LenBytes); - if Dest=nil then - break; - inc(P,LenBytes); - end; - // store Hash32 checksum - if Dest<>nil then // may be nil if RecordSave/ManagedTypeSave failed - PCardinal(result-SizeOf(Cardinal))^ := Hash32(pointer(result),Dest-result); - result := Dest; -end; - -function TDynArray.SaveToLength: integer; -var i,n,L,size: integer; - P: PAnsiChar; -begin - if fValue=nil then begin - result := 0; - exit; // avoid GPF if void - end; - n := GetCount; - result := ToVarUInt32Length(ElemSize)+ToVarUInt32Length(n)+1; - if n=0 then - exit; - if ElemType=nil then // FPC: nil also if not Kind in tkManagedTypes - if GetIsObjArray then - raise ESynException.CreateUTF8('TDynArray.SaveToLength(%) is a T*ObjArray', - [ArrayTypeShort^]) else - inc(result,integer(ElemSize)*n) else begin - P := fValue^; - case PTypeKind(ElemType)^ of // inlined the most used kind of items - tkLString{$ifdef FPC},tkLStringOld{$endif}: - for i := 1 to n do begin - if PPtrUInt(P)^=0 then - inc(result) else - inc(result,ToVarUInt32LengthWithData(PStrLen(PPtrUInt(P)^-_STRLEN)^)); - inc(P,SizeOf(pointer)); - end; - tkRecord{$ifdef FPC},tkObject{$endif}: - for i := 1 to n do begin - inc(result,RecordSaveLength(P^,ElemType)); - inc(P,ElemSize); - end; - else - for i := 1 to n do begin - L := ManagedTypeSaveLength(P,ElemType,size); - if L=0 then - break; // invalid record type (wrong field type) - inc(result,L); - inc(P,size); - end; - end; - end; - inc(result,SizeOf(Cardinal)); // Hash32 checksum -end; - -function TDynArray.SaveTo: RawByteString; -var Len: integer; -begin - Len := SaveToLength; - SetString(result,nil,Len); - if Len<>0 then - if SaveTo(pointer(result))-pointer(result)<>Len then - raise ESynException.Create('TDynArray.SaveTo len concern'); -end; - -function TDynArray.SaveToJSON(EnumSetsAsText: boolean; reformat: TTextWriterJSONFormat): RawUTF8; -begin - SaveToJSON(result,EnumSetsAsText,reformat); -end; - -procedure TDynArray.SaveToJSON(out Result: RawUTF8; EnumSetsAsText: boolean; - reformat: TTextWriterJSONFormat); -var temp: TTextWriterStackBuffer; -begin - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - if EnumSetsAsText then - CustomOptions := CustomOptions+[twoEnumSetsAsTextInRecord]; - AddDynArrayJSON(self); - SetText(result,reformat); - finally - Free; - end; -end; - -const - PTRSIZ = SizeOf(Pointer); - KNOWNTYPE_SIZE: array[TDynArrayKind] of byte = ( - 0, 1,1, 2, 4,4,4, 8,8,8,8,8,8,8, PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ,PTRSIZ, - 16,32,64, PTRSIZ, - {$ifndef NOVARIANTS}SizeOf(Variant),{$endif} 0); - DYNARRAY_PARSERUNKNOWN = -2; - -var // for TDynArray.LoadKnownType - KINDTYPE_INFO: array[TDynArrayKind] of pointer; - -function TDynArray.GetArrayTypeName: RawUTF8; -begin - TypeInfoToName(fTypeInfo,result); -end; - -function TDynArray.GetArrayTypeShort: PShortString; -begin // not inlined since PTypeInfo is private to implementation section - if fTypeInfo=nil then - result := @NULCHAR else - result := PShortString(@PTypeInfo(fTypeInfo).NameLen); -end; - -function TDynArray.GuessKnownType(exactType: boolean): TDynArrayKind; -const - RTTI: array[TJSONCustomParserRTTIType] of TDynArrayKind = ( - djNone, djBoolean, djByte, djCardinal, djCurrency, djDouble, djNone, djInt64, - djInteger, djQWord, djRawByteString, djNone, djRawUTF8, djNone, djSingle, - djString, djSynUnicode, djDateTime, djDateTimeMS, djHash128, djInt64, djTimeLog, - {$ifdef HASVARUSTRING} {$ifdef UNICODE}djSynUnicode{$else}djNone{$endif}, {$endif} - {$ifndef NOVARIANTS} djVariant, {$endif} djWideString, djWord, djNone); -var info: PTypeInfo; - field: PFieldInfo; -label bin, rec; -begin - result := fKnownType; - if result<>djNone then - exit; - info := fTypeInfo; - case ElemSize of // very fast guess of most known exact dynarray types - 1: if info=TypeInfo(TBooleanDynArray) then - result := djBoolean; - 4: if info=TypeInfo(TCardinalDynArray) then - result := djCardinal else - if info=TypeInfo(TSingleDynArray) then - result := djSingle - {$ifdef CPU64} ; 8: {$else} else {$endif} - if info=TypeInfo(TRawUTF8DynArray) then - result := djRawUTF8 else - if info=TypeInfo(TStringDynArray) then - result := djString else - if info=TypeInfo(TWinAnsiDynArray) then - result := djWinAnsi else - if info=TypeInfo(TRawByteStringDynArray) then - result := djRawByteString else - if info=TypeInfo(TSynUnicodeDynArray) then - result := djSynUnicode else - if (info=TypeInfo(TClassDynArray)) or - (info=TypeInfo(TPointerDynArray)) then - result := djPointer else - {$ifndef DELPHI5OROLDER} - if info=TypeInfo(TInterfaceDynArray) then - result := djInterface - {$endif DELPHI5OROLDER} - {$ifdef CPU64} else {$else} ; 8: {$endif} - if info=TypeInfo(TDoubleDynArray) then - result := djDouble else - if info=TypeInfo(TCurrencyDynArray) then - result := djCurrency else - if info=TypeInfo(TTimeLogDynArray) then - result := djTimeLog else - if info=TypeInfo(TDateTimeDynArray) then - result := djDateTime else - if info=TypeInfo(TDateTimeMSDynArray) then - result := djDateTimeMS; - end; - if result=djNone then begin // guess from RTTU - fKnownSize := 0; - if fElemType=nil then begin - {$ifdef DYNARRAYELEMTYPE2} // not backward compatible - disabled - if fElemType2<>nil then // try if a simple type known by extended RTTI - result := RTTI[TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(fElemType2)]; - if result=djNone then - {$endif} -bin: case fElemSize of - 1: result := djByte; - 2: result := djWord; - 4: result := djInteger; - 8: result := djInt64; - 16: result := djHash128; - 32: result := djHash256; - 64: result := djHash512; - else fKnownSize := fElemSize; - end; - end else // try to guess from 1st record/object field - if not exacttype and (PTypeKind(fElemType)^ in tkRecordTypes) then begin - info := fElemType; // inlined GetTypeInfo() -rec: {$ifdef HASALIGNTYPEDATA} - info := FPCTypeInfoOverName(info); - {$else} - inc(PByte(info),info^.NameLen); - {$endif} - {$ifdef FPC_OLDRTTI} - field := OldRTTIFirstManagedField(info); - if field=nil then - {$else} - if GetManagedFields(info,field)=0 then // only binary content - {$endif} - goto Bin; - case field^.Offset of - 0: begin - info := DeRef(field^.TypeInfo); - if info=nil then // paranoid check - goto bin else - if info^.kind in tkRecordTypes then - goto rec; // nested records - result := RTTI[TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(info)]; - if result=djNone then - goto Bin; - end; - 1: result := djByte; - 2: result := djWord; - 4: result := djInteger; - 8: result := djInt64; - 16: result := djHash128; - 32: result := djHash256; - 64: result := djHash512; - else fKnownSize := field^.Offset; - end; - end else - // will recognize simple arrays from PTypeKind(fElemType)^ - result := RTTI[TJSONCustomParserRTTI.TypeInfoToSimpleRTTIType(fElemType)]; - end; - if KNOWNTYPE_SIZE[result]<>0 then - fKnownSize := KNOWNTYPE_SIZE[result]; - fKnownType := result; -end; - -function TDynArray.ElemCopyFirstField(Source,Dest: Pointer): boolean; -begin - if fKnownType=djNone then - GuessKnownType(false); - case fKnownType of - djBoolean..djDateTimeMS,djHash128..djHash512: // no managed field - MoveFast(Source^,Dest^,fKnownSize); - djRawUTF8, djWinAnsi, djRawByteString: - PRawByteString(Dest)^ := PRawByteString(Source)^; - djSynUnicode: - PSynUnicode(Dest)^ := PSynUnicode(Source)^; - djString: - PString(Dest)^ := PString(Source)^; - djWideString: - PWideString(Dest)^ := PWideString(Source)^; - {$ifndef NOVARIANTS}djVariant: PVariant(Dest)^ := PVariant(Source)^;{$endif} - else begin // djNone, djInterface, djCustom - result := false; - exit; - end; - end; - result := true; -end; - -function TDynArray.LoadKnownType(Data,Source,SourceMax: PAnsiChar): boolean; -var info: PTypeInfo; -begin - if fKnownType=djNone then - GuessKnownType({exacttype=}false); // set fKnownType and fKnownSize - if fKnownType in [djBoolean..djDateTimeMS,djHash128..djHash512] then - if (SourceMax<>nil) and (Source+fKnownSize>SourceMax) then - result := false else begin - MoveFast(Source^,Data^,fKnownSize); - result := true; - end else begin - info := KINDTYPE_INFO[fKnownType]; - if info=nil then - result := false else - result := (ManagedTypeLoad(Data,Source,info,SourceMax)<>0) and (Source<>nil); - end; -end; - -const // kind of types which are serialized as JSON text - DJ_STRING = [djTimeLog..djHash512]; - -function TDynArray.LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; -var n, i, ValLen: integer; - T: TDynArrayKind; - wasString, expectedString, isValid: boolean; - EndOfObject: AnsiChar; - Val: PUTF8Char; - V: pointer; - CustomReader: TDynArrayJSONCustomReader; - NestedDynArray: TDynArray; -begin // code below must match TTextWriter.AddDynArrayJSON() - result := nil; - if (P=nil) or (fValue=nil) then - exit; - P := GotoNextNotSpace(P); - if P^<>'[' then begin - if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin - SetCount(0); - result := P+4; // handle 'null' as void array - end; - exit; - end; - repeat inc(P) until not(P^ in [#1..' ']); - n := JSONArrayCount(P); - if n<0 then - exit; // invalid array content - if n=0 then begin - if NextNotSpaceCharIs(P,']') then begin - SetCount(0); - result := P; - end; - exit; // handle '[]' array - end; - {$ifndef NOVARIANTS} - if CustomVariantOptions=nil then - CustomVariantOptions := @JSON_OPTIONS[true]; - {$endif} - if HasCustomJSONParser then - CustomReader := GlobalJSONCustomParsers.fParser[fParser].Reader else - CustomReader := nil; - if Assigned(CustomReader) then - T := djCustom else - T := GuessKnownType({exacttype=}true); - if (T=djNone) and (P^='[') and (PTypeKind(ElemType)^=tkDynArray) then begin - Count := n; // fast allocation of the whole dynamic array memory at once - for i := 0 to n-1 do begin - NestedDynArray.Init(ElemType,PPointerArray(fValue^)^[i]); - P := NestedDynArray.LoadFromJSON(P,@EndOfObject{$ifndef NOVARIANTS}, - CustomVariantOptions{$endif}); - if P=nil then - exit; - EndOfObject := P^; // ',' or ']' for the last item of the array - inc(P); - end; - end else - if (T=djNone) or - (PCardinal(P)^=JSON_BASE64_MAGIC_QUOTE) then begin - if n<>1 then - exit; // expect one Base64 encoded string value preceded by \uFFF0 - Val := GetJSONField(P,P,@wasString,@EndOfObject,@ValLen); - if (Val=nil) or (ValLen<3) or not wasString or - (PInteger(Val)^ and $00ffffff<>JSON_BASE64_MAGIC) or - not LoadFromBinary(Base64ToBin(PAnsiChar(Val)+3,ValLen-3)) then - exit; // invalid content - end else begin - if GetIsObjArray then - for i := 0 to Count-1 do // force release any previous instance - FreeAndNil(PObjectArray(fValue^)^[i]); - SetCount(n); // fast allocation of the whole dynamic array memory at once - case T of - {$ifndef NOVARIANTS} - djVariant: - for i := 0 to n-1 do - P := VariantLoadJSON(PVariantArray(fValue^)^[i],P,@EndOfObject,CustomVariantOptions); - {$endif} - djCustom: begin - Val := fValue^; - for i := 1 to n do begin - P := CustomReader(P,Val^,isValid{$ifndef NOVARIANTS},CustomVariantOptions{$endif}); - if not isValid then - exit; - EndOfObject := P^; // ',' or ']' for the last item of the array - inc(P); - inc(Val,ElemSize); - end; - end; - else begin - V := fValue^; - expectedString := T in DJ_STRING; - for i := 0 to n-1 do begin - Val := GetJSONField(P,P,@wasString,@EndOfObject,@ValLen); - if (Val=nil) or (wasString<>expectedString) then - exit; - case T of - djBoolean: PBooleanArray(V)^[i] := GetBoolean(Val); - djByte: PByteArray(V)^[i] := GetCardinal(Val); - djWord: PWordArray(V)^[i] := GetCardinal(Val); - djInteger: PIntegerArray(V)^[i] := GetInteger(Val); - djCardinal: PCardinalArray(V)^[i] := GetCardinal(Val); - djSingle: PSingleArray(V)^[i] := GetExtended(Val); - djInt64: SetInt64(Val,PInt64Array(V)^[i]); - djQWord: SetQWord(Val,PQWordArray(V)^[i]); - djTimeLog: PInt64Array(V)^[i] := Iso8601ToTimeLogPUTF8Char(Val,ValLen); - djDateTime, djDateTimeMS: - Iso8601ToDateTimePUTF8CharVar(Val,ValLen,PDateTimeArray(V)^[i]); - djDouble: PDoubleArray(V)^[i] := GetExtended(Val); - djCurrency: PInt64Array(V)^[i] := StrToCurr64(Val); - djRawUTF8: FastSetString(PRawUTF8Array(V)^[i],Val,ValLen); - djRawByteString: - if not Base64MagicCheckAndDecode(Val,ValLen,PRawByteStringArray(V)^[i]) then - FastSetString(PRawUTF8Array(V)^[i],Val,ValLen); - djWinAnsi: WinAnsiConvert.UTF8BufferToAnsi(Val,ValLen,PRawByteStringArray(V)^[i]); - djString: UTF8DecodeToString(Val,ValLen,string(PPointerArray(V)^[i])); - djWideString: UTF8ToWideString(Val,ValLen,WideString(PPointerArray(V)^[i])); - djSynUnicode: UTF8ToSynUnicode(Val,ValLen,SynUnicode(PPointerArray(V)^[i])); - djHash128: if ValLen<>SizeOf(THash128)*2 then FillZero(PHash128Array(V)^[i]) else - HexDisplayToBin(pointer(Val),@PHash128Array(V)^[i],SizeOf(THash128)); - djHash256: if ValLen<>SizeOf(THash256)*2 then FillZero(PHash256Array(V)^[i]) else - HexDisplayToBin(pointer(Val),@PHash256Array(V)^[i],SizeOf(THash256)); - djHash512: if ValLen<>SizeOf(THash512)*2 then FillZero(PHash512Array(V)^[i]) else - HexDisplayToBin(pointer(Val),@PHash512Array(V)^[i],SizeOf(THash512)); - else raise ESynException.CreateUTF8('% not readable',[ToText(T)^]); - end; - end; - end; - end; - end; - if aEndOfObject<>nil then - aEndOfObject^ := EndOfObject; - if EndOfObject=']' then - if P=nil then - result := @NULCHAR else - result := P; -end; - -{$ifndef NOVARIANTS} -function TDynArray.LoadFromVariant(const DocVariant: variant): boolean; -begin - with _Safe(DocVariant)^ do - if dvoIsArray in Options then - result := LoadFromJSON(pointer(_Safe(DocVariant)^.ToJSON))<>nil else - result := false; -end; -{$endif NOVARIANTS} - -function TDynArray.LoadFromBinary(const Buffer: RawByteString; - NoCheckHash: boolean): boolean; -var P: PAnsiChar; - len: PtrInt; -begin - len := length(Buffer); - P := LoadFrom(pointer(Buffer),nil,NoCheckHash,PAnsiChar(pointer(Buffer))+len); - result := (P<>nil) and (P-pointer(Buffer)=len); -end; - -function TDynArray.LoadFromHeader(var Source: PByte; SourceMax: PByte): integer; -var n: cardinal; -begin - // check context - result := -1; // to notify error - if (Source=nil) or (fValue=nil) then - exit; - // ignore legacy element size for cross-platform compatibility - if not FromVarUInt32(Source,SourceMax,n) or - ((SourceMax<>nil) and (PAnsiChar(Source)>=PAnsiChar(SourceMax))) then - exit; - // check stored element type - if ElemType=nil then begin - if Source^<>0 then - exit; - end else - if Source^<>{$ifdef FPC}ord(FPCTODELPHI[PTypeKind(ElemType)^]){$else} - PByte(ElemType)^{$endif} then - exit; - inc(Source); - // retrieve dynamic array count - if FromVarUInt32(Source,SourceMax,n) then - if (n=0) or (SourceMax=nil) or - (PAnsiChar(Source)+SizeOf(cardinal)nil) and (Source+n>SourceMax) then exit; - MoveFast(Source^,P^,n); - inc(Source,n); - end else - if PTypeKind(ElemType)^ in tkRecordTypes then - for i := 1 to n do begin - Source := RecordLoad(P^,Source,ElemType,nil,SourceMax); - if Source=nil then exit; - if Assigned(AfterEach) then - AfterEach(P^); - inc(P,ElemSize); - end else - for i := 1 to n do begin - ManagedTypeLoad(P,Source,ElemType,SourceMax); - if Source=nil then exit; - if Assigned(AfterEach) then - AfterEach(P^); - inc(P,ElemSize); - end; - // check security checksum (Hash[0]=0 from mORMot2 DynArraySave) - if NoCheckHash or (Source=nil) or (Hash[0]=0) or - (Hash32(@Hash[1],Source-PAnsiChar(@Hash[1]))=Hash[0]) then - result := Source; -end; - -function TDynArray.Find(const Elem; const aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare): PtrInt; -var n, L: PtrInt; - cmp: integer; - P: PAnsiChar; -begin - n := GetCount; - if (@aCompare<>nil) and (n>0) then begin - dec(n); - P := fValue^; - if (n>10) and (length(aIndex)>=n) then begin - // array should be sorted via aIndex[] -> use fast O(log(n)) binary search - L := 0; - repeat - result := (L+n) shr 1; - cmp := aCompare(P[cardinal(aIndex[result])*ElemSize],Elem); - if cmp=0 then begin - result := aIndex[result]; // returns index in TDynArray - exit; - end; - if cmp<0 then - L := result+1 else - n := result-1; - until L>n; - end else - // array is not sorted, or aIndex=nil -> use O(n) iterating search - for result := 0 to n do - if aCompare(P^,Elem)=0 then - exit else - inc(P,ElemSize); - end; - result := -1; -end; - -function TDynArray.FindIndex(const Elem; aIndex: PIntegerDynArray; - aCompare: TDynArraySortCompare): PtrInt; -begin - if aIndex<>nil then - result := Find(Elem,aIndex^,aCompare) else - if Assigned(aCompare) then - result := Find(Elem,nil,aCompare) else - result := Find(Elem); -end; - -function TDynArray.FindAndFill(var Elem; aIndex: PIntegerDynArray; - aCompare: TDynArraySortCompare): integer; -begin - result := FindIndex(Elem,aIndex,aCompare); - if result>=0 then // if found, fill Elem with the matching item - ElemCopy(PAnsiChar(fValue^)[cardinal(result)*ElemSize],Elem); -end; - -function TDynArray.FindAndDelete(const Elem; aIndex: PIntegerDynArray; - aCompare: TDynArraySortCompare): integer; -begin - result := FindIndex(Elem,aIndex,aCompare); - if result>=0 then - Delete(result); -end; - -function TDynArray.FindAndUpdate(const Elem; aIndex: PIntegerDynArray; - aCompare: TDynArraySortCompare): integer; -begin - result := FindIndex(Elem,aIndex,aCompare); - if result>=0 then // if found, fill Elem with the matching item - ElemCopy(Elem,PAnsiChar(fValue^)[cardinal(result)*ElemSize]); -end; - -function TDynArray.FindAndAddIfNotExisting(const Elem; aIndex: PIntegerDynArray; - aCompare: TDynArraySortCompare): integer; -begin - result := FindIndex(Elem,aIndex,aCompare); - if result<0 then - Add(Elem); // -1 will mark success -end; - -function TDynArray.Find(const Elem): PtrInt; -var n, L: PtrInt; - cmp: integer; - P: PAnsiChar; -begin - n := GetCount; - if (@fCompare<>nil) and (n>0) then begin - dec(n); - P := fValue^; - if fSorted and (n>10) then begin - // array is sorted -> use fast O(log(n)) binary search - L := 0; - repeat - result := (L+n) shr 1; - cmp := fCompare(P[cardinal(result)*ElemSize],Elem); - if cmp=0 then - exit; - if cmp<0 then - L := result+1 else - n := result-1; - until L>n; - end else // array is very small, or not sorted - for result := 0 to n do - if fCompare(P^,Elem)=0 then // O(n) search - exit else - inc(P,ElemSize); - end; - result := -1; -end; - -function TDynArray.FindAllSorted(const Elem; out FirstIndex,LastIndex: Integer): boolean; -var found,last: integer; - P: PAnsiChar; -begin - result := FastLocateSorted(Elem,found); - if not result then - exit; - FirstIndex := found; - P := fValue^; - while (FirstIndex>0) and (fCompare(P[cardinal(FirstIndex-1)*ElemSize],Elem)=0) do - dec(FirstIndex); - last := GetCount-1; - LastIndex := found; - while (LastIndexnil then - if n=0 then // a void array is always sorted - Index := 0 else - if fSorted then begin - P := fValue^; - dec(n); - cmp := fCompare(Elem,P[cardinal(n)*ElemSize]); - if cmp>=0 then begin // greater than last sorted item - Index := n; - if cmp=0 then - result := true else // returns true + index of existing Elem - inc(Index); // returns false + insert after last position - exit; - end; - Index := 0; - while Index<=n do begin // O(log(n)) binary search of the sorted position - i := (Index+n) shr 1; - cmp := fCompare(P[cardinal(i)*ElemSize],Elem); - if cmp=0 then begin - Index := i; // returns true + index of existing Elem - result := True; - exit; - end else - if cmp<0 then - Index := i+1 else - n := i-1; - end; - // Elem not found: returns false + the index where to insert - end else - Index := -1 else // not Sorted - Index := -1; // no fCompare() -end; - -procedure TDynArray.FastAddSorted(Index: Integer; const Elem); -begin - Insert(Index,Elem); - fSorted := true; // Insert -> SetCount -> fSorted := false -end; - -procedure TDynArray.FastDeleteSorted(Index: Integer); -begin - Delete(Index); - fSorted := true; // Delete -> SetCount -> fSorted := false -end; - -function TDynArray.FastLocateOrAddSorted(const Elem; wasAdded: PBoolean): integer; -var toInsert: boolean; -begin - toInsert := not FastLocateSorted(Elem,result) and (result>=0); - if toInsert then begin - Insert(result,Elem); - fSorted := true; // Insert -> SetCount -> fSorted := false - end; - if wasAdded<>nil then - wasAdded^ := toInsert; -end; - -type - // internal structure used to make QuickSort faster & with less stack usage - TDynArrayQuickSort = object - Compare: TDynArraySortCompare; - CompareEvent: TEventDynArraySortCompare; - Pivot: pointer; - Index: PCardinalArray; - ElemSize: cardinal; - P: PtrInt; - Value: PAnsiChar; - IP, JP: PAnsiChar; - procedure QuickSort(L, R: PtrInt); - procedure QuickSortIndexed(L, R: PtrInt); - procedure QuickSortEvent(L, R: PtrInt); - procedure QuickSortEventReverse(L, R: PtrInt); - end; - -procedure QuickSortIndexedPUTF8Char(Values: PPUtf8CharArray; Count: Integer; - var SortedIndexes: TCardinalDynArray; CaseSensitive: boolean); -var QS: TDynArrayQuickSort; -begin - if CaseSensitive then - QS.Compare := SortDynArrayPUTF8Char else - QS.Compare := SortDynArrayPUTF8CharI; - QS.Value := pointer(Values); - QS.ElemSize := SizeOf(PUTF8Char); - SetLength(SortedIndexes,Count); - FillIncreasing(pointer(SortedIndexes),0,Count); - QS.Index := pointer(SortedIndexes); - QS.QuickSortIndexed(0,Count-1); -end; - -procedure DynArraySortIndexed(Values: pointer; ElemSize, Count: Integer; - out Indexes: TSynTempBuffer; Compare: TDynArraySortCompare); -var QS: TDynArrayQuickSort; -begin - QS.Compare := Compare; - QS.Value := Values; - QS.ElemSize := ElemSize; - QS.Index := pointer(Indexes.InitIncreasing(Count)); - QS.QuickSortIndexed(0,Count-1); -end; - -procedure TDynArrayQuickSort.QuickSort(L, R: PtrInt); -var I, J: PtrInt; - {$ifndef PUREPASCAL}tmp: pointer;{$endif} -begin - if L0 do begin - dec(J); - dec(JP,ElemSize); - end; - if I <= J then begin - if I<>J then - {$ifndef PUREPASCAL} // inlined Exchg() is just fine - if ElemSize=SizeOf(pointer) then begin - // optimized version e.g. for TRawUTF8DynArray/TObjectDynArray - tmp := PPointer(IP)^; - PPointer(IP)^ := PPointer(JP)^; - PPointer(JP)^ := tmp; - end else - {$endif} - // generic exchange of row element data - Exchg(IP,JP,ElemSize); - if P = I then P := J else - if P = J then P := I; - Inc(I); Dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSort(L, J); - L := I; - end else begin - if I < R then - QuickSort(I, R); - R := J; - end; - until L >= R; -end; - -procedure TDynArrayQuickSort.QuickSortEvent(L, R: PtrInt); -var I, J: PtrInt; -begin - if L0 do begin - dec(J); - dec(JP,ElemSize); - end; - if I <= J then begin - if I<>J then - Exchg(IP,JP,ElemSize); - if P = I then P := J else - if P = J then P := I; - Inc(I); Dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortEvent(L, J); - L := I; - end else begin - if I < R then - QuickSortEvent(I, R); - R := J; - end; - until L >= R; -end; - -procedure TDynArrayQuickSort.QuickSortEventReverse(L, R: PtrInt); -var I, J: PtrInt; -begin - if L0 do begin - inc(I); - inc(IP,ElemSize); - end; - while CompareEvent(JP^,Pivot^)<0 do begin - dec(J); - dec(JP,ElemSize); - end; - if I <= J then begin - if I<>J then - Exchg(IP,JP,ElemSize); - if P = I then P := J else - if P = J then P := I; - Inc(I); Dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortEventReverse(L, J); - L := I; - end else begin - if I < R then - QuickSortEventReverse(I, R); - R := J; - end; - until L >= R; -end; - -procedure TDynArrayQuickSort.QuickSortIndexed(L, R: PtrInt); -var I, J: PtrInt; - tmp: integer; -begin - if L0 do dec(J); - if I <= J then begin - if I<>J then begin - tmp := Index[I]; - Index[I] := Index[J]; - Index[J] := tmp; - end; - if P = I then P := J else - if P = J then P := I; - Inc(I); Dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortIndexed(L, J); - L := I; - end else begin - if I < R then - QuickSortIndexed(I, R); - R := J; - end; - until L >= R; -end; - -procedure TDynArray.Sort(aCompare: TDynArraySortCompare); -begin - SortRange(0,Count-1,aCompare); - fSorted := true; -end; - -procedure QuickSortPtr(L, R: PtrInt; Compare: TDynArraySortCompare; V: PPointerArray); -var I, J, P: PtrInt; - tmp: pointer; -begin - if L0 do - dec(J); - if I <= J then begin - tmp := V[I]; - V[I] := V[J]; - V[J] := tmp; - if P = I then P := J else - if P = J then P := I; - Inc(I); Dec(J); - end; - until I > J; - if J - L < R - I then begin // use recursion only for smaller range - if L < J then - QuickSortPtr(L, J, Compare, V); - L := I; - end else begin - if I < R then - QuickSortPtr(I, R, Compare, V); - R := J; - end; - until L >= R; -end; - -procedure TDynArray.SortRange(aStart, aStop: integer; aCompare: TDynArraySortCompare); -var QuickSort: TDynArrayQuickSort; -begin - if aStop<=aStart then - exit; // nothing to sort - if @aCompare=nil then - Quicksort.Compare := @fCompare else - Quicksort.Compare := aCompare; - if (@Quicksort.Compare<>nil) and (fValue<>nil) and (fValue^<>nil) then - if ElemSize=SizeOf(pointer) then - QuickSortPtr(aStart,aStop,QuickSort.Compare,fValue^) else begin - Quicksort.Value := fValue^; - Quicksort.ElemSize := ElemSize; - Quicksort.QuickSort(aStart,aStop); - end; -end; - -procedure TDynArray.Sort(const aCompare: TEventDynArraySortCompare; aReverse: boolean); -var QuickSort: TDynArrayQuickSort; - R: PtrInt; -begin - if not Assigned(aCompare) or (fValue = nil) or (fValue^=nil) then - exit; // nothing to sort - Quicksort.CompareEvent := aCompare; - Quicksort.Value := fValue^; - Quicksort.ElemSize := ElemSize; - R := Count-1; - if aReverse then - Quicksort.QuickSortEventReverse(0,R) else - Quicksort.QuickSortEvent(0,R); -end; - -procedure TDynArray.CreateOrderedIndex(var aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare); -var QuickSort: TDynArrayQuickSort; - n: integer; -begin - if @aCompare=nil then - Quicksort.Compare := @fCompare else - Quicksort.Compare := aCompare; - if (@QuickSort.Compare<>nil) and (fValue<>nil) and (fValue^<>nil) then begin - n := GetCount; - if length(aIndex)nil) and (fValue<>nil) and (fValue^<>nil) then begin - n := GetCount; - Quicksort.Value := fValue^; - Quicksort.ElemSize := ElemSize; - Quicksort.Index := PCardinalArray(aIndex.InitIncreasing(n)); - Quicksort.QuickSortIndexed(0,n-1); - end else - aIndex.buf := nil; // avoid GPF in aIndex.Done -end; - -procedure TDynArray.CreateOrderedIndexAfterAdd(var aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare); -var ndx: integer; -begin - ndx := GetCount-1; - if ndx<0 then - exit; - if aIndex<>nil then begin // whole FillIncreasing(aIndex[]) for first time - if ndx>=length(aIndex) then - SetLength(aIndex,NextGrow(ndx)); // grow aIndex[] if needed - aIndex[ndx] := ndx; - end; - CreateOrderedIndex(aIndex,aCompare); -end; - -function TDynArray.ElemEquals(const A,B): boolean; -begin - if @fCompare<>nil then - result := fCompare(A,B)=0 else - if ElemType=nil then - case ElemSize of // optimized versions for arrays of common types - 1: result := byte(A)=byte(B); - 2: result := word(A)=word(B); - 4: result := cardinal(A)=cardinal(B); - 8: result := Int64(A)=Int64(B); - 16: result := IsEqual(THash128(A),THash128(B)); - else result := CompareMemFixed(@A,@B,ElemSize); // binary comparison - end else - if PTypeKind(ElemType)^ in tkRecordTypes then // most likely - result := RecordEquals(A,B,ElemType) else - result := ManagedTypeCompare(@A,@B,ElemType)>0; // other complex types -end; - -{$ifndef DELPHI5OROLDER} // disabled for Delphi 5 buggy compiler -procedure TDynArray.InitFrom(const aAnother: TDynArray; var aValue); -begin - self := aAnother; - fValue := @aValue; - fCountP := nil; -end; - -procedure TDynArray.AddDynArray(const aSource: TDynArray; aStartIndex: integer; - aCount: integer); -var SourceCount: integer; -begin - if (aSource.fValue<>nil) and (ArrayType=aSource.ArrayType) then begin - SourceCount := aSource.Count; - if (aCount<0) or (aCount>SourceCount) then - aCount := SourceCount; // force use of external Source.Count, if any - AddArray(aSource.fValue^,aStartIndex,aCount); - end; -end; - -function TDynArray.Equals(const B: TDynArray; ignorecompare: boolean): boolean; -var i, n: integer; - P1,P2: PAnsiChar; - A1: PPointerArray absolute P1; - A2: PPointerArray absolute P2; - function HandleObjArray: boolean; - var tmp1,tmp2: RawUTF8; - begin - SaveToJSON(tmp1); - B.SaveToJSON(tmp2); - result := tmp1=tmp2; - end; -begin - result := false; - if ArrayType<>B.ArrayType then - exit; // array types should match exactly - n := GetCount; - if n<>B.Count then - exit; - if GetIsObjArray then begin - result := HandleObjArray; - exit; - end; - P1 := fValue^; - P2 := B.fValue^; - if (@fCompare<>nil) and not ignorecompare then // use customized comparison - for i := 1 to n do - if fCompare(P1^,P2^)<>0 then - exit else begin - inc(P1,ElemSize); - inc(P2,ElemSize); - end else - if ElemType=nil then begin // binary type is compared as a whole - result := CompareMem(P1,P2,ElemSize*cardinal(n)); - exit; - end else - case PTypeKind(ElemType)^ of // some optimized versions for most used types - tkLString{$ifdef FPC},tkLStringOld{$endif}: - for i := 0 to n-1 do - if AnsiString(A1^[i])<>AnsiString(A2^[i]) then - exit; - tkWString: - for i := 0 to n-1 do - if WideString(A1^[i])<>WideString(A2^[i]) then - exit; - {$ifdef HASVARUSTRING} - tkUString: - for i := 0 to n-1 do - if UnicodeString(A1^[i])<>UnicodeString(A2^[i]) then - exit; - {$endif} - tkRecord{$ifdef FPC},tkObject{$endif}: - for i := 1 to n do - if not RecordEquals(P1^,P2^,ElemType) then - exit else begin - inc(P1,ElemSize); - inc(P2,ElemSize); - end; - else // generic TypeInfoCompare() use - for i := 1 to n do - if ManagedTypeCompare(P1,P2,ElemType)<=0 then - exit else begin // A^<>B^ or unexpected type - inc(P1,ElemSize); - inc(P2,ElemSize); - end; - end; - result := true; -end; - -procedure TDynArray.Copy(const Source: TDynArray; ObjArrayByRef: boolean); -var n: Cardinal; -begin - if (fValue=nil) or (ArrayType<>Source.ArrayType) then - exit; - if (fCountP<>nil) and (Source.fCountP<>nil) then - SetCapacity(Source.GetCapacity); - n := Source.Count; - SetCount(n); - if n<>0 then - if ElemType=nil then - if not ObjArrayByRef and GetIsObjArray then - LoadFromJSON(pointer(Source.SaveToJSON)) else - MoveFast(Source.fValue^^,fValue^^,n*ElemSize) else - CopyArray(fValue^,Source.fValue^,ElemType,n); -end; - -procedure TDynArray.CopyFrom(const Source; MaxElem: integer; ObjArrayByRef: boolean); -var SourceDynArray: TDynArray; -begin - SourceDynArray.Init(fTypeInfo,pointer(@Source)^); - SourceDynArray.fCountP := @MaxElem; // would set Count=0 at Init() - Copy(SourceDynArray,ObjArrayByRef); -end; - -procedure TDynArray.CopyTo(out Dest; ObjArrayByRef: boolean); -var DestDynArray: TDynArray; -begin - DestDynArray.Init(fTypeInfo,Dest); - DestDynArray.Copy(self,ObjArrayByRef); -end; -{$endif DELPHI5OROLDER} - -function TDynArray.IndexOf(const Elem): PtrInt; -var P: PPointerArray; - max: PtrInt; -begin - if fValue<>nil then begin - max := GetCount-1; - P := fValue^; - if @Elem<>nil then - if ElemType=nil then begin - result := AnyScanIndex(P,@Elem,max+1,ElemSize); - exit; - end else - case PTypeKind(ElemType)^ of - tkLString{$ifdef FPC},tkLStringOld{$endif}: - for result := 0 to max do - if AnsiString(P^[result])=AnsiString(Elem) then exit; - tkWString: - for result := 0 to max do - if WideString(P^[result])=WideString(Elem) then exit; - {$ifdef HASVARUSTRING} - tkUString: - for result := 0 to max do - if UnicodeString(P^[result])=UnicodeString(Elem) then exit; - {$endif} - {$ifndef NOVARIANTS} - tkVariant: - for result := 0 to max do - if SortDynArrayVariantComp(PVarDataStaticArray(P)^[result], - TVarData(Elem),false)=0 then exit; - {$endif} - tkRecord{$ifdef FPC},tkObject{$endif}: - // RecordEquals() works with packed records containing binary and string types - for result := 0 to max do - if RecordEquals(P^,Elem,ElemType) then - exit else - inc(PByte(P),ElemSize); - tkInterface: - for result := 0 to max do - if P^[result]=pointer(Elem) then exit; - else - for result := 0 to max do - if ManagedTypeCompare(pointer(P),@Elem,ElemType)>0 then - exit else - inc(PByte(P),ElemSize); - end; - end; - result := -1; -end; - -procedure TDynArray.Init(aTypeInfo: pointer; var aValue; aCountPointer: PInteger); -begin - fValue := @aValue; - fTypeInfo := aTypeInfo; - if PTypeKind(aTypeInfo)^<>tkDynArray then // inlined GetTypeInfo() - raise ESynException.CreateUTF8('TDynArray.Init: % is %, expected tkDynArray', - [ArrayTypeShort^,ToText(PTypeKind(aTypeInfo)^)^]); - {$ifdef HASALIGNTYPEDATA} - aTypeInfo := FPCTypeInfoOverName(aTypeInfo); - {$else} - inc(PByte(aTypeInfo),PTypeInfo(aTypeInfo)^.NameLen); - {$endif} - fElemSize := PTypeInfo(aTypeInfo)^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}; - fElemType := PTypeInfo(aTypeInfo)^.elType; - if fElemType<>nil then begin // inlined DeRef() - {$ifndef HASDIRECTTYPEINFO} - // FPC compatibility: if you have a GPF here at startup, your 3.1 trunk - // revision seems older than June 2016 - // -> enable HASDIRECTTYPEINFO conditional below $ifdef VER3_1 in Synopse.inc - // or in your project's options - fElemType := PPointer(fElemType)^; - {$endif HASDIRECTTYPEINFO} - {$ifdef FPC} - if not (PTypeKind(fElemType)^ in tkManagedTypes) then - fElemType := nil; // as with Delphi - {$endif FPC} - end; - {$ifdef DYNARRAYELEMTYPE2} // disabled not to break backward compatibility - fElemType2 := PTypeInfo(aTypeInfo)^.elType2; - {$endif} - fCountP := aCountPointer; - if fCountP<>nil then - fCountP^ := 0; - fCompare := nil; - fParser := DYNARRAY_PARSERUNKNOWN; - fKnownSize := 0; - fSorted := false; - fKnownType := djNone; - fIsObjArray := oaUnknown; -end; - -procedure TDynArray.InitSpecific(aTypeInfo: pointer; var aValue; aKind: TDynArrayKind; - aCountPointer: PInteger; aCaseInsensitive: boolean); -var Comp: TDynArraySortCompare; -begin - Init(aTypeInfo,aValue,aCountPointer); - Comp := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,aKind]; - if @Comp=nil then - raise ESynException.CreateUTF8('TDynArray.InitSpecific(%) wrong aKind=%', - [ArrayTypeShort^,ToText(aKind)^]); - fCompare := Comp; - fKnownType := aKind; - fKnownSize := KNOWNTYPE_SIZE[aKind]; -end; - -procedure TDynArray.UseExternalCount(var aCountPointer: Integer); -begin - fCountP := @aCountPointer; -end; - -function TDynArray.HasCustomJSONParser: boolean; -begin - if fParser=DYNARRAY_PARSERUNKNOWN then - fParser := GlobalJSONCustomParsers.DynArraySearch(ArrayType,ElemType); - result := cardinal(fParser)nil); - if result then - fIsObjArray := oaTrue else - fIsObjArray := oaFalse; -end; - -procedure TDynArray.SetIsObjArray(aValue: boolean); -begin - if aValue then - fIsObjArray := oaTrue else - fIsObjArray := oaFalse; -end; - -procedure TDynArray.InternalSetLength(OldLength,NewLength: PtrUInt); -var p: PDynArrayRec; - NeededSize, minLength: PtrUInt; - pp: pointer; -begin // this method is faster than default System.DynArraySetLength() function - p := fValue^; - // check that new array length is not just a finalize in disguise - if NewLength=0 then begin - if p<>nil then begin // FastDynArrayClear() with ObjArray support - dec(p); - if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin - if OldLength<>0 then - if ElemType<>nil then - FastFinalizeArray(fValue^,ElemType,OldLength) else - if GetIsObjArray then - RawObjectsClear(fValue^,OldLength); - FreeMem(p); - end; - fValue^ := nil; - end; - exit; - end; - // calculate the needed size of the resulting memory structure on heap - NeededSize := NewLength*ElemSize+SizeOf(TDynArrayRec); - {$ifndef CPU64} - if NeededSize>1024*1024*1024 then // max workable memory block is 1 GB - raise ERangeError.CreateFmt('TDynArray SetLength(%s,%d) size concern', - [ArrayTypeShort^,NewLength]); - {$endif} - // if not shared (refCnt=1), resize; if shared, create copy (not thread safe) - if p=nil then begin - p := AllocMem(NeededSize); // RTL/OS will return zeroed memory - OldLength := NewLength; // no FillcharFast() below - end else begin - dec(PtrUInt(p),SizeOf(TDynArrayRec)); // p^ = start of heap object - if (p^.refCnt>=0) and DACntDecFree(p^.refCnt) then begin - if NewLengthnil then // release managed types in trailing items - FastFinalizeArray(pointer(PAnsiChar(p)+NeededSize),ElemType,OldLength-NewLength) else - if GetIsObjArray then // FreeAndNil() of resized objects list - RawObjectsClear(pointer(PAnsiChar(p)+NeededSize),OldLength-NewLength); - ReallocMem(p,NeededSize); - end else begin // make copy - GetMem(p,NeededSize); - minLength := OldLength; - if minLength>NewLength then - minLength := NewLength; - pp := PAnsiChar(p)+SizeOf(TDynArrayRec); - if ElemType<>nil then begin - FillCharFast(pp^,minLength*elemSize,0); - CopyArray(pp,fValue^,ElemType,minLength); - end else - MoveFast(fValue^^,pp^,minLength*elemSize); - end; - end; - // set refCnt=1 and new length to the heap header - with p^ do begin - refCnt := 1; - {$ifdef FPC} - high := newLength-1; - {$else} - length := newLength; - {$endif} - end; - inc(PByte(p),SizeOf(p^)); // p^ = start of dynamic aray items - fValue^ := p; - // reset new allocated elements content to zero - if NewLength>OldLength then begin - OldLength := OldLength*elemSize; - FillCharFast(PAnsiChar(p)[OldLength],NewLength*ElemSize-OldLength,0); - end; -end; - -procedure TDynArray.SetCount(aCount: PtrInt); -const MINIMUM_SIZE = 64; -var oldlen, extcount, arrayptr, capa, delta: PtrInt; -begin - arrayptr := PtrInt(fValue); - extcount := PtrInt(fCountP); - fSorted := false; - if arrayptr=0 then - exit; // avoid GPF if void - arrayptr := PPtrInt(arrayptr)^; - if extcount<>0 then begin // fCountP^ as external capacity - oldlen := PInteger(extcount)^; - delta := aCount-oldlen; - if delta=0 then - exit; - PInteger(extcount)^ := aCount; // store new length - if arrayptr=0 then begin // void array - if (delta>0) and (aCount0 then begin // size-up - if capa>=aCount then - exit; // no need to grow - capa := NextGrow(capa); - if capa>aCount then - aCount := capa; // grow by chunks - end else // size-down - if (aCount>0) and ((capa<=MINIMUM_SIZE) or (capa-aCount realloc - InternalSetLength(oldlen,aCount); -end; - -function TDynArray.GetCapacity: PtrInt; -begin // capacity = length(DynArray) - result := PtrInt(fValue); - if result<>0 then begin - result := PPtrInt(result)^; - if result<>0 then - result := PDALen(result-_DALEN)^{$ifdef FPC}+1{$endif}; - end; -end; - -procedure TDynArray.SetCapacity(aCapacity: PtrInt); -var oldlen,capa: PtrInt; -begin - if fValue=nil then - exit; - capa := GetCapacity; - if fCountP<>nil then begin - oldlen := fCountP^; - if oldlen>aCapacity then - fCountP^ := aCapacity; - end else - oldlen := capa; - if capa<>aCapacity then - InternalSetLength(oldlen,aCapacity); -end; - -procedure TDynArray.SetCompare(const aCompare: TDynArraySortCompare); -begin - if @aCompare<>@fCompare then begin - @fCompare := @aCompare; - fSorted := false; - end; -end; - -procedure TDynArray.Slice(var Dest; aCount, aFirstIndex: cardinal); -var n: Cardinal; - D: PPointer; - P: PAnsiChar; -begin - if fValue=nil then - exit; // avoid GPF if void - n := GetCount; - if aFirstIndex>=n then - aCount := 0 else - if aCount>=n-aFirstIndex then - aCount := n-aFirstIndex; - DynArray(ArrayType,Dest).SetCapacity(aCount); - if aCount>0 then begin - D := @Dest; - P := PAnsiChar(fValue^)+aFirstIndex*ElemSize; - if ElemType=nil then - MoveFast(P^,D^^,aCount*ElemSize) else - CopyArray(D^,P,ElemType,aCount); - end; -end; - -function TDynArray.AddArray(const DynArrayVar; aStartIndex, aCount: integer): integer; -var c, n: integer; - PS,PD: pointer; -begin - result := 0; - if fValue=nil then - exit; // avoid GPF if void - c := DynArrayLength(pointer(DynArrayVar)); - if aStartIndex>=c then - exit; // nothing to copy - if (aCount<0) or (cardinal(aStartIndex+aCount)>cardinal(c)) then - aCount := c-aStartIndex; - if aCount<=0 then - exit; - result := aCount; - n := GetCount; - SetCount(n+aCount); - PS := pointer(PtrUInt(DynArrayVar)+cardinal(aStartIndex)*ElemSize); - PD := pointer(PtrUInt(fValue^)+cardinal(n)*ElemSize); - if ElemType=nil then - MoveFast(PS^,PD^,cardinal(aCount)*ElemSize) else - CopyArray(PD,PS,ElemType,aCount); -end; - -procedure TDynArray.ElemClear(var Elem); -begin - if @Elem=nil then - exit; // avoid GPF - if ElemType<>nil then - {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(@Elem,ElemType) else - if (fIsObjArray=oaTrue) or ((fIsObjArray=oaUnknown) and ComputeIsObjArray) then - TObject(Elem).Free; - FillCharFast(Elem,ElemSize,0); // always -end; - -function TDynArray.ElemLoad(Source,SourceMax: PAnsiChar): RawByteString; -begin - if (Source<>nil) and (ElemType=nil) then - SetString(result,Source,ElemSize) else begin - SetString(result,nil,ElemSize); - FillCharFast(pointer(result)^,ElemSize,0); - ElemLoad(Source,pointer(result)^); - end; -end; - -procedure TDynArray.ElemLoadClear(var ElemTemp: RawByteString); -begin - ElemClear(pointer(ElemTemp)); - ElemTemp := ''; -end; - -procedure TDynArray.ElemLoad(Source: PAnsiChar; var Elem; SourceMax: PAnsiChar); -begin - if Source<>nil then // avoid GPF - if ElemType=nil then begin - if (SourceMax=nil) or (Source+ElemSize<=SourceMax) then - MoveFast(Source^,Elem,ElemSize); - end else - ManagedTypeLoad(@Elem,Source,ElemType,SourceMax); -end; - -function TDynArray.ElemSave(const Elem): RawByteString; -var itemsize: integer; -begin - if ElemType=nil then - SetString(result,PAnsiChar(@Elem),ElemSize) else begin - SetString(result,nil,ManagedTypeSaveLength(@Elem,ElemType,itemsize)); - if result<>'' then - ManagedTypeSave(@Elem,pointer(result),ElemType,itemsize); - end; -end; - -function TDynArray.ElemLoadFind(Source, SourceMax: PAnsiChar): integer; -var tmp: array[0..2047] of byte; - data: pointer; -begin - result := -1; - if (Source=nil) or (ElemSize>SizeOf(tmp)) then - exit; - if ElemType=nil then - data := Source else begin - FillCharFast(tmp,ElemSize,0); - ManagedTypeLoad(@tmp,Source,ElemType,SourceMax); - if Source=nil then - exit; - data := @tmp; - end; - try - if @fCompare=nil then - result := IndexOf(data^) else - result := Find(data^); - finally - if ElemType<>nil then - {$ifdef FPC}FPCFinalize{$else}_Finalize{$endif}(data,ElemType); - end; -end; - - -{ TDynArrayLoadFrom } - -function TDynArrayLoadFrom.Init(ArrayTypeInfo: pointer; Source: PAnsiChar; - SourceMaxLen: PtrInt): boolean; -var fake: pointer; -begin - result := false; - Position := nil; // force Step() to return false if called aterwards - if Source=nil then - exit; - if SourceMaxLen=0 then - PositionEnd := nil else - PositionEnd := Source+SourceMaxLen; - DynArray.Init(ArrayTypeInfo,fake); // just to retrieve RTTI - Count := DynArray.LoadFromHeader(PByte(Source),PByte(PositionEnd)); - if Count<0 then - exit; - Hash := pointer(Source); - Position := @Hash[1]; - Current := 0; - result := true; -end; - -function TDynArrayLoadFrom.Init(ArrayTypeInfo: pointer; const Source: RawByteString): boolean; -begin - result := Init(ArrayTypeInfo,pointer(Source),length(Source)); -end; - -function TDynArrayLoadFrom.Step(out Elem): boolean; -begin - result := false; - if (Position<>nil) and (Currentnil) and (Position+DynArray.ElemSize>PositionEnd) then - exit; - MoveFast(Position^,Elem,DynArray.ElemSize); - inc(Position,DynArray.ElemSize); - end else begin - ManagedTypeLoad(@Elem,Position,DynArray.ElemType,PositionEnd); - if Position=nil then - exit; - end; - inc(Current); - result := true; - end; -end; - -function TDynArrayLoadFrom.FirstField(out Field): boolean; -begin - if (Position<>nil) and (Currentnil) and (Hash32(@Hash[1],Position-PAnsiChar(@Hash[1]))=Hash[0]); -end; - - -{ TDynArrayHasher } - -function HashFile(const FileName: TFileName; Hasher: THasher): cardinal; -var buf: array[word] of cardinal; // 256KB of buffer - read: integer; - f: THandle; -begin - if not Assigned(Hasher) then - Hasher := DefaultHasher; - result := 0; - f := FileOpenSequentialRead(FileName); - if PtrInt(f)>=0 then begin - repeat - read := FileRead(f,buf,SizeOf(buf)); - if read<=0 then - break; - result := Hasher(result,@buf,read); - until false; - FileClose(f); - end; -end; - -function HashAnsiString(const Elem; Hasher: THasher): cardinal; -begin - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,Pointer(Elem),PStrLen(PtrUInt(Elem)-_STRLEN)^); -end; - -function HashAnsiStringI(const Elem; Hasher: THasher): cardinal; -var tmp: array[byte] of AnsiChar; // avoid slow heap allocation -begin - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,tmp,UpperCopy255Buf(tmp, - pointer(Elem),PStrLen(PtrUInt(Elem)-_STRLEN)^)-tmp); -end; - -{$ifdef UNICODE} - -function HashUnicodeString(const Elem; Hasher: THasher): cardinal; -begin - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,Pointer(Elem),length(UnicodeString(Elem))*2); -end; - -function HashUnicodeStringI(const Elem; Hasher: THasher): cardinal; -var tmp: array[byte] of AnsiChar; // avoid slow heap allocation -begin - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,tmp,UpperCopy255W(tmp,Pointer(Elem),length(UnicodeString(Elem)))-tmp); -end; - -{$endif UNICODE} - -function HashSynUnicode(const Elem; Hasher: THasher): cardinal; -begin - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,Pointer(Elem),length(SynUnicode(Elem))*2); -end; - -function HashSynUnicodeI(const Elem; Hasher: THasher): cardinal; -var tmp: array[byte] of AnsiChar; // avoid slow heap allocation -begin - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,tmp,UpperCopy255W(tmp,SynUnicode(Elem))-tmp); -end; - -function HashWideString(const Elem; Hasher: THasher): cardinal; -begin // WideString internal size is in bytes, not WideChar - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,Pointer(Elem),Length(WideString(Elem))*2); -end; - -function HashWideStringI(const Elem; Hasher: THasher): cardinal; -var tmp: array[byte] of AnsiChar; // avoid slow heap allocation -begin - if PtrUInt(Elem)=0 then - result := 0 else - result := Hasher(0,tmp,UpperCopy255W(tmp,pointer(Elem),Length(WideString(Elem)))-tmp); -end; - -function HashPtrUInt(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(PtrUInt)); -end; - -function HashPointer(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(pointer)); -end; - -function HashByte(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(byte)); -end; - -function HashWord(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(word)); -end; - -function HashInteger(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(integer)); -end; - -function HashInt64(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(Int64)); -end; - -function Hash128(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(THash128)); -end; - -function Hash256(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(THash256)); -end; - -function Hash512(const Elem; Hasher: THasher): cardinal; -begin - result := Hasher(0,@Elem,SizeOf(THash512)); -end; - -{$ifndef NOVARIANTS} -function VariantHash(const value: variant; CaseInsensitive: boolean; - Hasher: THasher): cardinal; -var Up: array[byte] of AnsiChar; // avoid heap allocation - vt: cardinal; - procedure ComplexType; - var tmp: RawUTF8; - begin // slow but always working conversion to string - VariantSaveJSON(value,twNone,tmp); - if CaseInsensitive then - result := Hasher(vt,Up,UpperCopy255(Up,tmp)-Up) else - result := Hasher(vt,pointer(tmp),length(tmp)); - end; -begin - if not Assigned(Hasher) then - Hasher := DefaultHasher; - vt := TVarData(value).VType; - with TVarData(value) do - case vt of - varNull, varEmpty: - result := vt; // good enough for void values - varShortInt, varByte: - result := Hasher(vt,@VByte,1); - varSmallint, varWord, varBoolean: - result := Hasher(vt,@VWord,2); - varLongWord, varInteger, varSingle: - result := Hasher(vt,@VLongWord,4); - varInt64, varDouble, varDate, varCurrency, varWord64: - result := Hasher(vt,@VInt64,SizeOf(Int64)); - varString: - if CaseInsensitive then - result := Hasher(vt,Up,UpperCopy255Buf(Up,VString,length(RawUTF8(VString)))-Up) else - result := Hasher(vt,VString,length(RawUTF8(VString))); - varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: - if CaseInsensitive then - result := Hasher(vt,Up,UpperCopy255W(Up,VOleStr,StrLenW(VOleStr))-Up) else - result := Hasher(vt,VAny,StrLenW(VOleStr)*2); - else - ComplexType; - end; -end; - -function HashVariant(const Elem; Hasher: THasher): cardinal; -begin - result := VariantHash(variant(Elem),false,Hasher); -end; - -function HashVariantI(const Elem; Hasher: THasher): cardinal; -begin - result := VariantHash(variant(Elem),true,Hasher); -end; -{$endif NOVARIANTS} - -procedure TDynArrayHasher.Init(aDynArray: PDynArray; aHashElement: TDynArrayHashOne; - aEventHash: TEventDynArrayHashOne; aHasher: THasher; aCompare: TDynArraySortCompare; - aEventCompare: TEventDynArraySortCompare; aCaseInsensitive: boolean); -begin - DynArray := aDynArray; - if @aHasher=nil then - Hasher := DefaultHasher else - Hasher := aHasher; - HashElement := aHashElement; - EventHash := aEventHash; - if (@HashElement=nil) and (@EventHash=nil) then // fallback to first field RTTI - HashElement := DYNARRAY_HASHFIRSTFIELD[aCaseInsensitive,DynArray^.GuessKnownType]; - Compare := aCompare; - EventCompare := aEventCompare; - if (@Compare=nil) and (@EventCompare=nil) then - Compare := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,DynArray^.GuessKnownType]; - CountTrigger := 32; - Clear; -end; - -procedure TDynArrayHasher.InitSpecific(aDynArray: PDynArray; aKind: TDynArrayKind; - aCaseInsensitive: boolean); -var cmp: TDynArraySortCompare; - hsh: TDynArrayHashOne; -begin - cmp := DYNARRAY_SORTFIRSTFIELD[aCaseInsensitive,aKind]; - hsh := DYNARRAY_HASHFIRSTFIELD[aCaseInsensitive,aKind]; - if (@hsh=nil) or (@cmp=nil) then - raise ESynException.CreateUTF8('TDynArrayHasher.InitSpecific: %?',[ToText(aKind)^]); - Init(aDynArray,hsh,nil,nil,cmp,nil,aCaseInsensitive) -end; - -procedure TDynArrayHasher.Clear; -begin - HashTable := nil; - HashTableSize := 0; - ScanCounter := 0; - if Assigned(HashElement) or Assigned(EventHash) then - State := [hasHasher] else - byte(State) := 0; -end; - -function TDynArrayHasher.HashOne(Elem: pointer): cardinal; -begin - if Assigned(EventHash) then - result := EventHash(Elem^) else - if Assigned(HashElement) then - result := HashElement(Elem^,Hasher) else - result := 0; // will be ignored afterwards for sure -end; - -const // primes reduce memory consumption and enhance distribution - _PRIMES: array[0..38{$ifndef CPU32DELPHI}+15{$endif}] of integer = ( - {$ifndef CPU32DELPHI} 31, 127, 251, 499, 797, 1259, 2011, 3203, 5087, 8089, - 12853, 20399, 81649, 129607, 205759, {$endif} - // following HASH_PO2=2^18=262144 for Delphi Win32 - 326617, 411527, 518509, 653267, 823117, 1037059, 1306601, 1646237, - 2074129, 2613229, 3292489, 4148279, 5226491, 6584983, 8296553, 10453007, - 13169977, 16593127, 20906033, 26339969, 33186281, 41812097, 52679969, - 66372617, 83624237, 105359939, 132745199, 167248483, 210719881, 265490441, - 334496971, 421439783, 530980861, 668993977, 842879579, 1061961721, - 1337987929, 1685759167, 2123923447); - -function NextPrime(v: integer): integer; {$ifdef HASINLINE}inline;{$endif} -var i: PtrInt; - P: PIntegerArray; -begin - P := @_PRIMES; - for i := 0 to high(_PRIMES) do begin - result := P^[i]; - if result>v then - exit; - end; -end; - -function TDynArrayHasher.HashTableIndex(aHashCode: cardinal): cardinal; -begin - result := HashTableSize; - {$ifdef CPU32DELPHI} // Delphi Win32 is not efficient with 64-bit multiplication - if result>HASH_PO2 then - result := aHashCode mod result else - result := aHashCode and (result-1); - {$else} // FPC or dcc64 compile next line as very optimized asm - result := (QWord(aHashCode)*result)shr 32; - // see https://lemire.me/blog/2016/06/27/a-fast-alternative-to-the-modulo-reduction - {$endif CPU32DELPHI} -end; - -function TDynArrayHasher.Find(aHashCode: cardinal; aForAdd: boolean): integer; -var first,last: integer; - ndx,siz: PtrInt; - P: PAnsiChar; -begin - P := DynArray^.Value^; - siz := DynArray^.ElemSize; - if not(canHash in State) then begin // Count=0 or Count search once from HashTable[0] to HashTable[first-1] - if result=first then - break else begin - result := 0; - last := first; - end; - until false; - RaiseFatalCollision('Find',aHashCode); -end; - -function TDynArrayHasher.FindOrNew(aHashCode: cardinal; Elem: pointer; - aHashTableIndex: PInteger): integer; -var first,last,ndx,cmp: integer; - P: PAnsiChar; -begin - if not(canHash in State) then begin // e.g. Countnil then - aHashTableIndex^ := result; - result := ndx; - exit; - end; - // hash or slot collision -> search next item - {$ifdef DYNARRAYHASHCOLLISIONCOUNT} - inc(FindCollisions); - {$endif} - //inc(TDynArrayHashedCollisionCount); - inc(result); - if result=last then - // reached the end -> search once from HashTable[0] to HashTable[first-1] - if result=first then - break else begin - result := 0; - last := first; - end; - until false; - RaiseFatalCollision('FindOrNew',aHashCode); -end; - -procedure TDynArrayHasher.HashAdd(aHashCode: cardinal; var result: integer); -var n: integer; -begin // on input: HashTable[result] slot is already computed - n := DynArray^.Count; - if HashTableSize=0 then - RaiseFatalCollision('HashAdd',aHashCode); - end; - HashTable[-result-1] := n+1; // store Index+1 (0 means void slot) - result := n; -end; // on output: result holds the position in fValue[] - - -// brute force O(n) indexes fix after deletion (much faster than full ReHash) -procedure DynArrayHashTableAdjust(P: PIntegerArray; deleted: integer; count: PtrInt); -{$ifdef CPUX64ASM} // SSE2 simd is 25x faster than "if P^>deleted then dec(P^)" -{$ifdef FPC}nostackframe; assembler; asm {$else} -asm .noframe // rcx=P, edx=deleted, r8=count (Linux: rdi,esi,rdx) -{$endif FPC} -{$ifdef Linux} - mov r8, rdx - mov rcx, rdi - mov rdx, rsi -{$endif Linux} - xor eax, eax // reset eax high bits for setg al below - movq xmm0, rdx // xmm0 = 128-bit of quad deleted - pshufd xmm0, xmm0, 0 - test cl, 3 - jnz @1 // paranoid: a dword dynamic array is always dword-aligned - // ensure P is 256-bit aligned (for avx2) -@align: test cl, 31 - jz @ok - cmp dword ptr[rcx], edx - setg al // P[]>deleted -> al=1, 0 otherwise - sub dword ptr[rcx], eax // branchless dec(P[]) - add rcx, 4 - dec r8 - jmp @align -@ok: {$ifdef FPC} // AVX2 asm is not supported by Delphi (even 10.3) :( - test byte ptr[rip+CPUIDX64], 1 shl cpuAVX2 - jz @sse2 - vpshufd ymm0, ymm0, 0 // shuffle to ymm0 128-bit low lane - vperm2f128 ymm0, ymm0, ymm0, 0 // copy to ymm0 128-bit high lane - // avx process of 128 bytes (32 indexes) per loop iteration - align 16 -@avx2: sub r8, 32 - vmovdqa ymm1, [rcx] // 4 x 256-bit process = 4 x 8 integers - vmovdqa ymm3, [rcx + 32] - vmovdqa ymm5, [rcx + 64] - vmovdqa ymm7, [rcx + 96] - vpcmpgtd ymm2, ymm1, ymm0 // compare P[]>deleted -> -1, 0 otherwise - vpcmpgtd ymm4, ymm3, ymm0 - vpcmpgtd ymm6, ymm5, ymm0 - vpcmpgtd ymm8, ymm7, ymm0 - vpaddd ymm1, ymm1, ymm2 // adjust by adding -1 / 0 - vpaddd ymm3, ymm3, ymm4 - vpaddd ymm5, ymm5, ymm6 - vpaddd ymm7, ymm7, ymm8 - vmovdqa [rcx], ymm1 - vmovdqa [rcx + 32], ymm3 - vmovdqa [rcx + 64], ymm5 - vmovdqa [rcx + 96], ymm7 - add rcx, 128 - cmp r8, 32 - jae @avx2 - vzeroupper - jmp @2 - {$endif FPC} - // SSE2 process of 64 bytes (16 indexes) per loop iteration -{$ifdef FPC} align 16 {$else} .align 16 {$endif} -@sse2: sub r8, 16 - movaps xmm1, dqword [rcx] // 4 x 128-bit process = 4 x 4 integers - movaps xmm3, dqword [rcx + 16] - movaps xmm5, dqword [rcx + 32] - movaps xmm7, dqword [rcx + 48] - movaps xmm2, xmm1 // keep copy for paddd below - movaps xmm4, xmm3 - movaps xmm6, xmm5 - movaps xmm8, xmm7 - pcmpgtd xmm1, xmm0 // quad compare P[]>deleted -> -1, 0 otherwise - pcmpgtd xmm3, xmm0 - pcmpgtd xmm5, xmm0 - pcmpgtd xmm7, xmm0 - paddd xmm1, xmm2 // quad adjust by adding -1 / 0 - paddd xmm3, xmm4 - paddd xmm5, xmm6 - paddd xmm7, xmm8 - movaps dqword [rcx], xmm1 // quad store back - movaps dqword [rcx + 16], xmm3 - movaps dqword [rcx + 32], xmm5 - movaps dqword [rcx + 48], xmm7 - add rcx, 64 - cmp r8, 16 - jae @sse2 - jmp @2 - // trailing indexes -@1: dec r8 - cmp dword ptr[rcx + r8 * 4], edx - setg al - sub dword ptr[rcx + r8 * 4], eax -@2: test r8, r8 - jnz @1 -end; -{$else} -begin - repeat - dec(count,8); - dec(P[0],ord(P[0]>deleted)); // branchless code is 10x faster than if :) - dec(P[1],ord(P[1]>deleted)); - dec(P[2],ord(P[2]>deleted)); - dec(P[3],ord(P[3]>deleted)); - dec(P[4],ord(P[4]>deleted)); - dec(P[5],ord(P[5]>deleted)); - dec(P[6],ord(P[6]>deleted)); - dec(P[7],ord(P[7]>deleted)); - P := @P[8]; - until count<8; - while count>0 do begin - dec(count); - dec(P[count],ord(P[count]>deleted)); - end; -end; -{$endif CPUX64ASM} // SSE2 asm is invalid prior to Delphi XE7 (to be refined) - -// with x86_64/sse2 for 200,000 items: adjust=200.57ms (11.4GB/s) hash=2.46ms -// -> TDynArray.Delete move() takes more time than the HashTable update :) - -{ some numbers, with CITIES_MAX=200000, deleting 1/128 entries - first column (3..23) is the max number of indexes[] chunk to rehash -1. naive loop - for i := 0 to HashTableSize-1 do - if HashTable[i]>aArrayIndex then - dec(HashTable[i]); - 3 #257 adjust=7.95ms 191.7MB hash=8us - 8 #384 adjust=11.93ms 255.8MB hash=10us - 11 #1019 adjust=32.09ms 332.8MB hash=26us - 13 #16259 adjust=511.10ms 379.2MB hash=230us - 13 #32515 adjust=1.01s 383.6MB/s hash=440us - 14 #33531 adjust=1.04s 382.2MB hash=459us - 17 #46612 adjust=1.44s 386.3MB hash=639us - 17 #65027 adjust=1.97s 396.3MB/s hash=916us - 17 #97539 adjust=2.79s 419.9MB/s hash=1.37ms - 18 #109858 adjust=3.05s 431.2MB hash=1.51ms - 18 #130051 adjust=3.44s 454.1MB/s hash=1.75ms - 18 #162563 adjust=3.93s 496.9MB/s hash=2.14ms - 23 #172723 adjust=4.05s 511.7MB hash=2.26ms - 23 #195075 adjust=4.27s 548.6MB/s hash=2.47ms -2. branchless pure pascal code is about 10x faster! - 3 #257 adjust=670us 2.2GB hash=8us - 8 #384 adjust=1ms 2.9GB hash=9us - 11 #1019 adjust=2.70ms 3.8GB hash=21us - 13 #16259 adjust=43.65ms 4.3GB hash=210us - 13 #32515 adjust=87.75ms 4.3GB/s hash=423us - 14 #33531 adjust=90.44ms 4.3GB hash=441us - 17 #46612 adjust=127.68ms 4.2GB hash=627us - 17 #65027 adjust=179.64ms 4.2GB/s hash=908us - 17 #97539 adjust=267.44ms 4.2GB/s hash=1.35ms - 18 #109858 adjust=301.27ms 4.2GB hash=1.50ms - 18 #130051 adjust=355.37ms 4.2GB/s hash=1.74ms - 18 #162563 adjust=438.79ms 4.3GB/s hash=2.11ms - 23 #172723 adjust=465.23ms 4.3GB hash=2.23ms - 23 #195075 adjust=520.85ms 4.3GB/s hash=2.45ms -3. SSE2 simd assembly makes about 3x improvement - 3 #257 adjust=290us 5.1GB hash=8us - 8 #384 adjust=427us 6.9GB hash=10us - 11 #1019 adjust=1.11ms 9.3GB hash=20us - 13 #16259 adjust=18.33ms 10.3GB hash=219us - 13 #32515 adjust=36.32ms 10.5GB/s hash=435us - 14 #33531 adjust=37.39ms 10.4GB hash=452us - 17 #46612 adjust=51.70ms 10.5GB hash=622us - 17 #65027 adjust=72.47ms 10.5GB/s hash=893us - 17 #97539 adjust=107ms 10.6GB/s hash=1.32ms - 18 #109858 adjust=120.08ms 10.7GB hash=1.46ms - 18 #130051 adjust=140.50ms 10.8GB/s hash=1.71ms - 18 #162563 adjust=171.44ms 11.1GB/s hash=2.10ms - 23 #172723 adjust=181.02ms 11.1GB hash=2.22ms - 23 #195075 adjust=201.53ms 11.3GB/s hash=2.44ms -4. AVX2 simd assembly gives some additional 40% (consistent on my iCore3 cpu) - 3 #257 adjust=262us 5.6GB hash=8us - 8 #384 adjust=383us 7.7GB hash=10us - 11 #1019 adjust=994us 10.4GB hash=21us - 13 #16259 adjust=16.34ms 11.5GB hash=248us - 13 #32515 adjust=32.12ms 11.8GB/s hash=464us - 14 #33531 adjust=33.06ms 11.8GB hash=484us - 17 #46612 adjust=45.49ms 11.9GB hash=678us - 17 #65027 adjust=62.36ms 12.2GB/s hash=966us - 17 #97539 adjust=90.80ms 12.6GB/s hash=1.43ms - 18 #109858 adjust=101.82ms 12.6GB hash=1.59ms - 18 #130051 adjust=117.37ms 13GB/s hash=1.83ms - 18 #162563 adjust=140.08ms 13.6GB/s hash=2.23ms - 23 #172723 adjust=147.20ms 13.7GB hash=2.34ms - 23 #195075 adjust=161.73ms 14.1GB/s hash=2.57ms -} -procedure TDynArrayHasher.HashDelete(aArrayIndex,aHashTableIndex: integer; aHashCode: cardinal); -var first,next,last,ndx,i,n: integer; - P: PAnsiChar; - indexes: array[0..511] of cardinal; // to be rehashed -begin - // retrieve hash table entries to be recomputed - first := aHashTableIndex; - last := HashTableSize; - next := first; - n := 0; - repeat - HashTable[next] := 0; // Clear slots - inc(next); - if next=last then - if next=first then - RaiseFatalCollision('HashDelete down',aHashCode) else begin - next := 0; - last := first; - end; - ndx := HashTable[next]-1; // stored index+1 - if ndx<0 then - break; // stop at void entry - if n=high(indexes) then // typical 0..23 - RaiseFatalCollision('HashDelete indexes overflow',aHashCode); - indexes[n] := ndx; - inc(n); - until false; - // ReHash collided entries - note: item is not yet deleted in Value^[] - for i := 0 to n-1 do begin - P := PAnsiChar(DynArray^.Value^)+indexes[i]*DynArray^.ElemSize; - ndx := FindOrNew(HashOne(P),P,nil); - if ndx<0 then - HashTable[-ndx-1] := indexes[i]+1; // ignore ndx>=0 dups (like ReHash) - end; - // adjust all stored indexes - DynArrayHashTableAdjust(pointer(HashTable),aArrayIndex,HashTableSize); -end; - -function TDynArrayHasher.FindBeforeAdd(Elem: pointer; - out wasAdded: boolean; aHashCode: cardinal): integer; -var n: integer; -begin - wasAdded := false; - if not(canHash in State) then begin - n := DynArray^.Count; - if n=0 then - exit; // item found - if not(canHash in State) then begin - wasadded := true; - result := n; - exit; - end; - end; - end; - if not(canHash in State) then - ReHash({forced=}true); // hash previous CountTrigger items - result := FindOrNew(aHashCode,Elem,nil); - if result<0 then begin // found no matching item - wasAdded := true; - HashAdd(aHashCode,result); - end; -end; - -function TDynArrayHasher.FindBeforeDelete(Elem: pointer): integer; -var hc: cardinal; - ht: integer; -begin - if canHash in State then begin - hc := HashOne(Elem); - result := FindOrNew(hc,Elem,@ht); - if result<0 then - result := -1 else - HashDelete(result,ht,hc); - end else - result := Scan(Elem); -end; - -procedure TDynArrayHasher.RaiseFatalCollision(const caller: RawUTF8; - aHashCode: cardinal); -begin // a dedicated sub-procedure reduces code size - raise ESynException.CreateUTF8('TDynArrayHasher.% fatal collision: '+ - 'aHashCode=% HashTableSize=% Count=% Capacity=% ArrayType=% KnownType=%', - [caller,CardinalToHexShort(aHashCode),HashTableSize,DynArray^.Count, - DynArray^.Capacity,DynArray^.ArrayTypeShort^,ToText(DynArray^.KnownType)^]); -end; - -function TDynArrayHasher.GetHashFromIndex(aIndex: PtrInt): cardinal; -var P: pointer; -begin - P := DynArray^.ElemPtr(aIndex); - if P<>nil then - result := HashOne(P) else - result := 0; -end; - -procedure TDynArrayHasher.SetEventHash(const event: TEventDynArrayHashOne); -begin - EventHash := event; - Clear; -end; - -function TDynArrayHasher.Scan(Elem: pointer): integer; -var P: PAnsiChar; - i,max: integer; - siz: PtrInt; -begin - result := -1; - max := DynArray^.Count-1; - P := DynArray^.Value^; - siz := DynArray^.ElemSize; - if Assigned(EventCompare) then // custom comparison - for i := 0 to max do - if EventCompare(P^,Elem^)=0 then begin - result := i; - break; - end else - inc(P,siz) else - if Assigned(Compare) then - for i := 0 to max do - if Compare(P^,Elem^)=0 then begin - result := i; - break; - end else - inc(P,siz); - // enable hashing if Scan() called 2*CountTrigger - if (hasHasher in State) and (max>7) then begin - inc(ScanCounter); - if ScanCounter>=CountTrigger*2 then begin - CountTrigger := 2; // rather use hashing from now on - ReHash(false); // set HashTable[] and canHash - end; - end; -end; - -function TDynArrayHasher.Find(Elem: pointer): integer; -begin - result := Find(Elem,HashOne(Elem)); -end; - -function TDynArrayHasher.Find(Elem: pointer; aHashCode: cardinal): integer; -begin - result := FindOrNew(aHashCode,Elem,nil); // fallback to Scan() if needed - if result<0 then - result := -1; // for coherency with most search methods -end; - -function TDynArrayHasher.ReHash(forced: boolean): integer; -var i, n, cap, siz, ndx: integer; - P: PAnsiChar; - hc: cardinal; -begin - result := 0; - n := DynArray^.Count; - if not (Assigned(HashElement) or Assigned(EventHash)) or - (not forced and ((n=0) or (n=0 then - inc(result) else // found duplicated value - HashTable[-ndx-1] := i; // store index+1 (0 means void entry) - inc(P,DynArray^.ElemSize); - end; -end; - - -{ TDynArrayHashed } - -{$ifdef UNDIRECTDYNARRAY} // some Delphi 2009+ wrapper definitions - -function TDynArrayHashed.GetCount: PtrInt; -begin - result := InternalDynArray.GetCount; -end; -procedure TDynArrayHashed.SetCount(aCount: PtrInt); -begin - InternalDynArray.SetCount(aCount); -end; -function TDynArrayHashed.GetCapacity: PtrInt; -begin - result := InternalDynArray.GetCapacity; -end; -procedure TDynArrayHashed.SetCapacity(aCapacity: PtrInt); -begin - InternalDynArray.SetCapacity(aCapacity); -end; -function TDynArrayHashed.Value: PPointer; -begin - result := InternalDynArray.fValue; -end; -function TDynArrayHashed.ElemSize: PtrUInt; -begin - result := InternalDynArray.fElemSize; -end; -function TDynArrayHashed.ElemType: Pointer; -begin - result := InternalDynArray.fElemType; -end; -procedure TDynArrayHashed.ElemCopy(const A; var B); -begin - InternalDynArray.ElemCopy(A,B); -end; -function TDynArrayHashed.ElemPtr(index: PtrInt): pointer; -begin - result := InternalDynArray.ElemPtr(index); -end; -procedure TDynArrayHashed.ElemCopyAt(index: PtrInt; var Dest); -begin - InternalDynArray.ElemCopyAt(index,Dest); -end; -function TDynArrayHashed.KnownType: TDynArrayKind; -begin - result := InternalDynArray.KnownType; -end; -procedure TDynArrayHashed.Clear; -begin - InternalDynArray.SetCount(0); -end; -function TDynArrayHashed.Add(const Elem): integer; -begin - result := InternalDynArray.Add(Elem); -end; -procedure TDynArrayHashed.Delete(aIndex: PtrInt); -begin - InternalDynArray.Delete(aIndex); -end; -function TDynArrayHashed.SaveTo: RawByteString; -begin - result := InternalDynArray.SaveTo; -end; -function TDynArrayHashed.LoadFrom(Source: PAnsiChar; AfterEach: TDynArrayAfterLoadFrom; - NoCheckHash: boolean; SourceMax: PAnsiChar): PAnsiChar; -begin - result := InternalDynArray.LoadFrom(Source,AfterEach,NoCheckHash,SourceMax); -end; -function TDynArrayHashed.LoadFromBinary(const Buffer: RawByteString; NoCheckHash: boolean): boolean; -begin - result := InternalDynArray.LoadFromBinary(Buffer,NoCheckHash); -end; -function TDynArrayHashed.SaveTo(Dest: PAnsiChar): PAnsiChar; -begin - result := InternalDynArray.SaveTo(Dest); -end; -function TDynArrayHashed.SaveToJSON(EnumSetsAsText: boolean; - reformat: TTextWriterJSONFormat): RawUTF8; -begin - result := InternalDynArray.SaveToJSON(EnumSetsAsText,reformat); -end; -procedure TDynArrayHashed.Sort(aCompare: TDynArraySortCompare); -begin - InternalDynArray.Sort(aCompare); -end; -procedure TDynArrayHashed.CreateOrderedIndex(var aIndex: TIntegerDynArray; - aCompare: TDynArraySortCompare); -begin - InternalDynArray.CreateOrderedIndex(aIndex,aCompare); -end; -function TDynArrayHashed.LoadFromJSON(P: PUTF8Char; aEndOfObject: PUTF8Char{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): PUTF8Char; -begin - result := InternalDynArray.LoadFromJSON(P,aEndOfObject{$ifndef NOVARIANTS}, - CustomVariantOptions{$endif}); -end; -function TDynArrayHashed.SaveToLength: integer; -begin - result := InternalDynArray.SaveToLength; -end; - -{$endif UNDIRECTDYNARRAY} - -procedure TDynArrayHashed.Init(aTypeInfo: pointer; var aValue; - aHashElement: TDynArrayHashOne; aCompare: TDynArraySortCompare; - aHasher: THasher; aCountPointer: PInteger; aCaseInsensitive: boolean); -begin - {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$else}inherited{$endif} - Init(aTypeInfo,aValue,aCountPointer); - fHash.Init(@self,aHashElement,nil,aHasher,aCompare,nil,aCaseInsensitive); - {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}SetCompare(fHash.Compare); -end; - -procedure TDynArrayHashed.InitSpecific(aTypeInfo: pointer; var aValue; - aKind: TDynArrayKind; aCountPointer: PInteger; aCaseInsensitive: boolean); -begin - {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$else}inherited{$endif} - Init(aTypeInfo,aValue,aCountPointer); - fHash.InitSpecific(@self,aKind,aCaseInsensitive); - {$ifdef UNDIRECTDYNARRAY}with InternalDynArray do{$endif} begin - fCompare := fHash.Compare; - fKnownType := aKind; - fKnownSize := KNOWNTYPE_SIZE[aKind]; - end; -end; - -function TDynArrayHashed.Scan(const Elem): integer; -begin - result := fHash.Scan(@Elem); -end; - -function TDynArrayHashed.FindHashed(const Elem): integer; -begin - result := fHash.FindOrNew(fHash.HashOne(@Elem),@Elem); - if result<0 then - result := -1; // for coherency with most methods -end; - -function TDynArrayHashed.FindFromHash(const Elem; aHashCode: cardinal): integer; -begin // overload FindHashed() trigger F2084 Internal Error: C2130 on Delphi XE3 - result := fHash.FindOrNew(aHashCode,@Elem); // fallback to Scan() if needed - if result<0 then - result := -1; // for coherency with most methods -end; - -function TDynArrayHashed.FindHashedForAdding(const Elem; out wasAdded: boolean; - noAddEntry: boolean): integer; -begin - result := FindHashedForAdding(Elem,wasAdded,fHash.HashOne(@Elem),noAddEntry); -end; - -function TDynArrayHashed.FindHashedForAdding(const Elem; out wasAdded: boolean; - aHashCode: cardinal; noAddEntry: boolean): integer; -begin - result := fHash.FindBeforeAdd(@Elem,wasAdded,aHashCode); - if wasAdded and not noAddEntry then - SetCount(result+1); // reserve space for a void element in array -end; - -function TDynArrayHashed.AddAndMakeUniqueName(aName: RawUTF8): pointer; -var ndx,j: integer; - added: boolean; - aName_: RawUTF8; -begin - if aName='' then - aName := '_'; - ndx := FindHashedForAdding(aName,added); - if not added then begin // force unique column name - aName_ := aName+'_'; - j := 1; - repeat - aName := aName_+UInt32ToUTF8(j); - ndx := FindHashedForAdding(aName,added); - inc(j); - until added; - end; - result := PAnsiChar(Value^)+cardinal(ndx)*ElemSize; - PRawUTF8(result)^ := aName; // store unique name at 1st elem position -end; - -function TDynArrayHashed.AddUniqueName(const aName: RawUTF8; aNewIndex: PInteger): pointer; -begin - result := AddUniqueName(aName,'',[],aNewIndex); -end; - -function TDynArrayHashed.AddUniqueName(const aName: RawUTF8; - const ExceptionMsg: RawUTF8; const ExceptionArgs: array of const; aNewIndex: PInteger): pointer; -var ndx: integer; - added: boolean; -begin - ndx := FindHashedForAdding(aName,added); - if added then begin - if aNewIndex<>nil then - aNewIndex^ := ndx; - result := PAnsiChar(Value^)+cardinal(ndx)*ElemSize; - PRawUTF8(result)^ := aName; // store unique name at 1st elem position - end else - if ExceptionMsg='' then - raise ESynException.CreateUTF8('Duplicated [%] name',[aName]) else - raise ESynException.CreateUTF8(ExceptionMsg,ExceptionArgs); -end; - -function TDynArrayHashed.FindHashedAndFill(var ElemToFill): integer; -begin - result := fHash.FindOrNew(fHash.HashOne(@ElemtoFill),@ElemToFill); - if result<0 then - result := -1 else - ElemCopy(PAnsiChar(Value^)[cardinal(result)*ElemSize],ElemToFill); -end; - -procedure TDynArrayHashed.SetEventHash(const event: TEventDynArrayHashOne); -begin - fHash.SetEventHash(event); -end; - -function TDynArrayHashed.FindHashedAndUpdate(const Elem; AddIfNotExisting: boolean): integer; -var hc: cardinal; -label doh; -begin - if canHash in fHash.State then begin -doh:hc := fHash.HashOne(@Elem); - result := fHash.FindOrNew(hc,@Elem); - if (result<0) and AddIfNotExisting then begin - fHash.HashAdd(hc,result); // ReHash only if necessary - SetCount(result+1); // add new item - end; - end else begin - result := fHash.Scan(@Elem); - if result<0 then begin - if AddIfNotExisting then - if canHash in fHash.State then // Scan triggered ReHash - goto doh else begin - result := Add(Elem); // regular Add - exit; - end; - end; - end; - if result>=0 then - ElemCopy(Elem,PAnsiChar(Value^)[cardinal(result)*ElemSize]); // update -end; - -function TDynArrayHashed.FindHashedAndDelete(const Elem; FillDeleted: pointer; - noDeleteEntry: boolean): integer; -begin - result := fHash.FindBeforeDelete(@Elem); - if result>=0 then begin - if FillDeleted<>nil then - ElemCopyAt(result,FillDeleted^); - if not noDeleteEntry then - Delete(result); - end; -end; - -function TDynArrayHashed.GetHashFromIndex(aIndex: PtrInt): Cardinal; -begin - result := fHash.GetHashFromIndex(aIndex); -end; - -function TDynArrayHashed.ReHash(forAdd: boolean): integer; -begin - result := fHash.ReHash(forAdd); -end; - - -function DynArray(aTypeInfo: pointer; var aValue; aCountPointer: PInteger): TDynArray; -begin - result.Init(aTypeInfo,aValue,aCountPointer); -end; - -function SimpleDynArrayLoadFrom(Source: PAnsiChar; aTypeInfo: pointer; - var Count, ElemSize: integer; NoHash32Check: boolean): pointer; -var Hash: PCardinalArray absolute Source; - info: PTypeInfo; -begin - result := nil; - info := GetTypeInfo(aTypeInfo,tkDynArray); - if info=nil then - exit; // invalid type information - ElemSize := info^.elSize {$ifdef FPC}and $7FFFFFFF{$endif}; - if (info^.ElType<>nil) or (Source=nil) or - (Source[0]<>AnsiChar(ElemSize)) or (Source[1]<>#0) then - exit; // invalid type information or Source content - inc(Source,2); - Count := FromVarUInt32(PByte(Source)); // dynamic array count - if (Count<>0) and (NoHash32Check or (Hash32(@Hash[1],Count*ElemSize)=Hash[0])) then - result := @Hash[1]; // returns valid Source content -end; - -function IntegerDynArrayLoadFrom(Source: PAnsiChar; var Count: integer; - NoHash32Check: boolean): PIntegerArray; -var Hash: PCardinalArray absolute Source; -begin - result := nil; - if (Source=nil) or (Source[0]<>#4) or (Source[1]<>#0) then - exit; // invalid Source content - inc(Source,2); - Count := FromVarUInt32(PByte(Source)); // dynamic array count - if (Count<>0) and (NoHash32Check or (Hash32(@Hash[1],Count*4)=Hash[0])) then - result := @Hash[1]; // returns valid Source content -end; - -function RawUTF8DynArrayLoadFromContains(Source: PAnsiChar; - Value: PUTF8Char; ValueLen: PtrInt; CaseSensitive: boolean): PtrInt; -var Count, Len: PtrInt; -begin - if (Value=nil) or (ValueLen=0) or - (Source=nil) or (Source[0]<>AnsiChar(SizeOf(PtrInt))) - {$ifndef FPC}or (Source[1]<>AnsiChar(tkLString)){$endif} then begin - result := -1; - exit; // invalid Source or Value content - end; - inc(Source,2); - Count := FromVarUInt32(PByte(Source)); // dynamic array count - inc(Source,SizeOf(cardinal)); // ignore Hash32 security checksum - for result := 0 to Count-1 do begin - Len := FromVarUInt32(PByte(Source)); - if CaseSensitive then begin - if (Len=ValueLen) and CompareMemFixed(Value,Source,Len) then - exit; - end else - if UTF8ILComp(Value,pointer(Source),ValueLen,Len)=0 then - exit; - inc(Source,Len); - end; - result := -1; -end; - - -{ TObjectDynArrayWrapper } - -constructor TObjectDynArrayWrapper.Create(var aValue; aOwnObjects: boolean); -begin - fValue := @aValue; - fOwnObjects := aOwnObjects; -end; - -destructor TObjectDynArrayWrapper.Destroy; -begin - Clear; - inherited; -end; - -function TObjectDynArrayWrapper.Find(Instance: TObject): integer; -var P: PObjectArray; -begin - P := fValue^; - if P<>nil then - for result := 0 to fCount-1 do - if P[result]=Instance then - exit; - result := -1; -end; - -function TObjectDynArrayWrapper.Add(Instance: TObject): integer; -var cap: integer; -begin - cap := length(TObjectDynArray(fValue^)); - if cap<=fCount then - SetLength(TObjectDynArray(fValue^),NextGrow(cap)); - result := fCount; - TObjectDynArray(fValue^)[result] := Instance; - inc(fCount); -end; - -procedure TObjectDynArrayWrapper.Delete(Index: integer); -var P: PObjectArray; -begin - P := fValue^; - if (P=nil) or (cardinal(Index)>=cardinal(fCount)) then - exit; // avoid Out of range - if fOwnObjects then - P[Index].Free; - dec(fCount); - if fCount>Index then - MoveFast(P[Index+1],P[Index],(fCount-Index)*SizeOf(pointer)); -end; - -procedure TObjectDynArrayWrapper.Clear; -var i: PtrInt; - P: PObjectArray; -begin - P := fValue^; - if P<>nil then begin - if fOwnObjects then - for i := fCount-1 downto 0 do - try - P[i].Free; - except - on Exception do; - end; - TObjectDynArray(fValue^) := nil; // set capacity to 0 - fCount := 0; - end else - if fCount>0 then - raise ESynException.Create('You MUST define your IObjectDynArray field '+ - 'BEFORE the corresponding dynamic array'); -end; - -procedure TObjectDynArrayWrapper.Slice; -begin - SetLength(TObjectDynArray(fValue^),fCount); -end; - -function TObjectDynArrayWrapper.Count: integer; -begin - result := fCount; -end; - -function TObjectDynArrayWrapper.Capacity: integer; -begin - result := length(TObjectDynArray(fValue^)); -end; - -procedure TObjectDynArrayWrapper.Sort(Compare: TDynArraySortCompare); -begin - if (@Compare<>nil) and (fCount>0) then - QuickSortPtr(0,fCount-1,Compare,fValue^); -end; - -function NewSynLocker: PSynLocker; -begin - result := AllocMem(SizeOf(result^)); - result^.Init; -end; - -function PtrArrayAdd(var aPtrArray; aItem: pointer): integer; -var a: TPointerDynArray absolute aPtrArray; -begin - result := length(a); - SetLength(a,result+1); - a[result] := aItem; -end; - -function PtrArrayAddOnce(var aPtrArray; aItem: pointer): integer; -var a: TPointerDynArray absolute aPtrArray; - n: integer; -begin - n := length(a); - result := PtrUIntScanIndex(pointer(a),n,PtrUInt(aItem)); - if result>=0 then - exit; - SetLength(a,n+1); - a[n] := aItem; - result := n; -end; - -procedure PtrArrayDelete(var aPtrArray; aIndex: integer; aCount: PInteger); -var a: TPointerDynArray absolute aPtrArray; - n: integer; -begin - if aCount=nil then - n := length(a) else - n := aCount^; - if cardinal(aIndex)>=cardinal(n) then - exit; // out of range - dec(n); - if n>aIndex then - MoveFast(a[aIndex+1],a[aIndex],(n-aIndex)*SizeOf(pointer)); - if aCount=nil then - SetLength(a,n) else - aCount^ := n; -end; - -function PtrArrayDelete(var aPtrArray; aItem: pointer; aCount: PInteger): integer; -var a: TPointerDynArray absolute aPtrArray; - n: integer; -begin - if aCount=nil then - n := length(a) else - n := aCount^; - result := PtrUIntScanIndex(pointer(a),n,PtrUInt(aItem)); - if result<0 then - exit; - dec(n); - if n>result then - MoveFast(a[result+1],a[result],(n-result)*SizeOf(pointer)); - if aCount=nil then - SetLength(a,n) else - aCount^ := n; -end; - -function PtrArrayFind(var aPtrArray; aItem: pointer): integer; -var a: TPointerDynArray absolute aPtrArray; -begin - result := PtrUIntScanIndex(pointer(a),length(a),PtrUInt(aItem)); -end; - -{ wrapper functions to T*ObjArr types } - -function ObjArrayAdd(var aObjArray; aItem: TObject): PtrInt; -var a: TObjectDynArray absolute aObjArray; -begin - result := length(a); - SetLength(a,result+1); - a[result] := aItem; -end; - -function ObjArrayAddFrom(var aDestObjArray; const aSourceObjArray): PtrInt; -var n: PtrInt; - s: TObjectDynArray absolute aSourceObjArray; - d: TObjectDynArray absolute aDestObjArray; -begin - result := length(d); - n := length(s); - SetLength(d,result+n); - MoveFast(s[0],d[result],n*SizeOf(pointer)); - inc(result,n); -end; - -function ObjArrayAppend(var aDestObjArray, aSourceObjArray): PtrInt; -begin - result := ObjArrayAddFrom(aDestObjArray,aSourceObjArray); - TObjectDynArray(aSourceObjArray) := nil; // aSourceObjArray[] changed ownership -end; - -function ObjArrayAddCount(var aObjArray; aItem: TObject; var aObjArrayCount: integer): PtrInt; -var a: TObjectDynArray absolute aObjArray; -begin - result := aObjArrayCount; - if result=length(a) then - SetLength(a,NextGrow(result)); - a[result] := aItem; - inc(aObjArrayCount); -end; - -procedure ObjArrayAddOnce(var aObjArray; aItem: TObject); -var a: TObjectDynArray absolute aObjArray; - n: PtrInt; -begin - n := length(a); - if not PtrUIntScanExists(pointer(a),n,PtrUInt(aItem)) then begin - SetLength(a,n+1); - a[n] := aItem; - end; -end; - -function ObjArrayAddOnceFrom(var aDestObjArray; const aSourceObjArray): PtrInt; -var n, i: PtrInt; - s: TObjectDynArray absolute aSourceObjArray; - d: TObjectDynArray absolute aDestObjArray; -begin - result := length(d); - n := length(s); - if n=0 then - exit; - SetLength(d,result+n); - for i := 0 to n-1 do - if not PtrUIntScanExists(pointer(d),result,PtrUInt(s[i])) then begin - d[result] := s[i]; - inc(result); - end; - if result<>length(d) then - SetLength(d,result); -end; - -procedure ObjArraySetLength(var aObjArray; aLength: integer); -begin - SetLength(TObjectDynArray(aObjArray),aLength); -end; - -function ObjArrayFind(const aObjArray; aItem: TObject): PtrInt; -begin - result := PtrUIntScanIndex(pointer(aObjArray), - length(TObjectDynArray(aObjArray)),PtrUInt(aItem)); -end; - -function ObjArrayFind(const aObjArray; aCount: integer; aItem: TObject): PtrInt; -begin - result := PtrUIntScanIndex(pointer(aObjArray),aCount,PtrUInt(aItem)); -end; - -function ObjArrayCount(const aObjArray): integer; -var i: PtrInt; - a: TObjectDynArray absolute aObjArray; -begin - result := 0; - for i := 0 to length(a)-1 do - if a[i]<>nil then - inc(result); -end; - -procedure ObjArrayDelete(var aObjArray; aItemIndex: PtrInt; - aContinueOnException: boolean; aCount: PInteger); -var n: PtrInt; - a: TObjectDynArray absolute aObjArray; -begin - if aCount=nil then - n := length(a) else - n := aCount^; - if cardinal(aItemIndex)>=cardinal(n) then - exit; // out of range - if aContinueOnException then - try - a[aItemIndex].Free; - except - end else - a[aItemIndex].Free; - dec(n); - if n>aItemIndex then - MoveFast(a[aItemIndex+1],a[aItemIndex],(n-aItemIndex)*SizeOf(TObject)); - if aCount=nil then - SetLength(a,n) else - aCount^ := n; -end; - -function ObjArrayDelete(var aObjArray; aItem: TObject): PtrInt; -begin - result := PtrUIntScanIndex(pointer(aObjArray), - length(TObjectDynArray(aObjArray)),PtrUInt(aItem)); - if result>=0 then - ObjArrayDelete(aObjArray,result); -end; - -function ObjArrayDelete(var aObjArray; aCount: integer; aItem: TObject): PtrInt; overload; -begin - result := PtrUIntScanIndex(pointer(aObjArray),aCount,PtrUInt(aItem)); - if result>=0 then - ObjArrayDelete(aObjArray,result,false,@aCount); -end; - -procedure ObjArraySort(var aObjArray; Compare: TDynArraySortCompare); -begin - if @Compare<>nil then - QuickSortPtr(0,length(TObjectDynArray(aObjArray))-1,Compare,pointer(aObjArray)); -end; - -procedure RawObjectsClear(o: PObject; n: integer); -var obj: TObject; -begin - if n>0 then - repeat - obj := o^; - if obj<>nil then begin // inlined FreeAndNil(o^) - o^ := nil; - obj.Destroy; - end; - inc(o); - dec(n); - until n=0; -end; - -procedure ObjArrayClear(var aObjArray); -var a: TObjectDynArray absolute aObjArray; -begin - if a=nil then - exit; - RawObjectsClear(pointer(aObjArray),length(a)); - a := nil; -end; - -procedure ObjArrayClear(var aObjArray; aCount: integer); -var a: TObjectDynArray absolute aObjArray; - n: integer; -begin - n := length(a); - if n=0 then - exit; - if n>aCount then - aCount := n; - RawObjectsClear(pointer(aObjArray),aCount); - a := nil; -end; - -procedure ObjArrayClear(var aObjArray; aContinueOnException: boolean; - aCount: PInteger); -var n,i: PtrInt; - a: TObjectDynArray absolute aObjArray; -begin - if aCount=nil then - n := length(a) else begin - n := aCount^; - aCount^ := 0; - end; - if n=0 then - exit; - if aContinueOnException then - for i := 0 to n-1 do - try - a[i].Free; - except - end - else - RawObjectsClear(pointer(a),n); - a := nil; -end; - -function ObjArrayToJSON(const aObjArray; aOptions: TTextWriterWriteObjectOptions): RawUTF8; -var temp: TTextWriterStackBuffer; -begin - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - if woEnumSetsAsText in aOptions then - CustomOptions := CustomOptions+[twoEnumSetsAsTextInRecord]; - AddObjArrayJSON(aObjArray,aOptions); - SetText(result); - finally - Free; - end; -end; - - -procedure ObjArrayObjArrayClear(var aObjArray); -var i: PtrInt; - a: TPointerDynArray absolute aObjArray; -begin - if a<>nil then begin - for i := 0 to length(a)-1 do - ObjArrayClear(a[i]); - a := nil; - end; -end; - -procedure ObjArraysClear(const aObjArray: array of pointer); -var i: PtrInt; -begin - for i := 0 to high(aObjArray) do - if aObjArray[i]<>nil then - ObjArrayClear(aObjArray[i]^); -end; - -{$ifndef DELPHI5OROLDER} - -function InterfaceArrayAdd(var aInterfaceArray; const aItem: IUnknown): PtrInt; -var a: TInterfaceDynArray absolute aInterfaceArray; -begin - result := length(a); - SetLength(a,result+1); - a[result] := aItem; -end; - -procedure InterfaceArrayAddOnce(var aInterfaceArray; const aItem: IUnknown); -var a: TInterfaceDynArray absolute aInterfaceArray; - n: PtrInt; -begin - if PtrUIntScanExists(pointer(aInterfaceArray), - length(TInterfaceDynArray(aInterfaceArray)),PtrUInt(aItem)) then - exit; - n := length(a); - SetLength(a,n+1); - a[n] := aItem; -end; - -function InterfaceArrayFind(const aInterfaceArray; const aItem: IUnknown): PtrInt; -begin - result := PtrUIntScanIndex(pointer(aInterfaceArray), - length(TInterfaceDynArray(aInterfaceArray)),PtrUInt(aItem)); -end; - -procedure InterfaceArrayDelete(var aInterfaceArray; aItemIndex: PtrInt); -var n: PtrInt; - a: TInterfaceDynArray absolute aInterfaceArray; -begin - n := length(a); - if PtrUInt(aItemIndex)>=PtrUInt(n) then - exit; // out of range - a[aItemIndex] := nil; - dec(n); - if n>aItemIndex then - MoveFast(a[aItemIndex+1],a[aItemIndex],(n-aItemIndex)*SizeOf(IInterface)); - TPointerDynArray(aInterfaceArray)[n] := nil; // avoid GPF in SetLength() - SetLength(a,n); -end; - -function InterfaceArrayDelete(var aInterfaceArray; const aItem: IUnknown): PtrInt; -begin - result := InterfaceArrayFind(aInterfaceArray,aItem); - if result>=0 then - InterfaceArrayDelete(aInterfaceArray,result); -end; - -{$endif DELPHI5OROLDER} - - -{ TInterfacedObjectWithCustomCreate } - -constructor TInterfacedObjectWithCustomCreate.Create; -begin // nothing to do by default - overridden constructor may add custom code -end; - -procedure TInterfacedObjectWithCustomCreate.RefCountUpdate(Release: boolean); -begin - if Release then - _Release else - _AddRef; -end; - - -{ TAutoLock } - -type - /// used by TAutoLocker.ProtectMethod and TSynLocker.ProtectMethod - TAutoLock = class(TInterfacedObject) - protected - fLock: PSynLocker; - public - constructor Create(aLock: PSynLocker); - destructor Destroy; override; - end; - -constructor TAutoLock.Create(aLock: PSynLocker); -begin - fLock := aLock; - fLock^.Lock; -end; - -destructor TAutoLock.Destroy; -begin - fLock^.UnLock; -end; - - -{ TSynLocker } - -const - SYNLOCKER_VTYPENOCLEAR = [varEmpty..varDate,varBoolean, - varShortInt..varWord64,varUnknown]; - -procedure TSynLocker.Init; -begin - fLockCount := 0; - PaddingUsedCount := 0; - InitializeCriticalSection(fSection); - fInitialized := true; -end; - -procedure TSynLocker.Done; -var i: PtrInt; -begin - for i := 0 to PaddingUsedCount-1 do - if not(integer(Padding[i].VType) in SYNLOCKER_VTYPENOCLEAR) then - VarClear(variant(Padding[i])); - DeleteCriticalSection(fSection); - fInitialized := false; -end; - -procedure TSynLocker.DoneAndFreeMem; -begin - Done; - FreeMem(@self); -end; - -function TSynLocker.GetIsLocked: boolean; -begin - result := fLockCount <> 0; -end; - -procedure TSynLocker.Lock; -begin - EnterCriticalSection(fSection); - inc(fLockCount); -end; - -procedure TSynLocker.UnLock; -begin - dec(fLockCount); - LeaveCriticalSection(fSection); -end; - -function TSynLocker.TryLock: boolean; -begin - result := TryEnterCriticalSection(fSection){$ifdef LINUX}{$ifdef FPC}<>0{$endif}{$endif}; - if result then - inc(fLockCount); -end; - -function TSynLocker.TryLockMS(retryms: integer): boolean; -begin - repeat - result := TryLock; - if result or (retryms <= 0) then - break; - SleepHiRes(1); - dec(retryms); - until false; -end; - -function TSynLocker.ProtectMethod: IUnknown; -begin - result := TAutoLock.Create(@self); -end; - -{$ifndef NOVARIANTS} - -function TSynLocker.GetVariant(Index: integer): Variant; -begin - if cardinal(Index)=PaddingUsedCount then - PaddingUsedCount := Index+1; - variant(Padding[Index]) := Value; - finally - UnLock; - end; -end; - -function TSynLocker.GetInt64(Index: integer): Int64; -begin - if cardinal(Index)=cardinal(PaddingUsedCount)) or - not VariantToInt64(variant(Padding[index]),result) then - result := 0; -end; - -procedure TSynLocker.SetUnlockedInt64(Index: integer; const Value: Int64); -begin - if cardinal(Index)<=high(Padding) then begin - if Index>=PaddingUsedCount then - PaddingUsedCount := Index+1; - variant(Padding[Index]) := Value; - end; -end; - -function TSynLocker.GetPointer(Index: integer): Pointer; -begin - if cardinal(Index)=PaddingUsedCount then - PaddingUsedCount := Index+1; - with Padding[index] do begin - if not(integer(VType) in SYNLOCKER_VTYPENOCLEAR) then - VarClear(PVariant(@VType)^); - VType := varUnknown; - VUnknown := Value; - end; - finally - UnLock; - end; -end; - -function TSynLocker.GetUTF8(Index: integer): RawUTF8; -var wasString: Boolean; -begin - if cardinal(Index)=PaddingUsedCount then - PaddingUsedCount := Index+1; - RawUTF8ToVariant(Value,Padding[Index],varString); - finally - UnLock; - end; -end; - -function TSynLocker.LockedInt64Increment(Index: integer; const Increment: Int64): Int64; -begin - if cardinal(Index)<=high(Padding) then - try - Lock; - result := 0; - if Index nil then - SourceName := Source.ClassName else - SourceName := 'nil'; - raise EConvertError.CreateFmt('Cannot assign a %s to a %s', [SourceName, ClassName]); -end; - -procedure TSynPersistent.AssignTo(Dest: TSynPersistent); -begin - Dest.AssignError(Self); -end; - -procedure TSynPersistent.Assign(Source: TSynPersistent); -begin - if Source<>nil then - Source.AssignTo(Self) else - AssignError(nil); -end; - -{$ifdef FPC_OR_PUREPASCAL} -class function TSynPersistent.NewInstance: TObject; -begin // bypass vmtIntfTable and vmt^.vInitTable (FPC management operators) - {$ifdef FPC_X64MM} - result := _AllocMem(InstanceSize); - {$else} - GetMem(pointer(result),InstanceSize); // InstanceSize is inlined - FillCharFast(pointer(result)^,InstanceSize,0); - {$endif} - PPointer(result)^ := pointer(self); // store VMT -end; // no benefit of rewriting FreeInstance/CleanupInstance -{$else} -class function TSynPersistent.NewInstance: TObject; -asm - push eax // class - mov eax, [eax].vmtInstanceSize - push eax // size - call System.@GetMem - pop edx // size - push eax // self - mov cl, 0 - call dword ptr[FillcharFast] - pop eax // self - pop edx // class - mov [eax], edx // store VMT -end; // TSynPersistent has no interface -> bypass vmtIntfTable - -procedure TSynPersistent.FreeInstance; -asm - push ebx - mov ebx, eax -@loop: mov ebx, [ebx] // handle three VMT levels per iteration - mov edx, [ebx].vmtInitTable - mov ebx, [ebx].vmtParent - test edx, edx - jnz @clr - test ebx, ebx - jz @end - mov ebx, [ebx] - mov edx, [ebx].vmtInitTable - mov ebx, [ebx].vmtParent - test edx, edx - jnz @clr - test ebx, ebx - jz @end - mov ebx, [ebx] - mov edx, [ebx].vmtInitTable - mov ebx, [ebx].vmtParent - test edx, edx - jnz @clr - test ebx, ebx - jnz @loop -@end: pop ebx - jmp System.@FreeMem - // TSynPersistent has no TMonitor -> bypass TMonitor.Destroy(self) - // BTW, TMonitor.Destroy is private, so unreachable -@clr: push offset @loop // parent has never any vmtInitTable -> @loop - jmp RecordClear // eax=self edx=typeinfo -end; -{$endif FPC_OR_PUREPASCAL} - - -{ TSynPersistentLock } - -constructor TSynPersistentLock.Create; -begin - inherited Create; - fSafe := NewSynLocker; -end; - -destructor TSynPersistentLock.Destroy; -begin - inherited Destroy; - fSafe^.DoneAndFreeMem; -end; - - -{ TSynList } - -function TSynList.Add(item: pointer): integer; -begin - result := ObjArrayAddCount(fList,item,fCount); -end; - -procedure TSynList.Clear; -begin - fList := nil; - fCount := 0; -end; - -procedure TSynList.Delete(index: integer); -begin - PtrArrayDelete(fList,index,@fCount); - if (fCount>64) and (length(fList)>fCount*2) then - SetLength(fList,fCount); // reduce capacity when half list is void -end; - -function TSynList.Exists(item: pointer): boolean; -begin - result := PtrUIntScanExists(pointer(fList),fCount,PtrUInt(item)); -end; - -function TSynList.Get(index: Integer): pointer; -begin - if cardinal(index)=0 then - Delete(result); -end; - - -{ TSynObjectList } - -constructor TSynObjectList.Create(aOwnObjects: boolean); -begin - fOwnObjects := aOwnObjects; - inherited Create; -end; - -procedure TSynObjectList.Delete(index: integer); -begin - if cardinal(index)>=cardinal(fCount) then - exit; - if fOwnObjects then - TObject(fList[index]).Free; - inherited Delete(index); -end; - -procedure TSynObjectList.Clear; -begin - if fOwnObjects then - RawObjectsClear(pointer(fList),fCount); - inherited Clear; -end; - -procedure TSynObjectList.ClearFromLast; -var i: PtrInt; -begin - if fOwnObjects then - for i := fCount-1 downto 0 do - TObject(fList[i]).Free; - inherited Clear; -end; - -destructor TSynObjectList.Destroy; -begin - Clear; - inherited Destroy; -end; - - -{ TSynObjectListLocked } - -constructor TSynObjectListLocked.Create(AOwnsObjects: Boolean); -begin - inherited Create(AOwnsObjects); - fSafe.Init; -end; - -destructor TSynObjectListLocked.Destroy; -begin - inherited Destroy; - fSafe.Done; -end; - -function TSynObjectListLocked.Add(item: pointer): integer; -begin - Safe.Lock; - try - result := inherited Add(item); - finally - Safe.UnLock; - end; -end; - -function TSynObjectListLocked.Remove(item: pointer): integer; -begin - Safe.Lock; - try - result := inherited Remove(item); - finally - Safe.UnLock; - end; -end; - -function TSynObjectListLocked.Exists(item: pointer): boolean; -begin - Safe.Lock; - try - result := inherited Exists(item); - finally - Safe.UnLock; - end; -end; - -procedure TSynObjectListLocked.Clear; -begin - Safe.Lock; - try - inherited Clear; - finally - Safe.UnLock; - end; -end; - -procedure TSynObjectListLocked.ClearFromLast; -begin - Safe.Lock; - try - inherited ClearFromLast; - finally - Safe.UnLock; - end; -end; - - -{ ****************** text buffer and JSON functions and classes ********* } - -{ TTextWriter } - -procedure TTextWriter.Add(c: AnsiChar); -begin - if B>=BEnd then - FlushToStream; - inc(B); - B^ := c; -end; - -procedure TTextWriter.AddOnce(c: AnsiChar); -begin - if (B>=fTempBuf) and (B^=c) then - exit; // no duplicate - if B>=BEnd then - FlushToStream; - inc(B); - B^ := c; -end; - -procedure TTextWriter.Add(c1, c2: AnsiChar); -begin - if BEnd-B<=1 then - FlushToStream; - B[1] := c1; - B[2] := c2; - inc(B,2); -end; - -procedure TTextWriter.CancelLastChar; -begin - if B>=fTempBuf then // Add() methods append at B+1 - dec(B); -end; - -function TTextWriter.LastChar: AnsiChar; -begin - if B>=fTempBuf then - result := B^ else - result := #0; -end; - -procedure TTextWriter.CancelLastChar(aCharToCancel: AnsiChar); -begin - if (B>=fTempBuf) and (B^=aCharToCancel) then - dec(B); -end; - -function TTextWriter.PendingBytes: PtrUInt; -begin - result := B-fTempBuf+1; -end; - -procedure TTextWriter.CancelLastComma; -begin - if (B>=fTempBuf) and (B^=',') then - dec(B); -end; - -procedure TTextWriter.Add(Value: PtrInt); -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; - Len: PtrInt; -begin - if BEnd-B<=24 then - FlushToStream; - if PtrUInt(Value)<=high(SmallUInt32UTF8) then begin - P := pointer(SmallUInt32UTF8[Value]); - Len := PStrLen(P-_STRLEN)^; - end else begin - P := StrInt32(@tmp[23],value); - Len := @tmp[23]-P; - end; - MoveSmall(P,B+1,Len); - inc(B,Len); -end; - -{$ifndef CPU64} // Add(Value: PtrInt) already implemented it -procedure TTextWriter.Add(Value: Int64); -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; - Len: integer; -begin - if BEnd-B<=24 then - FlushToStream; - if Value<0 then begin - P := StrUInt64(@tmp[23],-Value)-1; - P^ := '-'; - Len := @tmp[23]-P; - end else - if Value<=high(SmallUInt32UTF8) then begin - P := pointer(SmallUInt32UTF8[Value]); - Len := PStrLen(P-_STRLEN)^; - end else begin - P := StrUInt64(@tmp[23],Value); - Len := @tmp[23]-P; - end; - MoveSmall(P,B+1,Len); - inc(B,Len); -end; -{$endif CPU64} - -procedure TTextWriter.AddCurr64(const Value: Int64); -var tmp: array[0..31] of AnsiChar; - P: PAnsiChar; - Len: PtrInt; -begin - if BEnd-B<=31 then - FlushToStream; - P := StrCurr64(@tmp[31],Value); - Len := @tmp[31]-P; - if Len>4 then - if P[Len-1]='0' then - if P[Len-2]='0' then - if P[Len-3]='0' then - if P[Len-4]='0' then - dec(Len,5) else - dec(Len,3) else - dec(Len,2) else - dec(Len); - MoveSmall(P,B+1,Len); - inc(B,Len); -end; - -procedure TTextWriter.AddCurr64(const Value: currency); -begin - AddCurr64(PInt64(@Value)^); -end; - -procedure TTextWriter.AddTimeLog(Value: PInt64); -begin - if BEnd-B<=31 then - FlushToStream; - inc(B,PTimeLogBits(Value)^.Text(B+1,true,'T')); -end; - -procedure TTextWriter.AddUnixTime(Value: PInt64); -begin // inlined UnixTimeToDateTime() - AddDateTime(Value^/SecsPerDay+UnixDateDelta); -end; - -procedure TTextWriter.AddUnixMSTime(Value: PInt64; WithMS: boolean); -begin // inlined UnixMSTimeToDateTime() - AddDateTime(Value^/MSecsPerDay+UnixDateDelta,WithMS); -end; - -procedure TTextWriter.AddDateTime(Value: PDateTime; FirstChar: AnsiChar; - QuoteChar: AnsiChar; WithMS: boolean); -begin - if (Value^=0) and (QuoteChar=#0) then - exit; - if BEnd-B<=26 then - FlushToStream; - inc(B); - if QuoteChar<>#0 then - B^ := QuoteChar else - dec(B); - if Value^<>0 then begin - inc(B); - if trunc(Value^)<>0 then - B := DateToIso8601PChar(Value^,B,true); - if frac(Value^)<>0 then - B := TimeToIso8601PChar(Value^,B,true,FirstChar,WithMS); - dec(B); - end; - if twoDateTimeWithZ in fCustomOptions then begin - inc(B); - B^ := 'Z'; - end; - if QuoteChar<>#0 then begin - inc(B); - B^ := QuoteChar; - end; -end; - -procedure TTextWriter.AddDateTime(const Value: TDateTime; WithMS: boolean); -begin - if Value=0 then - exit; - if BEnd-B<=24 then - FlushToStream; - inc(B); - if trunc(Value)<>0 then - B := DateToIso8601PChar(Value,B,true); - if frac(Value)<>0 then - B := TimeToIso8601PChar(Value,B,true,'T',WithMS); - if twoDateTimeWithZ in fCustomOptions then - B^ := 'Z' else - dec(B); -end; - -procedure TTextWriter.AddDateTimeMS(const Value: TDateTime; Expanded: boolean; - FirstTimeChar: AnsiChar; const TZD: RawUTF8); -var T: TSynSystemTime; -begin - if Value=0 then - exit; - T.FromDateTime(Value); - Add(DTMS_FMT[Expanded], [UInt4DigitsToShort(T.Year), - UInt2DigitsToShortFast(T.Month),UInt2DigitsToShortFast(T.Day),FirstTimeChar, - UInt2DigitsToShortFast(T.Hour),UInt2DigitsToShortFast(T.Minute), - UInt2DigitsToShortFast(T.Second),UInt3DigitsToShort(T.MilliSecond),TZD]); -end; - -procedure TTextWriter.AddU(Value: cardinal); -var tmp: array[0..23] of AnsiChar; - P: PAnsiChar; - Len: PtrInt; -begin - if BEnd-B<=24 then - FlushToStream; - if Value<=high(SmallUInt32UTF8) then begin - P := pointer(SmallUInt32UTF8[Value]); - Len := PStrLen(P-_STRLEN)^; - end else begin - P := StrUInt32(@tmp[23],Value); - Len := @tmp[23]-P; - end; - MoveSmall(P,B+1,Len); - inc(B,Len); -end; - -procedure TTextWriter.AddQ(Value: QWord); -var tmp: array[0..23] of AnsiChar; - V: Int64Rec absolute Value; - P: PAnsiChar; - Len: PtrInt; -begin - if BEnd-B<=32 then - FlushToStream; - if (V.Hi=0) and (V.Lo<=high(SmallUInt32UTF8)) then begin - P := pointer(SmallUInt32UTF8[V.Lo]); - Len := PStrLen(P-_STRLEN)^; - end else begin - P := StrUInt64(@tmp[23],Value); - Len := @tmp[23]-P; - end; - MoveSmall(P,B+1,Len); - inc(B,Len); -end; - -procedure TTextWriter.AddQHex(Value: QWord); -begin - AddBinToHexDisplayQuoted(@Value,SizeOf(Value)); -end; - -procedure TTextWriter.Add(Value: Extended; precision: integer; noexp: boolean); -var tmp: ShortString; -begin - AddShort(ExtendedToJSON(tmp,Value,precision,noexp)^); -end; - -procedure TTextWriter.AddDouble(Value: double; noexp: boolean); -var tmp: ShortString; -begin - AddShort(DoubleToJSON(tmp,Value,noexp)^); -end; - -procedure TTextWriter.AddSingle(Value: single; noexp: boolean); -var tmp: ShortString; -begin - AddShort(ExtendedToJSON(tmp,Value,SINGLE_PRECISION,noexp)^); -end; - -procedure TTextWriter.Add(Value: boolean); -var PS: PShortString; -begin - if Value then // normalize: boolean may not be in the expected [0,1] range - PS := @BOOL_STR[true] else - PS := @BOOL_STR[false]; - AddShort(PS^); -end; - -procedure TTextWriter.AddFloatStr(P: PUTF8Char); -begin - if StrLen(P)>127 then - exit; // clearly invalid input - if BEnd-B<=127 then - FlushToStream; - inc(B); - if P<>nil then - B := FloatStrCopy(P,B)-1 else - B^ := '0'; -end; - -procedure TTextWriter.Add({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} guid: TGUID); -begin - if BEnd-B<=36 then - FlushToStream; - GUIDToText(B+1,@guid); - inc(B,36); -end; - -procedure TTextWriter.AddCR; -begin - if BEnd-B<=1 then - FlushToStream; - PWord(B+1)^ := 13+10 shl 8; // CR + LF - inc(B,2); -end; - -procedure TTextWriter.AddCRAndIndent; -var ntabs: cardinal; -begin - if B^=#9 then - exit; // we most probably just added an indentation level - ntabs := fHumanReadableLevel; - if ntabs>=cardinal(fTempBufSize) then - exit; // avoid buffer overflow - if BEnd-B<=Integer(ntabs)+1 then - FlushToStream; - PWord(B+1)^ := 13+10 shl 8; // CR + LF - FillCharFast(B[3],ntabs,9); // #9=tab - inc(B,ntabs+2); -end; - -procedure TTextWriter.AddChars(aChar: AnsiChar; aCount: integer); -var n: integer; -begin - repeat - n := BEnd-B; - if aCount99 then - PCardinal(B+1)^ := $3030+ord(',')shl 16 else // '00,' if overflow - PCardinal(B+1)^ := TwoDigitLookupW[Value]+ord(',')shl 16; - inc(B,3); -end; - -procedure TTextWriter.Add4(Value: PtrUInt); -begin - if BEnd-B<=5 then - FlushToStream; - if Value>9999 then - PCardinal(B+1)^ := $30303030 else // '0000,' if overflow - YearToPChar(Value,B+1); - inc(B,5); - B^ := ','; -end; - -procedure TTextWriter.AddCurrentLogTime(LocalTime: boolean); -var time: TSynSystemTime; -begin - FromGlobalTime(LocalTime,time); - time.AddLogTime(self); -end; - -procedure TTextWriter.AddCurrentNCSALogTime(LocalTime: boolean); -var time: TSynSystemTime; -begin - FromGlobalTime(LocalTime,time); - if BEnd-B<=21 then - FlushToStream; - inc(B,time.ToNCSAText(B+1)); -end; - -function Value3Digits(V: PtrUInt; P: PUTF8Char; W: PWordArray): PtrUInt; - {$ifdef HASINLINE}inline;{$endif} -begin - result := V div 100; - PWord(P+1)^ := W[V-result*100]; - V := result; - result := result div 10; - P^ := AnsiChar(V-result*10+48); -end; - -procedure TTextWriter.AddMicroSec(MS: cardinal); -var W: PWordArray; -begin // in 00.000.000 TSynLog format - if BEnd-B<=17 then - FlushToStream; - B[3] := '.'; - B[7] := '.'; - inc(B); - W := @TwoDigitLookupW; - MS := Value3Digits(Value3Digits(MS,B+7,W),B+3,W); - if MS>99 then - MS := 99; - PWord(B)^:= W[MS]; - inc(B,9); -end; - -procedure TTextWriter.Add3(Value: PtrUInt); -var V: PtrUInt; -begin - if BEnd-B<=4 then - FlushToStream; - if Value>999 then - PCardinal(B+1)^ := $303030 else begin// '0000,' if overflow - V := Value div 10; - PCardinal(B+1)^ := TwoDigitLookupW[V]+(Value-V*10+48)shl 16; - end; - inc(B,4); - B^ := ','; -end; - -procedure TTextWriter.AddCSVInteger(const Integers: array of Integer); -var i: PtrInt; -begin - if length(Integers)=0 then - exit; - for i := 0 to high(Integers) do begin - Add(Integers[i]); - Add(','); - end; - CancelLastComma; -end; - -procedure TTextWriter.AddCSVDouble(const Doubles: array of double); -var i: PtrInt; -begin - if length(Doubles)=0 then - exit; - for i := 0 to high(Doubles) do begin - AddDouble(Doubles[i]); - Add(','); - end; - CancelLastComma; -end; - -procedure TTextWriter.AddCSVUTF8(const Values: array of RawUTF8); -var i: PtrInt; -begin - if length(Values)=0 then - exit; - for i := 0 to high(Values) do begin - Add('"'); - AddJSONEscape(pointer(Values[i])); - Add('"',','); - end; - CancelLastComma; -end; - -procedure TTextWriter.AddCSVConst(const Values: array of const); -var i: PtrInt; -begin - if length(Values)=0 then - exit; - for i := 0 to high(Values) do begin - AddJSONEscape(Values[i]); - Add(','); - end; - CancelLastComma; -end; - -procedure TTextWriter.Add(const Values: array of const); -var i: PtrInt; -begin - for i := 0 to high(Values) do - AddJSONEscape(Values[i]); -end; - -procedure TTextWriter.WriteObject(Value: TObject; Options: TTextWriterWriteObjectOptions); -var i: PtrInt; -begin - if Value<>nil then - if Value.InheritsFrom(Exception) then - Add('{"%":"%"}',[Value.ClassType,Exception(Value).Message]) else - if Value.InheritsFrom(TRawUTF8List) then - with TRawUTF8List(Value) do begin - self.Add('['); - for i := 0 to fCount-1 do begin - self.Add('"'); - self.AddJSONEscape(pointer(fValue[i])); - self.Add('"',','); - end; - self.CancelLastComma; - self.Add(']'); - exit; - end else - if Value.InheritsFrom(TStrings) then - with TStrings(Value) do begin - self.Add('['); - for i := 0 to Count-1 do begin - self.Add('"'); - {$ifdef UNICODE} - self.AddJSONEscapeW(pointer(Strings[i]),Length(Strings[i])); - {$else} - self.AddJSONEscapeAnsiString(Strings[i]); - {$endif} - self.Add('"',','); - end; - self.CancelLastComma; - self.Add(']'); - exit; - end else - if not(woFullExpand in Options) or - not(Value.InheritsFrom(TList) - {$ifndef LVCL} or Value.InheritsFrom(TCollection){$endif}) then - Value := nil; - if Value=nil then begin - AddShort('null'); - exit; - end; - Add('{'); - AddInstanceName(Value,':'); - Add('['); - if Value.InheritsFrom(TList) then - for i := 0 to TList(Value).Count-1 do - AddInstanceName(TList(Value).List[i],',') - {$ifndef LVCL} else - if Value.InheritsFrom(TCollection) then - for i := 0 to TCollection(Value).Count-1 do - AddInstanceName(TCollection(Value).Items[i],',') {$endif} ; - CancelLastComma; - Add(']','}'); -end; - -function TTextWriter.InternalJSONWriter: TTextWriter; -begin - if fInternalJSONWriter=nil then - fInternalJSONWriter := DefaultTextWriterSerializer.CreateOwnedStream else - fInternalJSONWriter.CancelAll; - result := fInternalJSONWriter; -end; - -procedure TTextWriter.AddJSONEscape(Source: TTextWriter); -begin - if Source.fTotalFileSize=0 then - AddJSONEscape(Source.fTempBuf,Source.B-Source.fTempBuf+1) else - AddJSONEscape(Pointer(Source.Text)); -end; - -procedure TTextWriter.AddNoJSONEscape(Source: TTextWriter); -begin - if Source.fTotalFileSize=0 then - AddNoJSONEscape(Source.fTempBuf,Source.B-Source.fTempBuf+1) else - AddNoJSONEscapeUTF8(Source.Text); -end; - -procedure TTextWriter.AddRawJSON(const json: RawJSON); -begin - if json='' then - AddShort('null') else - AddNoJSONEscape(pointer(json),length(json)); -end; - -procedure TTextWriter.WriteObjectAsString(Value: TObject; - Options: TTextWriterWriteObjectOptions); -begin - Add('"'); - InternalJSONWriter.WriteObject(Value,Options); - AddJSONEscape(fInternalJSONWriter); - Add('"'); -end; - -class procedure TTextWriter.RegisterCustomJSONSerializer(aTypeInfo: pointer; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); -begin - GlobalJSONCustomParsers.RegisterCallbacks(aTypeInfo,aReader,aWriter); -end; - -class procedure TTextWriter.UnRegisterCustomJSONSerializer(aTypeInfo: pointer); -begin - GlobalJSONCustomParsers.RegisterCallbacks(aTypeInfo,nil,nil); -end; - -class function TTextWriter.GetCustomJSONParser(var DynArray: TDynArray; - out CustomReader: TDynArrayJSONCustomReader; - out CustomWriter: TDynArrayJSONCustomWriter): boolean; -begin - result := DynArray.HasCustomJSONParser; // use var above since may set fParser - if result then - with GlobalJSONCustomParsers.fParser[DynArray.fParser] do begin - CustomReader := Reader; - CustomWriter := Writer; - end; -end; - -{$ifndef NOVARIANTS} -class procedure TTextWriter.RegisterCustomJSONSerializerForVariant( - aClass: TCustomVariantType; aReader: TDynArrayJSONCustomReader; - aWriter: TDynArrayJSONCustomWriter); -begin // here we register TCustomVariantTypeClass info instead of TypeInfo() - GlobalJSONCustomParsers.RegisterCallbacksVariant(aClass,aReader,aWriter); -end; - -class procedure TTextWriter.RegisterCustomJSONSerializerForVariantByType(aVarType: TVarType; - aReader: TDynArrayJSONCustomReader; aWriter: TDynArrayJSONCustomWriter); -var aClass: TCustomVariantType; -begin - if FindCustomVariantType(aVarType,aClass) then - RegisterCustomJSONSerializerForVariant(aClass,aReader,aWriter); -end; -{$endif NOVARIANTS} - -class function TTextWriter.RegisterCustomJSONSerializerFromText(aTypeInfo: pointer; - const aRTTIDefinition: RawUTF8): TJSONRecordAbstract; -begin - result := GlobalJSONCustomParsers.RegisterFromText(aTypeInfo,aRTTIDefinition); -end; - -class procedure TTextWriter.RegisterCustomJSONSerializerFromText( - const aTypeInfoTextDefinitionPairs: array of const); -var n,i: integer; - def: RawUTF8; -begin - n := length(aTypeInfoTextDefinitionPairs); - if (n=0) or (n and 1=1) then - exit; - n := n shr 1; - if n=0 then - exit; - for i := 0 to n-1 do - if (aTypeInfoTextDefinitionPairs[i*2].VType<>vtPointer) or - not VarRecToUTF8IsString(aTypeInfoTextDefinitionPairs[i*2+1],def) then - raise ESynException.Create('RegisterCustomJSONSerializerFromText[?]') else - GlobalJSONCustomParsers.RegisterFromText( - aTypeInfoTextDefinitionPairs[i*2].VPointer,def); -end; - -class function TTextWriter.RegisterCustomJSONSerializerSetOptions(aTypeInfo: pointer; - aOptions: TJSONCustomParserSerializationOptions; aAddIfNotExisting: boolean): boolean; -var ndx: integer; -begin - result := false; - if aTypeInfo=nil then - exit; - case PTypeKind(aTypeInfo)^ of - tkRecord{$ifdef FPC},tkObject{$endif}: - ndx := GlobalJSONCustomParsers.RecordSearch(aTypeInfo,aAddIfNotExisting); - tkDynArray: - ndx := GlobalJSONCustomParsers.DynArraySearch(aTypeInfo,nil,aAddIfNotExisting); - else - exit; - end; - if (ndx>=0) and - (GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser<>nil) then begin - GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser.Options := aOptions; - result := true; - end; -end; - -class function TTextWriter.RegisterCustomJSONSerializerSetOptions( - const aTypeInfo: array of pointer; aOptions: TJSONCustomParserSerializationOptions; - aAddIfNotExisting: boolean): boolean; -var i: integer; -begin - result := true; - for i := 0 to high(aTypeInfo) do - if not RegisterCustomJSONSerializerSetOptions(aTypeInfo[i],aOptions,aAddIfNotExisting) then - result := false; -end; - -class function TTextWriter.RegisterCustomJSONSerializerFindParser( - aTypeInfo: pointer; aAddIfNotExisting: boolean): TJSONRecordAbstract; -var ndx: integer; -begin - result := nil; - if aTypeInfo=nil then - exit; - case PTypeKind(aTypeInfo)^ of - tkRecord{$ifdef FPC},tkObject{$endif}: - ndx := GlobalJSONCustomParsers.RecordSearch(aTypeInfo,aAddIfNotExisting); - tkDynArray: - ndx := GlobalJSONCustomParsers.DynArraySearch(aTypeInfo,nil,aAddIfNotExisting); - else - exit; - end; - if ndx>=0 then - result := GlobalJSONCustomParsers.fParser[ndx].RecordCustomParser; -end; - -class procedure TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType( - aTypeInfo: pointer; const aTypeName: RawUTF8); -begin - JSONSerializerFromTextSimpleTypeAdd(aTypeName,aTypeInfo,0,0); -end; - -class procedure TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType( - const aTypeInfos: array of pointer); -var i: integer; -begin - for i := 0 to high(aTypeInfos) do - RegisterCustomJSONSerializerFromTextSimpleType(aTypeInfos[i],''); -end; - -class procedure TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType( - aTypeInfo: pointer; aDataSize, aFieldSize: integer); -begin - JSONSerializerFromTextSimpleTypeAdd('',aTypeInfo,aDataSize,aFieldSize); -end; - -class procedure TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType( - const aTypeInfoDataFieldSize: array of const); -var n,i: integer; - s1,s2: Int64; -begin - n := length(aTypeInfoDataFieldSize); - if n mod 3=0 then - for i := 0 to (n div 3)-1 do - if (aTypeInfoDataFieldSize[i*3].VType<>vtPointer) or - not VarRecToInt64(aTypeInfoDataFieldSize[i*3+1],s1) or - not VarRecToInt64(aTypeInfoDataFieldSize[i*3+2],s2) then - raise ESynException.CreateUTF8('RegisterCustomJSONSerializerFromTextBinaryType[%]',[i]) else - JSONSerializerFromTextSimpleTypeAdd('',aTypeInfoDataFieldSize[i*3].VPointer,s1,s2); -end; - -procedure TTextWriter.AddRecordJSON(const Rec; TypeInfo: pointer); -var customWriter: TDynArrayJSONCustomWriter; -begin - if (self=nil) or (@Rec=nil) or (TypeInfo=nil) or - not(PTypeKind(TypeInfo)^ in tkRecordTypes) then - raise ESynException.CreateUTF8('Invalid %.AddRecordJSON(%)',[self,TypeInfo]); - if GlobalJSONCustomParsers.RecordSearch(TypeInfo,customWriter,nil) then - customWriter(self,Rec) else - WrRecord(Rec,TypeInfo); -end; - -procedure TTextWriter.AddVoidRecordJSON(TypeInfo: pointer); -var tmp: TBytes; - info: PTypeInfo; -begin - info := GetTypeInfo(TypeInfo,tkRecordKinds); - if (self=nil) or (info=nil) then - raise ESynException.CreateUTF8('Invalid %.AddVoidRecordJSON(%)',[self,TypeInfo]); - SetLength(tmp,info^.recSize {$ifdef FPC}and $7FFFFFFF{$endif}); - AddRecordJSON(tmp[0],TypeInfo); -end; - -{$ifndef NOVARIANTS} -procedure TTextWriter.AddVariant(const Value: variant; Escape: TTextWriterKind); -var CustomVariantType: TCustomVariantType; - vt: cardinal; -begin - vt := TVarData(Value).VType; - with TVarData(Value) do - case vt of - varEmpty, - varNull: AddShort('null'); - varSmallint: Add(VSmallint); - varShortInt: Add(VShortInt); - varByte: AddU(VByte); - varWord: AddU(VWord); - varLongWord: AddU(VLongWord); - varInteger: Add(VInteger); - varInt64: Add(VInt64); - varWord64: AddQ(VInt64); - varSingle: AddSingle(VSingle); - varDouble: AddDouble(VDouble); - varDate: AddDateTime(@VDate,'T','"'); - varCurrency: AddCurr64(VInt64); - varBoolean: Add(VBoolean); // 'true'/'false' - varVariant: AddVariant(PVariant(VPointer)^,Escape); - varString: begin - if Escape=twJSONEscape then - Add('"'); - {$ifdef HASCODEPAGE} - AddAnyAnsiString(RawByteString(VString),Escape); - {$else} // VString is expected to be a RawUTF8 - Add(VString,length(RawUTF8(VString)),Escape); - {$endif} - if Escape=twJSONEscape then - Add('"'); - end; - varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}: begin - if Escape=twJSONEscape then - Add('"'); - AddW(VAny,0,Escape); - if Escape=twJSONEscape then - Add('"'); - end; - else - if vt=varVariant or varByRef then - AddVariant(PVariant(VPointer)^,Escape) else - if vt=varByRef or varString then begin - if Escape=twJSONEscape then - Add('"'); - {$ifdef HASCODEPAGE} - AddAnyAnsiString(PRawByteString(VAny)^,Escape); - {$else} // VString is expected to be a RawUTF8 - Add(PPointer(VAny)^,length(PRawUTF8(VAny)^),Escape); - {$endif} - if Escape=twJSONEscape then - Add('"'); - end else - if {$ifdef HASVARUSTRING}(vt=varByRef or varUString) or {$endif} - (vt=varByRef or varOleStr) then begin - if Escape=twJSONEscape then - Add('"'); - AddW(PPointer(VAny)^,0,Escape); - if Escape=twJSONEscape then - Add('"'); - end else - if FindCustomVariantType(vt,CustomVariantType) then - if CustomVariantType.InheritsFrom(TSynInvokeableVariantType) then - TSynInvokeableVariantType(CustomVariantType).ToJson(self,Value,Escape) else - GlobalJSONCustomParsers.VariantWrite(CustomVariantType,self,Value,Escape) else - raise ESynException.CreateUTF8('%.AddVariant VType=%',[self,vt]); - end; -end; -{$endif NOVARIANTS} - -procedure TTextWriter.AddDynArrayJSON(var aDynArray: TDynArrayHashed); -begin - AddDynArrayJson(PDynArray(@aDynArray)^); -end; - -procedure TTextWriter.AddDynArrayJSON(aTypeInfo: pointer; const aValue); -var DynArray: TDynArray; -begin - DynArray.Init(aTypeInfo,pointer(@aValue)^); - AddDynArrayJSON(DynArray); -end; - -procedure TTextWriter.AddDynArrayJSONAsString(aTypeInfo: pointer; var aValue); -begin - Add('"'); - InternalJSONWriter.AddDynArrayJSON(aTypeInfo,aValue); - AddJSONEscape(fInternalJSONWriter); - Add('"'); -end; - -procedure TTextWriter.AddObjArrayJSON(const aObjArray; aOptions: TTextWriterWriteObjectOptions); -var i: integer; - a: TObjectDynArray absolute aObjArray; -begin - Add('['); - for i := 0 to length(a)-1 do begin - WriteObject(a[i],aOptions); - Add(','); - end; - CancelLastComma; - Add(']'); -end; - -procedure TTextWriter.AddTypedJSON(aTypeInfo: pointer; const aValue); -var max, i: Integer; - PS: PShortString; - customWriter: TDynArrayJSONCustomWriter; - DynArray: TDynArray; - procedure AddPS; overload; - begin - Add('"'); - if twoTrimLeftEnumSets in fCustomOptions then - AddTrimLeftLowerCase(PS) else - AddShort(PS^); - Add('"'); - end; - procedure AddPS(bool: boolean); overload; - begin - AddPS; - Add(':'); - Add(bool); - end; -begin - case PTypeKind(aTypeInfo)^ of - tkClass: - WriteObject(TObject(aValue),[woFullExpand]); - tkEnumeration: - if twoEnumSetsAsBooleanInRecord in fCustomOptions then begin - PS := GetEnumName(aTypeInfo,byte(aValue)); - AddPS(true); - end else - if twoEnumSetsAsTextInRecord in fCustomOptions then begin - PS := GetEnumName(aTypeInfo,byte(aValue)); - AddPS; - end else - AddU(byte(aValue)); - tkSet: - if GetSetInfo(aTypeInfo,max,PS) then - if twoEnumSetsAsBooleanInRecord in fCustomOptions then begin - Add('{'); - for i := 0 to max do begin - AddPS(GetBitPtr(@aValue,i)); - Add(','); - inc(PByte(PS),PByte(PS)^+1); // next - end; - CancelLastComma; - Add('}'); - end else - if twoEnumSetsAsTextInRecord in fCustomOptions then begin - Add('['); - if (twoFullSetsAsStar in fCustomOptions) and - GetAllBits(cardinal(aValue),max+1) then - AddShort('"*"') else begin - for i := 0 to max do begin - if GetBitPtr(@aValue,i) then begin - AddPS; - Add(','); - end; - inc(PByte(PS),PByte(PS)^+1); // next - end; - CancelLastComma; - end; - Add(']'); - end else - if max<8 then - AddU(byte(aValue)) else - if max<16 then - AddU(word(aValue)) else - if max<32 then - AddU(cardinal(aValue)) else - Add(Int64(aValue)) - else AddShort('null'); - tkRecord{$ifdef FPC},tkObject{$endif}: // inlined AddRecordJSON() - if GlobalJSONCustomParsers.RecordSearch(aTypeInfo,customWriter,nil) then - customWriter(self,aValue) else - WrRecord(aValue,aTypeInfo); - tkDynArray: begin - DynArray.Init(aTypeInfo,(@aValue)^); - AddDynArrayJSON(DynArray); - end; -{$ifndef NOVARIANTS} - tkVariant: - AddVariant(variant(aValue),twJSONEscape); -{$endif} - else - AddShort('null'); - end; -end; - -function TTextWriter.AddJSONReformat(JSON: PUTF8Char; - Format: TTextWriterJSONFormat; EndOfObject: PUTF8Char): PUTF8Char; -var objEnd: AnsiChar; - Name,Value: PUTF8Char; - NameLen,ValueLen: integer; -begin - result := nil; - if JSON=nil then - exit; - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - case JSON^ of - '[': begin // array - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - if JSON^=']' then begin - Add('['); - inc(JSON); - end else begin - if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then - AddCRAndIndent; - inc(fHumanReadableLevel); - Add('['); - repeat - if JSON=nil then - exit; - if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then - AddCRAndIndent; - JSON := AddJSONReformat(JSON,Format,@objEnd); - if objEnd=']' then - break; - Add(objEnd); - until false; - dec(fHumanReadableLevel); - if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then - AddCRAndIndent; - end; - Add(']'); - end; - '{': begin // object - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - Add('{'); - inc(fHumanReadableLevel); - if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then - AddCRAndIndent; - if JSON^='}' then - repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else - repeat - Name := GetJSONPropName(JSON,@NameLen); - if Name=nil then - exit; - if (Format in [jsonUnquotedPropName,jsonUnquotedPropNameCompact]) and - JsonPropNameValid(Name) then - AddNoJSONEscape(Name,NameLen) else begin - Add('"'); - AddJSONEscape(Name); - Add('"'); - end; - if Format in [jsonCompact,jsonUnquotedPropNameCompact] then - Add(':') else - Add(':',' '); - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - JSON := AddJSONReformat(JSON,Format,@objEnd); - if objEnd='}' then - break; - Add(objEnd); - if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then - AddCRAndIndent; - until false; - dec(fHumanReadableLevel); - if not (Format in [jsonCompact,jsonUnquotedPropNameCompact]) then - AddCRAndIndent; - Add('}'); - end; - '"': begin // string - Value := JSON; - JSON := GotoEndOfJSONString(JSON); - if JSON^<>'"' then - exit; - inc(JSON); - AddNoJSONEscape(Value,JSON-Value); - end; - else begin // numeric or true/false/null - Value := GetJSONField(JSON,result,nil,EndOfObject,@ValueLen); // let wasString=nil - if Value=nil then - AddShort('null') else begin - while (ValueLen>0) and (Value[ValueLen-1]<=' ') do dec(ValueLen); - AddNoJSONEscape(Value,ValueLen); - end; - exit; - end; - end; - if JSON<>nil then begin - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - if EndOfObject<>nil then - EndOfObject^ := JSON^; - if JSON^<>#0 then - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - end; - result := JSON; -end; - -function TTextWriter.AddJSONToXML(JSON: PUTF8Char; ArrayName,EndOfObject: PUTF8Char): PUTF8Char; -var objEnd: AnsiChar; - Name,Value: PUTF8Char; - n,c: integer; -begin - result := nil; - if JSON=nil then - exit; - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - case JSON^ of - '[': begin - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - if JSON^=']' then - JSON := GotoNextNotSpace(JSON+1) else begin - n := 0; - repeat - if JSON=nil then - exit; - Add('<'); - if ArrayName=nil then - Add(n) else - AddXmlEscape(ArrayName); - Add('>'); - JSON := AddJSONToXML(JSON,nil,@objEnd); - Add('<','/'); - if ArrayName=nil then - Add(n) else - AddXmlEscape(ArrayName); - Add('>'); - inc(n); - until objEnd=']'; - end; - end; - '{': begin - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - if JSON^='}' then - repeat inc(JSON) until (JSON^=#0) or (JSON^>' ') else begin - repeat - Name := GetJSONPropName(JSON); - if Name=nil then - exit; - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - if JSON^='[' then // arrays are written as list of items, without root - JSON := AddJSONToXML(JSON,Name,@objEnd) else begin - Add('<'); - AddXmlEscape(Name); - Add('>'); - JSON := AddJSONToXML(JSON,Name,@objEnd); - Add('<','/'); - AddXmlEscape(Name); - Add('>'); - end; - until objEnd='}'; - end; - end; - else begin - Value := GetJSONField(JSON,result,nil,EndOfObject); // let wasString=nil - if Value=nil then - AddShort('null') else begin - c := PInteger(Value)^ and $ffffff; - if (c=JSON_BASE64_MAGIC) or (c=JSON_SQLDATE_MAGIC) then - inc(Value,3); // just ignore the Magic codepoint encoded as UTF-8 - AddXmlEscape(Value); - end; - exit; - end; - end; - if JSON<>nil then begin - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - if EndOfObject<>nil then - EndOfObject^ := JSON^; - if JSON^<>#0 then - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - end; - result := JSON; -end; - -procedure TTextWriter.AddDynArrayJSON(var aDynArray: TDynArray); -var i,n: PtrInt; - P: Pointer; - T: TDynArrayKind; - tmp: RawByteString; - customWriter: TDynArrayJSONCustomWriter; - customParser: TJSONRecordAbstract; - nested: TDynArray; - hr: boolean; -begin // code below must match TDynArray.LoadFromJSON - n := aDynArray.Count-1; - if n<0 then begin - Add('[',']'); - exit; - end; - if aDynArray.HasCustomJSONParser then - with GlobalJSONCustomParsers.fParser[aDynArray.fParser] do begin - customWriter := Writer; - customParser := RecordCustomParser; - end else begin - customWriter := nil; - customParser := nil; - end; - if Assigned(customWriter) then - T := djCustom else - T := aDynArray.GuessKnownType({exacttype=}true); - P := aDynArray.fValue^; - Add('['); - case T of - djNone: - if (aDynArray.ElemType<>nil) and - (PTypeKind(aDynArray.ElemType)^=tkDynArray) then begin - for i := 0 to n do begin - nested.Init(aDynArray.ElemType,P^); - AddDynArrayJSON(nested); - Add(','); - inc(PByte(P),aDynArray.ElemSize); - end; - end else begin - tmp := aDynArray.SaveTo; - WrBase64(pointer(tmp),length(tmp),{withMagic=}true); - end; - djCustom: begin - if customParser=nil then - hr := false else - hr := soWriteHumanReadable in customParser.Options; - if hr then - Inc(fHumanReadableLevel); - for i := 0 to n do begin - customWriter(self,P^); - Add(','); - inc(PByte(P),aDynArray.ElemSize); - end; - if hr then begin - dec(fHumanReadableLevel); - CancelLastComma; - AddCRAndIndent; - end; - end; - {$ifndef NOVARIANTS} - djVariant: - for i := 0 to n do begin - AddVariant(PVariantArray(P)^[i],twJSONEscape); - Add(','); - end; - {$endif} - djRawUTF8: - for i := 0 to n do begin - Add('"'); - AddJSONEscape(PPointerArray(P)^[i]); - Add('"',','); - end; - djRawByteString: - for i := 0 to n do begin - WrBase64(PPointerArray(P)^[i],Length(PRawByteStringArray(P)^[i]),{withMagic=}true); - Add(','); - end; - djInteger: - for i := 0 to n do begin - Add(PIntegerArray(P)^[i]); - Add(','); - end; - djInt64: - for i := 0 to n do begin - Add(PInt64Array(P)^[i]); - Add(','); - end; - djQWord: - for i := 0 to n do begin - AddQ(PQwordArray(P)^[i]); - Add(','); - end; - else // slightly less efficient for less-used types - if T in DJ_STRING then - for i := 0 to n do begin - Add('"'); - case T of - djTimeLog: AddTimeLog(@PInt64Array(P)^[i]); - djDateTime: AddDateTime(@PDoubleArray(P)^[i],'T',#0,false); - djDateTimeMS: AddDateTime(@PDoubleArray(P)^[i],'T',#0,true); - djWideString, djSynUnicode: AddJSONEscapeW(PPointerArray(P)^[i]); - djWinAnsi: AddAnyAnsiString(PRawByteStringArray(P)^[i],twJSONEscape,CODEPAGE_US); - djString: - {$ifdef UNICODE} - AddJSONEscapeW(PPointerArray(P)^[i]); - {$else} - AddAnyAnsiString(PRawByteStringArray(P)^[i],twJSONEscape,0); - {$endif} - djHash128: AddBinToHexDisplayLower(@PHash128Array(P)[i],SizeOf(THash128)); - djHash256: AddBinToHexDisplayLower(@PHash256Array(P)[i],SizeOf(THash256)); - djHash512: AddBinToHexDisplayLower(@PHash512Array(P)[i],SizeOf(THash512)); - djInterface: AddPointer(PPtrIntArray(P)^[i]); - else raise ESynException.CreateUTF8('AddDynArrayJSON unsupported %',[ToText(T)^]); - end; - Add('"',','); - end else - for i := 0 to n do begin - case T of - djBoolean: Add(PBooleanArray(P)^[i]); - djByte: AddU(PByteArray(P)^[i]); - djWord: AddU(PWordArray(P)^[i]); - djCardinal: AddU(PCardinalArray(P)^[i]); - djSingle: AddSingle(PSingleArray(P)^[i]); - djDouble: AddDouble(PDoubleArray(P)^[i]); - djCurrency: AddCurr64(PInt64Array(P)^[i]); - else raise ESynException.CreateUTF8('AddDynArrayJSON unsupported %',[ToText(T)^]); - end; - Add(','); - end; - end; - CancelLastComma; - Add(']'); -end; - -procedure TTextWriter.Add(const Format: RawUTF8; const Values: array of const; - Escape: TTextWriterKind; WriteObjectOptions: TTextWriterWriteObjectOptions); -var ValuesIndex: integer; - F: PUTF8Char; -label write; -begin // we put const char > #127 as #??? -> asiatic MBCS codepage OK - if Format='' then - exit; - if (Format='%') and (high(Values)>=0) then begin - Add(Values[0],Escape); - exit; - end; - ValuesIndex := 0; - F := pointer(Format); - repeat - repeat - case ord(F^) of - 0: exit; - ord('%'): break; - {$ifdef OLDTEXTWRITERFORMAT} - 164: AddCR; // currency sign -> add CR,LF - 167: if B^=',' then dec(B); // section sign to ignore next comma - ord('|'): begin - inc(F); // |% -> % - goto write; - end; - ord('$'),163,181: // dollar, pound, micro sign - break; // process command value - {$endif} - else begin -write: if B>=BEnd then - FlushToStream; - B[1] := F^; - inc(B); - end; - end; - inc(F); - until false; - // add next value as text - if ValuesIndex<=high(Values) then // missing value will display nothing - case ord(F^) of - ord('%'): - Add(Values[ValuesIndex],Escape,WriteObjectOptions); - {$ifdef OLDTEXTWRITERFORMAT} - ord('$'): with Values[ValuesIndex] do - if Vtype=vtInteger then Add2(VInteger); - 163: with Values[ValuesIndex] do // pound sign - if Vtype=vtInteger then Add4(VInteger); - 181: with Values[ValuesIndex] do // micro sign - if Vtype=vtInteger then Add3(VInteger); - {$endif} - end; - inc(F); - inc(ValuesIndex); - until false; -end; - -procedure TTextWriter.AddLine(const Text: shortstring); -var L: PtrInt; -begin - L := ord(Text[0]); - if BEnd-B<=L+2 then - FlushToStream; - inc(B); - if L>0 then begin - MoveFast(Text[1],B^,L); - inc(B,L); - end; - PWord(B)^ := 13+10 shl 8; // CR + LF - inc(B); -end; - -procedure TTextWriter.AddBinToHexDisplay(Bin: pointer; BinBytes: integer); -begin - if cardinal(BinBytes*2-1)>=cardinal(fTempBufSize) then - exit; - if BEnd-B<=BinBytes*2 then - FlushToStream; - BinToHexDisplay(Bin,PAnsiChar(B+1),BinBytes); - inc(B,BinBytes*2); -end; - -procedure TTextWriter.AddBinToHexDisplayLower(Bin: pointer; BinBytes: integer); -begin - if cardinal(BinBytes*2-1)>=cardinal(fTempBufSize) then - exit; - if BEnd-B<=BinBytes*2 then - FlushToStream; - BinToHexDisplayLower(Bin,PAnsiChar(B+1),BinBytes); - inc(B,BinBytes*2); -end; - -procedure TTextWriter.AddBinToHexDisplayQuoted(Bin: pointer; BinBytes: integer); -begin - if cardinal(BinBytes*2+2)>=cardinal(fTempBufSize) then - exit; - if BEnd-B<=BinBytes*2+2 then - FlushToStream; - B[1] := '"'; - BinToHexDisplayLower(Bin,PAnsiChar(B+2),BinBytes); - inc(B,BinBytes*2); - B[2] := '"'; - inc(B,2); -end; - -procedure TTextWriter.AddBinToHexDisplayMinChars(Bin: pointer; BinBytes: PtrInt); -begin - if (BinBytes<=0) or (cardinal(BinBytes*2-1)>=cardinal(fTempBufSize)) then - exit; - repeat // append hexa chars up to the last non zero byte - dec(BinBytes); - until (BinBytes=0) or (PByteArray(Bin)[BinBytes]<>0); - inc(BinBytes); - if BEnd-B<=BinBytes*2 then - FlushToStream; - BinToHexDisplayLower(Bin,PAnsiChar(B+1),BinBytes); - inc(B,BinBytes*2); -end; - -procedure TTextWriter.AddPointer(P: PtrUInt); -begin - AddBinToHexDisplayMinChars(@P,SizeOf(P)); -end; - -procedure TTextWriter.AddBinToHex(Bin: Pointer; BinBytes: integer); -var ChunkBytes: PtrInt; -begin - if BinBytes<=0 then - exit; - if B>=BEnd then - FlushToStream; - inc(B); - repeat - // guess biggest size to be added into buf^ at once - ChunkBytes := (BEnd-B) shr 1; // div 2, *2 -> two hexa chars per byte - if BinBytes special one below: - WriteToStream(fTempBuf,B-fTempBuf); - B := fTempBuf; - until false; - dec(B); // allow CancelLastChar -end; - -procedure TTextWriter.AddQuotedStr(Text: PUTF8Char; Quote: AnsiChar; - TextMaxLen: PtrInt); -var BMax: PUTF8Char; - c: AnsiChar; -begin - if TextMaxLen<=0 then - TextMaxLen := maxInt else - if TextMaxLen>5 then - dec(TextMaxLen,5); - BMax := BEnd-3; - if B>=BMax then begin - FlushToStream; - BMax := BEnd-3; - end; - inc(B); - B^ := Quote; - inc(B); - if Text<>nil then - repeat - if B0 then begin - c := Text^; - inc(Text); - if c=#0 then - break; - B^ := c; - inc(B); - if c<>Quote then - continue; - B^ := c; - inc(B); - end else begin - PCardinal(B)^ := ord('.')+ord('.')shl 8+ord('.')shl 16; - inc(B,3); - break; - end; - end else begin - FlushToStream; - BMax := BEnd-3; - end; - until false; - B^ := Quote; -end; - -const - HTML_ESC: array[hfAnyWhere..high(TTextWriterHTMLFormat)] of TSynAnsicharSet = ( - [#0,'&','"','<','>'],[#0,'&','<','>'],[#0,'&','"']); - -procedure TTextWriter.AddHtmlEscape(Text: PUTF8Char; Fmt: TTextWriterHTMLFormat); -var B: PUTF8Char; - esc: ^TSynAnsicharSet; -begin - if Text=nil then - exit; - if Fmt=hfNone then begin - AddNoJSONEscape(Text); - exit; - end; - esc := @HTML_ESC[Fmt]; - repeat - B := Text; - while not(Text^ in esc^) do - inc(Text); - AddNoJSONEscape(B,Text-B); - case Text^ of - #0: exit; - '<': AddShort('<'); - '>': AddShort('>'); - '&': AddShort('&'); - '"': AddShort('"'); - end; - inc(Text); - until Text^=#0; -end; - -procedure TTextWriter.AddHtmlEscape(Text: PUTF8Char; TextLen: PtrInt; - Fmt: TTextWriterHTMLFormat); -var B: PUTF8Char; - esc: ^TSynAnsicharSet; -begin - if (Text=nil) or (TextLen<=0) then - exit; - if Fmt=hfNone then begin - AddNoJSONEscape(Text,TextLen); - exit; - end; - inc(TextLen,PtrInt(Text)); // TextLen = final PtrInt(Text) - esc := @HTML_ESC[Fmt]; - repeat - B := Text; - while (PtrInt(Text)': AddShort('>'); - '&': AddShort('&'); - '"': AddShort('"'); - end; - inc(Text); - until false; -end; - -procedure TTextWriter.AddHtmlEscapeString(const Text: string; Fmt: TTextWriterHTMLFormat); -begin - AddHtmlEscape(pointer(StringToUTF8(Text)),Fmt); -end; - -procedure TTextWriter.AddHtmlEscapeUTF8(const Text: RawUTF8; Fmt: TTextWriterHTMLFormat); -begin - AddHtmlEscape(pointer(Text),length(Text),Fmt); -end; - -procedure TTextWriter.AddXmlEscape(Text: PUTF8Char); -const XML_ESCAPE: TSynByteSet = - [0..31,ord('<'),ord('>'),ord('&'),ord('"'),ord('''')]; -var i,beg: PtrInt; -begin - if Text=nil then - exit; - i := 0; - repeat - beg := i; - if not(ord(Text[i]) in XML_ESCAPE) then begin - repeat // it is faster to handle all not-escaped chars at once - inc(i); - until ord(Text[i]) in XML_ESCAPE; - AddNoJSONEscape(Text+beg,i-beg); - end; - repeat - case Text[i] of - #0: exit; - #1..#8,#11,#12,#14..#31: - ; // ignore invalid character - see http://www.w3.org/TR/xml/#NT-Char - #9,#10,#13: begin // characters below ' ', #9 e.g. -> // ' ' - AddShort('&#x'); - AddByteToHex(ord(Text[i])); - Add(';'); - end; - '<': AddShort('<'); - '>': AddShort('>'); - '&': AddShort('&'); - '"': AddShort('"'); - '''': AddShort('''); - else break; // should match XML_ESCAPE[] constant above - end; - inc(i); - until false; - until false; -end; - -procedure TTextWriter.AddReplace(Text: PUTF8Char; Orig,Replaced: AnsiChar); -begin - if Text<>nil then - while Text^<>#0 do begin - if Text^=Orig then - Add(Replaced) else - Add(Text^); - inc(Text); - end; -end; - -procedure TTextWriter.AddByteToHex(Value: byte); -begin - if BEnd-B<=1 then - FlushToStream; - PWord(B+1)^ := TwoDigitsHexWB[Value]; - inc(B,2); -end; - -procedure TTextWriter.AddInt18ToChars3(Value: cardinal); -begin - if BEnd-B<=3 then - FlushToStream; - PCardinal(B+1)^ := ((Value shr 12) and $3f)+ - ((Value shr 6) and $3f)shl 8+ - (Value and $3f)shl 16+$202020; - //assert(Chars3ToInt18(B+1)=Value); - inc(B,3); -end; - -function Int18ToChars3(Value: cardinal): RawUTF8; -begin - FastSetString(result,nil,3); - PCardinal(result)^ := ((Value shr 12) and $3f)+ - ((Value shr 6) and $3f)shl 8+ - (Value and $3f)shl 16+$202020; -end; - -procedure Int18ToChars3(Value: cardinal; var result: RawUTF8); -begin - FastSetString(result,nil,3); - PCardinal(result)^ := ((Value shr 12) and $3f)+ - ((Value shr 6) and $3f)shl 8+ - (Value and $3f)shl 16+$202020; -end; - -function Chars3ToInt18(P: pointer): cardinal; -begin - result := PCardinal(P)^-$202020; - result := ((result shr 16)and $3f)+ - ((result shr 8) and $3f)shl 6+ - (result and $3f)shl 12; -end; - -procedure TTextWriter.AddNoJSONEscape(P: Pointer); -begin - AddNoJSONEscape(P,StrLen(PUTF8Char(P))); -end; - -procedure TTextWriter.AddNoJSONEscape(P: Pointer; Len: PtrInt); -var i: PtrInt; -begin - if (P<>nil) and (Len>0) then begin - inc(B); // allow CancelLastChar - repeat - i := BEnd-B+1; // guess biggest size to be added into buf^ at once - if Len0 then begin - MoveFast(P^,B^,i); - inc(B,i); - end; - if i=Len then - break; - inc(PByte(P),i); - dec(Len,i); - // FlushInc writes B-buf+1 -> special one below: - WriteToStream(fTempBuf,B-fTempBuf); - B := fTempBuf; - until false; - dec(B); // allow CancelLastChar - end; -end; - -procedure TTextWriter.AddNoJSONEscapeUTF8(const text: RawByteString); -begin - AddNoJSONEscape(pointer(text),length(text)); -end; - -procedure TTextWriter.AddNoJSONEscapeW(WideChar: PWord; WideCharCount: integer); -var PEnd: PtrUInt; - BMax: PUTF8Char; -begin - if WideChar=nil then - exit; - BMax := BEnd-7; // ensure enough space for biggest Unicode glyph as UTF-8 - if WideCharCount=0 then - repeat - if B>=BMax then begin - FlushToStream; - BMax := BEnd-7; // B may have been resized -> recompute BMax - end; - if WideChar^=0 then - break; - if WideChar^<=126 then begin - B[1] := AnsiChar(ord(WideChar^)); - inc(WideChar); - inc(B); - end else - inc(B,UTF16CharToUtf8(B+1,WideChar)); - until false else begin - PEnd := PtrUInt(WideChar)+PtrUInt(WideCharCount)*SizeOf(WideChar^); - repeat - if B>=BMax then begin - FlushToStream; - BMax := BEnd-7; - end; - if WideChar^=0 then - break; - if WideChar^<=126 then begin - B[1] := AnsiChar(ord(WideChar^)); - inc(WideChar); - inc(B); - if PtrUInt(WideChar)nil then - case Escape of - twNone: AddNoJSONEscape(P,StrLen(P)); - twJSONEscape: AddJSONEscape(P); - twOnSameLine: AddOnSameLine(P); - end; -end; - -procedure TTextWriter.Add(P: PUTF8Char; Len: PtrInt; Escape: TTextWriterKind); -begin - if P<>nil then - case Escape of - twNone: AddNoJSONEscape(P,Len); - twJSONEscape: AddJSONEscape(P,Len); - twOnSameLine: AddOnSameLine(P,Len); - end; -end; - -procedure TTextWriter.AddW(P: PWord; Len: PtrInt; Escape: TTextWriterKind); -begin - if P<>nil then - case Escape of - twNone: AddNoJSONEscapeW(P,Len); - twJSONEscape: AddJSONEScapeW(P,Len); - twOnSameLine: AddOnSameLineW(P,Len); - end; -end; - -procedure TTextWriter.AddAnsiString(const s: AnsiString; Escape: TTextWriterKind); -begin - AddAnyAnsiBuffer(pointer(s),length(s),Escape,0); -end; - -procedure TTextWriter.AddAnyAnsiString(const s: RawByteString; - Escape: TTextWriterKind; CodePage: Integer); -var L: integer; -begin - L := length(s); - if L=0 then - exit; - if (L>2) and (PInteger(s)^ and $ffffff=JSON_BASE64_MAGIC) then begin - AddNoJSONEscape(pointer(s),L); // identified as a BLOB content - exit; - end; - if CodePage<0 then - {$ifdef HASCODEPAGE} - CodePage := PStrRec(PtrUInt(s)-STRRECSIZE)^.codePage; - {$else} - CodePage := 0; // TSynAnsiConvert.Engine(0)=CurrentAnsiConvert - {$endif} - AddAnyAnsiBuffer(pointer(s),L,Escape,CodePage); -end; - -procedure TTextWriter.AddAnyAnsiBuffer(P: PAnsiChar; Len: PtrInt; - Escape: TTextWriterKind; CodePage: Integer); -var B: PUTF8Char; -begin - if Len>0 then - case CodePage of - CP_UTF8: // direct write of RawUTF8 content - if Escape<>twJSONEscape then - Add(PUTF8Char(P),Len,Escape) else - Add(PUTF8Char(P),0,Escape); - CP_RAWBYTESTRING: - Add(PUTF8Char(P),Len,Escape); // direct write of RawByteString content - CP_UTF16: - AddW(PWord(P),0,Escape); // direct write of UTF-16 content - CP_SQLRAWBLOB: begin - AddNoJSONEscape(@PByteArray(@JSON_BASE64_MAGIC_QUOTE_VAR)[1],3); - WrBase64(P,Len,{withMagic=}false); - end; - else begin - // first handle trailing 7 bit ASCII chars, by quad - B := pointer(P); - if Len>=4 then - repeat - if PCardinal(P)^ and $80808080<>0 then - break; // break on first non ASCII quad - inc(P,4); - dec(Len,4); - until Len<4; - if (Len>0) and (P^<#128) then - repeat - inc(P); - dec(Len); - until (Len=0) or (P^>=#127); - if P<>pointer(B) then - Add(B,P-B,Escape); - if Len=0 then - exit; - // rely on explicit conversion for all remaining ASCII characters - TSynAnsiConvert.Engine(CodePage).InternalAppendUTF8(P,Len,self,Escape); - end; - end; -end; - -var - /// fast 256-byte branchless lookup table - // - 0 indicates no escape needed - // - 1 indicates #0 (end of string) - // - 2 should be escaped as \u00xx - // - b,t,n,f,r,\," as escaped character for #8,#9,#10,#12,#13,\," - JSON_ESCAPE: TNormTableByte; - -function NeedsJsonEscape(P: PUTF8Char; PLen: integer): boolean; -var tab: PNormTableByte; -begin - result := true; - tab := @JSON_ESCAPE; - if PLen>0 then - repeat - if tab[ord(P^)]<>0 then - exit; - inc(P); - dec(PLen); - until PLen=0; - result := false; -end; - -function NeedsJsonEscape(const Text: RawUTF8): boolean; -begin - result := NeedsJsonEscape(pointer(Text),length(Text)); -end; - -function NeedsJsonEscape(P: PUTF8Char): boolean; -var tab: PNormTableByte; - esc: byte; -begin - result := false; - if P=nil then - exit; - tab := @JSON_ESCAPE; - repeat - esc := tab[ord(P^)]; - if esc=0 then - inc(P) else - if esc=1 then - exit else // #0 reached - break; - until false; - result := true; -end; - -procedure TTextWriter.InternalAddFixedAnsi(Source: PAnsiChar; SourceChars: Cardinal; - AnsiToWide: PWordArray; Escape: TTextWriterKind); -var c: cardinal; - esc: byte; -begin - while SourceChars>0 do begin - c := byte(Source^); - if c<=$7F then begin - if c=0 then - exit; - if B>=BEnd then - FlushToStream; - case Escape of - twNone: begin - inc(B); - B^ := AnsiChar(c); - end; - twJSONEscape: begin - esc := JSON_ESCAPE[c]; - if esc=0 then begin // no escape needed - inc(B); - B^ := AnsiChar(c); - end else - if esc=1 then // #0 - exit else - if esc=2 then begin // #7 e.g. -> \u0007 - AddShort('\u00'); - AddByteToHex(c); - end else - Add('\',AnsiChar(esc)); // escaped as \ + b,t,n,f,r,\," - end; - twOnSameLine: begin - inc(B); - if c<32 then - B^ := ' ' else - B^ := AnsiChar(c); - end; - end - end else begin // no surrogate is expected in TSynAnsiFixedWidth charsets - if BEnd-B<=3 then - FlushToStream; - c := AnsiToWide[c]; // convert FixedAnsi char into Unicode char - if c>$7ff then begin - B[1] := AnsiChar($E0 or (c shr 12)); - B[2] := AnsiChar($80 or ((c shr 6) and $3F)); - B[3] := AnsiChar($80 or (c and $3F)); - inc(B,3); - end else begin - B[1] := AnsiChar($C0 or (c shr 6)); - B[2] := AnsiChar($80 or (c and $3F)); - inc(B,2); - end; - end; - dec(SourceChars); - inc(Source); - end; -end; - -procedure TTextWriter.AddOnSameLine(P: PUTF8Char); -begin - if P<>nil then - while P^<>#0 do begin - if B>=BEnd then - FlushToStream; - if P^<' ' then - B[1] := ' ' else - B[1] := P^; - inc(P); - inc(B); - end; -end; - -procedure TTextWriter.AddOnSameLine(P: PUTF8Char; Len: PtrInt); -var i: PtrInt; -begin - if P<>nil then - for i := 0 to Len-1 do begin - if B>=BEnd then - FlushToStream; - if P[i]<' ' then - B[1] := ' ' else - B[1] := P[i]; - inc(B); - end; -end; - -procedure TTextWriter.AddOnSameLineW(P: PWord; Len: PtrInt); -var PEnd: PtrUInt; -begin - if P=nil then exit; - if Len=0 then - PEnd := 0 else - PEnd := PtrUInt(P)+PtrUInt(Len)*SizeOf(WideChar); - while (Len=0) or (PtrUInt(P) UTF-8 encode - inc(B,UTF16CharToUtf8(B+1,P)); - end; - end; -end; - -procedure TTextWriter.AddJSONEscape(P: Pointer; Len: PtrInt); -var i,start: PtrInt; - {$ifdef CPUX86NOTPIC}tab: TNormTableByte absolute JSON_ESCAPE; - {$else}tab: PNormTableByte;{$endif} -label noesc; -begin - if P=nil then - exit; - if Len=0 then - dec(Len); // -1 = no end - i := 0; - {$ifndef CPUX86NOTPIC} tab := @JSON_ESCAPE; {$endif} - if tab[PByteArray(P)[i]]=0 then begin -noesc:start := i; - if Len<0 then - repeat // fastest loop is for AddJSONEscape(P,nil) - inc(i); - until tab[PByteArray(P)[i]]<>0 else - repeat - inc(i); - until (i>=Len) or (tab[PByteArray(P)[i]]<>0); - inc(PByte(P),start); - dec(i,start); - if Len>=0 then - dec(Len,start); - if BEnd-B<=i then - AddNoJSONEscape(P,i) else begin - MoveFast(P^,B[1],i); - inc(B,i); - end; - if (Len>=0) and (i>=Len) then - exit; - end; - repeat - if BEnd-B<=10 then - FlushToStream; - case tab[PByteArray(P)[i]] of - 0: goto noesc; - 1: exit; // #0 - 2: begin // characters below ' ', #7 e.g. -> // 'u0007' - PCardinal(B+1)^ := ord('\')+ord('u')shl 8+ord('0')shl 16+ord('0')shl 24; - inc(B,4); - PWord(B+1)^ := TwoDigitsHexWB[PByteArray(P)[i]]; - end; - else // escaped as \ + b,t,n,f,r,\," - PWord(B+1)^ := (integer(tab[PByteArray(P)[i]]) shl 8) or ord('\'); - end; - inc(i); - inc(B,2); - until (Len>=0) and (i>=Len); -end; - -procedure TTextWriter.AddJSONEscapeW(P: PWord; Len: PtrInt); -var i,c,s: PtrInt; - esc: byte; -begin - if P=nil then - exit; - if Len=0 then - Len := MaxInt; - i := 0; - while i0) then - break; - inc(i); - until i>=Len; - if i<>s then - AddNoJSONEscapeW(@PWordArray(P)[s],i-s); - if i>=Len then - exit; - c := PWordArray(P)[i]; - if c=0 then - exit; - esc := JSON_ESCAPE[c]; - if esc=1 then // #0 - exit else - if esc=2 then begin // characters below ' ', #7 e.g. -> \u0007 - AddShort('\u00'); - AddByteToHex(c); - end else - Add('\',AnsiChar(esc)); // escaped as \ + b,t,n,f,r,\," - inc(i); - end; -end; - -procedure TTextWriter.AddJSONEscape(const V: TVarRec); -begin - with V do - case VType of - vtPointer: AddShort('null'); - vtString, vtAnsiString,{$ifdef HASVARUSTRING}vtUnicodeString,{$endif} - vtPChar, vtChar, vtWideChar, vtWideString, vtClass: begin - Add('"'); - case VType of - vtString: if VString^[0]<>#0 then AddJSONEscape(@VString^[1],ord(VString^[0])); - vtAnsiString: AddJSONEscape(VAnsiString); - {$ifdef HASVARUSTRING} - vtUnicodeString: AddJSONEscapeW( - pointer(UnicodeString(VUnicodeString)),length(UnicodeString(VUnicodeString))); - {$endif} - vtPChar: AddJSONEscape(VPChar); - vtChar: AddJSONEscape(@VChar,1); - vtWideChar: AddJSONEscapeW(@VWideChar,1); - vtWideString: AddJSONEscapeW(VWideString); - vtClass: AddClassName(VClass); - end; - Add('"'); - end; - vtBoolean: Add(VBoolean); // 'true'/'false' - vtInteger: Add(VInteger); - vtInt64: Add(VInt64^); - {$ifdef FPC} - vtQWord: AddQ(V.VQWord^); - {$endif} - vtExtended: AddDouble(VExtended^); - vtCurrency: AddCurr64(VInt64^); - vtObject: WriteObject(VObject); - {$ifndef NOVARIANTS} - vtVariant: AddVariant(VVariant^,twJSONEscape); - {$endif} - end; -end; - -procedure TTextWriter.AddJSONString(const Text: RawUTF8); -begin - Add('"'); - AddJSONEscape(pointer(Text)); - Add('"'); -end; - -procedure TTextWriter.Add(const V: TVarRec; Escape: TTextWriterKind; - WriteObjectOptions: TTextWriterWriteObjectOptions); -begin - with V do - case VType of - vtInteger: Add(VInteger); - vtBoolean: if VBoolean then Add('1') else Add('0'); // normalize - vtChar: Add(@VChar,1,Escape); - vtExtended: AddDouble(VExtended^); - vtCurrency: AddCurr64(VInt64^); - vtInt64: Add(VInt64^); - {$ifdef FPC} - vtQWord: AddQ(VQWord^); - {$endif} - {$ifndef NOVARIANTS} - vtVariant: AddVariant(VVariant^,Escape); - {$endif} - vtString: if VString^[0]<>#0 then Add(@VString^[1],ord(VString^[0]),Escape); - vtInterface, - vtPointer: AddBinToHexDisplayMinChars(@VPointer,SizeOf(VPointer)); - vtPChar: Add(PUTF8Char(VPChar),Escape); - vtObject: WriteObject(VObject,WriteObjectOptions); - vtClass: AddClassName(VClass); - vtWideChar: AddW(@VWideChar,1,Escape); - vtPWideChar: - AddW(pointer(VPWideChar),StrLenW(VPWideChar),Escape); - vtAnsiString: - if VAnsiString<>nil then - Add(VAnsiString,length(RawUTF8(VAnsiString)),Escape); // expect RawUTF8 - vtWideString: - if VWideString<>nil then - AddW(VWideString,length(WideString(VWideString)),Escape); - {$ifdef HASVARUSTRING} - vtUnicodeString: - if VUnicodeString<>nil then // convert to UTF-8 - AddW(VUnicodeString,length(UnicodeString(VUnicodeString)),Escape); - {$endif} - end; -end; - -{$ifndef NOVARIANTS} -procedure TTextWriter.AddJSON(const Format: RawUTF8; const Args,Params: array of const); -var temp: variant; -begin - _JsonFmt(Format,Args,Params,JSON_OPTIONS_FAST,temp); - AddVariant(temp,twJSONEscape); -end; -{$endif} - -procedure TTextWriter.AddJSONArraysAsJSONObject(keys,values: PUTF8Char); -var k,v: PUTF8Char; -begin - if (keys=nil) or (keys^<>'[') or (values=nil) or (values^<>'[') then begin - AddShort('null'); - exit; - end; - inc(keys); // jump initial [ - inc(values); - Add('{'); - repeat - k := GotoEndJSONItem(keys); - v := GotoEndJSONItem(values); - if (k=nil) or (v=nil) then - break; // invalid JSON input - AddNoJSONEscape(keys,k-keys); - Add(':'); - AddNoJSONEscape(values,v-values); - Add(','); - if (k^<>',') or (v^<>',') then - break; // reached the end of the input JSON arrays - keys := k+1; - values := v+1; - until false; - CancelLastComma; - Add('}'); -end; - -procedure TTextWriter.AddJSONEscape(const NameValuePairs: array of const); -var a: integer; -procedure WriteValue; -begin - case VarRecAsChar(NameValuePairs[a]) of - ord('['): begin - Add('['); - while a'' then - {$ifdef UNICODE} - AddNoJSONEscapeW(pointer(s),0); - {$else} - AddAnsiString(s,twNone); - {$endif} -end; - -procedure TTextWriter.AddJSONEscapeString(const s: string); -begin - if s<>'' then - {$ifdef UNICODE} - AddJSONEscapeW(pointer(s),Length(s)); - {$else} - AddAnyAnsiString(s,twJSONEscape,0); - {$endif} -end; - -procedure TTextWriter.AddJSONEscapeAnsiString(const s: AnsiString); -begin - AddAnyAnsiString(s,twJSONEscape,0); -end; - -procedure TTextWriter.AddProp(PropName: PUTF8Char; PropNameLen: PtrInt); -begin - if PropNameLen=0 then - exit; // paranoid check - if BEnd-B<=PropNameLen+3 then - FlushToStream; - if twoForceJSONExtended in CustomOptions then begin - MoveSmall(PropName,B+1,PropNameLen); - inc(B,PropNameLen+1); - B^ := ':'; - end else begin - B[1] := '"'; - MoveSmall(PropName,B+2,PropNameLen); - inc(B,PropNameLen+2); - PWord(B)^ := ord('"')+ord(':')shl 8; - inc(B); - end; -end; - -procedure TTextWriter.AddPropName(const PropName: ShortString); -begin - AddProp(@PropName[1],ord(PropName[0])); -end; - -procedure TTextWriter.AddPropJSONString(const PropName: shortstring; const Text: RawUTF8); -begin - AddProp(@PropName[1],ord(PropName[0])); - AddJSONString(Text); - Add(','); -end; - -procedure TTextWriter.AddPropJSONInt64(const PropName: shortstring; Value: Int64); -begin - AddProp(@PropName[1],ord(PropName[0])); - Add(Value); - Add(','); -end; - -procedure TTextWriter.AddFieldName(const FieldName: RawUTF8); -begin - AddProp(Pointer(FieldName),length(FieldName)); -end; - -procedure TTextWriter.AddClassName(aClass: TClass); -begin - if aClass<>nil then - AddShort(PShortString(PPointer(PtrInt(PtrUInt(aClass))+vmtClassName)^)^); -end; - -procedure TTextWriter.AddInstanceName(Instance: TObject; SepChar: AnsiChar); -begin - Add('"'); - if Instance=nil then - AddShort('void') else - AddShort(PShortString(PPointer(PPtrInt(Instance)^+vmtClassName)^)^); - Add('('); - AddBinToHexDisplayMinChars(@Instance,SizeOf(Instance)); - Add(')','"'); - if SepChar<>#0 then - Add(SepChar); -end; - -procedure TTextWriter.AddInstancePointer(Instance: TObject; SepChar: AnsiChar; - IncludeUnitName, IncludePointer: boolean); -var info: PTypeInfo; -begin - if IncludeUnitName then begin - info := PPointer(PPtrInt(Instance)^+vmtTypeInfo)^; - if info<>nil then begin // avoid GPF if no RTTI for this class - AddShort(PShortString(@GetTypeInfo(info)^.UnitNameLen)^); - Add('.'); - end; - end; - AddShort(PShortString(PPointer(PPtrInt(Instance)^+vmtClassName)^)^); - if IncludePointer then begin - Add('('); - AddBinToHexDisplayMinChars(@Instance,SizeOf(Instance)); - Add(')'); - end; - if SepChar<>#0 then - Add(SepChar); -end; - -procedure TTextWriter.AddShort(const Text: ShortString); -var L: PtrInt; -begin - L := ord(Text[0]); - if L=0 then - exit; - if BEnd-B<=L then - FlushToStream; - MoveFast(Text[1],B[1],L); - inc(B,L); -end; - -procedure TTextWriter.AddQuotedStringAsJSON(const QuotedString: RawUTF8); -var L: integer; - P,B: PUTF8Char; - quote: AnsiChar; -begin - L := length(QuotedString); - if L>0 then begin - quote := QuotedString[1]; - if (quote in ['''','"']) and (QuotedString[L]=quote) then begin - Add('"'); - P := pointer(QuotedString); - inc(P); - repeat - B := P; - while P[0]<>quote do inc(P); - if P[1]<>quote then - break; // end quote - inc(P); - AddJSONEscape(B,P-B); - inc(P); // ignore double quote - until false; - if P-B<>0 then - AddJSONEscape(B,P-B); - Add('"'); - end else - AddNoJSONEscape(pointer(QuotedString),length(QuotedString)); - end; -end; - -procedure TTextWriter.AddTrimLeftLowerCase(Text: PShortString); -var P: PAnsiChar; - L: integer; -begin - L := length(Text^); - P := @Text^[1]; - while (L>0) and (P^ in ['a'..'z']) do begin - inc(P); - dec(L); - end; - if L=0 then - AddShort(Text^) else - AddNoJSONEscape(P,L); -end; - -procedure TTextWriter.AddTrimSpaces(const Text: RawUTF8); -begin - AddTrimSpaces(pointer(Text)); -end; - -procedure TTextWriter.AddTrimSpaces(P: PUTF8Char); -var c: AnsiChar; -begin - if P<>nil then - repeat - c := P^; - inc(P); - if c>' ' then - Add(c); - until c=#0; -end; - -procedure TTextWriter.AddString(const Text: RawUTF8); -var L: PtrInt; -begin - L := PtrInt(Text); - if L=0 then - exit; - L := PStrLen(L-_STRLEN)^; - if L0 then begin - if len0 then - if L*count>fTempBufSize then - for i := 1 to count do - AddString(Text) else begin - if BEnd-B<=L*count then - FlushToStream; - for i := 1 to count do begin - MoveFast(pointer(Text)^,B[1],L); - inc(B,L); - end; - end; -end; - -procedure TTextWriter.CancelAll; -begin - if self=nil then - exit; // avoid GPF - if fTotalFileSize<>0 then - fTotalFileSize := fStream.Seek(fInitialStreamPosition,soBeginning); - B := fTempBuf-1; -end; - -procedure TTextWriter.SetBuffer(aBuf: pointer; aBufSize: integer); -begin - if aBufSize<=16 then - raise ESynException.CreateUTF8('%.SetBuffer(size=%)',[self,aBufSize]); - if aBuf=nil then - GetMem(fTempBuf,aBufSize) else begin - fTempBuf := aBuf; - Include(fCustomOptions,twoBufferIsExternal); - end; - fTempBufSize := aBufSize; - B := fTempBuf-1; // Add() methods will append at B+1 - BEnd := fTempBuf+fTempBufSize-16; // -16 to avoid buffer overwrite/overread - if DefaultTextWriterTrimEnum then - Include(fCustomOptions,twoTrimLeftEnumSets); -end; - -constructor TTextWriter.Create(aStream: TStream; aBufSize: integer); -begin - SetStream(aStream); - if aBufSize<256 then - aBufSize := 256; - SetBuffer(nil,aBufSize); -end; - -constructor TTextWriter.Create(aStream: TStream; aBuf: pointer; aBufSize: integer); -begin - SetStream(aStream); - SetBuffer(aBuf,aBufSize); -end; - -constructor TTextWriter.CreateOwnedStream(aBufSize: integer); -begin - Create(TRawByteStringStream.Create,aBufSize); - Include(fCustomOptions,twoStreamIsOwned); -end; - -constructor TTextWriter.CreateOwnedStream(aBuf: pointer; aBufSize: integer); -begin - SetStream(TRawByteStringStream.Create); - SetBuffer(aBuf,aBufSize); - Include(fCustomOptions,twoStreamIsOwned); -end; - -constructor TTextWriter.CreateOwnedStream(var aStackBuf: TTextWriterStackBuffer; - aBufSize: integer); -begin - if aBufSize>SizeOf(aStackBuf) then // too small -> allocate on heap - CreateOwnedStream(aBufSize) else - CreateOwnedStream(@aStackBuf,SizeOf(aStackBuf)); -end; - -constructor TTextWriter.CreateOwnedFileStream(const aFileName: TFileName; - aBufSize: integer); -begin - DeleteFile(aFileName); - Create(TFileStream.Create(aFileName,fmCreate or fmShareDenyWrite),aBufSize); - Include(fCustomOptions,twoStreamIsOwned); -end; - -destructor TTextWriter.Destroy; -begin - if twoStreamIsOwned in fCustomOptions then - fStream.Free; - if not (twoBufferIsExternal in fCustomOptions) then - FreeMem(fTempBuf); - fInternalJSONWriter.Free; - inherited; -end; - -class procedure TTextWriter.SetDefaultEnumTrim(aShouldTrimEnumsAsText: boolean); -begin - DefaultTextWriterTrimEnum := aShouldTrimEnumsAsText; -end; - -procedure TTextWriter.SetStream(aStream: TStream); -begin - if fStream<>nil then - if twoStreamIsOwned in fCustomOptions then begin - FreeAndNil(fStream); - Exclude(fCustomOptions,twoStreamIsOwned); - end; - if aStream<>nil then begin - fStream := aStream; - fInitialStreamPosition := fStream.Seek(0,soCurrent); - fTotalFileSize := fInitialStreamPosition; - end; -end; - -procedure TTextWriter.FlushToStream; -var i: PtrInt; - s: PtrUInt; -begin - i := B-fTempBuf+1; - if i<=0 then - exit; - WriteToStream(fTempBuf,i); - if not (twoFlushToStreamNoAutoResize in fCustomOptions) then begin - s := fTotalFileSize-fInitialStreamPosition; - if (fTempBufSize<49152) and (s>PtrUInt(fTempBufSize)*4) then - s := fTempBufSize*2 else // tune small (stack-alloc?) buffer - if (fTempBufSize<1 shl 20) and (s>40 shl 20) then - s := 1 shl 20 else // 40MB -> 1MB buffer - s := 0; - if s>0 then begin - fTempBufSize := s; - if twoBufferIsExternal in fCustomOptions then // use heap, not stack - exclude(fCustomOptions,twoBufferIsExternal) else - FreeMem(fTempBuf); // with big content comes bigger buffer - GetMem(fTempBuf,fTempBufSize); - BEnd := fTempBuf+(fTempBufSize-16); - end; - end; - B := fTempBuf-1; -end; - -procedure TTextWriter.WriteToStream(data: pointer; len: PtrUInt); -begin - if Assigned(fOnFlushToStream) then - fOnFlushToStream(data,len); - fStream.WriteBuffer(data^,len); - inc(fTotalFileSize,len); -end; - -function TTextWriter.GetTextLength: PtrUInt; -begin - if self=nil then - result := 0 else - result := PtrUInt(B-fTempBuf+1)+fTotalFileSize-fInitialStreamPosition; -end; - -function TTextWriter.Text: RawUTF8; -begin - SetText(result); -end; - -procedure TTextWriter.ForceContent(const text: RawUTF8); -begin - CancelAll; - if (fInitialStreamPosition=0) and fStream.InheritsFrom(TRawByteStringStream) then - TRawByteStringStream(fStream).fDataString := text else - fStream.WriteBuffer(pointer(text)^,length(text)); - fTotalFileSize := fInitialStreamPosition+cardinal(length(text)); -end; - -procedure TTextWriter.FlushFinal; -begin - Include(fCustomOptions,twoFlushToStreamNoAutoResize); - FlushToStream; -end; - -procedure TTextWriter.SetText(var result: RawUTF8; reformat: TTextWriterJSONFormat); -var Len: cardinal; -begin - FlushFinal; - Len := fTotalFileSize-fInitialStreamPosition; - if Len=0 then - result := '' else - if fStream.InheritsFrom(TRawByteStringStream) then - with TRawByteStringStream(fStream) do - if fInitialStreamPosition=0 then begin - {$ifdef HASCODEPAGE} // FPC expects this - SetCodePage(fDataString,CP_UTF8,false); - {$endif} - result := fDataString; - fDataString := ''; - end else - FastSetString(result,PAnsiChar(pointer(DataString))+fInitialStreamPosition,Len) else - if fStream.InheritsFrom(TCustomMemoryStream) then - with TCustomMemoryStream(fStream) do - FastSetString(result,PAnsiChar(Memory)+fInitialStreamPosition,Len) else begin - FastSetString(result,nil,Len); - fStream.Seek(fInitialStreamPosition,soBeginning); - fStream.Read(pointer(result)^,Len); - end; - if reformat<>jsonCompact then begin // reformat using the very same instance - CancelAll; - AddJSONReformat(pointer(result),reformat,nil); - SetText(result); - end; -end; - -procedure TTextWriter.WrRecord(const Rec; TypeInfo: pointer); -var L: integer; - tmp: RawByteString; -begin - L := RecordSaveLength(Rec,TypeInfo); - SetString(tmp,nil,L); - if L<>0 then - RecordSave(Rec,pointer(tmp),TypeInfo); - WrBase64(pointer(tmp),L,{withMagic=}true); -end; - -procedure TTextWriter.WrBase64(P: PAnsiChar; Len: PtrUInt; withMagic: boolean); -var trailing, main, n: PtrUInt; -begin - if withMagic then - if Len<=0 then begin - AddShort('null'); // JSON null is better than "" for BLOBs - exit; - end else - AddNoJSONEscape(@JSON_BASE64_MAGIC_QUOTE_VAR,4); - if len>0 then begin - n := Len div 3; - trailing := Len-n*3; - dec(Len,trailing); - if BEnd-B>integer(n+1) shl 2 then begin - // will fit in available space in Buf -> fast in-buffer Base64 encoding - n := Base64EncodeMain(@B[1],P,Len); - inc(B,n*4); - inc(P,n*3); - end else begin - // bigger than available space in Buf -> do it per chunk - FlushToStream; - while Len>0 do begin // length(buf) const -> so is ((length(buf)-4)shr2 )*3 - n := ((fTempBufSize-4)shr 2)*3; - if Len0 then begin - Base64EncodeTrailing(@B[1],P,trailing); - inc(B,4); - end; - end; - if withMagic then - Add('"'); -end; - - -{ TTextWriterWithEcho } - -procedure TTextWriterWithEcho.AddEndOfLine(aLevel: TSynLogInfo=sllNone); -var i: integer; -begin - if BEnd-B<=1 then - FlushToStream; - if twoEndOfLineCRLF in fCustomOptions then begin - PWord(B+1)^ := 13+10 shl 8; // CR + LF - inc(B,2); - end else begin - B[1] := #10; // LF - inc(B); - end; - if fEchos<>nil then begin - fEchoStart := EchoFlush; - for i := length(fEchos)-1 downto 0 do // for MultiEventRemove() below - try - fEchos[i](self,aLevel,fEchoBuf); - except // remove callback in case of exception during echoing in user code - MultiEventRemove(fEchos,i); - end; - fEchoBuf := ''; - end; -end; - -procedure TTextWriterWithEcho.FlushToStream; -begin - if fEchos<>nil then begin - EchoFlush; - fEchoStart := 0; - end; - inherited FlushToStream; -end; - -procedure TTextWriterWithEcho.EchoAdd(const aEcho: TOnTextWriterEcho); -begin - if self<>nil then - if MultiEventAdd(fEchos,TMethod(aEcho)) then - if fEchos<>nil then - fEchoStart := B-fTempBuf+1; // ignore any previous buffer -end; - -procedure TTextWriterWithEcho.EchoRemove(const aEcho: TOnTextWriterEcho); -begin - if self<>nil then - MultiEventRemove(fEchos,TMethod(aEcho)); -end; - -function TTextWriterWithEcho.EchoFlush: PtrInt; -var L,LI: PtrInt; - P: PByteArray; -begin - result := B-fTempBuf+1; - L := result-fEchoStart; - P := @PByteArray(fTempBuf)[fEchoStart]; - while (L>0) and (P[L-1] in [10,13]) do // trim right CR/LF chars - dec(L); - LI := length(fEchoBuf); // fast append to fEchoBuf - SetLength(fEchoBuf,LI+L); - MoveFast(P^,PByteArray(fEchoBuf)[LI],L); -end; - -procedure TTextWriterWithEcho.EchoReset; -begin - fEchoBuf := ''; -end; - -function TTextWriterWithEcho.GetEndOfLineCRLF: boolean; -begin - result := twoEndOfLineCRLF in fCustomOptions; -end; - -procedure TTextWriterWithEcho.SetEndOfLineCRLF(aEndOfLineCRLF: boolean); -begin - if aEndOfLineCRLF then - include(fCustomOptions,twoEndOfLineCRLF) else - exclude(fCustomOptions,twoEndOfLineCRLF); -end; - - - -function JSONEncode(const NameValuePairs: array of const): RawUTF8; -var temp: TTextWriterStackBuffer; -begin - if high(NameValuePairs)<1 then - result := '{}' else // return void JSON object on error - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - AddJSONEscape(NameValuePairs); - SetText(result); - finally - Free - end; -end; - -{$ifndef NOVARIANTS} -function JSONEncode(const Format: RawUTF8; const Args,Params: array of const): RawUTF8; -var temp: TTextWriterStackBuffer; -begin - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - AddJSON(Format,Args,Params); - SetText(result); - finally - Free - end; -end; -{$endif} - -function JSONEncodeArrayDouble(const Values: array of double): RawUTF8; -var W: TTextWriter; - temp: TTextWriterStackBuffer; -begin - W := TTextWriter.CreateOwnedStream(temp); - try - W.Add('['); - W.AddCSVDouble(Values); - W.Add(']'); - W.SetText(result); - finally - W.Free - end; -end; - -function JSONEncodeArrayUTF8(const Values: array of RawUTF8): RawUTF8; -var W: TTextWriter; - temp: TTextWriterStackBuffer; -begin - W := TTextWriter.CreateOwnedStream(temp); - try - W.Add('['); - W.AddCSVUTF8(Values); - W.Add(']'); - W.SetText(result); - finally - W.Free - end; -end; - -function JSONEncodeArrayInteger(const Values: array of integer): RawUTF8; -var W: TTextWriter; - temp: TTextWriterStackBuffer; -begin - W := TTextWriter.CreateOwnedStream(temp); - try - W.Add('['); - W.AddCSVInteger(Values); - W.Add(']'); - W.SetText(result); - finally - W.Free - end; -end; - -function JSONEncodeArrayOfConst(const Values: array of const; - WithoutBraces: boolean): RawUTF8; -begin - JSONEncodeArrayOfConst(Values,WithoutBraces,result); -end; - -procedure JSONEncodeArrayOfConst(const Values: array of const; - WithoutBraces: boolean; var result: RawUTF8); -var temp: TTextWriterStackBuffer; -begin - if length(Values)=0 then - if WithoutBraces then - result := '' else - result := '[]' else - with DefaultTextWriterSerializer.CreateOwnedStream(temp) do - try - if not WithoutBraces then - Add('['); - AddCSVConst(Values); - if not WithoutBraces then - Add(']'); - SetText(result); - finally - Free - end; -end; - -procedure JSONEncodeNameSQLValue(const Name,SQLValue: RawUTF8; - var result: RawUTF8); -var temp: TTextWriterStackBuffer; -begin - if (SQLValue<>'') and (SQLValue[1] in ['''','"']) then - // unescape SQL quoted string value into a valid JSON string - with TTextWriter.CreateOwnedStream(temp) do - try - Add('{','"'); - AddNoJSONEscapeUTF8(Name); - Add('"',':'); - AddQuotedStringAsJSON(SQLValue); - Add('}'); - SetText(result); - finally - Free; - end else - // Value is a number or null/true/false - result := '{"'+Name+'":'+SQLValue+'}'; -end; - -{ TValuePUTF8Char } - -procedure TValuePUTF8Char.ToUTF8(var Text: RawUTF8); -begin - FastSetString(Text,Value,ValueLen); -end; - -function TValuePUTF8Char.ToUTF8: RawUTF8; -begin - FastSetString(result,Value,ValueLen); -end; - -function TValuePUTF8Char.ToString: string; -begin - UTF8DecodeToString(Value,ValueLen,result); -end; - -function TValuePUTF8Char.ToInteger: PtrInt; -begin - result := GetInteger(Value); -end; - -function TValuePUTF8Char.ToCardinal: PtrUInt; -begin - result := GetCardinal(Value); -end; - -function TValuePUTF8Char.Idem(const Text: RawUTF8): boolean; -begin - if length(Text)=ValueLen then - result := IdemPropNameUSameLen(pointer(Text),Value,ValueLen) else - result := false; -end; - -procedure JSONDecode(var JSON: RawUTF8; const Names: array of RawUTF8; - Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean); -begin - JSONDecode(UniqueRawUTF8(JSON),Names,Values,HandleValuesAsObjectOrArray); -end; - -procedure JSONDecode(var JSON: RawJSON; const Names: array of RawUTF8; - Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean); -begin - JSONDecode(UniqueRawUTF8(RawUTF8(JSON)),Names,Values,HandleValuesAsObjectOrArray); -end; - -function JSONDecode(P: PUTF8Char; const Names: array of RawUTF8; - Values: PValuePUTF8CharArray; HandleValuesAsObjectOrArray: Boolean): PUTF8Char; -var n, i: PtrInt; - namelen, valuelen: integer; - name, value: PUTF8Char; - EndOfObject: AnsiChar; -begin - result := nil; - if Values=nil then - exit; // avoid GPF - n := length(Names); - FillCharFast(Values[0],n*SizeOf(Values[0]),0); - dec(n); - if P=nil then - exit; - while P^<>'{' do - if P^=#0 then - exit else - inc(P); - inc(P); // jump { - repeat - name := GetJSONPropName(P,@namelen); - if name=nil then - exit; // invalid JSON content - value := GetJSONFieldOrObjectOrArray(P,nil,@EndOfObject,HandleValuesAsObjectOrArray,true,@valuelen); - if not(EndOfObject in [',','}']) then - exit; // invalid item separator - for i := 0 to n do - if (Values[i].Value=nil) and IdemPropNameU(Names[i],name,namelen) then begin - Values[i].Value := value; - Values[i].ValueLen := valuelen; - break; - end; - until (P=nil) or (EndOfObject='}'); - if P=nil then // result=nil indicates failure -> points to #0 for end of text - result := @NULCHAR else - result := P; -end; - -function JSONDecode(var JSON: RawUTF8; const aName: RawUTF8; - wasString: PBoolean; HandleValuesAsObjectOrArray: Boolean): RawUTF8; -var P, Name, Value: PUTF8Char; - NameLen, ValueLen: integer; - EndOfObject: AnsiChar; -begin - result := ''; - P := pointer(JSON); - if P=nil then - exit; - while P^<>'{' do - if P^=#0 then - exit else - inc(P); - inc(P); // jump { - repeat - Name := GetJSONPropName(P,@NameLen); - if Name=nil then - exit; // invalid JSON content - Value := GetJSONFieldOrObjectOrArray( - P,wasString,@EndOfObject,HandleValuesAsObjectOrArray,true,@ValueLen); - if not(EndOfObject in [',','}']) then - exit; // invalid item separator - if IdemPropNameU(aName,Name,NameLen) then begin - FastSetString(result,Value,ValueLen); - exit; - end; - until (P=nil) or (EndOfObject='}'); -end; - -function JSONDecode(P: PUTF8Char; out Values: TNameValuePUTF8CharDynArray; - HandleValuesAsObjectOrArray: Boolean): PUTF8Char; -var n: PtrInt; - field: TNameValuePUTF8Char; - EndOfObject: AnsiChar; -begin - {$ifdef FPC} - Values := nil; - {$endif} - result := nil; - n := 0; - if P<>nil then begin - while P^<>'{' do - if P^=#0 then - exit else - inc(P); - inc(P); // jump { - repeat - field.Name := GetJSONPropName(P,@field.NameLen); - if field.Name=nil then - exit; // invalid JSON content - field.Value := GetJSONFieldOrObjectOrArray(P,nil,@EndOfObject, - HandleValuesAsObjectOrArray,true,@field.ValueLen); - if not(EndOfObject in [',','}']) then - exit; // invalid item separator - if n=length(Values) then - SetLength(Values,n+32); - Values[n] := field; - inc(n); - until (P=nil) or (EndOfObject='}'); - end; - SetLength(Values,n); - if P=nil then // result=nil indicates failure -> points to #0 for end of text - result := @NULCHAR else - result := P; -end; - -function JSONRetrieveStringField(P: PUTF8Char; out Field: PUTF8Char; - out FieldLen: integer; ExpectNameField: boolean): PUTF8Char; -begin - result := nil; - // retrieve string field - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - if P^<>'"' then exit; - Field := P+1; - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; // here P^ should be '"' - FieldLen := P-Field; - // check valid JSON delimiter - repeat inc(P) until (P^>' ') or (P^=#0); - if ExpectNameField then begin - if P^<>':' then - exit; // invalid name field - end else - if not (P^ in ['}',',']) then - exit; // invalid value field - result := P; // return either ':' for name field, either '}',',' for value -end; - -// decode a JSON field into an UTF-8 encoded buffer, stored inplace of input buffer -function GetJSONField(P: PUTF8Char; out PDest: PUTF8Char; - wasString: PBoolean; EndOfObject: PUTF8Char; Len: PInteger): PUTF8Char; -var D: PUTF8Char; - c4,surrogate,j: integer; - c: AnsiChar; - b: byte; - jsonset: PJsonCharSet; - {$ifdef CPUX86NOTPIC} tab: TNormTableByte absolute ConvertHexToBin; - {$else} tab: PNormTableByte; {$endif} -label slash,num,lit; -begin // see http://www.ietf.org/rfc/rfc4627.txt - if wasString<>nil then - wasString^ := false; // not a string by default - if Len<>nil then - Len^ := 0; // avoid buffer overflow on parsing error - PDest := nil; // PDest=nil indicates parsing error (e.g. unexpected #0 end) - result := nil; - if P=nil then exit; - if P^<=' ' then repeat inc(P); if P^=#0 then exit; until P^>' '; - case P^ of - '"': begin // " -> unescape P^ into D^ - if wasString<>nil then - wasString^ := true; - inc(P); - result := P; - D := P; - repeat - c := P^; - if c=#0 then exit else - if c='"' then break else - if c='\' then goto slash; - inc(P); - D^ := c; - inc(D); - continue; -slash:inc(P); // unescape JSON string - c := P^; - if (c='"') or (c='\') then begin -lit: inc(P); - D^ := c; // most common case - inc(D); - continue; - end else - if c=#0 then - exit else // to avoid potential buffer overflow issue on \#0 - if c='b' then - c := #8 else - if c='t' then - c := #9 else - if c='n' then - c := #10 else - if c='f' then - c := #12 else - if c='r' then - c := #13 else - if c='u' then begin - // inlined decoding of '\u0123' UTF-16 codepoint(s) into UTF-8 - {$ifndef CPUX86NOTPIC}tab := @ConvertHexToBin;{$endif} - c4 := tab[ord(P[1])]; - if c4<=15 then begin - b := tab[ord(P[2])]; - if b<=15 then begin - c4 := c4 shl 4; - c4 := c4 or b; - b := tab[ord(P[3])]; - if b<=15 then begin - c4 := c4 shl 4; - c4 := c4 or b; - b := tab[ord(P[4])]; - if b<=15 then begin - c4 := c4 shl 4; - c4 := c4 or b; - case c4 of - 0: begin - D^ := '?'; // \u0000 is an invalid value - inc(D); - end; - 1..$7f: begin - D^ := AnsiChar(c4); - inc(D); - end; - $80..$7ff: begin - D[0] := AnsiChar($C0 or (c4 shr 6)); - D[1] := AnsiChar($80 or (c4 and $3F)); - inc(D,2); - end; - UTF16_HISURROGATE_MIN..UTF16_LOSURROGATE_MAX: - if PWord(P+5)^=ord('\')+ord('u') shl 8 then begin - inc(P,6); // optimistic conversion (no check) - surrogate := (ConvertHexToBin[ord(P[1])] shl 12)+ - (ConvertHexToBin[ord(P[2])] shl 8)+ - (ConvertHexToBin[ord(P[3])] shl 4)+ - ConvertHexToBin[ord(P[4])]; - case c4 of // inlined UTF16CharToUtf8() - UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX: - c4 := ((c4-$D7C0)shl 10)+(surrogate xor UTF16_LOSURROGATE_MIN); - UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX: - c4 := ((surrogate-$D7C0)shl 10)+(c4 xor UTF16_LOSURROGATE_MIN); - end; - case c4 of - 0..$7ff: b := 2; - $800..$ffff: b := 3; - $10000..$1FFFFF: b := 4; - $200000..$3FFFFFF: b := 5; - else b := 6; - end; - for j := b-1 downto 1 do begin - D[j] := AnsiChar((c4 and $3f)+$80); - c4 := c4 shr 6; - end; - D^ := AnsiChar(Byte(c4) or UTF8_FIRSTBYTE[b]); - inc(D,b); - end else begin - D^ := '?'; // unexpected surrogate without its pair - inc(D); - end; - else begin - D[0] := AnsiChar($E0 or (c4 shr 12)); - D[1] := AnsiChar($80 or ((c4 shr 6) and $3F)); - D[2] := AnsiChar($80 or (c4 and $3F)); - inc(D,3); - end; - end; - inc(P,5); - continue; - end; - end; - end; - end; - c := '?'; // bad formated hexa number -> '?0123' - end; - goto lit; - until false; - // here P^='"' - D^ := #0; // make zero-terminated - if Len<>nil then - Len^ := D-result; - inc(P); - if P^=#0 then - exit; - end; - '0': - if P[1] in ['0'..'9'] then // 0123 excluded by JSON! - exit else // leave PDest=nil for unexpected end - goto num;// may be 0.123 - '-','1'..'9': begin // numerical field: all chars before end of field -num:result := P; - jsonset := @JSON_CHARS; - repeat - if not (jcDigitFloatChar in jsonset[P^]) then - break; - inc(P); - until false; - if P^=#0 then - exit; - if Len<>nil then - Len^ := P-result; - if P^<=' ' then begin - P^ := #0; // force numerical field with no trailing ' ' - inc(P); - end; - end; - 'n': - if (PInteger(P)^=NULL_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin - result := nil; // null -> returns nil and wasString=false - if Len<>nil then - Len^ := 0; // when result is converted to string - inc(P,4); - end else - exit; - 'f': - if (PInteger(P+1)^=FALSE_LOW2) and (jcEndOfJSONValueField in JSON_CHARS[P[5]]) then begin - result := P; // false -> returns 'false' and wasString=false - if Len<>nil then - Len^ := 5; - inc(P,5); - end else - exit; - 't': - if (PInteger(P)^=TRUE_LOW) and (jcEndOfJSONValueField in JSON_CHARS[P[4]]) then begin - result := P; // true -> returns 'true' and wasString=false - if Len<>nil then - Len^ := 4; - inc(P,4); - end else - exit; - else - exit; // PDest=nil to indicate error - end; - jsonset := @JSON_CHARS; - while not (jcEndOfJSONField in jsonset[P^]) do begin - if P^=#0 then - exit; // leave PDest=nil for unexpected end - inc(P); - end; - if EndOfObject<>nil then - EndOfObject^ := P^; - P^ := #0; // make zero-terminated - PDest := @P[1]; - if P[1]=#0 then - PDest := nil; -end; - -function GetJSONPropName(var P: PUTF8Char; Len: PInteger): PUTF8Char; -var Name: PUTF8Char; - wasString: boolean; - c, EndOfObject: AnsiChar; - tab: PJsonCharSet; -begin // should match GotoNextJSONObjectOrArray() and JsonPropNameValid() - result := nil; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - Name := P; // put here to please some versions of Delphi compiler - c := P^; - if c='"' then begin - Name := GetJSONField(P,P,@wasString,@EndOfObject,Len); - if (Name=nil) or not wasString or (EndOfObject<>':') then - exit; - end else - if c = '''' then begin // single quotes won't handle nested quote character - inc(P); - Name := P; - while P^<>'''' do - if P^<' ' then - exit else - inc(P); - if Len<>nil then - Len^ := P-Name; - P^ := #0; - repeat inc(P) until (P^>' ') or (P^=#0); - if P^<>':' then - exit; - inc(P); - end else begin // e.g. '{age:{$gt:18}}' - tab := @JSON_CHARS; - if not (jcJsonIdentifierFirstChar in tab[c]) then - exit; - repeat - inc(P); - until not (jcJsonIdentifier in tab[P^]); - if Len<>nil then - Len^ := P-Name; - if (P^<=' ') and (P^<>#0) then begin - P^ := #0; - inc(P); - end; - while (P^<=' ') and (P^<>#0) do inc(P); - if not (P^ in [':','=']) then // allow both age:18 and age=18 pairs - exit; - P^ := #0; - inc(P); - end; - result := Name; -end; - -procedure GetJSONPropName(var P: PUTF8Char; out PropName: shortstring); -var Name: PAnsiChar; - c: AnsiChar; - tab: PJsonCharSet; -begin // match GotoNextJSONObjectOrArray() and overloaded GetJSONPropName() - PropName[0] := #0; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - Name := pointer(P); - c := P^; - if c='"' then begin - inc(Name); - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; - SetString(PropName,Name,P-Name); // note: won't unescape JSON strings - repeat inc(P) until (P^>' ') or (P^=#0); - if P^<>':' then begin - PropName[0] := #0; - exit; - end; - inc(P); - end else - if c='''' then begin // single quotes won't handle nested quote character - inc(P); - inc(Name); - while P^<>'''' do - if P^<' ' then - exit else - inc(P); - SetString(PropName,Name,P-Name); - repeat inc(P) until (P^>' ') or (P^=#0); - if P^<>':' then begin - PropName[0] := #0; - exit; - end; - inc(P); - end else begin // e.g. '{age:{$gt:18}}' - tab := @JSON_CHARS; - if not (jcJsonIdentifierFirstChar in tab[c]) then - exit; - repeat - inc(P); - until not (jcJsonIdentifier in tab[P^]); - SetString(PropName,Name,P-Name); - while (P^<=' ') and (P^<>#0) do inc(P); - if not (P^ in [':','=']) then begin // allow both age:18 and age=18 pairs - PropName[0] := #0; - exit; - end; - inc(P); - end; -end; - -function GotoNextJSONPropName(P: PUTF8Char): PUTF8Char; -var c: AnsiChar; - tab: PJsonCharSet; -label s; -begin // should match GotoNextJSONObjectOrArray() - while (P^<=' ') and (P^<>#0) do inc(P); - result := nil; - if P=nil then - exit; - c := P^; - if c='"' then begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; -s: repeat inc(P) until (P^>' ') or (P^=#0); - if P^<>':' then - exit; - end else - if c='''' then begin // single quotes won't handle nested quote character - inc(P); - while P^<>'''' do - if P^<' ' then - exit else - inc(P); - goto s; - end else begin // e.g. '{age:{$gt:18}}' - tab := @JSON_CHARS; - if not (jcJsonIdentifierFirstChar in tab[c]) then - exit; - repeat - inc(P); - until not (jcJsonIdentifier in tab[P^]); - if (P^<=' ') and (P^<>#0) then - inc(P); - while (P^<=' ') and (P^<>#0) do inc(P); - if not (P^ in [':','=']) then // allow both age:18 and age=18 pairs - exit; - end; - repeat inc(P) until (P^>' ') or (P^=#0); - result := P; -end; - -function GetJSONFieldOrObjectOrArray(var P: PUTF8Char; wasString: PBoolean; - EndOfObject: PUTF8Char; HandleValuesAsObjectOrArray: Boolean; - NormalizeBoolean: Boolean; Len: PInteger): PUTF8Char; -var Value: PUTF8Char; - wStr: boolean; -begin - result := nil; - if P=nil then - exit; - while ord(P^) in [1..32] do inc(P); - if HandleValuesAsObjectOrArray and (P^ in ['{','[']) then begin - Value := P; - P := GotoNextJSONObjectOrArray(P); - if P=nil then - exit; // invalid content - if Len<>nil then - Len^ := P-Value; - if wasString<>nil then - wasString^ := false; // was object or array - while ord(P^) in [1..32] do inc(P); - if EndOfObject<>nil then - EndOfObject^ := P^; - P^ := #0; // make zero-terminated - if P[1]=#0 then - P := nil else - inc(P); - result := Value; - end else begin - result := GetJSONField(P,P,@wStr,EndOfObject,Len); - if wasString<>nil then - wasString^ := wStr; - if not wStr and NormalizeBoolean and (result<>nil) then begin - if PInteger(result)^=TRUE_LOW then - result := pointer(SmallUInt32UTF8[1]) else // normalize true -> 1 - if PInteger(result)^=FALSE_LOW then - result := pointer(SmallUInt32UTF8[0]) else // normalize false -> 0 - exit; - if Len<>nil then - Len^ := 1; - end; - end; -end; - -function IsString(P: PUTF8Char): boolean; // test if P^ is a "string" value -begin - if P=nil then begin - result := false; - exit; - end; - while (P^<=' ') and (P^<>#0) do inc(P); - if (P[0] in ['0'..'9']) or // is first char numeric? - ((P[0] in ['-','+']) and (P[1] in ['0'..'9'])) then begin - // check if P^ is a true numerical value - repeat inc(P) until not (P^ in ['0'..'9']); // check digits - if P^='.' then - repeat inc(P) until not (P^ in ['0'..'9']); // check fractional digits - if ((P^='e') or (P^='E')) and (P[1] in ['0'..'9','+','-']) then begin - inc(P); - if P^='+' then inc(P) else - if P^='-' then inc(P); - while (P^>='0') and (P^<='9') do inc(P); - end; - while (P^<=' ') and (P^<>#0) do inc(P); - result := (P^<>#0); - exit; - end else - result := true; // don't begin with a numerical value -> must be a string -end; - -function IsStringJSON(P: PUTF8Char): boolean; // test if P^ is a "string" value -var c4: integer; - c: AnsiChar; - tab: PJsonCharSet; -begin - if P=nil then begin - result := false; - exit; - end; - while (P^<=' ') and (P^<>#0) do inc(P); - tab := @JSON_CHARS; - c4 := PInteger(P)^; - if (((c4=NULL_LOW)or(c4=TRUE_LOW)) and (jcEndOfJSONValueField in tab[P[4]])) or - ((c4=FALSE_LOW) and (P[4]='e') and (jcEndOfJSONValueField in tab[P[5]])) then begin - result := false; // constants are no string - exit; - end; - c := P^; - if (jcDigitFirstChar in tab[c]) and - (((c>='1') and (c<='9')) or // is first char numeric? - ((c='0') and ((P[1]<'0') or (P[1]>'9'))) or // '012' excluded by JSON - ((c='-') and (P[1]>='0') and (P[1]<='9'))) then begin - // check if c is a true numerical value - repeat inc(P) until (P^<'0') or (P^>'9'); // check digits - if P^='.' then - repeat inc(P) until (P^<'0') or (P^>'9'); // check fractional digits - if ((P^='e') or (P^='E')) and (jcDigitChar in tab[P[1]]) then begin - inc(P); - c := P^; - if c='+' then inc(P) else - if c='-' then inc(P); - while (P^>='0') and (P^<='9') do inc(P); - end; - while (P^<=' ') and (P^<>#0) do inc(P); - result := (P^<>#0); - exit; - end else - result := true; // don't begin with a numerical value -> must be a string -end; - -function IsValidJSON(const s: RawUTF8): boolean; -begin - result := IsValidJSON(pointer(s),length(s)); -end; - -function IsValidJSON(P: PUTF8Char; len: PtrInt): boolean; -var B: PUTF8Char; -begin - result := false; - if (P=nil) or (len<=0) or (StrLen(P)<>len) then - exit; - B := P; - P := GotoEndJSONItem(B,{strict=}true); - result := (P<>nil) and (P-B=len); -end; - -procedure GetJSONItemAsRawJSON(var P: PUTF8Char; var result: RawJSON; - EndOfObject: PAnsiChar); -var B: PUTF8Char; -begin - result := ''; - if P=nil then - exit; - B := GotoNextNotSpace(P); - P := GotoEndJSONItem(B); - if P=nil then - exit; - FastSetString(RawUTF8(result),B,P-B); - while (P^<=' ') and (P^<>#0) do inc(P); - if EndOfObject<>nil then - EndOfObject^ := P^; - if P^<>#0 then //if P^=',' then - repeat inc(P) until (P^>' ') or (P^=#0); -end; - -function GetJSONItemAsRawUTF8(var P: PUTF8Char; var output: RawUTF8; - wasString: PBoolean; EndOfObject: PUTF8Char): boolean; -var V: PUTF8Char; - VLen: integer; -begin - V := GetJSONFieldOrObjectOrArray(P,wasstring,EndOfObject,true,true,@VLen); - if V=nil then // parsing error - result := false else begin - FastSetString(output,V,VLen); - result := true; - end; -end; - -function GotoNextJSONObjectOrArrayInternal(P,PMax: PUTF8Char; EndChar: AnsiChar): PUTF8Char; -var tab: PJsonCharSet; -label Prop; -begin // should match GetJSONPropName() - result := nil; - repeat - case P^ of - '{','[': begin - if PMax=nil then - P := GotoNextJSONObjectOrArray(P) else - P := GotoNextJSONObjectOrArrayMax(P,PMax); - if P=nil then exit; - end; - ':': if EndChar<>'}' then exit else inc(P); // syntax for JSON object only - ',': inc(P); // comma appears in both JSON objects and arrays - '}': if EndChar='}' then break else exit; - ']': if EndChar=']' then break else exit; - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; - inc(P); - end; - '-','+','0'..'9': begin // '0123' excluded by JSON, but not here - tab := @JSON_CHARS; - repeat - inc(P); - until not (jcDigitFloatChar in tab[P^]); - end; - 't': if PInteger(P)^=TRUE_LOW then inc(P,4) else goto Prop; - 'f': if PInteger(P+1)^=FALSE_LOW2 then inc(P,5) else goto Prop; - 'n': if PInteger(P)^=NULL_LOW then inc(P,4) else goto Prop; - '''': begin // single-quoted identifier - repeat inc(P); if P^<=' ' then exit; until P^=''''; - repeat inc(P) until (P^>' ') or (P^=#0); - if P^<>':' then exit; - end; - '/': begin - repeat // allow extended /regex/ syntax - inc(P); - if P^=#0 then - exit; - until P^='/'; - repeat inc(P) until (P^>' ') or (P^=#0); - end; - else begin -Prop: tab := @JSON_CHARS; - if not (jcJsonIdentifierFirstChar in tab[P^]) then - exit; - repeat - inc(P); - until not (jcJsonIdentifier in tab[P^]); - while (P^<=' ') and (P^<>#0) do inc(P); - if P^='(' then begin // handle e.g. "born":isodate("1969-12-31") - inc(P); - while (P^<=' ') and (P^<>#0) do inc(P); - if P^='"' then begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; - end; - inc(P); - while (P^<=' ') and (P^<>#0) do inc(P); - if P^<>')' then - exit; - inc(P); - end - else - if P^<>':' then exit; - end; - end; - while (P^<=' ') and (P^<>#0) do inc(P); - if (PMax<>nil) and (P>=PMax) then - exit; - until P^=EndChar; - result := P+1; -end; - -function GotoEndJSONItem(P: PUTF8Char; strict: boolean): PUTF8Char; -var tab: PJsonCharSet; -label pok,ok; -begin - result := nil; // to notify unexpected end - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - case P^ of - #0: exit; - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; - inc(P); - goto ok; - end; - '[': begin - repeat inc(P) until (P^>' ') or (P^=#0); - P := GotoNextJSONObjectOrArrayInternal(P,nil,']'); - goto pok; - end; - '{': begin - repeat inc(P) until (P^>' ') or (P^=#0); - P := GotoNextJSONObjectOrArrayInternal(P,nil,'}'); -pok:if P=nil then - exit; -ok: while (P^<=' ') and (P^<>#0) do inc(P); - result := P; - exit; - end; - end; - if strict then - case P^ of - 't': if PInteger(P)^=TRUE_LOW then begin inc(P,4); goto ok; end; - 'f': if PInteger(P+1)^=FALSE_LOW2 then begin inc(P,5); goto ok; end; - 'n': if PInteger(P)^=NULL_LOW then begin inc(P,4); goto ok; end; - '-','+','0'..'9': begin - tab := @JSON_CHARS; - repeat inc(P) until not (jcDigitFloatChar in tab[P^]); - goto ok; - end; - end else begin // not strict - tab := @JSON_CHARS; - repeat // numeric or true/false/null or MongoDB extended {age:{$gt:18}} - inc(P); - until jcEndOfJSONFieldOr0 in tab[P^]; - if P^=#0 then exit; // unexpected end - end; - if P^=#0 then - exit; - result := P; -end; - -function GotoNextJSONItem(P: PUTF8Char; NumberOfItemsToJump: cardinal; - EndOfObject: PAnsiChar): PUTF8Char; -var tab: PJsonCharSet; -label pok,n; -begin - result := nil; // to notify unexpected end - while NumberOfItemsToJump>0 do begin - while (P^<=' ') and (P^<>#0) do inc(P); - // get a field - case P^ of - #0: exit; - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; // P^ should be '"' here - end; - '[': begin - repeat inc(P) until (P^>' ') or (P^=#0); - P := GotoNextJSONObjectOrArrayInternal(P,nil,']'); - goto pok; - end; - '{': begin - repeat inc(P) until (P^>' ') or (P^=#0); - P := GotoNextJSONObjectOrArrayInternal(P,nil,'}'); -pok: if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - goto n; - end; - end; - tab := @JSON_CHARS; - repeat // numeric or true/false/null or MongoDB extended {age:{$gt:18}} - inc(P); - until jcEndOfJSONFieldOr0 in tab[P^]; -n: if P^=#0 then - exit; - if EndOfObject<>nil then - EndOfObject^ := P^; - inc(P); - dec(NumberOfItemsToJump); - end; - result := P; -end; - -function GotoNextJSONObjectOrArray(P: PUTF8Char): PUTF8Char; -var EndChar: AnsiChar; -begin // should match GetJSONPropName() - result := nil; // mark error or unexpected end (#0) - while (P^<=' ') and (P^<>#0) do inc(P); - case P^ of - '[': EndChar := ']'; - '{': EndChar := '}'; - else exit; - end; - repeat inc(P) until (P^>' ') or (P^=#0); - result := GotoNextJSONObjectOrArrayInternal(P,nil,EndChar); -end; - -function GotoNextJSONObjectOrArray(P: PUTF8Char; EndChar: AnsiChar): PUTF8Char; -begin // should match GetJSONPropName() - while (P^<=' ') and (P^<>#0) do inc(P); - result := GotoNextJSONObjectOrArrayInternal(P,nil,EndChar); -end; - -function GotoNextJSONObjectOrArrayMax(P,PMax: PUTF8Char): PUTF8Char; -var EndChar: AnsiChar; -begin // should match GetJSONPropName() - result := nil; // mark error or unexpected end (#0) - while (P^<=' ') and (P^<>#0) do inc(P); - case P^ of - '[': EndChar := ']'; - '{': EndChar := '}'; - else exit; - end; - repeat inc(P) until (P^>' ') or (P^=#0); - result := GotoNextJSONObjectOrArrayInternal(P,PMax,EndChar); -end; - -function JSONArrayCount(P: PUTF8Char): integer; -var n: integer; -begin - result := -1; - n := 0; - P := GotoNextNotSpace(P); - if P^<>']' then - repeat - case P^ of - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; - inc(P); - end; - '{','[': begin - P := GotoNextJSONObjectOrArray(P); - if P=nil then - exit; // invalid content - end; - end; - while not (P^ in [#0,',',']']) do inc(P); - inc(n); - if P^<>',' then break; - repeat inc(P) until (P^>' ') or (P^=#0); - until false; - if P^=']' then - result := n; -end; - -function JSONArrayDecode(P: PUTF8Char; out Values: TPUTF8CharDynArray): boolean; -var n,max: integer; -begin - result := false; - max := 0; - n := 0; - P := GotoNextNotSpace(P); - if P^<>']' then - repeat - if max=n then begin - max := NextGrow(max); - SetLength(Values,max); - end; - Values[n] := P; - case P^ of - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; - inc(P); - end; - '{','[': begin - P := GotoNextJSONObjectOrArray(P); - if P=nil then - exit; // invalid content - end; - end; - while not (P^ in [#0,',',']']) do inc(P); - inc(n); - if P^<>',' then break; - repeat inc(P) until (P^>' ') or (P^=#0); - until false; - if P^=']' then begin - SetLength(Values,n); - result := true; - end else - Values := nil; -end; - -function JSONArrayItem(P: PUTF8Char; Index: integer): PUTF8Char; -begin - if P<>nil then begin - P := GotoNextNotSpace(P); - if P^='[' then begin - P := GotoNextNotSpace(P+1); - if P^<>']' then - repeat - if Index<=0 then begin - result := P; - exit; - end; - case P^ of - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - break; // invalid content - inc(P); - end; - '{','[': begin - P := GotoNextJSONObjectOrArray(P); - if P=nil then - break; // invalid content - end; - end; - while not (P^ in [#0,',',']']) do inc(P); - if P^<>',' then break; - repeat inc(P) until (P^>' ') or (P^=#0); - dec(Index); - until false; - end; - end; - result := nil; -end; - -function JSONArrayCount(P,PMax: PUTF8Char): integer; -var n: integer; -begin - result := -1; - n := 0; - P := GotoNextNotSpace(P); - if P^<>']' then - while P'"' then - exit; - inc(P); - end; - '{','[': begin - P := GotoNextJSONObjectOrArrayMax(P,PMax); - if P=nil then - exit; // invalid content or PMax reached - end; - end; - while not (P^ in [#0,',',']']) do inc(P); - inc(n); - if P^<>',' then break; - repeat inc(P) until (P^>' ') or (P^=#0); - end; - if P^=']' then - result := n; -end; - -function JSONObjectPropCount(P: PUTF8Char): integer; -var n: integer; -begin - result := -1; - n := 0; - P := GotoNextNotSpace(P); - if P^<>'}' then - repeat - P := GotoNextJSONPropName(P); - if P=nil then - exit; - case P^ of - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit; - inc(P); - end; - '{','[': begin - P := GotoNextJSONObjectOrArray(P); - if P=nil then - exit; // invalid content - end; - end; - while not (P^ in [#0,',','}']) do inc(P); - inc(n); - if P^<>',' then break; - repeat inc(P) until (P^>' ') or (P^=#0); - until false; - if P^='}' then - result := n; -end; - -function JsonObjectItem(P: PUTF8Char; const PropName: RawUTF8; - PropNameFound: PRawUTF8): PUTF8Char; -var name: shortstring; // no memory allocation nor P^ modification - PropNameLen: integer; - PropNameUpper: array[byte] of AnsiChar; -begin - if P<>nil then begin - P := GotoNextNotSpace(P); - PropNameLen := length(PropName); - if PropNameLen<>0 then begin - if PropName[PropNameLen]='*' then begin - UpperCopy255Buf(PropNameUpper,pointer(PropName),PropNameLen-1)^ := #0; - PropNameLen := 0; - end; - if P^='{' then - P := GotoNextNotSpace(P+1); - if P^<>'}' then - repeat - GetJSONPropName(P,name); - if (name[0]=#0) or (name[0]>#200) then - break; - while (P^<=' ') and (P^<>#0) do inc(P); - if PropNameLen=0 then begin - name[ord(name[0])+1] := #0; // make ASCIIZ - if IdemPChar(@name[1],PropNameUpper) then begin - if PropNameFound<>nil then - FastSetString(PropNameFound^,@name[1],ord(name[0])); - result := P; - exit; - end; - end else - if IdemPropName(name,pointer(PropName),PropNameLen) then begin - result := P; - exit; - end; - case P^ of - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - break; // invalid content - inc(P); - end; - '{','[': begin - P := GotoNextJSONObjectOrArray(P); - if P=nil then - break; // invalid content - end; - end; - while not (P^ in [#0,',','}']) do inc(P); - if P^<>',' then break; - repeat inc(P) until (P^>' ') or (P^=#0); - until false; - end; - end; - result := nil; -end; - -function JsonObjectByPath(JsonObject,PropPath: PUTF8Char): PUTF8Char; -var objName: RawUTF8; -begin - result := nil; - if (JsonObject=nil) or (PropPath=nil) then - exit; - repeat - GetNextItem(PropPath,'.',objName); - if objName='' then - exit; - JsonObject := JsonObjectItem(JsonObject,objName); - if JsonObject=nil then - exit; - until PropPath=nil; // found full name scope - result := JsonObject; -end; - -function JsonObjectsByPath(JsonObject,PropPath: PUTF8Char): RawUTF8; -var itemName,objName,propNameFound,objPath: RawUTF8; - start,ending,obj: PUTF8Char; - WR: TTextWriter; - temp: TTextWriterStackBuffer; - procedure AddFromStart(const name: RaWUTF8); - begin - start := GotoNextNotSpace(start); - ending := GotoEndJSONItem(start); - if ending=nil then - exit; - if WR=nil then begin - WR := TTextWriter.CreateOwnedStream(temp); - WR.Add('{'); - end else - WR.Add(','); - WR.AddFieldName(name); - while (ending>start) and (ending[-1]<=' ') do dec(ending); // trim right - WR.AddNoJSONEscape(start,ending-start); - end; -begin - result := ''; - if (JsonObject=nil) or (PropPath=nil) then - exit; - WR := nil; - try - repeat - GetNextItem(PropPath,',',itemName); - if itemName='' then - break; - if itemName[length(itemName)]<>'*' then begin - start := JsonObjectByPath(JsonObject,pointer(itemName)); - if start<>nil then - AddFromStart(itemName); - end else begin - objPath := ''; - obj := pointer(itemName); - repeat - GetNextItem(obj,'.',objName); - if objName='' then - exit; - propNameFound := ''; - JsonObject := JsonObjectItem(JsonObject,objName,@propNameFound); - if JsonObject=nil then - exit; - if obj=nil then begin // found full name scope - start := JsonObject; - repeat - AddFromStart(objPath+propNameFound); - ending := GotoNextNotSpace(ending); - if ending^<>',' then - break; - propNameFound := ''; - start := JsonObjectItem(GotoNextNotSpace(ending+1),objName,@propNameFound); - until start=nil; - break; - end else - objPath := objPath+objName+'.'; - until false; - end; - until PropPath=nil; - if WR<>nil then begin - WR.Add('}'); - WR.SetText(result); - end; - finally - WR.Free; - end; -end; - -function JSONObjectAsJSONArrays(JSON: PUTF8Char; out keys,values: RawUTF8): boolean; -var wk,wv: TTextWriter; - kb,ke,vb,ve: PUTF8Char; - temp1,temp2: TTextWriterStackBuffer; -begin - result := false; - if (JSON=nil) or (JSON^<>'{') then - exit; - wk := TTextWriter.CreateOwnedStream(temp1); - wv := TTextWriter.CreateOwnedStream(temp2); - try - wk.Add('['); - wv.Add('['); - kb := JSON+1; - repeat - ke := GotoEndJSONItem(kb); - if (ke=nil) or (ke^<>':') then - exit; // invalid input content - vb := ke+1; - ve := GotoEndJSONItem(vb); - if (ve=nil) or not(ve^ in [',','}']) then - exit; - wk.AddNoJSONEscape(kb,ke-kb); - wk.Add(','); - wv.AddNoJSONEscape(vb,ve-vb); - wv.Add(','); - kb := ve+1; - until ve^='}'; - wk.CancelLastComma; - wk.Add(']'); - wk.SetText(keys); - wv.CancelLastComma; - wv.Add(']'); - wv.SetText(values); - result := true; - finally - wv.Free; - wk.Free; - end; -end; - -function TryRemoveComment(P: PUTF8Char): PUTF8Char; {$ifdef HASINLINE}inline;{$endif} -begin - result := P + 1; - case result^ of - '/': begin // this is // comment - replace by ' ' - dec(result); - repeat - result^ := ' '; - inc(result) - until result^ in [#0, #10, #13]; - if result^<>#0 then inc(result); - end; - '*': begin // this is /* comment - replace by ' ' but keep CRLF - result[-1] := ' '; - repeat - if not(result^ in [#10, #13]) then - result^ := ' '; // keep CRLF for correct line numbering (e.g. for error) - inc(result); - if PWord(result)^=ord('*')+ord('/')shl 8 then begin - PWord(result)^ := $2020; - inc(result,2); - break; - end; - until result^=#0; - end; - end; -end; - -procedure RemoveCommentsFromJSON(P: PUTF8Char); -var PComma: PUTF8Char; -begin // replace comments by ' ' characters which will be ignored by parser - if P<>nil then - while P^<>#0 do begin - case P^ of - '"': begin - P := GotoEndOfJSONString(P); - if P^<>'"' then - exit else - Inc(P); - end; - '/': P := TryRemoveComment(P); - ',': begin // replace trailing comma by space for strict JSON parsers - PComma := P; - repeat inc(P) until (P^>' ') or (P^=#0); - if P^='/' then - P := TryRemoveComment(P); - while (P^<=' ') and (P^<>#0) do inc(P); - if P^ in ['}', ']'] then - PComma^ := ' '; // see https://github.com/synopse/mORMot/pull/349 - end; - else - inc(P); - end; - end; -end; - -procedure JSONBufferToXML(P: PUTF8Char; const Header,NameSpace: RawUTF8; - out result: RawUTF8); -var i,j,L: integer; - temp: TTextWriterStackBuffer; -begin - if P=nil then - result := Header else - with TTextWriter.CreateOwnedStream(temp) do - try - AddNoJSONEscape(pointer(Header),length(Header)); - L := length(NameSpace); - if L<>0 then - AddNoJSONEscape(pointer(NameSpace),L); - AddJSONToXML(P); - if L<>0 then - for i := 1 to L do - if NameSpace[i]='<' then begin - for j := i+1 to L do - if NameSpace[j] in [' ','>'] then begin - Add('<','/'); - AddStringCopy(NameSpace,i+1,j-i-1); - Add('>'); - break; - end; - break; - end; - SetText(result); - finally - Free; - end; -end; - -function JSONToXML(const JSON: RawUTF8; const Header: RawUTF8; - const NameSpace: RawUTF8): RawUTF8; -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); - try - JSONBufferToXML(tmp.buf,Header,NameSpace,result); - finally - tmp.Done; - end; -end; - -procedure JSONBufferReformat(P: PUTF8Char; out result: RawUTF8; - Format: TTextWriterJSONFormat); -var temp: array[word] of byte; // 64KB buffer -begin - if P<>nil then - with TTextWriter.CreateOwnedStream(@temp,SizeOf(temp)) do - try - AddJSONReformat(P,Format,nil); - SetText(result); - finally - Free; - end; -end; - -function JSONReformat(const JSON: RawUTF8; Format: TTextWriterJSONFormat): RawUTF8; -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); - try - JSONBufferReformat(tmp.buf,result,Format); - finally - tmp.Done; - end; -end; - -function JSONBufferReformatToFile(P: PUTF8Char; const Dest: TFileName; - Format: TTextWriterJSONFormat): boolean; -var F: TFileStream; - temp: array[word] of word; // 128KB -begin - try - F := TFileStream.Create(Dest,fmCreate); - try - with TTextWriter.Create(F,@temp,SizeOf(temp)) do - try - AddJSONReformat(P,Format,nil); - FlushFinal; - finally - Free; - end; - result := true; - finally - F.Free; - end; - except - on Exception do - result := false; - end; -end; - -function JSONReformatToFile(const JSON: RawUTF8; const Dest: TFileName; - Format: TTextWriterJSONFormat=jsonHumanReadable): boolean; -var tmp: TSynTempBuffer; -begin - tmp.Init(JSON); - try - result := JSONBufferReformatToFile(tmp.buf,Dest,Format); - finally - tmp.Done; - end; -end; - - -procedure KB(bytes: Int64; out result: TShort16; nospace: boolean); -type TUnits = (kb,mb,gb,tb,pb,eb,b); -const TXT: array[boolean,TUnits] of RawUTF8 = - ((' KB',' MB',' GB',' TB',' PB',' EB','% B'), ('KB','MB','GB','TB','PB','EB','%B')); -var hi,rem: cardinal; - u: TUnits; -begin - if bytes<1 shl 10-(1 shl 10) div 10 then begin - FormatShort16(TXT[nospace,b],[integer(bytes)],result); - exit; - end; - if bytes<1 shl 20-(1 shl 20) div 10 then begin - u := kb; - rem := bytes; - hi := bytes shr 10; - end else - if bytes<1 shl 30-(1 shl 30) div 10 then begin - u := mb; - rem := bytes shr 10; - hi := bytes shr 20; - end else - if bytes0 then - rem := rem div 102; - if rem=10 then begin - rem := 0; - inc(hi); // round up as expected by (most) human beings - end; - if rem<>0 then - FormatShort16('%.%%',[hi,rem,TXT[nospace,u]],result) else - FormatShort16('%%',[hi,TXT[nospace,u]],result); -end; - -function KB(bytes: Int64): TShort16; -begin - KB(bytes,result,{nospace=}false); -end; - -function KBNoSpace(bytes: Int64): TShort16; -begin - KB(bytes,result,{nospace=}true); -end; - -function KB(bytes: Int64; nospace: boolean): TShort16; -begin - KB(bytes,result,nospace); -end; - -function KB(const buffer: RawByteString): TShort16; -begin - KB(length(buffer),result,{nospace=}false); -end; - -procedure KBU(bytes: Int64; var result: RawUTF8); -var tmp: TShort16; -begin - KB(bytes,tmp,{nospace=}false); - FastSetString(result,@tmp[1],ord(tmp[0])); -end; - -function IntToThousandString(Value: integer; const ThousandSep: TShort4): shortstring; -var i,L,Len: cardinal; -begin - str(Value,result); - L := length(result); - Len := L+1; - if Value<0 then - dec(L,2) else // ignore '-' sign - dec(L); - for i := 1 to L div 3 do - insert(ThousandSep,result,Len-i*3); -end; - -function MicroSecToString(Micro: QWord): TShort16; -begin - MicroSecToString(Micro,result); -end; - -procedure MicroSecToString(Micro: QWord; out result: TShort16); - procedure TwoDigitToString(value: cardinal; const u: shortstring; var result: TShort16); - var d100: TDiv100Rec; - begin - if value<100 then - FormatShort16('0.%%',[UInt2DigitsToShortFast(value),u],result) else begin - Div100(value,d100); - if d100.m=0 then - FormatShort16('%%',[d100.d,u],result) else - FormatShort16('%.%%',[d100.d,UInt2DigitsToShortFast(d100.m),u],result); - end; - end; - procedure TimeToString(value: cardinal; const u: shortstring; var result: TShort16); - var d: cardinal; - begin - d := value div 60; - FormatShort16('%%%',[d,u,UInt2DigitsToShortFast(value-(d*60))],result); - end; -begin - if Int64(Micro)<=0 then - result := '0us' else - if Micro<1000 then - FormatShort16('%us',[Micro],result) else - if Micro<1000000 then - TwoDigitToString({$ifdef CPU32}PCardinal(@Micro)^{$else}Micro{$endif} div 10,'ms',result) else - if Micro<60000000 then - TwoDigitToString({$ifdef CPU32}PCardinal(@Micro)^{$else}Micro{$endif} div 10000,'s',result) else - if Micro0) or (fTime<>0); -end; - -procedure TPrecisionTimer.Resume; -begin - if fStart=0 then - {$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(fStart); -end; - -procedure TPrecisionTimer.Pause; -begin - if fStart=0 then - exit; - {$ifdef LINUX}QueryPerformanceMicroSeconds{$else}QueryPerformanceCounter{$endif}(fStop); - FromExternalQueryPerformanceCounters(fStop-fStart); - inc(fPauseCount); -end; - -procedure TPrecisionTimer.FromExternalMicroSeconds(const MicroSeconds: QWord); -begin - fLastTime := MicroSeconds; - inc(fTime,MicroSeconds); - fStart := 0; // indicates time has been computed -end; - -function TPrecisionTimer.FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; -begin // mimics Pause from already known elapsed time - {$ifdef LINUX} - FromExternalMicroSeconds(CounterDiff); - {$else} - if fWinFreq=0 then - QueryPerformanceFrequency(fWinFreq); - if fWinFreq<>0 then - FromExternalMicroSeconds((CounterDiff*1000000)div PQWord(@fWinFreq)^); - {$endif LINUX} - result := fLastTime; -end; - -function TPrecisionTimer.Stop: TShort16; -begin - if fStart<>0 then - Pause; - MicroSecToString(fTime,result); -end; - -function TPrecisionTimer.StopInMicroSec: TSynMonitorTotalMicroSec; -begin - if fStart<>0 then - Pause; - result := fTime; -end; - -function TPrecisionTimer.Time: TShort16; -begin - if fStart<>0 then - Pause; - MicroSecToString(fTime,result); -end; - -function TPrecisionTimer.LastTime: TShort16; -begin - if fStart<>0 then - Pause; - MicroSecToString(fLastTime,result); -end; - -function TPrecisionTimer.ByCount(Count: QWord): TShort16; -begin - if Count=0 then // avoid div per 0 exception - result := '0' else begin - if fStart<>0 then - Pause; - MicroSecToString(fTime div Count,result); - end; -end; - -function TPrecisionTimer.PerSec(const Count: QWord): QWord; -begin - if fStart<>0 then - Pause; - if fTime<=0 then // avoid negative value in case of incorrect Start/Stop sequence - result := 0 else // avoid div per 0 exception - result := (Count*1000000) div fTime; -end; - -function TPrecisionTimer.SizePerSec(Size: QWord): shortstring; -begin - FormatShort('% in % i.e. %/s',[KB(Size),Stop,KB(PerSec(Size))],result); -end; - - -type - /// a class used internaly by TPrecisionTimer.ProfileMethod - TPrecisionTimerProfiler = class(TInterfacedObject) - protected - fTimer: PPrecisionTimer; - public - constructor Create(aTimer: PPrecisionTimer); - destructor Destroy; override; - end; - -constructor TPrecisionTimerProfiler.Create(aTimer: PPrecisionTimer); -begin - fTimer := aTimer; -end; - -destructor TPrecisionTimerProfiler.Destroy; -begin - if fTimer<>nil then - fTimer^.Pause; - inherited; -end; - - -function TPrecisionTimer.ProfileCurrentMethod: IUnknown; -begin - Resume; - result := TPrecisionTimerProfiler.Create(@self); -end; - - -{ TLocalPrecisionTimer } - -function TLocalPrecisionTimer.ByCount(Count: cardinal): RawUTF8; -begin - result := fTimer.ByCount(Count); -end; - -procedure TLocalPrecisionTimer.Pause; -begin - fTimer.Pause; -end; - -function TLocalPrecisionTimer.PerSec(Count: cardinal): cardinal; -begin - result := fTimer.PerSec(Count); -end; - -procedure TLocalPrecisionTimer.Resume; -begin - fTimer.Resume; -end; - -procedure TLocalPrecisionTimer.Start; -begin - fTimer.Start; -end; - -function TLocalPrecisionTimer.Stop: TShort16; -begin - result := fTimer.Stop; -end; - -constructor TLocalPrecisionTimer.CreateAndStart; -begin - inherited; - fTimer.Start; -end; - -{ TSynMonitorTime } - -function TSynMonitorTime.GetAsText: TShort16; -begin - MicroSecToString(fMicroSeconds,result); -end; - -function TSynMonitorTime.PerSecond(const Count: QWord): QWord; -begin - if {$ifdef FPC}Int64(fMicroSeconds){$else}PInt64(@fMicroSeconds)^{$endif}<=0 then - result := 0 else // avoid negative or div per 0 - result := (Count*1000000) div fMicroSeconds; -end; - - -{ TSynMonitorOneTime } - -function TSynMonitorOneTime.GetAsText: TShort16; -begin - MicroSecToString(fMicroSeconds,result); -end; - -function TSynMonitorOneTime.PerSecond(const Count: QWord): QWord; -begin - if {$ifdef FPC}Int64(fMicroSeconds){$else}PInt64(@fMicroSeconds)^{$endif}<=0 then - result := 0 else - result := (Count*QWord(1000000)) div fMicroSeconds; -end; - - -{ TSynMonitorSizeParent } - -constructor TSynMonitorSizeParent.Create(aTextNoSpace: boolean); -begin - inherited Create; - fTextNoSpace := aTextNoSpace; -end; - -{ TSynMonitorSize } - -function TSynMonitorSize.GetAsText: TShort16; -begin - KB(fBytes,result,fTextNoSpace); -end; - -{ TSynMonitorOneSize } - -function TSynMonitorOneSize.GetAsText: TShort16; -begin - KB(fBytes,result,fTextNoSpace); -end; - -{ TSynMonitorThroughput } - -function TSynMonitorThroughput.GetAsText: TShort16; -begin - FormatShort16('%/s',[KB(fBytesPerSec,fTextNoSpace)],result); -end; - - -{ TSynMonitor } - -constructor TSynMonitor.Create; -begin - inherited Create; - fTotalTime := TSynMonitorTime.Create; - fLastTime := TSynMonitorOneTime.Create; - fMinimalTime := TSynMonitorOneTime.Create; - fAverageTime := TSynMonitorOneTime.Create; - fMaximalTime := TSynMonitorOneTime.Create; -end; - -constructor TSynMonitor.Create(const aName: RawUTF8); -begin - Create; - fName := aName; -end; - -destructor TSynMonitor.Destroy; -begin - fMaximalTime.Free; - fAverageTime.Free; - fMinimalTime.Free; - fLastTime.Free; - fTotalTime.Free; - inherited Destroy; -end; - -procedure TSynMonitor.Lock; -begin - fSafe^.Lock; -end; - -procedure TSynMonitor.UnLock; -begin - fSafe^.UnLock; -end; - -procedure TSynMonitor.Changed; -begin // do nothing by default - overriden classes may track modified changes -end; - -procedure TSynMonitor.ProcessStart; -begin - if fProcessing then - raise ESynException.CreateUTF8('Reentrant %.ProcessStart',[self]); - fSafe^.Lock; - try - InternalTimer.Resume; - fTaskStatus := taskNotStarted; - fProcessing := true; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.ProcessDoTask; -begin - fSafe^.Lock; - try - inc(fTaskCount); - fTaskStatus := taskStarted; - Changed; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.ProcessStartTask; -begin - if fProcessing then - raise ESynException.CreateUTF8('Reentrant %.ProcessStart',[self]); - fSafe^.Lock; - try - InternalTimer.Resume; - fProcessing := true; - inc(fTaskCount); - fTaskStatus := taskStarted; - Changed; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.ProcessEnd; -begin - fSafe^.Lock; - try - InternalTimer.Pause; - LockedFromProcessTimer; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.LockedFromProcessTimer; -begin - fTotalTime.MicroSec := InternalTimer.TimeInMicroSec; - if fTaskStatus=taskStarted then begin - fLastTime.MicroSec := InternalTimer.LastTimeInMicroSec; - if (fMinimalTime.MicroSec=0) or - (InternalTimer.LastTimeInMicroSecfMaximalTime.MicroSec then - fMaximalTime.MicroSec := InternalTimer.LastTimeInMicroSec; - fTaskStatus := taskNotStarted; - end; - LockedPerSecProperties; - fProcessing := false; - Changed; -end; - -function TSynMonitor.FromExternalQueryPerformanceCounters(const CounterDiff: QWord): QWord; -begin - fSafe^.Lock; - try // thread-safe ProcessStart+ProcessDoTask+ProcessEnd - inc(fTaskCount); - fTaskStatus := taskStarted; - result := InternalTimer.FromExternalQueryPerformanceCounters(CounterDiff); - LockedFromProcessTimer; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.FromExternalMicroSeconds(const MicroSecondsElapsed: QWord); -begin - fSafe^.Lock; - try // thread-safe ProcessStart+ProcessDoTask+ProcessEnd - inc(fTaskCount); - fTaskStatus := taskStarted; - InternalTimer.FromExternalMicroSeconds(MicroSecondsElapsed); - LockedFromProcessTimer; - finally - fSafe^.UnLock; - end; -end; - -class procedure TSynMonitor.InitializeObjArray(var ObjArr; Count: integer); -var i: integer; -begin - ObjArrayClear(ObjArr); - SetLength(TPointerDynArray(ObjArr),Count); - for i := 0 to Count-1 do - TPointerDynArray(ObjArr)[i] := Create; -end; - -procedure TSynMonitor.ProcessError(const info: variant); -begin - fSafe^.Lock; - try - if not VarIsEmptyOrNull(info) then - inc(fInternalErrors); - fLastInternalError := info; - Changed; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.ProcessErrorFmt(const Fmt: RawUTF8; const Args: array of const); -begin - ProcessError({$ifndef NOVARIANTS}RawUTF8ToVariant{$endif}(FormatUTF8(Fmt,Args))); -end; - -procedure TSynMonitor.ProcessErrorRaised(E: Exception); -begin - {$ifndef NOVARIANTS}if E.InheritsFrom(ESynException) then - ProcessError(_ObjFast([E,ObjectToVariant(E,true)])) else{$endif} - ProcessErrorFmt('%: %', [E,E.Message]); -end; - -procedure TSynMonitor.ProcessErrorNumber(info: integer); -begin - ProcessError(info); -end; - -procedure TSynMonitor.LockedPerSecProperties; -begin - if fTaskCount=0 then - exit; // avoid division per zero - fPerSec := fTotalTime.PerSecond(fTaskCount); - fAverageTime.MicroSec := fTotalTime.MicroSec div fTaskCount; -end; - -procedure TSynMonitor.Sum(another: TSynMonitor); -begin - if (self=nil) or (another=nil) then - exit; - fSafe^.Lock; - another.fSafe^.Lock; - try - LockedSum(another); - finally - another.fSafe^.UnLock; - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.LockedSum(another: TSynMonitor); -begin - fTotalTime.MicroSec := fTotalTime.MicroSec+another.fTotalTime.MicroSec; - if (fMinimalTime.MicroSec=0) or - (another.fMinimalTime.MicroSecfMaximalTime.MicroSec then - fMaximalTime.MicroSec := another.fMaximalTime.MicroSec; - inc(fTaskCount,another.fTaskCount); - if another.Processing then - fProcessing := true; // if any thread is active, whole daemon is active - inc(fInternalErrors,another.Errors); -end; - -procedure TSynMonitor.WriteDetailsTo(W: TTextWriter); -begin - fSafe^.Lock; - try - W.WriteObject(self); - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitor.ComputeDetailsTo(W: TTextWriter); -begin - fSafe^.Lock; - try - LockedPerSecProperties; // may not have been calculated after Sum() - WriteDetailsTo(W); - finally - fSafe^.UnLock; - end; -end; - -function TSynMonitor.ComputeDetailsJSON: RawUTF8; -var W: TTextWriter; - temp: TTextWriterStackBuffer; -begin - W := DefaultTextWriterSerializer.CreateOwnedStream(temp); - try - ComputeDetailsTo(W); - W.SetText(result); - finally - W.Free; - end; -end; - -{$ifndef NOVARIANTS} -function TSynMonitor.ComputeDetails: variant; -begin - _Json(ComputeDetailsJSON,result,JSON_OPTIONS_FAST); -end; -{$endif} - - -{ TSynMonitorWithSize} - -constructor TSynMonitorWithSize.Create; -begin - inherited Create; - fSize := TSynMonitorSize.Create({nospace=}false); - fThroughput := TSynMonitorThroughput.Create({nospace=}false); -end; - -destructor TSynMonitorWithSize.Destroy; -begin - inherited Destroy; - fThroughput.Free; - fSize.Free; -end; - -procedure TSynMonitorWithSize.LockedPerSecProperties; -begin - inherited LockedPerSecProperties; - fThroughput.BytesPerSec := fTotalTime.PerSecond(fSize.Bytes); -end; - -procedure TSynMonitorWithSize.AddSize(const Bytes: QWord); -begin - fSafe^.Lock; - try - fSize.Bytes := fSize.Bytes+Bytes; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitorWithSize.LockedSum(another: TSynMonitor); -begin - inherited LockedSum(another); - if another.InheritsFrom(TSynMonitorWithSize) then - AddSize(TSynMonitorWithSize(another).Size.Bytes); -end; - - -{ TSynMonitorInputOutput } - -constructor TSynMonitorInputOutput.Create; -begin - inherited Create; - fInput := TSynMonitorSize.Create({nospace=}false); - fOutput := TSynMonitorSize.Create({nospace=}false); - fInputThroughput := TSynMonitorThroughput.Create({nospace=}false); - fOutputThroughput := TSynMonitorThroughput.Create({nospace=}false); -end; - -destructor TSynMonitorInputOutput.Destroy; -begin - fOutputThroughput.Free; - fOutput.Free; - fInputThroughput.Free; - fInput.Free; - inherited Destroy; -end; - -procedure TSynMonitorInputOutput.LockedPerSecProperties; -begin - inherited LockedPerSecProperties; - fInputThroughput.BytesPerSec := fTotalTime.PerSecond(fInput.Bytes); - fOutputThroughput.BytesPerSec := fTotalTime.PerSecond(fOutput.Bytes); -end; - -procedure TSynMonitorInputOutput.AddSize(const Incoming, Outgoing: QWord); -begin - fSafe^.Lock; - try - fInput.Bytes := fInput.Bytes+Incoming; - fOutput.Bytes := fOutput.Bytes+Outgoing; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitorInputOutput.LockedSum(another: TSynMonitor); -begin - inherited LockedSum(another); - if another.InheritsFrom(TSynMonitorInputOutput) then begin - fInput.Bytes := fInput.Bytes+TSynMonitorInputOutput(another).Input.Bytes; - fOutput.Bytes := fOutput.Bytes+TSynMonitorInputOutput(another).Output.Bytes; - end; -end; - - -{ TSynMonitorServer } - -procedure TSynMonitorServer.ClientConnect; -begin - if self=nil then - exit; - fSafe^.Lock; - try - inc(fClientsCurrent); - if fClientsCurrent>fClientsMax then - fClientsMax := fClientsCurrent; - Changed; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitorServer.ClientDisconnect; -begin - if self=nil then - exit; - fSafe^.Lock; - try - if fClientsCurrent>0 then - dec(fClientsCurrent); - Changed; - finally - fSafe^.UnLock; - end; -end; - -procedure TSynMonitorServer.ClientDisconnectAll; -begin - if self=nil then - exit; - fSafe^.Lock; - try - fClientsCurrent := 0; - Changed; - finally - fSafe^.UnLock; - end; -end; - -function TSynMonitorServer.GetClientsCurrent: TSynMonitorOneCount; -begin - if self=nil then begin - result := 0; - exit; - end; - fSafe^.Lock; - try - result := fClientsCurrent; - finally - fSafe^.UnLock; - end; -end; - -function TSynMonitorServer.AddCurrentRequestCount(diff: integer): integer; -begin - if self=nil then begin - result := 0; - exit; - end; - fSafe^.Lock; - try - inc(fCurrentRequestCount,diff); - result := fCurrentRequestCount; - finally - fSafe^.UnLock; - end; -end; - - -{ ******************* cross-cutting classes and functions ***************** } - -{ TSynInterfacedObject } - -function TSynInterfacedObject._AddRef: {$ifdef FPC}longint{$else}integer{$endif}; -begin - result := VirtualAddRef; -end; - -function TSynInterfacedObject._Release: {$ifdef FPC}longint{$else}integer{$endif}; -begin - result := VirtualRelease; -end; - -{$ifdef FPC} -function TSynInterfacedObject.QueryInterface( - {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; - out Obj): longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; -{$else} -function TSynInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult; -{$endif} -begin - result := VirtualQueryInterface(IID,Obj); -end; - -function TSynInterfacedObject.VirtualQueryInterface(const IID: TGUID; out Obj): HResult; -begin - result := E_NOINTERFACE; -end; - -{$ifdef CPUINTEL} -{$ifndef DELPHI5OROLDER} - -{ TSynFPUException } - -function TSynFPUException.VirtualAddRef: integer; -begin - if fRefCount=0 then begin - {$ifndef CPU64} - fSaved8087 := Get8087CW; - Set8087CW(fExpected8087); // set FPU exceptions mask - {$else} - fSavedMXCSR := GetMXCSR; - SetMXCSR(fExpectedMXCSR); // set FPU exceptions mask - {$endif} - end; - inc(fRefCount); - result := 1; // should never be 0 (mark release of TSynFPUException instance) -end; - -function TSynFPUException.VirtualRelease: integer; -begin - dec(fRefCount); - if fRefCount=0 then - {$ifndef CPU64} - Set8087CW(fSaved8087); - {$else} - SetMXCSR(fSavedMXCSR); - {$endif} - result := 1; // should never be 0 (mark release of TSynFPUException instance) -end; - -threadvar - GlobalSynFPUExceptionDelphi, - GlobalSynFPUExceptionLibrary: TSynFPUException; - -{$ifndef CPU64} -constructor TSynFPUException.Create(Expected8087Flag: word); -begin // $1372=Delphi $137F=library (mask all exceptions) - inherited Create; - fExpected8087 := Expected8087Flag; -end; -{$else} -constructor TSynFPUException.Create(ExpectedMXCSR: word); -begin // $1920=Delphi $1FA0=library (mask all exceptions) - inherited Create; - fExpectedMXCSR := ExpectedMXCSR; -end; -{$endif} - -class function TSynFPUException.ForLibraryCode: IUnknown; -var obj: TSynFPUException; -begin - result := GlobalSynFPUExceptionLibrary; - if result<>nil then - exit; - {$ifndef CPU64} - obj := TSynFPUException.Create($137F); - {$else} - obj := TSynFPUException.Create($1FA0); - {$endif} - GarbageCollector.Add(obj); - GlobalSynFPUExceptionLibrary := obj; - result := obj; -end; - -class function TSynFPUException.ForDelphiCode: IUnknown; -var obj: TSynFPUException; -begin - result := GlobalSynFPUExceptionDelphi; - if result<>nil then - exit; - {$ifndef CPU64} - obj := TSynFPUException.Create($1372); - {$else} - obj := TSynFPUException.Create($1920); - {$endif} - GarbageCollector.Add(obj); - GlobalSynFPUExceptionDelphi := obj; - result := obj; -end; - -{$endif DELPHI5OROLDER} -{$endif CPUINTEL} - - -{ TAutoFree } - -constructor TAutoFree.Create(var localVariable; obj: TObject); -begin - fObject := obj; - TObject(localVariable) := obj; -end; - -class function TAutoFree.One(var localVariable; obj: TObject): IAutoFree; -begin - result := Create(localVariable,obj); -end; - -class function TAutoFree.Several(const varObjPairs: array of pointer): IAutoFree; -begin - result := Create(varObjPairs); -end; - -constructor TAutoFree.Create(const varObjPairs: array of pointer); -var n,i: integer; -begin - n := length(varObjPairs); - if (n=0) or (n and 1=1) then - exit; - n := n shr 1; - if n=0 then - exit; - SetLength(fObjectList,n); - for i := 0 to n-1 do begin - fObjectList[i] := varObjPairs[i*2+1]; - PPointer(varObjPairs[i*2])^ := fObjectList[i]; - end; -end; - -procedure TAutoFree.Another(var localVariable; obj: TObject); -var n: integer; -begin - n := length(fObjectList); - SetLength(fObjectList,n+1); - fObjectList[n] := obj; - TObject(localVariable) := obj; -end; - -destructor TAutoFree.Destroy; -var i: integer; -begin - if fObjectList<>nil then - for i := high(fObjectList) downto 0 do // release FILO - fObjectList[i].Free; - fObject.Free; - inherited; -end; - - -{ TAutoLocker } - -constructor TAutoLocker.Create; -begin - fSafe.Init; -end; - -destructor TAutoLocker.Destroy; -begin - fSafe.Done; - inherited; -end; - -function TAutoLocker.ProtectMethod: IUnknown; -begin - result := TAutoLock.Create(@fSafe); -end; - -procedure TAutoLocker.Enter; -begin - fSafe.Lock; -end; - -procedure TAutoLocker.Leave; -begin - fSafe.UnLock; -end; - -function TAutoLocker.Safe: PSynLocker; -begin - result := @fSafe; -end; - -{$ifndef DELPHI5OROLDER} // internal error C3517 under Delphi 5 :( -{$ifndef NOVARIANTS} - -{ TLockedDocVariant } - -constructor TLockedDocVariant.Create; -begin - Create(JSON_OPTIONS_FAST); -end; - -constructor TLockedDocVariant.Create(FastStorage: boolean); -begin - Create(JSON_OPTIONS[FastStorage]); -end; - -constructor TLockedDocVariant.Create(options: TDocVariantOptions); -begin - fLock := TAutoLocker.Create; - fValue.Init(options); -end; - -destructor TLockedDocVariant.Destroy; -begin - inherited; - fLock.Free; -end; - -function TLockedDocVariant.Lock: TAutoLocker; -begin - result := fLock; -end; - -function TLockedDocVariant.Exists(const Name: RawUTF8; out Value: Variant): boolean; -var i: integer; -begin - fLock.Enter; - try - i := fValue.GetValueIndex(Name); - if i<0 then - result := false else begin - Value := fValue.Values[i]; - result := true; - end; - finally - fLock.Leave; - end; -end; - -function TLockedDocVariant.ExistsOrLock(const Name: RawUTF8; out Value: Variant): boolean; -var i: integer; -begin - result := true; - fLock.Enter; - try - i := fValue.GetValueIndex(Name); - if i<0 then - result := false else - Value := fValue.Values[i]; - finally - if result then - fLock.Leave; - end; -end; - -procedure TLockedDocVariant.ReplaceAndUnlock( - const Name: RawUTF8; const Value: Variant; out LocalValue: Variant); -begin // caller made fLock.Enter - try - SetValue(Name,Value); - LocalValue := Value; - finally - fLock.Leave; - end; -end; - -function TLockedDocVariant.AddExistingPropOrLock(const Name: RawUTF8; - var Obj: variant): boolean; -var i: integer; -begin - result := true; - fLock.Enter; - try - i := fValue.GetValueIndex(Name); - if i<0 then - result := false else - _ObjAddProps([Name,fValue.Values[i]],Obj); - finally - if result then - fLock.Leave; - end; -end; - -procedure TLockedDocVariant.AddNewPropAndUnlock(const Name: RawUTF8; - const Value: variant; - var Obj: variant); -begin // caller made fLock.Enter - try - SetValue(Name,Value); - _ObjAddProps([Name,Value],Obj); - finally - fLock.Leave; - end; -end; - -function TLockedDocVariant.AddExistingProp(const Name: RawUTF8; - var Obj: variant): boolean; -var i: integer; -begin - result := true; - fLock.Enter; - try - i := fValue.GetValueIndex(Name); - if i<0 then - result := false else - _ObjAddProps([Name,fValue.Values[i]],Obj); - finally - fLock.Leave; - end; -end; - -procedure TLockedDocVariant.AddNewProp(const Name: RawUTF8; - const Value: variant; var Obj: variant); -begin - fLock.Enter; - try - SetValue(Name,Value); - _ObjAddProps([Name,Value],Obj); - finally - fLock.Leave; - end; -end; - -function TLockedDocVariant.GetValue(const Name: RawUTF8): Variant; -begin - fLock.Enter; - try - fValue.RetrieveValueOrRaiseException(pointer(Name),length(Name), - dvoNameCaseSensitive in fValue.Options,result,false); - finally - fLock.Leave; - end; -end; - -procedure TLockedDocVariant.SetValue(const Name: RawUTF8; - const Value: Variant); -begin - fLock.Enter; - try - fValue.AddOrUpdateValue(Name,Value); - finally - fLock.Leave; - end; -end; - -procedure TLockedDocVariant.AddItem(const Value: variant); -begin - fLock.Enter; - try - fValue.AddItem(Value); - finally - fLock.Leave; - end; -end; - -function TLockedDocVariant.Copy: variant; -begin - VarClear(result); - fLock.Enter; - try - TDocVariantData(result).InitCopy(variant(fValue),JSON_OPTIONS_FAST); - finally - fLock.Leave; - end; -end; - -procedure TLockedDocVariant.Clear; -var opt: TDocVariantOptions; -begin - fLock.Enter; - try - opt := fValue.Options; - fValue.Clear; - fValue.Init(opt); - finally - fLock.Leave; - end; -end; - -function TLockedDocVariant.ToJSON(HumanReadable: boolean): RawUTF8; -var tmp: RawUTF8; -begin - fLock.Enter; - try - VariantSaveJSON(variant(fValue),twJSONEscape,tmp); - finally - fLock.Leave; - end; - if HumanReadable then - JSONBufferReformat(pointer(tmp),result) else - result := tmp; -end; - -{$endif NOVARIANTS} -{$endif DELPHI5OROLDER} - - -function GetDelphiCompilerVersion: RawUTF8; -begin - result := -{$ifdef FPC} - 'Free Pascal' - {$ifdef VER2_6_4}+' 2.6.4'{$endif} - {$ifdef VER3_0_0}+' 3.0.0'{$endif} - {$ifdef VER3_0_1}+' 3.0.1'{$endif} - {$ifdef VER3_0_2}+' 3.0.2'{$endif} - {$ifdef VER3_1_1}+' 3.1.1'{$endif} - {$ifdef VER3_2} +' 3.2' {$endif} - {$ifdef VER3_3_1}+' 3.3.1'{$endif} -{$else} - {$ifdef VER130} 'Delphi 5'{$endif} - {$ifdef CONDITIONALEXPRESSIONS} // Delphi 6 or newer - {$if defined(KYLIX3)}'Kylix 3' - {$elseif defined(VER140)}'Delphi 6' - {$elseif defined(VER150)}'Delphi 7' - {$elseif defined(VER160)}'Delphi 8' - {$elseif defined(VER170)}'Delphi 2005' - {$elseif defined(VER185)}'Delphi 2007' - {$elseif defined(VER180)}'Delphi 2006' - {$elseif defined(VER200)}'Delphi 2009' - {$elseif defined(VER210)}'Delphi 2010' - {$elseif defined(VER220)}'Delphi XE' - {$elseif defined(VER230)}'Delphi XE2' - {$elseif defined(VER240)}'Delphi XE3' - {$elseif defined(VER250)}'Delphi XE4' - {$elseif defined(VER260)}'Delphi XE5' - {$elseif defined(VER265)}'AppMethod 1' - {$elseif defined(VER270)}'Delphi XE6' - {$elseif defined(VER280)}'Delphi XE7' - {$elseif defined(VER290)}'Delphi XE8' - {$elseif defined(VER300)}'Delphi 10 Seattle' - {$elseif defined(VER310)}'Delphi 10.1 Berlin' - {$elseif defined(VER320)}'Delphi 10.2 Tokyo' - {$elseif defined(VER330)}'Delphi 10.3 Rio' - {$elseif defined(VER340)}'Delphi 10.4 Sydney' - {$elseif defined(VER350)}'Delphi 11 Alexandria' - {$elseif defined(VER360)}'Delphi 11.1 Next' - {$ifend} - {$endif CONDITIONALEXPRESSIONS} -{$endif FPC} -{$ifdef CPU64} +' 64 bit' {$else} +' 32 bit' {$endif} -end; - - -{ TRawUTF8List } - -constructor TRawUTF8List.Create(aOwnObjects, aNoDuplicate, aCaseSensitive: boolean); -begin - if aOwnObjects then - include(fFlags,fObjectsOwned); - if aNoDuplicate then - include(fFlags,fNoDuplicate); - if aCaseSensitive then - include(fFlags,fCaseSensitive); - Create(fFlags); -end; - -constructor TRawUTF8List.Create(aFlags: TRawUTF8ListFlags); -begin - fNameValueSep := '='; - fFlags := aFlags; - fValues.InitSpecific(TypeInfo(TRawUTF8DynArray),fValue,djRawUTF8,@fCount, - not (fCaseSensitive in aFlags)); - fSafe.Init; -end; - -destructor TRawUTF8List.Destroy; -begin - SetCapacity(0); - inherited; - fSafe.Done; -end; - -procedure TRawUTF8List.SetCaseSensitive(Value: boolean); -begin - if (self=nil) or (fCaseSensitive in fFlags=Value) then - exit; - fSafe.Lock; - try - if Value then - include(fFlags,fCaseSensitive) else - exclude(fFlags,fCaseSensitive); - fValues.Hasher.InitSpecific(@fValues,djRawUTF8,not Value); - Changed; - finally - fSafe.UnLock; - end; -end; - -procedure TRawUTF8List.SetCapacity(const capa: PtrInt); -begin - if self<>nil then begin - fSafe.Lock; - try - if capa<=0 then begin // clear - if fObjects<>nil then begin - if fObjectsOwned in fFlags then - RawObjectsClear(pointer(fObjects),fCount); - fObjects := nil; - end; - fValues.Clear; - if fNoDuplicate in fFlags then - fValues.Hasher.Clear; - Changed; - end else begin // resize - if capanil then begin - if fObjectsOwned in fFlags then - RawObjectsClear(@fObjects[capa],fCount-capa-1); - SetLength(fObjects,capa); - end; - fValues.Count := capa; - if fNoDuplicate in fFlags then - fValues.ReHash; - Changed; - end; - if capa>length(fValue) then begin // resize up - SetLength(fValue,capa); - if fObjects<>nil then - SetLength(fObjects,capa); - end; - end; - finally - fSafe.UnLock; - end; - end; -end; - -function TRawUTF8List.Add(const aText: RawUTF8; aRaiseExceptionIfExisting: boolean): PtrInt; -begin - result := AddObject(aText,nil,aRaiseExceptionIfExisting); -end; - -function TRawUTF8List.AddObject(const aText: RawUTF8; aObject: TObject; - aRaiseExceptionIfExisting: boolean; aFreeAndReturnExistingObject: PPointer): PtrInt; -var added: boolean; - obj: TObject; -begin - result := -1; - if self=nil then - exit; - fSafe.Lock; - try - if fNoDuplicate in fFlags then begin - result := fValues.FindHashedForAdding(aText,added,{noadd=}true); - if not added then begin - obj := GetObject(result); - if (obj=aObject) and (obj<>nil) then - exit; // found identical aText/aObject -> behave as if added - if aFreeAndReturnExistingObject<>nil then begin - aObject.Free; - aFreeAndReturnExistingObject^ := obj; - end; - if aRaiseExceptionIfExisting then - raise ESynException.CreateUTF8('%.Add duplicate [%]',[self,aText]); - result := -1; - exit; - end; - end; - result := fValues.Add(aText); - if (fObjects<>nil) or (aObject<>nil) then begin - if result>=length(fObjects) then - SetLength(fObjects,length(fValue)); // same capacity - if aObject<>nil then - fObjects[result] := aObject; - end; - if Assigned(fOnChange) then - Changed; - finally - fSafe.UnLock; - end; -end; - -procedure TRawUTF8List.AddObjectUnique(const aText: RawUTF8; - aObjectToAddOrFree: PPointer); -begin - if fNoDuplicate in fFlags then - AddObject(aText,aObjectToAddOrFree^,{raiseexc=}false, - {freeandreturnexisting=}aObjectToAddOrFree); -end; - -procedure TRawUTF8List.AddRawUTF8List(List: TRawUTF8List); -var i: PtrInt; -begin - if List<>nil then begin - BeginUpdate; // includes Safe.Lock - try - for i := 0 to List.fCount-1 do - AddObject(List.fValue[i],List.GetObject(i)); - finally - EndUpdate; - end; - end; -end; - -procedure TRawUTF8List.BeginUpdate; -begin - if InterLockedIncrement(fOnChangeLevel)>1 then - exit; - fSafe.Lock; - fOnChangeBackupForBeginUpdate := fOnChange; - fOnChange := OnChangeHidden; - exclude(fFlags,fOnChangeTrigerred); -end; - -procedure TRawUTF8List.EndUpdate; -begin - if (fOnChangeLevel<=0) or (InterLockedDecrement(fOnChangeLevel)>0) then - exit; // allows nested BeginUpdate..EndUpdate calls - fOnChange := fOnChangeBackupForBeginUpdate; - if (fOnChangeTrigerred in fFlags) and Assigned(fOnChange) then - Changed; - exclude(fFlags,fOnChangeTrigerred); - fSafe.UnLock; -end; - -procedure TRawUTF8List.Changed; -begin - if Assigned(fOnChange) then - try - fOnChange(self); - except // ignore any exception in user code (may not trigger fSafe.UnLock) - end; -end; - -procedure TRawUTF8List.Clear; -begin - SetCapacity(0); // will also call Changed -end; - -procedure TRawUTF8List.InternalDelete(Index: PtrInt); -begin // caller ensured Index is correct - fValues.Delete(Index); // includes dec(fCount) - if PtrUInt(Index)Index then - MoveFast(fObjects[Index+1],fObjects[Index],(fCount-Index)*SizeOf(pointer)); - fObjects[fCount] := nil; - end; - if Assigned(fOnChange) then - Changed; -end; - -procedure TRawUTF8List.Delete(Index: PtrInt); -begin - if (self<>nil) and (PtrUInt(Index)=0 then - InternalDelete(result); - finally - fSafe.UnLock; - end; -end; - -function TRawUTF8List.DeleteFromName(const Name: RawUTF8): PtrInt; -begin - fSafe.Lock; - try - result := IndexOfName(Name); - Delete(result); - finally - fSafe.UnLock; - end; -end; - -function TRawUTF8List.IndexOf(const aText: RawUTF8): PtrInt; -begin - if self<>nil then begin - fSafe.Lock; - try - if fNoDuplicate in fFlags then - result := fValues.FindHashed(aText) else - result := FindRawUTF8(pointer(fValue),aText,fCount,fCaseSensitive in fFlags); - finally - fSafe.UnLock; - end; - end else - result := -1; -end; - -function TRawUTF8List.Get(Index: PtrInt): RawUTF8; -begin - if (self=nil) or (PtrUInt(Index)>=PtrUInt(fCount)) then - result := '' else - result := fValue[Index]; -end; - -function TRawUTF8List.GetCapacity: PtrInt; -begin - if self=nil then - result := 0 else - result := length(fValue); -end; - -function TRawUTF8List.GetCount: PtrInt; -begin - if self=nil then - result := 0 else - result := fCount; -end; - -function TRawUTF8List.GetTextPtr: PPUtf8CharArray; -begin - if self=nil then - result := nil else - result := pointer(fValue); -end; - -function TRawUTF8List.GetObjectPtr: PPointerArray; -begin - if self=nil then - result := nil else - result := pointer(fObjects); -end; - -function TRawUTF8List.GetName(Index: PtrInt): RawUTF8; -begin - result := Get(Index); - if result='' then - exit; - Index := PosExChar(NameValueSep,result); - if Index=0 then - result := '' else - SetLength(result,Index-1); -end; - -function TRawUTF8List.GetObject(Index: PtrInt): pointer; -begin - if (self<>nil) and (fObjects<>nil) and (PtrUInt(Index)nil) and (fObjects<>nil) then begin - fSafe.Lock; - try - ndx := IndexOf(aText); - if ndx0 then begin - MoveFast(pointer(fValue[i])^,P^,Len); - inc(P,Len); - end; - inc(i); - if i>=fCount then - Break; - if DelimLen>0 then begin - MoveSmall(pointer(Delimiter),P,DelimLen); - inc(P,DelimLen); - end; - until false; - finally - fSafe.UnLock; - end; -end; - -procedure TRawUTF8List.SaveToStream(Dest: TStream; const Delimiter: RawUTF8); -var W: TTextWriter; - i: PtrInt; - temp: TTextWriterStackBuffer; -begin - if (self=nil) or (fCount=0) then - exit; - fSafe.Lock; - try - W := TTextWriter.Create(Dest,@temp,SizeOf(temp)); - try - i := 0; - repeat - W.AddString(fValue[i]); - inc(i); - if i>=fCount then - Break; - W.AddString(Delimiter); - until false; - W.FlushFinal; - finally - W.Free; - end; - finally - fSafe.UnLock; - end; -end; - -procedure TRawUTF8List.SaveToFile(const FileName: TFileName; const Delimiter: RawUTF8); -var FS: TFileStream; -begin - FS := TFileStream.Create(FileName,fmCreate); - try - SaveToStream(FS,Delimiter); - finally - FS.Free; - end; -end; - -function TRawUTF8List.GetTextCRLF: RawUTF8; -begin - result := GetText; -end; - -function TRawUTF8List.GetValue(const Name: RawUTF8): RawUTF8; -begin - fSafe.Lock; - try - result := GetValueAt(IndexOfName(Name)); - finally - fSafe.UnLock; - end; -end; - -function TRawUTF8List.GetValueAt(Index: PtrInt): RawUTF8; -begin - if (self=nil) or (PtrUInt(Index)>=PtrUInt(fCount)) then - result := '' else - result := Get(Index); - if result='' then - exit; - Index := PosExChar(NameValueSep,result); - if Index=0 then - result := '' else - result := copy(result,Index+1,maxInt); -end; - -function TRawUTF8List.IndexOfName(const Name: RawUTF8): PtrInt; -var UpperName: array[byte] of AnsiChar; -begin - if self<>nil then begin - PWord(UpperCopy255(UpperName,Name))^ := ord(NameValueSep); - for result := 0 to fCount-1 do - if IdemPChar(Pointer(fValue[result]),UpperName) then - exit; - end; - result := -1; -end; - -function TRawUTF8List.IndexOfObject(aObject: TObject): PtrInt; -begin - if (self<>nil) and (fObjects<>nil) then begin - fSafe.Lock; - try - result := PtrUIntScanIndex(pointer(fObjects),fCount,PtrUInt(aObject)); - finally - fSafe.UnLock; - end - end else - result := -1; -end; - -function TRawUTF8List.Contains(const aText: RawUTF8; aFirstIndex: integer): PtrInt; -var i: PtrInt; // use a temp variable to make oldest Delphi happy :( -begin - result := -1; - if self<>nil then begin - fSafe.Lock; - try - for i := aFirstIndex to fCount-1 do - if PosEx(aText,fValue[i])>0 then begin - result := i; - exit; - end; - finally - fSafe.UnLock; - end; - end; -end; - -procedure TRawUTF8List.OnChangeHidden(Sender: TObject); -begin - if self<>nil then - include(fFlags,fOnChangeTrigerred); -end; - -procedure TRawUTF8List.Put(Index: PtrInt; const Value: RawUTF8); -begin - if (self<>nil) and (PtrUInt(Index)nil) and (PtrUInt(Index)0 then begin - if TextFileKind(Map)=isUTF8 then begin // ignore UTF-8 BOM - P := pointer(Map.Buffer+3); - SetTextPtr(P,P+Map.Size-3,#13#10); - end else begin - P := pointer(Map.Buffer); - SetTextPtr(P,P+Map.Size,#13#10); - end; - end; - finally - Map.UnMap; - end; -end; - -procedure TRawUTF8List.SetTextPtr(P,PEnd: PUTF8Char; const Delimiter: RawUTF8); -var DelimLen: PtrInt; - DelimFirst: AnsiChar; - PBeg, DelimNext: PUTF8Char; - Line: RawUTF8; -begin - DelimLen := length(Delimiter); - BeginUpdate; // also makes fSafe.Lock - try - Clear; - if (P<>nil) and (DelimLen>0) and (P=PEnd then - break; - inc(P,DelimLen); - until P>=PEnd; - end; - finally - EndUpdate; - end; -end; - -procedure TRawUTF8List.SetTextCRLF(const Value: RawUTF8); -begin - SetText(Value,#13#10); -end; - -procedure TRawUTF8List.SetFrom(const aText: TRawUTF8DynArray; const aObject: TObjectDynArray); -var n: integer; -begin - BeginUpdate; // also makes fSafe.Lock - try - Clear; - n := length(aText); - if n=0 then - exit; - SetCapacity(n); - fCount := n; - fValue := aText; - fObjects := aObject; - if fNoDuplicate in fFlags then - fValues.ReHash; - finally - EndUpdate; - end; -end; - -procedure TRawUTF8List.SetValue(const Name, Value: RawUTF8); -var i: PtrInt; - txt: RawUTF8; -begin - txt := Name+RawUTF8(NameValueSep)+Value; - fSafe.Lock; - try - i := IndexOfName(Name); - if i<0 then - AddObject(txt,nil) else - if fValue[i]<>txt then begin - fValue[i] := txt; - if fNoDuplicate in fFlags then - fValues.Hasher.Clear; // invalidate internal hash table - Changed; - end; - finally - fSafe.UnLock; - end; -end; - -function TRawUTF8List.GetCaseSensitive: boolean; -begin - result := (self<>nil) and (fCaseSensitive in fFlags); -end; - -function TRawUTF8List.GetNoDuplicate: boolean; -begin - result := (self<>nil) and (fNoDuplicate in fFlags); -end; - -function TRawUTF8List.UpdateValue(const Name: RawUTF8; var Value: RawUTF8; - ThenDelete: boolean): boolean; -var i: PtrInt; -begin - result := false; - fSafe.Lock; - try - i := IndexOfName(Name); - if i>=0 then begin - Value := GetValueAt(i); // copy value - if ThenDelete then - Delete(i); // optionally delete - result := true; - end; - finally - fSafe.UnLock; - end; -end; - -function TRawUTF8List.PopFirst(out aText: RawUTF8; aObject: PObject): boolean; -begin - result := false; - if fCount=0 then - exit; - fSafe.Lock; - try - if fCount>0 then begin - aText := fValue[0]; - if aObject<>nil then - if fObjects<>nil then - aObject^ := fObjects[0] else - aObject^ := nil; - Delete(0); - result := true; - end; - finally - fSafe.UnLock; - end; -end; - -function TRawUTF8List.PopLast(out aText: RawUTF8; aObject: PObject): boolean; -var last: PtrInt; -begin - result := false; - if fCount=0 then - exit; - fSafe.Lock; - try - last := fCount-1; - if last>=0 then begin - aText := fValue[last]; - if aObject<>nil then - if fObjects<>nil then - aObject^ := fObjects[last] else - aObject^ := nil; - Delete(last); - result := true; - end; - finally - fSafe.UnLock; - end; -end; - - -{ TObjectListHashedAbstract} - -constructor TObjectListHashedAbstract.Create(aFreeItems: boolean); -begin - inherited Create; - fHash.Init(TypeInfo(TObjectDynArray),fList,@HashPtrUInt,@SortDynArrayPointer,nil,@fCount); - fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}SetIsObjArray(aFreeItems); -end; - -destructor TObjectListHashedAbstract.Destroy; -begin - fHash.Clear; // will free items if needed - inherited; -end; - -procedure TObjectListHashedAbstract.Delete(aIndex: integer); -begin - if (self<>nil) and - fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}Delete(aIndex) then - fHash.fHash.Clear; -end; - -procedure TObjectListHashedAbstract.Delete(aObject: TObject); -begin - Delete(IndexOf(aObject)); -end; - -{ TObjectListHashed } - -function TObjectListHashed.Add(aObject: TObject; out wasAdded: boolean): integer; -begin - wasAdded := false; - if self<>nil then begin - result := fHash.FindHashedForAdding(aObject,wasAdded); - if wasAdded then - fList[result] := aObject; - end else - result := -1; -end; - -function TObjectListHashed.IndexOf(aObject: TObject): integer; -begin - if (self<>nil) and (fCount>0) then - result := fHash.FindHashed(aObject) else - result := -1; -end; - -procedure TObjectListHashed.Delete(aObject: TObject); -begin - fHash.FindHashedAndDelete(aObject); -end; - -{ TObjectListPropertyHashed } - -constructor TObjectListPropertyHashed.Create( - aSubPropAccess: TObjectListPropertyHashedAccessProp; - aHashElement: TDynArrayHashOne; aCompare: TDynArraySortCompare; - aFreeItems: boolean); -begin - inherited Create(aFreeItems); - fSubPropAccess := aSubPropAccess; - if Assigned(aHashElement) then - fHash.fHash.HashElement := aHashElement; - if Assigned(aCompare) then - fHash.fHash.Compare := aCompare; - fHash.EventCompare := IntComp; - fHash.EventHash := IntHash; -end; - -function TObjectListPropertyHashed.IntHash(const Elem): cardinal; -var O: TObject; -begin - O := fSubPropAccess(TObject(Elem)); - result := fHash.fHash.HashElement(O,fHash.fHash.Hasher); -end; - -function TObjectListPropertyHashed.IntComp(const A,B): integer; -var O: TObject; -begin - O := fSubPropAccess(TObject(A)); - result := fHash.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare(O,B); -end; - -function TObjectListPropertyHashed.Add(aObject: TObject; out wasAdded: boolean): integer; -begin - wasAdded := false; - if self<>nil then begin - result := fHash.FindHashedForAdding(aObject,wasAdded, - fHash.fHash.HashElement(aObject,fHash.fHash.Hasher)); - if wasAdded then - fList[result] := aObject; - end else - result := -1; -end; - -function TObjectListPropertyHashed.IndexOf(aObject: TObject): integer; -var h: cardinal; -begin - if fCount>0 then begin - h := fHash.fHash.HashElement(aObject,fHash.fHash.Hasher); - result := fHash.fHash.FindOrNew(h,@aObject); // fallback to Scan() if needed - if result>=0 then - exit else // found - result := -1; // for consistency - end else - result := -1; -end; - -{ TPointerClassHashed } - -constructor TPointerClassHashed.Create(aInfo: pointer); -begin - fInfo := aInfo; -end; - -{ TPointerClassHash } - -function PointerClassHashProcess(aObject: TPointerClassHashed): pointer; -begin - if aObject=nil then // may happen for Rehash after SetCount(n+1) - result := nil else - result := aObject.Info; -end; - -constructor TPointerClassHash.Create; -begin - inherited Create(@PointerClassHashProcess); -end; - -function TPointerClassHash.TryAdd(aInfo: pointer): PPointerClassHashed; -var wasAdded: boolean; - i: integer; -begin - i := inherited Add(aInfo,wasAdded); - if wasAdded then - result := @List[i] else - result := nil; -end; - -function TPointerClassHash.Find(aInfo: pointer): TPointerClassHashed; -var i: integer; - p: ^TPointerClassHashed; -begin - if self<>nil then begin - if fCount<64 then begin // brute force is faster for small count - p := pointer(List); - for i := 1 to fCount do begin - result := p^; - if result.fInfo=aInfo then - exit; - inc(p); - end; - end else begin - i := IndexOf(aInfo); // use hashing - if i>=0 then begin - result := TPointerClassHashed(List[i]); - exit; - end; - end; - end; - result := nil; -end; - -{ TPointerClassHashLocked } - -constructor TPointerClassHashLocked.Create; -begin - inherited Create; - fSafe.Init; -end; - -destructor TPointerClassHashLocked.Destroy; -begin - fSafe.Done; - inherited Destroy; -end; - -function TPointerClassHashLocked.FindLocked(aInfo: pointer): TPointerClassHashed; -begin - if self=nil then - result := nil else begin - fSafe.Lock; - try - result := inherited Find(aInfo); - finally - fSafe.UnLock; - end; - end; -end; - -function TPointerClassHashLocked.TryAddLocked(aInfo: pointer; - out aNewEntry: PPointerClassHashed): boolean; -var wasAdded: boolean; - i: integer; -begin - fSafe.Lock; - i := inherited Add(aInfo,wasAdded); - if wasAdded then begin - aNewEntry := @List[i]; - result := true; // caller should call Unlock - end else begin - fSafe.UnLock; - result := false; - end; -end; - -procedure TPointerClassHashLocked.Unlock; -begin - fSafe.UnLock; -end; - - -{ TSynDictionary } - -const - DIC_KEYCOUNT = 0; - DIC_KEY = 1; - DIC_VALUECOUNT = 2; - DIC_VALUE = 3; - DIC_TIMECOUNT = 4; - DIC_TIMESEC = 5; - DIC_TIMETIX = 6; - -function TSynDictionary.KeyFullHash(const Elem): cardinal; -begin - result := fKeys.fHash.Hasher(0,@Elem,fKeys.ElemSize); -end; - -function TSynDictionary.KeyFullCompare(const A,B): integer; -var i: PtrInt; -begin - - for i := 0 to fKeys.ElemSize-1 do begin - result := TByteArray(A)[i]-TByteArray(B)[i]; - if result<>0 then - exit; - end; - result := 0; -end; - -constructor TSynDictionary.Create(aKeyTypeInfo,aValueTypeInfo: pointer; - aKeyCaseInsensitive: boolean; aTimeoutSeconds: cardinal; aCompressAlgo: TAlgoCompress); -begin - inherited Create; - fSafe.Padding[DIC_KEYCOUNT].VType := varInteger; - fSafe.Padding[DIC_KEY].VType := varUnknown; - fSafe.Padding[DIC_VALUECOUNT].VType := varInteger; - fSafe.Padding[DIC_VALUE].VType := varUnknown; - fSafe.Padding[DIC_TIMECOUNT].VType := varInteger; - fSafe.Padding[DIC_TIMESEC].VType := varInteger; - fSafe.Padding[DIC_TIMETIX].VType := varInteger; - fSafe.PaddingUsedCount := DIC_TIMETIX+1; - fKeys.Init(aKeyTypeInfo,fSafe.Padding[DIC_KEY].VAny,nil,nil,nil, - @fSafe.Padding[DIC_KEYCOUNT].VInteger,aKeyCaseInsensitive); - if not Assigned(fKeys.HashElement) then - fKeys.EventHash := KeyFullHash; - if not Assigned(fKeys.{$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare) then - fKeys.EventCompare := KeyFullCompare; - fValues.Init(aValueTypeInfo,fSafe.Padding[DIC_VALUE].VAny, - @fSafe.Padding[DIC_VALUECOUNT].VInteger); - fTimeouts.Init(TypeInfo(TIntegerDynArray),fTimeOut,@fSafe.Padding[DIC_TIMECOUNT].VInteger); - if aCompressAlgo=nil then - aCompressAlgo := AlgoSynLZ; - fCompressAlgo := aCompressAlgo; - fSafe.Padding[DIC_TIMESEC].VInteger := aTimeoutSeconds; -end; - -function TSynDictionary.ComputeNextTimeOut: cardinal; -begin - result := fSafe.Padding[DIC_TIMESEC].VInteger; - if result<>0 then - result := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+result; -end; - -function TSynDictionary.GetCapacity: integer; -begin - fSafe.Lock; - result := fKeys.GetCapacity; - fSafe.UnLock; -end; - -procedure TSynDictionary.SetCapacity(const Value: integer); -begin - fSafe.Lock; - fKeys.Capacity := Value; - fValues.Capacity := Value; - if fSafe.Padding[DIC_TIMESEC].VInteger>0 then - fTimeOuts.Capacity := Value; - fSafe.UnLock; -end; - -function TSynDictionary.GetTimeOutSeconds: cardinal; -begin - result := fSafe.Padding[DIC_TIMESEC].VInteger; -end; - -procedure TSynDictionary.SetTimeouts; -var i: PtrInt; - timeout: cardinal; -begin - if fSafe.Padding[DIC_TIMESEC].VInteger=0 then - exit; - fTimeOuts.SetCount(fSafe.Padding[DIC_KEYCOUNT].VInteger); - timeout := ComputeNextTimeOut; - for i := 0 to fSafe.Padding[DIC_TIMECOUNT].VInteger-1 do - fTimeOut[i] := timeout; -end; - -function TSynDictionary.DeleteDeprecated: integer; -var i: PtrInt; - now: cardinal; -begin - result := 0; - if (self=nil) or (fSafe.Padding[DIC_TIMECOUNT].VInteger=0) or // no entry - (fSafe.Padding[DIC_TIMESEC].VInteger=0) then // nothing in fTimeOut[] - exit; - now := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10; - if fSafe.Padding[DIC_TIMETIX].VInteger=integer(now) then - exit; // no need to search more often than every second - fSafe.Lock; - try - fSafe.Padding[DIC_TIMETIX].VInteger := now; - for i := fSafe.Padding[DIC_TIMECOUNT].VInteger-1 downto 0 do - if (now>fTimeOut[i]) and (fTimeOut[i]<>0) and - (not Assigned(fOnCanDelete) or - fOnCanDelete(fKeys.ElemPtr(i)^,fValues.ElemPtr(i)^,i)) then begin - fKeys.Delete(i); - fValues.Delete(i); - fTimeOuts.Delete(i); - inc(result); - end; - if result>0 then - fKeys.Rehash; // mandatory after fKeys.Delete(i) - finally - fSafe.UnLock; - end; -end; - -procedure TSynDictionary.DeleteAll; -begin - if self=nil then - exit; - fSafe.Lock; - try - fKeys.Clear; - fKeys.Hasher.Clear; // mandatory to avoid GPF - fValues.Clear; - if fSafe.Padding[DIC_TIMESEC].VInteger>0 then - fTimeOuts.Clear; - finally - fSafe.UnLock; - end; -end; - -destructor TSynDictionary.Destroy; -begin - fKeys.Clear; - fValues.Clear; - inherited Destroy; -end; - -function TSynDictionary.Add(const aKey, aValue): integer; -var added: boolean; - tim: cardinal; -begin - fSafe.Lock; - try - result := fKeys.FindHashedForAdding(aKey,added); - if added then begin - with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do - ElemCopyFrom(aKey,result); // fKey[result] := aKey; - if fValues.Add(aValue)<>result then - raise ESynException.CreateUTF8('%.Add fValues.Add',[self]); - tim := ComputeNextTimeOut; - if tim>0 then - fTimeOuts.Add(tim); - end else - result := -1; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.AddOrUpdate(const aKey, aValue): integer; -var added: boolean; - tim: cardinal; -begin - fSafe.Lock; - try - tim := ComputeNextTimeOut; - result := fKeys.FindHashedForAdding(aKey,added); - if added then begin - with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do - ElemCopyFrom(aKey,result); // fKey[result] := aKey - if fValues.Add(aValue)<>result then - raise ESynException.CreateUTF8('%.AddOrUpdate fValues.Add',[self]); - if tim<>0 then - fTimeOuts.Add(tim); - end else begin - fValues.ElemCopyFrom(aValue,result,{ClearBeforeCopy=}true); - if tim<>0 then - fTimeOut[result] := tim; - end; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.Clear(const aKey): integer; -begin - fSafe.Lock; - try - result := fKeys.FindHashed(aKey); - if result>=0 then begin - fValues.ElemClear(fValues.ElemPtr(result)^); - if fSafe.Padding[DIC_TIMESEC].VInteger>0 then - fTimeOut[result] := 0; - end; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.Delete(const aKey): integer; -begin - fSafe.Lock; - try - result := fKeys.FindHashedAndDelete(aKey); - if result>=0 then begin - fValues.Delete(result); - if fSafe.Padding[DIC_TIMESEC].VInteger>0 then - fTimeOuts.Delete(result); - end; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.DeleteAt(aIndex: integer): boolean; -begin - if cardinal(aIndex)tkDynArray) then - raise ESynException.CreateUTF8('%.Values: % items are not dynamic arrays', - [self,fValues.ArrayTypeShort^]); - fSafe.Lock; - try - ndx := fKeys.FindHashed(aKey); - if ndx<0 then - exit; - nested.Init(fValues.ElemType,fValues.ElemPtr(ndx)^); - case aAction of - iaFind: - result := nested.Find(aArrayValue)>=0; - iaFindAndDelete: - result := nested.FindAndDelete(aArrayValue)>=0; - iaFindAndUpdate: - result := nested.FindAndUpdate(aArrayValue)>=0; - iaFindAndAddIfNotExisting: - result := nested.FindAndAddIfNotExisting(aArrayValue)>=0; - iaAdd: - result := nested.Add(aArrayValue)>=0; - end; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.FindInArray(const aKey, aArrayValue): boolean; -begin - result := InArray(aKey,aArrayValue,iaFind); -end; - -function TSynDictionary.FindKeyFromValue(const aValue; out aKey; - aUpdateTimeOut: boolean): boolean; -var ndx: integer; -begin - fSafe.Lock; - try - ndx := fValues.IndexOf(aValue); - result := ndx>=0; - if result then begin - fKeys.ElemCopyAt(ndx,aKey); - if aUpdateTimeOut then - SetTimeoutAtIndex(ndx); - end; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.DeleteInArray(const aKey, aArrayValue): boolean; -begin - result := InArray(aKey,aArrayValue,iaFindAndDelete); -end; - -function TSynDictionary.UpdateInArray(const aKey, aArrayValue): boolean; -begin - result := InArray(aKey,aArrayValue,iaFindAndUpdate); -end; - -function TSynDictionary.AddInArray(const aKey, aArrayValue): boolean; -begin - result := InArray(aKey,aArrayValue,iaAdd); -end; - -function TSynDictionary.AddOnceInArray(const aKey, aArrayValue): boolean; -begin - result := InArray(aKey,aArrayValue,iaFindAndAddIfNotExisting); -end; - -function TSynDictionary.Find(const aKey; aUpdateTimeOut: boolean): integer; -var tim: cardinal; -begin // caller is expected to call fSafe.Lock/Unlock - if self=nil then - result := -1 else - result := fKeys.FindHashed(aKey); - if aUpdateTimeOut and (result>=0) then begin - tim := fSafe.Padding[DIC_TIMESEC].VInteger; - if tim>0 then // inlined fTimeout[result] := GetTimeout - fTimeout[result] := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim; - end; -end; - -function TSynDictionary.FindValue(const aKey; aUpdateTimeOut: boolean; aIndex: PInteger): pointer; -var ndx: PtrInt; -begin - ndx := Find(aKey,aUpdateTimeOut); - if aIndex<>nil then - aIndex^ := ndx; - if ndx<0 then - result := nil else - result := pointer(PtrUInt(fValues.fValue^)+PtrUInt(ndx)*fValues.ElemSize); -end; - -function TSynDictionary.FindValueOrAdd(const aKey; var added: boolean; - aIndex: PInteger): pointer; -var ndx: integer; - tim: cardinal; -begin - tim := fSafe.Padding[DIC_TIMESEC].VInteger; // inlined tim := GetTimeout - if tim<>0 then - tim := cardinal({$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64 shr 10)+tim; - ndx := fKeys.FindHashedForAdding(aKey,added); - if added then begin - with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do - ElemCopyFrom(aKey,ndx); // fKey[i] := aKey - fValues.SetCount(ndx+1); // reserve new place for associated value - if tim>0 then - fTimeOuts.Add(tim); - end else - if tim>0 then - fTimeOut[ndx] := tim; - if aIndex<>nil then - aIndex^ := ndx; - result := fValues.ElemPtr(ndx); -end; - -function TSynDictionary.FindAndCopy(const aKey; out aValue; aUpdateTimeOut: boolean): boolean; -var ndx: integer; -begin - fSafe.Lock; - try - ndx := Find(aKey, aUpdateTimeOut); - if ndx>=0 then begin - fValues.ElemCopyAt(ndx,aValue); - result := true; - end else - result := false; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.FindAndExtract(const aKey; out aValue): boolean; -var ndx: integer; -begin - fSafe.Lock; - try - ndx := fKeys.FindHashedAndDelete(aKey); - if ndx>=0 then begin - fValues.ElemCopyAt(ndx,aValue); - fValues.Delete(ndx); - if fSafe.Padding[DIC_TIMESEC].VInteger>0 then - fTimeOuts.Delete(ndx); - result := true; - end else - result := false; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.Exists(const aKey): boolean; -begin - fSafe.Lock; - try - result := fKeys.FindHashed(aKey)>=0; - finally - fSafe.UnLock; - end; -end; - -{$ifndef DELPHI5OROLDER} -procedure TSynDictionary.CopyValues(out Dest; ObjArrayByRef: boolean); -begin - fSafe.Lock; - try - fValues.CopyTo(Dest,ObjArrayByRef); - finally - fSafe.UnLock; - end; -end; -{$endif DELPHI5OROLDER} - -function TSynDictionary.ForEach(const OnEach: TSynDictionaryEvent; Opaque: pointer): integer; -var k,v: PAnsiChar; - i,n,ks,vs: integer; -begin - result := 0; - fSafe.Lock; - try - n := fSafe.Padding[DIC_KEYCOUNT].VInteger; - if (n=0) or not Assigned(OnEach) then - exit; - k := fKeys.Value^; - ks := fKeys.ElemSize; - v := fValues.Value^; - vs := fValues.ElemSize; - for i := 0 to n-1 do begin - inc(result); - if not OnEach(k^,v^,i,n,Opaque) then - break; - inc(k,ks); - inc(v,vs); - end; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.ForEach(const OnMatch: TSynDictionaryEvent; - KeyCompare,ValueCompare: TDynArraySortCompare; const aKey,aValue; - Opaque: pointer): integer; -var k,v: PAnsiChar; - i,n,ks,vs: integer; -begin - fSafe.Lock; - try - result := 0; - if not Assigned(OnMatch) or - (not Assigned(KeyCompare) 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 := DefaultTextWriterSerializer.CreateOwnedStream(temp); - try - SaveToJSON(W,EnumSetsAsText); - W.SetText(result); - finally - W.Free; - end; -end; - -function TSynDictionary.SaveValuesToJSON(EnumSetsAsText: boolean): RawUTF8; -begin - fSafe.Lock; - try - fValues.SaveToJSON(result,EnumSetsAsText); - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.LoadFromJSON(const JSON: RawUTF8 - {$ifndef NOVARIANTS}; CustomVariantOptions: PDocVariantOptions{$endif}): boolean; -begin // pointer(JSON) is not modified in-place thanks to JSONObjectAsJSONArrays() - result := LoadFromJSON(pointer(JSON){$ifndef NOVARIANTS},CustomVariantOptions{$endif}); -end; - -function TSynDictionary.LoadFromJSON(JSON: PUTF8Char{$ifndef NOVARIANTS}; - CustomVariantOptions: PDocVariantOptions{$endif}): boolean; -var k,v: RawUTF8; // private copy of the JSON input, expanded as Keys/Values arrays -begin - result := false; - if not JSONObjectAsJSONArrays(JSON,k,v) then - exit; - fSafe.Lock; - try - if fKeys.LoadFromJSON(pointer(k),nil{$ifndef NOVARIANTS},CustomVariantOptions{$endif})<>nil then - if fValues.LoadFromJSON(pointer(v),nil{$ifndef NOVARIANTS},CustomVariantOptions{$endif})<>nil then - if fKeys.Count=fValues.Count then begin - SetTimeouts; - fKeys.Rehash; // warning: duplicated keys won't be identified - result := true; - end; - finally - fSafe.UnLock; - end; -end; - -function TSynDictionary.LoadFromBinary(const binary: RawByteString): boolean; -var plain: RawByteString; - P,PEnd: PAnsiChar; -begin - result := false; - plain := fCompressAlgo.Decompress(binary); - P := pointer(plain); - if P=nil then - exit; - PEnd := P+length(plain); - fSafe.Lock; - try - P := fKeys.LoadFrom(P,nil,{checkhash=}false,PEnd); - if P<>nil then - P := fValues.LoadFrom(P,nil,{checkhash=}false,PEnd); - if (P<>nil) and (fKeys.Count=fValues.Count) then begin - SetTimeouts; // set ComputeNextTimeOut for all items - fKeys.ReHash; // optimistic: input from safe TSynDictionary.SaveToBinary - result := true; - end; - finally - fSafe.UnLock; - end; -end; - -class function TSynDictionary.OnCanDeleteSynPersistentLock(const aKey, aValue; - aIndex: integer): boolean; -begin - result := not TSynPersistentLock(aValue).Safe^.IsLocked; -end; - -class function TSynDictionary.OnCanDeleteSynPersistentLocked(const aKey, aValue; - aIndex: integer): boolean; -begin - result := not TSynPersistentLock(aValue).Safe.IsLocked; -end; - -function TSynDictionary.SaveToBinary(NoCompression: boolean): RawByteString; -var tmp: TSynTempBuffer; - trigger: integer; -begin - fSafe.Lock; - try - result := ''; - if fSafe.Padding[DIC_KEYCOUNT].VInteger = 0 then - exit; - tmp.Init(fKeys.SaveToLength+fValues.SaveToLength); - if fValues.SaveTo(fKeys.SaveTo(tmp.buf))-PAnsiChar(tmp.buf)=tmp.len then begin - if NoCompression then - trigger := maxInt else - trigger := 128; - result := fCompressAlgo.Compress(tmp.buf,tmp.len,trigger); - end; - tmp.Done; - finally - fSafe.UnLock; - end; -end; - - -{ TMemoryMap } - -function TMemoryMap.Map(aFile: THandle; aCustomSize: PtrUInt; aCustomOffset: Int64): boolean; -var Available: Int64; -begin - fBuf := nil; - fBufSize := 0; - {$ifdef MSWINDOWS} - fMap := 0; - {$endif} - fFileLocal := false; - fFile := aFile; - fFileSize := FileSeek64(fFile,0,soFromEnd); - if fFileSize=0 then begin - result := true; // handle 0 byte file without error (but no memory map) - exit; - end; - result := false; - if (fFileSize<=0) {$ifdef CPU32}or (fFileSize>maxInt){$endif} then - /// maxInt = $7FFFFFFF = 1.999 GB (2GB would induce PtrInt errors) - exit; - if aCustomSize=0 then - fBufSize := fFileSize else begin - Available := fFileSize-aCustomOffset; - if Available<0 then - exit; - if aCustomSize>Available then - fBufSize := Available; - fBufSize := aCustomSize; - end; - {$ifdef MSWINDOWS} - with PInt64Rec(@fFileSize)^ do - fMap := CreateFileMapping(fFile,nil,PAGE_READONLY,Hi,Lo,nil); - if fMap=0 then - raise ESynException.Create('TMemoryMap.Map: CreateFileMapping()=0'); - with PInt64Rec(@aCustomOffset)^ do - fBuf := MapViewOfFile(fMap,FILE_MAP_READ,Hi,Lo,fBufSize); - if fBuf=nil then begin - // Windows failed to find a contiguous VA space -> fall back on direct read - CloseHandle(fMap); - fMap := 0; - {$else} - if aCustomOffset<>0 then - if aCustomOffset and (SystemInfo.dwPageSize-1)<>0 then - raise ESynException.CreateUTF8('fpmmap(aCustomOffset=%) with SystemInfo.dwPageSize=%', - [aCustomOffset,SystemInfo.dwPageSize]) else - aCustomOffset := aCustomOffset div SystemInfo.dwPageSize; - fBuf := {$ifdef KYLIX3}mmap{$else}fpmmap{$endif}( - nil,fBufSize,PROT_READ,MAP_SHARED,fFile,aCustomOffset); - if fBuf=MAP_FAILED then begin - fBuf := nil; - {$endif} - end else - result := true; -end; - -procedure TMemoryMap.Map(aBuffer: pointer; aBufferSize: PtrUInt); -begin - fBuf := aBuffer; - fFileSize := aBufferSize; - fBufSize := aBufferSize; - {$ifdef MSWINDOWS} - fMap := 0; - {$endif} - fFile := 0; - fFileLocal := false; -end; - -function TMemoryMap.Map(const aFileName: TFileName): boolean; -var F: THandle; -begin - result := false; - // Memory-mapped file access does not go through the cache manager so - // using FileOpenSequentialRead() is pointless here - F := FileOpen(aFileName,fmOpenRead or fmShareDenyNone); - if PtrInt(F)<0 then - exit; - if Map(F) then - result := true else - FileClose(F); - fFileLocal := result; -end; - -procedure TMemoryMap.UnMap; -begin - {$ifdef MSWINDOWS} - if fMap<>0 then begin - UnmapViewOfFile(fBuf); - CloseHandle(fMap); - fMap := 0; - end; - {$else} - if (fBuf<>nil) and (fBufSize>0) and (fFile<>0) then - {$ifdef KYLIX3}munmap{$else}fpmunmap{$endif}(fBuf,fBufSize); - {$endif} - fBuf := nil; - fBufSize := 0; - if fFile<>0 then begin - if fFileLocal then - FileClose(fFile); - fFile := 0; - end; -end; - - -{ TSynMemoryStream } - -constructor TSynMemoryStream.Create(const aText: RawByteString); -begin - inherited Create; - SetPointer(pointer(aText),length(aText)); -end; - -constructor TSynMemoryStream.Create(Data: pointer; DataLen: PtrInt); -begin - inherited Create; - SetPointer(Data,DataLen); -end; - -function TSynMemoryStream.Write(const Buffer; Count: Integer): Longint; -begin - {$ifdef FPC} - result := 0; // makes FPC compiler happy - {$endif} - raise EStreamError.CreateFmt('Unexpected %s.Write',[ClassNameShort(self)^]); -end; - - -{ TSynMemoryStreamMapped } - -constructor TSynMemoryStreamMapped.Create(const aFileName: TFileName; - aCustomSize: PtrUInt; aCustomOffset: Int64); -begin - fFileName := aFileName; - // Memory-mapped file access does not go through the cache manager so - // using FileOpenSequentialRead() is pointless here - fFileStream := TFileStream.Create(aFileName,fmOpenRead or fmShareDenyNone); - Create(fFileStream.Handle,aCustomSize,aCustomOffset); -end; - -constructor TSynMemoryStreamMapped.Create(aFile: THandle; - aCustomSize: PtrUInt; aCustomOffset: Int64); -begin - if not fMap.Map(aFile,aCustomSize,aCustomOffset) then - raise ESynException.CreateUTF8('%.Create(%) mapping error',[self,fFileName]); - inherited Create(fMap.fBuf,fMap.fBufSize); -end; - -destructor TSynMemoryStreamMapped.Destroy; -begin - fMap.UnMap; - fFileStream.Free; - inherited; -end; - -function FileSeek64(Handle: THandle; const Offset: Int64; Origin: DWORD): Int64; -{$ifdef MSWINDOWS} -var R64: packed record Lo, Hi: integer; end absolute Result; -begin - Result := Offset; - R64.Lo := integer(SetFilePointer(Handle,R64.Lo,@R64.Hi,Origin)); - if (R64.Lo=-1) and (GetLastError<>0) then - R64.Hi := -1; // so result=-1 -end; -{$else} -begin - {$ifdef FPC} - result := FPLSeek(Handle,Offset,Origin); - {$else} - {$ifdef KYLIX3} - result := LibC.lseek64(Handle,Offset,Origin); - {$else} - // warning: this won't handle file size > 2 GB :( - result := FileSeek(Handle,Offset,Origin); - {$endif} - {$endif} -end; -{$endif} - -function PropNameValid(P: PUTF8Char): boolean; -var tab: PTextCharSet; -begin - result := false; - tab := @TEXT_CHARS; - if (P=nil) or not (tcIdentifierFirstChar in tab[P^]) then - exit; // first char must be alphabetical - repeat - inc(P); // following chars can be alphanumerical - if tcIdentifier in tab[P^] then - continue; - if P^=#0 then - break; - exit; - until false; - result := true; -end; - -function PropNamesValid(const Values: array of RawUTF8): boolean; -var i,j: integer; - tab: PTextCharSet; -begin - result := false; - tab := @TEXT_CHARS; - for i := 0 to high(Values) do - for j := 1 to length(Values[i]) do - if not (tcIdentifier in tab[Values[i][j]]) then - exit; - result := true; -end; - -function JsonPropNameValid(P: PUTF8Char): boolean; -var tab: PJsonCharSet; -begin - tab := @JSON_CHARS; - if (P<>nil) and (jcJsonIdentifierFirstChar in tab[P^]) then begin - repeat - inc(P); - until not(jcJsonIdentifier in tab[P^]); - result := P^ = #0; - end else - result := false; -end; - -function StrCompL(P1,P2: PUTF8Char; L, Default: Integer): PtrInt; -var i: PtrInt; -begin - i := 0; - repeat - result := PtrInt(P1[i])-PtrInt(P2[i]); - if result=0 then begin - inc(i); - if inil then begin - f := PInt64(FieldName)^; - result := (f and $ffdfdf=(ord('I')+ord('D')shl 8)) or (f and $ffdfdfdfdfdf= - (ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24+Int64(ord('D')) shl 32)) - end -{$else} -begin - if FieldName<>nil then - result := (PInteger(FieldName)^ and $ffdfdf=ord('I')+ord('D')shl 8) or - ((PIntegerArray(FieldName)^[0] and $dfdfdfdf= - ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24) and - (PIntegerArray(FieldName)^[1] and $ffdf=ord('D'))) -{$endif} else result := false; -end; - -function IsRowID(FieldName: PUTF8Char; FieldLen: integer): boolean; -begin - case FieldLen of - 2: result := - PWord(FieldName)^ and $dfdf=ord('I')+ord('D')shl 8; - 5: result := - (PInteger(FieldName)^ and $dfdfdfdf= - ord('R')+ord('O')shl 8+ord('W')shl 16+ord('I')shl 24) and - (ord(FieldName[4]) and $df=ord('D')); - else result := false; - end; -end; - -function IsRowIDShort(const FieldName: shortstring): boolean; -begin - result := - (PInteger(@FieldName)^ and $DFDFFF= - 2+ord('I')shl 8+ord('D')shl 16) or - ((PIntegerArray(@FieldName)^[0] and $dfdfdfff= - 5+ord('R')shl 8+ord('O')shl 16+ord('W')shl 24) and - (PIntegerArray(@FieldName)^[1] and $dfdf= - ord('I')+ord('D')shl 8)); -end; - -function GotoNextSqlIdentifier(P: PUtf8Char; tab: PTextCharSet): PUtf8Char; - {$ifdef HASINLINE} inline; {$endif} -begin - while tcCtrlNot0Comma in tab[P^] do inc(P); // in [#1..' ', ';'] - if PWord(P)^=ord('/')+ord('*') shl 8 then begin // ignore e.g. '/*nocache*/' - repeat - inc(P); - if PWord(P)^ = ord('*')+ord('/') shl 8 then begin - inc(P, 2); - break; - end; - until P^ = #0; - while tcCtrlNot0Comma in tab[P^] do inc(P); - end; - result := P; -end; - -function GetNextFieldProp(var P: PUTF8Char; var Prop: RawUTF8): boolean; -var B: PUTF8Char; - tab: PTextCharSet; -begin - tab := @TEXT_CHARS; - P := GotoNextSqlIdentifier(P, tab); - B := P; - while tcIdentifier in tab[P^] do inc(P); // go to end of field name - FastSetString(Prop,B,P-B); - P := GotoNextSqlIdentifier(P, tab); - result := Prop<>''; -end; - -function GetNextFieldPropSameLine(var P: PUTF8Char; var Prop: ShortString): boolean; -var B: PUTF8Char; - tab: PTextCharSet; -begin - tab := @TEXT_CHARS; - while tcCtrlNotLF in tab[P^] do inc(P); - B := P; - while tcIdentifier in tab[P^] do inc(P); // go to end of field name - SetString(Prop,PAnsiChar(B),P-B); - while tcCtrlNotLF in TEXT_CHARS[P^] do inc(P); - result := Prop<>''; -end; - - -type - TSynLZHead = packed record - Magic: cardinal; - CompressedSize: integer; - HashCompressed: cardinal; - UnCompressedSize: integer; - HashUncompressed: cardinal; - end; - PSynLZHead = ^TSynLZHead; - TSynLZTrailer = packed record - HeaderRelativeOffset: cardinal; - Magic: cardinal; - end; - PSynLZTrailer = ^TSynLZTrailer; - -function StreamSynLZComputeLen(P: PAnsiChar; Len, aMagic: cardinal): integer; -begin - if (P=nil) or (Len<=SizeOf(TSynLZTrailer)) then - result := 0 else - with PSynLZTrailer(P+Len-SizeOf(TSynLZTrailer))^ do - if (Magic=aMagic) and (HeaderRelativeOffset0 then // '' is compressed and uncompressed to '' - if Compress then begin - len := SynLZcompressdestlen(DataLen)+8; - SetString(result,nil,len); - P := pointer(result); - PCardinal(P)^ := Hash32(pointer(Data),DataLen); - len := SynLZcompress1(pointer(Data),DataLen,P+8); - PCardinal(P+4)^ := Hash32(pointer(P+8),len); - SetString(Data,P,len+8); - end else begin - result := ''; - P := pointer(Data); - if (DataLen<=8) or (Hash32(pointer(P+8),DataLen-8)<>PCardinal(P+4)^) then - exit; - len := SynLZdecompressdestlen(P+8); - SetLength(result,len); - if (len<>0) and ((SynLZDecompress1(P+8,DataLen-8,pointer(result))<>len) or - (Hash32(pointer(result),len)<>PCardinal(P)^)) then begin - result := ''; - exit; - end else - SetString(Data,PAnsiChar(pointer(result)),len); - end; - result := 'synlz'; -end; - -function StreamSynLZ(Source: TCustomMemoryStream; Dest: TStream; Magic: cardinal): integer; -var DataLen: integer; - S,D: pointer; - Head: TSynLZHead; - Trailer: TSynLZTrailer; - tmp: TSynTempBuffer; -begin - if Dest=nil then begin - result := 0; - exit; - end; - if Source<>nil then begin - S := Source.Memory; - DataLen := Source.Size; - end else begin - S := nil; - DataLen := 0; - end; - tmp.Init(SynLZcompressdestlen(DataLen)); - try - Head.Magic := Magic; - Head.UnCompressedSize := DataLen; - Head.HashUncompressed := Hash32(S,DataLen); - result := SynLZcompress1(S,DataLen,tmp.buf); - if result>tmp.len then - raise ESynException.Create('StreamLZ: SynLZ compression overflow'); - if result>DataLen then begin - result := DataLen; // compression not worth it - D := S; - end else - D := tmp.buf; - Head.CompressedSize := result; - Head.HashCompressed := Hash32(D,result); - Dest.WriteBuffer(Head,SizeOf(Head)); - Dest.WriteBuffer(D^,Head.CompressedSize); - Trailer.HeaderRelativeOffset := result+(SizeOf(Head)+SizeOf(Trailer)); - Trailer.Magic := Magic; - Dest.WriteBuffer(Trailer,SizeOf(Trailer)); - result := Head.CompressedSize+(SizeOf(Head)+SizeOf(Trailer)); - finally - tmp.Done; - end; -end; - -function StreamSynLZ(Source: TCustomMemoryStream; const DestFile: TFileName; - Magic: cardinal): integer; -var F: TFileStream; -begin - F := TFileStream.Create(DestFile,fmCreate); - try - result := StreamSynLZ(Source,F,Magic); - finally - F.Free; - end; -end; - -function FileSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; -var src,dst: RawByteString; - S,D: THandleStream; - Head: TSynLZHead; - Count,Max: Int64; -begin - result := false; - if FileExists(Source) then - try - S := FileStreamSequentialRead(Source); - try - DeleteFile(Dest); - Max := 128 shl 20; // 128 MB default compression chunk - D := TFileStream.Create(Dest,fmCreate); - try - Head.Magic := Magic; - Count := S.Size; - while Count>0 do begin - if Count>Max then - Head.UnCompressedSize := Max else - Head.UnCompressedSize := Count; - if src='' then - SetString(src,nil,Head.UnCompressedSize); - if dst='' then - SetString(dst,nil,SynLZcompressdestlen(Head.UnCompressedSize)); - Head.UnCompressedSize := S.Read(pointer(src)^,Head.UnCompressedSize); - {$ifdef MSWINDOWS} - if (Head.UnCompressedSize<=0) and - (GetLastError=ERROR_NO_SYSTEM_RESOURCES) then begin - Max := 32 shl 20; // we observed a 32MB chunk size limitation on XP - Head.UnCompressedSize := S.Read(pointer(src)^,Max); - end; - {$endif MSWINDOWS} - if Head.UnCompressedSize<=0 then - exit; // read error - Head.HashUncompressed := Hash32(pointer(src),Head.UnCompressedSize); - Head.CompressedSize := - SynLZcompress1(pointer(src),Head.UnCompressedSize,pointer(dst)); - Head.HashCompressed := Hash32(pointer(dst),Head.CompressedSize); - if (D.Write(Head,SizeOf(Head))<>SizeOf(Head)) or - (D.Write(pointer(dst)^,Head.CompressedSize)<>Head.CompressedSize) then - exit; - dec(Count,Head.UnCompressedSize); - end; - finally - D.Free; - end; - result := FileSetDateFrom(Dest,S.Handle); - finally - S.Free; - end; - except - on Exception do - result := false; - end; -end; - -function FileUnSynLZ(const Source, Dest: TFileName; Magic: Cardinal): boolean; -var src,dst: RawByteString; - S,D: THandleStream; - Count: Int64; - Head: TSynLZHead; -begin - result := false; - if FileExists(Source) then - try - S := FileStreamSequentialRead(Source); - try - DeleteFile(Dest); - D := TFileStream.Create(Dest,fmCreate); - try - Count := S.Size; - while Count>0 do begin - if S.Read(Head,SizeOf(Head))<>SizeOf(Head) then - exit; - dec(Count,SizeOf(Head)); - if (Head.Magic<>Magic) or - (Head.CompressedSize>Count) then - exit; - if Head.CompressedSize>length(src) then - SetString(src,nil,Head.CompressedSize); - if S.Read(pointer(src)^,Head.CompressedSize)<>Head.CompressedSize then - exit; - dec(Count,Head.CompressedSize); - if (Hash32(pointer(src),Head.CompressedSize)<>Head.HashCompressed) or - (SynLZdecompressdestlen(pointer(src))<>Head.UnCompressedSize) then - exit; - if Head.UnCompressedSize>length(dst) then - SetString(dst,nil,Head.UnCompressedSize); - if (SynLZDecompress1(pointer(src),Head.CompressedSize,pointer(dst))<>Head.UnCompressedSize) or - (Hash32(pointer(dst),Head.UnCompressedSize)<>Head.HashUncompressed) then - exit; - if D.Write(pointer(dst)^,Head.UncompressedSize)<>Head.UncompressedSize then - exit; - end; - finally - D.Free; - end; - result := FileSetDateFrom(Dest,S.Handle); - finally - S.Free; - end; - except - on Exception do - result := false; - end; -end; - -function FileIsSynLZ(const Name: TFileName; Magic: Cardinal): boolean; -var S: TFileStream; - Head: TSynLZHead; -begin - result := false; - if FileExists(Name) then - try - S := TFileStream.Create(Name,fmOpenRead or fmShareDenyNone); - try - if S.Read(Head,SizeOf(Head))=SizeOf(Head) then - if Head.Magic=Magic then - result := true; // only check magic, since there may be several chunks - finally - S.Free; - end; - except - on Exception do - result := false; - end; -end; - -function StreamUnSynLZ(const Source: TFileName; Magic: cardinal): TMemoryStream; -var S: TStream; -begin - try - S := TSynMemoryStreamMapped.Create(Source); - try - result := StreamUnSynLZ(S,Magic); - finally - S.Free; - end; - except - on E: Exception do - result := nil; - end; -end; - -function StreamUnSynLZ(Source: TStream; Magic: cardinal): TMemoryStream; -var S,D: PAnsiChar; - sourcePosition,resultSize,sourceSize: Int64; - Head: TSynLZHead; - Trailer: TSynLZTrailer; - buf: RawByteString; - stored: boolean; -begin - result := nil; - if Source=nil then - exit; - sourceSize := Source.Size; - {$ifndef CPU64} - if sourceSize>maxInt then - exit; // result TMemoryStream should stay in memory! - {$endif} - sourcePosition := Source.Position; - if sourceSize-sourcePositionSizeOf(Head)) or - (Head.Magic<>Magic) then begin - // Source not positioned as expected -> try from the end - Source.Position := sourceSize-SizeOf(Trailer); - if (Source.Read(Trailer,SizeOf(Trailer))<>SizeOf(Trailer)) or - (Trailer.Magic<>Magic) then - exit; - sourcePosition := sourceSize-Trailer.HeaderRelativeOffset; - Source.Position := sourcePosition; - if (Source.Read(Head,SizeOf(Head))<>SizeOf(Head)) or - (Head.Magic<>Magic) then - exit; - end; - inc(sourcePosition,SizeOf(Head)); - if sourcePosition+Head.CompressedSize>sourceSize then - exit; - if Source.InheritsFrom(TCustomMemoryStream) then begin - S := PAnsiChar(TCustomMemoryStream(Source).Memory)+PtrUInt(sourcePosition); - Source.Seek(Head.CompressedSize,soCurrent); - end else begin - if Head.CompressedSize>length(Buf) then - SetString(Buf,nil,Head.CompressedSize); - S := pointer(Buf); - Source.Read(S^,Head.CompressedSize); - end; - inc(sourcePosition,Head.CompressedSize); - if (Source.Read(Trailer,SizeOf(Trailer))<>SizeOf(Trailer)) or - (Trailer.Magic<>Magic) then - // trailer not available in old .synlz layout, or in FileSynLZ multiblocks - Source.Position := sourcePosition else - sourceSize := 0; // should be monoblock - // Source stream will now point after all data - stored := (Head.CompressedSize=Head.UnCompressedSize) and - (Head.HashCompressed=Head.HashUncompressed); - if not stored then - if SynLZdecompressdestlen(S)<>Head.UnCompressedSize then - exit; - if Hash32(pointer(S),Head.CompressedSize)<>Head.HashCompressed then - exit; - if result=nil then - result := THeapMemoryStream.Create else begin - {$ifndef CPU64} - if resultSize+Head.UnCompressedSize>maxInt then begin - FreeAndNil(result); // result TMemoryStream should stay in memory! - break; - end; - {$endif CPU64} - end; - result.Size := resultSize+Head.UnCompressedSize; - D := PAnsiChar(result.Memory)+resultSize; - inc(resultSize,Head.UnCompressedSize); - if stored then - MoveFast(S^,D^,Head.CompressedSize) else - if SynLZDecompress1(S,Head.CompressedSize,D)<>Head.UnCompressedSize then - FreeAndNil(result) else - if Hash32(pointer(D),Head.UnCompressedSize)<>Head.HashUncompressed then - FreeAndNil(result); - until (result=nil) or (sourcePosition>=sourceSize); -end; - - -{ TAlgoCompress } - -const - COMPRESS_STORED = #0; - COMPRESS_SYNLZ = 1; - -var - SynCompressAlgos: TSynObjectList; - -constructor TAlgoCompress.Create; -var existing: TAlgoCompress; -begin - inherited Create; - if SynCompressAlgos=nil then - GarbageCollectorFreeAndNil(SynCompressAlgos,TSynObjectList.Create) else begin - existing := Algo(AlgoID); - if existing<>nil then - raise ESynException.CreateUTF8('%.Create: AlgoID=% already registered by %', - [self,AlgoID,existing.ClassType]); - end; - SynCompressAlgos.Add(self); -end; - -class function TAlgoCompress.Algo(const Comp: RawByteString): TAlgoCompress; -begin - result := Algo(Pointer(Comp),Length(Comp)); -end; - -class function TAlgoCompress.Algo(const Comp: TByteDynArray): TAlgoCompress; -begin - result := Algo(Pointer(Comp),Length(Comp)); -end; - -class function TAlgoCompress.Algo(Comp: PAnsiChar; CompLen: integer): TAlgoCompress; -begin - if (Comp<>nil) and (CompLen>9) then - if ord(Comp[4])<=1 then // inline-friendly Comp[4]<=COMPRESS_SYNLZ - result := AlgoSynLZ else // COMPRESS_STORED is also handled as SynLZ - result := Algo(ord(Comp[4])) else - result := nil; -end; - -class function TAlgoCompress.Algo(Comp: PAnsiChar; CompLen: integer; out IsStored: boolean): TAlgoCompress; -begin - if (Comp<>nil) and (CompLen>9) then begin - IsStored := Comp[4]=COMPRESS_STORED; - result := Algo(ord(Comp[4])); - end else begin - IsStored := false; - result := nil; - end; -end; - -class function TAlgoCompress.Algo(AlgoID: byte): TAlgoCompress; -var i: integer; - ptr: ^TAlgoCompress; -begin - if AlgoID<=COMPRESS_SYNLZ then // COMPRESS_STORED is handled as SynLZ - result := AlgoSynLZ else begin - if SynCompressAlgos<>nil then begin - ptr := pointer(SynCompressAlgos.List); - inc(ptr); // ignore List[0] = AlgoSynLZ - for i := 2 to SynCompressAlgos.Count do - if ptr^.AlgoID=AlgoID then begin - result := ptr^; - exit; - end - else - inc(ptr); - end; - result := nil; - end; -end; - -class function TAlgoCompress.UncompressedSize(const Comp: RawByteString): integer; -begin - result := Algo(Comp).DecompressHeader(pointer(Comp),length(Comp)); -end; - -function TAlgoCompress.AlgoName: TShort16; -var s: PShortString; - i: integer; -begin - if self=nil then - result := 'none' else begin - s := ClassNameShort(self); - if IdemPChar(@s^[1],'TALGO') then begin - result[0] := AnsiChar(ord(s^[0])-5); - inc(PByte(s),5); - end else - result[0] := s^[0]; - if result[0]>#16 then - result[0] := #16; - for i := 1 to ord(result[0]) do - result[i] := NormToLower[s^[i]]; - end; -end; - -function TAlgoCompress.AlgoHash(Previous: cardinal; Data: pointer; DataLen: integer): cardinal; -begin - result := crc32c(Previous,Data,DataLen); -end; - -function TAlgoCompress.Compress(const Plain: RawByteString; CompressionSizeTrigger: integer; - CheckMagicForCompressed: boolean; BufferOffset: integer): RawByteString; -begin - result := Compress(pointer(Plain),Length(Plain),CompressionSizeTrigger, - CheckMagicForCompressed,BufferOffset); -end; - -function TAlgoCompress.Compress(Plain: PAnsiChar; PlainLen: integer; CompressionSizeTrigger: integer; - CheckMagicForCompressed: boolean; BufferOffset: integer): RawByteString; -var len: integer; - R: PAnsiChar; - crc: cardinal; - tmp: array[0..16383] of AnsiChar; // big enough to resize Result in-place -begin - if (self=nil) or (PlainLen=0) or (Plain=nil) then begin - result := ''; - exit; - end; - crc := AlgoHash(0,Plain,PlainLen); - if (PlainLenSizeOf(tmp) then begin - SetString(result,nil,len); - R := pointer(result); - end else - R := @tmp; - inc(R,BufferOffset); - PCardinal(R)^ := crc; - len := AlgoCompress(Plain,PlainLen,R+9); - if len+64>=PlainLen then begin // store if compression was not worth it - R[4] := COMPRESS_STORED; - PCardinal(R+5)^ := crc; - MoveFast(Plain^,R[9],PlainLen); - len := PlainLen; - end else begin - R[4] := AnsiChar(AlgoID); - PCardinal(R+5)^ := AlgoHash(0,R+9,len); - end; - if R=@tmp[BufferOffset] then - SetString(result,tmp,len+BufferOffset+9) else - SetLength(result,len+BufferOffset+9); // MM may not move the data - end; -end; - -function TAlgoCompress.Compress(Plain, Comp: PAnsiChar; PlainLen, CompLen: integer; - CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): integer; -var len: integer; -begin - result := 0; - if (self=nil) or (PlainLen=0) or (CompLen=CompressionSizeTrigger) and - not(CheckMagicForCompressed and IsContentCompressed(Plain,PlainLen)) then begin - len := CompressDestLen(PlainLen); - if CompLen=PlainLen then begin // store if compression not worth it - R[4] := COMPRESS_STORED; - PCardinal(R+5)^ := crc; - MoveFast(Plain^,R[9],PlainLen); - len := PlainLen; - end else begin - R[4] := AnsiChar(AlgoID); - PCardinal(R+5)^ := AlgoHash(0,R+9,len); - end; - SetLength(result,len+9); - end; -end; - -function TAlgoCompress.CompressToBytes(const Plain: RawByteString; - CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): TByteDynArray; -begin - result := CompressToBytes(pointer(Plain),Length(Plain), - CompressionSizeTrigger,CheckMagicForCompressed); -end; - -function TAlgoCompress.Decompress(const Comp: TByteDynArray): RawByteString; -begin - Decompress(pointer(Comp),length(Comp),result); -end; - -procedure TAlgoCompress.Decompress(Comp: PAnsiChar; CompLen: integer; - out Result: RawByteString; Load: TAlgoCompressLoad; BufferOffset: integer); -var len: integer; - dec: PAnsiChar; -begin - len := DecompressHeader(Comp,CompLen,Load); - if len=0 then - exit; - SetString(result,nil,len+BufferOffset); - dec := pointer(result); - if not DecompressBody(Comp,dec+BufferOffset,CompLen,len,Load) then - result := ''; -end; - -function TAlgoCompress.Decompress(const Comp: RawByteString; - Load: TAlgoCompressLoad; BufferOffset: integer): RawByteString; -begin - Decompress(pointer(Comp),length(Comp),result,Load,BufferOffset); -end; - -function TAlgoCompress.TryDecompress(const Comp: RawByteString; - out Dest: RawByteString; Load: TAlgoCompressLoad): boolean; -var len: integer; -begin - result := Comp=''; - if result then - exit; - len := DecompressHeader(pointer(Comp),length(Comp),Load); - if len=0 then - exit; // invalid crc32c - SetString(Dest,nil,len); - if DecompressBody(pointer(Comp),pointer(Dest),length(Comp),len,Load) then - result := true else - Dest := ''; -end; - -function TAlgoCompress.Decompress(const Comp: RawByteString; - out PlainLen: integer; var tmp: RawByteString; Load: TAlgoCompressLoad): pointer; -begin - result := Decompress(pointer(Comp),length(Comp),PlainLen,tmp,Load); -end; - -function TAlgoCompress.Decompress(Comp: PAnsiChar; CompLen: integer; - out PlainLen: integer; var tmp: RawByteString; Load: TAlgoCompressLoad): pointer; -begin - result := nil; - PlainLen := DecompressHeader(Comp,CompLen,Load); - if PlainLen=0 then - exit; - if Comp[4]=COMPRESS_STORED then - result := Comp+9 else begin - if PlainLen > length(tmp) then - SetString(tmp,nil,PlainLen); - if DecompressBody(Comp,pointer(tmp),CompLen,PlainLen,Load) then - result := pointer(tmp); - end; -end; - -function TAlgoCompress.DecompressPartial(Comp, Partial: PAnsiChar; - CompLen, PartialLen, PartialLenMax: integer): integer; -var BodyLen: integer; -begin - result := 0; - if (self=nil) or (CompLen<=9) or (Comp=nil) or (PartialLenMaxBodyLen then - PartialLen := BodyLen; - if Comp[4]=COMPRESS_STORED then - MoveFast(Comp[9],Partial[0],PartialLen) else - if AlgoDecompressPartial(Comp+9,CompLen-9,Partial,PartialLen,PartialLenMax)aclNoCrcFast) and (AlgoHash(0,Comp+9,CompLen-9)<>PCardinal(Comp+5)^)) then - exit; - if Comp[4]=COMPRESS_STORED then begin - if PCardinal(Comp)^=PCardinal(Comp+5)^ then - result := CompLen-9; - end else - if Comp[4]=AnsiChar(AlgoID) then - result := AlgoDecompressDestLen(Comp+9); -end; - -function TAlgoCompress.DecompressBody(Comp, Plain: PAnsiChar; - CompLen, PlainLen: integer; Load: TAlgoCompressLoad): boolean; -begin - result := false; - if (self=nil) or (PlainLen<=0) then - exit; - if Comp[4]=COMPRESS_STORED then - MoveFast(Comp[9],Plain[0],PlainLen) else - if Comp[4]=AnsiChar(AlgoID) then - case Load of - aclNormal: - if (AlgoDecompress(Comp+9,CompLen-9,Plain)<>PlainLen) or - (AlgoHash(0,Plain,PlainLen)<>PCardinal(Comp)^) then - exit; - aclSafeSlow: - if (AlgoDecompressPartial(Comp+9,CompLen-9,Plain,PlainLen,PlainLen)<>PlainLen) or - (AlgoHash(0,Plain,PlainLen)<>PCardinal(Comp)^) then - exit; - aclNoCrcFast: - if (AlgoDecompress(Comp+9,CompLen-9,Plain)<>PlainLen) then - exit; - end; - result := true; -end; - - -{ TAlgoSynLZ } - -function TAlgoSynLZ.AlgoID: byte; -begin - result := COMPRESS_SYNLZ; // =1 -end; - -function TAlgoSynLZ.AlgoCompress(Plain: pointer; PlainLen: integer; - Comp: pointer): integer; -begin - result := SynLZcompress1(Plain,PlainLen,Comp); -end; - -function TAlgoSynLZ.AlgoCompressDestLen(PlainLen: integer): integer; -begin - result := SynLZcompressdestlen(PlainLen); -end; - -function TAlgoSynLZ.AlgoDecompress(Comp: pointer; CompLen: integer; - Plain: pointer): integer; -begin - result := SynLZdecompress1(Comp,CompLen,Plain); -end; - -function TAlgoSynLZ.AlgoDecompressDestLen(Comp: pointer): integer; -begin - result := SynLZdecompressdestlen(Comp); -end; - -function TAlgoSynLZ.AlgoDecompressPartial(Comp: pointer; - CompLen: integer; Partial: pointer; PartialLen, PartialLenMax: integer): integer; -begin - result := SynLZdecompress1partial(Comp,CompLen,Partial,PartialLen); -end; - -// deprecated wrapper methods - use SynLZ global variable instead - -function SynLZCompress(const Data: RawByteString; CompressionSizeTrigger: integer; - CheckMagicForCompressed: boolean): RawByteString; -begin - result := AlgoSynLZ.Compress(pointer(Data),length(Data),CompressionSizeTrigger, - CheckMagicForCompressed); -end; - -procedure SynLZCompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; - CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean); -begin - result := AlgoSynLZ.Compress(P,PLen,CompressionSizeTrigger,CheckMagicForCompressed); -end; - -function SynLZCompress(P, Dest: PAnsiChar; PLen, DestLen: integer; - CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): integer; -begin - result := AlgoSynLZ.Compress(P,Dest,PLen,DestLen,CompressionSizeTrigger,CheckMagicForCompressed); -end; - -function SynLZDecompress(const Data: RawByteString): RawByteString; -begin - AlgoSynLZ.Decompress(pointer(Data),Length(Data),result); -end; - -function SynLZDecompressHeader(P: PAnsiChar; PLen: integer): integer; -begin - result := AlgoSynLZ.DecompressHeader(P,PLen); -end; - -function SynLZDecompressBody(P,Body: PAnsiChar; PLen,BodyLen: integer; - SafeDecompression: boolean): boolean; -begin - result := AlgoSynLZ.DecompressBody(P,Body,PLen,BodyLen,ALGO_SAFE[SafeDecompression]); -end; - -function SynLZDecompressPartial(P,Partial: PAnsiChar; PLen,PartialLen: integer): integer; -begin - result := AlgoSynLZ.DecompressPartial(P,Partial,PLen,PartialLen,PartialLen); -end; - -procedure SynLZDecompress(P: PAnsiChar; PLen: integer; out Result: RawByteString; - SafeDecompression: boolean); -begin - AlgoSynLZ.Decompress(P,PLen,Result); -end; - -function SynLZDecompress(const Data: RawByteString; out Len: integer; - var tmp: RawByteString): pointer; -begin - result := AlgoSynLZ.Decompress(pointer(Data),length(Data),Len,tmp); -end; - -function SynLZDecompress(P: PAnsiChar; PLen: integer; out Len: integer; - var tmp: RawByteString): pointer; -begin - result := AlgoSynLZ.Decompress(P,PLen,Len,tmp); -end; - -function SynLZCompressToBytes(const Data: RawByteString; - CompressionSizeTrigger: integer): TByteDynArray; -begin - result := AlgoSynLZ.CompressToBytes(pointer(Data),length(Data),CompressionSizeTrigger); -end; - -function SynLZCompressToBytes(P: PAnsiChar; PLen,CompressionSizeTrigger: integer): TByteDynArray; -begin - result := AlgoSynLZ.CompressToBytes(P,PLen,CompressionSizeTrigger); -end; - -function SynLZDecompress(const Data: TByteDynArray): RawByteString; -begin - AlgoSynLZ.Decompress(pointer(Data),length(Data),result); -end; - - -{ TAlgoCompressWithNoDestLen } - -function TAlgoCompressWithNoDestLen.AlgoCompress(Plain: pointer; - PlainLen: integer; Comp: pointer): integer; -begin - Comp := ToVarUInt32(PlainLen,Comp); // deflate don't store PlainLen - result := RawProcess(Plain,Comp,PlainLen,AlgoCompressDestLen(PlainLen),0,doCompress); - if result>0 then - inc(result,ToVarUInt32Length(PlainLen)); -end; - -function TAlgoCompressWithNoDestLen.AlgoDecompress(Comp: pointer; - CompLen: integer; Plain: pointer): integer; -var start: PAnsiChar; -begin - start := Comp; - result := FromVarUInt32(PByte(Comp)); - if RawProcess(Comp,Plain,CompLen+(Start-Comp),result,0,doUnCompress)<>result then - result := 0; -end; - -function TAlgoCompressWithNoDestLen.AlgoDecompressDestLen(Comp: pointer): integer; -begin - if Comp=nil then - result := 0 else - result := FromVarUInt32(PByte(Comp)); -end; - -function TAlgoCompressWithNoDestLen.AlgoDecompressPartial(Comp: pointer; - CompLen: integer; Partial: pointer; PartialLen, PartialLenMax: integer): integer; -var start: PAnsiChar; -begin - start := Comp; - result := FromVarUInt32(PByte(Comp)); - if PartialLenMax>result then - PartialLenMax := result; - result := RawProcess(Comp,Partial,CompLen+(Start-Comp),PartialLen,PartialLenMax,doUncompressPartial); -end; - - -{ ESynException } - -constructor ESynException.CreateUTF8(const Format: RawUTF8; const Args: array of const); -var msg: string; -begin - FormatString(Format,Args,msg); - inherited Create(msg); -end; - -constructor ESynException.CreateLastOSError( - const Format: RawUTF8; const Args: array of const; const Trailer: RawUtf8); -var tmp: RawUTF8; - error: integer; -begin - error := GetLastError; - FormatUTF8(Format,Args,tmp); - CreateUTF8('% % [%] %',[Trailer,error,SysErrorMessage(error),tmp]); -end; - -{$ifndef NOEXCEPTIONINTERCEPT} -function ESynException.CustomLog(WR: TTextWriter; - const Context: TSynLogExceptionContext): boolean; -begin - if Assigned(TSynLogExceptionToStrCustom) then - result := TSynLogExceptionToStrCustom(WR,Context) else - if Assigned(DefaultSynLogExceptionToStr) then - result := DefaultSynLogExceptionToStr(WR,Context) else - result := false; -end; -{$endif} - - -{ TMemoryMapText } - -constructor TMemoryMapText.Create; -begin -end; - -constructor TMemoryMapText.Create(aFileContent: PUTF8Char; aFileSize: integer); -begin - Create; - fMap.Map(aFileContent,aFileSize); - LoadFromMap; -end; - -constructor TMemoryMapText.Create(const aFileName: TFileName); -begin - Create; - fFileName := aFileName; - if fMap.Map(aFileName) then - LoadFromMap; -end; // invalid file or unable to memory map its content -> Count := 0 - -destructor TMemoryMapText.Destroy; -begin - Freemem(fLines); - fMap.UnMap; - inherited; -end; - -procedure TMemoryMapText.SaveToStream(Dest: TStream; const Header: RawUTF8); -var i: integer; - W: TTextWriter; - temp: TTextWriterStackBuffer; -begin - i := length(Header); - if i>0 then - Dest.WriteBuffer(pointer(Header)^,i); - if fMap.Size>0 then - Dest.WriteBuffer(fMap.Buffer^,fMap.Size); - if fAppendedLinesCount=0 then - exit; - W := TTextWriter.Create(Dest,@temp,SizeOf(temp)); - try - if (fMap.Size>0) and (fMap.Buffer[fMap.Size-1]>=' ') then - W.Add(#10); - for i := 0 to fAppendedLinesCount-1 do begin - W.AddString(fAppendedLines[i]); - W.Add(#10); - end; - W.FlushFinal; - finally - W.Free; - end; -end; - -procedure TMemoryMapText.SaveToFile(FileName: TFileName; const Header: RawUTF8); -var FS: TFileStream; -begin - FS := TFileStream.Create(FileName,fmCreate); - try - SaveToStream(FS,Header); - finally - FS.Free; - end; -end; - -function TMemoryMapText.GetLine(aIndex: integer): RawUTF8; -begin - if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) then - result := '' else - FastSetString(result,fLines[aIndex],GetLineSize(fLines[aIndex],fMapEnd)); -end; - -function TMemoryMapText.GetString(aIndex: integer): string; -begin - if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) then - result := '' else - UTF8DecodeToString(fLines[aIndex],GetLineSize(fLines[aIndex],fMapEnd),result); -end; - -function GetLineContains(p, pEnd, up: PUTF8Char): boolean; -var - i: PtrInt; - {$ifdef CPUX86NOTPIC} table: TNormTable absolute NormToUpperAnsi7Byte; - {$else} table: PNormTable; {$endif} -label - Fnd1, LF1, Fnd2, LF2, Ok; // ugly but fast -begin - if (p<>nil) and (up<>nil) then begin - {$ifndef CPUX86NOTPIC} table := @NormToUpperAnsi7; {$endif} - if pEnd=nil then - repeat - if p^<=#13 then - goto LF1 - else if table[p^]=up^ then - goto Fnd1; - inc(p); - continue; -LF1: if (p^=#0) or (p^=#13) or (p^=#10) then - break; - inc(p); - continue; -Fnd1: i := 0; - repeat - inc(i); - if up[i]<>#0 then - if up[i]=table[p[i]] then - continue else - break else begin -Ok: result := true; // found - exit; - end; - until false; - inc(p); - until false - else - repeat - if p>=pEnd then - break; - if p^<=#13 then - goto LF2 - else if table[p^]=up^ then - goto Fnd2; - inc(p); - continue; -LF2: if (p^=#13) or (p^=#10) then - break; - inc(p); - continue; -Fnd2: i := 0; - repeat - inc(i); - if up[i]=#0 then - goto Ok; - if p+i>=pEnd then - break; - until up[i]<>table[p[i]]; - inc(p); - until false; - end; - result := false; -end; - -function TMemoryMapText.LineContains(const aUpperSearch: RawUTF8; - aIndex: Integer): Boolean; -begin - if (self=nil) or (cardinal(aIndex)>=cardinal(fCount)) or (aUpperSearch='') then - result := false else - result := GetLineContains(fLines[aIndex],fMapEnd,pointer(aUpperSearch)); -end; - -function TMemoryMapText.LineSize(aIndex: integer): integer; -begin - result := GetLineSize(fLines[aIndex],fMapEnd); -end; - -function GetLineSizeSmallerThan(P,PEnd: PUTF8Char; aMinimalCount: integer): boolean; -begin - if P<>nil then - while (P#10) and (P^<>#13) do - if aMinimalCount=0 then begin - result := false; - exit; - end else begin - dec(aMinimalCount); - inc(P); - end; - result := true; -end; - -function TMemoryMapText.LineSizeSmallerThan(aIndex, aMinimalCount: integer): boolean; -begin - result := GetLineSizeSmallerThan(fLines[aIndex],fMapEnd,aMinimalCount); -end; - -procedure TMemoryMapText.ProcessOneLine(LineBeg, LineEnd: PUTF8Char); -begin - if fCount=fLinesMax then begin - fLinesMax := NextGrow(fLinesMax); - ReallocMem(fLines,fLinesMax*SizeOf(pointer)); - end; - fLines[fCount] := LineBeg; - inc(fCount); -end; - -procedure TMemoryMapText.LoadFromMap(AverageLineLength: integer=32); - procedure ParseLines(P,PEnd: PUTF8Char); - var PBeg: PUTF8Char; - begin // generated asm is much better with a local proc - while P#13) and (P^<>#10) do - inc(P); - ProcessOneLine(PBeg,P); - if P+1>=PEnd then - break; - if P[0]=#13 then - if P[1]=#10 then - inc(P,2) else // ignore #13#10 - inc(P) else // ignore #13 - inc(P); // ignore #10 - end; - end; -var P: PUTF8Char; -begin - fLinesMax := fMap.fFileSize div AverageLineLength+8; - GetMem(fLines,fLinesMax*SizeOf(pointer)); - P := pointer(fMap.Buffer); - fMapEnd := P+fMap.Size; - if TextFileKind(Map)=isUTF8 then - inc(PByte(P),3); // ignore UTF-8 BOM - ParseLines(P,fMapEnd); - if fLinesMax>fCount+16384 then - Reallocmem(fLines,fCount*SizeOf(pointer)); // size down only if worth it -end; - -procedure TMemoryMapText.AddInMemoryLine(const aNewLine: RawUTF8); -var P: PUTF8Char; -begin - if aNewLine='' then - exit; - AddRawUTF8(fAppendedLines,fAppendedLinesCount,aNewLine); - P := pointer(fAppendedLines[fAppendedLinesCount-1]); - ProcessOneLine(P,P+StrLen(P)); -end; - -procedure TMemoryMapText.AddInMemoryLinesClear; -begin - dec(fCount,fAppendedLinesCount); - fAppendedLinesCount := 0; - fAppendedLines := nil; -end; - - -{ TRawByteStringStream } - -constructor TRawByteStringStream.Create(const aString: RawByteString); -begin - fDataString := aString; -end; - -function TRawByteStringStream.Read(var Buffer; Count: Integer): Longint; -begin - if Count<=0 then - Result := 0 else begin - Result := Length(fDataString)-fPosition; - if Result>Count then - Result := Count; - MoveFast(PByteArray(fDataString)[fPosition],Buffer,Result); - inc(fPosition, Result); - end; -end; - -function TRawByteStringStream.Seek(Offset: Integer; Origin: Word): Longint; -begin - case Origin of - soFromBeginning: fPosition := Offset; - soFromCurrent: fPosition := fPosition+Offset; - soFromEnd: fPosition := Length(fDataString)-Offset; - end; - if fPosition>Length(fDataString) then - fPosition := Length(fDataString) else - if fPosition<0 then - fPosition := 0; - result := fPosition; -end; - -procedure TRawByteStringStream.SetSize(NewSize: Integer); -begin - SetLength(fDataString, NewSize); - if fPosition>NewSize then - fPosition := NewSize; -end; - -function TRawByteStringStream.Write(const Buffer; Count: Integer): Longint; -begin - if Count<=0 then - Result := 0 else begin - Result := Count; - SetLength(fDataString,fPosition+Result); - MoveFast(Buffer,PByteArray(fDataString)[fPosition],Result); - inc(FPosition,Result); - end; -end; - - -{ TFakeWriterStream } - -function TFakeWriterStream.Read(var Buffer; Count: Longint): Longint; -begin // do nothing - result := Count; -end; - -function TFakeWriterStream.Write(const Buffer; Count: Longint): Longint; -begin // do nothing - result := Count; -end; - -function TFakeWriterStream.Seek(Offset: Longint; Origin: Word): Longint; -begin - result := Offset; -end; - - -{ TSynNameValue } - -procedure TSynNameValue.Add(const aName, aValue: RawUTF8; aTag: PtrInt); -var added: boolean; - i: Integer; -begin - i := DynArray.FindHashedForAdding(aName,added); - with List[i] do begin - if added then - Name := aName; - Value := aValue; - Tag := aTag; - end; - if Assigned(fOnAdd) then - fOnAdd(List[i],i); -end; - -procedure TSynNameValue.InitFromIniSection(Section: PUTF8Char; - OnTheFlyConvert: TOnSynNameValueConvertRawUTF8; OnAdd: TOnSynNameValueNotify); -var s: RawUTF8; - i: integer; -begin - Init(false); - fOnAdd := OnAdd; - while (Section<>nil) and (Section^<>'[') do begin - s := GetNextLine(Section,Section); - i := PosExChar('=',s); - if (i>1) and not(s[1] in [';','[']) then - if Assigned(OnTheFlyConvert) then - Add(copy(s,1,i-1),OnTheFlyConvert(copy(s,i+1,1000))) else - Add(copy(s,1,i-1),copy(s,i+1,1000)); - end; -end; - -procedure TSynNameValue.InitFromCSV(CSV: PUTF8Char; NameValueSep,ItemSep: AnsiChar); -var n,v: RawUTF8; -begin - Init(false); - while CSV<>nil do begin - GetNextItem(CSV,NameValueSep,n); - if ItemSep=#10 then - GetNextItemTrimedCRLF(CSV,v) else - GetNextItem(CSV,ItemSep,v); - if n='' then - break; - Add(n,v); - end; -end; - -procedure TSynNameValue.InitFromNamesValues(const Names, Values: array of RawUTF8); -var i: integer; -begin - Init(false); - if high(Names)<>high(Values) then - exit; - DynArray.SetCapacity(length(Names)); - for i := 0 to high(Names) do - Add(Names[i],Values[i]); -end; - -function TSynNameValue.InitFromJSON(JSON: PUTF8Char; aCaseSensitive: boolean): boolean; -var N,V: PUTF8Char; - nam,val: RawUTF8; - Nlen, Vlen, c: integer; - EndOfObject: AnsiChar; -begin - result := false; - Init(aCaseSensitive); - if JSON=nil then - exit; - while (JSON^<=' ') and (JSON^<>#0) do inc(JSON); - if JSON^<>'{' then - exit; - repeat inc(JSON) until (JSON^=#0) or (JSON^>' '); - c := JSONObjectPropCount(JSON); - if c<=0 then - exit; - DynArray.SetCapacity(c); - repeat - N := GetJSONPropName(JSON,@Nlen); - if N=nil then - exit; - V := GetJSONFieldOrObjectOrArray(JSON,nil,@EndOfObject,true,true,@Vlen); - if V=nil then - exit; - FastSetString(nam,N,Nlen); - FastSetString(val,V,Vlen); - Add(nam,val); - until EndOfObject='}'; - result := true; -end; - -procedure TSynNameValue.Init(aCaseSensitive: boolean); -begin - // release dynamic arrays memory before FillcharFast() - List := nil; - DynArray.fHash.Clear; - // initialize hashed storage - FillCharFast(self,SizeOf(self),0); - DynArray.InitSpecific(TypeInfo(TSynNameValueItemDynArray),List, - djRawUTF8,@Count,not aCaseSensitive); -end; - -function TSynNameValue.Find(const aName: RawUTF8): integer; -begin - result := DynArray.FindHashed(aName); -end; - -function TSynNameValue.FindStart(const aUpperName: RawUTF8): integer; -begin - for result := 0 to Count-1 do - if IdemPChar(pointer(List[result].Name),pointer(aUpperName)) then - exit; - result := -1; -end; - -function TSynNameValue.FindByValue(const aValue: RawUTF8): integer; -begin - for result := 0 to Count-1 do - if List[result].Value=aValue then - exit; - result := -1; -end; - -function TSynNameValue.Delete(const aName: RawUTF8): boolean; -begin - result := DynArray.FindHashedAndDelete(aName)>=0; -end; - -function TSynNameValue.DeleteByValue(const aValue: RawUTF8; Limit: integer): integer; -var ndx: integer; -begin - result := 0; - if Limit<1 then - exit; - for ndx := Count-1 downto 0 do - if List[ndx].Value=aValue then begin - DynArray.Delete(ndx); - inc(result); - if result>=Limit then - break; - end; - if result>0 then - DynArray.ReHash; -end; - -function TSynNameValue.Value(const aName: RawUTF8; const aDefaultValue: RawUTF8): RawUTF8; -var i: integer; -begin - if @self=nil then - i := -1 else - i := DynArray.FindHashed(aName); - if i<0 then - result := aDefaultValue else - result := List[i].Value; -end; - -function TSynNameValue.ValueInt(const aName: RawUTF8; const aDefaultValue: Int64): Int64; -var i,err: integer; -begin - i := DynArray.FindHashed(aName); - if i<0 then - result := aDefaultValue else begin - result := {$ifdef CPU64}GetInteger{$else}GetInt64{$endif}(pointer(List[i].Value),err); - if err<>0 then - result := aDefaultValue; - end; -end; - -function TSynNameValue.ValueBool(const aName: RawUTF8): Boolean; -begin - result := Value(aName)='1'; -end; - -function TSynNameValue.ValueEnum(const aName: RawUTF8; aEnumTypeInfo: pointer; - out aEnum; aEnumDefault: byte): boolean; -var v: RawUTF8; - err,i: integer; -begin - result := false; - byte(aEnum) := aEnumDefault; - v := trim(Value(aName,'')); - if v='' then - exit; - i := GetInteger(pointer(v),err); - if (err<>0) or (i<0) then - i := GetEnumNameValue(aEnumTypeInfo,v,true); - if i>=0 then begin - byte(aEnum) := i; - result := true; - end; -end; - -function TSynNameValue.Initialized: boolean; -begin - result := DynArray.Value=@List; -end; - -function TSynNameValue.GetBlobData: RawByteString; -begin - result := DynArray.SaveTo; -end; - -procedure TSynNameValue.SetBlobDataPtr(aValue: pointer); -begin - DynArray.LoadFrom(aValue); - DynArray.ReHash; -end; - -procedure TSynNameValue.SetBlobData(const aValue: RawByteString); -begin - DynArray.LoadFromBinary(aValue); - DynArray.ReHash; -end; - -function TSynNameValue.GetStr(const aName: RawUTF8): RawUTF8; -begin - result := Value(aName,''); -end; - -function TSynNameValue.GetInt(const aName: RawUTF8): Int64; -begin - result := ValueInt(aName,0); -end; - -function TSynNameValue.GetBool(const aName: RawUTF8): Boolean; -begin - result := Value(aName)='1'; -end; - -function TSynNameValue.AsCSV(const KeySeparator,ValueSeparator,IgnoreKey: RawUTF8): RawUTF8; -var i: integer; - temp: TTextWriterStackBuffer; -begin - with TTextWriter.CreateOwnedStream(temp) do - try - for i := 0 to Count-1 do - if (IgnoreKey='') or (List[i].Name<>IgnoreKey) then begin - AddNoJSONEscapeUTF8(List[i].Name); - AddNoJSONEscapeUTF8(KeySeparator); - AddNoJSONEscapeUTF8(List[i].Value); - AddNoJSONEscapeUTF8(ValueSeparator); - end; - SetText(result); - finally - Free; - end; -end; - -function TSynNameValue.AsJSON: RawUTF8; -var i: integer; - temp: TTextWriterStackBuffer; -begin - with TTextWriter.CreateOwnedStream(temp) do - try - Add('{'); - for i := 0 to Count-1 do - with List[i] do begin - AddProp(pointer(Name),length(Name)); - Add('"'); - AddJSONEscape(pointer(Value)); - Add('"',','); - end; - CancelLastComma; - Add('}'); - SetText(result); - finally - Free; - end; -end; - -procedure TSynNameValue.AsNameValues(out Names,Values: TRawUTF8DynArray); -var i: integer; -begin - SetLength(Names,Count); - SetLength(Values,Count); - for i := 0 to Count-1 do begin - Names[i] := List[i].Name; - Values[i] := List[i].Value; - end; -end; - -{$ifndef NOVARIANTS} -function TSynNameValue.ValueVariantOrNull(const aName: RawUTF8): variant; -var i: integer; -begin - i := Find(aName); - if i<0 then - SetVariantNull(result) else - RawUTF8ToVariant(List[i].Value,result); -end; - -procedure TSynNameValue.AsDocVariant(out DocVariant: variant; - ExtendedJson,ValueAsString,AllowVarDouble: boolean); -var ndx: integer; -begin - if Count>0 then - with TDocVariantData(DocVariant) do begin - Init(JSON_OPTIONS_NAMEVALUE[ExtendedJson],dvObject); - VCount := self.Count; - SetLength(VName,VCount); - SetLength(VValue,VCount); - for ndx := 0 to VCount-1 do begin - VName[ndx] := List[ndx].Name; - if ValueAsString or not GetNumericVariantFromJSON(pointer(List[ndx].Value), - TVarData(VValue[ndx]),AllowVarDouble) then - RawUTF8ToVariant(List[ndx].Value,VValue[ndx]); - end; - end else - TVarData(DocVariant).VType := varNull; -end; - -function TSynNameValue.AsDocVariant(ExtendedJson,ValueAsString: boolean): variant; -begin - AsDocVariant(result,ExtendedJson,ValueAsString); -end; - -function TSynNameValue.MergeDocVariant(var DocVariant: variant; - ValueAsString: boolean; ChangedProps: PVariant; ExtendedJson,AllowVarDouble: Boolean): integer; -var DV: TDocVariantData absolute DocVariant; - i,ndx: integer; - v: variant; - intvalues: TRawUTF8Interning; -begin - if integer(DV.VType)<>DocVariantVType then - TDocVariant.New(DocVariant,JSON_OPTIONS_NAMEVALUE[ExtendedJson]); - if ChangedProps<>nil then - TDocVariant.New(ChangedProps^,DV.Options); - if dvoInternValues in DV.Options then - intvalues := DocVariantType.InternValues else - intvalues := nil; - result := 0; // returns number of changed values - for i := 0 to Count-1 do - if List[i].Name<>'' then begin - VarClear(v); - if ValueAsString or not GetNumericVariantFromJSON(pointer(List[i].Value), - TVarData(v),AllowVarDouble) then - RawUTF8ToVariant(List[i].Value,v); - ndx := DV.GetValueIndex(List[i].Name); - if ndx<0 then - ndx := DV.InternalAdd(List[i].Name) else - if SortDynArrayVariantComp(TVarData(v),TVarData(DV.Values[ndx]),false)=0 then - continue; // value not changed -> skip - if ChangedProps<>nil then - PDocVariantData(ChangedProps)^.AddValue(List[i].Name,v); - SetVariantByValue(v,DV.VValue[ndx]); - if intvalues<>nil then - intvalues.UniqueVariant(DV.VValue[ndx]); - inc(result); - end; -end; -{$endif NOVARIANTS} - - -{$ifdef MSWINDOWS} -function IsDebuggerPresent: BOOL; stdcall; external kernel32; // since XP -{$endif} - -procedure SetCurrentThreadName(const Format: RawUTF8; const Args: array of const); -begin - SetThreadName(GetCurrentThreadId,Format,Args); -end; - -procedure SetThreadName(ThreadID: TThreadID; const Format: RawUTF8; - const Args: array of const); -var name: RawUTF8; -begin - FormatUTF8(Format,Args,name); - name := StringReplaceAll(name,['TSQLRest','', 'TSQL','', 'TWebSocket','WS', - 'TServiceFactory','SF', 'TSyn','', 'Thread','', 'Process','', - 'Background','Bgd', 'Server','Svr', 'Client','Clt', 'WebSocket','WS', - 'Timer','Tmr', 'Thread','Thd']); - SetThreadNameInternal(ThreadID,name); -end; - -procedure SetThreadNameDefault(ThreadID: TThreadID; const Name: RawUTF8); -{$ifndef FPC} -{$ifndef NOSETTHREADNAME} -var s: RawByteString; - {$ifndef ISDELPHIXE2} - {$ifdef MSWINDOWS} - info: record - FType: LongWord; // must be 0x1000 - FName: PAnsiChar; // pointer to name (in user address space) - FThreadID: LongWord; // thread ID (-1 indicates caller thread) - FFlags: LongWord; // reserved for future use, must be zero - end; - {$endif} - {$endif} -{$endif NOSETTHREADNAME} -{$endif FPC} -begin -{$ifdef FPC} - {$ifdef LINUX} - if ThreadID<>MainThreadID then // don't change the main process name - SetUnixThreadName(ThreadID, Name); // call pthread_setname_np() - {$endif} -{$else} -{$ifndef NOSETTHREADNAME} - {$ifdef MSWINDOWS} - if not IsDebuggerPresent then - exit; - {$endif MSWINDOWS} - s := CurrentAnsiConvert.UTF8ToAnsi(Name); - {$ifdef ISDELPHIXE2} - TThread.NameThreadForDebugging(s,ThreadID); - {$else} - {$ifdef MSWINDOWS} - info.FType := $1000; - info.FName := pointer(s); - info.FThreadID := ThreadID; - info.FFlags := 0; - try - RaiseException($406D1388,0,SizeOf(info) div SizeOf(LongWord),@info); - except {ignore} end; - {$endif MSWINDOWS} - {$endif ISDELPHIXE2} -{$endif NOSETTHREADNAME} -{$endif FPC} -end; - - -{ MultiEvent* functions } - -function MultiEventFind(const EventList; const Event: TMethod): integer; -var Events: TMethodDynArray absolute EventList; -begin - if Event.Code<>nil then // callback assigned - for result := 0 to length(Events)-1 do - if (Events[result].Code=Event.Code) and - (Events[result].Data=Event.Data) then - exit; - result := -1; -end; - -function MultiEventAdd(var EventList; const Event: TMethod): boolean; -var Events: TMethodDynArray absolute EventList; - n: integer; -begin - result := false; - n := MultiEventFind(EventList,Event); - if n>=0 then - exit; // already registered - result := true; - n := length(Events); - SetLength(Events,n+1); - Events[n] := Event; -end; - -procedure MultiEventRemove(var EventList; const Event: TMethod); -begin - MultiEventRemove(EventList,MultiEventFind(EventList,Event)); -end; - -procedure MultiEventRemove(var EventList; Index: Integer); -var Events: TMethodDynArray absolute EventList; - max: integer; -begin - max := length(Events); - if cardinal(index)nil) and (po^<>nil) then - FreeAndNil(po^); - except - on E: Exception do - ; // just ignore exceptions in client code destructors - end; - FreeAndNil(GarbageCollectorFreeAndNilList); -end; - -procedure GarbageCollectorFreeAndNil(var InstanceVariable; Instance: TObject); -begin - TObject(InstanceVariable) := Instance; - GarbageCollectorFreeAndNilList.Add(@InstanceVariable); -end; - -var - GlobalCriticalSection: TRTLCriticalSection; - -procedure GlobalLock; -begin - EnterCriticalSection(GlobalCriticalSection); -end; - -procedure GlobalUnLock; -begin - LeaveCriticalSection(GlobalCriticalSection); -end; - -{$ifdef CPUINTEL} -function IsXmmYmmOSEnabled: boolean; assembler; {$ifdef FPC} nostackframe; assembler; {$endif} -asm // see https://software.intel.com/en-us/blogs/2011/04/14/is-avx-enabled - xor ecx, ecx // specify control register XCR0 = XFEATURE_ENABLED_MASK - db $0f, $01, $d0 // XGETBV reads XCR0 into EDX:EAX - and eax, 6 // check OS has enabled both XMM (bit 1) and YMM (bit 2) - cmp al, 6 - sete al -end; - -procedure TestIntelCpuFeatures; -var regs: TRegisters; - c: cardinal; -begin - // retrieve CPUID raw flags - regs.edx := 0; - regs.ecx := 0; - GetCPUID(1,regs); - PIntegerArray(@CpuFeatures)^[0] := regs.edx; - PIntegerArray(@CpuFeatures)^[1] := regs.ecx; - GetCPUID(7,regs); - PIntegerArray(@CpuFeatures)^[2] := regs.ebx; - PIntegerArray(@CpuFeatures)^[3] := regs.ecx; - PIntegerArray(@CpuFeatures)^[4] := regs.edx; - {$ifdef DISABLE_SSE42} // paranoid execution on Darwin x64 (as reported by alf) - CpuFeatures := CpuFeatures-[cfSSE42,cfAESNI]; - {$endif DISABLE_SSE42} - if not(cfOSXS in CpuFeatures) or not IsXmmYmmOSEnabled then - CpuFeatures := CpuFeatures-[cfAVX,cfAVX2,cfFMA]; - {$ifndef ABSOLUTEPASCAL} - {$ifdef CPUX64} - {$ifdef WITH_ERMS} - if cfERMS in CpuFeatures then // actually slower than our AVX code -> disabled - include(CPUIDX64,cpuERMS); - {$endif WITH_ERMS} - if cfAVX in CpuFeatures then begin - include(CPUIDX64,cpuAVX); - if cfAVX2 in CpuFeatures then - include(CPUIDX64,cpuAVX2); - end; - {$endif CPUX64} - {$endif ABSOLUTEPASCAL} - // validate accuracy of most used HW opcodes - if cfRAND in CpuFeatures then - try - c := RdRand32; - if RdRand32=c then // most probably a RDRAND bug, e.g. on AMD Rizen 3000 - exclude(CpuFeatures,cfRAND); - except // may trigger an illegal instruction exception on some Ivy Bridge - exclude(CpuFeatures,cfRAND); - end; - if cfSSE42 in CpuFeatures then - try - if crc32cBy4SSE42(0,1)<>3712330424 then - raise ESynException.Create('Invalid crc32cBy4SSE42'); - except // disable now on illegal instruction or incorrect result - exclude(CpuFeatures,cfSSE42); - end; -end; -{$endif CPUINTEL} - -procedure InitFunctionsRedirection; -begin - {$ifdef CPUINTEL} - TestIntelCpuFeatures; - {$endif CPUINTEL} - {$ifndef MSWINDOWS} // now for RedirectCode (RetrieveSystemInfo is too late) - SystemInfo.dwPageSize := getpagesize; // use libc for this value - if SystemInfo.dwPageSize=0 then // should not be 0 - SystemInfo.dwPageSize := 4096; - {$endif MSWINDOWS} - {$ifdef PUREPASCAL} - {$ifndef HASINLINE} - PosEx := @PosExPas; - {$endif HASINLINE} - PosExString := @PosExStringPas; // fast pure pascal process - {$else not PUREPASCAL} - {$ifdef UNICODE} - PosExString := @PosExStringPas; // fast PWideChar process - {$else} - PosExString := @PosEx; // use optimized PAnsiChar i386 asm - {$endif UNICODE} - {$endif PUREPASCAL} - crc32c := @crc32cfast; // now to circumvent Internal Error C11715 for Delphi 5 - crc32cBy4 := @crc32cBy4fast; - {$ifndef CPUX64} - MoveFast := @System.Move; - {$endif CPUX64} - {$ifdef FPC} - {$ifdef CPUX64} - {$ifndef ABSOLUTEPASCAL} - if @System.FillChar<>@FillCharFast then begin - // force to use our optimized x86_64 asm versions - RedirectCode(@System.FillChar,@FillcharFast); - RedirectCode(@System.Move,@MoveFast); - {$ifdef DOPATCHTRTL} - PatchCode(@fpc_ansistr_incr_ref,@_ansistr_incr_ref,$17); // fpclen=$2f - PatchJmp(@fpc_ansistr_decr_ref,@_ansistr_decr_ref,$27); // fpclen=$3f - PatchJmp(@fpc_ansistr_assign,@_ansistr_assign,$3f); // fpclen=$3f - PatchCode(@fpc_ansistr_compare,@_ansistr_compare,$77); // fpclen=$12f - PatchCode(@fpc_ansistr_compare_equal,@_ansistr_compare_equal,$57); // =$cf - PatchCode(@fpc_unicodestr_incr_ref,@_ansistr_incr_ref,$17); // fpclen=$2f - PatchJmp(@fpc_unicodestr_decr_ref,@_ansistr_decr_ref,$27); // fpclen=$3f - PatchJmp(@fpc_unicodestr_assign,@_ansistr_assign,$3f); // fpclen=$3f - PatchCode(@fpc_dynarray_incr_ref,@_dynarray_incr_ref,$17); // fpclen=$2f - PatchJmp(@fpc_dynarray_clear,@_dynarray_decr_ref,$2f,PtrUInt(@_dynarray_decr_ref_free)); - RedirectCode(@fpc_dynarray_decr_ref,@fpc_dynarray_clear); - {$ifdef FPC_HAS_CPSTRING} - {$ifdef LINUX} - if (DefaultSystemCodePage=CP_UTF8) or (DefaultSystemCodePage=0) then begin - RedirectRtl(@_fpc_ansistr_concat,@_ansistr_concat_utf8); - RedirectRtl(@_fpc_ansistr_concat_multi,@_ansistr_concat_multi_utf8); - end; - {$endif LINUX} - {$ifdef FPC_X64MM} - RedirectCode(@fpc_ansistr_setlength,@_ansistr_setlength); - {$endif FPC_X64MM} - {$endif FPC_HAS_CPSTRING} - {$ifdef FPC_X64MM} - RedirectCode(@fpc_getmem,@_Getmem); - RedirectCode(@fpc_freemem,@_Freemem); - {$endif FPC_X64MM} - {$endif DOPATCHTRTL} - end; - {$endif ABSOLUTEPASCAL} - {$else} - FillCharFast := @System.FillChar; // fallback to FPC cross-platform RTL - {$endif CPUX64} - {$else Dephi: } - {$ifdef CPUARM} - FillCharFast := @System.FillChar; - {$else} - {$ifndef CPUX64} - Pointer(@FillCharFast) := SystemFillCharAddress; - {$endif CPUX64} - {$ifdef DELPHI5OROLDER} - StrLen := @StrLenX86; - MoveFast := @MoveX87; - FillcharFast := @FillCharX87; - {$else DELPHI5OROLDER} - {$ifdef CPU64} // x86_64 redirection - {$ifdef HASAESNI} - {$ifdef FORCE_STRSSE42} - if cfSSE42 in CpuFeatures then begin - StrLen := @StrLenSSE42; - StrComp := @StrCompSSE42; - end else - {$endif FORCE_STRSSE42} - {$endif HASAESNI} - StrLen := @StrLenSSE2; - {$else} // i386 redirection - {$ifdef CPUINTEL} - if cfSSE2 in CpuFeatures then begin - {$ifdef FORCE_STRSSE42} - if cfSSE42 in CpuFeatures then - StrLen := @StrLenSSE42 else - {$endif FORCE_STRSSE42} - StrLen := @StrLenSSE2; - FillcharFast := @FillCharSSE2; - end else begin - StrLen := @StrLenX86; - FillcharFast := @FillCharX87; - end; - {$ifdef WITH_ERMS} // disabled by default (much slower for small blocks) - if cfERMS in CpuFeatures then begin - MoveFast := @MoveERMSB; - FillcharFast := @FillCharERMSB; - end else {$endif} - MoveFast := @MoveX87; // SSE2 is not faster than X87 version on 32-bit CPU - {$endif CPUINTEL} - {$endif CPU64} - {$endif DELPHI5OROLDER} - {$ifndef USEPACKAGES} - // do redirection from RTL to our fastest version - {$ifdef DOPATCHTRTL} - if DebugHook=0 then begin // patch only outside debugging - RedirectCode(SystemFillCharAddress,@FillcharFast); - RedirectCode(@System.Move,@MoveFast); - {$ifdef CPUX86} - RedirectCode(SystemRecordCopyAddress,@RecordCopy); - RedirectCode(SystemFinalizeRecordAddress,@RecordClear); - RedirectCode(SystemInitializeRecordAddress,@_InitializeRecord); - {$ifndef UNICODE} // buggy Delphi 2009+ RTL expects a TMonitor.Destroy call - RedirectCode(@TObject.CleanupInstance,@TObjectCleanupInstance); - {$endif UNICODE} - {$endif} - end; - {$endif DOPATCHTRTL} - {$endif USEPACKAGES} - {$endif CPUARM} - {$endif FPC} - UpperCopy255Buf := @UpperCopy255BufPas; - DefaultHasher := @xxHash32; // faster than crc32cfast for small content - {$ifndef ABSOLUTEPASCAL} - {$ifdef CPUINTEL} - {$ifdef FPC} // StrLen was set above for Delphi - {$ifdef CPUX86} - if cfSSE2 in CpuFeatures then - {$endif CPUX86} - StrLen := @StrLenSSE2; - {$endif FPC} - if cfSSE42 in CpuFeatures then begin - crc32c := @crc32csse42; // seems safe on all targets - crc32cby4 := @crc32cby4sse42; - crcblock := @crcblockSSE42; - crcblocks := @crcblocksSSE42; - {$ifdef FORCE_STRSSE42} // disabled by default: may trigger random GPF - strspn := @strspnSSE42; - strcspn := @strcspnSSE42; - {$ifdef CPU64} - {$ifdef FPC} // done in InitRedirectCode for Delphi - {$ifdef HASAESNI} - StrLen := @StrLenSSE42; - StrComp := @StrCompSSE42; - {$endif HASAESNI} - {$endif FPC} - {$endif CPU64} - {$ifndef PUREPASCAL} - {$ifndef DELPHI5OROLDER} - UpperCopy255Buf := @UpperCopy255BufSSE42; - {$endif DELPHI5OROLDER} - {$endif PUREPASCAL} - {$ifndef PUREPASCAL} - StrComp := @StrCompSSE42; - DYNARRAY_SORTFIRSTFIELD[false,djRawUTF8] := @SortDynArrayAnsiStringSSE42; - DYNARRAY_SORTFIRSTFIELD[false,djWinAnsi] := @SortDynArrayAnsiStringSSE42; - {$ifndef UNICODE} - DYNARRAY_SORTFIRSTFIELD[false,djString] := @SortDynArrayAnsiStringSSE42; - {$endif} - DYNARRAY_SORTFIRSTFIELDHASHONLY[true] := @SortDynArrayAnsiStringSSE42; - {$endif PUREPASCAL} - {$endif FORCE_STRSSE42} - DefaultHasher := crc32c; - end; - if cfPOPCNT in CpuFeatures then - GetBitsCountPtrInt := @GetBitsCountSSE42; - {$endif CPUINTEL} - {$endif ABSOLUTEPASCAL} - InterningHasher := DefaultHasher; -end; - -procedure InitSynCommonsConversionTables; -var i,n: integer; - v: byte; - c: AnsiChar; - crc: cardinal; - tmp: array[0..15] of AnsiChar; - P: PAnsiChar; -{$ifdef OWNNORMTOUPPER} - d: integer; -const n2u: array[138..255] of byte = - (83,139,140,141,90,143,144,145,146,147,148,149,150,151,152,153,83,155,140, - 157,90,89,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175, - 176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,65,65,65, - 65,65,65,198,67,69,69,69,69,73,73,73,73,68,78,79,79,79,79,79,215,79,85,85, - 85,85,89,222,223,65,65,65,65,65,65,198,67,69,69,69,69,73,73,73,73,68,78,79, - 79,79,79,79,247,79,85,85,85,85,89,222,89); -{$endif OWNNORMTOUPPER} -const HexChars: array[0..15] of AnsiChar = '0123456789ABCDEF'; - HexCharsLower: array[0..15] of AnsiChar = '0123456789abcdef'; -begin - JSON_CONTENT_TYPE_VAR := JSON_CONTENT_TYPE; - JSON_CONTENT_TYPE_HEADER_VAR := JSON_CONTENT_TYPE_HEADER; - NULL_STR_VAR := 'null'; - BOOL_UTF8[false] := 'false'; - BOOL_UTF8[true] := 'true'; - {$ifdef FPC} - {$ifdef ISFPC27} - {$ifndef MSWINDOWS} - GetACP := GetSystemCodePage; - {$endif MSWINDOWS} - SetMultiByteConversionCodePage(CP_UTF8); - SetMultiByteRTLFileSystemCodePage(CP_UTF8); - {$endif ISFPC27} - {$endif FPC} - {$ifdef KYLIX3} - // if default locale is set to *.UTF-8, which is the case in most modern - // linux default configuration, unicode decode will fail in SysUtils.CheckLocale - setlocale(LC_CTYPE,'en_US'); // force locale for a UTF-8 server - {$endif} -{$ifndef EXTENDEDTOSHORT_USESTR} - {$ifdef ISDELPHIXE} - SettingsUS := TFormatSettings.Create($0409); - {$else} - GetLocaleFormatSettings($0409,SettingsUS); - {$endif} - SettingsUS.DecimalSeparator := '.'; // value may have been overriden :( -{$endif} - for i := 0 to 255 do - NormToNormByte[i] := i; - NormToUpperAnsi7Byte := NormToNormByte; - for i := ord('a') to ord('z') do - dec(NormToUpperAnsi7Byte[i],32); - {$ifdef OWNNORMTOUPPER} - MoveFast(NormToUpperAnsi7,NormToUpper,138); - MoveFast(n2u,NormToUpperByte[138],SizeOf(n2u)); - for i := 0 to 255 do begin - d := NormToUpperByte[i]; - if d in [ord('A')..ord('Z')] then - inc(d,32); - NormToLowerByte[i] := d; - end; - {$endif OWNNORMTOUPPER} - FillcharFast(ConvertHexToBin[0],SizeOf(ConvertHexToBin),255); // all to 255 - v := 0; - for i := ord('0') to ord('9') do begin - ConvertHexToBin[i] := v; - inc(v); - end; - for i := ord('A') to ord('F') do begin - ConvertHexToBin[i] := v; - ConvertHexToBin[i+(ord('a')-ord('A'))] := v; - inc(v); - end; - for i := 0 to 255 do begin - TwoDigitsHex[i][1] := HexChars[i shr 4]; - TwoDigitsHex[i][2] := HexChars[i and $f]; - end; - for i := 0 to 255 do begin - TwoDigitsHexLower[i][1] := HexCharsLower[i shr 4]; - TwoDigitsHexLower[i][2] := HexCharsLower[i and $f]; - end; - MoveFast(TwoDigitLookup[0], TwoDigitByteLookupW[0], SizeOf(TwoDigitLookup)); - for i := 0 to 199 do - dec(PByteArray(@TwoDigitByteLookupW)[i],ord('0')); // '0'..'9' -> 0..9 - FillcharFast(ConvertBase64ToBin,256,255); // invalid value set to -1 - for i := 0 to high(b64enc) do - ConvertBase64ToBin[b64enc[i]] := i; - ConvertBase64ToBin['='] := -2; // special value for '=' - for i := 0 to high(b64urienc) do - ConvertBase64uriToBin[b64urienc[i]] := i; - for i := high(Baudot2Char) downto 0 do - if Baudot2Char[i]<#128 then - Char2Baudot[Baudot2Char[i]] := i; - for i := ord('a') to ord('z') do - Char2Baudot[AnsiChar(i-32)] := Char2Baudot[AnsiChar(i)]; // A-Z -> a-z - JSON_ESCAPE[0] := 1; // 1 for #0 end of input - for i := 1 to 31 do // 0 indicates no JSON escape needed - JSON_ESCAPE[i] := 2; // 2 should be escaped as \u00xx - JSON_ESCAPE[8] := ord('b'); // others contain the escaped character - JSON_ESCAPE[9] := ord('t'); - JSON_ESCAPE[10] := ord('n'); - JSON_ESCAPE[12] := ord('f'); - JSON_ESCAPE[13] := ord('r'); - JSON_ESCAPE[ord('\')] := ord('\'); - JSON_ESCAPE[ord('"')] := ord('"'); - include(JSON_CHARS[#0], jcEndOfJSONFieldOr0); - for c := low(c) to high(c) do begin - if not (c in [#0,#10,#13]) then - include(TEXT_CHARS[c], tcNot01013); - if c in [#10,#13] then - include(TEXT_CHARS[c], tc1013); - if c in ['0'..'9','a'..'z','A'..'Z'] then - include(TEXT_CHARS[c], tcWord); - if c in ['_','a'..'z','A'..'Z'] then - include(TEXT_CHARS[c], tcIdentifierFirstChar); - if c in ['_','0'..'9','a'..'z','A'..'Z'] then - include(TEXT_CHARS[c], tcIdentifier); - if c in ['_','-','.','0'..'9','a'..'z','A'..'Z'] then - // '~' is part of the RFC 3986 but should be escaped in practice - // see https://blog.synopse.info/?post/2020/08/11/The-RFC%2C-The-URI%2C-and-The-Tilde - include(TEXT_CHARS[c], tcURIUnreserved); - if c in [#1..#9,#11,#12,#14..' '] then - include(TEXT_CHARS[c], tcCtrlNotLF); - if c in [#1..' ',';'] then - include(TEXT_CHARS[c], tcCtrlNot0Comma); - if c in [',',']','}',':'] then begin - include(JSON_CHARS[c], jcEndOfJSONField); - include(JSON_CHARS[c], jcEndOfJSONFieldOr0); - end; - if c in [#0,#9,#10,#13,' ',',','}',']'] then - include(JSON_CHARS[c], jcEndOfJSONValueField); - if c in ['-','0'..'9'] then - include(JSON_CHARS[c], jcDigitFirstChar); - if c in ['-','+','0'..'9'] then - include(JSON_CHARS[c], jcDigitChar); - if c in ['-','+','0'..'9','.','E','e'] then - include(JSON_CHARS[c], jcDigitFloatChar); - if c in ['_','0'..'9','a'..'z','A'..'Z','$'] then - include(JSON_CHARS[c], jcJsonIdentifierFirstChar); - if c in ['_','0'..'9','a'..'z','A'..'Z','.','[',']'] then - include(JSON_CHARS[c], jcJsonIdentifier); - end; - TSynAnsiConvert.Engine(0); // define CurrentAnsi/WinAnsi/UTF8AnsiConvert - for i := 0 to 255 do begin - crc := i; - for n := 1 to 8 do - if (crc and 1)<>0 then // polynom is not the same as with zlib's crc32() - crc := (crc shr 1) xor $82f63b78 else - crc := crc shr 1; - crc32ctab[0,i] := crc; // for crc32cfast() and SymmetricEncrypt/FillRandom - end; - for i := 0 to 255 do begin - crc := crc32ctab[0,i]; - for n := 1 to high(crc32ctab) do begin - crc := (crc shr 8) xor crc32ctab[0,ToByte(crc)]; - crc32ctab[n,i] := crc; - end; - end; - for i := 0 to high(SmallUInt32UTF8) do begin - P := StrUInt32(@tmp[15],i); - FastSetString(SmallUInt32UTF8[i],P,@tmp[15]-P); - end; - KINDTYPE_INFO[djRawUTF8] := TypeInfo(RawUTF8); // for TDynArray.LoadKnownType - KINDTYPE_INFO[djWinAnsi] := TypeInfo(WinAnsiString); - KINDTYPE_INFO[djString] := TypeInfo(String); - KINDTYPE_INFO[djRawByteString] := TypeInfo(RawByteString); - KINDTYPE_INFO[djWideString] := TypeInfo(WideString); - KINDTYPE_INFO[djSynUnicode] := TypeInfo(SynUnicode); - {$ifndef NOVARIANTS}KINDTYPE_INFO[djVariant] := TypeInfo(variant);{$endif} -end; - -initialization - // initialization of internal dynamic functions and tables - InitFunctionsRedirection; - InitializeCriticalSection(GlobalCriticalSection); - GarbageCollectorFreeAndNilList := TSynList.Create; - GarbageCollectorFreeAndNil(GarbageCollector,TSynObjectList.Create); - InitSynCommonsConversionTables; - RetrieveSystemInfo; - SetExecutableVersion(0,0,0,0); - AlgoSynLZ := TAlgoSynLZ.Create; - GarbageCollectorFreeAndNil(GlobalCustomJSONSerializerFromTextSimpleType, - TSynDictionary.Create(TypeInfo(TRawUTF8DynArray), - TypeInfo(TJSONSerializerFromTextSimpleDynArray),true)); - TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType( - {$ifdef ISDELPHI2010}TypeInfo(TGUID){$else}nil{$endif},'TGUID'); - TTextWriter.RegisterCustomJSONSerializerFromText([ - TypeInfo(TFindFilesDynArray), - 'Name:string Attr:Integer Size:Int64 Timestamp:TDateTime']); - // some paranoid cross-platform/cross-compiler assertions - {$ifndef NOVARIANTS} - Assert(SizeOf(TVarData)={$ifdef CPU64}24{$else}16{$endif}); // for ExchgVariant - Assert(SizeOf(TDocVariantData)=SizeOf(TVarData)); - DocVariantType := TDocVariant(SynRegisterCustomVariantType(TDocVariant)); - DocVariantVType := DocVariantType.VarType; - {$endif NOVARIANTS} - {$ifndef FPC}{$warnings OFF}{$endif} - Assert((MAX_SQLFIELDS>=64)and(MAX_SQLFIELDS<=256)); - {$ifndef FPC}{$warnings ON}{$endif} - Assert(SizeOf(THash128Rec)=SizeOf(THash128)); - Assert(SizeOf(THash256Rec)=SizeOf(THash256)); - Assert(SizeOf(TBlock128)=SizeOf(THash128)); - assert(SizeOf(TSynSystemTime)=SizeOf(TSystemTime)); - assert(SizeOf(TSynSystemTime)=SizeOf(THash128)); - Assert(SizeOf(TOperatingSystemVersion)=SizeOf(integer)); - Assert(SizeOf(TSynLocker)>=128,'cpucacheline'); - Assert(SizeOf(TJsonChar)=1); - Assert(SizeOf(TTextChar)=1); - {$ifdef MSWINDOWS} - {$ifndef CPU64} - Assert(SizeOf(TFileTime)=SizeOf(Int64)); // see e.g. FileTimeToInt64 - {$endif CPU64} - {$endif MSWINDOWS} - -finalization - {$ifndef NOVARIANTS} - DocVariantType.Free; - {$endif NOVARIANTS} - GarbageCollectorFree; - DeleteCriticalSection(GlobalCriticalSection); - //writeln('TDynArrayHashedCollisionCount=',TDynArrayHashedCollisionCount); readln; -end. diff --git a/lib/dmustache/SynDoubleToText.inc b/lib/dmustache/SynDoubleToText.inc deleted file mode 100644 index 75f933b9..00000000 --- a/lib/dmustache/SynDoubleToText.inc +++ /dev/null @@ -1,950 +0,0 @@ -/// efficient double to text conversion using the GRISU-1 algorithm -// - as a complement to SynCommons, which tended to increase too much -// - licensed under a MPL/GPL/LGPL tri-license; version 1.18 - -{ - Implement 64-bit floating point (double) to ASCII conversion using the - GRISU-1 efficient algorithm. - - Original Code in flt_core.inc flt_conv.inc flt_pack.inc from FPC RTL. - Copyright (C) 2013 by Max Nazhalov - Licenced with LGPL 2 with the linking exception. - If you don't agree with these License terms, disable this feature - by undefining DOUBLETOSHORT_USEGRISU in Synopse.inc - - GRISU Original Algorithm - Copyright (c) 2009 Florian Loitsch - - We extracted a double-to-ascii only cut-down version of those files, - and made a huge refactoring to reach the best performance, especially - tuning the Intel target with some dedicated asm and code rewrite. - - With Delphi 10.3 on Win32: (no benefit) - 100000 FloatToText in 38.11ms i.e. 2,623,570/s, aver. 0us, 47.5 MB/s - 100000 str in 43.19ms i.e. 2,315,082/s, aver. 0us, 50.7 MB/s - 100000 DoubleToShort in 45.50ms i.e. 2,197,367/s, aver. 0us, 43.8 MB/s - 100000 DoubleToAscii in 42.44ms i.e. 2,356,045/s, aver. 0us, 47.8 MB/s - - With Delphi 10.3 on Win64: - 100000 FloatToText in 61.83ms i.e. 1,617,233/s, aver. 0us, 29.3 MB/s - 100000 str in 53.20ms i.e. 1,879,663/s, aver. 0us, 41.2 MB/s - 100000 DoubleToShort in 18.45ms i.e. 5,417,998/s, aver. 0us, 108 MB/s - 100000 DoubleToAscii in 18.19ms i.e. 5,496,921/s, aver. 0us, 111.5 MB/s - - With FPC on Win32: - 100000 FloatToText in 115.62ms i.e. 864,842/s, aver. 1us, 15.6 MB/s - 100000 str in 57.30ms i.e. 1,745,109/s, aver. 0us, 39.9 MB/s - 100000 DoubleToShort in 23.88ms i.e. 4,187,078/s, aver. 0us, 83.5 MB/s - 100000 DoubleToAscii in 23.34ms i.e. 4,284,490/s, aver. 0us, 86.9 MB/s - - With FPC on Win64: - 100000 FloatToText in 76.92ms i.e. 1,300,052/s, aver. 0us, 23.5 MB/s - 100000 str in 27.70ms i.e. 3,609,456/s, aver. 0us, 82.6 MB/s - 100000 DoubleToShort in 14.73ms i.e. 6,787,944/s, aver. 0us, 135.4 MB/s - 100000 DoubleToAscii in 13.78ms i.e. 7,253,735/s, aver. 0us, 147.2 MB/s - - With FPC on Linux x86_64: - 100000 FloatToText in 81.48ms i.e. 1,227,249/s, aver. 0us, 22.2 MB/s - 100000 str in 36.98ms i.e. 2,703,871/s, aver. 0us, 61.8 MB/s - 100000 DoubleToShort in 13.11ms i.e. 7,626,601/s, aver. 0us, 152.1 MB/s - 100000 DoubleToAscii in 12.59ms i.e. 7,942,180/s, aver. 0us, 161.2 MB/s - - - Our rewrite is twice faster than original flt_conv.inc from FPC RTL (str) - - Delphi Win32 has trouble making 64-bit computation - no benefit since it - has good optimized i87 asm (but slower than our code with FPC/Win32) - - FPC is more efficient when compiling integer arithmetic; we avoided slow - division by calling our Div100(), but Delphi Win64 is still far behind - - Delphi Win64 has very slow FloatToText and str() - -} - - -// Controls printing of NaN-sign. -// Undefine to print NaN sign during float->ASCII conversion. -// IEEE does not interpret the sign of a NaN, so leave it defined. -{$define GRISU1_F2A_NAN_SIGNLESS} - -// Controls rounding of generated digits when formatting with narrowed -// width (either fixed or exponential notation). -// Traditionally, FPC and BP7/Delphi use "roundTiesToAway" mode. -// Undefine to use "roundTiesToEven" approach. -{$define GRISU1_F2A_HALF_ROUNDUP} - -// This one is a hack against Grusu sub-optimality. -// It may be used only strictly together with GRISU1_F2A_HALF_ROUNDUP. -// It does not violate most general rules due to the fact that it is -// applicable only when formatting with narrowed width, where the fine -// view is more desirable, and the precision is already lost, so it can -// be used in general-purpose applications. -// Refer to its implementation. -{$define GRISU1_F2A_AGRESSIVE_ROUNDUP} // Defining this fixes several tests. - -// Undefine to enable SNaN support. -// Note: IEEE [754-2008, page 31] requires (1) to recognize "SNaN" during -// ASCII->float, and (2) to generate the "invalid FP operation" exception -// either when SNaN is printed as "NaN", or "SNaN" is evaluated to QNaN, -// so it would be preferable to undefine these settings, -// but the FPC RTL is not ready for this right now.. -{$define GRISU1_F2A_NO_SNAN} - -/// If Value=0 would just store '0', whatever frac_digits is supplied. -{$define GRISU1_F2A_ZERONOFRACT} - - -{$ifndef FPC} - -// those functions are intrinsics with FPC :) - -function BSRdword(c: cardinal): cardinal; -asm - {$ifdef CPU64} - .noframe - mov eax, c - {$endif} - bsr eax, eax -end; // in our code below, we are sure that c<>0 - -function BSRqword(const q: qword): cardinal; -asm - {$ifdef CPU32} - bsr eax, [esp + 8] - jz @1 - add eax, 32 - ret -@1: bsr eax, [esp + 4] -@2: {$else} - .noframe - mov rax, q - bsr rax, rax - {$endif} -end; // in our code below, we are sure that q<>0 - - -{$endif FPC} - -const - // TFloatFormatProfile for double - nDig_mantissa = 17; - nDig_exp10 = 3; - -type - // "Do-It-Yourself Floating Point" structures - TDIY_FP = record - f: qword; - e: integer; - end; - - TDIY_FP_Power_of_10 = record - c: TDIY_FP; - e10: integer; - end; - PDIY_FP_Power_of_10 = ^TDIY_FP_Power_of_10; - -const - ROUNDER = $80000000; - -{$ifdef CPUINTEL} // our faster version using 128-bit x86_64 multiplication - -procedure d2a_diy_fp_multiply(var x, y: TDIY_FP; normalize: boolean; - out result: TDIY_FP); {$ifdef HASINLINE} inline; {$endif} -var - p: THash128Rec; -begin - mul64x64(x.f, y.f, p); // fast x86_64 / i386 asm - if (p.c1 and ROUNDER) <> 0 then - inc(p.h); - result.f := p.h; - result.e := PtrInt(x.e) + PtrInt(y.e) + 64; - if normalize then - if (PQWordRec(@result.f)^.h and ROUNDER) = 0 then - begin - result.f := result.f * 2; - dec(result.e); - end; -end; - -{$else} // regular Grisu method - optimized for 32-bit CPUs - -procedure d2a_diy_fp_multiply(var x, y: TDIY_FP; normalize: boolean; out result: TDIY_FP); -var - _x: TQWordRec absolute x; - _y: TQWordRec absolute y; - r: TQWordRec absolute result; - ac, bc, ad, bd, t1: TQWordRec; -begin - ac.v := qword(_x.h) * _y.h; - bc.v := qword(_x.l) * _y.h; - ad.v := qword(_x.h) * _y.l; - bd.v := qword(_x.l) * _y.l; - t1.v := qword(ROUNDER) + bd.h + bc.l + ad.l; - result.f := ac.v + ad.h + bc.h + t1.h; - result.e := x.e + y.e + 64; - if normalize then - if (r.h and ROUNDER) = 0 then - begin - inc(result.f, result.f); - dec(result.e); - end; -end; - -{$endif CPUINTEL} - -const - // alpha =-61; gamma = 0 - // full cache: 1E-450 .. 1E+432, step = 1E+18 - // sparse = 1/10 - C_PWR10_DELTA = 18; - C_PWR10_COUNT = 50; - -type - TDIY_FP_Cached_Power10 = record - base: array [ 0 .. 9 ] of TDIY_FP_Power_of_10; - factor_plus: array [ 0 .. 1 ] of TDIY_FP_Power_of_10; - factor_minus: array [ 0 .. 1 ] of TDIY_FP_Power_of_10; - // extra mantissa correction [ulp; signed] - corrector: array [ 0 .. C_PWR10_COUNT - 1 ] of shortint; - end; - -const - CACHED_POWER10: TDIY_FP_Cached_Power10 = ( - base: ( - ( c: ( f: qword($825ECC24C8737830); e: -362 ); e10: -90 ), - ( c: ( f: qword($E2280B6C20DD5232); e: -303 ); e10: -72 ), - ( c: ( f: qword($C428D05AA4751E4D); e: -243 ); e10: -54 ), - ( c: ( f: qword($AA242499697392D3); e: -183 ); e10: -36 ), - ( c: ( f: qword($9392EE8E921D5D07); e: -123 ); e10: -18 ), - ( c: ( f: qword($8000000000000000); e: -63 ); e10: 0 ), - ( c: ( f: qword($DE0B6B3A76400000); e: -4 ); e10: 18 ), - ( c: ( f: qword($C097CE7BC90715B3); e: 56 ); e10: 36 ), - ( c: ( f: qword($A70C3C40A64E6C52); e: 116 ); e10: 54 ), - ( c: ( f: qword($90E40FBEEA1D3A4B); e: 176 ); e10: 72 ) - ); - factor_plus: ( - ( c: ( f: qword($F6C69A72A3989F5C); e: 534 ); e10: 180 ), - ( c: ( f: qword($EDE24AE798EC8284); e: 1132 ); e10: 360 ) - ); - factor_minus: ( - ( c: ( f: qword($84C8D4DFD2C63F3B); e: -661 ); e10: -180 ), - ( c: ( f: qword($89BF722840327F82); e: -1259 ); e10: -360 ) - ); - corrector: ( - 0, 0, 0, 0, 1, 0, 0, 0, 1, -1, - 0, 1, 1, 1, -1, 0, 0, 1, 0, -1, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - -1, 0, 0, -1, 0, 0, 0, 0, 0, -1, - 0, 0, 0, 0, 1, 0, 0, 0, -1, 0 - )); - CACHED_POWER10_MIN10 = -90 -360; - // = ref.base[low(ref.base)].e10 + ref.factor_minus[high(ref.factor_minus)].e10 - -// return normalized correctly rounded approximation of the power of 10 -// scaling factor, intended to shift a binary exponent of the original number -// into selected [ alpha .. gamma ] range -procedure d2a_diy_fp_cached_power10(exp10: integer; out factor: TDIY_FP_Power_of_10); -var - i, xmul: integer; - A, B: PDIY_FP_Power_of_10; - cx: PtrInt; - ref: ^TDIY_FP_Cached_Power10; -begin - ref := @CACHED_POWER10; // much better code generation on PIC/x86_64 - // find non-sparse index - if exp10 <= CACHED_POWER10_MIN10 then - i := 0 - else - begin - i := (exp10 - CACHED_POWER10_MIN10) div C_PWR10_DELTA; - if i * C_PWR10_DELTA + CACHED_POWER10_MIN10 <> exp10 then - inc(i); // round-up - if i > C_PWR10_COUNT - 1 then - i := C_PWR10_COUNT - 1; - end; - // generate result - xmul := i div length(ref.base); - A := @ref.base[i - (xmul * length(ref.base))]; // fast mod - dec(xmul, length(ref.factor_minus)); - if xmul = 0 then - begin - // base - factor := A^; - exit; - end; - // surrogate - if xmul > 0 then - begin - dec(xmul); - B := @ref.factor_plus[xmul]; - end - else - begin - xmul := -(xmul + 1); - B := @ref.factor_minus[xmul]; - end; - factor.e10 := A.e10 + B.e10; - if A.e10 <> 0 then - begin - d2a_diy_fp_multiply(A.c, B.c, true, factor.c); - // adjust mantissa - cx := ref.corrector[i]; - if cx <> 0 then - inc(int64(factor.c.f), int64(cx)); - end - else - // exact - factor.c := B^.c; -end; - - -procedure d2a_unpack_float(const f: double; out minus: boolean; out result: TDIY_FP); - {$ifdef HASINLINE} inline;{$endif} -type - TSplitFloat = packed record - case byte of - 0: (f: double); - 1: (b: array[0..7] of byte); - 2: (w: array[0..3] of word); - 3: (d: array[0..1] of cardinal); - 4: (l: qword); - end; -var - doublebits: TSplitFloat; -begin -{$ifdef FPC_DOUBLE_HILO_SWAPPED} - // high and low cardinal are swapped when using the arm fpa - doublebits.d[0] := TSplitFloat(f).d[1]; - doublebits.d[1] := TSplitFloat(f).d[0]; -{$else not FPC_DOUBLE_HILO_SWAPPED} - doublebits.f := f; -{$endif FPC_DOUBLE_HILO_SWAPPED} -{$ifdef endian_big} - minus := (doublebits.b[0] and $80 <> 0); - result.e := (doublebits.w[0] shr 4) and $7FF; -{$else endian_little} - minus := (doublebits.b[7] and $80 <> 0); - result.e := (doublebits.w[3] shr 4) and $7FF; -{$endif endian} - result.f := doublebits.l and $000FFFFFFFFFFFFF; -end; - -const - C_FRAC2_BITS = 52; - C_EXP2_BIAS = 1023; - C_DIY_FP_Q = 64; - C_GRISU_ALPHA = -61; - C_GRISU_GAMMA = 0; - - C_EXP2_SPECIAL = C_EXP2_BIAS * 2 + 1; - C_MANT2_INTEGER = qword(1) shl C_FRAC2_BITS; - -type - TAsciiDigits = array[0..47] of byte; - PAsciiDigits = ^TAsciiDigits; - -// convert unsigned integers into decimal digits - -{$ifdef FPC_64} // leverage efficient FPC 64-bit division as mul reciprocal - -function d2a_gen_digits_64(buf: PAsciiDigits; x: qword): PtrInt; -var - tab: PWordArray; - P: PAnsiChar; - c100: qword; -begin - tab := @TwoDigitByteLookupW; // 0..99 value -> two byte digits (0..9) - P := PAnsiChar(@buf[24]); // append backwards - repeat - if x >= 100 then - begin - dec(P, 2); - c100 := x div 100; - dec(x, c100 * 100); - PWord(P)^ := tab[x]; - if c100 = 0 then - break; - x := c100; - continue; - end; - if x < 10 then - begin - dec(P); - P^ := AnsiChar(x); - break; - end; - dec(P, 2); - PWord(P)^ := tab[x]; - break; - until false; - PQWordArray(buf)[0] := PQWordArray(P)[0]; // faster than MoveSmall(P,buf,result) - PQWordArray(buf)[1] := PQWordArray(P)[1]; - PQWordArray(buf)[2] := PQWordArray(P)[2]; - result := PAnsiChar(@buf[24]) - P; -end; - -{$else not FPC_64} // use three 32-bit groups of digit - -function d2a_gen_digits_32(buf: PAsciiDigits; x: dword; pad_9zero: boolean): PtrInt; -const - digits: array[0..9] of cardinal = ( - 0, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000); -var - n: PtrInt; - m: cardinal; - {$ifdef FPC} - z: cardinal; - {$else} - d100: TDiv100Rec; - {$endif FPC} - tab: PWordArray; -begin - // Calculate amount of digits - if x = 0 then - n := 0 // emit nothing if padding is not required - else - begin - n := integer((BSRdword(x) + 1) * 1233) shr 12; - if x >= digits[n] then - inc(n); - end; - if pad_9zero and (n < 9) then - n := 9; - result := n; - if n = 0 then - exit; - // Emit digits - dec(PByte(buf)); - tab := @TwoDigitByteLookupW; - m := x; - while (n >= 2) and (m <> 0) do - begin - dec(n); - {$ifdef FPC} // FPC will use fast mul reciprocal - z := m div 100; // compute two 0..9 digits - PWord(@buf[n])^ := tab^[m - z * 100]; - m := z; - {$else} - Div100(m, d100); // our asm is faster than Delphi div operation - PWord(@buf[n])^ := tab^[d100.M]; - m := d100.D; - {$endif FPC} - dec(n); - end; - if n = 0 then - exit; - if m <> 0 then - begin - if m > 9 then - m := m mod 10; // compute last 0..9 digit - buf[n] := m; - dec(n); - if n = 0 then - exit; - end; - repeat - buf[n] := 0; // padding with 0 - dec(n); - until n = 0; -end; - -function d2a_gen_digits_64(buf: PAsciiDigits; const x: qword): PtrInt; -var - n_digits: PtrInt; - temp: qword; - splitl, splitm, splith: cardinal; -begin - // Split X into 3 unsigned 32-bit integers; lower two should be < 10 digits long - n_digits := 0; - if x < 1000000000 then - splitl := x - else - begin - temp := x div 1000000000; - splitl := x - temp * 1000000000; - if temp < 1000000000 then - splitm := temp - else - begin - splith := temp div 1000000000; - splitm := cardinal(temp) - splith * 1000000000; - n_digits := d2a_gen_digits_32(buf, splith, false); // Generate hi digits - end; - inc(n_digits, d2a_gen_digits_32(@buf[n_digits], splitm, n_digits <> 0)); - end; - // Generate digits - inc(n_digits, d2a_gen_digits_32(@buf[n_digits], splitl, n_digits <> 0)); - result := n_digits; -end; - -{$endif FPC_64} - -// Performs digit sequence rounding, returns decimal point correction -function d2a_round_digits(var buf: TAsciiDigits; var n_current: integer; - n_max: PtrInt; half_round_to_even: boolean = true): PtrInt; -var - n: PtrInt; - dig_round, dig_sticky: byte; - {$ifdef GRISU1_F2A_AGRESSIVE_ROUNDUP} - i: PtrInt; - {$endif} -begin - result := 0; - n := n_current; - n_current := n_max; - // Get round digit - dig_round := buf[n_max]; -{$ifdef GRISU1_F2A_AGRESSIVE_ROUNDUP} - // Detect if rounding-up the second last digit turns the "dig_round" - // into "5"; also make sure we have at least 1 digit between "dig_round" - // and the second last. - if not half_round_to_even then - if (dig_round = 4) and (n_max < n - 3) then - if buf[n - 2] >= 8 then // somewhat arbitrary... - begin - // check for only "9" are in between - i := n - 2; - repeat - dec(i); - until (i = n_max) or (buf[i] <> 9); - if i = n_max then - // force round-up - dig_round := 9; // any value ">=5" - end; -{$endif GRISU1_F2A_AGRESSIVE_ROUNDUP} - if dig_round < 5 then - exit; - // Handle "round half to even" case - if (dig_round = 5) and half_round_to_even and - ((n_max = 0) or (buf[n_max - 1] and 1 = 0)) then - begin - // even and a half: check if exactly the half - dig_sticky := 0; - while (n > n_max + 1) and (dig_sticky = 0) do - begin - dec(n); - dig_sticky := buf[n]; - end; - if dig_sticky = 0 then - exit; // exactly a half -> no rounding is required - end; - // Round-up - while n_max > 0 do - begin - dec(n_max); - inc(buf[n_max]); - if buf[n_max] < 10 then - begin - // no more overflow: stop now - n_current := n_max + 1; - exit; - end; - // continue rounding - end; - // Overflow out of the 1st digit, all n_max digits became 0 - buf[0] := 1; - n_current := 1; - result := 1; -end; - - -// format the number in the fixed-point representation -procedure d2a_return_fixed(str: PAnsiChar; minus: boolean; var digits: TAsciiDigits; - n_digits_have, fixed_dot_pos, frac_digits: integer); -var - p: PAnsiChar; - d: PByte; - cut_digits_at, n_before_dot, n_before_dot_pad0, n_after_dot_pad0, - n_after_dot, n_tail_pad0: integer; -begin - // Round digits if necessary - cut_digits_at := fixed_dot_pos + frac_digits; - if cut_digits_at < 0 then - // zero - n_digits_have := 0 - else if cut_digits_at < n_digits_have then - // round digits - inc(fixed_dot_pos, d2a_round_digits(digits, n_digits_have, cut_digits_at - {$ifdef GRISU1_F2A_HALF_ROUNDUP}, false {$endif} )); - // Before dot: digits, pad0 - if (fixed_dot_pos <= 0) or (n_digits_have = 0) then - begin - n_before_dot := 0; - n_before_dot_pad0 := 1; - end - else if fixed_dot_pos > n_digits_have then - begin - n_before_dot := n_digits_have; - n_before_dot_pad0 := fixed_dot_pos - n_digits_have; - end - else - begin - n_before_dot := fixed_dot_pos; - n_before_dot_pad0 := 0; - end; - // After dot: pad0, digits, pad0 - if fixed_dot_pos < 0 then - n_after_dot_pad0 := -fixed_dot_pos - else - n_after_dot_pad0 := 0; - if n_after_dot_pad0 > frac_digits then - n_after_dot_pad0 := frac_digits; - n_after_dot := n_digits_have - n_before_dot; - n_tail_pad0 := frac_digits - n_after_dot - n_after_dot_pad0; - p := str + 1; - // Sign - if minus then - begin - p^ := '-'; - inc(p); - end; - // Integer significant digits - d := @digits; - if n_before_dot > 0 then - repeat - p^ := AnsiChar(d^ + ord('0')); - inc(p); - inc(d); - dec(n_before_dot); - until n_before_dot = 0; - // Integer 0-padding - if n_before_dot_pad0 > 0 then - repeat - p^ := '0'; - inc(p); - dec(n_before_dot_pad0); - until n_before_dot_pad0 = 0; - // - if frac_digits <> 0 then - begin - // Dot - p^ := '.'; - inc(p); - // Pre-fraction 0-padding - if n_after_dot_pad0 > 0 then - repeat - p^ := '0'; - inc(p); - dec(n_after_dot_pad0); - until n_after_dot_pad0 = 0; - // Fraction significant digits - if n_after_dot > 0 then - repeat - p^ := AnsiChar(d^ + ord('0')); - inc(p); - inc(d); - dec(n_after_dot); - until n_after_dot = 0; - // Tail 0-padding - if n_tail_pad0 > 0 then - repeat - p^ := '0'; - inc(p); - dec(n_tail_pad0); - until n_tail_pad0 = 0; - end; - // Store length - str[0] := AnsiChar(p - str - 1); -end; - -// formats the number as exponential representation -procedure d2a_return_exponential(str: PAnsiChar; minus: boolean; - digits: PByte; n_digits_have, n_digits_req, d_exp: PtrInt); -var - p, exp: PAnsiChar; -begin - p := str + 1; - // Sign - if minus then - begin - p^ := '-'; - inc(p); - end; - // Integer part - if n_digits_have > 0 then - begin - p^ := AnsiChar(digits^ + ord('0')); - dec(n_digits_have); - end - else - p^ := '0'; - inc(p); - // Dot - if n_digits_req > 1 then - begin - p^ := '.'; - inc(p); - end; - // Fraction significant digits - if n_digits_req < n_digits_have then - n_digits_have := n_digits_req; - if n_digits_have > 0 then - begin - repeat - inc(digits); - p^ := AnsiChar(digits^ + ord('0')); - inc(p); - dec(n_digits_have); - until n_digits_have = 0; - while p[-1] = '0' do - dec(p); // trim #.###00000 -> #.### - if p[-1] = '.' then - dec(p); // #.0 -> # - end; - // Exponent designator - p^ := 'E'; - inc(p); - // Exponent sign (+ is not stored, as in Delphi) - if d_exp < 0 then - begin - p^ := '-'; - d_exp := -d_exp; - inc(p); - end; - // Exponent digits - exp := pointer(SmallUInt32UTF8[d_exp]); // 0..999 range is fine - PCardinal(p)^ := PCardinal(exp)^; - inc(p, PStrLen(exp - _STRLEN)^); - // Store length - str[0] := AnsiChar(p - str - 1); -end; - -/// set one of special results with proper sign -procedure d2a_return_special(str: PAnsiChar; sign: integer; const spec: shortstring); -begin - // Compute length - str[0] := spec[0]; - if sign <> 0 then - inc(str[0]); - inc(str); - // Sign - if sign <> 0 then - begin - if sign > 0 then - str^ := '+' - else - str^ := '-'; - inc(str); - end; - // Special text (3 chars) - PCardinal(str)^ := PCardinal(@spec[1])^; -end; - - -// Calculates the exp10 of a factor required to bring the binary exponent -// of the original number into selected [ alpha .. gamma ] range: -// result := ceiling[ ( alpha - e ) * log10(2) ] -function d2a_k_comp(e, alpha{, gamma}: integer): integer; -var - dexp: double; -const - D_LOG10_2: double = 0.301029995663981195213738894724493027; // log10(2) -var - x, n: integer; -begin - x := alpha - e; - dexp := x * D_LOG10_2; - // ceil( dexp ) - n := trunc(dexp); - if x > 0 then - if dexp <> n then - inc(n); // round-up - result := n; -end; - - -/// raw function to convert a 64-bit double into a shortstring, stored in str -// - implements Fabian Loitsch's Grisu algorithm dedicated to double values -// - currently, SynCommnons only set min_width=0 (for DoubleToShortNoExp to avoid -// any scientific notation ) or min_width=C_NO_MIN_WIDTH (for DoubleToShort to -// force the scientific notation when the double cannot be represented as -// a simple fractinal number) -procedure DoubleToAscii(min_width, frac_digits: integer; const v: double; str: PAnsiChar); -var - w, D: TDIY_FP; - c_mk: TDIY_FP_Power_of_10; - n, mk, dot_pos, n_digits_need, n_digits_have: integer; - n_digits_req, n_digits_sci: integer; - minus: boolean; - fl, one_maskl: qword; - one_e: integer; - {$ifdef CPU32} - one_mask, f: cardinal; // run a 2nd loop with 32-bit range - {$endif CPU32} - buf: TAsciiDigits; -begin - // Limit parameters - if frac_digits > 216 then - frac_digits := 216; // Delphi compatible - if min_width <= C_NO_MIN_WIDTH then - min_width := -1 // no minimal width - else if min_width < 0 then - min_width := 0; // minimal width is as short as possible - // Format profile: select "n_digits_need" (and "n_digits_exp") - n_digits_req := nDig_mantissa; - // number of digits to be calculated by Grisu - n_digits_need := nDig_mantissa; - if n_digits_req < n_digits_need then - n_digits_need := n_digits_req; - // number of mantissa digits to be printed in exponential notation - if min_width < 0 then - n_digits_sci := n_digits_req - else - begin - n_digits_sci := min_width -1 {sign} -1 {dot} -1 {E} -1 {E-sign} - nDig_exp10; - if n_digits_sci < 2 then - n_digits_sci := 2; // at least 2 digits - if n_digits_sci > n_digits_req then - n_digits_sci := n_digits_req; // at most requested by real_type - end; - // Float -> DIY_FP - d2a_unpack_float(v, minus, w); - // Handle Zero - if (w.e = 0) and (w.f = 0) then - begin - {$ifdef GRISU1_F2A_ZERONOFRACT} - PWord(str)^ := 1 + ord('0') shl 8; // just return '0' - {$else} - if frac_digits >= 0 then - d2a_return_fixed(str, minus, buf, 0, 1, frac_digits) - else - d2a_return_exponential(str, minus, @buf, 0, n_digits_sci, 0); - {$endif GRISU1_F2A_ZERONOFRACT} - exit; - end; - // Handle specials - if w.e = C_EXP2_SPECIAL then - begin - n := 1 - ord(minus) * 2; // default special sign [-1|+1] - if w.f = 0 then - d2a_return_special(str, n, C_STR_INF) - else - begin - // NaN [also pseudo-NaN, pseudo-Inf, non-normal for floatx80] - {$ifdef GRISU1_F2A_NAN_SIGNLESS} - n := 0; - {$endif} - {$ifndef GRISU1_F2A_NO_SNAN} - if (w.f and (C_MANT2_INTEGER shr 1)) = 0 then - return_special(str, n, C_STR_SNAN) - else - {$endif GRISU1_F2A_NO_SNAN} - d2a_return_special(str, n, C_STR_QNAN); - end; - exit; - end; - // Handle denormals - if w.e <> 0 then - begin - // normal - w.f := w.f or C_MANT2_INTEGER; - n := C_DIY_FP_Q - C_FRAC2_BITS - 1; - end - else - begin - // denormal (w.e=0) - n := 63 - BSRqword(w.f); // we are sure that w.f<>0 - see Handle Zero above - inc(w.e); - end; - // Final normalization - w.f := w.f shl n; - dec(w.e, C_EXP2_BIAS + n + C_FRAC2_BITS); - // 1. Find the normalized "c_mk = f_c * 2^e_c" such that - // "alpha <= e_c + e_w + q <= gamma" - // 2. Define "V = D * 10^k": multiply the input number by "c_mk", do not - // normalize to land into [ alpha .. gamma ] - // 3. Generate digits ( n_digits_need + "round" ) - if (C_GRISU_ALPHA <= w.e) and (w.e <= C_GRISU_GAMMA) then - begin - // no scaling required - D := w; - c_mk.e10 := 0; - end - else - begin - mk := d2a_k_comp(w.e, C_GRISU_ALPHA{, C_GRISU_GAMMA} ); - d2a_diy_fp_cached_power10(mk, c_mk); - // Let "D = f_D * 2^e_D := w (*) c_mk" - if c_mk.e10 = 0 then - D := w - else - d2a_diy_fp_multiply(w, c_mk.c, false, D); - end; - // Generate digits: integer part - n_digits_have := d2a_gen_digits_64(@buf, D.f shr (-D.e)); - dot_pos := n_digits_have; - // Generate digits: fractional part - {$ifdef CPU32} - f := 0; // "sticky" digit - {$endif CPU32} - if D.e < 0 then - repeat - // MOD by ONE - one_e := D.e; - one_maskl := qword(1) shl (-D.e) - 1; - fl := D.f and one_maskl; - // 64-bit loop (very efficient on x86_64, slower on i386) - while {$ifdef CPU32} (one_e < -29) and {$endif} - (n_digits_have < n_digits_need + 1) and (fl <> 0) do - begin - // f := f * 5; - inc(fl, fl shl 2); - // one := one / 2 - one_maskl := one_maskl shr 1; - inc(one_e); - // DIV by one - buf[n_digits_have] := fl shr (-one_e); - // MOD by one - fl := fl and one_maskl; - // next - inc(n_digits_have); - end; - {$ifdef CPU32} - if n_digits_have >= n_digits_need + 1 then - begin - // only "sticky" digit remains - f := ord(fl <> 0); - break; - end; - one_mask := cardinal(one_maskl); - f := cardinal(fl); - // 32-bit loop - while (n_digits_have < n_digits_need + 1) and (f <> 0) do - begin - // f := f * 5; - inc(f, f shl 2); - // one := one / 2 - one_mask := one_mask shr 1; - inc(one_e); - // DIV by one - buf[n_digits_have] := f shr (-one_e); - // MOD by one - f := f and one_mask; - // next - inc(n_digits_have); - end; - {$endif CPU32} - until true; - {$ifdef CPU32} - // Append "sticky" digit if any - if (f <> 0) and (n_digits_have >= n_digits_need + 1) then - begin - // single "<>0" digit is enough - n_digits_have := n_digits_need + 2; - buf[n_digits_need + 1] := 1; - end; - {$endif CPU32} - // Round to n_digits_need using "roundTiesToEven" - if n_digits_have > n_digits_need then - inc(dot_pos, d2a_round_digits(buf, n_digits_have, n_digits_need)); - // Generate output - if frac_digits >= 0 then - begin - d2a_return_fixed(str, minus, buf, n_digits_have, dot_pos - c_mk.e10, - frac_digits); - exit; - end; - if n_digits_have > n_digits_sci then - inc(dot_pos, d2a_round_digits(buf, n_digits_have, n_digits_sci - {$ifdef GRISU1_F2A_HALF_ROUNDUP}, false {$endif} )); - d2a_return_exponential(str, minus, @buf, n_digits_have, n_digits_sci, - dot_pos - c_mk.e10 - 1); -end; - diff --git a/lib/dmustache/SynFPCLinux.pas b/lib/dmustache/SynFPCLinux.pas deleted file mode 100644 index b6b8671f..00000000 --- a/lib/dmustache/SynFPCLinux.pas +++ /dev/null @@ -1,1201 +0,0 @@ -/// wrapper of some Windows-like functions translated to Linux/BSD for FPC -// - this unit is a part of the freeware Synopse mORMot framework, -// licensed under a MPL/GPL/LGPL tri-license; version 1.18 -unit SynFPCLinux; - -{ - This file is part of Synopse mORMot framework. - - Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez - Synopse Informatique - https://synopse.info - - *** BEGIN LICENSE BLOCK ***** - Version: MPL 1.1/GPL 2.0/LGPL 2.1 - - The contents of this file are subject to the Mozilla Public License Version - 1.1 (the "License"); you may not use this file except in compliance with - the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License - for the specific language governing rights and limitations under the License. - - The Original Code is Synopse mORMot framework. - - The Initial Developer of the Original Code is Alfred Glaenzer. - - Portions created by the Initial Developer are Copyright (C) 2022 - the Initial Developer. All Rights Reserved. - - Contributor(s): - - Alan Chate - - Arnaud Bouchez - - - Alternatively, the contents of this file may be used under the terms of - either the GNU General Public License Version 2 or later (the "GPL"), or - the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), - in which case the provisions of the GPL or the LGPL are applicable instead - of those above. if you wish to allow use of your version of this file only - under the terms of either the GPL or the LGPL, and not to allow others to - use your version of this file under the terms of the MPL, indicate your - decision by deleting the provisions above and replace them with the notice - and other provisions required by the GPL or the LGPL. if you do not delete - the provisions above, a recipient may use your version of this file under - the terms of any one of the MPL, the GPL or the LGPL. - - ***** END LICENSE BLOCK ***** - -} - -interface - - -{$ifndef FPC} - 'this unit is for FPC only - do not include it in any Delphi project!' -{$endif FPC} - - -{$I Synopse.inc} // set proper flags, and define LINUX for BSD and ANDROID - -uses - {$ifdef LINUX} - BaseUnix, - UnixType, - {$endif LINUX} - SysUtils; - -const - { HRESULT codes, delphi-like } - NOERROR = 0; - NO_ERROR = 0; - INVALID_HANDLE_VALUE = THandle(-1); - - LOCALE_USER_DEFAULT = $400; - - // for CompareStringW() - NORM_IGNORECASE = 1 shl ord(coIgnoreCase); // [widestringmanager.coIgnoreCase] - -/// compatibility function, wrapping Win32 API mutex initialization -procedure InitializeCriticalSection(var cs : TRTLCriticalSection); inline; - -/// compatibility function, wrapping Win32 API mutex finalization -procedure DeleteCriticalSection(var cs : TRTLCriticalSection); inline; - -{$ifdef LINUX} - -/// used by SynCommons to compute the sizes in byte -function getpagesize: Integer; cdecl; external 'c'; - -/// compatibility function, wrapping Win32 API high resolution timer -// - returns nanoseconds resolution, calling e.g. CLOCK_MONOTONIC on Linux/BSD -procedure QueryPerformanceCounter(out Value: Int64); - -/// slightly faster than QueryPerformanceCounter() div 1000 - but not for Windows -// - returns microseconds resolution, calling e.g. CLOCK_MONOTONIC on Linux/BSD -procedure QueryPerformanceMicroSeconds(out Value: Int64); inline; - -/// compatibility function, wrapping Win32 API high resolution timer -// - hardcoded to 1e9 for clock_gettime() nanoseconds resolution on Linux/BSD -function QueryPerformanceFrequency(out Value: Int64): boolean; - -/// compatibility function, wrapping Win32 API file position change -function SetFilePointer(hFile: cInt; lDistanceToMove: TOff; - lpDistanceToMoveHigh: Pointer; dwMoveMethod: cint): TOff; inline; - -/// compatibility function, wrapping Win32 API file size retrieval -function GetFileSize(hFile: cInt; lpFileSizeHigh: PDWORD): DWORD; - -/// compatibility function, wrapping Win32 API file truncate at current position -procedure SetEndOfFile(hFile: cInt); inline; - -/// compatibility function, wrapping Win32 API file flush to disk -procedure FlushFileBuffers(hFile: cInt); inline; - -/// compatibility function, wrapping Win32 API last error code -function GetLastError: longint; inline; - -/// compatibility function, wrapping Win32 API last error code -procedure SetLastError(error: longint); inline; - -/// compatibility function, wrapping Win32 API text comparison -// - will use the system ICU library if available, or the widestringmanager -// - seldom called, unless our proprietary WIN32CASE collation is used in SynSQLite3 -function CompareStringW(GetThreadLocale: DWORD; dwCmpFlags: DWORD; lpString1: PWideChar; - cchCount1: integer; lpString2: PWideChar; cchCount2: integer): integer; - -/// compatibility function, wrapping Win32 API text case conversion -function CharUpperBuffW(W: PWideChar; WLen: integer): integer; - -/// compatibility function, wrapping Win32 API text case conversion -function CharLowerBuffW(W: PWideChar; WLen: integer): integer; - -/// compatibility function, wrapping Win32 MultiByteToWideChar API conversion -// - will use the system ICU library for efficient conversion -function AnsiToWideICU(codepage: cardinal; Source: PAnsiChar; Dest: PWideChar; - SourceChars: PtrInt): PtrInt; - -/// compatibility function, wrapping Win32 WideCharToMultiByte API conversion -// - will use the system ICU library for efficient conversion -function WideToAnsiICU(codepage: cardinal; Source: PWideChar; Dest: PAnsiChar; - SourceChars: PtrInt): PtrInt; - -/// returns the current UTC time -// - will convert from clock_gettime(CLOCK_REALTIME_COARSE) if available -function GetNowUTC: TDateTime; - -/// returns the current UTC time, as Unix Epoch seconds -// - will call clock_gettime(CLOCK_REALTIME_COARSE) if available -function GetUnixUTC: Int64; - -/// returns the current UTC time, as Unix Epoch milliseconds -// - will call clock_gettime(CLOCK_REALTIME_COARSE) if available -function GetUnixMSUTC: Int64; - -/// returns the current UTC time as TSystemTime -// - will convert from clock_gettime(CLOCK_REALTIME_COARSE) if available -procedure GetNowUTCSystem(out result: TSystemTime); - -var - /// will contain the current Linux kernel revision, as one 24-bit integer - // - e.g. $030d02 for 3.13.2, or $020620 for 2.6.32 - KernelRevision: cardinal; - -/// calls the pthread_setname_np() function, if available on this system -// - under Linux/FPC, this API truncates the name to 16 chars -procedure SetUnixThreadName(ThreadID: TThreadID; const Name: RawByteString); - -/// calls mprotect() syscall or clib -function SynMProtect(addr:pointer; size:size_t; prot:integer): longint; - -{$ifdef BSD} -function fpsysctlhwint(hwid: cint): Int64; -function fpsysctlhwstr(hwid: cint; var temp: shortstring): pointer; -{$endif BSD} - -{$ifndef DARWIN} // OSX has no clock_gettime() API - -{$ifdef BSD} -const // see https://github.com/freebsd/freebsd/blob/master/sys/sys/time.h - CLOCK_REALTIME = 0; -{$ifdef OpenBSD} - CLOCK_MONOTONIC = 3; - CLOCK_REALTIME_COARSE = CLOCK_REALTIME; // no faster alternative - CLOCK_MONOTONIC_COARSE = CLOCK_MONOTONIC; -{$else} - CLOCK_MONOTONIC = 4; - CLOCK_REALTIME_COARSE = 10; // named CLOCK_REALTIME_FAST in FreeBSD 8.1+ - CLOCK_MONOTONIC_COARSE = 12; -{$endif OPENBSD} - -{$else} -const - CLOCK_REALTIME = 0; - CLOCK_MONOTONIC = 1; - CLOCK_REALTIME_COARSE = 5; // see http://lwn.net/Articles/347811 - CLOCK_MONOTONIC_COARSE = 6; -{$endif BSD} - -var - // contains CLOCK_REALTIME_COARSE since kernel 2.6.32 - CLOCK_REALTIME_FAST: integer = CLOCK_REALTIME; - // contains CLOCK_MONOTONIC_COARSE since kernel 2.6.32 - CLOCK_MONOTONIC_FAST: integer = CLOCK_MONOTONIC; - -{$endif DARWIN} -{$endif LINUX} - -/// compatibility function, to be implemented according to the running OS -// - expect more or less the same result as the homonymous Win32 API function -// - will call clock_gettime(CLOCK_MONOTONIC_COARSE) if available -function GetTickCount64: Int64; - -/// compatibility function, to be implemented according to the running OS -// - expect more or less the same result as the homonymous Win32 API function -// - will call clock_gettime(CLOCK_MONOTONIC_COARSE) if available -function GetTickCount: cardinal; - -var - /// could be set to TRUE to force SleepHiRes(0) to call the sched_yield API - // - in practice, it has been reported as buggy under POSIX systems - // - even Linus Torvald himself raged against its usage - see e.g. - // https://www.realworldtech.com/forum/?threadid=189711&curpostid=189752 - // - you may tempt the devil and try it by yourself - SleepHiRes0Yield: boolean = false; - -/// similar to Windows sleep() API call, to be truly cross-platform -// - using millisecond resolution -// - SleepHiRes(0) calls ThreadSwitch on windows, but this POSIX version will -// wait 10 microsecond unless SleepHiRes0Yield is forced to true (bad idea) -// - in respect to RTL's Sleep() function, it will return on ESysEINTR -procedure SleepHiRes(ms: cardinal); - -/// check if any char is pending from StdInputHandle file descriptor -function UnixKeyPending: boolean; - - -{$ifdef LINUX} - -type - /// the libraries supported by TExternalLibrariesAPI - TExternalLibrary = ( - elPThread, elICU {$ifdef LINUXNOTBSD} , elSystemD {$endif}); - /// set of libraries supported by TExternalLibrariesAPI - TExternalLibraries = set of TExternalLibrary; - - /// implements late-binding of system libraries - // - about systemd: see https://www.freedesktop.org/wiki/Software/systemd - // and http://0pointer.de/blog/projects/socket-activation.html - to get headers - // on debian: `sudo apt install libsystemd-dev && cd /usr/include/systemd` - TExternalLibrariesAPI = object - private - Lock: TRTLCriticalSection; - Loaded: TExternalLibraries; - {$ifdef LINUX} - pthread: pointer; - {$ifdef LINUXNOTBSD} - systemd: pointer; - {$endif LINUXNOTBSD} - {$endif LINUX} - icu, icudata, icui18n: pointer; - procedure LoadIcuWithVersion; - procedure Done; - public - {$ifdef LINUXNOTBSD} - /// customize the name of a thread (truncated to 16 bytes) - // - see https://stackoverflow.com/a/7989973 - pthread_setname_np: function(thread: pointer; name: PAnsiChar): longint; cdecl; - /// systemd: returns how many file descriptors have been passed to process - // - if result=1 then socket for accepting connection is SD_LISTEN_FDS_START - sd_listen_fds: function(unset_environment: integer): integer; cdecl; - /// systemd: returns 1 if the file descriptor is an AF_UNIX socket of the specified type and path - sd_is_socket_unix: function(fd, typr, listening: integer; - var path: TFileName; pathLength: PtrUInt): integer; cdecl; - /// systemd: submit simple, plain text log entries to the system journal - // - priority value can be obtained using longint(LOG_TO_SYSLOG[logLevel]) - // - WARNING: args strings processed using C printf semantic, so % is a printf - // placeholder and should be either escaped using %% or all formatting args must be passed - sd_journal_print: function(priority: longint; args: array of const): longint; cdecl; - /// systemd: submit array of iov structures instead of the format string to the system journal. - // - each structure should reference one field of the entry to submit. - // - the second argument specifies the number of structures in the array. - sd_journal_sendv: function(const iov: Piovec; n: longint): longint; cdecl; - /// systemd: sends notification to systemd - // - see https://www.freedesktop.org/software/systemd/man/sd_notify.html - // status notification sample: sd.notify(0, 'READY=1'); - // watchdog notification: sd.notify(0, 'WATCHDOG=1'); - sd_notify: function(unset_environment: longint; state: PAnsiChar): longint; cdecl; - /// systemd: check whether the service manager expects watchdog keep-alive - // notifications from a service - // - if result > 0 then usec contains the notification interval (app should - // notify every usec/2) - sd_watchdog_enabled: function(unset_environment: longint; usec: Puint64): longint; cdecl; - {$endif LINUXNOTBSD} - /// Initialize an ICU text converter for a given encoding - ucnv_open: function (converterName: PAnsiChar; var err: SizeInt): pointer; cdecl; - /// finalize the ICU text converter for a given encoding - ucnv_close: procedure (converter: pointer); cdecl; - /// customize the ICU text converter substitute char - ucnv_setSubstChars: procedure (converter: pointer; - subChars: PAnsiChar; len: byte; var err: SizeInt); cdecl; - /// enable the ICU text converter fallback - ucnv_setFallback: procedure (cnv: pointer; usesFallback: LongBool); cdecl; - /// ICU text conversion from UTF-16 to a given encoding - ucnv_fromUChars: function (cnv: pointer; dest: PAnsiChar; destCapacity: cardinal; - src: PWideChar; srcLength: cardinal; var err: SizeInt): cardinal; cdecl; - /// ICU text conversion from a given encoding to UTF-16 - ucnv_toUChars: function (cnv: pointer; dest: PWideChar; destCapacity: cardinal; - src: PAnsiChar; srcLength: cardinal; var err: SizeInt): cardinal; cdecl; - /// ICU UTF-16 text conversion to uppercase - u_strToUpper: function (dest: PWideChar; destCapacity: cardinal; - src: PWideChar; srcLength: cardinal; locale: PAnsiChar; - var err: SizeInt): cardinal; cdecl; - /// ICU UTF-16 text conversion to lowercase - u_strToLower: function (dest: PWideChar; destCapacity: cardinal; - src: PWideChar; srcLength: cardinal; locale: PAnsiChar; - var err: SizeInt): cardinal; cdecl; - /// ICU UTF-16 text comparison - u_strCompare: function (s1: PWideChar; length1: cardinal; - s2: PWideChar; length2: cardinal; codePointOrder: LongBool): cardinal; cdecl; - /// ICU UTF-16 text comparison with options, e.g. for case-insensitive - u_strCaseCompare: function (s1: PWideChar; length1: cardinal; - s2: PWideChar; length2: cardinal; options: cardinal; - var err: SizeInt): cardinal; cdecl; - /// get the ICU data folder - u_getDataDirectory: function: PAnsiChar; cdecl; - /// set the ICU data folder - u_setDataDirectory: procedure(directory: PAnsiChar); cdecl; - /// initialize the ICU library - u_init: procedure(var status: SizeInt); cdecl; - /// Initialize an ICU text converter for a given codepage - // - returns nil if ICU is not available on this system - function ucnv(codepage: cardinal): pointer; - /// thread-safe loading of a system library - // - caller should then check the API function to be not nil - procedure EnsureLoaded(lib: TExternalLibrary); - end; - -var - /// late-binding of system libraries - ExternalLibraries: TExternalLibrariesAPI; - -{$ifdef LINUXNOTBSD} { the systemd API is Linux-specific } - -const - /// The first passed file descriptor is fd 3 - SD_LISTEN_FDS_START = 3; - - /// low-level libcurl library file name, depending on the running OS - LIBSYSTEMD_PATH = 'libsystemd.so.0'; - - ENV_INVOCATION_ID: PAnsiChar = 'INVOCATION_ID'; - -type - /// low-level exception raised during systemd library access - ESystemd = class(Exception); - -/// returns true in case process is started by systemd -// - For systemd v232+ -function ProcessIsStartedBySystemd: boolean; - -/// initialize the libsystemd API -// - do nothing if the library has already been loaded -// - will raise ESsytemd exception on any loading issue -procedure LibSystemdInitialize; - -/// returns TRUE if a systemd library is available -// - will load and initialize it, calling LibSystemdInitialize if necessary, -// catching any exception during the process -function SystemdIsAvailable: boolean; inline; - -{$endif LINUXNOTBSD} - -{$endif LINUX} - - -implementation - -{$ifdef LINUX} -uses - Classes, - Unix, - {$ifdef BSD} - sysctl, - {$else} - Linux, - SysCall, - {$endif BSD} - dl; -{$endif LINUX} - -procedure InitializeCriticalSection(var cs : TRTLCriticalSection); -begin - InitCriticalSection(cs); -end; - -procedure DeleteCriticalSection(var cs : TRTLCriticalSection); -begin - {$ifdef LINUXNOTBSD} - if cs.__m_kind<>0 then - {$else} - {$ifdef BSD} - {$ifdef Darwin} - if cs.sig<>0 then - {$else} - if Assigned(cs) then - {$endif Darwin} - {$endif BSD} - {$endif LINUXNOTBSD} - DoneCriticalSection(cs); -end; - -function UnixKeyPending: boolean; -var - fdsin: tfdSet; -begin - fpFD_ZERO(fdsin); - fpFD_SET(StdInputHandle,fdsin); - result := fpSelect(StdInputHandle+1,@fdsin,nil,nil,0)>0; -end; - -{$ifdef LINUX} - -const // Date Translation - see http://en.wikipedia.org/wiki/Julian_day - HoursPerDay = 24; - MinsPerHour = 60; - SecsPerMin = 60; - MinsPerDay = HoursPerDay*MinsPerHour; - SecsPerDay = MinsPerDay*SecsPerMin; - SecsPerHour = MinsPerHour*SecsPerMin; - C1970 = 2440588; - D0 = 1461; - D1 = 146097; - D2 = 1721119; - UnixDelta = 25569; - - C_THOUSAND = Int64(1000); - C_MILLION = Int64(C_THOUSAND * C_THOUSAND); - C_BILLION = Int64(C_THOUSAND * C_THOUSAND * C_THOUSAND); - -procedure JulianToGregorian(JulianDN: PtrUInt; out result: TSystemTime); - {$ifdef HASINLINE}inline;{$endif} -var YYear,XYear,Temp,TempMonth: PtrUInt; -begin - Temp := ((JulianDN-D2)*4)-1; - JulianDN := Temp div D1; - XYear := (Temp-(JulianDN*D1)) or 3; - YYear := XYear div D0; - Temp := (((XYear-(YYear*D0)+4) shr 2)*5)-3; - TempMonth := Temp div 153; - result.Day := ((Temp-(TempMonth*153))+5) div 5; - if TempMonth>=10 then begin - inc(YYear); - dec(TempMonth,12-3); - end else - inc(TempMonth,3); - result.Month := TempMonth; - result.Year := YYear+(JulianDN*100); - // initialize fake dayOfWeek - as used by SynCommons.FromGlobalTime RCU128 - result.DayOfWeek := 0; -end; - -procedure EpochToSystemTime(epoch: PtrUInt; out result: TSystemTime); -var t: PtrUInt; -begin - t := epoch div SecsPerDay; - JulianToGregorian(t+C1970,result); - dec(epoch,t*SecsPerDay); - t := epoch div SecsPerHour; - result.Hour := t; - dec(epoch,t*SecsPerHour); - t := epoch div SecsPerMin; - result.Minute := t; - result.Second := epoch-t*SecsPerMin; -end; - -function GetTickCount: cardinal; -begin - result := cardinal(GetTickCount64); -end; - -{$ifdef DARWIN} -// clock_gettime() is not implemented: http://stackoverflow.com/a/5167506 - -type - TTimebaseInfoData = record - Numer: cardinal; - Denom: cardinal; - end; - -function mach_absolute_time: UInt64; - cdecl external 'libc.dylib' name 'mach_absolute_time'; -function mach_timebase_info(var TimebaseInfoData: TTimebaseInfoData): Integer; - cdecl external 'libc.dylib' name 'mach_timebase_info'; - -var - mach_timeinfo: TTimebaseInfoData; - mach_timecoeff: double; - mach_timenanosecond: boolean; // very likely to be TRUE on Intel CPUs - -procedure QueryPerformanceCounter(out Value: Int64); -begin // returns time in nano second resolution - Value := mach_absolute_time; - if mach_timeinfo.Denom=1 then - if mach_timeinfo.Numer=1 then - // seems to be the case on Intel CPUs - exit else - Value := Value*mach_timeinfo.Numer else - // use floating point to avoid potential overflow - Value := round(Value*mach_timecoeff); -end; - -procedure QueryPerformanceMicroSeconds(out Value: Int64); -begin - if mach_timenanosecond then - Value := mach_absolute_time div C_THOUSAND else begin - QueryPerformanceCounter(Value); - Value := Value div C_THOUSAND; // ns to us - end; -end; - -function GetTickCount64: Int64; -begin - if mach_timenanosecond then - result := mach_absolute_time else - QueryPerformanceCounter(result); - result := result div C_MILLION; // ns to ms -end; - -function GetUnixUTC: Int64; -var tz: timeval; -begin - fpgettimeofday(@tz,nil); - result := tz.tv_sec; -end; - -function GetUnixMSUTC: Int64; -var tz: timeval; -begin - fpgettimeofday(@tz,nil); - result := (tz.tv_sec*C_THOUSAND)+tz.tv_usec div C_THOUSAND; // in milliseconds -end; - -procedure GetNowUTCSystem(out result: TSystemTime); -var tz: timeval; -begin - fpgettimeofday(@tz,nil); - EpochToSystemTime(tz.tv_sec,result); - result.MilliSecond := tz.tv_usec div C_THOUSAND; -end; - -{$else} - -{$ifdef BSD} - -function clock_gettime(ID: cardinal; r: ptimespec): Integer; - cdecl external 'libc.so' name 'clock_gettime'; -function clock_getres(ID: cardinal; r: ptimespec): Integer; - cdecl external 'libc.so' name 'clock_getres'; - -{$else} - -// libc's clock_gettime function uses vDSO (avoid syscall) while FPC by default -// is compiled without FPC_USE_LIBC defined and do a syscall each time -// GetTickCount64 fpc 2 494 563 op/sec -// GetTickCount64 libc 119 919 893 op/sec -// note: for high-resolution QueryPerformanceMicroSeconds, calling the kernel -// is also slower -function clock_gettime(clk_id : clockid_t; tp: ptimespec) : cint; - cdecl; external 'c' name 'clock_gettime'; - -{$endif BSD} - -function GetTickCount64: Int64; -var tp: timespec; -begin - clock_gettime(CLOCK_MONOTONIC_FAST,@tp); // likely = CLOCK_MONOTONIC_COARSE - Result := (Int64(tp.tv_sec) * C_THOUSAND) + (tp.tv_nsec div C_MILLION); // in ms -end; - -function GetUnixMSUTC: Int64; -var r: timespec; -begin - clock_gettime(CLOCK_REALTIME_FAST,@r); // likely = CLOCK_REALTIME_COARSE - result := (Int64(r.tv_sec) * C_THOUSAND) + (r.tv_nsec div C_MILLION); // in ms -end; - -function GetUnixUTC: Int64; -var r: timespec; -begin - clock_gettime(CLOCK_REALTIME_FAST,@r); - result := r.tv_sec; -end; - -procedure QueryPerformanceCounter(out Value: Int64); -var r : TTimeSpec; -begin - clock_gettime(CLOCK_MONOTONIC, @r); - value := r.tv_nsec+r.tv_sec*C_BILLION; // returns nanoseconds resolution -end; - -procedure QueryPerformanceMicroSeconds(out Value: Int64); -var r : TTimeSpec; -begin - clock_gettime(CLOCK_MONOTONIC, @r); - value := PtrUInt(r.tv_nsec) div C_THOUSAND+r.tv_sec*C_MILLION; // as microseconds -end; - -procedure GetNowUTCSystem(out result: TSystemTime); -var r: timespec; -begin - clock_gettime(CLOCK_REALTIME_FAST,@r); // faster than fpgettimeofday() - EpochToSystemTime(r.tv_sec,result); - result.MilliSecond := r.tv_nsec div C_MILLION; -end; - -{$endif DARWIN} - -{$ifdef BSD} -function fpsysctlhwint(hwid: cint): Int64; -var mib: array[0..1] of cint; - len: cint; -begin - result := 0; - mib[0] := CTL_HW; - mib[1] := hwid; - len := SizeOf(result); - fpsysctl(pointer(@mib),2,@result,@len,nil,0); -end; - -function fpsysctlhwstr(hwid: cint; var temp: shortstring): pointer; -var mib: array[0..1] of cint; - len: cint; -begin - mib[0] := CTL_HW; - mib[1] := hwid; - FillChar(temp,SizeOf(temp),0); // use shortstring as temp 0-terminated buffer - len := SizeOf(temp); - fpsysctl(pointer(@mib),2,@temp,@len,nil,0); - if temp[0]<>#0 then - result := @temp else - result := nil; -end; -{$endif BSD} - -function GetNowUTC: TDateTime; -begin - result := GetUnixMSUTC / MSecsPerDay + UnixDelta; -end; - -function QueryPerformanceFrequency(out Value: Int64): boolean; -begin - Value := C_BILLION; // 1 second = 1e9 nanoseconds - result := true; -end; - -function SetFilePointer(hFile: cInt; lDistanceToMove: TOff; - lpDistanceToMoveHigh: Pointer; dwMoveMethod: cint): TOff; -var offs: Int64; -begin - Int64Rec(offs).Lo := lDistanceToMove; - if lpDistanceToMoveHigh=nil then - Int64Rec(offs).Hi := 0 else - Int64Rec(offs).Hi := PDWord(lpDistanceToMoveHigh)^; - offs := FpLseek(hFile,offs,dwMoveMethod); - result := Int64Rec(offs).Lo; - if lpDistanceToMoveHigh<>nil then - PDWord(lpDistanceToMoveHigh)^ := Int64Rec(offs).Hi; -end; - -procedure SetEndOfFile(hFile: cInt); -begin - FpFtruncate(hFile,FPLseek(hFile,0,SEEK_CUR)); -end; - -procedure FlushFileBuffers(hFile: cInt); -begin - FpFsync(hFile); -end; - -function GetLastError: longint; -begin - result := fpgeterrno; -end; - -procedure SetLastError(error: longint); -begin - fpseterrno(error); -end; - -function CompareStringRTL(a, b: PWideChar; al, bl, flags: integer): integer; -var - U1, U2: UnicodeString; -begin - SetString(U1,a,al); - SetString(U2,b,bl); - result := widestringmanager.CompareUnicodeStringProc(U1,U2,TCompareOptions(flags)); -end; - -function CompareStringW(GetThreadLocale: DWORD; dwCmpFlags: DWORD; lpString1: PWideChar; - cchCount1: integer; lpString2: PWideChar; cchCount2: integer): integer; -const - U_COMPARE_CODE_POINT_ORDER = $8000; -var - err: SizeInt; -begin - if cchCount1 < 0 then - cchCount1 := StrLen(lpString1); - if cchCount2 < 0 then - cchCount2 := StrLen(lpString2); - with ExternalLibraries do - begin - if not (elICU in Loaded) then - EnsureLoaded(elICU); - if Assigned(ucnv_open) then - begin - err := 0; - if dwCmpFlags and NORM_IGNORECASE <> 0 then - result := u_strCaseCompare(lpString1, cchCount1, lpString2, cchCount2, - U_COMPARE_CODE_POINT_ORDER, err) - else - result := u_strCompare(lpString1, cchCount1, lpString2, cchCount2, true); - end - else - result := CompareStringRTL(lpString1, lpString2, cchCount1, cchCount2, dwCmpFlags); - end; - inc(result, 2); // caller would make -2 to get regular -1/0/1 comparison values -end; - -function CharUpperBuffW(W: PWideChar; WLen: integer): integer; -var - err: SizeInt; -begin - with ExternalLibraries do - begin - if not (elICU in Loaded) then - EnsureLoaded(elICU); - if Assigned(ucnv_open) then - begin - err := 0; - result := u_strToUpper(W, WLen, W, WLen, nil, err); - end - else - result := WLen; - end; -end; - -function CharLowerBuffW(W: PWideChar; WLen: integer): integer; -var - err: SizeInt; -begin - with ExternalLibraries do - begin - if not (elICU in Loaded) then - EnsureLoaded(elICU); - if Assigned(ucnv_open) then - begin - err := 0; - result := u_strToLower(W, WLen, W, WLen, nil, err); - end - else - result := WLen; - end; -end; - -function AnsiToWideRTL(codepage: cardinal; Source: PAnsiChar; Dest: PWideChar; - SourceChars: PtrInt): PtrInt; -var - tmp: UnicodeString; -begin - widestringmanager.Ansi2UnicodeMoveProc(Source, codepage, tmp, SourceChars); - result := length(tmp); - Move(pointer(tmp)^, Dest^, result * 2); -end; - -function AnsiToWideICU(codepage: cardinal; Source: PAnsiChar; Dest: PWideChar; - SourceChars: PtrInt): PtrInt; -var - cnv: pointer; - err: SizeInt; -begin - if codepage = CP_UTF8 then - exit(Utf8ToUnicode(Dest, Source, SourceChars)); - cnv := ExternalLibraries.ucnv(codepage); - if cnv = nil then - exit(AnsiToWideRTL(codepage, Source, Dest, SourceChars)); - err := 0; - result := ExternalLibraries.ucnv_toUChars( - cnv, Dest, SourceChars, Source, SourceChars, err); - if result < 0 then - result := 0; - ExternalLibraries.ucnv_close(cnv); -end; - -function WideToAnsiRTL(codepage: cardinal; Source: PWideChar; Dest: PAnsiChar; - SourceChars: PtrInt): PtrInt; -var - tmp: RawByteString; -begin - widestringmanager.Unicode2AnsiMoveProc(Source, tmp, codepage, SourceChars); - result := length(tmp); - Move(pointer(tmp)^, Dest^, result); -end; - -function WideToAnsiICU(codepage: cardinal; Source: PWideChar; Dest: PAnsiChar; - SourceChars: PtrInt): PtrInt; -var - cnv: pointer; - err: SizeInt; -begin - if codepage = CP_UTF8 then - // fallback to RTL - exit(UnicodeToUTF8(Dest, Source, SourceChars)); - cnv := ExternalLibraries.ucnv(codepage); - if cnv = nil then - exit(WideToAnsiRTL(codepage, Source, Dest, SourceChars)); - err := 0; - result := ExternalLibraries.ucnv_fromUChars( - cnv, Dest, SourceChars * 3, Source, SourceChars, err); - if result < 0 then - result := 0; - ExternalLibraries.ucnv_close(cnv); -end; - - -function GetFileSize(hFile: cInt; lpFileSizeHigh: PDWORD): DWORD; -var FileInfo: TStat; -begin - if fpFstat(hFile,FileInfo)<>0 then - FileInfo.st_Size := 0; // returns 0 on error - result := Int64Rec(FileInfo.st_Size).Lo; - if lpFileSizeHigh<>nil then - lpFileSizeHigh^ := Int64Rec(FileInfo.st_Size).Hi; -end; - -procedure SleepHiRes(ms: cardinal); -var timeout: TTimespec; -begin - if ms=0 then // handle SleepHiRes(0) special case - if SleepHiRes0Yield then begin // reported as buggy by Alan on POSIX - ThreadSwitch; // call e.g. pthread's sched_yield API - exit; - end else begin - timeout.tv_sec := 0; - timeout.tv_nsec := 10000; // 10us is around timer resolution on modern HW - end else begin - timeout.tv_sec := ms div 1000; - timeout.tv_nsec := 1000000*(ms mod 1000); - end; - fpnanosleep(@timeout,nil) - // no retry loop on ESysEINTR (as with regular RTL's Sleep) -end; - -{$ifdef BSD} -function mprotect(Addr: Pointer; Len: size_t; Prot: Integer): Integer; - {$ifdef Darwin} cdecl external 'libc.dylib' name 'mprotect'; - {$else} cdecl external 'libc.so' name 'mprotect'; {$endif} -{$endif BSD} - -function SynMProtect(addr: pointer; size: size_t; prot: integer): longint; -begin - result := -1; - {$ifdef UNIX} - {$ifdef BSD} - result := mprotect(addr, size, prot); - {$else} - if Do_SysCall(syscall_nr_mprotect, PtrUInt(addr), size, prot) >= 0 then - result := 0; - {$endif BSD} - {$endif UNIX} -end; - -procedure GetKernelRevision; -var uts: UtsName; - P: PAnsiChar; - tp: timespec; - function GetNext: cardinal; - var c: cardinal; - begin - result := 0; - repeat - c := ord(P^)-48; - if c>9 then - break else - result := result*10+c; - inc(P); - until false; - if P^ in ['.','-',' '] then - inc(P); - end; -begin - if fpuname(uts)=0 then begin - P := @uts.release[0]; - KernelRevision := GetNext shl 16+GetNext shl 8+GetNext; - end else - uts.release[0] := #0; - {$ifdef DARWIN} - mach_timebase_info(mach_timeinfo); - mach_timecoeff := mach_timeinfo.Numer/mach_timeinfo.Denom; - mach_timenanosecond := (mach_timeinfo.Numer=1) and (mach_timeinfo.Denom=1); - {$else} - {$ifdef LINUX} - // try Linux kernel 2.6.32+ or FreeBSD 8.1+ fastest clocks - if (CLOCK_REALTIME_COARSE <> CLOCK_REALTIME_FAST) and - (clock_gettime(CLOCK_REALTIME_COARSE, @tp) = 0) then - CLOCK_REALTIME_FAST := CLOCK_REALTIME_COARSE; - if (CLOCK_MONOTONIC_COARSE <> CLOCK_MONOTONIC_FAST) and - (clock_gettime(CLOCK_MONOTONIC_COARSE, @tp) = 0) then - CLOCK_MONOTONIC_FAST := CLOCK_MONOTONIC_COARSE; - if (clock_gettime(CLOCK_REALTIME_FAST,@tp)<>0) or // paranoid check - (clock_gettime(CLOCK_MONOTONIC_FAST,@tp)<>0) then - raise Exception.CreateFmt('clock_gettime() not supported by %s kernel - errno=%d', - [PAnsiChar(@uts.release),GetLastError]); - {$endif LINUX} - {$endif DARWIN} -end; - - -{ TExternalLibrariesAPI } - -procedure TExternalLibrariesAPI.LoadIcuWithVersion; -const - NAMES: array[0..12] of string = ( - 'ucnv_open', 'ucnv_close', 'ucnv_setSubstChars', 'ucnv_setFallback', - 'ucnv_fromUChars', 'ucnv_toUChars', 'u_strToUpper', 'u_strToLower', - 'u_strCompare', 'u_strCaseCompare', 'u_getDataDirectory', - 'u_setDataDirectory', 'u_init'); -{$ifdef ANDROID} -// from https://developer.android.com/guide/topics/resources/internationalization - ICU_VER: array[1..13] of string = ( - '_3_8', '_4_2', '_44', '_46', '_48', '_50', '_51', '_53', '_55', '_56', '_58', '_60', '_63'); - SYSDATA: PAnsiChar = '/system/usr/icu'; -{$else} - SYSDATA: PAnsiChar = ''; -{$endif ANDROID} -var - i, j: integer; - err: SizeInt; - P: PPointer; - v, vers: string; - data: PAnsiChar; -begin - {$ifdef ANDROID} - for i := high(ICU_VER) downto 1 do - begin - if dlsym(icu, pointer(NAMES[0] + ICU_VER[i])) <> nil then - begin - vers := ICU_VER[i]; - break; - end; - end; - if vers <> '' then - {$endif ANDROID} - if dlsym(icu, 'ucnv_open') = nil then - for i := 80 downto 44 do - begin - str(i, v); - if dlsym(icu, pointer('ucnv_open_' + v)) <> nil then - begin - vers := '_' + v; - break; - end; - end; - P := @@ucnv_open; - for i := 0 to high(NAMES) do - begin - P[i] := dlsym(icu, pointer(NAMES[i] + vers)); - if P[i] = nil then - begin - @ucnv_open := nil; - exit; - end; - end; - data := u_getDataDirectory; - if (data = nil) or (data^ = #0) then - if SYSDATA <> '' then - u_setDataDirectory(SYSDATA); - err := 0; - u_init(err); -end; - -function TExternalLibrariesAPI.ucnv(codepage: cardinal): pointer; -var - s: shortstring; - err: SizeInt; - {$ifdef CPUINTEL} - mask: cardinal; - {$endif CPUINTEL} -begin - if not (elICU in Loaded) then - EnsureLoaded(elICU); - if not Assigned(ucnv_open) then - exit(nil); - str(codepage, s); - Move(s[1], s[3], ord(s[0])); - PWord(@s[1])^ := ord('c') + ord('p') shl 8; - inc(s[0], 3); - s[ord(s[0])] := #0; - {$ifdef CPUINTEL} - mask := GetMXCSR; - SetMXCSR(mask or $0080 {MM_MaskInvalidOp} or $1000 {MM_MaskPrecision}); - {$endif CPUINTEL} - err := 0; - result := ucnv_open(@s[1], err); - if result <> nil then - begin - err := 0; - ucnv_setSubstChars(result, '?', 1, err); - ucnv_setFallback(result, true); - end; - {$ifdef CPUINTEL} - SetMXCSR(mask); - {$endif CPUINTEL} -end; - -procedure TExternalLibrariesAPI.EnsureLoaded(lib: TExternalLibrary); -var - p: PPointer; - i, j: integer; -const - NAMES: array[0..5] of PAnsiChar = ( - 'sd_listen_fds', 'sd_is_socket_unix', 'sd_journal_print', 'sd_journal_sendv', - 'sd_notify', 'sd_watchdog_enabled'); -begin - if lib in Loaded then - exit; - EnterCriticalSection(Lock); - if not (lib in Loaded) then - case lib of - elPThread: - begin - {$ifdef LINUX} - pthread := dlopen({$ifdef ANDROID}'libc.so'{$else}'libpthread.so.0'{$endif}, RTLD_LAZY); - if pthread <> nil then - begin - {$ifdef LINUXNOTBSD} - @pthread_setname_np := dlsym(pthread, 'pthread_setname_np'); - {$endif LINUXNOTBSD} - end; - {$endif LINUX} - include(Loaded, elPThread); - end; - elICU: - begin - {$ifdef DARWIN} - icu := dlopen('libicuuc.dylib', RTLD_LAZY); - if icu <> nil then - icui18n := dlopen('libicui18n.dylib', RTLD_LAZY); - {$else} - // libicudata should be loaded first because other two depend on it - icudata := dlopen('libicudata.so', RTLD_LAZY); - if icudata <> nil then - begin - icu := dlopen('libicuuc.so', RTLD_LAZY); - if icu <> nil then - icui18n := dlopen('libicui18n.so', RTLD_LAZY); - end; - {$endif DARWIN} - if icui18n = nil then - begin - if icu <> nil then - dlclose(icu); - if icudata <> nil then - dlclose(icudata); - end - else - // ICU append a version prefix to all its functions e.g. ucnv_open_66 - LoadIcuWithVersion; - include(Loaded, elICU); - end; - {$ifdef LINUXNOTBSD} - elSystemD: - begin - systemd := dlopen(LIBSYSTEMD_PATH, RTLD_LAZY); - if systemd <> nil then - begin - p := @@sd_listen_fds; - for i := 0 to high(NAMES) do - begin - p^ := dlsym(systemd, NAMES[i]); - if p^ = nil then - begin - p := @@sd_listen_fds; - for j := 0 to i do - begin - p^ := nil; - inc(p); - end; - break; - end; - inc(p); - end; - end; - include(Loaded, elSystemD); - end; - {$endif LINUXNOTBSD} - end; - LeaveCriticalSection(Lock); -end; - -procedure TExternalLibrariesAPI.Done; -begin - EnterCriticalSection(Lock); - if elPThread in Loaded then - begin - {$ifdef LINUX} - {$ifdef LINUXNOTBSD} - @pthread_setname_np := nil; - {$endif LINUXNOTBSD} - if pthread <> nil then - dlclose(pthread); - {$endif LINUX} - end; - if elICU in Loaded then - begin - if icui18n <> nil then - dlclose(icui18n); - if icu <> nil then - dlclose(icu); - if icudata <> nil then - dlclose(icudata); - @ucnv_open := nil; - end; - {$ifdef LINUXNOTBSD} - if (elSystemD in Loaded) and (systemd <> nil) then - dlclose(systemd); - {$endif LINUXNOTBSD} - LeaveCriticalSection(Lock); - DeleteCriticalSection(Lock); -end; - -procedure SetUnixThreadName(ThreadID: TThreadID; const Name: RawByteString); -var trunc: array[0..15] of AnsiChar; // truncated to 16 bytes (including #0) - i,L: integer; -begin - {$ifdef LINUXNOTBSD} - if not(elPThread in ExternalLibraries.Loaded) then - ExternalLibraries.EnsureLoaded(elPThread); - if not Assigned(ExternalLibraries.pthread_setname_np) then - exit; - if Name = '' then - exit; - L := 0; // trim unrelevant spaces and prefixes when filling the 16 chars - i := 1; - if Name[1] = 'T' then - if PCardinal(Name)^ = ord('T') + ord('S') shl 8 + ord('Q') shl 16 + ord('L') shl 24 then - i := 5 - else - i := 2; - while i <= length(Name) do begin - if Name[i]>' ' then begin - trunc[L] := Name[i]; - inc(L); - if L = high(trunc) then - break; - end; - inc(i); - end; - if L = 0 then - exit; - trunc[L] := #0; - ExternalLibraries.pthread_setname_np(pointer(ThreadID), @trunc[0]); - {$endif LINUXNOTBSD} -end; - - -{$ifdef LINUXNOTBSD} - -function SystemdIsAvailable: boolean; -begin - if not(elSystemD in ExternalLibraries.Loaded) then - ExternalLibraries.EnsureLoaded(elSystemD); - result := Assigned(ExternalLibraries.sd_listen_fds); -end; - -function ProcessIsStartedBySystemd: boolean; -begin - result := SystemdIsAvailable and - // note: for example on Ubuntu 20.04 INVOCATION_ID is always defined - // from the other side PPID 1 can be set if we run under docker and started - // by init.d so let's verify both - (fpgetppid() = 1) and (fpGetenv(ENV_INVOCATION_ID) <> nil); -end; - -procedure LibSystemdInitialize; -begin - if not SystemdIsAvailable then - raise ESystemd.Create('Impossible to load ' + LIBSYSTEMD_PATH); -end; - -{$endif LINUXNOTBSD} - - -initialization - GetKernelRevision; - InitializeCriticalSection(ExternalLibraries.Lock); - -finalization - ExternalLibraries.Done; -{$endif LINUX} -end. diff --git a/lib/dmustache/SynFPCTypInfo.pas b/lib/dmustache/SynFPCTypInfo.pas deleted file mode 100644 index 42ab29ad..00000000 --- a/lib/dmustache/SynFPCTypInfo.pas +++ /dev/null @@ -1,200 +0,0 @@ -/// wrapper around FPC typinfo.pp unit for SynCommons.pas and mORMot.pas -// - this unit is a part of the freeware Synopse mORMot framework, -// licensed under a MPL/GPL/LGPL tri-license; version 1.18 -unit SynFPCTypInfo; - -{ - This file is part of Synopse mORMot framework. - - Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez - Synopse Informatique - https://synopse.info - - *** BEGIN LICENSE BLOCK ***** - Version: MPL 1.1/GPL 2.0/LGPL 2.1 - - The contents of this file are subject to the Mozilla Public License Version - 1.1 (the "License"); you may not use this file except in compliance with - the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License - for the specific language governing rights and limitations under the License. - - The Original Code is Synopse mORMot framework. - - The Initial Developer of the Original Code is Alfred Glaenzer. - - Portions created by the Initial Developer are Copyright (C) 2022 - the Initial Developer. All Rights Reserved. - - Contributor(s): - - Arnaud Bouchez - - - Alternatively, the contents of this file may be used under the terms of - either the GNU General Public License Version 2 or later (the "GPL"), or - the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), - in which case the provisions of the GPL or the LGPL are applicable instead - of those above. if you wish to allow use of your version of this file only - under the terms of either the GPL or the LGPL, and not to allow others to - use your version of this file under the terms of the MPL, indicate your - decision by deleting the provisions above and replace them with the notice - and other provisions required by the GPL or the LGPL. if you do not delete - the provisions above, a recipient may use your version of this file under - the terms of any one of the MPL, the GPL or the LGPL. - - ***** END LICENSE BLOCK ***** - - Unit created to avoid polluting the SynCommons.pas/mORMot.pas namespace - with overloaded typinfo.pp types. - -} - -interface - -{$ifndef FPC} - 'this unit is for FPC only - do not include it in any Delphi project!' -{$endif FPC} - -{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER - -uses - SysUtils, - TypInfo; - -{$ifdef FPC_PROVIDE_ATTR_TABLE} -type - // if you have a compilation error here, your FPC trunk is too old - // - TTypeData.AttributeTable was introduced in SVN 42356-42411 (2019/07) - // -> undefine FPC_PROVIDE_ATTR_TABLE in Synopse.inc and recompile - PFPCAttributeTable = TypInfo.PAttributeTable; -{$endif FPC_PROVIDE_ATTR_TABLE} - -{$ifdef HASALIGNTYPEDATA} -function AlignTypeData(p: pointer): pointer; inline; -function AlignTypeDataClean(p: pointer): pointer; inline; -{$else} -type - AlignTypeData = pointer; - AlignTypeDataClean = pointer; -{$endif HASALIGNTYPEDATA} - - -{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} -function AlignToPtr(p: pointer): pointer; inline; -function AlignPTypeInfo(p: pointer): pointer; inline; -{$else FPC_REQUIRES_PROPER_ALIGNMENT} -type - AlignToPtr = pointer; - AlignPTypeInfo = pointer; -{$endif FPC_REQUIRES_PROPER_ALIGNMENT} - -type - /// some type definition to avoid inclusion of TypInfo in SynCommons/mORMot.pas - PFPCInterfaceData = TypInfo.PInterfaceData; - PFPCVmtMethodParam = TypInfo.PVmtMethodParam; - PFPCIntfMethodTable = TypInfo.PIntfMethodTable; - PFPCIntfMethodEntry = TypInfo.PIntfMethodEntry; -{$ifdef FPC_NEWRTTI} - PFPCRecInitData = TypInfo.PRecInitData; - -{$endif FPC_NEWRTTI} - -procedure FPCDynArrayClear(var a: Pointer; TypeInfo: Pointer); -procedure FPCFinalizeArray(p: Pointer; TypeInfo: Pointer; elemCount: PtrUInt); -procedure FPCFinalize(Data: Pointer; TypeInfo: Pointer); -procedure FPCRecordCopy(const Source; var Dest; TypeInfo: pointer); -procedure FPCRecordAddRef(var Data; TypeInfo : pointer); - - -implementation - -procedure FPCDynArrayClear(var a: Pointer; TypeInfo: Pointer); - external name 'FPC_DYNARRAY_CLEAR'; -procedure FPCFinalizeArray(p: Pointer; TypeInfo: Pointer; elemCount: PtrUInt); - external name 'FPC_FINALIZE_ARRAY'; -procedure FPCFinalize(Data: Pointer; TypeInfo: Pointer); - external name 'FPC_FINALIZE'; -procedure FPCRecordCopy(const Source; var Dest; TypeInfo: pointer); - external name 'FPC_COPY'; -procedure FPCRecordAddRef(var Data; TypeInfo : pointer); - external name 'FPC_ADDREF'; - -{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} // copied from latest typinfo.pp -function AlignToPtr(p: pointer): pointer; -begin - result := align(p,sizeof(p)); -end; - -function AlignTypeData(p: pointer): pointer; -{$packrecords c} - type - TAlignCheck = record // match RTTI TTypeInfo definition - b : byte; // = TTypeKind - q : qword; // = this is where the PTypeData begins - end; -{$packrecords default} -begin -{$ifdef VER3_0} - result := Pointer(align(p,SizeOf(Pointer))); -{$else VER3_0} - result := Pointer(align(p,PtrInt(@TAlignCheck(nil^).q))); -{$endif VER3_0} - {$ifdef FPC_PROVIDE_ATTR_TABLE} - inc(PByte(result),SizeOf(PFPCAttributeTable)); // ignore attributes table - result := Pointer(align(result,PtrInt(@TAlignCheck(nil^).q))); - {$endif FPC_PROVIDE_ATTR_TABLE} -end; -{$else} -{$ifdef FPC_PROVIDE_ATTR_TABLE} -function AlignTypeData(p: pointer): pointer; -begin - result := p; - inc(PByte(result),SizeOf(PFPCAttributeTable)); // ignore attributes table -end; -{$endif FPC_PROVIDE_ATTR_TABLE} -{$endif FPC_REQUIRES_PROPER_ALIGNMENT} - -{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} // copied from latest typinfo.pp - -function AlignTypeDataClean(p: pointer): pointer; -{$packrecords c} - type - TAlignCheck = record // match RTTI TTypeInfo definition - b : byte; // = TTypeKind - q : qword; // = this is where the PTypeData begins - end; -{$packrecords default} -begin - {$ifdef VER3_0} - result := Pointer(align(p,SizeOf(Pointer))); - {$else VER3_0} - result := Pointer(align(p,PtrInt(@TAlignCheck(nil^).q))); - {$endif VER3_0} -end; - -function AlignPTypeInfo(p: pointer): pointer; inline; -{$packrecords c} - type - TAlignCheck = record - b : byte; - p : pointer; - end; -{$packrecords default} -begin - Result := Pointer(align(p,PtrInt(@TAlignCheck(nil^).p))) - -end; - -{$else} -{$ifdef HASALIGNTYPEDATA} -function AlignTypeDataClean(p: pointer): pointer; -begin - result := p; -end; -{$endif HASALIGNTYPEDATA} - -{$endif FPC_REQUIRES_PROPER_ALIGNMENT} - -end. diff --git a/lib/dmustache/SynLZ.pas b/lib/dmustache/SynLZ.pas deleted file mode 100644 index 1c66a661..00000000 --- a/lib/dmustache/SynLZ.pas +++ /dev/null @@ -1,1474 +0,0 @@ -/// SynLZ Compression routines -// - licensed under a MPL/GPL/LGPL tri-license; version 1.18 -unit SynLZ; - -{ - This file is part of Synopse SynLZ Compression. - - Synopse SynLZ Compression. Copyright (C) 2022 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 SynLZ Compression. - - The Initial Developer of the Original Code is Arnaud Bouchez. - - Portions created by the Initial Developer are Copyright (C) 2022 - the Initial Developer. All Rights Reserved. - - Contributor(s): - - Alternatively, the contents of this file may be used under the terms of - either the GNU General Public License Version 2 or later (the "GPL"), or - the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), - in which case the provisions of the GPL or the LGPL are applicable instead - of those above. If you wish to allow use of your version of this file only - under the terms of either the GPL or the LGPL, and not to allow others to - use your version of this file under the terms of the MPL, indicate your - decision by deleting the provisions above and replace them with the notice - and other provisions required by the GPL or the LGPL. If you do not delete - the provisions above, a recipient may use your version of this file under - the terms of any one of the MPL, the GPL or the LGPL. - - ***** END LICENSE BLOCK ***** - - - SynLZ Compression / Decompression library - ========================================= - - * SynLZ is a very FAST lossless data compression library - written in optimized pascal code for FPC and Delphi 3 and up - with a tuned asm version available - * symetrical compression and decompression speed (which is - very rare above all other compression algorithms in the wild) - * good compression rate (usualy better than LZO) - * fastest averrage compression speed (ideal for xml/text communication, e.g.) - - SynLZ implements a new LZ compression algorithm with the following features: - * hashing+dictionary compression in one pass, with no huffman table - * optimized 32bits control word, embedded in the data stream - * in-memory compression (the dictionary is the input stream itself) - * compression and decompression have the same speed (both use hashing) - * thread safe and lossless algorithm - * supports overlapping compression and in-place decompression - * code size for compression/decompression functions is smaller than LZO's - - Implementation notes: - - this format is NOT stream compatible with any lz* official format - => meant for proprietary server-side content real-time compression - => use it internally in your application, not as exchange format - => consider our SynLizard.pas unit for Lizard (LZ5) compression standard - - very small code size (less than 1KB for both compressor/decompressor) - - the uncompressed data length is stored in the beginning of the stream - and can be retrieved easily for proper out_p memory allocation - - please give correct data to the decompressor (i.e. first CRC in_p data) - => we recommend crc32c() from SynCommons, or a zip-like container - - a 2nd more tuned algorithm is included, but is somewhat slower in practice - => use SynLZ[de]compres1*() functions in your applications - - tested and benchmarked with a lot of data types/sizes - => use the asm code, which is very tuned: SynLZ[de]compress1asm() - - a hashing limitation makes SynLZ sometimes unable to pack continuous - blocks of same byte -> SynLZ is perfect for xml/text (e.g. log files), - but SynZip or SynLizard may be prefered for database files - - if you include it in your application, please give me some credits: - "use SynLZ compression by https://synopse.info" - - use at your own risk! - - Benchmark update - introducing LZ4 at http://code.google.com/p/lz4 - 190 MB file containing pascal sources, on a Core 2 duo PC, using x86 asm: - LZ4 compression = 1.25 sec, comp. size = 71 MB, decompression = 0.44 sec - SynLZ compression = 1.09 sec, comp. size = 63 MB, decompression = 0.51 sec - zip (1) compression = 6.44 sec, comp. size = 52 MB, decompression = 1.49 sec - zip (6) compression = 20.1 sec, comp. size = 42 MB, decompression = 1.35 sec - Note: zip decompression here uses fast asm optimized version of SynZip.pas - Decompression is slower in SynLZ, due to the algorithm used: it does recreate - the hash table even at decompression, while it is not needed by LZ4. - Having the hash table at hand allows more patterns to be available, so - compression ratio is better, at the expand of a slower speed. - - Conclusion: - SynLZ compresses better than LZ4, SynLZ is faster to compress than LZ4, - but slower to decompress than LZ4. So SynLZ is still very competitive for - our Client-Server mORMot purpose, since it is a simple pascal unit with - no external .obj/.o/.dll dependency. ;) - - Updated benchmarks on a Core i7, with the 2017/08 x86 and x64 optimized asm: - Win32 Processing devpcm.log = 98.7 MB - Snappy compress in 125.07ms, ratio=84%, 789.3 MB/s - Snappy uncompress in 70.35ms, 1.3 GB/s - SynLZ compress in 103.61ms, ratio=93%, 952.8 MB/s - SynLZ uncompress in 68.71ms, 1.4 GB/s - Win64 Processing devpcm.log = 98.7 MB - Snappy compress in 107.13ms, ratio=84%, 921.5 MB/s - Snappy uncompress in 61.06ms, 1.5 GB/s - SynLZ compress in 97.25ms, ratio=93%, 1015.1 MB/s - SynLZ uncompress in 61.27ms, 1.5 GB/s - -} - -interface - -{$I Synopse.inc} - -/// get maximum possible (worse) compressed size for out_p -function SynLZcompressdestlen(in_len: integer): integer; - -/// get uncompressed size from lz-compressed buffer (to reserve memory, e.g.) -function SynLZdecompressdestlen(in_p: PAnsiChar): integer; - -/// 1st compression algorithm uses hashing with a 32bits control word -function SynLZcompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; - -/// 1st compression algorithm uses hashing with a 32bits control word -// - this is the fastest pure pascal implementation -function SynLZdecompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; - -/// 1st compression algorithm uses hashing with a 32bits control word -// - this overload function is slower, but will allow to uncompress only the start -// of the content (e.g. to read some metadata header) -// - it will also check for dst buffer overflow, so will be more secure than -// other functions, which expect the content to be verified (e.g. via CRC) -function SynLZdecompress1partial(src: PAnsiChar; size: integer; dst: PAnsiChar; - maxDst: integer): integer; - -{$ifdef CPUINTEL} -/// optimized x86/x64 asm version of the 1st compression algorithm -function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -/// optimized x86/x64 asm version of the 1st compression algorithm -function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -{$else} -var - /// fast redirection to pure pascal SynLZ compression (using 1st algorithm) - SynLZCompress1: function( - src: PAnsiChar; size: integer; dst: PAnsiChar): integer = SynLZcompress1pas; - - /// fast redirection to pure pascal SynLZ decompression (using 1st algorithm) - SynLZDecompress1: function( - src: PAnsiChar; size: integer; dst: PAnsiChar): integer = SynLZDecompress1pas; -{$endif CPUINTEL} - -/// 2nd compression algorithm optimizing pattern copy -// - this algorithm is a bit smaller, but slower, so the 1st method is preferred -function SynLZcompress2(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -/// 2nd compression algorithm optimizing pattern copy -// - this algorithm is a bit smaller, but slower, so the 1st method is preferred -function SynLZdecompress2(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; - - -implementation - -function SynLZcompressdestlen(in_len: integer): integer; -begin // get maximum possible (worse) compressed size for out_p - result := in_len+in_len shr 3+16; -end; - -type // some cross-platform and cross-compiler definitions - {$ifndef FPC} - PtrInt = {$ifdef CPU64}NativeInt{$else}integer{$endif}; - PtrUInt = {$ifdef CPU64}NativeUInt{$else}cardinal{$endif}; - {$endif} - {$ifdef DELPHI5OROLDER} // Delphi 5 doesn't have those base types defined :( - PByte = ^Byte; - PWord = ^Word; - PInteger = ^integer; - PCardinal = ^Cardinal; - IntegerArray = array[0..$effffff] of integer; - PIntegerArray = ^IntegerArray; - {$endif} - TOffsets = array[0..4095] of PAnsiChar; // 16KB/32KB hashing code - -function SynLZdecompressdestlen(in_p: PAnsiChar): integer; -begin // get uncompressed size from lz-compressed buffer (to reserve memory, e.g.) - result := PWord(in_p)^; - if result and $8000<>0 then - result := (result and $7fff) or (integer(PWord(in_p+2)^) shl 15); -end; - -{$ifdef CPUINTEL} -// using direct x86 jmp also circumvents Internal Error C11715 for Delphi 5 -{$ifdef CPUX86} -function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; - {$ifdef FPC} nostackframe; assembler; {$endif} -asm - push ebp - push ebx - push esi - push edi - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -32 - mov esi, eax // esi=src - mov edi, ecx // edi=dst - mov [esp+08H], ecx - mov eax, edx - cmp eax, 32768 - jl @@0889 - or ax, 8000H - mov [edi], eax - mov eax, edx - shr eax, 15 - mov [edi+2], eax - add edi, 4 - jmp @@0891 -@@0890: mov eax, 2 - jmp @@0904 -@@0889: mov [edi], eax - test eax, eax - jz @@0890 - add edi, 2 -@@0891: lea eax, [edx+esi] - mov [esp+18H], edi - mov [esp+0CH], eax - sub eax, 11 - mov [esp+4], eax - lea ebx, [esp+24H] - xor eax, eax - mov ecx, 1024 -@@089I: mov [ebx], eax // faster than FillChar / stosb - mov [ebx+4], eax - mov [ebx+8], eax - mov [ebx+12], eax - add ebx, 16 - dec ecx - jnz @@089I - mov [edi], eax - add edi, 4 - mov ebx, 1 // ebx=1 shl CWbit - // main loop: - cmp esi, [esp+4] - ja @@0900 -@@0892: mov edx, [esi] - mov eax, edx - shr edx, 12 - xor edx, eax - and edx, 0FFFH - mov ebp, [esp+edx*4+24H] - mov ecx, [esp+edx*4+4024H] - mov [esp+edx*4+24H], esi - xor ecx, eax - test ecx, 0FFFFFFH - mov [esp+edx*4+4024H], eax - jnz @@0897 - mov eax, esi - or ebp, ebp - jz @@0897 - sub eax, ebp - mov ecx, [esp+18H] - cmp eax, 2 - jle @@0897 - lea esi, [esi+2] - or dword ptr[ecx], ebx - mov ecx, [esp+0CH] - add ebp, 2 - mov eax, 1 - sub ecx, esi - dec ecx - mov [esp], ecx - cmp ecx, 271 - jl @@0894 - mov dword ptr [esp], 271 - jmp @@0894 -@@0893: inc eax -@@0894: mov ecx, [ebp+eax] - cmp cl, [esi+eax] - jnz @@0895 - cmp eax, [esp] - jge @@0895 - inc eax - cmp ch, [esi+eax] - jnz @@0895 - shr ecx, 16 - cmp eax, [esp] - jge @@0895 - inc eax - cmp cl, [esi+eax] - jnz @@0895 - cmp eax, [esp] - jge @@0895 - inc eax - cmp ch, [esi+eax] - jnz @@0895 - cmp eax, [esp] - jl @@0893 -@@0895: add esi, eax - shl edx, 4 - cmp eax, 15 - jg @@0896 - or eax, edx - mov word ptr [edi], ax - add edi, 2 - jmp @@0898 -@@0896: sub eax, 16 - mov [edi], dx - mov [edi+2H], al - add edi, 3 - jmp @@0898 -@@0897: mov al, [esi] // movsb is actually slower! - mov [edi], al - inc esi - inc edi -@@0898: add ebx, ebx - jz @@0899 - cmp esi, [esp+4] - jbe @@0892 - jmp @@0900 -@@0899: mov [esp+18H], edi - mov [edi], ebx - inc ebx - add edi, 4 - cmp esi, [esp+4] - jbe @@0892 -@@0900: cmp esi, [esp+0CH] - jnc @@0903 -@@0901: mov al, [esi] - mov [edi], al - inc esi - inc edi - add ebx, ebx - jz @@0902 - cmp esi, [esp+0CH] - jc @@0901 - jmp @@0903 -@@0902: mov [edi], ebx - inc ebx - add edi, 4 - cmp esi, [esp+0CH] - jc @@0901 -@@0903: mov eax, edi - sub eax, [esp+08H] -@@0904: add esp, 32804 - pop edi - pop esi - pop ebx - pop ebp -{$else CPUX86} -function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -var off: TOffsets; - cache: array[0..4095] of cardinal; // uses 32KB+16KB=48KB on stack -asm // rcx=src, edx=size, r8=dest - {$ifdef win64} // additional registers to preserve - push rdi - push rsi - {$else} // Linux 64-bit ABI - mov r8, rdx - mov rdx, rsi - mov rcx, rdi - {$endif win64} - push rbx - push r12 - push r13 - push r14 - push r15 - mov r15, r8 // r8=dest r15=dst_beg - mov rbx, rcx // rbx=src - cmp edx, 32768 - jc @03 - mov eax, edx - and eax, 7FFFH - or eax, 8000H - mov word ptr [r8], ax - mov eax, edx - shr eax, 15 - mov word ptr [r8+2H], ax - add r8, 4 - jmp @05 -@03: mov word ptr [r8], dx - test edx, edx - jnz @04 - mov r15d, 2 - jmp @19 - nop -@04: add r8, 2 -@05: lea r9, [rdx+rbx] // r9=src_end - lea r10, [r9-0BH] // r10=src_endmatch - mov ecx, 1 // ecx=CWBits - mov r11, r8 // r11=CWpoint - mov dword ptr [r8], 0 - add r8, 4 - pxor xmm0, xmm0 - mov eax, 32768-64 -@06: movaps dqword ptr [off+rax-48], xmm0 // stack is aligned to 16 bytes - movaps dqword ptr [off+rax-32], xmm0 - movaps dqword ptr [off+rax-16], xmm0 - movaps dqword ptr [off+rax], xmm0 - sub eax, 64 - jae @06 - cmp rbx, r10 - ja @15 -@07: mov edx, dword ptr [rbx] - mov rax, rdx - mov r12, rdx - shr rax, 12 - xor rax, rdx - and rax, 0FFFH // rax=h - mov r14, qword ptr [off+rax*8] // r14=o - mov edx, dword ptr [cache+rax*4] - mov qword ptr [off+rax*8], rbx - mov dword ptr [cache+rax*4], r12d - xor rdx, r12 - test r14, r14 - lea rdi, [r9-1] - je @12 - and rdx, 0FFFFFFH - jne @12 - mov rdx, rbx - sub rdx, r14 - cmp rdx, 2 - jbe @12 - or dword ptr[r11], ecx - add rbx, 2 - add r14, 2 - mov esi, 1 - sub rdi, rbx - cmp rdi, 271 - jc @09 - mov edi, 271 - jmp @09 -@08: inc rsi -@09: mov edx, dword ptr [r14+rsi] - cmp dl, byte ptr [rbx+rsi] - jnz @10 - cmp rsi, rdi - jge @10 - inc rsi - cmp dh, byte ptr [rbx+rsi] - jnz @10 - shr edx, 16 - cmp rsi, rdi - jge @10 - inc rsi - cmp dl, byte ptr [rbx+rsi] - jnz @10 - cmp rsi, rdi - jge @10 - inc rsi - cmp dh, byte ptr [rbx+rsi] - jnz @10 - cmp rsi, rdi - jc @08 -@10: add rbx, rsi - shl rax, 4 - cmp rsi, 15 - ja @11 - or rax, rsi - mov word ptr [r8], ax - add r8, 2 - jmp @13 -@11: sub rsi, 16 - mov word ptr [r8], ax - mov byte ptr [r8+2H], sil - add r8, 3 - jmp @13 -@12: mov al, byte ptr [rbx] - mov byte ptr [r8], al - add rbx, 1 - add r8, 1 -@13: add ecx, ecx - jnz @14 - mov r11, r8 - mov [r8], ecx - add r8, 4 - add ecx, 1 -@14: cmp rbx, r10 - jbe @07 -@15: cmp rbx, r9 - jnc @18 -@16: mov al, byte ptr [rbx] - mov byte ptr [r8], al - add rbx, 1 - add r8, 1 - add ecx, ecx - jnz @17 - mov [r8], ecx - add r8, 4 - add ecx, 1 -@17: cmp rbx, r9 - jc @16 -@18: sub r8, r15 - mov r15, r8 -@19: mov rax, r15 - pop r15 - pop r14 - pop r13 - pop r12 - pop rbx - {$ifdef win64} // additional registers to preserve - pop rsi - pop rdi - {$endif win64} -{$endif CPUX86} -end; -{$endif CPUINTEL} - -function SynLZcompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -var dst_beg, // initial dst value - src_end, // real last byte available in src - src_endmatch, // last byte to try for hashing - o: PAnsiChar; - CWbit: byte; - CWpoint: PCardinal; - v, h, cached, t, tmax: PtrUInt; - offset: TOffsets; - cache: array[0..4095] of cardinal; // 16KB+16KB=32KB on stack (48KB under Win64) -begin - dst_beg := dst; - // 1. store in_len - if size>=$8000 then begin // size in 32KB..2GB -> stored as integer - PWord(dst)^ := $8000 or (size and $7fff); - PWord(dst+2)^ := size shr 15; - inc(dst,4); - end else begin - PWord(dst)^ := size ; // size<32768 -> stored as word - if size=0 then begin - result := 2; - exit; - end; - inc(dst,2); - end; - // 2. compress - src_end := src+size; - src_endmatch := src_end-(6+5); - CWbit := 0; - CWpoint := pointer(dst); - PCardinal(dst)^ := 0; - inc(dst,sizeof(CWpoint^)); - fillchar(offset,sizeof(offset),0); // fast 16KB reset to 0 - // 1. main loop to search using hash[] - if src<=src_endmatch then - repeat - v := PCardinal(src)^; - h := ((v shr 12) xor v) and 4095; - o := offset[h]; - offset[h] := src; - cached := v xor cache[h]; // o=nil if cache[h] is uninitialized - cache[h] := v; - if (cached and $00ffffff=0) and (o<>nil) and (src-o>2) then begin - CWpoint^ := CWpoint^ or (cardinal(1) shl CWbit); - inc(src,2); - inc(o,2); - t := 1; - tmax := src_end-src-1; - if tmax>=(255+16) then - tmax := (255+16); - while (o[t]=src[t]) and (t0 - if t<=15 then begin // mark 2 to 17 bytes -> size=1..15 - PWord(dst)^ := integer(t or h); - inc(dst,2); - end else begin // mark 18 to (255+16) bytes -> size=0, next byte=t - dec(t,16); - PWord(dst)^ := h; // size=0 - dst[2] := ansichar(t); - inc(dst,3); - end; - end else begin - dst^ := src^; - inc(src); - inc(dst); - end; - if CWbit<31 then begin - inc(CWbit); - if src<=src_endmatch then continue else break; - end else begin - CWpoint := pointer(dst); - PCardinal(dst)^ := 0; - inc(dst,sizeof(CWpoint^)); - CWbit := 0; - if src<=src_endmatch then continue else break; - end; - until false; - // 2. store remaining bytes - if src0 then begin - result := (result and $7fff) or (integer(PWord(src)^) shl 15); - inc(src,2); - end; - // 2. decompress - last_hashed := dst-1; - CWbit := 32; -nextCW: - CW := PCardinal(src)^; - inc(src,4); - CWbit := CWbit-32; - if src=src_end then break; - while last_hashed=src_end then break; - if last_hashed=dst; - inc(dst,t); - if src>=src_end then break; - last_hashed := dst-1; - inc(CWbit); - CW := CW shr 1; - if CWbit<32 then - continue else - goto nextCW; - end; - until false; -// assert(result=dst-dst_beg); -end; - -{$ifdef CPUINTEL} -{$ifdef CPUX86} -// using direct x86 jmp also circumvents Internal Error C11715 for Delphi 5 -function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; - {$ifdef FPC} nostackframe; assembler; {$endif} -asm - push ebp - push ebx - push esi - push edi - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -4092 - push eax - add esp, -24 - mov esi, ecx - mov ebx, eax - add edx, eax - mov [esp+8H], esi - mov [esp+10H], edx - movzx eax, word ptr [ebx] - mov [esp], eax - or eax,eax - je @@0917 - add ebx, 2 - mov eax, [esp] - test ah, 80H - jz @@0907 - and eax, 7FFFH - movzx edx, word ptr [ebx] - shl edx, 15 - or eax, edx - mov [esp], eax - add ebx, 2 -@@0907: lea ebp, [esi-1] -@@0908: mov ecx, [ebx] - add ebx, 4 - mov [esp+14H], ecx - mov edi, 1 // edi=CWbit - cmp ebx, [esp+10H] - jnc @@0917 -@@0909: mov ecx, [esp+14H] -@@090A: test ecx, edi - jnz @@0911 - mov al, [ebx] - inc ebx - mov [esi], al - inc esi - cmp ebx, [esp+10H] - lea eax, [esi-3] - jnc @@0917 - cmp eax, ebp - jbe @@0910 - inc ebp - mov eax, [ebp] - mov edx, eax - shr eax, 12 - xor eax, edx - and eax, 0FFFH - mov [esp+eax*4+1CH], ebp -@@0910: add edi, edi - jnz @@090A - jmp @@0908 -@@0911: movzx edx, word ptr [ebx] - add ebx, 2 - mov eax, edx - and edx, 0FH - add edx, 2 - shr eax, 4 - cmp edx,2 - jnz @@0912 - movzx edx, byte ptr [ebx] - inc ebx - add edx, 18 -@@0912: mov eax, [esp+eax*4+1CH] - mov ecx, esi - mov [esp+18H], edx - sub ecx, eax - cmp ecx, edx - jl @@0913 - cmp edx, 32 // inlined optimized move() - ja @large - sub edx, 8 - jg @9_32 - mov ecx, [eax] - mov eax, [eax+4] // always copy 8 bytes for 0..8 - mov [esi], ecx // safe since src_endmatch := src_end-(6+5) - mov [esi+4], eax - jmp @movend -@9_32: fild qword ptr[eax+edx] - fild qword ptr[eax] - cmp edx, 8 - jle @16 - fild qword ptr[eax+8] - cmp edx, 16 - jle @24 - fild qword ptr[eax+16] - fistp qword ptr[esi+16] -@24: fistp qword ptr[esi+8] -@16: fistp qword ptr[esi] - fistp qword ptr[esi+edx] - jmp @movend - nop -@large: push esi - fild qword ptr[eax] - lea eax, [eax+edx-8] - lea edx, [esi+edx-8] - fild qword ptr[eax] - push edx - neg edx - and esi, -8 - lea edx, [edx+esi+8] - pop esi -@lrgnxt:fild qword ptr[eax+edx] - fistp qword ptr[esi+edx] - add edx, 8 - jl @lrgnxt - fistp qword ptr[esi] - pop esi - fistp qword ptr[esi] -@movend:cmp esi, ebp - jbe @@0916 -@@0915: inc ebp - mov edx, [ebp] - mov eax, edx - shr edx, 12 - xor eax, edx - and eax, 0FFFH - mov [esp+eax*4+1CH], ebp - cmp esi, ebp - ja @@0915 -@@0916: add esi, [esp+18H] - cmp ebx, [esp+10H] - jnc @@0917 - add edi, edi - lea ebp, [esi-1] - jz @@0908 - jmp @@0909 -@@0913: push ebx - xor ecx, ecx -@s: dec edx - mov bl, [eax+ecx] - mov [esi+ecx], bl - lea ecx,[ecx+1] - jnz @s - pop ebx - jmp @movend -@@0917: mov eax, [esp] - add esp, 16412 - pop edi - pop esi - pop ebx - pop ebp -{$else CPUX86} -function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -var off: TOffsets; -asm // rcx=src, edx=size, r8=dest - {$ifdef win64} // additional registers to preserve - push rsi - push rdi - {$else} // Linux 64-bit ABI - mov r8, rdx - mov rdx, rsi - mov rcx, rdi - {$endif win64} - push rbx - push r12 - push r13 - push r14 - push r15 - movzx eax, word ptr [rcx] // rcx=src eax=result - lea r9, [rcx+rdx] // r9=src_end - test eax, eax - je @35 - add rcx, 2 - mov r10d, eax - and r10d, 8000H - jz @21 - movzx ebx, word ptr [rcx] - shl ebx, 15 - mov r10d, eax - and r10d, 7FFFH - or r10d, ebx - mov eax, r10d - add rcx, 2 -@21: lea r10, [r8-1H] // r10=last_hashed r8=dest -@22: mov edi, dword ptr [rcx] // edi=CW - add rcx, 4 - mov r13d, 1 // r13d=CWBit - cmp rcx, r9 - jnc @35 -@23: test r13d, edi - jnz @25 - mov bl, byte ptr [rcx] - mov byte ptr [r8], bl - add rcx, 1 - lea rbx, [r8-2H] - add r8, 1 - cmp rcx, r9 - jnc @35 - cmp rbx, r10 - jbe @24 - add r10, 1 - mov esi, dword ptr [r10] - mov rbx, rsi - shr esi, 12 - xor ebx, esi - and ebx, 0FFFH - mov qword ptr [off+rbx*8], r10 -@24: shl r13d, 1 - jnz @23 - jmp @22 -@25: movzx r11, word ptr [rcx] // r11=t - add rcx, 2 - mov ebx, r11d // ebx=h - shr ebx, 4 - and r11, 0FH - lea r11, [r11+2H] - jnz @26 - movzx r11, byte ptr [rcx] - add rcx, 1 - lea r11, [r11+12H] -@26: mov r14, qword ptr [off+rbx*8] // r14=o - mov rbx, r8 - xor rsi, rsi - sub rbx, r14 - mov r12, r11 - mov r15, r11 - cmp rbx, r11 - jc @29 - shr r12, 3 - jz @30 -@27: mov rbx, qword ptr [r14+rsi] // inline move by 8 bytes - mov qword ptr [r8+rsi], rbx - add rsi, 8 - dec r12 - jnz @27 - mov rbx, qword ptr [r14+rsi] // 1..7 remaining bytes - and r15, 7 - jz @31 -@28: mov byte ptr [r8+rsi], bl - shr rbx, 8 - inc rsi - dec r15 - jnz @28 - jmp @31 -@29: mov bl, byte ptr [r14+rsi] // overlaping move - mov byte ptr [r8+rsi], bl - inc rsi - dec r12 - jnz @29 - cmp rcx, r9 - jnz @33 - jmp @35 -@30: mov rbx, qword ptr [r14] - mov qword ptr [r8], rbx -@31: cmp rcx, r9 - jz @35 - cmp r10, r8 - jnc @34 -@32: add r10, 1 - mov ebx, dword ptr [r10] - mov rsi, rbx - shr ebx, 12 - xor esi, ebx - and esi, 0FFFH - mov qword ptr [off+rsi*8], r10 -@33: cmp r10, r8 - jc @32 -@34: add r8, r11 - lea r10, [r8-1H] - shl r13d, 1 - jnz @23 - jmp @22 -@35: pop r15 - pop r14 - pop r13 - pop r12 - pop rbx - {$ifdef win64} // additional registers to preserve - pop rdi - pop rsi - {$endif win64} -{$endif CPUX86} -end; -{$endif CPUINTEL} - -// better code generation with sub-functions for raw decoding -procedure SynLZdecompress1passub(src, src_end, dst: PAnsiChar; var offset: TOffsets); -var last_hashed: PAnsiChar; // initial src and dst value - {$ifdef CPU64} - o: PAnsiChar; - {$endif} - CW, CWbit: cardinal; - v, t, h: PtrUInt; -label nextCW; -begin - last_hashed := dst-1; -nextCW: - CW := PCardinal(src)^; - inc(src,4); - CWbit := 1; - if src=src_end then break; - if last_hashed0 then - continue else - goto nextCW; - end else begin - h := PWord(src)^; - inc(src,2); - t := (h and 15)+2; - h := h shr 4; - if t=2 then begin - t := ord(src^)+(16+2); - inc(src); - end; - {$ifdef CPU64} - o := offset[h]; - if PtrUInt(dst-o)8 then // safe since src_endmatch := src_end-(6+5) - move(offset[h]^,dst^,t) else - PInt64(dst)^ := PInt64(offset[h])^; // much faster in practice - {$endif} - if src>=src_end then break; - if last_hashed=dst; - inc(dst,t); - last_hashed := dst-1; - CWbit := CWbit shl 1; - if CWbit<>0 then - continue else - goto nextCW; - end; - until false; -end; - -function SynLZdecompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -var offset: TOffsets; - src_end: PAnsiChar; -begin - src_end := src+size; - result := PWord(src)^; - if result=0 then exit; - inc(src,2); - if result and $8000<>0 then begin - result := (result and $7fff) or (integer(PWord(src)^) shl 15); - inc(src,2); - end; - SynLZdecompress1passub(src, src_end, dst, offset); -end; - -procedure SynLZdecompress1partialsub(src, dst, src_end, dst_end: PAnsiChar; var offset: TOffsets); -var last_hashed: PAnsiChar; // initial src and dst value - CWbit, CW: integer; - v, t, h: PtrUInt; - {$ifdef CPU64} - o: PAnsiChar; - {$endif} -label nextCW; -begin - last_hashed := dst-1; -nextCW: - CW := PCardinal(src)^; - inc(src,4); - CWbit := 1; - if src=src_end) or (dst>=dst_end) then - break; - if last_hashed0 then - continue else - goto nextCW; - end else begin - h := PWord(src)^; - inc(src,2); - t := (h and 15)+2; - h := h shr 4; - if t=2 then begin - t := ord(src^)+(16+2); - inc(src); - end; - if dst+t>=dst_end then begin // avoid buffer overflow by all means - movechars(offset[h],dst,dst_end-dst); - break; - end; - {$ifdef CPU64} - o := offset[h]; - if (t<=8) or (PtrUInt(dst-o)=src_end then - break; - if last_hashed=dst; - inc(dst,t); - last_hashed := dst-1; - CWbit := CWbit shl 1; - if CWbit<>0 then - continue else - goto nextCW; - end; - until false; -end; - -function SynLZdecompress1partial(src: PAnsiChar; size: integer; dst: PAnsiChar; maxDst: integer): integer; -var offset: TOffsets; - src_end: PAnsiChar; -begin - src_end := src+size; - result := PWord(src)^; - if result=0 then exit; - inc(src,2); - if result and $8000<>0 then begin - result := (result and $7fff) or (integer(PWord(src)^) shl 15); - inc(src,2); - end; - if maxDst0 then - SynLZdecompress1partialsub(src, dst, src_end, dst+result, offset); -end; - - -function SynLZcompress2(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; -var dst_beg, // initial dst value - src_end, // real last byte available in src - src_endmatch, // last byte to try for hashing - o: PAnsiChar; - CWbit: byte; - CWpoint: PCardinal; - h, v, cached: integer; - t, tmax, tdiff, i: integer; - offset: TOffsets; // 16KB+16KB=32KB hashing code - cache: array[0..4095] of integer; - label dotdiff; -begin - dst_beg := dst; - // 1. store in_len - if size>=$8000 then begin - PWord(dst)^ := $8000 or (size and $7fff); - PWord(dst+2)^ := size shr 15; - inc(dst,4); - end else begin - PWord(dst)^ := size ; // src<32768 -> stored as word, otherwise as integer - if size=0 then begin - result := 2; - exit; - end; - inc(dst,2); - end; - // 2. compress - src_end := src+size; - src_endmatch := src_end-(6+5); - CWbit := 0; - CWpoint := pointer(dst); - PCardinal(dst)^ := 0; - inc(dst,sizeof(CWpoint^)); - tdiff := 0; - fillchar(offset,sizeof(offset),0); // fast 16KB reset to 0 - // 1. main loop to search using hash[] - if src<=src_endmatch then - repeat - v := PCardinal(src)^; - h := ((v shr 12) xor v) and 4095; - o := offset[h]; - offset[h] := src; - cached := v xor cache[h]; - cache[h] := v; - if (cached and $00ffffff=0) and (o<>nil) and (src-o>2) then begin -// SetBit(CWpoint,CWbit); -// asm movzx eax,byte ptr CWbit; bts [CWpoint],eax; end - if tdiff<>0 then begin - dec(src,tdiff); -dotdiff:v := tdiff; - if v<=8 then begin - if CWBit+v>31 then begin - for i := CWBit to 31 do begin - dst^ := src^; - inc(dst); - inc(src); - end; - CWpoint := pointer(dst); - PCardinal(dst)^ := 0; - inc(dst,4); - CWBit := (CWBit+v) and 31; - for i := 1 to CWBit do begin - dst^ := src^; - inc(dst); - inc(src); - end; - end else begin - inc(CWBit,v); - for i := 1 to v do begin - dst^ := src^; - inc(dst); - inc(src); - end; - end; - end else begin - CWpoint^ := CWpoint^ or (cardinal(1) shl CWbit); - dec(v,9); - if v>15 then begin - v := 15; // v=9..24 -> h=0..15 - dst^ := #$ff; // size=15 -> tdiff - end else - dst^ := ansichar((v shl 4) or 15); // size=15 -> tdiff - inc(dst); - pInt64(dst)^ := pInt64(src)^; - inc(dst,8); - inc(src,8); - for i := 1 to v+1 do begin - dst^ := src^; - inc(dst); - inc(src); - end; - if CWBit<31 then - inc(CWBit) else begin - CWpoint := pointer(dst); - PCardinal(dst)^ := 0; - inc(dst,4); - CWbit := 0; - end; - dec(tdiff,24); - if tdiff>0 then - goto dotdiff; - end; - end; -// assert(PWord(o)^=PWord(src)^); - tdiff := 0; - CWpoint^ := CWpoint^ or (cardinal(1) shl CWbit); - inc(src,2); - inc(o,2); - t := 0; // t=matchlen-2 - tmax := src_end-src; - if tmax>=(255+15) then - tmax := (255+15); - while (o[t]=src[t]) and (t0); - // here we have always t>0 - if t<15 then begin // store t=1..14 -> size=t=1..14 - PWord(dst)^ := integer(t or h); - inc(dst,2); - end else begin // store t=15..255+15 -> size=0, next byte=matchlen-15-2 - dst[2] := ansichar(t-15); - PWord(dst)^ := h; // size=0 - inc(dst,3); - end; - if CWbit<31 then begin - inc(CWbit); - if src<=src_endmatch then continue else break; - end else begin - CWpoint := pointer(dst); - PCardinal(dst)^ := 0; - inc(dst,4); - CWbit := 0; - if src<=src_endmatch then continue else break; - end; - end else begin - inc(src); - inc(tdiff); - if src<=src_endmatch then continue else break; - end; - until false; - // 2. store remaining bytes - dec(src,tdiff); // force store trailing bytes - if src0 then begin - result := (result and $7fff) or (integer(PWord(src)^) shl 15); - inc(src,2); - end; - // 2. decompress - last_hashed := dst-1; -nextCW: - CW := PCardinal(src)^; - inc(src,4); - CWbit := 1; - if src=src_end then break; - if last_hashed0 then - continue else - goto nextCW; - end else begin - case ord(src^) and 15 of // get size - 0: begin // size=0 -> next byte=matchlen-15-2 - h := PWord(src)^ shr 4; - t := ord(src[2])+(15+2); - inc(src,3); - if dst-offset[h] tdiff - inc(src); - dst^ := src^; - inc(dst); - end; - inc(src); - if src>=src_end then break; - while last_hashed0 then - continue else - goto nextCW; - end; - else begin // size=1..14=matchlen-2 - h := PWord(src)^; - inc(src,2); - t := (h and 15)+2; - h := h shr 4; - if dst-offset[h]=dst; - inc(dst,t); - if src>=src_end then break; - last_hashed := dst-1; - CWbit := CWbit shl 1; - if CWbit<>0 then - continue else - goto nextCW; - end; - until false; - {$ifopt C+} - assert(result=dst-dst_beg); - {$endif} -end; - -end. diff --git a/lib/dmustache/SynMustache.pas b/lib/dmustache/SynMustache.pas deleted file mode 100644 index 7e86dcbd..00000000 --- a/lib/dmustache/SynMustache.pas +++ /dev/null @@ -1,1488 +0,0 @@ -/// Logic-less {{mustache}} template rendering -// - this unit is a part of the freeware Synopse mORMot framework, -// licensed under a MPL/GPL/LGPL tri-license; version 1.18 -unit SynMustache; - -{ - This file is part of Synopse mORMot framework. - - Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez - Synopse Informatique - https://synopse.info - - *** BEGIN LICENSE BLOCK ***** - Version: MPL 1.1/GPL 2.0/LGPL 2.1 - - The contents of this file are subject to the Mozilla Public License Version - 1.1 (the "License"); you may not use this file except in compliance with - the License. You may obtain a copy of the License at - http://www.mozilla.org/MPL - - Software distributed under the License is distributed on an "AS IS" basis, - WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License - for the specific language governing rights and limitations under the License. - - The Original Code is Synopse mORMot framework. - - The Initial Developer of the Original Code is Arnaud Bouchez. - - Portions created by the Initial Developer are Copyright (C) 2022 - the Initial Developer. All Rights Reserved. - - Contributor(s): - - shura1990 - - Alternatively, the contents of this file may be used under the terms of - either the GNU General Public License Version 2 or later (the "GPL"), or - the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), - in which case the provisions of the GPL or the LGPL are applicable instead - of those above. If you wish to allow use of your version of this file only - under the terms of either the GPL or the LGPL, and not to allow others to - use your version of this file under the terms of the MPL, indicate your - decision by deleting the provisions above and replace them with the notice - and other provisions required by the GPL or the LGPL. If you do not delete - the provisions above, a recipient may use your version of this file under - the terms of any one of the MPL, the GPL or the LGPL. - - ***** END LICENSE BLOCK ***** - -} - - -{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER - -interface - -uses - {$ifdef HASINLINENOTX86} - {$ifdef MSWINDOWS}Windows,{$endif} // for Lock/UnLock inlining - {$endif} - Variants, - SysUtils, - SynCommons, - SynTable; - - -type - /// exception raised during process of a {{mustache}} template - ESynMustache = class(ESynException); - - /// identify the {{mustache}} tag kind - // - mtVariable if the tag is a variable - e.g. {{myValue}} - or an Expression - // Helper - e.g. {{helperName valueName}} - // - mtVariableUnescape, mtVariableUnescapeAmp to unescape the variable HTML - e.g. - // {{{myRawValue}}} or {{& name}} - // - mtSection and mtInvertedSection for sections beginning - e.g. - // {{#person}} or {{^person}} - // - mtSectionEnd for sections ending - e.g. {{/person}} - // - mtComment for comments - e.g. {{! ignore me}} - // - mtPartial for partials - e.g. {{> next_more}} - // - mtSetPartial for setting an internal partial - e.g. - // {{=}} - - // Warning: current implementation only supports two character delimiters - // - mtTranslate for content i18n via a callback - e.g. {{"English text}} - // - mtText for all text that appears outside a symbol - TSynMustacheTagKind = ( - mtVariable, mtVariableUnescape, mtVariableUnescapeAmp, - mtSection, mtInvertedSection, mtSectionEnd, - mtComment, mtPartial, mtSetPartial, mtSetDelimiter, mtTranslate, mtText); - - /// store a {{mustache}} tag - TSynMustacheTag = record - /// the kind of the tag - Kind: TSynMustacheTagKind; - /// points to the mtText buffer start - // - main template's text is not allocated as a separate string during - // parsing, but will rather be copied directly from the template memory - TextStart: PUTF8Char; - /// stores the mtText buffer length - TextLen: integer; - /// the index in Tags[] of the other end of this section - // - either the index of mtSectionEnd for mtSection/mtInvertedSection - // - or the index of mtSection/mtInvertedSection for mtSectionEnd - SectionOppositeIndex: integer; - /// the tag content, excluding trailing {{ }} and corresponding symbol - // - is not set for mtText nor mtSetDelimiter - Value: RawUTF8; - end; - - /// store all {{mustache}} tags of a given template - TSynMustacheTagDynArray = array of TSynMustacheTag; - - /// states the section content according to a given value - // - msNothing for false values or empty lists - // - msSingle for non-false values but not a list - // - msSinglePseudo is for *-first *-last *-odd and helper values - // - msList for non-empty lists - TSynMustacheSectionType = (msNothing,msSingle,msSinglePseudo,msList); - - TSynMustache = class; - - /// callback signature used to process an Expression Helper variable - // - i.e. {{helperName value}} tags - // - returned value will be used to process as replacement of a single {{tag}} - TSynMustacheHelperEvent = procedure(const Value: variant; out result: variant) of object; - - /// used to store a registered Expression Helper implementation - TSynMustacheHelper = record - /// the Expression Helper name - Name: RawUTF8; - /// the corresponding callback to process the tag - Event: TSynMustacheHelperEvent; - end; - - /// used to store all registered Expression Helpers - // - i.e. {{helperName value}} tags - // - use TSynMustache.HelperAdd/HelperDelete class methods to manage the list - // or retrieve standard helpers via TSynMustache.HelpersGetStandardList - TSynMustacheHelpers = array of TSynMustacheHelper; - - /// handle {{mustache}} template rendering context, i.e. all values - // - this abstract class should not be used directly, but rather any - // other overridden class - TSynMustacheContext = class - protected - fContextCount: integer; - fWriter: TTextWriter; - fOwner: TSynMustache; - fEscapeInvert: boolean; - fHelpers: TSynMustacheHelpers; - fOnStringTranslate: TOnStringTranslate; - procedure TranslateBlock(Text: PUTF8Char; TextLen: Integer); virtual; - procedure PopContext; virtual; abstract; - procedure AppendValue(const ValueName: RawUTF8; UnEscape: boolean); - virtual; abstract; - function AppendSection(const ValueName: RawUTF8): TSynMustacheSectionType; - virtual; abstract; - function GotoNextListItem: boolean; - virtual; abstract; - public - /// initialize the rendering context for the given text writer - constructor Create(Owner: TSynMustache; WR: TTextWriter); - /// the registered Expression Helpers, to handle {{helperName value}} tags - // - use TSynMustache.HelperAdd/HelperDelete class methods to manage the list - // or retrieve standard helpers via TSynMustache.HelpersGetStandardList - property Helpers: TSynMustacheHelpers read fHelpers write fHelpers; - /// access to the {{"English text}} translation callback - property OnStringTranslate: TOnStringTranslate - read fOnStringTranslate write fOnStringTranslate; - /// read-only access to the associated text writer instance - property Writer: TTextWriter read fWriter; - /// invert the HTML characters escaping process - // - by default, {{value}} will escape value chars, and {{{value}} won't - // - set this property to true to force {{value}} NOT to escape HTML chars - // and {{{value}} escaping chars (may be useful e.g. for code generation) - property EscapeInvert: boolean read fEscapeInvert write fEscapeInvert; - end; - - /// handle {{mustache}} template rendering context from a custom variant - // - the context is given via a custom variant type implementing - // TSynInvokeableVariantType.Lookup, e.g. TDocVariant or TSMVariant - TSynMustacheContextVariant = class(TSynMustacheContext) - protected - fContext: array of record - Document: TVarData; - DocumentType: TSynInvokeableVariantType; - ListCount: integer; - ListCurrent: integer; - ListCurrentDocument: TVarData; - ListCurrentDocumentType: TSynInvokeableVariantType; - end; - fTempGetValueFromContextHelper: TVariantDynArray; - procedure PushContext(aDoc: TVarData); - procedure PopContext; override; - procedure AppendValue(const ValueName: RawUTF8; UnEscape: boolean); override; - function AppendSection(const ValueName: RawUTF8): TSynMustacheSectionType; override; - function GotoNextListItem: boolean; override; - function GetDocumentType(const aDoc: TVarData): TSynInvokeableVariantType; - function GetValueFromContext(const ValueName: RawUTF8; var Value: TVarData): TSynMustacheSectionType; - function GetValueCopyFromContext(const ValueName: RawUTF8): variant; - procedure AppendVariant(const Value: variant; UnEscape: boolean); - public - /// initialize the context from a custom variant document - // - note that the aDocument instance shall be available during all - // lifetime of this TSynMustacheContextVariant instance - // - you should not use this constructor directly, but the - // corresponding TSynMustache.Render*() methods - constructor Create(Owner: TSynMustache; WR: TTextWriter; SectionMaxCount: integer; - const aDocument: variant); - end; - - /// maintain a list of {{mustache}} partials - // - this list of partials template could be supplied to TSynMustache.Render() - // method, to render {{>partials}} as expected - // - using a dedicated class allows to share the partials between execution - // context, without recurring to non SOLID global variables - // - you may also define "internal" partials, e.g. {{partialName}} template - // - returns the parsed template - function Add(const aName,aTemplate: RawUTF8): TSynMustache; overload; - /// register a {{>partialName}} template - // - returns the parsed template - function Add(const aName: RawUTF8; aTemplateStart,aTemplateEnd: PUTF8Char): TSynMustache; overload; - /// search some text withing the {{mustache}} partial - function FoundInTemplate(const text: RawUTF8): PtrInt; - /// delete the partials - destructor Destroy; override; - /// low-level access to the internal partials list - property List: TRawUTF8List read fList; - end; - - /// stores one {{mustache}} pre-rendered template - // - once parsed, a template will be stored in this class instance, to be - // rendered lated via the Render() method - // - you can use the Parse() class function to maintain a shared cache of - // parsed templates - // - implements all official mustache specifications, and some extensions - // - handles {{.}} pseudo-variable for the current context object (very - // handy when looping through a simple list, for instance) - // - handles {{-index}} pseudo-variable for the current context array index - // (1-based value) so that e.g. - // "My favorite things:\n{{#things}}{{-index}}. {{.}}\n{{/things}}" - // over {things:["Peanut butter", "Pen spinning", "Handstands"]} renders as - // "My favorite things:\n1. Peanut butter\n2. Pen spinning\n3. Handstands\n" - // - you could use {{-index0}} for 0-based index value - // - handles -first -last and -odd pseudo-section keys, e.g. - // "{{#things}}{{^-first}}, {{/-first}}{{.}}{{/things}}" - // over {things:["one", "two", "three"]} renders as 'one, two, three' - // - allows inlined partial templates , to be defined e.g. as - // {{ <= >= <> operators over two values: - // $ {{#if .,"=",123}} {{#if Total,">",1000}} {{#if info,"<>",""}} - // which may be shortened as such: - // $ {{#if .=123}} {{#if Total>1000}} {{#if info<>""}} - class function HelpersGetStandardList: TSynMustacheHelpers; overload; - /// returns a list of most used static Expression Helpers, adding some - // custom callbacks - // - is just a wrapper around HelpersGetStandardList and HelperAdd() - class function HelpersGetStandardList(const aNames: array of RawUTF8; - const aEvents: array of TSynMustacheHelperEvent): TSynMustacheHelpers; overload; - - /// renders the {{mustache}} template into a destination text buffer - // - the context is given via our abstract TSynMustacheContext wrapper - // - the rendering extended in fTags[] is supplied as parameters - // - you can specify a list of partials via TSynMustachePartials.CreateOwned - procedure RenderContext(Context: TSynMustacheContext; TagStart,TagEnd: integer; - Partials: TSynMustachePartials; NeverFreePartials: boolean); - /// renders the {{mustache}} template from a variant defined context - // - the context is given via a custom variant type implementing - // TSynInvokeableVariantType.Lookup, e.g. TDocVariant or TSMVariant - // - you can specify a list of partials via TSynMustachePartials.CreateOwned, - // a list of Expression Helpers, or a custom {{"English text}} callback - // - can be used e.g. via a TDocVariant: - // !var mustache := TSynMustache; - // ! doc: variant; - // ! html: RawUTF8; - // !begin - // ! mustache := TSynMustache.Parse( - // ! 'Hello {{name}}'#13#10'You have just won {{value}} dollars!'); - // ! TDocVariant.New(doc); - // ! doc.name := 'Chris'; - // ! doc.value := 10000; - // ! html := mustache.Render(doc); - // ! // here html='Hello Chris'#13#10'You have just won 10000 dollars!' - // - you can also retrieve the context from an ORM query of mORMot.pas: - // ! dummy := TSynMustache.Parse( - // ! '{{#items}}'#13#10'{{Int}}={{Test}}'#13#10'{{/items}}').Render( - // ! aClient.RetrieveDocVariantArray(TSQLRecordTest,'items','Int,Test')); - // - set EscapeInvert = true to force {{value}} NOT to escape HTML chars - // and {{{value}} escaping chars (may be useful e.g. for code generation) - function Render(const Context: variant; Partials: TSynMustachePartials=nil; - Helpers: TSynMustacheHelpers=nil; OnTranslate: TOnStringTranslate=nil; - EscapeInvert: boolean=false): RawUTF8; - /// renders the {{mustache}} template from JSON defined context - // - the context is given via a JSON object, defined from UTF-8 buffer - // - you can specify a list of partials via TSynMustachePartials.CreateOwned, - // a list of Expression Helpers, or a custom {{"English text}} callback - // - is just a wrapper around Render(_JsonFast()) - // - you can write e.g. with the extended JSON syntax: - // ! html := mustache.RenderJSON('{things:["one", "two", "three"]}'); - // - set EscapeInvert = true to force {{value}} NOT to escape HTML chars - // and {{{value}} escaping chars (may be useful e.g. for code generation) - function RenderJSON(const JSON: RawUTF8; Partials: TSynMustachePartials=nil; - Helpers: TSynMustacheHelpers=nil; OnTranslate: TOnStringTranslate=nil; - EscapeInvert: boolean=false): RawUTF8; overload; - /// renders the {{mustache}} template from JSON defined context - // - the context is given via a JSON object, defined with parameters - // - you can specify a list of partials via TSynMustachePartials.CreateOwned, - // a list of Expression Helpers, or a custom {{"English text}} callback - // - is just a wrapper around Render(_JsonFastFmt()) - // - you can write e.g. with the extended JSON syntax: - // ! html := mustache.RenderJSON('{name:?,value:?}',[],['Chris',10000]); - // - set EscapeInvert = true to force {{value}} NOT to escape HTML chars - // and {{{value}} escaping chars (may be useful e.g. for code generation) - function RenderJSON(const JSON: RawUTF8; const Args,Params: array of const; - Partials: TSynMustachePartials=nil; Helpers: TSynMustacheHelpers=nil; - OnTranslate: TOnStringTranslate=nil; - EscapeInvert: boolean=false): RawUTF8; overload; - /// search some text within the {{mustache}} template text - function FoundInTemplate(const text: RawUTF8): boolean; - - /// read-only access to the raw {{mustache}} template content - property Template: RawUTF8 read fTemplate; - /// the maximum possible number of nested contexts - property SectionMaxCount: Integer read fSectionMaxCount; - end; - - -const - /// this constant can be used to define as JSON a tag value - NULL_OR_TRUE: array[boolean] of RawUTF8 = ('null','true'); - - /// this constant can be used to define as JSON a tag value as separator - NULL_OR_COMMA: array[boolean] of RawUTF8 = ('null','","'); - -implementation - -function KindToText(Kind: TSynMustacheTagKind): PShortString; -begin - result := GetEnumName(TypeInfo(TSynMustacheTagKind),ord(Kind)); -end; - -type - TSynMustacheParser = class - protected - fTagStart, fTagStop: word; - fPos, fPosMin, fPosMax, fPosTagStart: PUTF8Char; - fTagCount: integer; - fTemplate: TSynMustache; - fScanStart, fScanEnd: PUTF8Char; - function Scan(ExpectedTag: Word): boolean; - procedure AddTag(aKind: TSynMustacheTagKind; - aStart: PUTF8Char=nil; aEnd: PUTF8Char=nil); - public - constructor Create(Template: TSynMustache; const DelimiterStart, DelimiterStop: RawUTF8); - procedure Parse(P,PEnd: PUTF8Char); - end; - - TSynMustacheCache = class(TRawUTF8List) - public - function Parse(const aTemplate: RawUTF8): TSynMustache; - function UnParse(const aTemplate: RawUTF8): boolean; - end; - -var - SynMustacheCache: TSynMustacheCache = nil; - - - -{ TSynMustacheParser } - -procedure TSynMustacheParser.AddTag(aKind: TSynMustacheTagKind; - aStart, aEnd: PUTF8Char); -var - P: PUTF8Char; -begin - if (aStart=nil) or (aEnd=nil) then begin - aStart := fScanStart; - aEnd := fScanEnd; - case aKind of - mtComment, mtSection, mtSectionEnd, mtInvertedSection, mtSetDelimiter, mtPartial: begin - // (indented) standalone lines should be removed from the template - if aKind<>mtPartial then - while (fPosTagStart>fPosMin) and (fPosTagStart[-1] in [' ',#9]) do - dec(fPosTagStart); // ignore any indentation chars - if (fPosTagStart=fPosMin) or (fPosTagStart[-1]=#$0A) then - // tag starts on a new line -> check if ends on the same line - if (fPos>fPosMax) or (fPos^=#$0A) or (PWord(fPos)^=$0A0D) then begin - if fPos<=fPosMax then - if fPos^=#$0A then - inc(fPos) else - if PWord(fPos)^=$0A0D then - inc(fPos,2); - if fTagCount>0 then // remove any indentation chars from previous text - with fTemplate.fTags[fTagCount-1] do - if Kind=mtText then - while (TextLen>0) and (TextStart[TextLen-1] in [' ',#9]) do - dec(TextLen); - end; - end; - mtVariable, mtVariableUnescape, mtVariableUnescapeAmp: begin - // handle JSON object/array with nested } e.g. as {{helper [{a:{a:1,b:2}}]}} - P := PosChar(aStart,' '); - if (P<>nil) and (Pnil then begin - aEnd := P; - fPos := P; - if not Scan(fTagStop) then - raise ESynMustache.CreateUTF8('Unfinished {{%',[aStart]); - if (aKind=mtVariableUnescape) and (fTagStop=$7d7d) and (PWord(fPos-1)^=$7d7d) then - inc(fPos); // {{{name}}} -> point after }}} - end; - end; - end; - end; - end; - end; - if aEnd<=aStart then - exit; - if fTagCount>=length(fTemplate.fTags) then - SetLength(fTemplate.fTags,NextGrow(fTagCount)); - with fTemplate.fTags[fTagCount] do begin - Kind := aKind; - SectionOppositeIndex := -1; - case aKind of - mtText, mtComment, mtTranslate: begin - TextStart := aStart; - TextLen := aEnd-aStart; - end; - else begin - TextStart := fPosTagStart; - TextLen := aEnd-fPosTagStart; - // superfluous in-tag whitespace should be ignored - while (aStartaStart) and (aEnd[-1]<=' ') do dec(aEnd); - if aEnd=aStart then - raise ESynMustache.CreateUTF8('Void % identifier',[KindToText(aKind)^]); - FastSetString(Value,aStart,aEnd-aStart); - end; - end; - end; - inc(fTagCount); -end; - -constructor TSynMustacheParser.Create(Template: TSynMustache; - const DelimiterStart, DelimiterStop: RawUTF8); -begin - fTemplate := Template; - if length(DelimiterStart)<>2 then - raise ESynMustache.CreateUTF8('DelimiterStart="%"',[DelimiterStart]); - if length(DelimiterStop)<>2 then - raise ESynMustache.CreateUTF8('DelimiterStop="%"',[DelimiterStop]); - fTagStart := PWord(DelimiterStart)^; - fTagStop := PWord(DelimiterStop)^; -end; - -function GotoNextTag(P,PMax: PUTF8Char; ExpectedTag: Word): PUTF8Char; -begin - if PExpectedTag then begin - inc(P); - if P0) and IdemPropNameU(finish,pointer(start),i-1); - end; -end; - -procedure TSynMustacheParser.Parse(P, PEnd: PUTF8Char); -var Kind: TSynMustacheTagKind; - Symbol: AnsiChar; - i,j,secCount,secLevel: integer; -begin - secCount := 0; - if P=nil then - exit; - fPos := P; - fPosMin := P; - fPosMax := PEnd-1; - repeat - if not Scan(fTagStart) then - break; - fPosTagStart := fScanEnd; - AddTag(mtText); - if fPos>=fPosMax then - break; - Symbol := fPos^; - case Symbol of - '=': Kind := mtSetDelimiter; - '{': Kind := mtVariableUnescape; - '&': Kind := mtVariableUnescapeAmp; - '#': Kind := mtSection; - '^': Kind := mtInvertedSection; - '/': Kind := mtSectionEnd; - '!': Kind := mtComment; - '>': Kind := mtPartial; - '<': Kind := mtSetPartial; - '"': Kind := mtTranslate; - else Kind := mtVariable; - end; - if Kind<>mtVariable then - inc(fPos); - if not Scan(fTagStop) then - raise ESynMustache.CreateUTF8('Unfinished {{tag [%]',[fPos]); - case Kind of - mtSetDelimiter: begin - if (fScanEnd-fScanStart<>6) or (fScanEnd[-1]<>'=') then - raise ESynMustache.Create('mtSetDelimiter syntax is e.g. {{=<% %>=}}'); - fTagStart := PWord(fScanStart)^; - fTagStop := PWord(fScanStart+3)^; - continue; // do not call AddTag(mtSetDelimiter) - end; - mtVariableUnescape: - if (Symbol='{') and (fTagStop=$7d7d) and (PWord(fPos-1)^=$7d7d) then - inc(fPos); // {{{name}}} -> point after }}} - end; - AddTag(Kind); - until false; - AddTag(mtText,fPos,fPosMax+1); - for i := 0 to fTagCount-1 do - with fTemplate.fTags[i] do - case Kind of - mtSection, mtInvertedSection, mtSetPartial: begin - inc(secCount); - if secCount>fTemplate.fSectionMaxCount then - fTemplate.fSectionMaxCount := secCount; - secLevel := 1; - for j := i+1 to fTagCount-1 do - case fTemplate.fTags[j].Kind of - mtSection, mtInvertedSection, mtSetPartial: - inc(secLevel); - mtSectionEnd: begin - dec(secLevel); - if secLevel=0 then - if SectionNameMatch(Value,fTemplate.fTags[j].Value) then begin - fTemplate.fTags[j].SectionOppositeIndex := i; - SectionOppositeIndex := j; - if Kind=mtSetPartial then begin - if fTemplate.fInternalPartials=nil then - fTemplate.fInternalPartials := TSynMustachePartials.Create; - fTemplate.fInternalPartials.Add(Value, - TextStart+TextLen+2,fTemplate.fTags[j].TextStart); - end; - break; - end else - raise ESynMustache.CreateUTF8('Got {{/%}}, expected {{/%}}', - [Value,fTemplate.fTags[j].Value]); - end; - end; - if SectionOppositeIndex<0 then - raise ESynMustache.CreateUTF8('Missing section end {{/%}}',[Value]); - end; - mtSectionEnd: begin - dec(secCount); - if SectionOppositeIndex<0 then - raise ESynMustache.CreateUTF8('Unexpected section end {{/%}}',[Value]); - end; - end; - SetLength(fTemplate.fTags,fTagCount); -end; - - -{ TSynMustacheCache } - -function TSynMustacheCache.Parse(const aTemplate: RawUTF8): TSynMustache; -begin - result := GetObjectFrom(aTemplate); - if result=nil then begin - result := TSynMustache.Create(aTemplate); - AddObjectUnique(aTemplate,@result); - end; -end; - -function TSynMustacheCache.UnParse(const aTemplate: RawUTF8): boolean; -begin - result := Delete(aTemplate)>=0; -end; - - -{ TSynMustache } - -class function TSynMustache.Parse(const aTemplate: RawUTF8): TSynMustache; -begin - if SynMustacheCache=nil then - GarbageCollectorFreeAndNil(SynMustacheCache, - TSynMustacheCache.Create([fObjectsOwned,fNoDuplicate,fCaseSensitive])); - result := SynMustacheCache.Parse(aTemplate); -end; - -class function TSynMustache.UnParse(const aTemplate: RawUTF8): boolean; -begin - result := SynMustacheCache.UnParse(aTemplate); -end; - -class function TSynMustache.TryRenderJson(const aTemplate, aJSON: RawUTF8; - out aContent: RawUTF8): boolean; -var mus: TSynMustache; -begin - if aTemplate<>'' then - try - mus := Parse(aTemplate); - aContent := mus.RenderJSON(aJSON); - result := true; - except - result := false; - end else - result := false; -end; - -constructor TSynMustache.Create(const aTemplate: RawUTF8); -begin - Create(pointer(aTemplate),length(aTemplate)); -end; - -constructor TSynMustache.Create(aTemplate: PUTF8Char; aTemplateLen: integer); -begin - inherited Create; - fTemplate := aTemplate; - with TSynMustacheParser.Create(self,'{{','}}') do - try - Parse(aTemplate,aTemplate+aTemplateLen); - finally - Free; - end; -end; - -type - TSynMustacheProcessSection = procedure of object; - -procedure TSynMustache.RenderContext(Context: TSynMustacheContext; - TagStart,TagEnd: integer; Partials: TSynMustachePartials; NeverFreePartials: boolean); -var partial: TSynMustache; -begin - try - while TagStart<=TagEnd do begin - with fTags[TagStart] do - case Kind of - mtText: - if TextLen<>0 then // may be 0 e.g. for standalone without previous Line - Context.fWriter.AddNoJSONEscape(TextStart,TextLen); - mtVariable: - Context.AppendValue(Value,false); - mtVariableUnescape, mtVariableUnescapeAmp: - Context.AppendValue(Value,true); - mtSection: - case Context.AppendSection(Value) of - msNothing: begin // e.g. for no key, false value, or empty list - TagStart := SectionOppositeIndex; - continue; // ignore whole section - end; - msList: begin - while Context.GotoNextListItem do - RenderContext(Context,TagStart+1,SectionOppositeIndex-1,Partials,true); - TagStart := SectionOppositeIndex; - continue; // ignore whole section since we just rendered it as a list - end; - // msSingle,msSinglePseudo: process the section once with current context - end; - mtInvertedSection: // display section for no key, false value, or empty list - if Context.AppendSection(Value)<>msNothing then begin - TagStart := SectionOppositeIndex; - continue; // ignore whole section - end; - mtSectionEnd: - if (fTags[SectionOppositeIndex].Kind in [mtSection,mtInvertedSection]) and - (Value[1]<>'-') and (PosExChar(' ',fTags[SectionOppositeIndex].Value)=0) then - Context.PopContext; - mtComment: - ; // just ignored - mtPartial: begin - partial := fInternalPartials.GetPartial(Value); - if (partial=nil) and (Context.fOwner<>self) then // recursive call - partial := Context.fOwner.fInternalPartials.GetPartial(Value); - if (partial=nil) and (Partials<>nil) then - partial := Partials.GetPartial(Value); - if partial<>nil then - partial.RenderContext(Context,0,high(partial.fTags),Partials,true); - end; - mtSetPartial: - TagStart := SectionOppositeIndex; // ignore whole internal {{0 then - Context.TranslateBlock(TextStart,TextLen); - else - raise ESynMustache.CreateUTF8('Kind=% not implemented yet', - [KindToText(fTags[TagStart].Kind)^]); - end; - inc(TagStart); - end; - finally - if (Partials<>nil) and (Partials.fOwned) and not NeverFreePartials then - Partials.Free; - end; -end; - -function TSynMustache.Render(const Context: variant; - Partials: TSynMustachePartials; Helpers: TSynMustacheHelpers; - OnTranslate: TOnStringTranslate; EscapeInvert: boolean): RawUTF8; -var W: TTextWriter; - Ctxt: TSynMustacheContext; - tmp: TTextWriterStackBuffer; -begin - W := TTextWriter.CreateOwnedStream(tmp); - try - Ctxt := TSynMustacheContextVariant.Create(self,W,SectionMaxCount,Context); - try - Ctxt.Helpers := Helpers; - Ctxt.OnStringTranslate := OnTranslate; - Ctxt.EscapeInvert := EscapeInvert; - RenderContext(Ctxt,0,high(fTags),Partials,false); - W.SetText(result); - finally - Ctxt.Free; - end; - finally - W.Free; - end; -end; - -function TSynMustache.RenderJSON(const JSON: RawUTF8; - Partials: TSynMustachePartials; Helpers: TSynMustacheHelpers; - OnTranslate: TOnStringTranslate; EscapeInvert: boolean): RawUTF8; -var context: variant; -begin - _Json(JSON,context,JSON_OPTIONS[true]); - result := Render(context,Partials,Helpers,OnTranslate,EscapeInvert); -end; - -function TSynMustache.RenderJSON(const JSON: RawUTF8; const Args, - Params: array of const; Partials: TSynMustachePartials; - Helpers: TSynMustacheHelpers; OnTranslate: TOnStringTranslate; - EscapeInvert: boolean): RawUTF8; -var context: variant; -begin - _Json(FormatUTF8(JSON,Args,Params,true),context,JSON_OPTIONS[true]); - result := Render(context,Partials,Helpers,OnTranslate,EscapeInvert); -end; - -destructor TSynMustache.Destroy; -begin - FreeAndNil(fInternalPartials); - inherited; -end; - -function TSynMustache.FoundInTemplate(const text: RawUTF8): boolean; -begin // internal partials are part of fTemplate - result := (self<>nil) and (text<>'') and (PosEx(text,fTemplate)>0); -end; - -class procedure TSynMustache.HelperAdd(var Helpers: TSynMustacheHelpers; - const aName: RawUTF8; aEvent: TSynMustacheHelperEvent); -var n,i: PtrInt; -begin - n := length(Helpers); - for i := 0 to n-1 do - if IdemPropNameU(Helpers[i].Name,aName) then begin - Helpers[i].Event := aEvent; - exit; - end; - SetLength(Helpers,n+1); - Helpers[n].Name := aName; - Helpers[n].Event := aEvent; -end; - -class procedure TSynMustache.HelperAdd(var Helpers: TSynMustacheHelpers; - const aNames: array of RawUTF8; const aEvents: array of TSynMustacheHelperEvent); -var n,i: PtrInt; -begin - n := length(aNames); - if n=length(aEvents) then - for i := 0 to n-1 do - HelperAdd(Helpers,aNames[i],aEvents[i]); -end; - -class procedure TSynMustache.HelperDelete(var Helpers: TSynMustacheHelpers; - const aName: RawUTF8); -var n,i,j: PtrInt; -begin - n := length(Helpers); - for i := 0 to n-1 do - if IdemPropNameU(Helpers[i].Name,aName) then begin - for j := i to n-2 do - Helpers[j] := Helpers[j+1]; - SetLength(Helpers,n-1); - exit; - end; -end; - -class function TSynMustache.HelperFind(const Helpers: TSynMustacheHelpers; - aName: PUTF8Char; aNameLen: integer): integer; -begin - for result := 0 to length(Helpers)-1 do - if IdemPropNameU(Helpers[result].Name,aName,aNameLen) then - exit; - result := -1; -end; - -var - HelpersStandardList: TSynMustacheHelpers; - -class function TSynMustache.HelpersGetStandardList: TSynMustacheHelpers; -begin - if HelpersStandardList=nil then - HelperAdd(HelpersStandardList, - ['DateTimeToText','DateToText','DateFmt','TimeLogToText','JSONQuote','JSONQuoteURI', - 'ToJSON','MarkdownToHtml','SimpleToHtml','WikiToHtml','BlobToBase64','EnumTrim', - 'EnumTrimRight','PowerOfTwo','Equals','If','NewGUID','ExtractFileName','Lower','Upper'], - [DateTimeToText,DateToText,DateFmt,TimeLogToText,JSONQuote,JSONQuoteURI, - ToJSON,MarkdownToHtml,SimpleToHtml,WikiToHtml,BlobToBase64,EnumTrim,EnumTrimRight, - PowerOfTwo,Equals_,If_,NewGUID,ExtractFileName,Lower,Upper]); - result := HelpersStandardList; -end; - -class function TSynMustache.HelpersGetStandardList(const aNames: array of RawUTF8; - const aEvents: array of TSynMustacheHelperEvent): TSynMustacheHelpers; -begin - result := copy(HelpersGetStandardList); // don't affect global HelpersStandardList - HelperAdd(result,aNames,aEvents); -end; - -class procedure TSynMustache.DateTimeToText(const Value: variant; out result: variant); -var Time: TTimeLogBits; - dt: TDateTime; -begin - if VariantToDateTime(Value,dt) then begin - Time.From(dt,false); - result := Time.i18nText; - end else - SetVariantNull(result); -end; - -class procedure TSynMustache.DateToText(const Value: variant; out result: variant); -var Time: TTimeLogBits; - dt: TDateTime; -begin - if VariantToDateTime(Value,dt) then begin - Time.From(dt,true); - result := Time.i18nText; - end else - SetVariantNull(result); -end; - -class procedure TSynMustache.DateFmt(const Value: variant; out result: variant); -var dt: TDateTime; -begin // {{DateFmt DateValue,"dd/mm/yyy"}} - with _Safe(Value)^ do - if (Kind=dvArray) and (Count=2) and VariantToDateTime(Values[0],dt) then - result := FormatDateTime(Values[1],dt) else - SetVariantNull(result); -end; - -class procedure TSynMustache.TimeLogToText(const Value: variant; out result: variant); -var Time: TTimeLogBits; -begin - if VariantToInt64(Value,Time.Value) then - result := Time.i18nText else - SetVariantNull(result); -end; - -class procedure TSynMustache.ToJSON(const Value: variant; out result: variant); -begin - if not VarIsEmptyOrNull(Value) then - RawUTF8ToVariant(JSONReformat(VariantToUTF8(Value)),result); -end; - -class procedure TSynMustache.JSONQuote(const Value: variant; out result: variant); -var json: RawUTF8; -begin - if not VarIsEmptyOrNull(Value) then // avoid to return "null" - VariantToUTF8(Value,json); - RawUTF8ToVariant(QuotedStrJSON(json),result); -end; - -class procedure TSynMustache.JSONQuoteURI(const Value: variant; out result: variant); -var json: RawUTF8; -begin - if not VarIsEmptyOrNull(Value) then // avoid to return "null" - VariantToUTF8(Value,json); - RawUTF8ToVariant(UrlEncode(QuotedStrJSON(json)),result); -end; - -procedure ToHtml(const Value: variant; var result: variant; fmt: TTextWriterHTMLEscape; - wiki: boolean=false); -var txt: RawUTF8; - d: PDocVariantData; -begin - d := _Safe(Value); // {{{SimpleToHtml content,browserhasnoemoji,nohtmlescape}}} - if (dvoIsArray in d^.Options) and (d^.Count>=2) then begin - if VarIsEmptyOrNull(d^.Values[0]) then - exit; // don't append 'null' text - VariantToUTF8(d^.Values[0],txt); - if not VarIsVoid(d^.Values[1]) then - exclude(fmt,heEmojiToUTF8); - if (d^.Count>=3) and not VarIsVoid(d^.Values[2]) then - exclude(fmt,heHtmlEscape); - end else // {{{MarkdownToHtml content}}} - if VarIsEmptyOrNull(Value) then - exit else - VariantToUTF8(Value,txt); - if txt<>'' then - if wiki then - txt := HtmlEscapeWiki(txt,fmt) else - txt := HtmlEscapeMarkdown(txt,fmt); - RawUTF8ToVariant(txt,result); -end; - -class procedure TSynMustache.WikiToHtml(const Value: variant; out result: variant); -begin - ToHtml(Value,result,[heHtmlEscape,heEmojiToUTF8],{wiki=}true); -end; - -class procedure TSynMustache.MarkdownToHtml(const Value: variant; out result: variant); -begin - ToHtml(Value,result,[heEmojiToUTF8]); // default Markdown is to allow HTML tags -end; - -class procedure TSynMustache.SimpleToHtml(const Value: variant; out result: variant); -begin - ToHtml(Value,result,[heHtmlEscape,heEmojiToUTF8]); -end; - -class procedure TSynMustache.BlobToBase64(const Value: variant; out result: variant); -var tmp: RawUTF8; - wasString: boolean; -begin - VariantToUTF8(Value,tmp,wasString); - if wasString and (pointer(tmp)<>nil) then begin - if PInteger(tmp)^ and $00ffffff=JSON_BASE64_MAGIC then - delete(tmp,1,3); - RawUTF8ToVariant(tmp,result); - end else - result := Value; -end; - -class procedure TSynMustache.EnumTrim(const Value: variant; out result: variant); -var tmp: RawUTF8; - wasString: boolean; - short: PUTF8Char; -begin - VariantToUTF8(Value,tmp,wasString); - if not wasString then - exit; - short := TrimLeftLowerCase(tmp); - RawUTF8ToVariant(short,StrLen(short),result); -end; - -class procedure TSynMustache.EnumTrimRight(const Value: variant; out result: variant); -var tmp: RawUTF8; - wasString: boolean; - i,L: integer; -begin - VariantToUTF8(Value,tmp,wasString); - if not wasString then - exit; - L := length(tmp); - for i := 1 to L do - if not (tmp[i] in ['a'..'z']) then begin - L := i-1; - break; - end; - RawUTF8ToVariant(Pointer(tmp),L,result); -end; - -class procedure TSynMustache.PowerOfTwo(const Value: variant; out result: variant); -var V: Int64; -begin - if TVarData(Value).VType>varNull then - if VariantToInt64(Value,V) then - result := Int64(1) shl V; -end; - -class procedure TSynMustache.Equals_(const Value: variant; out result: variant); -begin // {{#Equals .,12}} - with _Safe(Value)^ do - if (Kind=dvArray) and (Count=2) and - (SortDynArrayVariantComp(TVarData(Values[0]),TVarData(Values[1]),false)=0) then - result := true else - SetVariantNull(result); -end; - -class procedure TSynMustache.If_(const Value: variant; out result: variant); -var cmp: integer; - oper: RawUTF8; - wasString: boolean; -begin // {{#if .<>""}} or {{#if .,"=",123}} - SetVariantNull(result); - with _Safe(Value)^ do - if (Kind=dvArray) and (Count=3) then begin - VariantToUTF8(Values[1],oper,wasString); - if wasString and (oper<>'') then begin - cmp := SortDynArrayVariantComp(TVarData(Values[0]),TVarData(Values[2]),false); - case PWord(oper)^ of - ord('='): if cmp=0 then result := True; - ord('>'): if cmp>0 then result := True; - ord('<'): if cmp<0 then result := True; - ord('>')+ord('=')shl 8: if cmp>=0 then result := True; - ord('<')+ord('=')shl 8: if cmp<=0 then result := True; - ord('<')+ord('>')shl 8: if cmp<>0 then result := True; - end; - end; - end; -end; - -class procedure TSynMustache.NewGUID(const Value: variant; out result: variant); -var g: TGUID; -begin - CreateGUID(g); - RawUTF8ToVariant(GUIDToRawUTF8(g),result); -end; - -class procedure TSynMustache.ExtractFileName(const Value: variant; out result: variant); -begin - result := SysUtils.ExtractFileName(Value); -end; - -class procedure TSynMustache.Lower(const Value: variant; out result: variant); -begin - result := SysUtils.LowerCase(Value); -end; - -class procedure TSynMustache.Upper(const Value: variant; out result: variant); -begin - result := SysUtils.UpperCase(Value); -end; - - -{ TSynMustacheContext } - -constructor TSynMustacheContext.Create(Owner: TSynMustache; WR: TTextWriter); -begin - fOwner := Owner; - fWriter := WR; -end; - -procedure TSynMustacheContext.TranslateBlock(Text: PUTF8Char; TextLen: Integer); -var s: string; -begin - if Assigned(OnStringTranslate) then begin - UTF8DecodeToString(Text,TextLen,s); - OnStringTranslate(s); - fWriter.AddNoJSONEscapeString(s); - end else - fWriter.AddNoJSONEscape(Text,TextLen); -end; - - -{ TSynMustacheContextVariant } - -constructor TSynMustacheContextVariant.Create(Owner: TSynMustache; WR: TTextWriter; - SectionMaxCount: integer; const aDocument: variant); -begin - inherited Create(Owner,WR); - SetLength(fContext,SectionMaxCount+1); - PushContext(TVarData(aDocument)); // weak copy -end; - -function TSynMustacheContextVariant.GetDocumentType( - const aDoc: TVarData): TSynInvokeableVariantType; -begin - result := nil; - if aDoc.VType<=varAny then - exit; - if (fContextCount>0) and (fContext[0].DocumentType<>nil) and - (aDoc.VType=fContext[0].DocumentType.VarType) then - result := fContext[0].DocumentType else - if not (FindCustomVariantType(aDoc.VType,TCustomVariantType(result)) and - result.InheritsFrom(TSynInvokeableVariantType)) then - result := nil; -end; - -procedure TSynMustacheContextVariant.PushContext(aDoc: TVarData); -begin - if fContextCount>=length(fContext) then - SetLength(fContext,fContextCount+32); // roughtly set by SectionMaxCount - with fContext[fContextCount] do begin - Document := aDoc; - DocumentType := GetDocumentType(aDoc); - ListCurrent := -1; - if DocumentType=nil then - ListCount := -1 else - ListCount := DocumentType.IterateCount(aDoc); - end; - inc(fContextCount); -end; - -procedure TSynMustacheContextVariant.PopContext; -begin - if fContextCount>1 then - dec(fContextCount); -end; - -function TSynMustacheContextVariant.GetValueCopyFromContext( - const ValueName: RawUTF8): variant; -var tmp: TVarData; -begin - if (ValueName='') or (ValueName[1] in ['0'..'9','"','{','[']) or - (ValueName='true') or (ValueName='false') or (ValueName='null') then - VariantLoadJSON(result,ValueName,@JSON_OPTIONS[true]) else begin - GetValueFromContext(ValueName,tmp); - SetVariantByValue(variant(tmp),result); // copy value - end; -end; - -function TSynMustacheContextVariant.GetValueFromContext( - const ValueName: RawUTF8; var Value: TVarData): TSynMustacheSectionType; -var i,space,helper: Integer; - - procedure ProcessHelper; - var valnam: RawUTF8; - val: TVarData; - valArr: TDocVariantData absolute val; - valFree: boolean; - names: TRawUTF8DynArray; - res: PVarData; - j,k,n: integer; - begin - valnam := Copy(ValueName,space+1,maxInt); - valFree := false; - if valnam<>'' then begin - if valnam='.' then - GetValueFromContext(valnam,val) else - if ((valnam<>'') and (valnam[1] in ['1'..'9','"','{','['])) or - (valnam='true') or (valnam='false') or (valnam='null') then begin - // {{helper 123}} or {{helper "constant"}} or {{helper [1,2,3]}} - val.VType := varEmpty; - VariantLoadJson(variant(val),pointer(valnam),nil,@JSON_OPTIONS[true]); - valFree := true; - end else begin - for j := 1 to length(valnam) do - case valnam[j] of - ' ': break; // allows {{helper1 helper2 value}} recursive calls - ',': begin // {{helper value,123,"constant"}} - CSVToRawUTF8DynArray(Pointer(valnam),names,',',true); // TODO: handle 123,"a,b,c" - valArr.InitFast; - for k := 0 to High(names) do - valArr.AddItem(GetValueCopyFromContext(names[k])); - valFree := true; - break; - end; - '<','>','=': begin // {{#if .=123}} -> {{#if .,"=",123}} - k := j+1; - if valnam[k] in ['=','>'] then - inc(k); - valArr.InitArray([GetValueCopyFromContext(Copy(valnam,1,j-1)), - Copy(valnam,j,k-j),GetValueCopyFromContext(Copy(valnam,k,maxInt))],JSON_OPTIONS[true]); - valFree := true; - break; - end; - end; - if not valFree then - GetValueFromContext(valnam,val); - end; - end; - n := fContextCount+4; - if length(fTempGetValueFromContextHelper)0 then - Value := ListCurrentDocument else - Value := Document; - exit; - end; - space := PosExChar(' ',ValueName); - if space>1 then begin // {{helper value}} - helper := TSynMustache.HelperFind(Helpers,pointer(ValueName),space-1); - if helper>=0 then begin - ProcessHelper; - exit; - end; // if helper not found, will return the unprocessed value - end; - for i := fContextCount-1 downto 0 do // recursive search of {{value}} - with fContext[i] do - if DocumentType<>nil then - if ListCount<0 then begin // single item context - DocumentType.Lookup(Value,Document,pointer(ValueName)); - if Value.VType>=varNull then - exit; - end else - if IdemPChar(pointer(ValueName),'-INDEX') then begin // {{-index}} - Value.VType := varInteger; - if ValueName[7]='0' then - Value.VInteger := ListCurrent else - Value.VInteger := ListCurrent+1; - exit; - end else - if (ListCurrentnil) then begin - ListCurrentDocumentType.Lookup(Value,ListCurrentDocument,pointer(ValueName)); - if Value.VType>=varNull then - exit; - end; - if space=0 then begin - space := length(ValueName); // {{helper}} - helper := TSynMustache.HelperFind(Helpers,pointer(ValueName),space); - if helper>=0 then - ProcessHelper; - end; -end; - -procedure TSynMustacheContextVariant.AppendValue(const ValueName: RawUTF8; - UnEscape: boolean); -var Value: TVarData; -begin - GetValueFromContext(ValueName,Value); - AppendVariant(variant(Value),UnEscape); -end; - -procedure TSynMustacheContextVariant.AppendVariant(const Value: variant; - UnEscape: boolean); -var ValueText: RawUTF8; - wasString: boolean; -begin - if TVarData(Value).VType>varNull then - if VarIsNumeric(Value) then // avoid RawUTF8 conversion for plain numbers - fWriter.AddVariant(Value,twNone) else begin - if fEscapeInvert then - UnEscape := not UnEscape; - VariantToUTF8(Value,ValueText,wasString); - if UnEscape then - fWriter.AddNoJSONEscape(pointer(ValueText),length(ValueText)) else - fWriter.AddHtmlEscape(pointer(ValueText)); - end; -end; - -function TSynMustacheContextVariant.AppendSection( - const ValueName: RawUTF8): TSynMustacheSectionType; -var Value: TVarData; -begin - result := msNothing; - if (fContextCount>0) and (ValueName[1]='-') then - with fContext[fContextCount-1] do - if ListCount>=0 then begin - if ((ValueName='-first') and (ListCurrent=0)) or - ((ValueName='-last') and (ListCurrent=ListCount-1)) or - ((ValueName='-odd') and (ListCurrent and 1=0)) then - result := msSinglePseudo; - exit; - end; - result := GetValueFromContext(ValueName,Value); - if result<>msNothing then begin - if (Value.VType<=varNull) or - ((Value.VType=varBoolean) and not Value.VBoolean) then - result := msNothing; - exit; - end; - PushContext(Value); - if (Value.VType<=varNull) or - ((Value.VType=varBoolean) and not Value.VBoolean) then - exit; // null or false value will not display the section - with fContext[fContextCount-1] do - if ListCount<0 then - result := msSingle else // single item - if ListCount=0 then // empty list will not display the section - exit else - result := msList; // non-empty list -end; - -function TSynMustacheContextVariant.GotoNextListItem: boolean; -begin - result := false; - if fContextCount>0 then - with fContext[fContextCount-1] do begin - ListCurrentDocument.VType := varEmpty; - ListCurrentDocumentType := nil; - inc(ListCurrent); - if ListCurrent>=ListCount then - exit; - DocumentType.Iterate(ListCurrentDocument,Document,ListCurrent); - ListCurrentDocumentType := GetDocumentType(ListCurrentDocument); - result := true; - end; -end; - - -{ TSynMustachePartials } - -constructor TSynMustachePartials.Create; -begin - fList := TRawUTF8List.Create([fNoDuplicate,fCaseSensitive]); -end; - -constructor TSynMustachePartials.CreateOwned(const NameTemplatePairs: array of RawUTF8); -var A: integer; -begin - Create; - fOwned := true; - for A := 0 to high(NameTemplatePairs) div 2 do - Add(NameTemplatePairs[A*2],NameTemplatePairs[A*2+1]); -end; - -function TSynMustachePartials.Add(const aName, aTemplate: RawUTF8): TSynMustache; -begin - result := TSynMustache.Parse(aTemplate); - if (result<>nil) and (fList.AddObject(aName,result)<0) then - raise ESynMustache.CreateUTF8('%.Add(%) duplicated name',[self,aName]); -end; - -function TSynMustachePartials.Add(const aName: RawUTF8; - aTemplateStart, aTemplateEnd: PUTF8Char): TSynMustache; -var aTemplate: RawUTF8; -begin - FastSetString(aTemplate,aTemplateStart,aTemplateEnd-aTemplateStart); - result := Add(aName,aTemplate); -end; - -function TSynMustachePartials.FoundInTemplate(const text: RawUTF8): PtrInt; -begin - if self<>nil then - result := fList.Contains(text) else - result := -1; -end; - -class function TSynMustachePartials.CreateOwned(const Partials: variant): TSynMustachePartials; -var p: integer; -begin - result := nil; - if DocVariantType.IsOfType(Partials) then - with TDocVariantData(partials) do - if (Kind=dvObject) and (Count>0) then begin - result := TSynMustachePartials.Create; - result.fOwned := true; - for p := 0 to Count-1 do - result.Add(Names[p],VariantToUTF8(Values[p])); - end; -end; - -destructor TSynMustachePartials.Destroy; -begin - FreeAndNil(fList); - inherited; -end; - -function TSynMustachePartials.GetPartial(const PartialName: RawUTF8): TSynMustache; -var i: integer; -begin - if self=nil then begin - result := nil; - exit; - end; - i := fList.IndexOf(PartialName); // using O(1) hashing - if i<0 then - result := nil else - result := TSynMustache(fList.Objects[i]); -end; - -end. diff --git a/lib/dmustache/SynTable.pas b/lib/dmustache/SynTable.pas deleted file mode 100644 index 77797306..00000000 --- a/lib/dmustache/SynTable.pas +++ /dev/null @@ -1,18530 +0,0 @@ -/// filter/database/cache/buffer/security/search/multithread/OS features -// - as a complement to SynCommons, which tended to increase too much -// - licensed under a MPL/GPL/LGPL tri-license; version 1.18 -unit SynTable; - -(* - This file is part of Synopse framework. - - Synopse framework. Copyright (C) 2022 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) 2022 - the Initial Developer. All Rights Reserved. - - Contributor(s): - - Alternatively, the contents of this file may be used under the terms of - either the GNU General Public License Version 2 or later (the "GPL"), or - the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), - in which case the provisions of the GPL or the LGPL are applicable instead - of those above. If you wish to allow use of your version of this file only - under the terms of either the GPL or the LGPL, and not to allow others to - use your version of this file under the terms of the MPL, indicate your - decision by deleting the provisions above and replace them with the notice - and other provisions required by the GPL or the LGPL. If you do not delete - the provisions above, a recipient may use your version of this file under - the terms of any one of the MPL, the GPL or the LGPL. - - ***** END LICENSE BLOCK ***** - - - A lot of code has moved from SynCommons.pas and mORMot.pas, to reduce the - number of source code lines of those units, and circumvent Delphi 5/6/7 - limitations (e.g. internal error PRO-3006) - -*) - -interface - -{$I Synopse.inc} // define HASINLINE CPU32 CPU64 - -uses - {$ifdef MSWINDOWS} - Windows, - Messages, - {$else} - {$ifdef KYLIX3} - Types, - LibC, - SynKylix, - {$endif KYLIX3} - {$ifdef FPC} - BaseUnix, - Unix, - {$endif FPC} - {$endif MSWINDOWS} - SysUtils, - Classes, - {$ifndef LVCL} - SyncObjs, // for TEvent and TCriticalSection - Contnrs, // for TObjectList - {$endif} - {$ifndef NOVARIANTS} - Variants, - {$endif} - SynCommons; - - - -{ ************ text search and functions ****************** } - -type - PMatch = ^TMatch; - TMatchSearchFunction = function(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; - - /// low-level structure used by IsMatch() for actual glob search - // - you can use this object to prepare a given pattern, e.g. in a loop - // - implemented as a fast brute-force state-machine without any heap allocation - // - some common patterns ('exactmatch', 'startwith*', '*endwith', '*contained*') - // are handled with dedicated code, optionally with case-insensitive search - // - consider using TMatchs (or SetMatchs/TMatchDynArray) if you expect to - // search for several patterns, or even TExprParserMatch for expression search - {$ifdef USERECORDWITHMETHODS}TMatch = record - {$else}TMatch = object{$endif} - private - Pattern, Text: PUTF8Char; - P, T, PMax, TMax: PtrInt; - Upper: PNormTable; - State: (sNONE, sABORT, sEND, sLITERAL, sPATTERN, sRANGE, sVALID); - procedure MatchAfterStar; - procedure MatchMain; - public - /// published for proper inlining - Search: TMatchSearchFunction; - /// initialize the internal fields for a given glob search pattern - // - note that the aPattern instance should remain in memory, since it will - // be pointed to by the Pattern private field of this object - procedure Prepare(const aPattern: RawUTF8; aCaseInsensitive, aReuse: boolean); overload; - /// initialize the internal fields for a given glob search pattern - // - note that the aPattern buffer should remain in memory, since it will - // be pointed to by the Pattern private field of this object - procedure Prepare(aPattern: PUTF8Char; aPatternLen: integer; - aCaseInsensitive, aReuse: boolean); overload; - /// initialize low-level internal fields for'*aPattern*' search - // - this method is faster than a regular Prepare('*' + aPattern + '*') - // - warning: the supplied aPattern variable may be modified in-place to be - // filled with some lookup buffer, for length(aPattern) in [2..31] range - procedure PrepareContains(var aPattern: RawUTF8; aCaseInsensitive: boolean); overload; - /// initialize low-level internal fields for a custom search algorithm - procedure PrepareRaw(aPattern: PUTF8Char; aPatternLen: integer; - aSearch: TMatchSearchFunction); - /// returns TRUE if the supplied content matches the prepared glob pattern - // - this method is not thread-safe - function Match(const aText: RawUTF8): boolean; overload; - {$ifdef FPC}inline;{$endif} - /// returns TRUE if the supplied content matches the prepared glob pattern - // - this method is not thread-safe - function Match(aText: PUTF8Char; aTextLen: PtrInt): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - /// returns TRUE if the supplied content matches the prepared glob pattern - // - this method IS thread-safe, and won't lock - function MatchThreadSafe(const aText: RawUTF8): boolean; - /// returns TRUE if the supplied VCL/LCL content matches the prepared glob pattern - // - this method IS thread-safe, will use stack to UTF-8 temporary conversion - // if possible, and won't lock - function MatchString(const aText: string): boolean; - /// returns TRUE if this search pattern matches another - function Equals(const aAnother{$ifndef DELPHI5OROLDER}: TMatch{$endif}): boolean; - {$ifdef HASINLINE}inline;{$endif} - /// access to the pattern length as stored in PMax + 1 - function PatternLength: integer; {$ifdef HASINLINE}inline;{$endif} - /// access to the pattern text as stored in Pattern - function PatternText: PUTF8Char; {$ifdef HASINLINE}inline;{$endif} - end; - /// use SetMatchs() to initialize such an array from a CSV pattern text - TMatchDynArray = array of TMatch; - - /// TMatch descendant owning a copy of the Pattern string to avoid GPF issues - TMatchStore = record - /// access to the research criteria - // - defined as a nested record (and not an object) to circumvent Delphi bug - Pattern: TMatch; - /// Pattern.Pattern PUTF8Char will point to this instance - PatternInstance: RawUTF8; - end; - TMatchStoreDynArray = array of TMatchStore; - - /// stores several TMatch instances, from a set of glob patterns - TMatchs = class(TSynPersistent) - protected - fMatch: TMatchStoreDynArray; - fMatchCount: integer; - public - /// add once some glob patterns to the internal TMach list - // - aPatterns[] follows the IsMatch() syntax - constructor Create(const aPatterns: TRawUTF8DynArray; CaseInsensitive: Boolean); reintroduce; overload; - /// add once some glob patterns to the internal TMach list - // - aPatterns[] follows the IsMatch() syntax - procedure Subscribe(const aPatterns: TRawUTF8DynArray; CaseInsensitive: Boolean); overload; virtual; - /// add once some glob patterns to the internal TMach list - // - each CSV item in aPatterns follows the IsMatch() syntax - procedure Subscribe(const aPatternsCSV: RawUTF8; CaseInsensitive: Boolean); overload; - /// search patterns in the supplied UTF-8 text - // - returns -1 if no filter has been subscribed - // - returns -2 if there is no match on any previous pattern subscription - // - returns fMatch[] index, i.e. >= 0 number on first matching pattern - // - this method is thread-safe - function Match(const aText: RawUTF8): integer; overload; {$ifdef HASINLINE}inline;{$endif} - /// search patterns in the supplied UTF-8 text buffer - function Match(aText: PUTF8Char; aLen: integer): integer; overload; - /// search patterns in the supplied VCL/LCL text - // - could be used on a TFileName for instance - // - will avoid any memory allocation if aText is small enough - function MatchString(const aText: string): integer; - end; - -/// fill the Match[] dynamic array with all glob patterns supplied as CSV -// - returns how many patterns have been set in Match[|] -// - note that the CSVPattern instance should remain in memory, since it will -// be pointed to by the Match[].Pattern private field -function SetMatchs(const CSVPattern: RawUTF8; CaseInsensitive: boolean; - out Match: TMatchDynArray): integer; overload; - -/// fill the Match[0..MatchMax] static array with all glob patterns supplied as CSV -// - note that the CSVPattern instance should remain in memory, since it will -// be pointed to by the Match[].Pattern private field -function SetMatchs(CSVPattern: PUTF8Char; CaseInsensitive: boolean; - Match: PMatch; MatchMax: integer): integer; overload; - -/// search if one TMach is already registered in the Several[] dynamic array -function MatchExists(const One: TMatch; const Several: TMatchDynArray): boolean; - -/// add one TMach if not already registered in the Several[] dynamic array -function MatchAdd(const One: TMatch; var Several: TMatchDynArray): boolean; - -/// returns TRUE if Match=nil or if any Match[].Match(Text) is TRUE -function MatchAny(const Match: TMatchDynArray; const Text: RawUTF8): boolean; - -/// apply the CSV-supplied glob patterns to an array of RawUTF8 -// - any text not maching the pattern will be deleted from the array -procedure FilterMatchs(const CSVPattern: RawUTF8; CaseInsensitive: boolean; - var Values: TRawUTF8DynArray); - -/// return TRUE if the supplied content matchs a glob pattern -// - ? Matches any single characer -// - * Matches any contiguous characters -// - [abc] Matches a or b or c at that position -// - [^abc] Matches anything but a or b or c at that position -// - [!abc] Matches anything but a or b or c at that position -// - [a-e] Matches a through e at that position -// - [abcx-z] Matches a or b or c or x or y or or z, as does [a-cx-z] -// - 'ma?ch.*' would match match.exe, mavch.dat, march.on, etc.. -// - 'this [e-n]s a [!zy]est' would match 'this is a test', but would not -// match 'this as a test' nor 'this is a zest' -// - consider using TMatch or TMatchs if you expect to reuse the pattern -function IsMatch(const Pattern, Text: RawUTF8; CaseInsensitive: boolean=false): boolean; - -/// return TRUE if the supplied content matchs a glob pattern, using VCL strings -// - is a wrapper around IsMatch() with fast UTF-8 conversion -function IsMatchString(const Pattern, Text: string; CaseInsensitive: boolean=false): boolean; - - -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 - TSynSoundEx = object - protected - 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; - -var - DoIsValidUTF8: function(source: PUTF8Char): Boolean; - DoIsValidUTF8Len: function(source: PUTF8Char; sourcelen: PtrInt): Boolean; - -/// returns TRUE if the supplied buffer has valid UTF-8 encoding -// - will stop when the buffer contains #0 -// - on Haswell AVX2 Intel/AMD CPUs, will use very efficient ASM -function IsValidUTF8(source: PUTF8Char): Boolean; overload; {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if the supplied buffer has valid UTF-8 encoding -// - will also refuse #0 characters within the buffer -// - on Haswell AVX2 Intel/AMD CPUs, will use very efficient ASM -function IsValidUTF8(source: PUTF8Char; sourcelen: PtrInt): Boolean; overload; {$ifdef HASINLINE}inline;{$endif} - -/// returns TRUE if the supplied buffer has valid UTF-8 encoding -// - will also refuse #0 characters within the buffer -// - on Haswell AVX2 Intel/AMD CPUs, will use very efficient ASM -function IsValidUTF8(const source: RawUTF8): Boolean; overload; - - - -{ ************ filtering and validation classes and functions ************** } - -/// 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} - -/// return TRUE if the supplied content is a valid email address -// - follows RFC 822, to validate local-part@domain email format -function IsValidEmail(P: PUTF8Char): boolean; - -/// return TRUE if the supplied content is a valid IP v4 address -function IsValidIP4Address(P: PUTF8Char): boolean; - - -type - TSynFilterOrValidate = class; - - TSynFilterOrValidateObjArray = array of TSynFilterOrValidate; - TSynFilterOrValidateObjArrayArray = array of TSynFilterOrValidateObjArray; - - /// will define a filter (transformation) or a validation process to be - // applied to a database Record content (typicaly a TSQLRecord) - // - the optional associated parameters are to be supplied JSON-encoded - TSynFilterOrValidate = class - protected - fParameters: RawUTF8; - /// children must override this method in order to parse the JSON-encoded - // parameters, and store it in protected field values - procedure SetParameters(const Value: RawUTF8); virtual; - public - /// add the filter or validation process to a list, checking if not present - // - if an instance with the same class type and parameters is already - // registered, will call aInstance.Free and return the exising instance - // - if there is no similar instance, will add it to the list and return it - function AddOnce(var aObjArray: TSynFilterOrValidateObjArray; - aFreeIfAlreadyThere: boolean=true): TSynFilterOrValidate; - public - /// initialize the filter (transformation) or validation instance - // - most of the time, optional parameters may be specified as JSON, - // possibly with the extended MongoDB syntax - constructor Create(const aParameters: RawUTF8=''); overload; virtual; - /// initialize the filter or validation instance - /// - this overloaded constructor will allow to easily set the parameters - constructor CreateUTF8(const Format: RawUTF8; const Args, Params: array of const); overload; - /// the optional associated parameters, supplied as JSON-encoded - property Parameters: RawUTF8 read fParameters write SetParameters; - end; - - /// will define a validation to be applied to a Record (typicaly a TSQLRecord) - // field content - // - a typical usage is to validate an email or IP adress e.g. - // - the optional associated parameters are to be supplied JSON-encoded - TSynValidate = class(TSynFilterOrValidate) - public - /// perform the validation action to the specified value - // - the value is expected by be UTF-8 text, as generated by - // TPropInfo.GetValue e.g. - // - if the validation failed, must return FALSE and put some message in - // ErrorMsg (translated into the current language: you could e.g. use - // a resourcestring and a SysUtils.Format() call for automatic translation - // via the mORMoti18n unit - you can leave ErrorMsg='' to trigger a - // generic error message from clas name ('"Validate email" rule failed' - // for TSynValidateEmail class e.g.) - // - if the validation passed, will return TRUE - function Process(FieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string): boolean; - virtual; abstract; - end; - - /// points to a TSynValidate variable - // - used e.g. as optional parameter to TSQLRecord.Validate/FilterAndValidate - PSynValidate = ^TSynValidate; - - /// IP v4 address validation to be applied to a Record field content - // (typicaly a TSQLRecord) - // - this versions expect no parameter - TSynValidateIPAddress = class(TSynValidate) - protected - public - /// perform the IP Address validation action to the specified value - function Process(aFieldIndex: integer; const Value: RawUTF8; - var ErrorMsg: string): boolean; override; - end; - - /// IP address validation to be applied to a Record field content - // (typicaly a TSQLRecord) - // - optional JSON encoded parameters are "AllowedTLD" or "ForbiddenTLD", - // expecting a CSV lis of Top-Level-Domain (TLD) names, e.g. - // $ '{"AllowedTLD":"com,org,net","ForbiddenTLD":"fr"}' - // $ '{AnyTLD:true,ForbiddenDomains:"mailinator.com,yopmail.com"}' - // - this will process a validation according to RFC 822 (calling the - // IsValidEmail() function) then will check for the TLD to be in one of - // the Top-Level domains ('.com' and such) or a two-char country, and - // then will check the TLD according to AllowedTLD and ForbiddenTLD - TSynValidateEmail = class(TSynValidate) - private - fAllowedTLD: RawUTF8; - fForbiddenTLD: RawUTF8; - fForbiddenDomains: RawUTF8; - fAnyTLD: boolean; - protected - /// decode all published properties from their JSON representation - procedure SetParameters(const Value: RawUTF8); override; - public - /// perform the Email Address validation action to the specified value - // - call IsValidEmail() function and check for the supplied TLD - function Process(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string): boolean; override; - /// allow any TLD to be allowed, even if not a generic TLD (.com,.net ...) - // - this may be mandatory since already over 1,300 new gTLD names or - // "strings" could become available in the next few years: there is a - // growing list of new gTLDs available at - // @http://newgtlds.icann.org/en/program-status/delegated-strings - // - the only restriction is that it should be ascii characters - property AnyTLD: boolean read fAnyTLD write fAnyTLD; - /// a CSV list of allowed TLD - // - if accessed directly, should be set as lower case values - // - e.g. 'com,org,net' - property AllowedTLD: RawUTF8 read fAllowedTLD write fAllowedTLD; - /// a CSV list of forbidden TLD - // - if accessed directly, should be set as lower case values - // - e.g. 'fr' - property ForbiddenTLD: RawUTF8 read fForbiddenTLD write fForbiddenTLD; - /// a CSV list of forbidden domain names - // - if accessed directly, should be set as lower case values - // - not only the TLD, but whole domains like 'cracks.ru,hotmail.com' or such - property ForbiddenDomains: RawUTF8 read fForbiddenDomains write fForbiddenDomains; - end; - - /// glob case-sensitive pattern validation of a Record field content - // - parameter is NOT JSON encoded, but is some basic TMatch glob pattern - // - ? Matches any single characer - // - * Matches any contiguous characters - // - [abc] Matches a or b or c at that position - // - [^abc] Matches anything but a or b or c at that position - // - [!abc] Matches anything but a or b or c at that position - // - [a-e] Matches a through e at that position - // - [abcx-z] Matches a or b or c or x or y or or z, as does [a-cx-z] - // - 'ma?ch.*' would match match.exe, mavch.dat, march.on, etc.. - // - 'this [e-n]s a [!zy]est' would match 'this is a test', but would not - // match 'this as a test' nor 'this is a zest' - // - pattern check IS case sensitive (TSynValidatePatternI is not) - // - this class is not as complete as PCRE regex for example, - // but code overhead is very small, and speed good enough in practice - TSynValidatePattern = class(TSynValidate) - protected - fMatch: TMatch; - procedure SetParameters(const Value: RawUTF8); override; - public - /// perform the pattern validation to the specified value - // - pattern can be e.g. '[0-9][0-9]:[0-9][0-9]:[0-9][0-9]' - // - this method will implement both TSynValidatePattern and - // TSynValidatePatternI, checking the current class - function Process(aFieldIndex: integer; const Value: RawUTF8; - var ErrorMsg: string): boolean; override; - end; - - /// glob case-insensitive pattern validation of a text field content - // (typicaly a TSQLRecord) - // - parameter is NOT JSON encoded, but is some basic TMatch glob pattern - // - same as TSynValidatePattern, but is NOT case sensitive - TSynValidatePatternI = class(TSynValidatePattern); - - /// text validation to ensure that to any text field would not be '' - TSynValidateNonVoidText = class(TSynValidate) - public - /// perform the non void text validation action to the specified value - function Process(aFieldIndex: integer; const Value: RawUTF8; - var ErrorMsg: string): boolean; override; - end; - - TSynValidateTextProps = array[0..15] of cardinal; - -{$M+} // to have existing RTTI for published properties - /// text validation to be applied to any Record field content - // - default MinLength value is 1, MaxLength is maxInt: so a blank - // TSynValidateText.Create('') is the same as TSynValidateNonVoidText - // - MinAlphaCount, MinDigitCount, MinPunctCount, MinLowerCount and - // MinUpperCount allow you to specify the minimal count of respectively - // alphabetical [a-zA-Z], digit [0-9], punctuation [_!;.,/:?%$="#@(){}+-*], - // lower case or upper case characters - // - expects optional JSON parameters of the allowed text length range as - // $ '{"MinLength":5,"MaxLength":10,"MinAlphaCount":1,"MinDigitCount":1, - // $ "MinPunctCount":1,"MinLowerCount":1,"MinUpperCount":1} - TSynValidateText = class(TSynValidate) - private - /// used to store all associated validation properties by index - fProps: TSynValidateTextProps; - fUTF8Length: boolean; - protected - /// use sInvalidTextChar resourcestring to create a translated error message - procedure SetErrorMsg(fPropsIndex, InvalidTextIndex, MainIndex: integer; - var result: string); - /// decode "MinLength", "MaxLength", and other parameters into fProps[] - procedure SetParameters(const Value: RawUTF8); override; - public - /// perform the text length validation action to the specified value - function Process(aFieldIndex: integer; const Value: RawUTF8; - var ErrorMsg: string): boolean; override; - published - /// Minimal length value allowed for the text content - // - the length is calculated with UTF-16 Unicode codepoints, unless - // UTF8Length has been set to TRUE so that the UTF-8 byte count is checked - // - default is 1, i.e. a void text will not pass the validation - property MinLength: cardinal read fProps[0] write fProps[0]; - /// Maximal length value allowed for the text content - // - the length is calculated with UTF-16 Unicode codepoints, unless - // UTF8Length has been set to TRUE so that the UTF-8 byte count is checked - // - default is maxInt, i.e. no maximum length is set - property MaxLength: cardinal read fProps[1] write fProps[1]; - /// Minimal alphabetical character [a-zA-Z] count - // - default is 0, i.e. no minimum set - property MinAlphaCount: cardinal read fProps[2] write fProps[2]; - /// Maximal alphabetical character [a-zA-Z] count - // - default is maxInt, i.e. no Maximum set - property MaxAlphaCount: cardinal read fProps[10] write fProps[10]; - /// Minimal digit character [0-9] count - // - default is 0, i.e. no minimum set - property MinDigitCount: cardinal read fProps[3] write fProps[3]; - /// Maximal digit character [0-9] count - // - default is maxInt, i.e. no Maximum set - property MaxDigitCount: cardinal read fProps[11] write fProps[11]; - /// Minimal punctuation sign [_!;.,/:?%$="#@(){}+-*] count - // - default is 0, i.e. no minimum set - property MinPunctCount: cardinal read fProps[4] write fProps[4]; - /// Maximal punctuation sign [_!;.,/:?%$="#@(){}+-*] count - // - default is maxInt, i.e. no Maximum set - property MaxPunctCount: cardinal read fProps[12] write fProps[12]; - /// Minimal alphabetical lower case character [a-z] count - // - default is 0, i.e. no minimum set - property MinLowerCount: cardinal read fProps[5] write fProps[5]; - /// Maximal alphabetical lower case character [a-z] count - // - default is maxInt, i.e. no Maximum set - property MaxLowerCount: cardinal read fProps[13] write fProps[13]; - /// Minimal alphabetical upper case character [A-Z] count - // - default is 0, i.e. no minimum set - property MinUpperCount: cardinal read fProps[6] write fProps[6]; - /// Maximal alphabetical upper case character [A-Z] count - // - default is maxInt, i.e. no Maximum set - property MaxUpperCount: cardinal read fProps[14] write fProps[14]; - /// Minimal space count inside the value text - // - default is 0, i.e. any space number allowed - property MinSpaceCount: cardinal read fProps[7] write fProps[7]; - /// Maximal space count inside the value text - // - default is maxInt, i.e. any space number allowed - property MaxSpaceCount: cardinal read fProps[15] write fProps[15]; - /// Maximal space count allowed on the Left side - // - default is maxInt, i.e. any Left space allowed - property MaxLeftTrimCount: cardinal read fProps[8] write fProps[8]; - /// Maximal space count allowed on the Right side - // - default is maxInt, i.e. any Right space allowed - property MaxRightTrimCount: cardinal read fProps[9] write fProps[9]; - /// defines if lengths parameters expects UTF-8 or UTF-16 codepoints number - // - with default FALSE, the length is calculated with UTF-16 Unicode - // codepoints - MaxLength may not match the UCS4 glyphs number, in case of - // UTF-16 surrogates - // - you can set this property to TRUE so that the UTF-8 byte count would - // be used for truncation againts the MaxLength parameter - property UTF8Length: boolean read fUTF8Length write fUTF8Length; - end; -{$M-} - - /// strong password validation for a Record field content (typicaly a TSQLRecord) - // - the following parameters are set by default to - // $ '{"MinLength":5,"MaxLength":20,"MinAlphaCount":1,"MinDigitCount":1, - // $ "MinPunctCount":1,"MinLowerCount":1,"MinUpperCount":1,"MaxSpaceCount":0}' - // - you can specify some JSON encoded parameters to change this default - // values, which will validate the text field only if it contains from 5 to 10 - // characters, with at least one digit, one upper case letter, one lower case - // letter, and one ponctuation sign, with no space allowed inside - TSynValidatePassWord = class(TSynValidateText) - protected - /// set password specific parameters - procedure SetParameters(const Value: RawUTF8); override; - end; - - { C++Builder doesn't support array elements as properties (RSP-12595). - For now, simply exclude the relevant classes from C++Builder. } - {$NODEFINE TSynValidateTextProps} - {$NODEFINE TSynValidateText } - {$NODEFINE TSynValidatePassWord } - - /// will define a transformation to be applied to a Record field content - // (typicaly a TSQLRecord) - // - here "filter" means that content would be transformed according to a - // set of defined rules - // - a typical usage is to convert to lower or upper case, or - // trim any time or date value in a TDateTime field - // - the optional associated parameters are to be supplied JSON-encoded - TSynFilter = class(TSynFilterOrValidate) - protected - public - /// perform the transformation to the specified value - // - the value is converted into UTF-8 text, as expected by - // TPropInfo.GetValue / TPropInfo.SetValue e.g. - procedure Process(aFieldIndex: integer; var Value: RawUTF8); virtual; abstract; - end; - - /// class-refrence type (metaclass) for a TSynFilter or a TSynValidate - TSynFilterOrValidateClass = class of TSynFilterOrValidate; - - /// class-reference type (metaclass) of a record filter (transformation) - TSynFilterClass = class of TSynFilter; - - /// convert the value into ASCII Upper Case characters - // - UpperCase conversion is made for ASCII-7 only, i.e. 'a'..'z' characters - // - this version expects no parameter - TSynFilterUpperCase = class(TSynFilter) - public - /// perform the case conversion to the specified value - procedure Process(aFieldIndex: integer; var Value: RawUTF8); override; - end; - - /// convert the value into WinAnsi Upper Case characters - // - UpperCase conversion is made for all latin characters in the WinAnsi - // code page only, e.g. 'e' acute will be converted to 'E' - // - this version expects no parameter - TSynFilterUpperCaseU = class(TSynFilter) - public - /// perform the case conversion to the specified value - procedure Process(aFieldIndex: integer; var Value: RawUTF8); override; - end; - - /// convert the value into ASCII Lower Case characters - // - LowerCase conversion is made for ASCII-7 only, i.e. 'A'..'Z' characters - // - this version expects no parameter - TSynFilterLowerCase = class(TSynFilter) - public - /// perform the case conversion to the specified value - procedure Process(aFieldIndex: integer; var Value: RawUTF8); override; - end; - - /// convert the value into WinAnsi Lower Case characters - // - LowerCase conversion is made for all latin characters in the WinAnsi - // code page only, e.g. 'E' acute will be converted to 'e' - // - this version expects no parameter - TSynFilterLowerCaseU = class(TSynFilter) - public - /// perform the case conversion to the specified value - procedure Process(aFieldIndex: integer; var Value: RawUTF8); override; - end; - - /// trim any space character left or right to the value - // - this versions expect no parameter - TSynFilterTrim = class(TSynFilter) - public - /// perform the space triming conversion to the specified value - procedure Process(aFieldIndex: integer; var Value: RawUTF8); override; - end; - - /// truncate a text above a given maximum length - // - expects optional JSON parameters of the allowed text length range as - // $ '{MaxLength":10} - TSynFilterTruncate = class(TSynFilter) - protected - fMaxLength: cardinal; - fUTF8Length: boolean; - /// decode the MaxLength: and UTF8Length: parameters - procedure SetParameters(const Value: RawUTF8); override; - public - /// perform the length truncation of the specified value - procedure Process(aFieldIndex: integer; var Value: RawUTF8); override; - /// Maximal length value allowed for the text content - // - the length is calculated with UTF-16 Unicode codepoints, unless - // UTF8Length has been set to TRUE so that the UTF-8 byte count is checked - // - default is 0, i.e. no maximum length is forced - property MaxLength: cardinal read fMaxLength write fMaxLength; - /// defines if MaxLength is stored as UTF-8 or UTF-16 codepoints number - // - with default FALSE, the length is calculated with UTF-16 Unicode - // codepoints - MaxLength may not match the UCS4 glyphs number, in case of - // UTF-16 surrogates - // - you can set this property to TRUE so that the UTF-8 byte count would - // be used for truncation againts the MaxLength parameter - property UTF8Length: boolean read fUTF8Length write fUTF8Length; - end; - -resourcestring - sInvalidIPAddress = '"%s" is an invalid IP v4 address'; - sInvalidEmailAddress = '"%s" is an invalid email address'; - sInvalidPattern = '"%s" does not match the expected pattern'; - sCharacter01n = 'character,character,characters'; - sInvalidTextLengthMin = 'Expect at least %d %s'; - sInvalidTextLengthMax = 'Expect up to %d %s'; - sInvalidTextChar = 'Expect at least %d %s %s,Expect up to %d %s %s,'+ - 'alphabetical,digital,punctuation,lowercase,uppercase,space,'+ - 'Too much spaces on the left,Too much spaces on the right'; - sValidationFailed = '"%s" rule failed'; - sValidationFieldVoid = 'An unique key field must not be void'; - sValidationFieldDuplicate = 'Value already used for this unique key field'; - - -{ ************ Database types and classes ************************** } - -type - /// handled field/parameter/column types for abstract database access - // - this will map JSON-compatible low-level database-level access types, not - // high-level Delphi types as TSQLFieldType defined in mORMot.pas - // - it does not map either all potential types as defined in DB.pas (which - // are there for compatibility with old RDBMS, and are not abstract enough) - // - those types can be mapped to standard SQLite3 generic types, i.e. - // NULL, INTEGER, REAL, TEXT, BLOB (with the addition of a ftCurrency and - // ftDate type, for better support of most DB engines) - // see @http://www.sqlite.org/datatype3.html - // - the only string type handled here uses UTF-8 encoding (implemented - // using our RawUTF8 type), for cross-Delphi true Unicode process - TSQLDBFieldType = - (ftUnknown, ftNull, ftInt64, ftDouble, ftCurrency, ftDate, ftUTF8, ftBlob); - - /// set of field/parameter/column types for abstract database access - TSQLDBFieldTypes = set of TSQLDBFieldType; - - /// array of field/parameter/column types for abstract database access - TSQLDBFieldTypeDynArray = array of TSQLDBFieldType; - - /// array of field/parameter/column types for abstract database access - // - this array as a fixed size, ready to handle up to MAX_SQLFIELDS items - TSQLDBFieldTypeArray = array[0..MAX_SQLFIELDS-1] of TSQLDBFieldType; - PSQLDBFieldTypeArray = ^TSQLDBFieldTypeArray; - - /// how TSQLVar may be processed - // - by default, ftDate will use seconds resolution unless svoDateWithMS is set - TSQLVarOption = (svoDateWithMS); - - /// defines how TSQLVar may be processed - TSQLVarOptions = set of TSQLVarOption; - - /// memory structure used for database values by reference storage - // - used mainly by SynDB, mORMot, mORMotDB and mORMotSQLite3 units - // - defines only TSQLDBFieldType data types (similar to those handled by - // SQLite3, with the addition of ftCurrency and ftDate) - // - cleaner/lighter dedicated type than TValue or variant/TVarData, strong - // enough to be marshalled as JSON content - // - variable-length data (e.g. UTF-8 text or binary BLOB) are never stored - // within this record, but VText/VBlob will point to an external (temporary) - // memory buffer - // - date/time is stored as ISO-8601 text (with milliseconds if svoDateWithMS - // option is set and the database supports it), and currency as double or BCD - // in most databases - TSQLVar = record - /// how this value should be processed - Options: TSQLVarOptions; - /// the type of the value stored - case VType: TSQLDBFieldType of - ftInt64: ( - VInt64: Int64); - ftDouble: ( - VDouble: double); - ftDate: ( - VDateTime: TDateTime); - ftCurrency: ( - VCurrency: Currency); - ftUTF8: ( - VText: PUTF8Char); - ftBlob: ( - VBlob: pointer; - VBlobLen: Integer) - end; - - /// dynamic array of database values by reference storage - TSQLVarDynArray = array of TSQLVar; - - /// used to store bit set for all available fields in a Table - // - with current MAX_SQLFIELDS value, 64 bits uses 8 bytes of memory - // - see also IsZero() and IsEqual() functions - // - you can also use ALL_FIELDS as defined in mORMot.pas - TSQLFieldBits = set of 0..MAX_SQLFIELDS-1; - - /// used to store a field index in a Table - // - note that -1 is commonly used for the ID/RowID field so the values should - // be signed - // - even if ShortInt (-128..127) may have been enough, we define a 16 bit - // safe unsigned integer to let the source compile with Delphi 5 - TSQLFieldIndex = SmallInt; // -32768..32767 - - /// used to store field indexes in a Table - // - same as TSQLFieldBits, but allowing to store the proper order - TSQLFieldIndexDynArray = array of TSQLFieldIndex; - - /// points to a bit set used for all available fields in a Table - PSQLFieldBits = ^TSQLFieldBits; - - /// generic parameter types, as recognized by SQLParamContent() and - // ExtractInlineParameters() functions - TSQLParamType = (sptUnknown, sptInteger, sptFloat, sptText, sptBlob, sptDateTime); - - /// array of parameter types, as recognized by SQLParamContent() and - // ExtractInlineParameters() functions - TSQLParamTypeDynArray = array of TSQLParamType; - - /// simple writer to a Stream, specialized for the JSON format and SQL export - // - i.e. define some property/method helpers to export SQL resultset as JSON - // - see mORMot.pas for proper class serialization via TJSONSerializer.WriteObject - TJSONWriter = class(TTextWriterWithEcho) - protected - /// used to store output format - fExpand: boolean; - /// used to store output format for TSQLRecord.GetJSONValues() - fWithID: boolean; - /// used to store field for TSQLRecord.GetJSONValues() - fFields: TSQLFieldIndexDynArray; - /// if not Expanded format, contains the Stream position of the first - // useful Row of data; i.e. ',val11' position in: - // & { "fieldCount":1,"values":["col1","col2",val11,"val12",val21,..] } - fStartDataPosition: integer; - public - /// used internally to store column names and count for AddColumns - ColNames: TRawUTF8DynArray; - /// the data will be written to the specified Stream - // - if no Stream is supplied, a temporary memory stream will be created - // (it's faster to supply one, e.g. any TSQLRest.TempMemoryStream) - constructor Create(aStream: TStream; Expand, withID: boolean; - const Fields: TSQLFieldBits; aBufSize: integer=8192); overload; - /// the data will be written to the specified Stream - // - if no Stream is supplied, a temporary memory stream will be created - // (it's faster to supply one, e.g. any TSQLRest.TempMemoryStream) - constructor Create(aStream: TStream; Expand, withID: boolean; - const Fields: TSQLFieldIndexDynArray=nil; aBufSize: integer=8192; - aStackBuffer: PTextWriterStackBuffer=nil); overload; - /// rewind the Stream position and write void JSON object - procedure CancelAllVoid; - /// write or init field names for appropriate JSON Expand later use - // - ColNames[] must have been initialized before calling this procedure - // - if aKnownRowsCount is not null, a "rowCount":... item will be added - // to the generated JSON stream (for faster unserialization of huge content) - procedure AddColumns(aKnownRowsCount: integer=0); - /// allow to change on the fly an expanded format column layout - // - by definition, a non expanded format will raise a ESynException - // - caller should then set ColNames[] and run AddColumns() - procedure ChangeExpandedFields(aWithID: boolean; const aFields: TSQLFieldIndexDynArray); overload; - /// end the serialized JSON object - // - cancel last ',' - // - close the JSON object ']' or ']}' - // - write non expanded postlog (,"rowcount":...), if needed - // - flush the internal buffer content if aFlushFinal=true - procedure EndJSONObject(aKnownRowsCount,aRowsCount: integer; aFlushFinal: boolean=true); - {$ifdef HASINLINE}inline;{$endif} - /// the first data row is erased from the content - // - only works if the associated storage stream is TMemoryStream - // - expect not Expanded format - procedure TrimFirstRow; - /// is set to TRUE in case of Expanded format - property Expand: boolean read fExpand write fExpand; - /// is set to TRUE if the ID field must be appended to the resulting JSON - // - this field is used only by TSQLRecord.GetJSONValues - // - this field is ignored by TSQLTable.GetJSONValues - property WithID: boolean read fWithID; - /// Read-Only access to the field bits set for each column to be stored - property Fields: TSQLFieldIndexDynArray read fFields; - /// if not Expanded format, contains the Stream position of the first - // useful Row of data; i.e. ',val11' position in: - // & { "fieldCount":1,"values":["col1","col2",val11,"val12",val21,..] } - property StartDataPosition: integer read fStartDataPosition; - end; - -/// returns TRUE if no bit inside this TSQLFieldBits is set -// - is optimized for 64, 128, 192 and 256 max bits count (i.e. MAX_SQLFIELDS) -// - will work also with any other value -function IsZero(const Fields: TSQLFieldBits): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast comparison of two TSQLFieldBits values -// - is optimized for 64, 128, 192 and 256 max bits count (i.e. MAX_SQLFIELDS) -// - will work also with any other value -function IsEqual(const A,B: TSQLFieldBits): boolean; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// fast initialize a TSQLFieldBits with 0 -// - is optimized for 64, 128, 192 and 256 max bits count (i.e. MAX_SQLFIELDS) -// - will work also with any other value -procedure FillZero(var Fields: TSQLFieldBits); overload; - {$ifdef HASINLINE}inline;{$endif} - -/// convert a TSQLFieldBits set of bits into an array of integers -procedure FieldBitsToIndex(const Fields: TSQLFieldBits; - var Index: TSQLFieldIndexDynArray; MaxLength: integer=MAX_SQLFIELDS; - IndexStart: integer=0); overload; - -/// convert a TSQLFieldBits set of bits into an array of integers -function FieldBitsToIndex(const Fields: TSQLFieldBits; - MaxLength: integer=MAX_SQLFIELDS): TSQLFieldIndexDynArray; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// add a field index to an array of field indexes -// - returns the index in Indexes[] of the newly appended Field value -function AddFieldIndex(var Indexes: TSQLFieldIndexDynArray; Field: integer): integer; - -/// convert an array of field indexes into a TSQLFieldBits set of bits -procedure FieldIndexToBits(const Index: TSQLFieldIndexDynArray; var Fields: TSQLFieldBits); overload; - -// search a field index in an array of field indexes -// - returns the index in Indexes[] of the given Field value, -1 if not found -function SearchFieldIndex(var Indexes: TSQLFieldIndexDynArray; Field: integer): integer; - -/// convert an array of field indexes into a TSQLFieldBits set of bits -function FieldIndexToBits(const Index: TSQLFieldIndexDynArray): TSQLFieldBits; overload; - {$ifdef HASINLINE}inline;{$endif} - -/// returns the stored size of a TSQLVar database value -// - only returns VBlobLen / StrLen(VText) size, 0 otherwise -function SQLVarLength(const Value: TSQLVar): integer; - -{$ifndef NOVARIANTS} - -/// convert any Variant into a database value -// - ftBlob kind won't be handled by this function -// - complex variant types would be converted into ftUTF8 JSON object/array -procedure VariantToSQLVar(const Input: variant; var temp: RawByteString; - var Output: TSQLVar); - -/// guess the correct TSQLDBFieldType from a variant type -function VariantVTypeToSQLDBFieldType(VType: cardinal): TSQLDBFieldType; - -/// guess the correct TSQLDBFieldType from a variant value -function VariantTypeToSQLDBFieldType(const V: Variant): TSQLDBFieldType; - {$ifdef HASINLINE}inline;{$endif} - -/// guess the correct TSQLDBFieldType from the UTF-8 representation of a value -function TextToSQLDBFieldType(json: PUTF8Char): TSQLDBFieldType; - -type - /// define a variant published property as a nullable integer - // - either a varNull or a varInt64 value will be stored in the variant - // - either a NULL or an INTEGER value will be stored in the database - // - the property should be defined as such: - // ! property Int: TNullableInteger read fInt write fInt; - TNullableInteger = type variant; - /// define a variant published property as a nullable boolean - // - either a varNull or a varBoolean value will be stored in the variant - // - either a NULL or a 0/1 INTEGER value will be stored in the database - // - the property should be defined as such: - // ! property Bool: TNullableBoolean read fBool write fBool; - TNullableBoolean = type variant; - /// define a variant published property as a nullable floating point value - // - either a varNull or a varDouble value will be stored in the variant - // - either a NULL or a FLOAT value will be stored in the database - // - the property should be defined as such: - // ! property Flt: TNullableFloat read fFlt write fFlt; - TNullableFloat = type variant; - /// define a variant published property as a nullable decimal value - // - either a varNull or a varCurrency value will be stored in the variant - // - either a NULL or a FLOAT value will be stored in the database - // - the property should be defined as such: - // ! property Cur: TNullableCurrency read fCur write fCur; - TNullableCurrency = type variant; - /// define a variant published property as a nullable date/time value - // - either a varNull or a varDate value will be stored in the variant - // - either a NULL or a ISO-8601 TEXT value will be stored in the database - // - the property should be defined as such: - // ! property Dat: TNullableDateTime read fDat write fDat; - TNullableDateTime = type variant; - /// define a variant published property as a nullable timestamp value - // - either a varNull or a varInt64 value will be stored in the variant - // - either a NULL or a TTimeLog INTEGER value will be stored in the database - // - the property should be defined as such: - // ! property Tim: TNullableTimrency read fTim write fTim; - TNullableTimeLog = type variant; - /// define a variant published property as a nullable UTF-8 encoded text - // - either a varNull or varString (RawUTF8) will be stored in the variant - // - either a NULL or a TEXT value will be stored in the database - // - the property should be defined as such: - // ! property Txt: TNullableUTF8Text read fTxt write fTxt; - // or for a fixed-width VARCHAR (in external databases), here of 32 max chars: - // ! property Txt: TNullableUTF8Text index 32 read fTxt write fTxt; - // - warning: prior to Delphi 2009, since the variant will be stored as - // RawUTF8 internally, you should not use directly the field value as a - // VCL string=AnsiString like string(aField) but use VariantToString(aField) - TNullableUTF8Text = type variant; - -var - /// a nullable integer value containing null - NullableIntegerNull: TNullableInteger absolute NullVarData; - /// a nullable boolean value containing null - NullableBooleanNull: TNullableBoolean absolute NullVarData; - /// a nullable float value containing null - NullableFloatNull: TNullableFloat absolute NullVarData; - /// a nullable currency value containing null - NullableCurrencyNull: TNullableCurrency absolute NullVarData; - /// a nullable TDateTime value containing null - NullableDateTimeNull: TNullableDateTime absolute NullVarData; - /// a nullable TTimeLog value containing null - NullableTimeLogNull: TNullableTimeLog absolute NullVarData; - /// a nullable UTF-8 encoded text value containing null - NullableUTF8TextNull: TNullableUTF8Text absolute NullVarData; - -/// creates a nullable integer value from a supplied constant -// - FPC does not allow direct assignment to a TNullableInteger = type variant -// variable: use this function to circumvent it -function NullableInteger(const Value: Int64): TNullableInteger; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow -// direct transtyping from a TNullableInteger = type variant variable: use this -// function to circumvent those limitations -function NullableIntegerIsEmptyOrNull(const V: TNullableInteger): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableInteger is null, or return its value -// - returns FALSE if V is null or empty, or TRUE and set the Integer value -function NullableIntegerToValue(const V: TNullableInteger; out Value: Int64): Boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableInteger is null, or return its value -// - returns 0 if V is null or empty, or the stored Integer value -function NullableIntegerToValue(const V: TNullableInteger): Int64; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// creates a nullable Boolean value from a supplied constant -// - FPC does not allow direct assignment to a TNullableBoolean = type variant -// variable: use this function to circumvent it -function NullableBoolean(Value: boolean): TNullableBoolean; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow -// direct transtyping from a TNullableBoolean = type variant variant: use this -// function to circumvent those limitations -function NullableBooleanIsEmptyOrNull(const V: TNullableBoolean): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableBoolean is null, or return its value -// - returns FALSE if V is null or empty, or TRUE and set the Boolean value -function NullableBooleanToValue(const V: TNullableBoolean; out Value: Boolean): Boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableBoolean is null, or return its value -// - returns false if V is null or empty, or the stored Boolean value -function NullableBooleanToValue(const V: TNullableBoolean): Boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// creates a nullable floating-point value from a supplied constant -// - FPC does not allow direct assignment to a TNullableFloat = type variant -// variable: use this function to circumvent it -function NullableFloat(const Value: double): TNullableFloat; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow -// direct transtyping from a TNullableFloat = type variant variable: use this -// function to circumvent those limitations -function NullableFloatIsEmptyOrNull(const V: TNullableFloat): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableFloat is null, or return its value -// - returns FALSE if V is null or empty, or TRUE and set the Float value -function NullableFloatToValue(const V: TNullableFloat; out Value: double): boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableFloat is null, or return its value -// - returns 0 if V is null or empty, or the stored Float value -function NullableFloatToValue(const V: TNullableFloat): double; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// creates a nullable Currency value from a supplied constant -// - FPC does not allow direct assignment to a TNullableCurrency = type variant -// variable: use this function to circumvent it -function NullableCurrency(const Value: currency): TNullableCurrency; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow -// direct transtyping from a TNullableCurrency = type variant variable: use this -// function to circumvent those limitations -function NullableCurrencyIsEmptyOrNull(const V: TNullableCurrency): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableCurrency is null, or return its value -// - returns FALSE if V is null or empty, or TRUE and set the Currency value -function NullableCurrencyToValue(const V: TNullableCurrency; out Value: currency): boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableCurrency is null, or return its value -// - returns 0 if V is null or empty, or the stored Currency value -function NullableCurrencyToValue(const V: TNullableCurrency): currency; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// creates a nullable TDateTime value from a supplied constant -// - FPC does not allow direct assignment to a TNullableDateTime = type variant -// variable: use this function to circumvent it -function NullableDateTime(const Value: TDateTime): TNullableDateTime; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow -// direct transtyping from a TNullableDateTime = type variant variable: use this -// function to circumvent those limitations -function NullableDateTimeIsEmptyOrNull(const V: TNullableDateTime): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableDateTime is null, or return its value -// - returns FALSE if V is null or empty, or TRUE and set the DateTime value -function NullableDateTimeToValue(const V: TNullableDateTime; out Value: TDateTime): boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableDateTime is null, or return its value -// - returns 0 if V is null or empty, or the stored DateTime value -function NullableDateTimeToValue(const V: TNullableDateTime): TDateTime; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// creates a nullable TTimeLog value from a supplied constant -// - FPC does not allow direct assignment to a TNullableTimeLog = type variant -// variable: use this function to circumvent it -function NullableTimeLog(const Value: TTimeLog): TNullableTimeLog; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow -// direct transtyping from a TNullableTimeLog = type variant variable: use this -// function to circumvent those limitations -function NullableTimeLogIsEmptyOrNull(const V: TNullableTimeLog): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableTimeLog is null, or return its value -// - returns FALSE if V is null or empty, or TRUE and set the TimeLog value -function NullableTimeLogToValue(const V: TNullableTimeLog; out Value: TTimeLog): boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableTimeLog is null, or return its value -// - returns 0 if V is null or empty, or the stored TimeLog value -function NullableTimeLogToValue(const V: TNullableTimeLog): TTimeLog; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// creates a nullable UTF-8 encoded text value from a supplied constant -// - FPC does not allow direct assignment to a TNullableUTF8 = type variant -// variable: use this function to circumvent it -function NullableUTF8Text(const Value: RawUTF8): TNullableUTF8Text; - {$ifdef HASINLINE}inline;{$endif} - -/// same as VarIsEmpty(V) or VarIsEmpty(V), but faster -// - FPC VarIsNull() seems buggy with varByRef variants, and does not allow -// direct transtyping from a TNullableUTF8Text = type variant variable: use this -// function to circumvent those limitations -function NullableUTF8TextIsEmptyOrNull(const V: TNullableUTF8Text): Boolean; - {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableUTF8Text is null, or return its value -// - returns FALSE if V is null or empty, or TRUE and set the UTF8Text value -function NullableUTF8TextToValue(const V: TNullableUTF8Text; out Value: RawUTF8): boolean; - overload; {$ifdef HASINLINE}inline;{$endif} - -/// check if a TNullableUTF8Text is null, or return its value -// - returns '' if V is null or empty, or the stored UTF8-encoded text value -function NullableUTF8TextToValue(const V: TNullableUTF8Text): RawUTF8; - overload; {$ifdef HASINLINE}inline;{$endif} - -{$endif NOVARIANTS} - - /// convert a date to a ISO-8601 string format for SQL '?' inlined parameters -// - will return the date encoded as '\uFFF1YYYY-MM-DD' - therefore -// ':("\uFFF12012-05-04"):' pattern will be recognized as a sftDateTime -// inline parameter in SQLParamContent() / ExtractInlineParameters() functions -// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern) -// - to be used e.g. as in: -// ! aRec.CreateAndFillPrepare(Client,'Datum=?',[DateToSQL(EncodeDate(2012,5,4))]); -function DateToSQL(Date: TDateTime): RawUTF8; overload; - -/// convert a date to a ISO-8601 string format for SQL '?' inlined parameters -// - will return the date encoded as '\uFFF1YYYY-MM-DD' - therefore -// ':("\uFFF12012-05-04"):' pattern will be recognized as a sftDateTime -// inline parameter in SQLParamContent() / ExtractInlineParameters() functions -// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern) -// - to be used e.g. as in: -// ! aRec.CreateAndFillPrepare(Client,'Datum=?',[DateToSQL(2012,5,4)]); -function DateToSQL(Year,Month,Day: cardinal): RawUTF8; overload; - -/// convert a date/time to a ISO-8601 string format for SQL '?' inlined parameters -// - if DT=0, returns '' -// - if DT contains only a date, returns the date encoded as '\uFFF1YYYY-MM-DD' -// - if DT contains only a time, returns the time encoded as '\uFFF1Thh:mm:ss' -// - otherwise, returns the ISO-8601 date and time encoded as '\uFFF1YYYY-MM-DDThh:mm:ss' -// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern) -// - if WithMS is TRUE, will append '.sss' for milliseconds resolution -// - to be used e.g. as in: -// ! aRec.CreateAndFillPrepare(Client,'Datum<=?',[DateTimeToSQL(Now)]); -// - see TimeLogToSQL() if you are using TTimeLog/TModTime/TCreateTime values -function DateTimeToSQL(DT: TDateTime; WithMS: boolean=false): RawUTF8; - -/// decode a SQL '?' inlined parameter (i.e. with JSON_SQLDATE_MAGIC prefix) -// - as generated by DateToSQL/DateTimeToSQL/TimeLogToSQL functions -function SQLToDateTime(const ParamValueWithMagic: RawUTF8): TDateTime; - -/// convert a TTimeLog value into a ISO-8601 string format for SQL '?' inlined -// parameters -// - handle TTimeLog bit-encoded Int64 format -// - follows the same pattern as DateToSQL or DateTimeToSQL functions, i.e. -// will return the date or time encoded as '\uFFF1YYYY-MM-DDThh:mm:ss' - -// therefore ':("\uFFF12012-05-04T20:12:13"):' pattern will be recognized as a -// sftDateTime inline parameter in SQLParamContent() / ExtractInlineParameters() -// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern) -// - to be used e.g. as in: -// ! aRec.CreateAndFillPrepare(Client,'Datum<=?',[TimeLogToSQL(TimeLogNow)]); -function TimeLogToSQL(const Timestamp: TTimeLog): RawUTF8; - -/// convert a Iso8601 encoded string into a ISO-8601 string format for SQL -// '?' inlined parameters -// - follows the same pattern as DateToSQL or DateTimeToSQL functions, i.e. -// will return the date or time encoded as '\uFFF1YYYY-MM-DDThh:mm:ss' - -// therefore ':("\uFFF12012-05-04T20:12:13"):' pattern will be recognized as a -// sftDateTime inline parameter in SQLParamContent() / ExtractInlineParameters() -// (JSON_SQLDATE_MAGIC will be used as prefix to create '\uFFF1...' pattern) -// - in practice, just append the JSON_SQLDATE_MAGIC prefix to the supplied text -function Iso8601ToSQL(const S: RawByteString): RawUTF8; - - -/// guess the content type of an UTF-8 SQL value, in :(....): format -// - will be used e.g. by ExtractInlineParameters() to un-inline a SQL statement -// - sftInteger is returned for an INTEGER value, e.g. :(1234): -// - sftFloat is returned for any floating point value (i.e. some digits -// separated by a '.' character), e.g. :(12.34): or :(12E-34): -// - sftUTF8Text is returned for :("text"): or :('text'):, with double quoting -// inside the value -// - sftBlob will be recognized from the ':("\uFFF0base64encodedbinary"):' -// pattern, and return raw binary (for direct blob parameter assignment) -// - sftDateTime will be recognized from ':(\uFFF1"2012-05-04"):' pattern, -// i.e. JSON_SQLDATE_MAGIC-prefixed string as returned by DateToSQL() or -// DateTimeToSQL() functions -// - sftUnknown is returned on invalid content, or if wasNull is set to TRUE -// - if ParamValue is not nil, the pointing RawUTF8 string is set with the -// value inside :(...): without double quoting in case of sftUTF8Text -// - wasNull is set to TRUE if P was ':(null):' and ParamType is sftUnknwown -function SQLParamContent(P: PUTF8Char; out ParamType: TSQLParamType; out ParamValue: RawUTF8; - out wasNull: boolean): PUTF8Char; - -/// this function will extract inlined :(1234): parameters into Types[]/Values[] -// - will return the generic SQL statement with ? place holders for inlined -// parameters and setting Values with SQLParamContent() decoded content -// - will set maxParam=0 in case of no inlined parameters -// - recognized types are sptInteger, sptFloat, sptDateTime ('\uFFF1...'), -// sptUTF8Text and sptBlob ('\uFFF0...') -// - sptUnknown is returned on invalid content -function ExtractInlineParameters(const SQL: RawUTF8; - var Types: TSQLParamTypeDynArray; var Values: TRawUTF8DynArray; - var maxParam: integer; var Nulls: TSQLFieldBits): RawUTF8; - -/// returns a 64-bit value as inlined ':(1234):' text -function InlineParameter(ID: Int64): shortstring; overload; - -/// returns a string value as inlined ':("value"):' text -function InlineParameter(const value: RawUTF8): RawUTF8; overload; - -type - /// SQL Query comparison operators - // - used e.g. by CompareOperator() functions in SynTable.pas or vt_BestIndex() - // in mORMotSQLite3.pas - TCompareOperator = ( - soEqualTo, - soNotEqualTo, - soLessThan, - soLessThanOrEqualTo, - soGreaterThan, - soGreaterThanOrEqualTo, - soBeginWith, - soContains, - soSoundsLikeEnglish, - soSoundsLikeFrench, - soSoundsLikeSpanish); - -const - /// convert identified field types into high-level ORM types - // - as will be implemented in unit mORMot.pas - SQLDBFIELDTYPE_TO_DELPHITYPE: array[TSQLDBFieldType] of RawUTF8 = ( - '???','???', 'Int64', 'Double', 'Currency', 'TDateTime', 'RawUTF8', 'TSQLRawBlob'); - - -{ ************ low-level buffer processing functions ************************* } - -type - /// safe decoding of a TFileBufferWriter content - // - similar to TFileBufferReader, but faster and only for in-memory buffer - // - is also safer, since will check for reaching end of buffer - // - raise a EFastReader exception on decoding error (e.g. if a buffer - // overflow may occur) or call OnErrorOverflow/OnErrorData event handlers - {$ifdef USERECORDWITHMETHODS}TFastReader = record - {$else}TFastReader = object{$endif} - public - /// the current position in the memory - P: PAnsiChar; - /// the last position in the buffer - Last: PAnsiChar; - /// use this event to customize the ErrorOverflow process - OnErrorOverflow: procedure of object; - /// use this event to customize the ErrorData process - OnErrorData: procedure(const fmt: RawUTF8; const args: array of const) of object; - /// some opaque value, which may be a version number to define the binary layout - Tag: PtrInt; - /// initialize the reader from a memory block - procedure Init(Buffer: pointer; Len: integer); overload; - /// initialize the reader from a RawByteString content - procedure Init(const Buffer: RawByteString); overload; - /// raise a EFastReader with an "overflow" error message - procedure ErrorOverflow; - /// raise a EFastReader with an "incorrect data" error message - procedure ErrorData(const fmt: RawUTF8; const args: array of const); - /// read the next 32-bit signed value from the buffer - function VarInt32: integer; {$ifdef HASINLINE}inline;{$endif} - /// read the next 32-bit unsigned value from the buffer - function VarUInt32: cardinal; - /// try to read the next 32-bit signed value from the buffer - // - don't change the current position - function PeekVarInt32(out value: PtrInt): boolean; {$ifdef HASINLINE}inline;{$endif} - /// try to read the next 32-bit unsigned value from the buffer - // - don't change the current position - function PeekVarUInt32(out value: PtrUInt): boolean; - /// read the next 32-bit unsigned value from the buffer - // - this version won't call ErrorOverflow, but return false on error - // - returns true on read success - function VarUInt32Safe(out Value: cardinal): boolean; - /// read the next 64-bit signed value from the buffer - function VarInt64: Int64; {$ifdef HASINLINE}inline;{$endif} - /// read the next 64-bit unsigned value from the buffer - function VarUInt64: QWord; - /// read the next RawUTF8 value from the buffer - function VarUTF8: RawUTF8; overload; - /// read the next RawUTF8 value from the buffer - procedure VarUTF8(out result: RawUTF8); overload; - /// read the next RawUTF8 value from the buffer - // - this version won't call ErrorOverflow, but return false on error - // - returns true on read success - function VarUTF8Safe(out Value: RawUTF8): boolean; - /// read the next RawByteString value from the buffer - function VarString: RawByteString; {$ifdef HASINLINE}inline;{$endif} - /// read the next pointer and length value from the buffer - procedure VarBlob(out result: TValueResult); overload; {$ifdef HASINLINE}inline;{$endif} - /// read the next pointer and length value from the buffer - function VarBlob: TValueResult; overload; {$ifdef HASINLINE}inline;{$endif} - /// read the next ShortString value from the buffer - function VarShortString: shortstring; {$ifdef HASINLINE}inline;{$endif} - /// fast ignore the next VarUInt32/VarInt32/VarUInt64/VarInt64 value - // - don't raise any exception, so caller could check explicitly for any EOF - procedure VarNextInt; overload; {$ifdef HASINLINE}inline;{$endif} - /// fast ignore the next count VarUInt32/VarInt32/VarUInt64/VarInt64 values - // - don't raise any exception, so caller could check explicitly for any EOF - procedure VarNextInt(count: integer); overload; - /// read the next byte from the buffer - function NextByte: byte; {$ifdef HASINLINE}inline;{$endif} - /// read the next byte from the buffer, checking - function NextByteSafe(dest: pointer): boolean; {$ifdef HASINLINE}inline;{$endif} - /// read the next 4 bytes from the buffer as a 32-bit unsigned value - function Next4: cardinal; {$ifdef HASINLINE}inline;{$endif} - /// read the next 8 bytes from the buffer as a 64-bit unsigned value - function Next8: Qword; {$ifdef HASINLINE}inline;{$endif} - /// consumes the next byte from the buffer, if matches a given value - function NextByteEquals(Value: byte): boolean; {$ifdef HASINLINE}inline;{$endif} - /// returns the current position, and move ahead the specified bytes - function Next(DataLen: PtrInt): pointer; {$ifdef HASINLINE}inline;{$endif} - /// returns the current position, and move ahead the specified bytes - function NextSafe(out Data: Pointer; DataLen: PtrInt): boolean; {$ifdef HASINLINE}inline;{$endif} - {$ifndef NOVARIANTS} - /// read the next variant from the buffer - // - is a wrapper around VariantLoad() - procedure NextVariant(var Value: variant; CustomVariantOptions: PDocVariantOptions); - /// read the JSON-serialized TDocVariant from the buffer - // - matches TFileBufferWriter.WriteDocVariantData format - procedure NextDocVariantData(out Value: variant; CustomVariantOptions: PDocVariantOptions); - {$endif NOVARIANTS} - /// copy data from the current position, and move ahead the specified bytes - procedure Copy(out Dest; DataLen: PtrInt); {$ifdef HASINLINE}inline;{$endif} - /// copy data from the current position, and move ahead the specified bytes - // - this version won't call ErrorOverflow, but return false on error - // - returns true on read success - function CopySafe(out Dest; DataLen: PtrInt): boolean; - /// apply TDynArray.LoadFrom on the buffer - // - will unserialize a previously appended dynamic array, e.g. as - // ! aWriter.WriteDynArray(DA); - procedure Read(var DA: TDynArray; NoCheckHash: boolean=false); - /// retrieved cardinal values encoded with TFileBufferWriter.WriteVarUInt32Array - // - only supports wkUInt32, wkVarInt32, wkVarUInt32 kind of encoding - function ReadVarUInt32Array(var Values: TIntegerDynArray): PtrInt; - /// retrieve some TAlgoCompress buffer, appended via Write() - // - BufferOffset could be set to reserve some bytes before the uncompressed buffer - function ReadCompressed(Load: TAlgoCompressLoad=aclNormal; BufferOffset: integer=0): RawByteString; - /// returns TRUE if the current position is the end of the input stream - function EOF: boolean; {$ifdef HASINLINE}inline;{$endif} - /// returns remaining length (difference between Last and P) - function RemainingLength: PtrUInt; {$ifdef HASINLINE}inline;{$endif} - end; - - /// implements a stack-based writable storage of binary content - // - memory allocation is performed via a TSynTempBuffer - TSynTempWriter = object - 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: PtrInt); - /// append some shortstring as binary to the internal buffer - procedure wrss(const str: shortstring); {$ifdef HASINLINE}inline;{$endif} - /// append some string as binary to the internal buffer - procedure wrs(const str: RawByteString); {$ifdef HASINLINE}inline;{$endif} - /// append some 8-bit value as binary to the internal buffer - procedure wrb(b: byte); {$ifdef HASINLINE}inline;{$endif} - /// append some 16-bit value as binary to the internal buffer - procedure wrw(w: word); {$ifdef HASINLINE}inline;{$endif} - /// append some 32-bit value as binary to the internal buffer - procedure wrint(int: integer); {$ifdef HASINLINE}inline;{$endif} - /// append some 32-bit/64-bit pointer value as binary to the internal buffer - procedure wrptr(ptr: pointer); {$ifdef HASINLINE}inline;{$endif} - /// append some 32-bit/64-bit integer as binary to the internal buffer - procedure wrptrint(int: PtrInt); {$ifdef HASINLINE}inline;{$endif} - /// 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: PtrInt; {$ifdef HASINLINE}inline;{$endif} - /// returns the buffer as a RawByteString instance - function AsBinary: RawByteString; - /// returns the buffer as a RawUTF8 instance - procedure AsUTF8(var result: RawUTF8); - protected - tmp: TSynTempBuffer; - end; - - /// available kind of integer array storage, corresponding to the data layout - // - wkUInt32 will write the content as "plain" 4 bytes binary (this is the - // prefered way if the integers can be negative) - // - wkVarUInt32 will write the content using our 32-bit variable-length integer - // encoding - // - wkVarInt32 will write the content using our 32-bit variable-length integer - // encoding and the by-two complement (0=0,1=1,2=-1,3=2,4=-2...) - // - wkSorted will write an increasing array of integers, handling the special - // case of a difference of similar value (e.g. 1) between two values - note - // that this encoding is efficient only if the difference is main < 253 - // - wkOffsetU and wkOffsetI will write the difference between two successive - // values, handling constant difference (Unsigned or Integer) in an optimized manner - // - wkFakeMarker won't be used by WriteVarUInt32Array, but to notify a - // custom encoding - TFileBufferWriterKind = (wkUInt32, wkVarUInt32, wkVarInt32, wkSorted, - wkOffsetU, wkOffsetI, wkFakeMarker); - - /// this class can be used to speed up writing to a file - // - big speed up if data is written in small blocks - // - also handle optimized storage of any dynamic array of Integer/Int64/RawUTF8 - // - use TFileBufferReader or TFastReader for decoding of the stored binary - TFileBufferWriter = class - private - fPos: PtrInt; - fBufLen: PtrInt; - fStream: TStream; - fTotalWritten: Int64; - fInternalStream: boolean; - fTag: PtrInt; - fBuffer: PByteArray; - fBufInternal: RawByteString; - procedure InternalFlush; - public - /// initialize the buffer, and specify a file handle to use for writing - // - use an internal buffer of the specified size - constructor Create(aFile: THandle; BufLen: integer=65536); overload; - /// initialize the buffer, and specify a TStream to use for writing - // - use an internal buffer of the specified size - constructor Create(aStream: TStream; BufLen: integer=65536); overload; - /// initialize the buffer, and specify a file to use for writing - // - use an internal buffer of the specified size - // - would replace any existing file by default, unless Append is TRUE - constructor Create(const aFileName: TFileName; BufLen: integer=65536; - Append: boolean=false); overload; - /// initialize the buffer, using an internal TStream instance - // - parameter could be e.g. THeapMemoryStream or TRawByteStringStream - // - use Flush then TMemoryStream(Stream) to retrieve its content, or - // TRawByteStringStream(Stream).DataString - constructor Create(aClass: TStreamClass; BufLen: integer=4096); overload; - /// initialize with a specified buffer and TStream class - // - use a specified external buffer (which may be allocated on stack), - // to avoid a memory allocation - constructor Create(aStream: TStream; aTempBuf: pointer; aTempLen: integer); overload; - /// initialize with a specified buffer - // - use a specified external buffer (which may be allocated on stack), - // to avoid a memory allocation - // - aStream parameter could be e.g. THeapMemoryStream or TRawByteStringStream - constructor Create(aClass: TStreamClass; aTempBuf: pointer; aTempLen: integer); overload; - /// release internal TStream (after AssignToHandle call) - // - warning: an explicit call to Flush is needed to write the data pending - // in internal buffer - destructor Destroy; override; - /// append some data at the current position - procedure Write(Data: pointer; DataLen: PtrInt); overload; - /// append 1 byte of data at the current position - procedure Write1(Data: Byte); {$ifdef HASINLINE}inline;{$endif} - /// append 2 bytes of data at the current position - procedure Write2(Data: Word); {$ifdef HASINLINE}inline;{$endif} - /// append 4 bytes of data at the current position - procedure Write4(Data: integer); {$ifdef HASINLINE}inline;{$endif} - /// append 4 bytes of data, encoded as BigEndian, at the current position - procedure Write4BigEndian(Data: integer); {$ifdef HASINLINE}inline;{$endif} - /// append 8 bytes of data at the current position - procedure Write8(const Data8Bytes); {$ifdef HASINLINE}inline;{$endif} - /// append the same byte a given number of occurences at the current position - procedure WriteN(Data: Byte; Count: integer); - /// append some UTF-8 encoded text at the current position - // - will write the string length (as VarUInt32), then the string content, as expected - // by the FromVarString() function - procedure Write(const Text: RawByteString); overload; {$ifdef HASINLINE}inline;{$endif} - /// append some UTF-8 encoded text at the current position - // - will write the string length (as VarUInt32), then the string content - procedure WriteShort(const Text: ShortString); - /// append some content at the current position - // - will write the binary data, without any length prefix - procedure WriteBinary(const Data: RawByteString); - {$ifndef NOVARIANTS} - /// append some variant value at the current position - // - matches FromVarVariant() and VariantSave/VariantLoad format - procedure Write(const Value: variant); overload; - /// append some TDocVariant value at the current position, as JSON string - // - matches TFastReader.NextDocVariantData format - procedure WriteDocVariantData(const Value: variant); - {$endif} - /// append some record at the current position, with binary serialization - // - will use the binary serialization as for: - // ! aWriter.WriteBinary(RecordSave(Rec,RecTypeInfo)); - // but writing directly into the buffer, if possible - procedure WriteRecord(const Rec; RecTypeInfo: pointer); - /// append some dynamic array at the current position - // - will use the binary serialization as for: - // ! aWriter.WriteBinary(DA.SaveTo); - // but writing directly into the buffer, if possible - procedure WriteDynArray(const DA: TDynArray); - /// append "New[0..Len-1] xor Old[0..Len-1]" bytes - // - as used e.g. by ZeroCompressXor/TSynBloomFilterDiff.SaveTo - procedure WriteXor(New,Old: PAnsiChar; Len: PtrInt; crc: PCardinal=nil); - /// append a cardinal value using 32-bit variable-length integer encoding - procedure WriteVarUInt32(Value: PtrUInt); - /// append an integer value using 32-bit variable-length integer encoding of - // the by-two complement of the given value - procedure WriteVarInt32(Value: PtrInt); - /// append an integer value using 64-bit variable-length integer encoding of - // the by-two complement of the given value - procedure WriteVarInt64(Value: Int64); - /// append an unsigned integer value using 64-bit variable-length encoding - procedure WriteVarUInt64(Value: QWord); - /// append cardinal values (NONE must be negative!) using 32-bit - // variable-length integer encoding or other specialized algorithm, - // depending on the data layout - procedure WriteVarUInt32Array(const Values: TIntegerDynArray; ValuesCount: integer; - DataLayout: TFileBufferWriterKind); - /// append cardinal values (NONE must be negative!) using 32-bit - // variable-length integer encoding or other specialized algorithm, - // depending on the data layout - procedure WriteVarUInt32Values(Values: PIntegerArray; ValuesCount: integer; - DataLayout: TFileBufferWriterKind); - /// append UInt64 values using 64-bit variable length integer encoding - // - if Offset is TRUE, then it will store the difference between - // two values using 64-bit variable-length integer encoding (in this case, - // a fixed-sized record storage is also handled separately) - // - could be decoded later on via TFileBufferReader.ReadVarUInt64Array - procedure WriteVarUInt64DynArray(const Values: TInt64DynArray; - ValuesCount: integer; Offset: Boolean); - /// append the RawUTF8 dynamic array - // - handled the fixed size strings array case in a very efficient way - procedure WriteRawUTF8DynArray(const Values: TRawUTF8DynArray; ValuesCount: integer); - /// append a RawUTF8 array of values, from its low-level memory pointer - // - handled the fixed size strings array case in a very efficient way - procedure WriteRawUTF8Array(Values: PPtrUIntArray; ValuesCount: integer); - /// append the RawUTF8List content - // - if StoreObjectsAsVarUInt32 is TRUE, all Objects[] properties will be - // stored as VarUInt32 - procedure WriteRawUTF8List(List: TRawUTF8List; StoreObjectsAsVarUInt32: Boolean=false); - /// append a TStream content - // - is StreamSize is left as -1, the Stream.Size is used - // - the size of the content is stored in the resulting stream - procedure WriteStream(aStream: TCustomMemoryStream; aStreamSize: Integer=-1); - /// allows to write directly to a memory buffer - // - caller should specify the maximum possible number of bytes to be written - // - then write the data to the returned pointer, and call DirectWriteFlush - function DirectWritePrepare(len: PtrInt; out tmp: RawByteString): PAnsiChar; - /// finalize a direct write to a memory buffer - // - by specifying the number of bytes written to the buffer - procedure DirectWriteFlush(len: PtrInt; const tmp: RawByteString); - /// write any pending data in the internal buffer to the file - // - after a Flush, it's possible to call FileSeek64(aFile,....) - // - returns the number of bytes written between two FLush method calls - function Flush: Int64; - /// write any pending data, then call algo.Compress() on the buffer - // - expect the instance to have been created via - // ! TFileBufferWriter.Create(TRawByteStringStream) - // - if algo is left to its default nil, will use global AlgoSynLZ - // - features direct compression from internal buffer, if stream was not used - // - BufferOffset could be set to reserve some bytes before the compressed buffer - function FlushAndCompress(nocompression: boolean=false; algo: TAlgoCompress=nil; - BufferOffset: integer=0): RawByteString; - /// 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; virtual; - /// the associated writing stream - property Stream: TStream read fStream; - /// get the byte count written since last Flush - property TotalWritten: Int64 read fTotalWritten; - /// simple property used to store some integer content - property Tag: PtrInt read fTag write fTag; - end; - - PFileBufferReader = ^TFileBufferReader; - - /// this structure can be used to speed up reading from a file - // - use internaly memory mapped files for a file up to 2 GB (Windows has - // problems with memory mapped files bigger than this size limit - at least - // with 32-bit executables) - but sometimes, Windows fails to allocate - // more than 512 MB for a memory map, because it does lack of contiguous - // memory space: in this case, we fall back on direct file reading - // - maximum handled file size has no limit (but will use slower direct - // file reading) - // - can handle sophisticated storage layout of TFileBufferWriter for - // dynamic arrays of Integer/Int64/RawUTF8 - // - is defined as an object or as a record, due to a bug - // in Delphi 2009/2010 compiler (at least): this structure is not initialized - // if defined as an object on the stack, but will be as a record :( - TFileBufferReader = object - protected - fCurrentPos: PtrUInt; - fMap: TMemoryMap; - /// get Isize + buffer from current memory map or fBufTemp into (P,PEnd) - procedure ReadChunk(out P, PEnd: PByte; var BufTemp: RawByteString); - public - /// initialize the buffer, and specify a file to use for reading - // - will try to map the whole file content in memory - // - if memory mapping failed, or aFileNotMapped is true, methods - // will use default slower file API - procedure Open(aFile: THandle; aFileNotMapped: boolean=false); - /// initialize the buffer from an already existing memory block - // - may be e.g. a resource or a TMemoryStream - procedure OpenFrom(aBuffer: pointer; aBufferSize: PtrUInt); overload; - /// initialize the buffer from an already existing memory block - procedure OpenFrom(const aBuffer: RawByteString); overload; - /// initialize the buffer from an already existing Stream - // - accept either TFileStream or TCustomMemoryStream kind of stream - function OpenFrom(Stream: TStream): boolean; overload; - /// close all internal mapped files - // - call Open() again to use the Read() methods - procedure Close; - {$ifndef CPU64} - /// change the current reading position, from the beginning of the file - // - returns TRUE if success, or FALSE if Offset is out of range - function Seek(Offset: Int64): boolean; overload; - {$endif} - /// change the current reading position, from the beginning of the file - // - returns TRUE if success, or FALSE if Offset is out of range - function Seek(Offset: PtrInt): boolean; overload; - /// raise an exception in case of invalid content - procedure ErrorInvalidContent; - /// read some bytes from the given reading position - // - returns the number of bytes which was read - // - if Data is nil, it won't read content but will forward reading position - function Read(Data: pointer; DataLen: PtrInt): integer; overload; - /// read some UTF-8 encoded text at the current position - // - returns the resulting text length, in bytes - function Read(out Text: RawUTF8): integer; overload; - /// read some buffer texgt at the current position - // - returns the resulting text length, in bytes - function Read(out Text: RawByteString): integer; overload; - /// read some UTF-8 encoded text at the current position - // - returns the resulting text - function ReadRawUTF8: RawUTF8; {$ifdef HASINLINE}inline;{$endif} - /// read one byte - // - if reached end of file, don't raise any error, but returns 0 - function ReadByte: PtrUInt; {$ifdef HASINLINE}inline;{$endif} - /// read one cardinal, which was written as fixed length - // - if reached end of file, don't raise any error, but returns 0 - function ReadCardinal: cardinal; - /// read one cardinal value encoded using our 32-bit variable-length integer - function ReadVarUInt32: PtrUInt; - /// read one integer value encoded using our 32-bit variable-length integer, - // and the by-two complement - function ReadVarInt32: PtrInt; - /// read one UInt64 value encoded using our 64-bit variable-length integer - function ReadVarUInt64: QWord; - /// read one Int64 value encoded using our 64-bit variable-length integer - function ReadVarInt64: Int64; - /// retrieved cardinal values encoded with TFileBufferWriter.WriteVarUInt32Array - // - returns the number of items read into Values[] (may differ from - // length(Values), which will be resized, so could be void before calling) - // - if the returned integer is negative, it is -Count, and testifies from - // wkFakeMarker and the content should be retrieved by the caller - function ReadVarUInt32Array(var Values: TIntegerDynArray): PtrInt; - /// retrieved Int64 values encoded with TFileBufferWriter.WriteVarUInt64DynArray - // - returns the number of items read into Values[] (may differ from length(Values)) - function ReadVarUInt64Array(var Values: TInt64DynArray): PtrInt; - /// retrieved RawUTF8 values encoded with TFileBufferWriter.WriteRawUTF8DynArray - // - returns the number of items read into Values[] (may differ from length(Values)) - function ReadVarRawUTF8DynArray(var Values: TRawUTF8DynArray): PtrInt; - /// retrieve the RawUTF8List content encoded with TFileBufferWriter.WriteRawUTF8List - // - if StoreObjectsAsVarUInt32 was TRUE, all Objects[] properties will be - // retrieved as VarUInt32 - function ReadRawUTF8List(List: TRawUTF8List): boolean; - /// retrieve a pointer to the current position, for a given data length - // - if the data is available in the current memory mapped file, it - // will just return a pointer to it - // - otherwise (i.e. if the data is split between to 1GB memory map buffers), - // data will be copied into the temporary aTempData buffer before retrieval - function ReadPointer(DataLen: PtrUInt; var aTempData: RawByteString): pointer; - /// create a TMemoryStream instance from the current position - // - the content size is either specified by DataLen>=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; PEnd: PPAnsiChar=nil): pointer; - /// retrieve the current in-memory position - // - if file was not memory-mapped, returns -1 - function CurrentPosition: integer; {$ifdef HASINLINE}inline;{$endif} - /// read-only access to the global file size - function FileSize: Int64; {$ifdef HASINLINE}inline;{$endif} - /// read-only access to the global mapped buffer binary - function MappedBuffer: PAnsiChar; {$ifdef HASINLINE}inline;{$endif} - end; - - /// implements a thread-safe Bloom Filter storage - // - a "Bloom Filter" is a space-efficient probabilistic data structure, - // that is used to test whether an element is a member of a set. False positive - // matches are possible, but false negatives are not. Elements can be added to - // the set, but not removed. Typical use cases are to avoid unecessary - // slow disk or network access if possible, when a lot of items are involved. - // - memory use is very low, when compared to storage of all values: fewer - // than 10 bits per element are required for a 1% false positive probability, - // independent of the size or number of elements in the set - for instance, - // storing 10,000,000 items presence with 1% of false positive ratio - // would consume only 11.5 MB of memory, using 7 hash functions - // - use Insert() methods to add an item to the internal bits array, and - // Reset() to clear all bits array, if needed - // - MayExist() function would check if the supplied item was probably set - // - SaveTo() and LoadFrom() methods allow transmission of the bits array, - // for a disk/database storage or transmission over a network - // - internally, several (hardware-accelerated) crc32c hash functions will be - // used, with some random seed values, to simulate several hashing functions - // - Insert/MayExist/Reset methods are thread-safe - TSynBloomFilter = class(TSynPersistentLock) - private - fSize: cardinal; - fFalsePositivePercent: double; - fBits: cardinal; - fHashFunctions: cardinal; - fInserted: cardinal; - fStore: RawByteString; - function GetInserted: cardinal; - public - /// initialize the internal bits storage for a given number of items - // - by default, internal bits array size will be guess from a 1 % false - // positive rate - but you may specify another value, to reduce memory use - // - this constructor would compute and initialize Bits and HashFunctions - // corresponding to the expected false positive ratio - constructor Create(aSize: integer; aFalsePositivePercent: double = 1); reintroduce; overload; - /// initialize the internal bits storage from a SaveTo() binary buffer - // - this constructor will initialize the internal bits array calling LoadFrom() - constructor Create(const aSaved: RawByteString; aMagic: cardinal=$B1003F11); reintroduce; overload; - /// add an item in the internal bits array storage - // - this method is thread-safe - procedure Insert(const aValue: RawByteString); overload; - /// add an item in the internal bits array storage - // - this method is thread-safe - procedure Insert(aValue: pointer; aValueLen: integer); overload; virtual; - /// clear the internal bits array storage - // - you may call this method after some time, if some items may have - // been removed, to reduce false positives - // - this method is thread-safe - procedure Reset; virtual; - /// returns TRUE if the supplied items was probably set via Insert() - // - some false positive may occur, but not much than FalsePositivePercent - // - this method is thread-safe - function MayExist(const aValue: RawByteString): boolean; overload; - /// returns TRUE if the supplied items was probably set via Insert() - // - some false positive may occur, but not much than FalsePositivePercent - // - this method is thread-safe - function MayExist(aValue: pointer; aValueLen: integer): boolean; overload; - /// store the internal bits array into a binary buffer - // - may be used to transmit or store the state of a dataset, avoiding - // to recompute all Insert() at program startup, or to synchronize - // networks nodes information and reduce the number of remote requests - function SaveTo(aMagic: cardinal=$B1003F11): RawByteString; overload; - /// store the internal bits array into a binary buffer - // - may be used to transmit or store the state of a dataset, avoiding - // to recompute all Insert() at program startup, or to synchronize - // networks nodes information and reduce the number of remote requests - procedure SaveTo(aDest: TFileBufferWriter; aMagic: cardinal=$B1003F11); overload; - /// read the internal bits array from a binary buffer - // - as previously serialized by the SaveTo method - // - may be used to transmit or store the state of a dataset - function LoadFrom(const aSaved: RawByteString; aMagic: cardinal=$B1003F11): boolean; overload; - /// read the internal bits array from a binary buffer - // - as previously serialized by the SaveTo method - // - may be used to transmit or store the state of a dataset - function LoadFrom(P: PByte; PLen: integer; aMagic: cardinal=$B1003F11): boolean; overload; virtual; - published - /// maximum number of items which are expected to be inserted - property Size: cardinal read fSize; - /// expected percentage (1..100) of false positive results for MayExists() - property FalsePositivePercent: double read fFalsePositivePercent; - /// number of bits stored in the internal bits array - property Bits: cardinal read fBits; - /// how many hash functions would be applied for each Insert() - property HashFunctions: cardinal read fHashFunctions; - /// how many times the Insert() method has been called - property Inserted: cardinal read GetInserted; - end; - - /// implements a thread-safe differential Bloom Filter storage - // - this inherited class is able to compute incremental serialization of - // its internal bits array, to reduce network use - // - an obfuscated revision counter is used to identify storage history - TSynBloomFilterDiff = class(TSynBloomFilter) - protected - fRevision: Int64; - fSnapShotAfterMinutes: cardinal; - fSnapshotAfterInsertCount: cardinal; - fSnapshotTimestamp: Int64; - fSnapshotInsertCount: cardinal; - fKnownRevision: Int64; - fKnownStore: RawByteString; - public - /// add an item in the internal bits array storage - // - this overloaded thread-safe method would compute fRevision - procedure Insert(aValue: pointer; aValueLen: integer); override; - /// clear the internal bits array storage - // - this overloaded thread-safe method would reset fRevision - procedure Reset; override; - /// store the internal bits array into an incremental binary buffer - // - here the difference from a previous SaveToDiff revision will be computed - // - if aKnownRevision is outdated (e.g. if equals 0), the whole bits array - // would be returned, and around 10 bits per item would be transmitted - // (for 1% false positive ratio) - // - incremental retrieval would then return around 10 bytes per newly added - // item since the last snapshot reference state (with 1% ratio, i.e. 7 hash - // functions) - function SaveToDiff(const aKnownRevision: Int64): RawByteString; - /// use the current internal bits array state as known revision - // - is done the first time SaveToDiff() is called, then after 1/32th of - // the filter size has been inserted (see SnapshotAfterInsertCount property), - // or after SnapShotAfterMinutes property timeout period - procedure DiffSnapshot; - /// retrieve the revision number from an incremental binary buffer - // - returns 0 if the supplied binary buffer does not match this bloom filter - function DiffKnownRevision(const aDiff: RawByteString): Int64; - /// read the internal bits array from an incremental binary buffer - // - as previously serialized by the SaveToDiff() method - // - may be used to transmit or store the state of a dataset - // - returns false if the supplied content is incorrect, e.g. if the known - // revision is deprecated - function LoadFromDiff(const aDiff: RawByteString): boolean; - /// the opaque revision number of this internal storage - // - is in fact the Unix timestamp shifted by 31 bits, and an incremental - // counter: this pattern will allow consistent IDs over several ServPanels - property Revision: Int64 read fRevision; - /// after how many Insert() the internal bits array storage should be - // promoted as known revision - // - equals Size div 32 by default - property SnapshotAfterInsertCount: cardinal read fSnapshotAfterInsertCount - write fSnapshotAfterInsertCount; - /// after how many time the internal bits array storage should be - // promoted as known revision - // - equals 30 minutes by default - property SnapShotAfterMinutes: cardinal read fSnapShotAfterMinutes - write fSnapShotAfterMinutes; - end; - - -/// RLE compression of a memory buffer containing mostly zeros -// - will store the number of consecutive zeros instead of plain zero bytes -// - used for spare bit sets, e.g. TSynBloomFilter serialization -// - will also compute the crc32c of the supplied content -// - use ZeroDecompress() to expand the compressed result -// - resulting content would be at most 14 bytes bigger than the input -// - you may use this function before SynLZ compression -procedure ZeroCompress(P: PAnsiChar; Len: integer; Dest: TFileBufferWriter); - -/// RLE uncompression of a memory buffer containing mostly zeros -// - returns Dest='' if P^ is not a valid ZeroCompress() function result -// - used for spare bit sets, e.g. TSynBloomFilter serialization -// - will also check the crc32c of the supplied content -procedure ZeroDecompress(P: PByte; Len: integer; {$ifdef FPC}var{$else}out{$endif} Dest: RawByteString); - -/// RLE compression of XORed memory buffers resulting in mostly zeros -// - will perform ZeroCompress(Dest^ := New^ xor Old^) without any temporary -// memory allocation -// - is used e.g. by TSynBloomFilterDiff.SaveToDiff() in incremental mode -// - will also compute the crc32c of the supplied content -procedure ZeroCompressXor(New,Old: PAnsiChar; Len: cardinal; Dest: TFileBufferWriter); - -/// RLE uncompression and ORing of a memory buffer containing mostly zeros -// - will perform Dest^ := Dest^ or ZeroDecompress(P^) without any temporary -// memory allocation -// - is used e.g. by TSynBloomFilterDiff.LoadFromDiff() in incremental mode -// - returns false if P^ is not a valid ZeroCompress/ZeroCompressXor() result -// - will also check the crc32c of the supplied content -function ZeroDecompressOr(P,Dest: PAnsiChar; Len,DestLen: integer): boolean; - - -const - /// normal pattern search depth for DeltaCompress() - // - gives good results on most content - DELTA_LEVEL_FAST = 100; - /// brutal pattern search depth for DeltaCompress() - // - may become very slow, with minor benefit, on huge content - DELTA_LEVEL_BEST = 500; - /// 2MB as internal chunks/window default size for DeltaCompress() - // - will use up to 9 MB of RAM during DeltaCompress() - none in DeltaExtract() - DELTA_BUF_DEFAULT = 2 shl 20; - -/// compute difference of two binary buffers -// - returns '=' for equal buffers, or an optimized binary delta -// - DeltaExtract() could be used later on to compute New from Old + Delta -function DeltaCompress(const New, Old: RawByteString; - Level: integer=DELTA_LEVEL_FAST; BufSize: integer=DELTA_BUF_DEFAULT): RawByteString; overload; - -/// compute difference of two binary buffers -// - returns '=' for equal buffers, or an optimized binary delta -// - DeltaExtract() could be used later on to compute New from Old -function DeltaCompress(New, Old: PAnsiChar; NewSize, OldSize: integer; - Level: integer=DELTA_LEVEL_FAST; BufSize: integer=DELTA_BUF_DEFAULT): RawByteString; overload; - -/// compute difference of two binary buffers -// - returns '=' for equal buffers, or an optimized binary delta -// - DeltaExtract() could be used later on to compute New from Old + Delta -// - caller should call Freemem(Delta) once finished with the output buffer -function DeltaCompress(New, Old: PAnsiChar; NewSize, OldSize: integer; - out Delta: PAnsiChar; Level: integer=DELTA_LEVEL_FAST; BufSize: integer=DELTA_BUF_DEFAULT): integer; overload; - -type - /// result of function DeltaExtract() - TDeltaError = ( - dsSuccess, dsCrcCopy, dsCrcComp, dsCrcBegin, dsCrcEnd, dsCrcExtract, dsFlag, dsLen); - -/// returns how many bytes a DeltaCompress() result will expand to -function DeltaExtractSize(const Delta: RawByteString): integer; overload; - -/// returns how many bytes a DeltaCompress() result will expand to -function DeltaExtractSize(Delta: PAnsiChar): integer; overload; - -/// apply the delta binary as computed by DeltaCompress() -// - decompression don't use any RAM, will perform crc32c check, and is very fast -// - return dsSuccess if was uncompressed to aOutUpd as expected -function DeltaExtract(const Delta,Old: RawByteString; out New: RawByteString): TDeltaError; overload; - -/// low-level apply the delta binary as computed by DeltaCompress() -// - New should already be allocated with DeltaExtractSize(Delta) bytes -// - as such, expect Delta, Old and New to be <> nil, and Delta <> '=' -// - return dsSuccess if was uncompressed to aOutUpd as expected -function DeltaExtract(Delta,Old,New: PAnsiChar): TDeltaError; overload; - -function ToText(err: TDeltaError): PShortString; overload; - - -{ ************ high-level storage classes ************************* } - -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 - 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; - - /// 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; - /// extract one matching item from the queue, as FIFO (First-In-First-Out) - // - the current pending item is compared with aAnother value - function PopEquals(aAnother: pointer; aCompare: TDynArraySortCompare; 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 - // - you can optionally compare the pending item before returning it (could - // be used e.g. when several threads are putting items into the queue) - // - this method is thread-safe, but will lock the instance only if needed - function WaitPop(aTimeoutMS: integer; const aWhenIdle: TThreadMethod; out aValue; - aCompared: pointer=nil; aCompare: TDynArraySortCompare=nil): 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(aTimeoutMS: integer=100); - /// 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; - - /// 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; - - /// abstract high-level handling of (SynLZ-)compressed persisted storage - // - LoadFromReader/SaveToWriter abstract methods should be overriden - // with proper binary persistence implementation - TSynPersistentStore = class(TSynPersistentLock) - protected - fName: RawUTF8; - fReader: TFastReader; - fReaderTemp: PRawByteString; - fLoadFromLastUncompressed, fSaveToLastUncompressed: integer; - fLoadFromLastAlgo: TAlgoCompress; - /// low-level virtual methods implementing the persistence - procedure LoadFromReader; virtual; - procedure SaveToWriter(aWriter: TFileBufferWriter); virtual; - public - /// initialize a void storage with the supplied name - constructor Create(const aName: RawUTF8); reintroduce; overload; virtual; - /// initialize a storage from a SaveTo persisted buffer - // - raise a EFastReader exception on decoding error - constructor CreateFrom(const aBuffer: RawByteString; - aLoad: TAlgoCompressLoad = aclNormal); - /// initialize a storage from a SaveTo persisted buffer - // - raise a EFastReader exception on decoding error - constructor CreateFromBuffer(aBuffer: pointer; aBufferLen: integer; - aLoad: TAlgoCompressLoad = aclNormal); - /// initialize a storage from a SaveTo persisted buffer - // - raise a EFastReader exception on decoding error - constructor CreateFromFile(const aFileName: TFileName; - aLoad: TAlgoCompressLoad = aclNormal); - /// fill the storage from a SaveTo persisted buffer - // - actually call the LoadFromReader() virtual method for persistence - // - raise a EFastReader exception on decoding error - procedure LoadFrom(const aBuffer: RawByteString; - aLoad: TAlgoCompressLoad = aclNormal); overload; - /// initialize the storage from a SaveTo persisted buffer - // - actually call the LoadFromReader() virtual method for persistence - // - raise a EFastReader exception on decoding error - procedure LoadFrom(aBuffer: pointer; aBufferLen: integer; - aLoad: TAlgoCompressLoad = aclNormal); overload; virtual; - /// initialize the storage from a SaveToFile content - // - actually call the LoadFromReader() virtual method for persistence - // - returns false if the file is not found, true if the file was loaded - // without any problem, or raise a EFastReader exception on decoding error - function LoadFromFile(const aFileName: TFileName; - aLoad: TAlgoCompressLoad = aclNormal): boolean; - /// persist the content as a SynLZ-compressed binary blob - // - to be retrieved later on via LoadFrom method - // - actually call the SaveToWriter() protected virtual method for persistence - // - you can specify ForcedAlgo if you want to override the default AlgoSynLZ - // - BufferOffset could be set to reserve some bytes before the compressed buffer - procedure SaveTo(out aBuffer: RawByteString; nocompression: boolean=false; - BufLen: integer=65536; ForcedAlgo: TAlgoCompress=nil; BufferOffset: integer=0); overload; virtual; - /// persist the content as a SynLZ-compressed binary blob - // - just an overloaded wrapper - function SaveTo(nocompression: boolean=false; BufLen: integer=65536; - ForcedAlgo: TAlgoCompress=nil; BufferOffset: integer=0): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - /// persist the content as a SynLZ-compressed binary file - // - to be retrieved later on via LoadFromFile method - // - returns the number of bytes of the resulting file - // - actually call the SaveTo method for persistence - function SaveToFile(const aFileName: TFileName; nocompression: boolean=false; - BufLen: integer=65536; ForcedAlgo: TAlgoCompress=nil): PtrUInt; - /// one optional text associated with this storage - // - you can define this field as published to serialize its value in log/JSON - property Name: RawUTF8 read fName; - /// after a LoadFrom(), contains the uncompressed data size read - property LoadFromLastUncompressed: integer read fLoadFromLastUncompressed; - /// after a SaveTo(), contains the uncompressed data size written - property SaveToLastUncompressed: integer read fSaveToLastUncompressed; - end; - - /// implement binary persistence and JSON serialization (not deserialization) - TSynPersistentStoreJson = class(TSynPersistentStore) - protected - // append "name" -> inherited should add properties to the JSON object - procedure AddJSON(W: TTextWriter); virtual; - public - /// serialize this instance as a JSON object - function SaveToJSON(reformat: TTextWriterJSONFormat = jsonCompact): RawUTF8; - end; - - -type - /// item as stored in a TRawByteStringGroup instance - TRawByteStringGroupValue = record - Position: integer; - Value: RawByteString; - end; - PRawByteStringGroupValue = ^TRawByteStringGroupValue; - /// items as stored in a TRawByteStringGroup instance - TRawByteStringGroupValueDynArray = array of TRawByteStringGroupValue; - - /// store several RawByteString content with optional concatenation - {$ifdef USERECORDWITHMETHODS}TRawByteStringGroup = record - {$else}TRawByteStringGroup = object{$endif} - public - /// actual list storing the data - Values: TRawByteStringGroupValueDynArray; - /// how many items are currently stored in Values[] - Count: integer; - /// the current size of data stored in Values[] - Position: integer; - /// naive but efficient cache for Find() - LastFind: integer; - /// add a new item to Values[] - procedure Add(const aItem: RawByteString); overload; - /// add a new item to Values[] - procedure Add(aItem: pointer; aItemLen: integer); overload; - {$ifndef DELPHI5OROLDER} - /// add another TRawByteStringGroup to Values[] - procedure Add(const aAnother: TRawByteStringGroup); overload; - /// low-level method to abort the latest Add() call - // - warning: will work only once, if an Add() has actually been just called: - // otherwise, the behavior is unexpected, and may wrongly truncate data - procedure RemoveLastAdd; - /// compare two TRawByteStringGroup instance stored text - function Equals(const aAnother: TRawByteStringGroup): boolean; - {$endif DELPHI5OROLDER} - /// clear any stored information - procedure Clear; - /// append stored information into another RawByteString, and clear content - procedure AppendTextAndClear(var aDest: RawByteString); - // compact the Values[] array into a single item - // - is also used by AsText to compute a single RawByteString - procedure Compact; - /// return all content as a single RawByteString - // - will also compact the Values[] array into a single item (which is returned) - function AsText: RawByteString; - /// return all content as a single TByteDynArray - function AsBytes: TByteDynArray; - /// save all content into a TTextWriter instance - procedure Write(W: TTextWriter; Escape: TTextWriterKind=twJSONEscape); overload; - /// save all content into a TFileBufferWriter instance - procedure WriteBinary(W: TFileBufferWriter); overload; - /// save all content as a string into a TFileBufferWriter instance - // - storing the length as WriteVarUInt32() prefix - procedure WriteString(W: TFileBufferWriter); - /// add another TRawByteStringGroup previously serialized via WriteString() - procedure AddFromReader(var aReader: TFastReader); - /// returns a pointer to Values[] containing a given position - // - returns nil if not found - function Find(aPosition: integer): PRawByteStringGroupValue; overload; - /// returns a pointer to Values[].Value containing a given position and length - // - returns nil if not found - function Find(aPosition, aLength: integer): pointer; overload; - /// returns the text at a given position in Values[] - // - text should be in a single Values[] entry - procedure FindAsText(aPosition, aLength: integer; out aText: RawByteString); overload; - {$ifdef HASINLINE}inline;{$endif} - /// returns the text at a given position in Values[] - // - text should be in a single Values[] entry - function FindAsText(aPosition, aLength: integer): RawByteString; overload; - {$ifdef HASINLINE}inline;{$endif} - {$ifndef NOVARIANTS} - /// returns the text at a given position in Values[] - // - text should be in a single Values[] entry - // - explicitly returns null if the supplied text was not found - procedure FindAsVariant(aPosition, aLength: integer; out aDest: variant); - {$ifdef HASINLINE}inline;{$endif} - {$endif} - /// append the text at a given position in Values[], JSON escaped by default - // - text should be in a single Values[] entry - procedure FindWrite(aPosition, aLength: integer; W: TTextWriter; - Escape: TTextWriterKind=twJSONEscape; TrailingCharsToIgnore: integer=0); - {$ifdef HASINLINE}inline;{$endif} - /// append the blob at a given position in Values[], base-64 encoded - // - text should be in a single Values[] entry - procedure FindWriteBase64(aPosition, aLength: integer; W: TTextWriter; - withMagic: boolean); {$ifdef HASINLINE}inline;{$endif} - /// copy the text at a given position in Values[] - // - text should be in a single Values[] entry - procedure FindMove(aPosition, aLength: integer; aDest: pointer); - end; - /// pointer reference to a TRawByteStringGroup - PRawByteStringGroup = ^TRawByteStringGroup; - - /// simple stack-allocated type for handling a non-void type names list - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}TPropNameList = record - {$else}TPropNameList = object{$endif} - public - /// the actual names storage - Values: TRawUTF8DynArray; - /// how many items are currently in Values[] - Count: Integer; - /// initialize the list - // - set Count := 0 - procedure Init; {$ifdef HASINLINE}inline;{$endif} - /// search for a Value within Values[0..Count-1] using IdemPropNameU() - function FindPropName(const Value: RawUTF8): Integer; {$ifdef HASINLINE}inline;{$endif} - /// if Value is in Values[0..Count-1] using IdemPropNameU() returns FALSE - // - otherwise, returns TRUE and add Value to Values[] - // - any Value='' is rejected - function AddPropName(const Value: RawUTF8): Boolean; - end; - - -{ ************ Security and Identifier classes ************************** } - -type - /// 64-bit integer unique identifier, as computed by TSynUniqueIdentifierGenerator - // - they are increasing over time (so are much easier to store/shard/balance - // than UUID/GUID), and contain generation time and a 16-bit process ID - // - mapped by TSynUniqueIdentifierBits memory structure - // - may be used on client side for something similar to a MongoDB ObjectID, - // but compatible with TSQLRecord.ID: TID properties - TSynUniqueIdentifier = type Int64; - - /// 16-bit unique process identifier, used to compute TSynUniqueIdentifier - // - each TSynUniqueIdentifierGenerator instance is expected to have - // its own unique process identifier, stored as a 16 bit integer 1..65535 value - TSynUniqueIdentifierProcess = type word; - - {$A-} - /// map 64-bit integer unique identifier internal memory structure - // - as stored in TSynUniqueIdentifier = Int64 values, and computed by - // TSynUniqueIdentifierGenerator - // - bits 0..14 map a 15-bit increasing counter (collision-free) - // - bits 15..30 map a 16-bit process identifier - // - bits 31..63 map a 33-bit UTC time, encoded as seconds since Unix epoch - {$ifdef USERECORDWITHMETHODS}TSynUniqueIdentifierBits = record - {$else}TSynUniqueIdentifierBits = object{$endif} - public - /// the actual 64-bit storage value - // - in practice, only first 63 bits are used - Value: TSynUniqueIdentifier; - /// 15-bit counter (0..32767), starting with a random value - function Counter: word; - {$ifdef HASINLINE}inline;{$endif} - /// 16-bit unique process identifier - // - as specified to TSynUniqueIdentifierGenerator constructor - function ProcessID: TSynUniqueIdentifierProcess; - {$ifdef HASINLINE}inline;{$endif} - /// low-endian 4-byte value representing the seconds since the Unix epoch - // - time is expressed in Coordinated Universal Time (UTC), not local time - // - it uses in fact a 33-bit resolution, so is "Year 2038" bug-free - function CreateTimeUnix: TUnixTime; - {$ifdef HASINLINE}inline;{$endif} - /// fill this unique identifier structure from its TSynUniqueIdentifier value - // - is just a wrapper around PInt64(@self)^ - procedure From(const AID: TSynUniqueIdentifier); - {$ifdef HASINLINE}inline;{$endif} - {$ifndef NOVARIANTS} - /// convert this identifier as an explicit TDocVariant JSON object - // - returns e.g. - // ! {"Created":"2016-04-19T15:27:58","Identifier":1,"Counter":1, - // ! "Value":3137644716930138113,"Hex":"2B8B273F00008001"} - function AsVariant: variant; {$ifdef HASINLINE}inline;{$endif} - /// convert this identifier to an explicit TDocVariant JSON object - // - returns e.g. - // ! {"Created":"2016-04-19T15:27:58","Identifier":1,"Counter":1, - // ! "Value":3137644716930138113,"Hex":"2B8B273F00008001"} - procedure ToVariant(out result: variant); - {$endif NOVARIANTS} - /// extract the UTC generation timestamp from the identifier as TDateTime - // - time is expressed in Coordinated Universal Time (UTC), not local time - function CreateDateTime: TDateTime; - {$ifdef HASINLINE}inline;{$endif} - /// extract the UTC generation timestamp from the identifier - // - time is expressed in Coordinated Universal Time (UTC), not local time - function CreateTimeLog: TTimeLog; - {$ifndef DELPHI5OROLDER} - /// compare two Identifiers - function Equal(const Another: TSynUniqueIdentifierBits): boolean; - {$ifdef HASINLINE}inline;{$endif} - {$endif DELPHI5OROLDER} - /// convert the identifier into a 16 chars hexadecimal string - function ToHexa: RawUTF8; - {$ifdef HASINLINE}inline;{$endif} - /// fill this unique identifier back from a 16 chars hexadecimal string - // - returns TRUE if the supplied hexadecimal is on the expected format - // - returns FALSE if the supplied text is invalid - function FromHexa(const hexa: RawUTF8): boolean; - /// fill this unique identifier with a fake value corresponding to a given - // timestamp - // - may be used e.g. to limit database queries on a particular time range - // - bits 0..30 would be 0, i.e. would set Counter = 0 and ProcessID = 0 - procedure FromDateTime(const aDateTime: TDateTime); - /// fill this unique identifier with a fake value corresponding to a given - // timestamp - // - may be used e.g. to limit database queries on a particular time range - // - bits 0..30 would be 0, i.e. would set Counter = 0 and ProcessID = 0 - procedure FromUnixTime(const aUnixTime: TUnixTime); - end; - {$A+} - - /// points to a 64-bit integer identifier, as computed by TSynUniqueIdentifierGenerator - // - may be used to access the identifier internals, from its stored - // Int64 or TSynUniqueIdentifier value - PSynUniqueIdentifierBits = ^TSynUniqueIdentifierBits; - - /// a 24 chars cyphered hexadecimal string, mapping a TSynUniqueIdentifier - // - has handled by TSynUniqueIdentifierGenerator.ToObfuscated/FromObfuscated - TSynUniqueIdentifierObfuscated = type RawUTF8; - - /// thread-safe 64-bit integer unique identifier computation - // - may be used on client side for something similar to a MongoDB ObjectID, - // but compatible with TSQLRecord.ID: TID properties, since it will contain - // a 63-bit unsigned integer, following our ORM expectations - // - each identifier would contain a 16-bit process identifier, which is - // supplied by the application, and should be unique for this process at a - // given time - // - identifiers may be obfuscated as hexadecimal text, using both encryption - // and digital signature - TSynUniqueIdentifierGenerator = class(TSynPersistent) - protected - fUnixCreateTime: cardinal; - fLatestCounterOverflowUnixCreateTime: cardinal; - fIdentifier: TSynUniqueIdentifierProcess; - fIdentifierShifted: cardinal; - fLastCounter: cardinal; - fCrypto: array[0..7] of cardinal; // only fCrypto[6..7] are used in practice - fCryptoCRC: cardinal; - fSafe: TSynLocker; - function GetComputedCount: Int64; - public - /// initialize the generator for the given 16-bit process identifier - // - you can supply an obfuscation key, which should be shared for the - // whole system, so that you may use FromObfuscated/ToObfuscated methods - constructor Create(aIdentifier: TSynUniqueIdentifierProcess; - const aSharedObfuscationKey: RawUTF8=''); reintroduce; - /// finalize the generator structure - destructor Destroy; override; - /// return a new unique ID - // - this method is very optimized, and would use very little CPU - procedure ComputeNew(out result: TSynUniqueIdentifierBits); overload; - /// return a new unique ID, type-casted to an Int64 - function ComputeNew: Int64; overload; - {$ifdef HASINLINE}inline;{$endif} - /// return an unique ID matching this generator pattern, at a given timestamp - // - may be used e.g. to limit database queries on a particular time range - procedure ComputeFromDateTime(const aDateTime: TDateTime; out result: TSynUniqueIdentifierBits); - /// return an unique ID matching this generator pattern, at a given timestamp - // - may be used e.g. to limit database queries on a particular time range - procedure ComputeFromUnixTime(const aUnixTime: TUnixTime; out result: TSynUniqueIdentifierBits); - /// map a TSynUniqueIdentifier as 24 chars cyphered hexadecimal text - // - cyphering includes simple key-based encryption and a CRC-32 digital signature - function ToObfuscated(const aIdentifier: TSynUniqueIdentifier): TSynUniqueIdentifierObfuscated; - /// retrieve a TSynUniqueIdentifier from 24 chars cyphered hexadecimal text - // - any file extension (e.g. '.jpeg') would be first deleted from the - // supplied obfuscated text - // - returns true if the supplied obfuscated text has the expected layout - // and a valid digital signature - // - returns false if the supplied obfuscated text is invalid - function FromObfuscated(const aObfuscated: TSynUniqueIdentifierObfuscated; - out aIdentifier: TSynUniqueIdentifier): boolean; - /// some 32-bit value, derivated from aSharedObfuscationKey as supplied - // to the class constructor - // - FromObfuscated and ToObfuscated methods will validate their hexadecimal - // content with this value to secure the associated CRC - // - may be used e.g. as system-depending salt - property CryptoCRC: cardinal read fCryptoCRC; - /// direct access to the associated mutex - property Safe: TSynLocker read fSafe; - published - /// the process identifier, associated with this generator - property Identifier: TSynUniqueIdentifierProcess read fIdentifier; - /// how many times ComputeNew method has been called - property ComputedCount: Int64 read GetComputedCount; - end; - -type - /// abstract TSynPersistent class allowing safe storage of a password - // - the associated Password, e.g. for storage or transmission encryption - // will be persisted encrypted with a private key (which can be customized) - // - if default simple symmetric encryption is not enough, you may define - // a custom TSynPersistentWithPasswordUserCrypt callback, e.g. to - // SynCrypto's CryptDataForCurrentUser, for hardened password storage - // - a published property should be defined as such in inherited class: - // ! property PasswordPropertyName: RawUTF8 read fPassword write fPassword; - // - use the PassWordPlain property to access to its uncyphered value - TSynPersistentWithPassword = class(TSynPersistent) - protected - fPassWord: RawUTF8; - fKey: cardinal; - function GetKey: cardinal; {$ifdef HASINLINE}inline;{$endif} - function GetPassWordPlain: RawUTF8; - function GetPassWordPlainInternal(AppSecret: RawUTF8): RawUTF8; - procedure SetPassWordPlain(const Value: RawUTF8); - public - /// finalize the instance - destructor Destroy; override; - /// this class method could be used to compute the encrypted password, - // ready to be stored as JSON, according to a given private key - class function ComputePassword(const PlainPassword: RawUTF8; - CustomKey: cardinal=0): RawUTF8; overload; - /// this class method could be used to compute the encrypted password from - // a binary digest, ready to be stored as JSON, according to a given private key - // - just a wrapper around ComputePassword(BinToBase64URI()) - class function ComputePassword(PlainPassword: pointer; PlainPasswordLen: integer; - CustomKey: cardinal=0): RawUTF8; overload; - /// this class method could be used to decrypt a password, stored as JSON, - // according to a given private key - // - may trigger a ESynException if the password was stored using a custom - // TSynPersistentWithPasswordUserCrypt callback, and the current user - // doesn't match the expected user stored in the field - class function ComputePlainPassword(const CypheredPassword: RawUTF8; - CustomKey: cardinal=0; const AppSecret: RawUTF8=''): RawUTF8; - /// low-level function used to identify if a given field is a Password - // - this method is used e.g. by TJSONSerializer.WriteObject to identify the - // password field, since its published name is set by the inherited classes - function GetPasswordFieldAddress: pointer; {$ifdef HASINLINE}inline;{$endif} - /// the private key used to cypher the password storage on serialization - // - application can override the default 0 value at runtime - property Key: cardinal read GetKey write fKey; - /// access to the associated unencrypted Password value - // - read may trigger a ESynException if the password was stored using a - // custom TSynPersistentWithPasswordUserCrypt callback, and the current user - // doesn't match the expected user stored in the field - property PasswordPlain: RawUTF8 read GetPassWordPlain write SetPassWordPlain; - end; - -var - /// function prototype to customize TSynPersistent class password storage - // - is called when 'user1:base64pass1,user2:base64pass2' layout is found, - // and the current user logged on the system is user1 or user2 - // - you should not call this low-level method, but assign e.g. from SynCrypto: - // $ TSynPersistentWithPasswordUserCrypt := CryptDataForCurrentUser; - TSynPersistentWithPasswordUserCrypt: - function(const Data,AppServer: RawByteString; Encrypt: boolean): RawByteString; - -type - /// could be used to store a credential pair, as user name and password - // - password will be stored with TSynPersistentWithPassword encryption - TSynUserPassword = class(TSynPersistentWithPassword) - protected - fUserName: RawUTF8; - published - /// the associated user name - property UserName: RawUTF8 read FUserName write FUserName; - /// the associated encrypted password - // - use the PasswordPlain public property to access to the uncrypted password - property Password: RawUTF8 read FPassword write FPassword; - end; - - /// handle safe storage of any connection properties - // - would be used by SynDB.pas to serialize TSQLDBConnectionProperties, or - // by mORMot.pas to serialize TSQLRest instances - // - the password will be stored as Base64, after a simple encryption as - // defined by TSynPersistentWithPassword - // - typical content could be: - // $ { - // $ "Kind": "TSQLDBSQLite3ConnectionProperties", - // $ "ServerName": "server", - // $ "DatabaseName": "", - // $ "User": "", - // $ "Password": "PtvlPA==" - // $ } - // - the "Kind" value will be used to let the corresponding TSQLRest or - // TSQLDBConnectionProperties NewInstance*() class methods create the - // actual instance, from its class name - TSynConnectionDefinition = class(TSynPersistentWithPassword) - protected - fKind: string; - fServerName: RawUTF8; - fDatabaseName: RawUTF8; - fUser: RawUTF8; - public - /// unserialize the database definition from JSON - // - as previously serialized with the SaveToJSON method - // - you can specify a custom Key used for password encryption, if the - // default value is not safe enough for you - // - this method won't use JSONToObject() so avoid any dependency to mORMot.pas - constructor CreateFromJSON(const JSON: RawUTF8; Key: cardinal=0); virtual; - /// serialize the database definition as JSON - // - this method won't use ObjectToJSON() so avoid any dependency to mORMot.pas - function SaveToJSON: RawUTF8; virtual; - published - /// the class name implementing the connection or TSQLRest instance - // - will be used to instantiate the expected class type - property Kind: string read fKind write fKind; - /// the associated server name (or file, for SQLite3) to be connected to - property ServerName: RawUTF8 read fServerName write fServerName; - /// the associated database name (if any), or additional options - property DatabaseName: RawUTF8 read fDatabaseName write fDatabaseName; - /// the associated User Identifier (if any) - property User: RawUTF8 read fUser write fUser; - /// the associated Password, e.g. for storage or transmission encryption - // - will be persisted encrypted with a private key - // - use the PassWordPlain property to access to its uncyphered value - property Password: RawUTF8 read fPassword write fPassword; - end; - - -type - /// class-reference type (metaclass) of an authentication class - TSynAuthenticationClass = class of TSynAuthenticationAbstract; - - /// abstract authentication class, implementing safe token/challenge security - // and a list of active sessions - // - do not use this class, but plain TSynAuthentication - TSynAuthenticationAbstract = class - protected - fSessions: TIntegerDynArray; - fSessionsCount: Integer; - fSessionGenerator: integer; - fTokenSeed: Int64; - fSafe: TSynLocker; - function ComputeCredential(previous: boolean; const UserName,PassWord: RawUTF8): cardinal; virtual; - function GetPassword(const UserName: RawUTF8; out Password: RawUTF8): boolean; virtual; abstract; - function GetUsersCount: integer; virtual; abstract; - // check the given Hash challenge, against stored credentials - function CheckCredentials(const UserName: RaWUTF8; Hash: cardinal): boolean; virtual; - public - /// initialize the authentication scheme - constructor Create; - /// finalize the authentation - destructor Destroy; override; - /// register one credential for a given user - // - this abstract method will raise an exception: inherited classes should - // implement them as expected - procedure AuthenticateUser(const aName, aPassword: RawUTF8); virtual; - /// unregister one credential for a given user - // - this abstract method will raise an exception: inherited classes should - // implement them as expected - procedure DisauthenticateUser(const aName: RawUTF8); virtual; - /// create a new session - // - should return 0 on authentication error, or an integer session ID - // - this method will check the User name and password, and create a new session - function CreateSession(const User: RawUTF8; Hash: cardinal): integer; virtual; - /// check if the session exists in the internal list - function SessionExists(aID: integer): boolean; - /// delete a session - procedure RemoveSession(aID: integer); - /// returns the current identification token - // - to be sent to the client for its authentication challenge - function CurrentToken: Int64; - /// the number of current opened sessions - property SessionsCount: integer read fSessionsCount; - /// the number of registered users - property UsersCount: integer read GetUsersCount; - /// to be used to compute a Hash on the client sude, for a given Token - // - the token should have been retrieved from the server, and the client - // should compute and return this hash value, to perform the authentication - // challenge and create the session - // - internal algorithm is not cryptographic secure, but fast and safe - class function ComputeHash(Token: Int64; const UserName,PassWord: RawUTF8): cardinal; virtual; - end; - - /// simple authentication class, implementing safe token/challenge security - // - maintain a list of user / name credential pairs, and a list of sessions - // - is not meant to handle authorization, just plain user access validation - // - used e.g. by TSQLDBConnection.RemoteProcessMessage (on server side) and - // TSQLDBProxyConnectionPropertiesAbstract (on client side) in SynDB.pas - TSynAuthentication = class(TSynAuthenticationAbstract) - protected - fCredentials: TSynNameValue; // store user/password pairs - function GetPassword(const UserName: RawUTF8; out Password: RawUTF8): boolean; override; - function GetUsersCount: integer; override; - public - /// initialize the authentication scheme - // - you can optionally register one user credential - constructor Create(const aUserName: RawUTF8=''; const aPassword: RawUTF8=''); reintroduce; - /// register one credential for a given user - procedure AuthenticateUser(const aName, aPassword: RawUTF8); override; - /// unregister one credential for a given user - procedure DisauthenticateUser(const aName: RawUTF8); override; - end; - -type - /// optimized thread-safe storage of a list of IP v4 adresses - // - can be used e.g. as white-list or black-list of clients - // - will maintain internally a sorted list of 32-bit integers for fast lookup - // - with optional binary persistence - TIPBan = class(TSynPersistentStore) - protected - fIP4: TIntegerDynArray; - fCount: integer; - procedure LoadFromReader; override; - procedure SaveToWriter(aWriter: TFileBufferWriter); override; - public - /// register one IP to the list - function Add(const aIP: RawUTF8): boolean; - /// unregister one IP to the list - function Delete(const aIP: RawUTF8): boolean; - /// returns true if the IP is in the list - function Exists(const aIP: RawUTF8): boolean; - /// creates a TDynArray wrapper around the stored list of values - // - could be used e.g. for binary persistence - // - warning: caller should make Safe.Unlock when finished - function DynArrayLocked: TDynArray; - /// low-level access to the internal IPv4 list - // - 32-bit unsigned values are sorted, for fast O(log(n)) binary search - property IP4: TIntegerDynArray read fIP4; - published - /// how many IPs are currently banned - property Count: integer read fCount; - end; - - -{ ************ Expression Search Engine ************************** } - -type - /// exception type used by TExprParser - EExprParser = class(ESynException); - - /// identify an expression search engine node type, as used by TExprParser - TExprNodeType = (entWord, entNot, entOr, entAnd); - - /// results returned by TExprParserAbstract.Parse method - TExprParserResult = ( - eprSuccess, eprNoExpression, - eprMissingParenthesis, eprTooManyParenthesis, eprMissingFinalWord, - eprInvalidExpression, eprUnknownVariable, eprUnsupportedOperator, - eprInvalidConstantOrVariable); - - TParserAbstract = class; - - /// stores an expression search engine node, as used by TExprParser - TExprNode = class(TSynPersistent) - protected - fNext: TExprNode; - fNodeType: TExprNodeType; - function Append(node: TExprNode): boolean; - public - /// initialize a node for the search engine - constructor Create(nodeType: TExprNodeType); reintroduce; - /// recursively destroys the linked list of nodes (i.e. Next) - destructor Destroy; override; - /// browse all nodes until Next = nil - function Last: TExprNode; - /// points to the next node in the parsed tree - property Next: TExprNode read fNext; - /// what is actually stored in this node - property NodeType: TExprNodeType read fNodeType; - end; - - /// abstract class to handle word search, as used by TExprParser - TExprNodeWordAbstract = class(TExprNode) - protected - fOwner: TParserAbstract; - fWord: RawUTF8; - /// should be set from actual data before TExprParser.Found is called - fFound: boolean; - function ParseWord: TExprParserResult; virtual; abstract; - public - /// you should override this virtual constructor for proper initialization - constructor Create(aOwner: TParserAbstract; const aWord: RawUTF8); reintroduce; virtual; - end; - - /// class-reference type (metaclass) for a TExprNode - // - allow to customize the actual searching process for entWord - TExprNodeWordClass = class of TExprNodeWordAbstract; - - /// parent class of TExprParserAbstract - TParserAbstract = class(TSynPersistent) - protected - fExpression, fCurrentWord, fAndWord, fOrWord, fNotWord: RawUTF8; - fCurrent: PUTF8Char; - fCurrentError: TExprParserResult; - fFirstNode: TExprNode; - fWordClass: TExprNodeWordClass; - fWords: array of TExprNodeWordAbstract; - fWordCount: integer; - fNoWordIsAnd: boolean; - fFoundStack: array[byte] of boolean; // simple stack-based virtual machine - procedure ParseNextCurrentWord; virtual; abstract; - function ParseExpr: TExprNode; - function ParseFactor: TExprNode; - function ParseTerm: TExprNode; - procedure Clear; virtual; - // override this method to initialize fWordClass and fAnd/Or/NotWord - procedure Initialize; virtual; abstract; - /// perform the expression search over TExprNodeWord.fFound flags - // - warning: caller should check that fFirstNode<>nil (e.g. WordCount>0) - function Execute: boolean; {$ifdef HASINLINE}inline;{$endif} - public - /// initialize an expression parser - constructor Create; override; - /// finalize the expression parser - destructor Destroy; override; - /// initialize the parser from a given text expression - function Parse(const aExpression: RawUTF8): TExprParserResult; - /// try this parser class on a given text expression - // - returns '' on success, or an explicit error message (e.g. - // 'Missing parenthesis') - class function ParseError(const aExpression: RawUTF8): RawUTF8; - /// the associated text expression used to define the search - property Expression: RawUTF8 read fExpression; - /// how many words did appear in the search expression - property WordCount: integer read fWordCount; - end; - - /// abstract class to parse a text expression into nodes - // - you should inherit this class to provide actual text search - // - searched expressions can use parenthesis and &=AND -=WITHOUT +=OR operators, - // e.g. '((w1 & w2) - w3) + w4' means ((w1 and w2) without w3) or w4 - // - no operator is handled like a AND, e.g. 'w1 w2' = 'w1 & w2' - TExprParserAbstract = class(TParserAbstract) - protected - procedure ParseNextCurrentWord; override; - // may be overriden to provide custom words escaping (e.g. handle quotes) - procedure ParseNextWord; virtual; - procedure Initialize; override; - end; - - /// search expression engine using TMatch for the actual word searches - TExprParserMatch = class(TExprParserAbstract) - protected - fCaseSensitive: boolean; - fMatchedLastSet: integer; - procedure Initialize; override; - public - /// initialize the search engine - constructor Create(aCaseSensitive: boolean = true); reintroduce; - /// returns TRUE if the expression is within the text buffer - function Search(aText: PUTF8Char; aTextLen: PtrInt): boolean; overload; - /// returns TRUE if the expression is within the text buffer - function Search(const aText: RawUTF8): boolean; overload; {$ifdef HASINLINE}inline;{$endif} - end; - -const - /// may be used when overriding TExprParserAbstract.ParseNextWord method - PARSER_STOPCHAR = ['&', '+', '-', '(', ')']; - -function ToText(r: TExprParserResult): PShortString; overload; -function ToUTF8(r: TExprParserResult): RawUTF8; overload; - - -{ ************ Multi-Threading classes ************************** } - -type - /// internal item definition, used by TPendingTaskList storage - TPendingTaskListItem = packed record - /// the task should be executed when TPendingTaskList.GetTimestamp reaches - // this value - Timestamp: Int64; - /// the associated task, stored by representation as raw binary - Task: RawByteString; - end; - /// internal list definition, used by TPendingTaskList storage - TPendingTaskListItemDynArray = array of TPendingTaskListItem; - - /// handle a list of tasks, stored as RawByteString, with a time stamp - // - internal time stamps would be GetTickCount64 by default, so have a - // resolution of about 16 ms under Windows - // - you can add tasks to the internal list, to be executed after a given - // delay, using a post/peek like algorithm - // - execution delays are not expected to be accurate, but are best guess, - // according to NextTask call - // - this implementation is thread-safe, thanks to the Safe internal locker - TPendingTaskList = class(TSynPersistentLock) - protected - fCount: Integer; - fTask: TPendingTaskListItemDynArray; - fTasks: TDynArray; - function GetCount: integer; - function GetTimestamp: Int64; virtual; - public - /// initialize the list memory and resources - constructor Create; override; - /// append a task, specifying a delay in milliseconds from current time - procedure AddTask(aMilliSecondsDelayFromNow: integer; const aTask: RawByteString); virtual; - /// append several tasks, specifying a delay in milliseconds between tasks - // - first supplied delay would be computed from the current time, then - // it would specify how much time to wait between the next supplied task - procedure AddTasks(const aMilliSecondsDelays: array of integer; - const aTasks: array of RawByteString); - /// retrieve the next pending task - // - returns '' if there is no scheduled task available at the current time - // - returns the next stack as defined corresponding to its specified delay - function NextPendingTask: RawByteString; virtual; - /// flush all pending tasks - procedure Clear; virtual; - /// access to the internal TPendingTaskListItem.Timestamp stored value - // - corresponding to the current time - // - default implementation is to return GetTickCount64, with a 16 ms - // typical resolution under Windows - property Timestamp: Int64 read GetTimestamp; - /// how many pending tasks are currently defined - property Count: integer read GetCount; - /// direct low-level access to the internal task list - // - warning: this dynamic array length is the list capacity: use Count - // property to retrieve the exact number of stored items - // - use Safe.Lock/TryLock with a try ... finally Safe.Unlock block for - // thread-safe access to this array - // - items are stored in increasing Timestamp, i.e. the first item is - // the next one which would be returned by the NextPendingTask method - property Task: TPendingTaskListItemDynArray read fTask; - end; - -{$ifndef LVCL} // LVCL does not implement TEvent - -type - {$M+} - TSynBackgroundThreadAbstract = class; - TSynBackgroundThreadEvent = class; - {$M-} - - /// idle method called by TSynBackgroundThreadAbstract in the caller thread - // during remote blocking process in a background thread - // - typical use is to run Application.ProcessMessages, e.g. for - // TSQLRestClientURI.URI() to provide a responsive UI even in case of slow - // blocking remote access - // - provide the time elapsed (in milliseconds) from the request start (can be - // used e.g. to popup a temporary message to wait) - // - is call once with ElapsedMS=0 at request start - // - is call once with ElapsedMS=-1 at request ending - // - see TLoginForm.OnIdleProcess and OnIdleProcessForm in mORMotUILogin.pas - TOnIdleSynBackgroundThread = procedure(Sender: TSynBackgroundThreadAbstract; - ElapsedMS: Integer) of object; - - /// event prototype used e.g. by TSynBackgroundThreadAbstract callbacks - // - a similar signature is defined in SynCrtSock and LVCL.Classes - TNotifyThreadEvent = procedure(Sender: TThread) of object; - - /// abstract TThread with its own execution content - // - you should not use this class directly, but use either - // TSynBackgroundThreadMethodAbstract / TSynBackgroundThreadEvent / - // TSynBackgroundThreadMethod and provide a much more convenient callback - TSynBackgroundThreadAbstract = class(TThread) - protected - fProcessEvent: TEvent; - fOnBeforeExecute: TNotifyThreadEvent; - fOnAfterExecute: TNotifyThreadEvent; - fThreadName: RawUTF8; - fExecute: (exCreated,exRun,exFinished); - fExecuteLoopPause: boolean; - procedure SetExecuteLoopPause(dopause: boolean); - /// where the main process takes place - procedure Execute; override; - procedure ExecuteLoop; virtual; abstract; - public - /// initialize the thread - // - you could define some callbacks to nest the thread execution, e.g. - // assigned to TSQLRestServer.BeginCurrentThread/EndCurrentThread, or - // at least set OnAfterExecute to TSynLogFamily.OnThreadEnded - constructor Create(const aThreadName: RawUTF8; OnBeforeExecute: TNotifyThreadEvent=nil; - OnAfterExecute: TNotifyThreadEvent=nil; CreateSuspended: boolean=false); reintroduce; - /// release used resources - destructor Destroy; override; - {$ifndef HASTTHREADSTART} - /// method to be called to start the thread - // - Resume is deprecated in the newest RTL, since some OS - e.g. Linux - - // do not implement this pause/resume feature; we define here this method - // for older versions of Delphi - procedure Start; - {$endif} - {$ifdef HASTTHREADTERMINATESET} - /// properly terminate the thread - // - called by TThread.Terminate - procedure TerminatedSet; override; - {$else} - /// properly terminate the thread - // - called by reintroduced Terminate - procedure TerminatedSet; virtual; - /// reintroduced to call TeminatedSet - procedure Terminate; reintroduce; - {$endif} - /// wait for Execute/ExecuteLoop to be ended (i.e. fExecute<>exRun) - procedure WaitForNotExecuting(maxMS: integer=500); - /// temporary stop the execution of ExecuteLoop, until set back to false - // - may be used e.g. by TSynBackgroundTimer to delay the process of - // background tasks - property Pause: boolean read fExecuteLoopPause write SetExecuteLoopPause; - /// access to the low-level associated event used to notify task execution - // to the background thread - // - you may call ProcessEvent.SetEvent to trigger the internal process loop - property ProcessEvent: TEvent read fProcessEvent; - /// defined as public since may be used to terminate the processing methods - property Terminated; - end; - - /// state machine status of the TSynBackgroundThreadAbstract process - TSynBackgroundThreadProcessStep = ( - flagIdle, flagStarted, flagFinished, flagDestroying); - - /// state machine statuses of the TSynBackgroundThreadAbstract process - TSynBackgroundThreadProcessSteps = set of TSynBackgroundThreadProcessStep; - - /// abstract TThread able to run a method in its own execution content - // - typical use is a background thread for processing data or remote access, - // while the UI will be still responsive by running OnIdle event in loop: see - // e.g. how TSQLRestClientURI.OnIdle handle this in mORMot.pas unit - // - you should not use this class directly, but inherit from it and override - // the Process method, or use either TSynBackgroundThreadEvent / - // TSynBackgroundThreadMethod and provide a much more convenient callback - TSynBackgroundThreadMethodAbstract = class(TSynBackgroundThreadAbstract) - protected - fCallerEvent: TEvent; - fParam: pointer; - fCallerThreadID: TThreadID; - fBackgroundException: Exception; - fOnIdle: TOnIdleSynBackgroundThread; - fOnBeforeProcess: TNotifyThreadEvent; - fOnAfterProcess: TNotifyThreadEvent; - fPendingProcessFlag: TSynBackgroundThreadProcessStep; - fPendingProcessLock: TSynLocker; - procedure ExecuteLoop; override; - function OnIdleProcessNotify(start: Int64): integer; - function GetOnIdleBackgroundThreadActive: boolean; - function GetPendingProcess: TSynBackgroundThreadProcessStep; - procedure SetPendingProcess(State: TSynBackgroundThreadProcessStep); - // returns flagIdle if acquired, flagDestroying if terminated - function AcquireThread: TSynBackgroundThreadProcessStep; - procedure WaitForFinished(start: Int64; const onmainthreadidle: TNotifyEvent); - /// called by Execute method when fProcessParams<>nil and fEvent is notified - procedure Process; virtual; abstract; - public - /// initialize the thread - // - if aOnIdle is not set (i.e. equals nil), it will simply wait for - // the background process to finish until RunAndWait() will return - // - you could define some callbacks to nest the thread execution, e.g. - // assigned to TSQLRestServer.BeginCurrentThread/EndCurrentThread - constructor Create(aOnIdle: TOnIdleSynBackgroundThread; - const aThreadName: RawUTF8; OnBeforeExecute: TNotifyThreadEvent=nil; - OnAfterExecute: TNotifyThreadEvent=nil); reintroduce; - /// finalize the thread - destructor Destroy; override; - /// launch Process abstract method asynchronously in the background thread - // - wait until process is finished, calling OnIdle() callback in - // the meanwhile - // - any exception raised in background thread will be translated in the - // caller thread - // - returns false if self is not set, or if called from the same thread - // as it is currently processing (to avoid race condition from OnIdle() - // callback) - // - returns true when the background process is finished - // - OpaqueParam will be used to specify a thread-safe content for the - // background process - // - this method is thread-safe, that is it will wait for any started process - // already launch by another thread: you may call this method from any - // thread, even if its main purpose is to be called from the main UI thread - function RunAndWait(OpaqueParam: pointer): boolean; - /// set a callback event to be executed in loop during remote blocking - // process, e.g. to refresh the UI during a somewhat long request - // - you can assign a callback to this property, calling for instance - // Application.ProcessMessages, to execute the remote request in a - // background thread, but let the UI still be reactive: the - // TLoginForm.OnIdleProcess and OnIdleProcessForm methods of - // mORMotUILogin.pas will match this property expectations - // - if OnIdle is not set (i.e. equals nil), it will simply wait for - // the background process to finish until RunAndWait() will return - property OnIdle: TOnIdleSynBackgroundThread read fOnIdle write fOnIdle; - /// TRUE if the background thread is active, and OnIdle event is called - // during process - // - to be used e.g. to ensure no re-entrance from User Interface messages - property OnIdleBackgroundThreadActive: Boolean read GetOnIdleBackgroundThreadActive; - /// optional callback event triggered in Execute before each Process - property OnBeforeProcess: TNotifyThreadEvent read fOnBeforeProcess write fOnBeforeProcess; - /// optional callback event triggered in Execute after each Process - property OnAfterProcess: TNotifyThreadEvent read fOnAfterProcess write fOnAfterProcess; - end; - - /// background process method called by TSynBackgroundThreadEvent - // - will supply the OpaqueParam parameter as provided to RunAndWait() - // method when the Process virtual method will be executed - TOnProcessSynBackgroundThread = procedure(Sender: TSynBackgroundThreadEvent; - ProcessOpaqueParam: pointer) of object; - - /// allow background thread process of a method callback - TSynBackgroundThreadEvent = class(TSynBackgroundThreadMethodAbstract) - protected - fOnProcess: TOnProcessSynBackgroundThread; - /// just call the OnProcess handler - procedure Process; override; - public - /// initialize the thread - // - if aOnIdle is not set (i.e. equals nil), it will simply wait for - // the background process to finish until RunAndWait() will return - constructor Create(aOnProcess: TOnProcessSynBackgroundThread; - aOnIdle: TOnIdleSynBackgroundThread; const aThreadName: RawUTF8); reintroduce; - /// provide a method handler to be execute in the background thread - // - triggered by RunAndWait() method - which will wait until finished - // - the OpaqueParam as specified to RunAndWait() will be supplied here - property OnProcess: TOnProcessSynBackgroundThread read fOnProcess write fOnProcess; - end; - - /// allow background thread process of a variable TThreadMethod callback - TSynBackgroundThreadMethod = class(TSynBackgroundThreadMethodAbstract) - protected - /// just call the TThreadMethod, as supplied to RunAndWait() - procedure Process; override; - public - /// run once the supplied TThreadMethod callback - // - use this method, and not the inherited RunAndWait() - procedure RunAndWait(Method: TThreadMethod); reintroduce; - end; - - /// background process procedure called by TSynBackgroundThreadProcedure - // - will supply the OpaqueParam parameter as provided to RunAndWait() - // method when the Process virtual method will be executed - TOnProcessSynBackgroundThreadProc = procedure(ProcessOpaqueParam: pointer); - - /// allow background thread process of a procedure callback - TSynBackgroundThreadProcedure = class(TSynBackgroundThreadMethodAbstract) - protected - fOnProcess: TOnProcessSynBackgroundThreadProc; - /// just call the OnProcess handler - procedure Process; override; - public - /// initialize the thread - // - if aOnIdle is not set (i.e. equals nil), it will simply wait for - // the background process to finish until RunAndWait() will return - constructor Create(aOnProcess: TOnProcessSynBackgroundThreadProc; - aOnIdle: TOnIdleSynBackgroundThread; const aThreadName: RawUTF8); reintroduce; - /// provide a procedure handler to be execute in the background thread - // - triggered by RunAndWait() method - which will wait until finished - // - the OpaqueParam as specified to RunAndWait() will be supplied here - property OnProcess: TOnProcessSynBackgroundThreadProc read fOnProcess write fOnProcess; - end; - - /// an exception which would be raised by TSynParallelProcess - ESynParallelProcess = class(ESynException); - - /// callback implementing some parallelized process for TSynParallelProcess - // - if 0<=IndexStart<=IndexStop, it should execute some process - TSynParallelProcessMethod = procedure(IndexStart, IndexStop: integer) of object; - - /// thread executing process for TSynParallelProcess - TSynParallelProcessThread = class(TSynBackgroundThreadMethodAbstract) - protected - fMethod: TSynParallelProcessMethod; - fIndexStart, fIndexStop: integer; - procedure Start(Method: TSynParallelProcessMethod; IndexStart,IndexStop: integer); - /// executes fMethod(fIndexStart,fIndexStop) - procedure Process; override; - public - end; - - /// allow parallel execution of an index-based process in a thread pool - // - will create its own thread pool, then execute any method by spliting the - // work into each thread - TSynParallelProcess = class(TSynPersistentLock) - protected - fThreadName: RawUTF8; - fPool: array of TSynParallelProcessThread; - fThreadPoolCount: integer; - fParallelRunCount: integer; - public - /// initialize the thread pool - // - you could define some callbacks to nest the thread execution, e.g. - // assigned to TSQLRestServer.BeginCurrentThread/EndCurrentThread - // - up to MaxThreadPoolCount=32 threads could be setup (you may allow a - // bigger value, but interrest of this thread pool is to have its process - // saturating each CPU core) - // - if ThreadPoolCount is 0, no thread would be created, and process - // would take place in the current thread - constructor Create(ThreadPoolCount: integer; const ThreadName: RawUTF8; - OnBeforeExecute: TNotifyThreadEvent=nil; OnAfterExecute: TNotifyThreadEvent=nil; - MaxThreadPoolCount: integer = 32); reintroduce; virtual; - /// finalize the thread pool - destructor Destroy; override; - /// run a method in parallel, and wait for the execution to finish - // - will split Method[0..MethodCount-1] execution over the threads - // - in case of any exception during process, an ESynParallelProcess - // exception would be raised by this method - // - if OnMainThreadIdle is set, the current thread (which is expected to be - // e.g. the main UI thread) won't process anything, but call this event - // during waiting for the background threads - procedure ParallelRunAndWait(const Method: TSynParallelProcessMethod; - MethodCount: integer; const OnMainThreadIdle: TNotifyEvent = nil); - published - /// how many threads have been activated - property ParallelRunCount: integer read fParallelRunCount; - /// how many threads are currently in this instance thread pool - property ThreadPoolCount: integer read fThreadPoolCount; - /// some text identifier, used to distinguish each owned thread - property ThreadName: RawUTF8 read fThreadName; - end; - - TSynBackgroundThreadProcess = class; - - /// event callback executed periodically by TSynBackgroundThreadProcess - // - Event is wrTimeout after the OnProcessMS waiting period - // - Event is wrSignaled if ProcessEvent.SetEvent has been called - TOnSynBackgroundThreadProcess = procedure(Sender: TSynBackgroundThreadProcess; - Event: TWaitResult) of object; - - /// TThread able to run a method at a given periodic pace - TSynBackgroundThreadProcess = class(TSynBackgroundThreadAbstract) - protected - fOnProcess: TOnSynBackgroundThreadProcess; - fOnException: TNotifyEvent; - fOnProcessMS: cardinal; - fStats: TSynMonitor; - procedure ExecuteLoop; override; - public - /// initialize the thread for a periodic task processing - // - aOnProcess would be called when ProcessEvent.SetEvent is called or - // aOnProcessMS milliseconds period was elapse since last process - // - if aOnProcessMS is 0, will wait until ProcessEvent.SetEvent is called - // - you could define some callbacks to nest the thread execution, e.g. - // assigned to TSQLRestServer.BeginCurrentThread/EndCurrentThread - constructor Create(const aThreadName: RawUTF8; - aOnProcess: TOnSynBackgroundThreadProcess; aOnProcessMS: cardinal; - aOnBeforeExecute: TNotifyThreadEvent=nil; - aOnAfterExecute: TNotifyThreadEvent=nil; - aStats: TSynMonitorClass=nil; CreateSuspended: boolean=false); reintroduce; virtual; - /// finalize the thread - destructor Destroy; override; - /// access to the implementation event of the periodic task - property OnProcess: TOnSynBackgroundThreadProcess read fOnProcess; - /// event callback executed when OnProcess did raise an exception - // - supplied Sender parameter is the raised Exception instance - property OnException: TNotifyEvent read fOnException write fOnException; - published - /// access to the delay, in milliseconds, of the periodic task processing - property OnProcessMS: cardinal read fOnProcessMS write fOnProcessMS; - /// processing statistics - // - may be nil if aStats was nil in the class constructor - property Stats: TSynMonitor read fStats; - end; - - TSynBackgroundTimer = class; - - /// event callback executed periodically by TSynBackgroundThreadProcess - // - Event is wrTimeout after the OnProcessMS waiting period - // - Event is wrSignaled if ProcessEvent.SetEvent has been called - // - Msg is '' if there is no pending message in this task FIFO - // - Msg is set for each pending message in this task FIFO - TOnSynBackgroundTimerProcess = procedure(Sender: TSynBackgroundTimer; - Event: TWaitResult; const Msg: RawUTF8) of object; - - /// used by TSynBackgroundTimer internal registration list - TSynBackgroundTimerTask = record - OnProcess: TOnSynBackgroundTimerProcess; - Secs: cardinal; - NextTix: Int64; - FIFO: TRawUTF8DynArray; - end; - /// stores TSynBackgroundTimer internal registration list - TSynBackgroundTimerTaskDynArray = array of TSynBackgroundTimerTask; - - /// TThread able to run one or several tasks at a periodic pace in a - // background thread - // - as used e.g. by TSQLRest.TimerEnable/TimerDisable methods, via the - // inherited TSQLRestBackgroundTimer - // - each process can have its own FIFO of text messages - // - if you expect to update some GUI, you should rather use a TTimer - // component (with a period of e.g. 200ms), since TSynBackgroundTimer will - // use its own separated thread - TSynBackgroundTimer = class(TSynBackgroundThreadProcess) - protected - fTask: TSynBackgroundTimerTaskDynArray; - fTasks: TDynArray; - fTaskLock: TSynLocker; - procedure EverySecond(Sender: TSynBackgroundThreadProcess; Event: TWaitResult); - function Find(const aProcess: TMethod): integer; - function Add(aOnProcess: TOnSynBackgroundTimerProcess; - const aMsg: RawUTF8; aExecuteNow: boolean): boolean; - public - /// initialize the thread for a periodic task processing - // - you could define some callbacks to nest the thread execution, e.g. - // assigned to TSQLRestServer.BeginCurrentThread/EndCurrentThread, as - // made by TSQLRestBackgroundTimer.Create - constructor Create(const aThreadName: RawUTF8; - aOnBeforeExecute: TNotifyThreadEvent=nil; aOnAfterExecute: TNotifyThreadEvent=nil; - aStats: TSynMonitorClass=nil); reintroduce; virtual; - /// finalize the thread - destructor Destroy; override; - /// define a process method for a task running on a periodic number of seconds - // - for background process on a mORMot service, consider using TSQLRest - // TimerEnable/TimerDisable methods, and its associated BackgroundTimer thread - procedure Enable(aOnProcess: TOnSynBackgroundTimerProcess; aOnProcessSecs: cardinal); - /// undefine a task running on a periodic number of seconds - // - aOnProcess should have been registered by a previous call to Enable() method - // - returns true on success, false if the supplied task was not registered - // - for background process on a mORMot service, consider using TSQLRestServer - // TimerEnable/TimerDisable methods, and their TSynBackgroundTimer thread - function Disable(aOnProcess: TOnSynBackgroundTimerProcess): boolean; - /// add a message to be processed during the next execution of a task - // - supplied message will be added to the internal FIFO list associated - // with aOnProcess, then supplied to as aMsg parameter for each call - // - if aExecuteNow is true, won't wait for the next aOnProcessSecs occurence - // - aOnProcess should have been registered by a previous call to Enable() method - // - returns true on success, false if the supplied task was not registered - function EnQueue(aOnProcess: TOnSynBackgroundTimerProcess; - const aMsg: RawUTF8; aExecuteNow: boolean=false): boolean; overload; - /// add a message to be processed during the next execution of a task - // - supplied message will be added to the internal FIFO list associated - // with aOnProcess, then supplied to as aMsg parameter for each call - // - if aExecuteNow is true, won't wait for the next aOnProcessSecs occurence - // - aOnProcess should have been registered by a previous call to Enable() method - // - returns true on success, false if the supplied task was not registered - function EnQueue(aOnProcess: TOnSynBackgroundTimerProcess; - const aMsgFmt: RawUTF8; const Args: array of const; aExecuteNow: boolean=false): boolean; overload; - /// remove a message from the processing list - // - supplied message will be searched in the internal FIFO list associated - // with aOnProcess, then removed from the list if found - // - aOnProcess should have been registered by a previous call to Enable() method - // - returns true on success, false if the supplied message was not registered - function DeQueue(aOnProcess: TOnSynBackgroundTimerProcess; const aMsg: RawUTF8): boolean; - /// execute a task without waiting for the next aOnProcessSecs occurence - // - aOnProcess should have been registered by a previous call to Enable() method - // - returns true on success, false if the supplied task was not registered - function ExecuteNow(aOnProcess: TOnSynBackgroundTimerProcess): boolean; - /// returns true if there is currenly one task processed - function Processing: boolean; - /// wait until no background task is processed - procedure WaitUntilNotProcessing(timeoutsecs: integer=10); - /// low-level access to the internal task list - property Task: TSynBackgroundTimerTaskDynArray read fTask; - /// low-level access to the internal task mutex - property TaskLock: TSynLocker read fTaskLock; - end; - - /// the current state of a TBlockingProcess instance - TBlockingEvent = (evNone,evWaiting,evTimeOut,evRaised); - - {$M+} - /// a semaphore used to wait for some process to be finished - // - used e.g. by TBlockingCallback in mORMot.pas - // - once created, process would block via a WaitFor call, which would be - // released when NotifyFinished is called by the process background thread - TBlockingProcess = class(TEvent) - protected - fTimeOutMs: integer; - fEvent: TBlockingEvent; - fSafe: PSynLocker; - fOwnedSafe: boolean; - procedure ResetInternal; virtual; // override to reset associated params - public - /// initialize the semaphore instance - // - specify a time out millliseconds period after which blocking execution - // should be handled as failure (if 0 is set, default 3000 would be used) - // - an associated mutex shall be supplied - constructor Create(aTimeOutMs: integer; aSafe: PSynLocker); reintroduce; overload; virtual; - /// initialize the semaphore instance - // - specify a time out millliseconds period after which blocking execution - // should be handled as failure (if 0 is set, default 3000 would be used) - // - an associated mutex would be created and owned by this instance - constructor Create(aTimeOutMs: integer); reintroduce; overload; virtual; - /// finalize the instance - destructor Destroy; override; - /// called to wait for NotifyFinished() to be called, or trigger timeout - // - returns the final state of the process, i.e. evRaised or evTimeOut - function WaitFor: TBlockingEvent; reintroduce; overload; virtual; - /// called to wait for NotifyFinished() to be called, or trigger timeout - // - returns the final state of the process, i.e. evRaised or evTimeOut - function WaitFor(TimeOutMS: integer): TBlockingEvent; reintroduce; overload; - /// should be called by the background process when it is finished - // - the caller would then let its WaitFor method return - // - returns TRUE on success (i.e. status was not evRaised or evTimeout) - // - if the instance is already locked (e.g. when retrieved from - // TBlockingProcessPool.FromCallLocked), you may set alreadyLocked=TRUE - function NotifyFinished(alreadyLocked: boolean=false): boolean; virtual; - /// just a wrapper to reset the internal Event state to evNone - // - may be used to re-use the same TBlockingProcess instance, after - // a successfull WaitFor/NotifyFinished process - // - returns TRUE on success (i.e. status was not evWaiting), setting - // the current state to evNone, and the Call property to 0 - // - if there is a WaitFor currently in progress, returns FALSE - function Reset: boolean; virtual; - /// just a wrapper around fSafe^.Lock - procedure Lock; - /// just a wrapper around fSafe^.Unlock - procedure Unlock; - published - /// the current state of process - // - use Reset method to re-use this instance after a WaitFor process - property Event: TBlockingEvent read fEvent; - /// the time out period, in ms, as defined at constructor level - property TimeOutMs: integer read fTimeOutMS; - end; - {$M-} - - /// used to identify each TBlockingProcessPool call - // - allow to match a given TBlockingProcessPoolItem semaphore - TBlockingProcessPoolCall = type integer; - - /// a semaphore used in the TBlockingProcessPool - // - such semaphore have a Call field to identify each execution - TBlockingProcessPoolItem = class(TBlockingProcess) - protected - fCall: TBlockingProcessPoolCall; - procedure ResetInternal; override; - published - /// an unique identifier, when owned by a TBlockingProcessPool - // - Reset would restore this field to its 0 default value - property Call: TBlockingProcessPoolCall read fCall; - end; - - /// class-reference type (metaclass) of a TBlockingProcess - TBlockingProcessPoolItemClass = class of TBlockingProcessPoolItem; - - /// manage a pool of TBlockingProcessPoolItem instances - // - each call will be identified via a TBlockingProcessPoolCall unique value - // - to be used to emulate e.g. blocking execution from an asynchronous - // event-driven DDD process - // - it would also allow to re-use TEvent system resources - TBlockingProcessPool = class(TSynPersistent) - protected - fClass: TBlockingProcessPoolItemClass; - fPool: TSynObjectListLocked; - fCallCounter: TBlockingProcessPoolCall; // set TBlockingProcessPoolItem.Call - public - /// initialize the pool, for a given implementation class - constructor Create(aClass: TBlockingProcessPoolItemClass=nil); reintroduce; - /// finalize the pool - // - would also force all pending WaitFor to trigger a evTimeOut - destructor Destroy; override; - /// book a TBlockingProcess from the internal pool - // - returns nil on error (e.g. the instance is destroying) - // - or returns the blocking process instance corresponding to this call; - // its Call property would identify the call for the asynchronous callback, - // then after WaitFor, the Reset method should be run to release the mutex - // for the pool - function NewProcess(aTimeOutMs: integer): TBlockingProcessPoolItem; virtual; - /// retrieve a TBlockingProcess from its call identifier - // - may be used e.g. from the callback of the asynchronous process - // to set some additional parameters to the inherited TBlockingProcess, - // then call NotifyFinished to release the caller WaitFor - // - if leavelocked is TRUE, the returned instance would be locked: caller - // should execute result.Unlock or NotifyFinished(true) after use - function FromCall(call: TBlockingProcessPoolCall; - locked: boolean=false): TBlockingProcessPoolItem; virtual; - end; - -/// allow to fix TEvent.WaitFor() method for Kylix -// - under Windows or with FPC, will call original TEvent.WaitFor() method -function FixedWaitFor(Event: TEvent; Timeout: LongWord): TWaitResult; - -/// allow to fix TEvent.WaitFor(Event,INFINITE) method for Kylix -// - under Windows or with FPC, will call original TEvent.WaitFor() method -procedure FixedWaitForever(Event: TEvent); - -{$endif LVCL} // LVCL does not implement TEvent - - -{ ************ Operating System types and classes ************************** } - -type - /// store CPU and RAM usage for a given process - // - as used by TSystemUse class - TSystemUseData = packed record - /// when the data has been sampled - Timestamp: TDateTime; - /// percent of current Kernel-space CPU usage for this process - Kernel: single; - /// percent of current User-space CPU usage for this process - User: single; - /// how many KB of working memory are used by this process - WorkKB: cardinal; - /// how many KB of virtual memory are used by this process - VirtualKB: cardinal; - end; - /// store CPU and RAM usage history for a given process - // - as returned by TSystemUse.History - TSystemUseDataDynArray = array of TSystemUseData; - - /// low-level structure used to compute process memory and CPU usage - {$ifdef USERECORDWITHMETHODS}TProcessInfo = record - {$else}TProcessInfo = object {$endif} - private - {$ifdef MSWINDOWS} - fSysPrevIdle, fSysPrevKernel, fSysPrevUser, - fDiffIdle, fDiffKernel, fDiffUser, fDiffTotal: Int64; - {$endif} - public - /// initialize the system/process resource tracking - function Init: boolean; - /// to be called before PerSystem() or PerProcess() iteration - function Start: boolean; - /// percent of current Idle/Kernel/User CPU usage for all processes - function PerSystem(out Idle,Kernel,User: currency): boolean; - /// retrieve CPU and RAM usage for a given process - function PerProcess(PID: cardinal; Now: PDateTime; out Data: TSystemUseData; - var PrevKernel, PrevUser: Int64): boolean; - end; - - /// event handler which may be executed by TSystemUse.BackgroundExecute - // - called just after the measurement of each process CPU and RAM consumption - // - run from the background thread, so should not directly make VCL calls, - // unless BackgroundExecute is run from a VCL timer - TOnSystemUseMeasured = procedure(ProcessID: integer; const Data: TSystemUseData) of object; - - /// internal storage of CPU and RAM usage for one process - TSystemUseProcess = record - ID: integer; - Data: TSystemUseDataDynArray; - PrevKernel: Int64; - PrevUser: Int64; - end; - /// internal storage of CPU and RAM usage for a set of processes - TSystemUseProcessDynArray = array of TSystemUseProcess; - - /// monitor CPU and RAM usage of one or several processes - // - you should execute BackgroundExecute on a regular pace (e.g. every second) - // to gather low-level CPU and RAM information for the given set of processes - // - is able to keep an history of latest sample values - // - use Current class function to access a process-wide instance - TSystemUse = class(TSynPersistentLock) - protected - fProcess: TSystemUseProcessDynArray; - fProcesses: TDynArray; - fDataIndex: integer; - fProcessInfo: TProcessInfo; - fHistoryDepth: integer; - fOnMeasured: TOnSystemUseMeasured; - fTimer: TSynBackgroundTimer; - fUnsubscribeProcessOnAccessError: boolean; - function ProcessIndex(aProcessID: integer): integer; - public - /// a TSynBackgroundThreadProcess compatible event - // - matches TOnSynBackgroundTimerProcess callback signature - // - to be supplied e.g. to a TSynBackgroundTimer.Enable method so that it - // will run every few seconds and retrieve the CPU and RAM use - procedure BackgroundExecute(Sender: TSynBackgroundTimer; - Event: TWaitResult; const Msg: RawUTF8); - /// a VCL's TTimer.OnTimer compatible event - // - to be run every few seconds and retrieve the CPU and RAM use: - // ! tmrSystemUse.Interval := 10000; // every 10 seconds - // ! tmrSystemUse.OnTimer := TSystemUse.Current.OnTimerExecute; - procedure OnTimerExecute(Sender: TObject); - /// track the CPU and RAM usage of the supplied set of Process ID - // - any aProcessID[]=0 will be replaced by the current process ID - // - you can specify the number of sample values for the History() method - // - you should then execute the BackgroundExecute method of this instance - // in a VCL timer or from a TSynBackgroundTimer.Enable() registration - constructor Create(const aProcessID: array of integer; - aHistoryDepth: integer=60); reintroduce; overload; virtual; - /// track the CPU and RAM usage of the current process - // - you can specify the number of sample values for the History() method - // - you should then execute the BackgroundExecute method of this instance - // in a VCL timer or from a TSynBackgroundTimer.Enable() registration - constructor Create(aHistoryDepth: integer=60); reintroduce; overload; virtual; - /// add a Process ID to the internal tracking list - procedure Subscribe(aProcessID: integer); - /// remove a Process ID from the internal tracking list - function Unsubscribe(aProcessID: integer): boolean; - /// returns the total (Kernel+User) CPU usage percent of the supplied process - // - aProcessID=0 will return information from the current process - // - returns -1 if the Process ID was not registered via Create/Subscribe - function Percent(aProcessID: integer=0): single; overload; - /// returns the Kernel-space CPU usage percent of the supplied process - // - aProcessID=0 will return information from the current process - // - returns -1 if the Process ID was not registered via Create/Subscribe - function PercentKernel(aProcessID: integer=0): single; overload; - /// returns the User-space CPU usage percent of the supplied process - // - aProcessID=0 will return information from the current process - // - returns -1 if the Process ID was not registered via Create/Subscribe - function PercentUser(aProcessID: integer=0): single; overload; - /// returns the total (Work+Paged) RAM use of the supplied process, in KB - // - aProcessID=0 will return information from the current process - // - returns 0 if the Process ID was not registered via Create/Subscribe - function KB(aProcessID: integer=0): cardinal; overload; - /// percent of current Idle/Kernel/User CPU usage for all processes - function PercentSystem(out Idle,Kernel,User: currency): boolean; - /// returns the detailed CPU and RAM usage percent of the supplied process - // - aProcessID=0 will return information from the current process - // - returns -1 if the Process ID was not registered via Create/Subscribe - function Data(out aData: TSystemUseData; aProcessID: integer=0): boolean; overload; - /// returns the detailed CPU and RAM usage percent of the supplied process - // - aProcessID=0 will return information from the current process - // - returns Timestamp=0 if the Process ID was not registered via Create/Subscribe - function Data(aProcessID: integer=0): TSystemUseData; overload; - /// returns total (Kernel+User) CPU usage percent history of the supplied process - // - aProcessID=0 will return information from the current process - // - returns nil if the Process ID was not registered via Create/Subscribe - // - returns the sample values as an array, starting from the last to the oldest - // - you can customize the maximum depth, with aDepth < HistoryDepth - function History(aProcessID: integer=0; aDepth: integer=0): TSingleDynArray; overload; - /// returns total (Kernel+User) CPU usage percent history of the supplied - // process, as a string of two digits values - // - aProcessID=0 will return information from the current process - // - returns '' if the Process ID was not registered via Create/Subscribe - // - you can customize the maximum depth, with aDepth < HistoryDepth - // - the memory history (in MB) can be optionally returned in aDestMemoryMB - function HistoryText(aProcessID: integer=0; aDepth: integer=0; - aDestMemoryMB: PRawUTF8=nil): RawUTF8; - {$ifndef NOVARIANTS} - /// returns total (Kernel+User) CPU usage percent history of the supplied process - // - aProcessID=0 will return information from the current process - // - returns null if the Process ID was not registered via Create/Subscribe - // - returns the sample values as a TDocVariant array, starting from the - // last to the oldest, with two digits precision (as currency values) - // - you can customize the maximum depth, with aDepth < HistoryDepth - function HistoryVariant(aProcessID: integer=0; aDepth: integer=0): variant; - {$endif} - /// access to a global instance, corresponding to the current process - // - its HistoryDepth will be of 60 items - class function Current(aCreateIfNone: boolean=true): TSystemUse; - /// returns detailed CPU and RAM usage history of the supplied process - // - aProcessID=0 will return information from the current process - // - returns nil if the Process ID was not registered via Create/Subscribe - // - returns the sample values as an array, starting from the last to the oldest - // - you can customize the maximum depth, with aDepth < HistoryDepth - function HistoryData(aProcessID: integer=0; aDepth: integer=0): TSystemUseDataDynArray; overload; - /// if any unexisting (e.g. closed/killed) process should be unregistered - // - e.g. if OpenProcess() API call fails - property UnsubscribeProcessOnAccessError: boolean - read fUnsubscribeProcessOnAccessError write fUnsubscribeProcessOnAccessError; - /// how many items are stored internally, and returned by the History() method - property HistoryDepth: integer read fHistoryDepth; - /// executed when TSystemUse.BackgroundExecute finished its measurement - property OnMeasured: TOnSystemUseMeasured read fOnMeasured write fOnMeasured; - /// low-level access to the associated timer running BackgroundExecute - // - equals nil if has been associated to no timer - property Timer: TSynBackgroundTimer read fTimer write fTimer; - end; - - /// stores information about a disk partition - TDiskPartition = packed record - /// the name of this partition - // - is the Volume name under Windows, or the Device name under POSIX - name: RawUTF8; - /// where this partition has been mounted - // - e.g. 'C:' or '/home' - // - you can use GetDiskInfo(mounted) to retrieve current space information - mounted: TFileName; - /// total size (in bytes) of this partition - size: QWord; - end; - /// stores information about several disk partitions - TDiskPartitions = array of TDiskPartition; - - /// value object able to gather information about the current system memory - TSynMonitorMemory = class(TSynPersistent) - protected - FAllocatedUsed: TSynMonitorOneSize; - FAllocatedReserved: TSynMonitorOneSize; - FMemoryLoadPercent: integer; - FPhysicalMemoryFree: TSynMonitorOneSize; - FVirtualMemoryFree: TSynMonitorOneSize; - FPagingFileTotal: TSynMonitorOneSize; - FPhysicalMemoryTotal: TSynMonitorOneSize; - FVirtualMemoryTotal: TSynMonitorOneSize; - FPagingFileFree: TSynMonitorOneSize; - fLastMemoryInfoRetrievedTix: cardinal; - procedure RetrieveMemoryInfo; virtual; - function GetAllocatedUsed: TSynMonitorOneSize; - function GetAllocatedReserved: TSynMonitorOneSize; - function GetMemoryLoadPercent: integer; - function GetPagingFileFree: TSynMonitorOneSize; - function GetPagingFileTotal: TSynMonitorOneSize; - function GetPhysicalMemoryFree: TSynMonitorOneSize; - function GetPhysicalMemoryTotal: TSynMonitorOneSize; - function GetVirtualMemoryFree: TSynMonitorOneSize; - function GetVirtualMemoryTotal: TSynMonitorOneSize; - public - /// initialize the class, and its nested TSynMonitorOneSize instances - constructor Create(aTextNoSpace: boolean); reintroduce; - /// finalize the class, and its nested TSynMonitorOneSize instances - destructor Destroy; override; - /// some text corresponding to current 'free/total' memory information - // - returns e.g. '10.3 GB / 15.6 GB' - class function FreeAsText(nospace: boolean=false): ShortString; - /// how many physical memory is currently installed, as text (e.g. '32 GB'); - class function PhysicalAsText(nospace: boolean=false): TShort16; - /// returns a JSON object with the current system memory information - // - numbers would be given in KB (Bytes shl 10) - class function ToJSON: RawUTF8; - {$ifndef NOVARIANTS} - /// fill a TDocVariant with the current system memory information - // - numbers would be given in KB (Bytes shl 10) - class function ToVariant: variant; - {$endif} - published - /// Total of allocated memory used by the program - property AllocatedUsed: TSynMonitorOneSize read GetAllocatedUsed; - /// Total of allocated memory reserved by the program - property AllocatedReserved: TSynMonitorOneSize read GetAllocatedReserved; - /// Percent of memory in use for the system - property MemoryLoadPercent: integer read GetMemoryLoadPercent; - /// Total of physical memory for the system - property PhysicalMemoryTotal: TSynMonitorOneSize read GetPhysicalMemoryTotal; - /// Free of physical memory for the system - property PhysicalMemoryFree: TSynMonitorOneSize read GetPhysicalMemoryFree; - /// Total of paging file for the system - property PagingFileTotal: TSynMonitorOneSize read GetPagingFileTotal; - /// Free of paging file for the system - property PagingFileFree: TSynMonitorOneSize read GetPagingFileFree; - {$ifdef MSWINDOWS} - /// Total of virtual memory for the system - // - property not defined under Linux, since not applying to this OS - property VirtualMemoryTotal: TSynMonitorOneSize read GetVirtualMemoryTotal; - /// Free of virtual memory for the system - // - property not defined under Linux, since not applying to this OS - property VirtualMemoryFree: TSynMonitorOneSize read GetVirtualMemoryFree; - {$endif} - end; - - /// value object able to gather information about a system drive - TSynMonitorDisk = class(TSynPersistent) - protected - fName: TFileName; - {$ifdef MSWINDOWS} - fVolumeName: TFileName; - {$endif} - fAvailableSize: TSynMonitorOneSize; - fFreeSize: TSynMonitorOneSize; - fTotalSize: TSynMonitorOneSize; - fLastDiskInfoRetrievedTix: cardinal; - procedure RetrieveDiskInfo; virtual; - function GetName: TFileName; - function GetAvailable: TSynMonitorOneSize; - function GetFree: TSynMonitorOneSize; - function GetTotal: TSynMonitorOneSize; - public - /// initialize the class, and its nested TSynMonitorOneSize instances - constructor Create; override; - /// finalize the class, and its nested TSynMonitorOneSize instances - destructor Destroy; override; - /// some text corresponding to current 'free/total' disk information - // - could return e.g. 'D: 64.4 GB / 213.4 GB' - class function FreeAsText: RawUTF8; - published - /// the disk name - property Name: TFileName read GetName; - {$ifdef MSWINDOWS} - /// the volume name (only available on Windows) - property VolumeName: TFileName read fVolumeName write fVolumeName; - /// space currently available on this disk for the current user - // - may be less then FreeSize, if user quotas are specified (only taken - // into account under Windows) - property AvailableSize: TSynMonitorOneSize read GetAvailable; - {$endif MSWINDOWS} - /// free space currently available on this disk - property FreeSize: TSynMonitorOneSize read GetFree; - /// total space - property TotalSize: TSynMonitorOneSize read GetTotal; - end; - - /// hold low-level information about current memory usage - // - as filled by GetMemoryInfo() - TMemoryInfo = record - memtotal, memfree, filetotal, filefree, vmtotal, vmfree, - allocreserved, allocused: QWord; - percent: integer; - end; - -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 - // - Delphi "object" is buggy on stack -> also defined as record with methods - {$ifdef USERECORDWITHMETHODS}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} - /// read time zone information from the Windows registry - procedure LoadFromRegistry; - {$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; DateIsUTC: boolean=false): boolean; - /// retrieve the display text corresponding to a TzId - // - returns '' if the supplied TzId is not recognized - function GetDisplay(const TzId: TTimeZoneID): RawUTF8; - /// 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; - - -/// retrieve low-level information about all mounted disk partitions of the system -// - returned partitions array is sorted by "mounted" ascending order -function GetDiskPartitions: TDiskPartitions; - -/// retrieve low-level information about all mounted disk partitions as text -// - returns e.g. under Linux -// '/ /dev/sda3 (19 GB), /boot /dev/sda2 (486.8 MB), /home /dev/sda4 (0.9 TB)' -// or under Windows 'C:\ System (115 GB), D:\ Data (99.3 GB)' -// - uses internally a cache unless nocache is true -// - includes the free space if withfreespace is true - e.g. '(80 GB / 115 GB)' -function GetDiskPartitionsText(nocache: boolean=false; - withfreespace: boolean=false; nospace: boolean=false): RawUTF8; - -/// returns a JSON object containing basic information about the computer -// - including Host, User, CPU, OS, freemem, freedisk... -function SystemInfoJson: RawUTF8; - -{$ifdef MSWINDOWS} - -/// a wrapper around EnumProcesses() PsAPI call -function EnumAllProcesses(out Count: Cardinal): TCardinalDynArray; - -/// a wrapper around QueryFullProcessImageNameW/GetModuleFileNameEx PsAPI call -function EnumProcessName(PID: Cardinal): RawUTF8; - -{$endif MSWINDOWS} - - -/// retrieve low-level information about current memory usage -// - as used by TSynMonitorMemory -// - under BSD, only memtotal/memfree/percent are properly returned -// - allocreserved and allocused are set only if withalloc is TRUE -function GetMemoryInfo(out info: TMemoryInfo; withalloc: boolean): boolean; - -/// retrieve low-level information about a given disk partition -// - as used by TSynMonitorDisk and GetDiskPartitionsText() -// - only under Windows the Quotas are applied separately to aAvailableBytes -// in respect to global aFreeBytes -function GetDiskInfo(var aDriveFolderOrFile: TFileName; - out aAvailableBytes, aFreeBytes, aTotalBytes: QWord - {$ifdef MSWINDOWS}; aVolumeName: PFileName = nil{$endif}): boolean; - - -{ ************ Markup (e.g. HTML or Emoji) process ******************** } - -type - /// tune AddHtmlEscapeWiki/AddHtmlEscapeMarkdown wrapper functions process - // - heHtmlEscape will escape any HTML special chars, e.g. & into & - // - heEmojiToUTF8 will convert any Emoji text into UTF-8 Unicode character, - // recognizing e.g. :joy: or :) in the text - TTextWriterHTMLEscape = set of ( - heHtmlEscape, heEmojiToUTF8); - -/// convert some wiki-like text into proper HTML -// - convert all #13#10 into

...

, *..* into .., +..+ into -// .., `..` into .., and http://... as -// -// - escape any HTML special chars, and Emoji tags as specified with esc -procedure AddHtmlEscapeWiki(W: TTextWriter; P: PUTF8Char; - esc: TTextWriterHTMLEscape=[heHtmlEscape,heEmojiToUTF8]); - -/// convert minimal Markdown text into proper HTML -// - see https://enterprise.github.com/downloads/en/markdown-cheatsheet.pdf -// - convert all #13#10 into

...

, *..* into .., **..** into -// .., `...` into ..., backslash espaces \\ -// \* \_ and so on, [title](http://...) and detect plain http:// as -// -// - create unordered lists from trailing * + - chars, blockquotes from -// trailing > char, and code line from 4 initial spaces -// - as with default Markdown, won't escape HTML special chars (i.e. you can -// write plain HTML in the supplied text) unless esc is set otherwise -// - only inline-style links and images are supported yet (not reference-style); -// tables aren't supported either -procedure AddHtmlEscapeMarkdown(W: TTextWriter; P: PUTF8Char; - esc: TTextWriterHTMLEscape=[heEmojiToUTF8]); - -/// escape some wiki-marked text into HTML -// - just a wrapper around AddHtmlEscapeWiki() process -function HtmlEscapeWiki(const wiki: RawUTF8; esc: TTextWriterHTMLEscape=[heHtmlEscape,heEmojiToUTF8]): RawUTF8; - -/// escape some Markdown-marked text into HTML -// - just a wrapper around AddHtmlEscapeMarkdown() process -function HtmlEscapeMarkdown(const md: RawUTF8; esc: TTextWriterHTMLEscape=[heEmojiToUTF8]): RawUTF8; - - -type - /// map the first Unicode page of Emojis, from U+1F600 to U+1F64F - // - naming comes from github/Markdown :identifiers: - TEmoji = (eNone, - eGrinning, eGrin, eJoy, eSmiley, eSmile, eSweat_smile, - eLaughing, eInnocent, eSmiling_imp, eWink, eBlush, eYum, eRelieved, - eHeart_eyes, eSunglasses, eSmirk, eNeutral_face, eExpressionless, - eUnamused, eSweat, ePensive,eConfused, eConfounded, eKissing, - eKissing_heart, eKissing_smiling_eyes, eKissing_closed_eyes, - eStuck_out_tongue, eStuck_out_tongue_winking_eye, - eStuck_out_tongue_closed_eyes, eDisappointed, eWorried, eAngry, - ePout, eCry, ePersevere, eTriumph, eDisappointed_relieved, eFrowning, - eAnguished, eFearful, eWeary, eSleepy, eTired_face, eGrimacing, eSob, - eOpen_mouth, eHushed, eCold_sweat, eScream, eAstonished, eFlushed, - eSleeping, eDizzy_face, eNo_mouth, eMask, eSmile_cat, eJoy_cat, eSmiley_cat, - eHeart_eyes_cat, eSmirk_cat, eKissing_cat, ePouting_cat, eCrying_cat_face, - eScream_cat, eSlightly_frowning_face, eSlightly_smiling_face, - eUpside_down_face, eRoll_eyes, eNo_good, oOk_woman, eBow, eSee_no_evil, - eHear_no_evil, eSpeak_no_evil, eRaising_hand, eRaised_hands, - eFrowning_woman, ePerson_with_pouting_face, ePray); - -var - /// github/Markdown compatible text of Emojis - // - e.g. 'grinning' or 'person_with_pouting_face' - EMOJI_TEXT: array[TEmoji] of RawUTF8; - /// github/Markdown compatible tag of Emojis, including trailing and ending : - // - e.g. ':grinning:' or ':person_with_pouting_face:' - EMOJI_TAG: array[TEmoji] of RawUTF8; - /// the Unicode character matching a given Emoji, after UTF-8 encoding - EMOJI_UTF8: array[TEmoji] of RawUTF8; - /// low-level access to TEmoji RTTI - used when inlining EmojiFromText() - EMOJI_RTTI: PShortString; - /// to recognize simple :) :( :| :/ :D :o :p :s characters as smilleys - EMOJI_AFTERDOTS: array['('..'|'] of TEmoji; - -/// recognize github/Markdown compatible text of Emojis -// - for instance 'sunglasses' text buffer will return eSunglasses -// - returns eNone if no case-insensitive match was found -function EmojiFromText(P: PUTF8Char; len: PtrInt): TEmoji; - {$ifdef HASINLINE}inline;{$endif} - -/// low-level parser of github/Markdown compatible text of Emojis -// - supplied P^ should point to ':' -// - will append the recognized UTF-8 Emoji if P contains e.g. :joy: or :) -// - will append ':' if no Emoji text is recognized, and return eNone -// - will try both EMOJI_AFTERDOTS[] and EMOJI_RTTI[] reference set -// - if W is nil, won't append anything, but just return the recognized TEmoji -function EmojiParseDots(var P: PUTF8Char; W: TTextWriter=nil): TEmoji; - -/// low-level conversion of UTF-8 Emoji sequences into github/Markdown :identifiers: -procedure EmojiToDots(P: PUTF8Char; W: TTextWriter); overload; - -/// conversion of UTF-8 Emoji sequences into github/Markdown :identifiers: -function EmojiToDots(const text: RawUTF8): RawUTF8; overload; - -/// low-level conversion of github/Markdown :identifiers: into UTF-8 Emoji sequences -procedure EmojiFromDots(P: PUTF8Char; W: TTextWriter); overload; - -/// conversion of github/Markdown :identifiers: into UTF-8 Emoji sequences -function EmojiFromDots(const text: RawUTF8): RawUTF8; overload; - - -{ ************ Command Line and Console process ************************** } - -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 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); - -/// write some text to the console using a given color -procedure ConsoleWrite(const Text: RawUTF8; Color: TConsoleColor=ccLightGray; - NoLineFeed: boolean=false; NoColor: boolean=false); overload; - -/// write some text to the console using a given color -procedure ConsoleWrite(const Fmt: RawUTF8; const Args: array of const; - Color: TConsoleColor=ccLightGray; NoLineFeed: boolean=false); overload; - -/// change the console text background color -procedure TextBackground(Color: TConsoleColor); - -/// will wait for the ENTER key to be pressed, processing Synchronize() pending -// notifications, and the internal Windows Message loop (on this OS) -// - to be used e.g. for proper work of console applications with interface-based -// service implemented as optExecInMainThread -procedure ConsoleWaitForEnterKey; - -/// read all available content from stdin -// - could be used to retrieve some file piped to the command line -// - the content is not converted, so will follow the encoding used for storage -function ConsoleReadBody: RawByteString; - -{$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} - -{ ************ TSynTable types and classes ************************** } - -{$define SORTCOMPAREMETHOD} -{ if defined, the field content comparison will use a method instead of fixed - functions - could be mandatory for tftArray field kind } - -type - /// exception raised by all TSynTable related code - ETableDataException = class(ESynException); - - /// the available types for any TSynTable field property - // - this is used in our so-called SBF compact binary format - // (similar to BSON or Protocol Buffers) - // - those types are used for both storage and JSON conversion - // - basic types are similar to SQLite3, i.e. Int64/Double/UTF-8/Blob - // - storage can be of fixed size, or of variable length - // - you can specify to use WinAnsi encoding instead of UTF-8 for string storage - // (it can use less space on disk than UTF-8 encoding) - // - BLOB fields can be either internal (i.e. handled by TSynTable like a - // RawByteString text storage), either external (i.e. must be stored in a dedicated - // storage structure - e.g. another TSynBigTable instance) - TSynTableFieldType = - (// unknown or not defined field type - tftUnknown, - // some fixed-size field value - tftBoolean, tftUInt8, tftUInt16, tftUInt24, tftInt32, tftInt64, - tftCurrency, tftDouble, - // some variable-size field value - tftVarUInt32, tftVarInt32, tftVarUInt64, - // text storage - tftWinAnsi, tftUTF8, - // BLOB fields - tftBlobInternal, tftBlobExternal, - // other variable-size field value - tftVarInt64); - - /// set of available field types for TSynTable - TSynTableFieldTypes = set of TSynTableFieldType; - - /// available option types for a field property - // - tfoIndex is set if an index must be created for this field - // - tfoUnique is set if field values must be unique (if set, the tfoIndex - // will be always forced) - // - tfoCaseInsensitive can be set to make no difference between 'a' and 'A' - // (by default, comparison is case-sensitive) - this option has an effect - // not only if tfoIndex or tfoUnique is set, but also for iterating search - TSynTableFieldOption = ( - tfoIndex, tfoUnique, tfoCaseInsensitive); - - /// set of option types for a field - TSynTableFieldOptions = set of TSynTableFieldOption; - - /// used to store bit set for all available fiels in a Table - // - with current format, maximum field count is 64 - TSynTableFieldBits = set of 0..63; - - /// an custom RawByteString type used to store internaly a data in - // our SBF compact binary format - TSBFString = type RawByteString; - - /// function prototype used to retrieve the index of a specified property name - // - 'ID' is handled separately: here must be available only the custom fields - TSynTableFieldIndex = function(const PropName: RawUTF8): integer of object; - - /// the recognized operators for a TSynTableStatement where clause - TSynTableStatementOperator = ( - opEqualTo, - opNotEqualTo, - opLessThan, - opLessThanOrEqualTo, - opGreaterThan, - opGreaterThanOrEqualTo, - opIn, - opIsNull, - opIsNotNull, - opLike, - opContains, - opFunction); - - TSynTableFieldProperties = class; - - /// one recognized SELECT expression for TSynTableStatement - TSynTableStatementSelect = record - /// the column SELECTed for the SQL statement, in the expected order - // - contains 0 for ID/RowID, or the RTTI field index + 1 - Field: integer; - /// an optional integer to be added - // - recognized from .. +123 .. -123 patterns in the select - ToBeAdded: integer; - /// the optional column alias, e.g. 'MaxID' for 'max(id) as MaxID' - Alias: RawUTF8; - /// the optional function applied to the SELECTed column - // - e.g. Max(RowID) would store 'Max' and SelectField[0]=0 - // - but Count( * ) would store 'Count' and SelectField[0]=0, and - // set FunctionIsCountStart = TRUE - FunctionName: RawUTF8; - /// if the function needs a special process - // - e.g. funcCountStar for the special Count( * ) expression or - // funcDistinct, funcMax for distinct(...)/max(...) aggregation - FunctionKnown: (funcNone, funcCountStar, funcDistinct, funcMax); - /// MongoDB-like sub field e.g. 'mainfield.subfield1.subfield2' - // - still identifying 'mainfield' in Field index, and setting - // SubField='.subfield1.subfield2' - SubField: RawUTF8; - end; - - /// the recognized SELECT expressions for TSynTableStatement - TSynTableStatementSelectDynArray = array of TSynTableStatementSelect; - - /// one recognized WHERE expression for TSynTableStatement - TSynTableStatementWhere = record - /// any '(' before the actual expression - ParenthesisBefore: RawUTF8; - /// any ')' after the actual expression - ParenthesisAfter: RawUTF8; - /// expressions are evaluated as AND unless this field is set to TRUE - JoinedOR: boolean; - /// if this expression is preceded by a NOT modifier - NotClause: boolean; - /// the index of the field used for the WHERE expression - // - WhereField=0 for ID, 1 for field # 0, 2 for field #1, - // and so on... (i.e. WhereField = RTTI field index +1) - Field: integer; - /// MongoDB-like sub field e.g. 'mainfield.subfield1.subfield2' - // - still identifying 'mainfield' in Field index, and setting - // SubField='.subfield1.subfield2' - SubField: RawUTF8; - /// the operator of the WHERE expression - Operator: TSynTableStatementOperator; - /// the SQL function name associated to a Field and Value - // - e.g. 'INTEGERDYNARRAYCONTAINS' and Field=0 for - // IntegerDynArrayContains(RowID,10) and ValueInteger=10 - // - Value does not contain anything - FunctionName: RawUTF8; - /// the value used for the WHERE expression - Value: RawUTF8; - /// the raw value SQL buffer used for the WHERE expression - ValueSQL: PUTF8Char; - /// the raw value SQL buffer length used for the WHERE expression - ValueSQLLen: integer; - /// an integer representation of WhereValue (used for ID check e.g.) - ValueInteger: integer; - /// used to fast compare with SBF binary compact formatted data - ValueSBF: TSBFString; - {$ifndef NOVARIANTS} - /// the value used for the WHERE expression, encoded as Variant - // - may be a TDocVariant for the IN operator - ValueVariant: variant; - {$endif} - end; - - /// the recognized WHERE expressions for TSynTableStatement - TSynTableStatementWhereDynArray = array of TSynTableStatementWhere; - - /// used to parse a SELECT SQL statement, following the SQlite3 syntax - // - handle basic REST commands, i.e. a SELECT over a single table (no JOIN) - // with its WHERE clause, and result column aliases - // - handle also aggregate functions like "SELECT Count( * ) FROM TableName" - // - will also parse any LIMIT, OFFSET, ORDER BY, GROUP BY statement clause - TSynTableStatement = class - protected - fSQLStatement: RawUTF8; - fSelect: TSynTableStatementSelectDynArray; - fSelectFunctionCount: integer; - fTableName: RawUTF8; - fWhere: TSynTableStatementWhereDynArray; - fOrderByField: TSQLFieldIndexDynArray; - fGroupByField: TSQLFieldIndexDynArray; - fWhereHasParenthesis, fHasSelectSubFields, fWhereHasSubFields: boolean; - fOrderByDesc: boolean; - fLimit: integer; - fOffset: integer; - fWriter: TJSONWriter; - public - /// parse the given SELECT SQL statement and retrieve the corresponding - // parameters into this class read-only properties - // - the supplied GetFieldIndex() method is used to populate the - // SelectedFields and Where[].Field properties - // - SimpleFieldsBits is used for '*' field names - // - SQLStatement is left '' if the SQL statement is not correct - // - if SQLStatement is set, the caller must check for TableName to match - // the expected value, then use the Where[] to retrieve the content - // - if FieldProp is set, then the Where[].ValueSBF property is initialized - // with the SBF equivalence of the Where[].Value - constructor Create(const SQL: RawUTF8; GetFieldIndex: TSynTableFieldIndex; - SimpleFieldsBits: TSQLFieldBits=[0..MAX_SQLFIELDS-1]; - FieldProp: TSynTableFieldProperties=nil); - /// compute the SELECT column bits from the SelectFields array - // - optionally set Select[].SubField into SubFields[Select[].Field] - // (e.g. to include specific fields from MongoDB embedded document) - procedure SelectFieldBits(var Fields: TSQLFieldBits; var withID: boolean; - SubFields: PRawUTF8Array=nil); - - /// the SELECT SQL statement parsed - // - equals '' if the parsing failed - property SQLStatement: RawUTF8 read fSQLStatement; - /// the column SELECTed for the SQL statement, in the expected order - property Select: TSynTableStatementSelectDynArray read fSelect; - /// if the SELECTed expression of this SQL statement have any function defined - property SelectFunctionCount: integer read fSelectFunctionCount; - /// the retrieved table name - property TableName: RawUTF8 read fTableName; - /// if any Select[].SubField was actually set - property HasSelectSubFields: boolean read fHasSelectSubFields; - /// the WHERE clause of this SQL statement - property Where: TSynTableStatementWhereDynArray read fWhere; - /// if the WHERE clause contains any ( ) parenthesis expression - property WhereHasParenthesis: boolean read fWhereHasParenthesis; - /// if the WHERE clause contains any Where[].SubField - property WhereHasSubFields: boolean read fWhereHasSubFields; - /// recognize an GROUP BY clause with one or several fields - // - here 0 = ID, otherwise RTTI field index +1 - property GroupByField: TSQLFieldIndexDynArray read fGroupByField; - /// recognize an ORDER BY clause with one or several fields - // - here 0 = ID, otherwise RTTI field index +1 - property OrderByField: TSQLFieldIndexDynArray read fOrderByField; - /// false for default ASC order, true for DESC attribute - property OrderByDesc: boolean read fOrderByDesc; - /// the number specified by the optional LIMIT ... clause - // - set to 0 by default (meaning no LIMIT clause) - property Limit: integer read fLimit; - /// the number specified by the optional OFFSET ... clause - // - set to 0 by default (meaning no OFFSET clause) - property Offset: integer read fOffset; - /// optional associated writer - property Writer: TJSONWriter read fWriter write fWriter; - end; - - /// function prototype used to retrieve the RECORD data of a specified Index - // - the index is not the per-ID index, but the "physical" index, i.e. the - // index value used to retrieve data from low-level (and faster) method - // - should return nil if Index is out of range - // - caller must provide a temporary storage buffer to be used optionally - TSynTableGetRecordData = function( - Index: integer; var aTempData: RawByteString): pointer of object; - - TSynTable = class; - - {$ifdef SORTCOMPAREMETHOD} - /// internal value used by TSynTableFieldProperties.SortCompare() method to - // avoid stack allocation - TSortCompareTmp = record - PB1, PB2: PByte; - L1,L2: integer; - end; - {$endif} - - /// store the type properties of a given field / database column - TSynTableFieldProperties = class - protected - /// used during OrderedIndexSort to prevent stack usage - SortPivot: pointer; - {$ifdef SORTCOMPAREMETHOD} - /// internal value used by SortCompare() method to avoid stack allocation - SortCompareTmp: TSortCompareTmp; - {$endif} - /// these two temporary buffers are used to call TSynTableGetRecordData - DataTemp1, DataTemp2: RawByteString; - /// the associated table which own this field property - Owner: TSynTable; - /// the global size of a default field value, as encoded - // in our SBF compact binary format - fDefaultFieldLength: integer; - /// a default field data, as encoded in our SBF compact binary format - fDefaultFieldData: TSBFString; - /// last >=0 value returned by the last OrderedIndexFindAdd() call - fOrderedIndexFindAdd: integer; - /// used for internal QuickSort of OrderedIndex[] - // - call SortCompare() for sorting the items - procedure OrderedIndexSort(L,R: PtrInt); - /// retrieve an index from OrderedIndex[] of the given value - // - call SortCompare() to compare to the reference value - function OrderedIndexFind(Value: pointer): PtrInt; - /// retrieve an index where a Value must be added into OrderedIndex[] - // - call SortCompare() to compare to the reference value - // - returns -1 if Value is there, or the index where to insert - // - the returned value (if >= 0) will be stored in fOrderedIndexFindAdd - function OrderedIndexFindAdd(Value: pointer): PtrInt; - /// set OrderedIndexReverse[OrderedIndex[aOrderedIndex]] := aOrderedIndex; - procedure OrderedIndexReverseSet(aOrderedIndex: integer); - public - /// the field name - Name: RawUTF8; - /// kind of field (defines both value type and storage to be used) - FieldType: TSynTableFieldType; - /// the fixed-length size, or -1 for a varInt, -2 for a variable string - FieldSize: integer; - /// options of this field - Options: TSynTableFieldOptions; - /// contains the offset of this field, in case of fixed-length field - // - normally, fixed-length fields are stored in the beginning of the record - // storage: in this case, a value >= 0 will point to the position of the - // field value of this field - // - if the value is < 0, its absolute will be the field number to be counted - // after TSynTable.fFieldVariableOffset (-1 for first item) - Offset: integer; - /// number of the field in the table (starting at 0) - FieldNumber: integer; - /// if allocated, contains the storage indexes of every item, in sorted order - // - only available if tfoIndex is in Options - // - the index is not the per-ID index, but the "physical" index, i.e. the - // index value used to retrieve data from low-level (and faster) method - OrderedIndex: TIntegerDynArray; - /// if allocated, contains the reverse storage index of OrderedIndex - // - i.e. OrderedIndexReverse[OrderedIndex[i]] := i; - // - used to speed up the record update procedure with huge number of - // records - OrderedIndexReverse: TIntegerDynArray; - /// number of items in OrderedIndex[] - // - is set to 0 when the content has been modified (mark force recreate) - OrderedIndexCount: integer; - /// if set to TRUE after an OrderedIndex[] refresh but with not sorting - // - OrderedIndexSort(0,OrderedIndexCount-1) must be called before using - // the OrderedIndex[] array - // - you should call OrderedIndexRefresh method to ensure it is sorted - OrderedIndexNotSorted: boolean; - /// all TSynValidate instances registered per each field - Filters: TSynObjectList; - /// all TSynValidate instances registered per each field - Validates: TSynObjectList; - /// low-level binary comparison used by IDSort and TSynTable.IterateJSONValues - // - P1 and P2 must point to the values encoded in our SBF compact binary format - {$ifdef SORTCOMPAREMETHOD} - function SortCompare(P1,P2: PUTF8Char): PtrInt; - {$else} - SortCompare: TUTF8Compare; - {$endif} - - /// read entry from a specified file reader - constructor CreateFrom(var RD: TFileBufferReader); - /// release associated memory and objects - destructor Destroy; override; - /// save entry to a specified file writer - procedure SaveTo(WR: TFileBufferWriter); - /// decode the value from our SBF compact binary format into UTF-8 JSON - // - returns the next FieldBuffer value - function GetJSON(FieldBuffer: pointer; W: TTextWriter): pointer; - /// decode the value from our SBF compact binary format into UTF-8 text - // - this method does not check for FieldBuffer to be not nil -> caller - // should check this explicitely - function GetValue(FieldBuffer: pointer): RawUTF8; - /// decode the value from a record buffer into an Boolean - // - will call Owner.GetData to retrieve then decode the field SBF content - function GetBoolean(RecordBuffer: pointer): Boolean; - {$ifdef HASINLINE}inline;{$endif} - /// decode the value from a record buffer into an integer - // - will call Owner.GetData to retrieve then decode the field SBF content - function GetInteger(RecordBuffer: pointer): Integer; - /// decode the value from a record buffer into an Int64 - // - will call Owner.GetData to retrieve then decode the field SBF content - function GetInt64(RecordBuffer: pointer): Int64; - /// decode the value from a record buffer into an floating-point value - // - will call Owner.GetData to retrieve then decode the field SBF content - function GetDouble(RecordBuffer: pointer): Double; - /// decode the value from a record buffer into an currency value - // - will call Owner.GetData to retrieve then decode the field SBF content - function GetCurrency(RecordBuffer: pointer): Currency; - /// decode the value from a record buffer into a RawUTF8 string - // - will call Owner.GetData to retrieve then decode the field SBF content - function GetRawUTF8(RecordBuffer: pointer): RawUTF8; - {$ifndef NOVARIANTS} - /// decode the value from our SBF compact binary format into a Variant - function GetVariant(FieldBuffer: pointer): Variant; overload; - {$ifdef HASINLINE}inline;{$endif} - /// decode the value from our SBF compact binary format into a Variant - procedure GetVariant(FieldBuffer: pointer; var result: Variant); overload; - {$endif} - /// retrieve the binary length (in bytes) of some SBF compact binary format - function GetLength(FieldBuffer: pointer): Integer; - {$ifdef HASINLINE}inline;{$endif} - /// create some SBF compact binary format from a Delphi binary value - // - will return '' if the field type doesn't match a boolean - function SBF(const Value: Boolean): TSBFString; overload; - /// create some SBF compact binary format from a Delphi binary value - // - will encode any byte, word, integer, cardinal, Int64 value - // - will return '' if the field type doesn't match an integer - function SBF(const Value: Int64): TSBFString; overload; - /// create some SBF compact binary format from a Delphi binary value - // - will encode any byte, word, integer, cardinal value - // - will return '' if the field type doesn't match an integer - function SBF(const Value: Integer): TSBFString; overload; - /// create some SBF compact binary format from a Delphi binary value - // - will return '' if the field type doesn't match a currency - // - we can't use SBF() method name because of Currency/Double ambiguity - function SBFCurr(const Value: Currency): TSBFString; - /// create some SBF compact binary format from a Delphi binary value - // - will return '' if the field type doesn't match a floating-point - // - we can't use SBF() method name because of Currency/Double ambiguity - function SBFFloat(const Value: Double): TSBFString; - /// create some SBF compact binary format from a Delphi binary value - // - expect a RawUTF8 string: will be converted to WinAnsiString - // before storage, for tftWinAnsi - // - will return '' if the field type doesn't match a string - function SBF(const Value: RawUTF8): TSBFString; overload; - /// create some SBF compact binary format from a BLOB memory buffer - // - will return '' if the field type doesn't match tftBlobInternal - function SBF(Value: pointer; ValueLen: integer): TSBFString; overload; - /// convert any UTF-8 encoded value into our SBF compact binary format - // - can be used e.g. from a WHERE clause, for fast comparison in - // TSynTableStatement.WhereValue content using OrderedIndex[] - // - is the reverse of GetValue/GetRawUTF8 methods above - function SBFFromRawUTF8(const aValue: RawUTF8): TSBFString; - {$ifndef NOVARIANTS} - /// create some SBF compact binary format from a Variant value - function SBF(const Value: Variant): TSBFString; overload; - {$endif} - - /// will update then sort the array of indexes used for the field index - // - the OrderedIndex[] array is first refreshed according to the - // aOldIndex, aNewIndex parameters: aOldIndex=-1 for Add, aNewIndex=-1 for - // Delete, or both >= 0 for update - // - call with both indexes = -1 will sort the existing OrderedIndex[] array - // - GetData property must have been set with a method returning a pointer - // to the field data for a given index (this index is not the per-ID index, - // but the "physical" index, i.e. the index value used to retrieve data - // from low-level (and fast) GetData method) - // - aOldRecordData and aNewRecordData can be specified in order to guess - // if the field data has really been modified (speed up the update a lot - // to only sort indexed fields if its content has been really modified) - // - returns FALSE if any parameter is invalid - function OrderedIndexUpdate(aOldIndex, aNewIndex: integer; - aOldRecordData, aNewRecordData: pointer): boolean; - /// retrieve one or more "physical" indexes matching a WHERE Statement - // - is faster than O(1) GetIteraring(), because will use O(log(n)) binary - // search using the OrderedIndex[] array - // - returns the resulting indexes as a a sorted list in MatchIndex/MatchIndexCount - // - if the indexes are already present in the list, won't duplicate them - // - WhereSBFValue must be a valid SBF formated field buffer content - // - the Limit parameter is similar to the SQL LIMIT clause: if greater than 0, - // an upper bound on the number of rows returned is placed (e.g. set Limit=1 - // to only retrieve the first match) - // - GetData property must have been set with a method returning a pointer - // to the field data for a given index (this index is not the per-ID index, - // but the "physical" index, i.e. the index value used to retrieve data - // from low-level (and fast) GetData method) - // - in this method, indexes are not the per-ID indexes, but the "physical" - // indexes, i.e. each index value used to retrieve data from low-level - // (and fast) GetData method - function OrderedIndexMatch(WhereSBFValue: pointer; - var MatchIndex: TIntegerDynArray; var MatchIndexCount: integer; - Limit: Integer=0): Boolean; - /// will force refresh the OrderedIndex[] array - // - to be called e.g. if OrderedIndexNotSorted = TRUE, if you want to - // access to the OrderedIndex[] array - procedure OrderedIndexRefresh; - /// register a custom filter or validation rule to the class for this field - // - this will be used by Filter() and Validate() methods - // - will return the specified associated TSynFilterOrValidate instance - // - a TSynValidateTableUniqueField is always added by - // TSynTable.AfterFieldModif if tfoUnique is set in Options - function AddFilterOrValidate(aFilter: TSynFilterOrValidate): TSynFilterOrValidate; - /// check the registered constraints - // - returns '' on success - // - returns an error message e.g. if a tftUnique constraint failed - // - RecordIndex=-1 in case of adding, or the physical index of the updated record - function Validate(RecordBuffer: pointer; RecordIndex: integer): string; - /// some default SBF compact binary format content - property SBFDefault: TSBFString read fDefaultFieldData; - end; - - -{$ifndef DELPHI5OROLDER} - - /// a pointer to structure used to store a TSynTable record - PSynTableData = ^TSynTableData; - - {$A-} { packet object not allowed since Delphi 2009 :( } - /// used to store a TSynTable record using our SBF compact binary format - // - this object can be created on the stack - // - it is mapped into a variant TVarData, to be retrieved by the - // TSynTable.Data method - but direct allocation of a TSynTableData on the - // stack is faster (due to the Variant overhead) - // - 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 USERECORDWITHMETHODS}TSynTableData = record - {$else}TSynTableData = object {$endif UNICODE} - private - VType: cardinal; // defined as cardinal not as word for proper aligment - VID: integer; - VTable: TSynTable; - VValue: TSBFString; - {$ifndef NOVARIANTS} - function GetFieldVarData(FieldName: PUTF8Char; FieldNameLen: PtrInt; var Value: TVarData): boolean; - procedure GetFieldVariant(const FieldName: RawUTF8; var result: Variant); - function GetField(const FieldName: RawUTF8): Variant; - procedure SetField(const FieldName: RawUTF8; const Value: Variant); - {$endif} - /// raise an exception if VTable=nil - procedure CheckVTableInitialized; - {$ifdef HASINLINE}inline;{$endif} - public - /// initialize a record data content for a specified table - // - a void content is set - procedure Init(aTable: TSynTable; aID: Integer=0); overload; {$ifdef HASINLINE}inline;{$endif} - /// initialize a record data content for a specified table - // - the specified SBF content is store inside this TSynTableData - procedure Init(aTable: TSynTable; aID: Integer; RecordBuffer: pointer; - RecordBufferLen: integer); overload; - /// the associated record ID - property ID: integer read VID write VID; - /// the associated TSynTable instance - property Table: TSynTable read VTable write VTable; - /// the record content, SBF compact binary format encoded - property SBF: TSBFString read VValue; - {$ifndef NOVARIANTS} - /// set or retrieve a field value from a variant data - property Field[const FieldName: RawUTF8]: Variant read GetField write SetField; - /// get a field value for a specified field - // - this method is faster than Field[], because it won't look for the field name - function GetFieldValue(aField: TSynTableFieldProperties): Variant; - /// set a field value for a specified field - // - this method is faster than Field[], because it won't look for the field name - procedure SetFieldValue(aField: TSynTableFieldProperties; const Value: Variant); - {$ifdef HASINLINE}inline;{$endif} - {$endif} - /// set a field value for a specified field, from SBF-encoded data - // - this method is faster than the other, because it won't look for the field - // name nor make any variant conversion - procedure SetFieldSBFValue(aField: TSynTableFieldProperties; const Value: TSBFString); - /// get a field value for a specified field, into SBF-encoded data - // - this method is faster than the other, because it won't look for the field - // name nor make any variant conversion - function GetFieldSBFValue(aField: TSynTableFieldProperties): TSBFString; - /// filter the SBF buffer record content with all registered filters - // - all field values are filtered in-place, following our SBF compact - // binary format encoding for this record - procedure FilterSBFValue; {$ifdef HASINLINE}inline;{$endif} - /// check the registered constraints according to a record SBF buffer - // - returns '' on success - // - returns an error message e.g. if a tftUnique constraint failed - // - RecordIndex=-1 in case of adding, or the physical index of the updated record - function ValidateSBFValue(RecordIndex: integer): string; - end; - {$A+} { packet object not allowed since Delphi 2009 :( } -{$endif DELPHI5OROLDER} - - PUpdateFieldEvent = ^TUpdateFieldEvent; - - /// an opaque structure used for TSynTable.UpdateFieldEvent method - TUpdateFieldEvent = record - /// the number of record added - Count: integer; - /// the list of IDs added - // - this list is already in increasing order, because GetIterating was - // called with the ioID order - IDs: TIntegerDynArray; - /// the offset of every record added - // - follows the IDs[] order - Offsets64: TInt64DynArray; - /// previous indexes: NewIndexs[oldIndex] := newIndex - NewIndexs: TIntegerDynArray; - /// the list of existing field in the previous data - AvailableFields: TSQLFieldBits; - /// where to write the updated data - WR: TFileBufferWriter; - end; - - /// will define a validation to be applied to a TSynTableFieldProperties field - // - a typical usage is to validate a value to be unique in the table - // (implemented in the TSynValidateTableUniqueField class) - // - the optional associated parameters are to be supplied JSON-encoded - // - ProcessField and ProcessRecordIndex properties will be filled before - // Process method call by TSynTableFieldProperties.Validate() - TSynValidateTable = class(TSynValidate) - protected - fProcessField: TSynTableFieldProperties; - fProcessRecordIndex: integer; - public - /// the associated TSQLRest instance - // - this value is filled by TSynTableFieldProperties.Validate with its - // self value to be used for the validation - // - it can be used in the overridden Process method - property ProcessField: TSynTableFieldProperties read fProcessField write fProcessField; - /// the associated record index (in case of update) - // - is set to -1 in case of adding, or the physical index of the updated record - // - this value is filled by TSynTableFieldProperties.Validate - // - it can be used in the overridden Process method - property ProcessRecordIndex: integer read fProcessRecordIndex write fProcessRecordIndex; - end; - - /// will define a validation for a TSynTableFieldProperties Unique field - // - implement constraints check e.g. if tfoUnique is set in Options - // - it will check that the field value is not void - // - it will check that the field value is not a duplicate - TSynValidateTableUniqueField = class(TSynValidateTable) - public - /// perform the unique field validation action to the specified value - // - duplication value check will use the ProcessField and - // ProcessRecordIndex properties, which will be filled before call by - // TSynTableFieldProperties.Validate() - // - aFieldIndex parameter is not used here, since we have already the - // ProcessField property set - // - here the Value is expected to be UTF-8 text, as converted from our SBF - // compact binary format via e.g. TSynTableFieldProperties.GetValue / - // GetRawUTF8: this is mandatory to have the validation rule fit with other - // TSynValidateTable classes - function Process(aFieldIndex: integer; const Value: RawUTF8; var ErrorMsg: string): boolean; override; - end; - - /// store the description of a table with records, to implement a Database - // - can be used with several storage engines, for instance TSynBigTableRecord - // - each record can have up to 64 fields - // - a mandatory ID field must be handled by the storage engine itself - // - will handle the storage of records into our SBF compact binary format, in - // which fixed-length fields are stored leftmost side, then variable-length - // fields follow - TSynTable = class - protected - fTableName: RawUTF8; - /// list of TSynTableFieldProperties instances - fField: TObjectList; - /// offset of the first variable length value field - fFieldVariableOffset: PtrUInt; - /// index of the first variable length value field - // - equals -1 if no variable length field exists - fFieldVariableIndex: integer; - /// bit is set for a tftWinAnsi, tftUTF8 or tftBlobInternal kind of field - // - these kind of field are encoded as a VarInt length, then the data - fFieldIsVarString: TSynTableFieldBits; - /// bit is set for a tftBlobExternal kind of field e.g. - fFieldIsExternal: TSynTableFieldBits; - /// event used for proper data retrieval of a given record buffer - fGetRecordData: TSynTableGetRecordData; - /// the global size of a default value, as encoded in our SBF compact binary format - fDefaultRecordLength: integer; - /// a default record data, as encoded in our SBF compact binary format - fDefaultRecordData: TSBFString; - /// list of TSynTableFieldProperties added via all AddField() call - fAddedField: TList; - /// true if any field has a tfoUnique option set - fFieldHasUniqueIndexes: boolean; - function GetFieldType(Index: integer): TSynTableFieldProperties; - function GetFieldCount: integer; - function GetFieldFromName(const aName: RawUTF8): TSynTableFieldProperties; - function GetFieldFromNameLen(aName: PUTF8Char; aNameLen: integer): TSynTableFieldProperties; - /// following method matchs the TSynTableFieldIndex event type - function GetFieldIndexFromName(const aName: RawUTF8): integer; overload; - function GetFieldIndexFromNameLen(aName: PUTF8Char; aNameLen: integer): integer; overload; - /// refresh Offset,FieldNumber,FieldSize and fFieldVariableIndex,fFieldVariableOffset - procedure AfterFieldModif; - public - /// create a table definition instance - constructor Create(const aTableName: RawUTF8); - /// create a table definition instance from a specified file reader - procedure LoadFrom(var RD: TFileBufferReader); - /// release used memory - destructor Destroy; override; - /// save field properties to a specified file writer - procedure SaveTo(WR: TFileBufferWriter); - - /// retrieve to the corresponding data address of a given field - function GetData(RecordBuffer: PUTF8Char; Field: TSynTableFieldProperties): pointer; - /// add a field description to the table - // - warning: the class responsible of the storage itself must process the - // data already stored when a field is created, e.g. in - // TSynBigTableRecord.AddFieldUpdate method - // - physical order does not necessary follow the AddField() call order: - // for better performance, it will try to store fixed-sized record first, - // multiple of 4 bytes first (access is faster if dat is 4 byte aligned), - // then variable-length after fixed-sized fields; in all case, a field - // indexed will be put first - function AddField(const aName: RawUTF8; aType: TSynTableFieldType; - aOptions: TSynTableFieldOptions=[]): TSynTableFieldProperties; - /// update a record content - // - return the updated record data, in our SBF compact binary format - // - if NewFieldData is not specified, a default 0 or '' value is appended - // - if NewFieldData is set, it must match the field value kind - // - warning: this method will update result in-place, so RecordBuffer MUST - // be <> pointer(result) or data corruption may occur - procedure UpdateFieldData(RecordBuffer: PUTF8Char; RecordBufferLen, - FieldIndex: integer; var result: TSBFString; const NewFieldData: TSBFString=''); - /// update a record content after any AddfieldUpdate, to refresh the data - // - AvailableFields must contain the list of existing fields in the previous data - function UpdateFieldRecord(RecordBuffer: PUTF8Char; var AvailableFields: TSQLFieldBits): TSBFString; - /// this Event is to be called for all data records (via a GetIterating method) - // after any AddfieldUpdate, to refresh the data - // - Opaque is in fact a pointer to a TUpdateFieldEvent record, and will contain - // all parameters set by TSynBigTableRecord.AddFieldUpdate, including a - // TFileBufferWriter instance to use to write the recreated data - // - it will work with either any newly added field, handly also field data - // order change in SBF record (e.g. when a fixed-sized field has been added - // on a record containing variable-length fields) - function UpdateFieldEvent(Sender: TObject; Opaque: pointer; ID, Index: integer; - Data: pointer; DataLen: integer): boolean; - /// event which must be called by the storage engine when some values are modified - // - if aOldIndex and aNewIndex are both >= 0, the corresponding aOldIndex - // will be replaced by aNewIndex value (i.e. called in case of a data Update) - // - if aOldIndex is -1 and aNewIndex is >= 0, aNewIndex refers to a just - // created item (i.e. called in case of a data Add) - // - if aOldIndex is >= 0 and aNewIndex is -1, aNewIndex refers to a just - // deleted item (i.e. called in case of a data Delete) - // - will update then sort all existing TSynTableFieldProperties.OrderedIndex - // values - // - the GetDataBuffer protected virtual method must have been overridden to - // properly return the record data for a given "physical/stored" index - // - aOldRecordData and aNewRecordData can be specified in order to guess - // if the field data has really been modified (speed up the update a lot - // to only sort indexed fields if its content has been really modified) - procedure FieldIndexModify(aOldIndex, aNewIndex: integer; - aOldRecordData, aNewRecordData: pointer); - /// return the total length of the given record buffer, encoded in our SBF - // compact binary format - function DataLength(RecordBuffer: pointer): integer; - {$ifndef NOVARIANTS} - /// create a Variant able to access any field content via late binding - // - i.e. you can use Var.Name to access the 'Name' field of record Var - // - if you leave ID and RecordBuffer void, a void record is created - function Data(aID: integer=0; RecordBuffer: pointer=nil; - RecordBufferLen: Integer=0): Variant; overload; - {$endif NOVARIANTS} - /// return a default content for ALL record fields - // - uses our SBF compact binary format - property DefaultRecordData: TSBFString read fDefaultRecordData; - /// list of TSynTableFieldProperties added via all AddField() call - // - this list will allow TSynBigTableRecord.AddFieldUpdate to refresh - // the data on disk according to the new field configuration - property AddedField: TList read fAddedField write fAddedField; - /// offset of the first variable length value field - property FieldVariableOffset: PtrUInt read fFieldVariableOffset; - public - {$ifndef DELPHI5OROLDER} - /// create a TJSONWriter, ready to be filled with GetJSONValues(W) below - // - will initialize all TJSONWriter.ColNames[] values according to the - // specified Fields index list, and initialize the JSON content - function CreateJSONWriter(JSON: TStream; Expand, withID: boolean; - const Fields: TSQLFieldIndexDynArray): TJSONWriter; overload; - /// create a TJSONWriter, ready to be filled with GetJSONValues(W) below - // - will initialize all TJSONWriter.ColNames[] values according to the - // specified Fields bit set, and initialize the JSON content - function CreateJSONWriter(JSON: TStream; Expand, withID: boolean; - const Fields: TSQLFieldBits): TJSONWriter; overload; - /// return the UTF-8 encoded JSON objects for the values contained - // in the specified RecordBuffer encoded in our SBF compact binary format, - // according to the Expand/WithID/Fields parameters of W - // - if W.Expand is true, JSON data is an object, for direct use with any Ajax or .NET client: - // ! {"col1":val11,"col2":"val12"} - //- if W.Expand is false, JSON data is serialized (as used in TSQLTableJSON) - // ! { "fieldCount":1,"values":["col1","col2",val11,"val12",val21,..] } - // - only fields with a bit set in W.Fields will be appended - // - if W.WithID is true, then the first ID field value is included - procedure GetJSONValues(aID: integer; RecordBuffer: PUTF8Char; W: TJSONWriter); - /// can be used to retrieve all values matching a preparated TSynTableStatement - // - this method matchs the TSynBigTableIterateEvent callback definition - // - Sender will be the TSynBigTable instance, and Opaque will point to a - // TSynTableStatement instance (with all fields initialized, including Writer) - function IterateJSONValues(Sender: TObject; Opaque: pointer; ID: integer; - Data: pointer; DataLen: integer): boolean; - {$endif DELPHI5OROLDER} - /// check the registered constraints according to a record SBF buffer - // - returns '' on success - // - returns an error message e.g. if a tftUnique constraint failed - // - RecordIndex=-1 in case of adding, or the physical index of the updated record - function Validate(RecordBuffer: pointer; RecordIndex: integer): string; - /// filter the SBF buffer record content with all registered filters - // - all field values are filtered in-place, following our SBF compact - // binary format encoding for this record - procedure Filter(var RecordBuffer: TSBFString); - - /// event used for proper data retrieval of a given record buffer, according - // to the physical/storage index value (not per-ID index) - // - if not set, field indexes won't work - // - will be mapped e.g. to TSynBigTable.GetPointerFromPhysicalIndex - property GetRecordData: TSynTableGetRecordData read fGetRecordData write fGetRecordData; - public - /// the internal Table name used to identify it (e.g. from JSON or SQL) - // - similar to the SQL Table name - property TableName: RawUTF8 read fTableName write fTableName; - /// number of fields in this table - property FieldCount: integer read GetFieldCount; - /// retrieve the properties of a given field - // - returns nil if the specified Index is out of range - property Field[Index: integer]: TSynTableFieldProperties read GetFieldType; - /// retrieve the properties of a given field - // - returns nil if the specified Index is out of range - property FieldFromName[const aName: RawUTF8]: TSynTableFieldProperties read GetFieldFromName; default; - /// retrieve the index of a given field - // - returns -1 if the specified Index is out of range - property FieldIndexFromName[const aName: RawUTF8]: integer read GetFieldIndexFromName; - /// read-only access to the Field list - property FieldList: TObjectList read fField; - /// true if any field has a tfoUnique option set - property HasUniqueIndexes: boolean read fFieldHasUniqueIndexes; - end; - -{$ifndef NOVARIANTS} - /// a custom variant type used to have direct access to a record content - // - use TSynTable.Data method to retrieve such a Variant - // - this variant will store internaly a SBF compact binary format - // representation of the record content - // - uses internally a TSynTableData object - TSynTableVariantType = class(TSynInvokeableVariantType) - protected - function IntGet(var Dest: TVarData; const Instance: TVarData; Name: PAnsiChar; NameLen: PtrInt): boolean; override; - function IntSet(const Instance, Value: TVarData; Name: PAnsiChar; NameLen: PtrInt): boolean; override; - public - /// retrieve the SBF compact binary format representation of a record content - class function ToSBF(const V: Variant): TSBFString; - /// retrieve the ID value associated to a record content - class function ToID(const V: Variant): integer; - /// retrieve the TSynTable instance associated to a record content - class function ToTable(const V: Variant): TSynTable; - /// clear the content - procedure Clear(var V: TVarData); override; - /// copy two record content - procedure Copy(var Dest: TVarData; const Source: TVarData; - const Indirect: Boolean); override; - end; - -/// initialize TSynTableVariantType if needed, and return the correspongind VType -function SynTableVariantVarType: cardinal; - -{$endif NOVARIANTS} - -const - /// used by TSynTableStatement.WhereField for "SELECT .. FROM TableName WHERE ID=?" - SYNTABLESTATEMENTWHEREID = 0; - - -/// low-level integer comparison according to a specified operator -// - SBF must point to the values encoded in our SBF compact binary format -// - Value must contain the plain integer value -// - Value can be a Currency accessed via a PInt64 -// - will work only for tftBoolean, tftUInt8, tftUInt16, tftUInt24, -// tftInt32, tftInt64 and tftCurrency field types -// - will handle only soEqualTo...soGreaterThanOrEqualTo operators -// - if SBFEnd is not nil, it will test for all values until SBF>=SBFEnd -// (can be used for tftArray) -// - returns true if both values match, or false otherwise -function CompareOperator(FieldType: TSynTableFieldType; SBF, SBFEnd: PUTF8Char; - Value: Int64; Oper: TCompareOperator): boolean; overload; - -/// low-level floating-point comparison according to a specified operator -// - SBF must point to the values encoded in our SBF compact binary format -// - Value must contain the plain floating-point value -// - will work only for tftDouble field type -// - will handle only soEqualTo...soGreaterThanOrEqualTo operators -// - if SBFEnd is not nil, it will test for all values until SBF>=SBFEnd -// (can be used for tftArray) -// - returns true if both values match, or false otherwise -function CompareOperator(SBF, SBFEnd: PUTF8Char; - Value: double; Oper: TCompareOperator): boolean; overload; - -/// low-level text comparison according to a specified operator -// - SBF must point to the values encoded in our SBF compact binary format -// - Value must contain the plain text value, in the same encoding (either -// WinAnsi either UTF-8, as FieldType defined for the SBF value) -// - will work only for tftWinAnsi and tftUTF8 field types -// - will handle all kind of operators - including soBeginWith, soContains and -// soSoundsLike* - but soSoundsLike* won't make use of the CaseSensitive parameter -// - for soSoundsLikeEnglish, soSoundsLikeFrench and soSoundsLikeSpanish -// operators, Value is not a real PUTF8Char but a prepared PSynSoundEx -// - if SBFEnd is not nil, it will test for all values until SBF>=SBFEnd -// (can be used for tftArray) -// - returns true if both values match, or false otherwise -function CompareOperator(FieldType: TSynTableFieldType; SBF, SBFEnd: PUTF8Char; - Value: PUTF8Char; ValueLen: integer; Oper: TCompareOperator; - CaseSensitive: boolean): boolean; overload; - -/// convert any AnsiString content into our SBF compact binary format storage -procedure ToSBFStr(const Value: RawByteString; out Result: TSBFString); - - -implementation - -{$ifdef WITH_FASTMM4STATS} -uses - FastMM4; // override OS information by actual FastMM4 status -{$endif WITH_FASTMM4STATS} - -{$ifdef FPCLINUX} -uses - termio, - {$ifdef BSD} - ctypes, - sysctl, - {$else} - Linux, - {$endif BSD} - SynFPCLinux; -{$endif FPCLINUX} - - -{ ************ TSynTable generic types and classes ************************** } - -{$ifndef NOVARIANTS} - -{ TSynTableVariantType } - -var - SynTableVariantType: TCustomVariantType = nil; - -function SynTableVariantVarType: cardinal; -begin - if SynTableVariantType=nil then - SynTableVariantType := SynRegisterCustomVariantType(TSynTableVariantType); - result := SynTableVariantType.VarType; -end; - -procedure TSynTableVariantType.Clear(var V: TVarData); -begin - //Assert(V.VType=SynTableVariantType.VarType); - TSynTableData(V).VValue := ''; // clean memory release - PPtrUInt(@V)^ := 0; // will set V.VType := varEmpty -end; - -procedure TSynTableVariantType.Copy(var Dest: TVarData; - const Source: TVarData; const Indirect: Boolean); -begin - //Assert(Source.VType=SynTableVariantType.VarType); - inherited Copy(Dest,Source,Indirect); // copy VType+VID+VTable - if not Indirect then - with TSynTableData(Dest) do begin - PtrInt(VValue) := 0; // avoid GPF - VValue := TSynTableData(Source).VValue; // copy by reference - end; -end; - -function TSynTableVariantType.IntGet(var Dest: TVarData; const Instance: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; -begin - result:= TSynTableData(Instance).GetFieldVarData(pointer(Name),NameLen,Dest); -end; - -function TSynTableVariantType.IntSet(const Instance, Value: TVarData; - Name: PAnsiChar; NameLen: PtrInt): boolean; -var aName: RawUTF8; -begin - FastSetString(aName,Name,NameLen); - TSynTableData(Instance).SetField(aName,Variant(Value)); - result := true; -end; - -class function TSynTableVariantType.ToID(const V: Variant): integer; -var Data: TSynTableData absolute V; -begin - if Data.VType<>SynTableVariantType.VarType then - result := 0 else - result := Data.VID; -end; - -class function TSynTableVariantType.ToSBF(const V: Variant): TSBFString; -var Data: TSynTableData absolute V; -begin - if Data.VType<>SynTableVariantType.VarType then - result := '' else - result := Data.VValue; -end; - -class function TSynTableVariantType.ToTable(const V: Variant): TSynTable; -var Data: TSynTableData absolute V; -begin - if Data.VType<>SynTableVariantType.VarType then - result := nil else - result := Data.VTable; -end; - -{$endif NOVARIANTS} - - -{ TSynTable } - -{$ifdef CPUX86} -function SortQWord(const A,B: QWord): integer; {$ifdef FPC} nostackframe; assembler; {$endif} -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 SortInt64(const A,B: Int64): integer; {$ifdef FPC} nostackframe; assembler; {$endif} -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; -{$endif} - -{$ifndef SORTCOMPAREMETHOD} - -function SortU8(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - result := PByte(P1)^-PByte(P2)^; - exit; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortU16(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - result := PWord(P1)^-PWord(P2)^; - exit; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortI32(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - result := PInteger(P1)^-PInteger(P2)^; - exit; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortDouble(P1,P2: PUTF8Char): PtrInt; -var V: Double; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - V := unaligned(PDouble(P1)^)-unaligned(PDouble(P2)^); - if V<0 then - result := -1 else - if V=0 then - result := 0 else - result := 1; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortU24(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - result := PtrInt(PWord(P1)^)+PtrInt(P1[2])shl 16 - -PtrInt(PWord(P2)^)-PtrInt(P2[2]) shl 16; - exit; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarUInt32(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - result := FromVarUInt32(PByte(P1))-FromVarUInt32(PByte(P2)); - exit; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarInt32(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - result := FromVarInt32(PByte(P1))-FromVarInt32(PByte(P2)); - exit; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -{$ifdef CPU64} // PtrInt = Int64 -> so direct substraction works - -function SortI64(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then - result := PInt64(P1)^-PInt64(P2)^ else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarUInt64(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then - result := FromVarUInt64(PByte(P1))-FromVarUInt64(PByte(P2)) else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarInt64(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then - result := FromVarInt64(PByte(P1))-FromVarInt64(PByte(P2)) else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -{$else} - -{$ifdef CPUX86} // circumvent comparison slowness (and QWord bug) - -function SortI64(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then - result := SortInt64(PInt64(P1)^,PInt64(P2)^) else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarUInt64(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then - result := SortQWord(FromVarUInt64(PByte(P1)),FromVarUInt64(PByte(P2))) else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarInt64(P1,P2: PUTF8Char): PtrInt; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then - result := SortInt64(FromVarInt64(PByte(P1)),FromVarInt64(PByte(P2))) else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -{$else} - -function SortI64(P1,P2: PUTF8Char): PtrInt; -var V: Int64; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - V := PInt64(P1)^-PInt64(P2)^; - if V<0 then - result := -1 else - if V>0 then - result := 1 else - result := 0; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarUInt64(P1,P2: PUTF8Char): PtrInt; -var V1,V2: QWord; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - V1 := FromVarUInt64(PByte(P1)); - V2 := FromVarUInt64(PByte(P2)); - if V1>V2 then - result := 1 else - if V1=V2 then - result := 0 else - result := -1; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortVarInt64(P1,P2: PUTF8Char): PtrInt; -var V1,V2: Int64; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - V1 := FromVarInt64(PByte(P1)); - V2 := FromVarInt64(PByte(P2)); - if V1>V2 then - result := 1 else - if V1=V2 then - result := 0 else - result := -1; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -{$endif CPUX86} - -{$endif CPU64} - -function SortStr(P1,P2: PUTF8Char): PtrInt; -var L1, L2, L, i: PtrInt; - PB1, PB2: PByte; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - if PtrInt(P1^)<=$7F then begin - L1 := PtrInt(P1^); - inc(P1); - end else begin - PB1 := pointer(P1); - L1 := FromVarUInt32High(PB1); - P1 := pointer(PB1); - end; - if PtrInt(P2^)<=$7F then begin - L2 := PtrInt(P2^); - inc(P2); - end else begin - PB2 := pointer(P2); - L2 := FromVarUInt32High(PB2); - P2 := pointer(PB2); - end; - L := L1; - if L2>L then - L := L2; - for i := 0 to L-1 do begin - result := PtrInt(P1[i])-PtrInt(P2[i]); - if Result<>0 then - exit; - end; - result := L1-L2; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -function SortIStr(P1,P2: PUTF8Char): PtrInt; -var L1, L2, L, i: PtrInt; - PB1, PB2: PByte; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then begin - if PtrInt(P1^)<=$7F then begin - L1 := PtrInt(P1^); - inc(P1); - end else begin - PB1 := pointer(P1); - L1 := FromVarUInt32High(PB1); - P1 := pointer(PB1); - end; - if PtrInt(P2^)<=$7F then begin - L2 := PtrInt(P2^); - inc(P2); - end else begin - PB2 := pointer(P2); - L2 := FromVarUInt32High(PB2); - P2 := pointer(PB2); - end; - if L2>L1 then - L := L2 else - L := L1; - for i := 0 to L-1 do // NormToUpperAnsi7 works for both WinAnsi & UTF-8 - if NormToUpperAnsi7[P1[i]]<>NormToUpperAnsi7[P2[i]] then begin - result := PtrInt(P1[i])-PtrInt(P2[i]); - exit; - end; - result := L1-L2; - end else - result := 1 else // P2=nil - result := -1 else // P1=nil - result := 0; // P1=P2 -end; - -const - FIELD_SORT: array[TSynTableFieldType] of TUTF8Compare = ( - nil, // tftUnknown, - SortU8, SortU8, SortU16, SortU24, SortI32, SortI64, - // tftBoolean,tftUInt8,tftUInt16,tftUInt24,tftInt32,tftInt64, - SortI64, SortDouble, SortVarUInt32,SortVarInt32,SortVarUInt64, - // tftCurrency,tftDouble, tftVarUInt32, tftVarInt32,tftVarUInt64, - SortStr, SortStr, SortStr, nil, SortVarInt64); - // tftWinAnsi,tftUTF8, tftBlobInternal,tftBlobExternal,tftVarInt64); - -{$endif SORTCOMPAREMETHOD} - -const - FIELD_FIXEDSIZE: array[TSynTableFieldType] of Integer = ( - 0, // tftUnknown, - 1, 1, 2, 3, 4, 8, 8, 8, - // tftBoolean, tftUInt8, tftUInt16, tftUInt24, tftInt32, tftInt64, tftCurrency, tftDouble - -1, -1, -1, // tftVarUInt32, tftVarInt32, tftVarUInt64 have -1 as size - -2, -2, -2, // tftWinAnsi, tftUTF8, tftBlobInternal have -2 as size - -3, // tftBlobExternal has -3 as size - -1); //tftVarInt64 - - // note: boolean is not in this set, because it can be 'true' or 'false' - FIELD_INTEGER: TSynTableFieldTypes = [ - tftUInt8, tftUInt16, tftUInt24, tftInt32, tftInt64, - tftVarUInt32, tftVarInt32, tftVarUInt64, tftVarInt64]; - -function TSynTable.AddField(const aName: RawUTF8; - aType: TSynTableFieldType; aOptions: TSynTableFieldOptions): TSynTableFieldProperties; -var aSize: Integer; -begin - result := nil; - aSize := FIELD_FIXEDSIZE[aType]; - if (self=nil) or (aSize=0) or IsRowID(pointer(aName)) or - not PropNameValid(pointer(aName)) or (GetFieldFromName(aName)<>nil) then - exit; - result := TSynTableFieldProperties.Create; - if fAddedField=nil then - fAddedField := TList.Create; - fAddedField.Add(result); - result.Name := aName; - result.FieldType := aType; - if tfoUnique in aOptions then - Include(aOptions,tfoIndex); // create an index for faster Unique field - if aSize=-3 then // external field has no index available - aOptions := aOptions-[tfoIndex,tfoUnique]; - result.Options := aOptions; - if aSize>0 then begin - // fixed-size field should be inserted left-side of the stream - if (tfoIndex in aOptions) or (aSize and 3=0) then begin - // indexed field or size is alignment friendly: put left side - if not ((tfoIndex in aOptions) and (aSize and 3=0)) then - // indexed+aligned field -> set first, otherwise at variable or not indexed - while result.FieldNumber=0 then - result.FieldNumber := fFieldVariableIndex else - result.FieldNumber := fField.Count; - fField.Insert(result.FieldNumber,result); - end else begin - if (tfoIndex in aOptions) and (fFieldVariableIndex>=0) then begin - // indexed field should be added left side (faster access for sort) - result.FieldNumber := fFieldVariableIndex; - while result.FieldNumbernil) and ((RecordBuffer=nil) or (RecordBufferLen=0)) then begin - // no data yet -> use default - RecordBuffer := pointer(fDefaultRecordData); - RecordBufferLen := fDefaultRecordLength; - end; - if RecordBuffer=pointer(result) then - // update content code below will fail -> please correct calling code - raise ETableDataException.CreateUTF8('In-place call of %.UpdateFieldData',[self]); - if (self=nil) or (cardinal(FieldIndex)>=cardinal(fField.Count)) then begin - SetString(result,PAnsiChar(RecordBuffer),RecordBufferLen); - exit; - end; - F := TSynTableFieldProperties(fField.List[FieldIndex]); - NewSize := length(NewFieldData); - if NewSize=0 then begin - // no NewFieldData specified -> use default field data to be inserted - NewData := pointer(F.fDefaultFieldData); - NewSize := F.fDefaultFieldLength; - end else - NewData := pointer(NewFieldData); - Dest := GetData(RecordBuffer,F); - DestOffset := Dest-RecordBuffer; - // update content - OldSize := F.GetLength(Dest); - dec(RecordBufferLen,OldSize); - SetString(Result,nil,RecordBufferLen+NewSize); - MoveFast(RecordBuffer^,PByteArray(result)[0],DestOffset); - MoveFast(NewData^,PByteArray(result)[DestOffset],NewSize); - MoveFast(Dest[OldSize],PByteArray(result)[DestOffset+NewSize],RecordBufferLen-DestOffset); -end; - -constructor TSynTable.Create(const aTableName: RawUTF8); -begin - if not PropNameValid(pointer(aTableName)) then - raise ETableDataException.CreateUTF8('Invalid %.Create(%)',[self,aTableName]); - fTableName := aTableName; - fField := TObjectList.Create; - fFieldVariableIndex := -1; -end; - -procedure TSynTable.LoadFrom(var RD: TFileBufferReader); -var n, i: integer; - aTableName: RawUTF8; -begin - fField.Clear; - RD.Read(aTableName); - if not PropNameValid(pointer(aTableName)) then - RD.ErrorInvalidContent; - fTableName := aTableName; - n := RD.ReadVarUInt32; - if cardinal(n)>=MAX_SQLFIELDS then - RD.ErrorInvalidContent; - for i := 0 to n-1 do - fField.Add(TSynTableFieldProperties.CreateFrom(RD)); - AfterFieldModif; -end; - -destructor TSynTable.Destroy; -begin - fField.Free; - fAddedField.Free; - inherited; -end; - -function TSynTable.GetFieldCount: integer; -begin - if self=nil then - result := 0 else - result := fField.Count; -end; - -function TSynTable.GetFieldFromName(const aName: RawUTF8): TSynTableFieldProperties; -begin - result := GetFieldFromNameLen(pointer(aName),length(aName)); -end; - -function TSynTable.GetFieldFromNameLen(aName: PUTF8Char; aNameLen: integer): TSynTableFieldProperties; -var p: ^TSynTableFieldProperties; - i: integer; -begin - if self<>nil then begin - p := pointer(fField.List); - for i := 1 to fField.Count do - if IdemPropNameU(p^.Name,aName,aNameLen) then begin - result := p^; - exit; - end else - inc(p); - end; - result := nil; -end; - -function TSynTable.GetFieldIndexFromName(const aName: RawUTF8): integer; -begin - result := GetFieldIndexFromNameLen(pointer(aName),length(aName)); -end; - -function TSynTable.GetFieldIndexFromNameLen(aName: PUTF8Char; aNameLen: integer): integer; -var p: ^TSynTableFieldProperties; -begin - if self<>nil then begin - p := pointer(fField.List); - for result := 0 to fField.Count-1 do - if IdemPropNameU(p^.Name,aName,aNameLen) then - exit else - inc(p); - end; - result := -1; -end; - -function TSynTable.GetFieldType(Index: integer): TSynTableFieldProperties; -begin - if (self=nil) or (cardinal(Index)>=cardinal(fField.Count)) then - result := nil else // avoid GPF - result := fField.List[Index]; -end; - -{$ifndef DELPHI5OROLDER} - -function TSynTable.CreateJSONWriter(JSON: TStream; Expand, withID: boolean; - const Fields: TSQLFieldBits): TJSONWriter; -begin - result := CreateJSONWriter(JSON,Expand,withID,FieldBitsToIndex(Fields,fField.Count)); -end; - -function TSynTable.CreateJSONWriter(JSON: TStream; Expand, withID: boolean; - const Fields: TSQLFieldIndexDynArray): TJSONWriter; -var i,nf,n: integer; -begin - if (self=nil) or ((Fields=nil) and not withID) then begin - result := nil; // no data to retrieve - exit; - end; - result := TJSONWriter.Create(JSON,Expand,withID,Fields); - // set col names - if withID then - n := 1 else - n := 0; - nf := length(Fields); - SetLength(result.ColNames,nf+n); - if withID then - result.ColNames[0] := 'ID'; - for i := 0 to nf-1 do - result.ColNames[i+n] := TSynTableFieldProperties(fField.List[Fields[i]]).Name; - result.AddColumns; // write or init field names for appropriate JSON Expand -end; - -procedure TSynTable.GetJSONValues(aID: integer; RecordBuffer: PUTF8Char; - W: TJSONWriter); -var i,n: integer; - buf: array[0..MAX_SQLFIELDS-1] of PUTF8Char; -begin - if (self=nil) or (RecordBuffer=nil) or (W=nil) then - exit; // avoid GPF - if W.Expand then begin - W.Add('{'); - if W.WithID then - W.AddString(W.ColNames[0]); - end; - if W.WithID then begin - W.Add(aID); - W.Add(','); - n := 1; - end else - n := 0; - for i := 0 to fField.Count-1 do begin - buf[i] := RecordBuffer; - inc(RecordBuffer,TSynTableFieldProperties(fField.List[i]).GetLength(RecordBuffer)); - end; - for i := 0 to length(W.Fields)-1 do begin - if W.Expand then begin - W.AddString(W.ColNames[n]); // '"'+ColNames[]+'":' - inc(n); - end; - TSynTableFieldProperties(fField.List[W.Fields[i]]).GetJSON(buf[i],W); - W.Add(','); - end; - W.CancelLastComma; // cancel last ',' - if W.Expand then - W.Add('}'); -end; - -function TSynTable.IterateJSONValues(Sender: TObject; Opaque: pointer; - ID: integer; Data: pointer; DataLen: integer): boolean; -var Statement: TSynTableStatement absolute Opaque; - F: TSynTableFieldProperties; - nWhere,fIndex: cardinal; -begin // note: we should have handled -2 (=COUNT) case already - nWhere := length(Statement.Where); - if (self=nil) or (Statement=nil) or (Data=nil) or - (Statement.Select=nil) or (nWhere>1) or - ((nWhere=1)and(Statement.Where[0].ValueSBF='')) then begin - result := false; - exit; - end; - result := true; - if nWhere=1 then begin // Where=nil -> all rows - fIndex := Statement.Where[0].Field; - if fIndex=SYNTABLESTATEMENTWHEREID then begin - if ID<>Statement.Where[0].ValueInteger then - exit; - end else begin - dec(fIndex); // 0 is ID, 1 for field # 0, 2 for field #1, and so on... - if fIndex0 then - exit; - end; - end; - end; - GetJSONValues(ID,Data,Statement.Writer); -end; - -{$endif DELPHI5OROLDER} - -function TSynTable.GetData(RecordBuffer: PUTF8Char; Field: TSynTableFieldProperties): pointer; -var i: integer; - PB: PByte; -begin - if Field.Offset>=0 then - result := RecordBuffer+Field.Offset else begin - result := RecordBuffer+fFieldVariableOffset; - for i := fFieldVariableIndex to Field.FieldNumber-1 do - if i in fFieldIsVarString then begin - // inlined result := GotoNextVarString(result); - if PByte(result)^<=$7f then - inc(PByte(result),PByte(result)^+1) else begin - PB := result; - inc(PByte(result),FromVarUInt32High(PB)+PtrUInt(PB)-PtrUInt(result)); - end; - end else - if not (i in fFieldIsExternal) then begin - // inlined result := GotoNextVarInt(result) - while PByte(result)^>$7f do inc(PByte(result)); - inc(PByte(result)); - end; - end; -end; - -procedure TSynTable.SaveTo(WR: TFileBufferWriter); -var i: Integer; -begin - WR.Write(fTableName); - WR.WriteVarUInt32(fField.Count); - for i := 0 to fField.Count-1 do - TSynTableFieldProperties(fField.List[i]).SaveTo(WR); -end; - -procedure TSynTable.AfterFieldModif; -var i, Offs: integer; -begin - PInt64(@fFieldIsVarString)^ := 0; - PInt64(@fFieldIsExternal)^ := 0; - fFieldVariableIndex := -1; - fDefaultRecordLength := 0; - fFieldHasUniqueIndexes := false; - Offs := 0; - for i := 0 to fField.Count-1 do - with TSynTableFieldProperties(fField.List[i]) do begin - FieldNumber := i; - {$ifndef SORTCOMPAREMETHOD} - SortCompare := FIELD_SORT[FieldType]; - {$endif} - Owner := self; - FieldSize := FIELD_FIXEDSIZE[FieldType]; - if FieldSize>=0 then begin - //assert(Offs>=0); - Offset := Offs; - inc(Offs,FieldSize); - inc(fDefaultRecordLength,FieldSize); - fDefaultFieldLength := FieldSize; - end else begin - if FieldSize=-3 then - Include(fFieldIsExternal,i) else begin - fDefaultFieldLength := 1; - inc(fDefaultRecordLength); - if FieldSize=-2 then - Include(fFieldIsVarString,i); - {$ifndef SORTCOMPAREMETHOD} - if (FieldType in [tftWinAnsi,tftUTF8]) and - (tfoCaseInsensitive in Options) then - SortCompare := SortIStr; // works for both WinAnsi and UTF-8 encodings - {$endif} - end; - // we need the Offset even for tftBlobExternal (FieldSize=-3) - if fFieldVariableIndex<0 then begin - fFieldVariableIndex := i; - fFieldVariableOffset := Offs; - Offs := -1; - end; - Offset := Offs; - dec(Offs); - end; - SetLength(fDefaultFieldData,fDefaultFieldLength); - FillcharFast(pointer(fDefaultFieldData)^,fDefaultFieldLength,0); - end; - SetLength(fDefaultRecordData,fDefaultRecordLength); - FillcharFast(pointer(fDefaultRecordData)^,fDefaultRecordLength,0); -end; - -procedure TSynTable.FieldIndexModify(aOldIndex, aNewIndex: integer; - aOldRecordData, aNewRecordData: pointer); -var F: integer; -begin - for F := 0 to fField.Count-1 do - with TSynTableFieldProperties(fField.List[F]) do - if tfoIndex in Options then - OrderedIndexUpdate(aOldIndex,aNewIndex,aOldRecordData,aNewRecordData); -end; - -procedure TSynTable.Filter(var RecordBuffer: TSBFString); -var Old, New: RawUTF8; - NewRecord: TSBFString; // UpdateFieldData update result in-place - F, i: integer; -begin - for F := 0 to fField.Count-1 do - with TSynTableFieldProperties(fField.List[F]) do - if Filters<>nil then begin - Old := GetRawUTF8(pointer(RecordBuffer)); - New := Old; - for i := 0 to Filters.Count-1 do - TSynFilter(Filters.List[i]).Process(F,New); - if Old<>New then begin - // value was changed -> store modified - UpdateFieldData(pointer(RecordBuffer),length(RecordBuffer),F, - NewRecord,SBFFromRawUTF8(New)); - RecordBuffer := NewRecord; - end; - end; -end; - -{$ifndef NOVARIANTS} -function TSynTable.Data(aID: integer; RecordBuffer: pointer; RecordBufferLen: Integer): Variant; -var data: TSynTableData absolute result; -begin - VarClear(result); - data.VType := SynTableVariantVarType; - data.VID := aID; - data.VTable := self; - pointer(data.VValue) := nil; // avoid GPF - if RecordBuffer=nil then - data.VValue := DefaultRecordData else begin - if RecordBufferLen=0 then - RecordBufferLen := DataLength(RecordBuffer); - SetString(data.VValue,PAnsiChar(RecordBuffer),RecordBufferLen); - end; -end; -{$endif NOVARIANTS} - -function TSynTable.DataLength(RecordBuffer: pointer): integer; -var F: Integer; - PC: PUTF8Char; -begin - if (Self<>nil) and (RecordBuffer<>nil) then begin - PC := RecordBuffer; - for F := 0 to fField.Count-1 do - inc(PC,TSynTableFieldProperties(fField.List[F]).GetLength(PC)); - result := PC-RecordBuffer; - end else - result := 0; -end; - -function TSynTable.UpdateFieldEvent(Sender: TObject; Opaque: pointer; - ID, Index: integer; Data: pointer; DataLen: integer): boolean; -var Added: PUpdateFieldEvent absolute Opaque; - F, aSize: integer; -begin // in practice, this data processing is very fast (thanks to WR speed) - with Added^ do begin - result := Count1 shl 30 then - raise ETableDataException.CreateUTF8('%: File size too big (>1GB)',[self]) else - Offsets64[Count] := WR.TotalWritten; - IDs[Count] := ID; - NewIndexs[Index] := Count; - inc(Count); - end; -end; - -function TSynTable.UpdateFieldRecord(RecordBuffer: PUTF8Char; - var AvailableFields: TSQLFieldBits): TSBFString; -var Lens: array[0..MAX_SQLFIELDS-1] of Integer; - F, Len, TotalLen: integer; - P: PUTF8Char; - Dest: PByte; -begin - // retrieve all field buffer lengths, to speed up record content creation - TotalLen := 0; - P := RecordBuffer; - for F := 0 to fField.Count-1 do - with TSynTableFieldProperties(fField.List[F]) do - if F in AvailableFields then begin - Len := GetLength(P); - inc(P,Len); - inc(TotalLen,Len); - Lens[F] := Len; - end else - inc(TotalLen,fDefaultFieldLength); - // create new record content - P := RecordBuffer; - SetString(Result,nil,TotalLen); - Dest := pointer(Result); - for F := 0 to fField.Count-1 do - with TSynTableFieldProperties(fField.List[F]) do - if F in AvailableFields then begin - Len := Lens[F]; - MoveFast(P^,Dest^,Len); - inc(P,Len); - inc(Dest,Len); - end else begin - FillcharFast(Dest^,fDefaultFieldLength,0); - inc(Dest,fDefaultFieldLength); - end; - //Assert(PtrUInt(Dest)-PtrUInt(result)=PtrUInt(TotalLen)); -end; - -function TSynTable.Validate(RecordBuffer: pointer; RecordIndex: integer): string; -var F: integer; -begin - result := ''; - for F := 0 to fField.Count-1 do - with TSynTableFieldProperties(fField.List[F]) do - if Validates<>nil then begin - result := Validate(RecordBuffer,RecordIndex); - if result<>'' then - exit; - end; -end; - - -{ TSynTableFieldProperties } - -constructor TSynTableFieldProperties.CreateFrom(var RD: TFileBufferReader); -begin - fOrderedIndexFindAdd := -1; - RD.Read(Name); - if not PropNameValid(pointer(Name)) then - RD.ErrorInvalidContent; - RD.Read(@FieldType,SizeOf(FieldType)); - RD.Read(@Options,SizeOf(Options)); - if (FieldType>high(FieldType)) then - RD.ErrorInvalidContent; - OrderedIndexCount := RD.ReadVarUInt32Array(OrderedIndex); - if OrderedIndexCount>0 then begin - if tfoIndex in Options then begin - //assert(OrderedIndexReverse=nil); - OrderedIndexReverseSet(-1); // compute whole OrderedIndexReverse[] array - end else - RD.ErrorInvalidContent; - end; - // we allow a void OrderedIndex[] array from disk -end; - -destructor TSynTableFieldProperties.Destroy; -begin - Filters.Free; - Validates.Free; - inherited; -end; - -function TSynTableFieldProperties.GetJSON(FieldBuffer: pointer; - W: TTextWriter): pointer; -var len: integer; - tmp: RawUTF8; -begin - case FieldType of - // fixed-sized field value - tftBoolean: - W.Add(PBoolean(FieldBuffer)^); - tftUInt8: - W.Add(PByte(FieldBuffer)^); - tftUInt16: - W.Add(PWord(FieldBuffer)^); - tftUInt24: - // PInteger()^ and $ffffff -> possible GPF on Memory Mapped file - W.Add(PWord(FieldBuffer)^+integer(PByteArray(FieldBuffer)^[2])shl 16); - tftInt32: - W.Add(PInteger(FieldBuffer)^); - tftInt64: - W.Add(PInt64(FieldBuffer)^); - tftCurrency: - W.AddCurr64(PInt64(FieldBuffer)^); - tftDouble: - W.AddDouble(unaligned(PDouble(FieldBuffer)^)); - // some variable-size field value - tftVarUInt32: - W.Add(FromVarUInt32(PByte(FieldBuffer))); - tftVarInt32: - W.Add(FromVarInt32(PByte(FieldBuffer))); - tftVarUInt64: - W.AddQ(FromVarUInt64(PByte(FieldBuffer))); - tftVarInt64: - W.Add(FromVarInt64(PByte(FieldBuffer))); - // text storage - WinAnsi could use less space than UTF-8 - tftWinAnsi, tftUTF8: begin - W.Add('"'); - len := FromVarUInt32(PByte(FieldBuffer)); - if len>0 then - if FieldType=tftUTF8 then - W.AddJSONEscape(PAnsiChar(FieldBuffer),len) else begin - SetLength(tmp,len*3); // in-place decoding and appending - W.AddJSONEscape(pointer(tmp),WinAnsiBufferToUtf8(pointer(tmp),PAnsiChar(FieldBuffer),len)-pointer(tmp)); - end; - W.Add('"'); - result := PAnsiChar(FieldBuffer)+len; - exit; - end; - tftBlobInternal: begin - W.AddShort('"X'''); - len := FromVarUInt32(PByte(FieldBuffer)); - W.AddBinToHex(PByte(FieldBuffer),len); - W.Add('''','"'); - end; - tftBlobExternal: - ; // BLOB fields are not handled here, but must be directly accessed - end; - result := PAnsiChar(FieldBuffer)+FieldSize; // // tftWinAnsi,tftUTF8 already done -end; - -function TSynTableFieldProperties.GetLength(FieldBuffer: pointer): Integer; -var PB: PByte; -begin - if FieldSize>=0 then - result := FieldSize else - case FieldSize of - -1: begin // variable-length data - result := 0; - while PByteArray(FieldBuffer)^[result]>$7f do inc(result); - inc(result); - end; - -2: begin // tftWinAnsi, tftUTF8, tftBlobInternal records - result := PByte(FieldBuffer)^; - if result<=$7F then - inc(Result) else begin - PB := FieldBuffer; - result := FromVarUInt32High(PB)+PtrUInt(PB)-PtrUInt(FieldBuffer); - end; - end; - else - result := 0; // tftBlobExternal is not stored in FieldBuffer - end; -end; - -{$ifndef NOVARIANTS} -function TSynTableFieldProperties.GetVariant(FieldBuffer: pointer): Variant; -begin - GetVariant(FieldBuffer,result); -end; - -procedure TSynTableFieldProperties.GetVariant(FieldBuffer: pointer; var result: Variant); -var len: integer; - PB: PByte absolute FieldBuffer; - PA: PAnsiChar absolute FieldBuffer; - PU: PUTF8Char absolute FieldBuffer; - tmp: RawByteString; - {$ifndef HASVARUSTRING} - WS: SynUnicode; - {$endif} -begin - case FieldType of - // fixed-sized field value - tftBoolean: - result := PBoolean(FieldBuffer)^; - tftUInt8: - result := PB^; - tftUInt16: - result := PWord(FieldBuffer)^; - tftUInt24: - // PInteger()^ and $ffffff -> possible GPF on Memory Mapped file - result := PWord(FieldBuffer)^+integer(PByteArray(FieldBuffer)^[2])shl 16; - tftInt32: - result := PInteger(FieldBuffer)^; - tftInt64: - result := PInt64(FieldBuffer)^; - tftCurrency: - result := PCurrency(FieldBuffer)^; - tftDouble: - result := unaligned(PDouble(FieldBuffer)^); - // some variable-size field value - tftVarUInt32: - result := FromVarUInt32(PB); - tftVarInt32: - result := FromVarInt32(PB); - tftVarUInt64: - result := FromVarUInt64(PB); - tftVarInt64: - result := FromVarInt64(PB); - // text storage - WinAnsi could use less space than UTF-8 - tftWinAnsi: begin - len := FromVarUInt32(PB); - if len>0 then - {$ifdef HASVARUSTRING} - result := WinAnsiToUnicodeString(PA,len) - {$else} - result := CurrentAnsiConvert.AnsiToAnsi(WinAnsiConvert,PA,len) - {$endif} else - result := ''; - end; - tftUTF8: begin - len := FromVarUInt32(PB); - if len>0 then - {$ifdef HASVARUSTRING} - result := UTF8DecodeToUnicodeString(PU,len) - {$else} begin - UTF8ToSynUnicode(PU,len,WS); - result := WS; - end - {$endif} else - result := ''; - end; - tftBlobInternal: begin - len := FromVarUInt32(PB); - SetString(tmp,PA,len); - result := tmp; // return internal BLOB content as string - end - else - result := ''; // tftBlobExternal fields e.g. must be directly accessed - end; -end; -{$endif} - -{$ifdef ISDELPHI20062007} - {$WARNINGS OFF} // circument Delphi 2007 false positive warning -{$endif} - -function TSynTableFieldProperties.GetValue(FieldBuffer: pointer): RawUTF8; -var len: integer; - PB: PByte absolute FieldBuffer; - PC: PAnsiChar absolute FieldBuffer; -begin - result := ''; - case FieldType of - // fixed-sized field value - tftBoolean: - result := BOOL_UTF8[PBoolean(FieldBuffer)^]; - tftUInt8: - UInt32ToUtf8(PB^,result); - tftUInt16: - UInt32ToUtf8(PWord(FieldBuffer)^,result); - tftUInt24: - // PInteger()^ and $ffffff -> possible GPF on Memory Mapped file - UInt32ToUtf8(PWord(FieldBuffer)^+integer(PByteArray(FieldBuffer)^[2])shl 16,result); - tftInt32: - Int32ToUtf8(PInteger(FieldBuffer)^,result); - tftInt64: - Int64ToUtf8(PInt64(FieldBuffer)^,result); - tftCurrency: - Curr64ToStr(PInt64(FieldBuffer)^,result); - tftDouble: - DoubleToStr(unaligned(PDouble(FieldBuffer)^),result); - // some variable-size field value - tftVarUInt32: - UInt32ToUtf8(FromVarUInt32(PB),result); - tftVarInt32: - Int32ToUtf8(FromVarInt32(PB),result); - tftVarUInt64: - UInt64ToUtf8(FromVarUInt64(PB),result); - tftVarInt64: - Int64ToUtf8(FromVarInt64(PB),result); - // text storage - WinAnsi could use less space than UTF-8 - tftWinAnsi, tftUTF8, tftBlobInternal: begin - len := FromVarUInt32(PB); - if len>0 then - if FieldType<>tftWinAnsi then - SetString(result,PC,len) else - result := WinAnsiConvert.AnsiBufferToRawUTF8(PC,len); - end; - // tftBlobExternal fields e.g. must be directly accessed - end; -end; - -{$ifdef ISDELPHI20062007} - {$WARNINGS ON} // circument Delphi 2007 false positive warning -{$endif} - -procedure TSynTableFieldProperties.OrderedIndexReverseSet(aOrderedIndex: integer); -var nrev, ndx, n: PtrInt; -begin - n := length(OrderedIndex); - nrev := length(OrderedIndexReverse); - if nrev=0 then - if n=0 then - exit else begin - // void OrderedIndexReverse[] - nrev := MaxInteger(OrderedIndex,OrderedIndexCount,n)+1; - SetLength(OrderedIndexReverse,nrev); - FillcharFast(OrderedIndexReverse[0],nrev*4,255); // all to -1 - Reverse(OrderedIndex,OrderedIndexCount,pointer(OrderedIndexReverse)); - end; - if PtrUInt(aOrderedIndex)>=PtrUInt(OrderedIndexCount) then - exit; // e.g. CreateFrom() will call OrderedIndexReverseSet(-1) - if nrev=nrev then - SetLength(OrderedIndexReverse,ndx+256) else - OrderedIndexReverse[ndx] := aOrderedIndex; -end; - -procedure TSynTableFieldProperties.OrderedIndexSort(L, R: PtrInt); -var I, J, P: PtrInt; - TmpI, TmpJ: integer; -begin - if (L0 do dec(J); - end; - if I <= J then begin - if I < J then begin - TmpJ := OrderedIndex[J]; - TmpI := OrderedIndex[I]; - OrderedIndex[J] := TmpI; - OrderedIndex[I] := TmpJ; - // keep OrderedIndexReverse[OrderedIndex[i]]=i - OrderedIndexReverse[TmpJ] := I; - OrderedIndexReverse[TmpI] := 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 - OrderedIndexSort(L, J); - L := I; - end else begin - if I < R then - OrderedIndexSort(I, R); - R := J; - end; - until L >= R; -end; - -procedure TSynTableFieldProperties.OrderedIndexRefresh; -begin - if (self=nil) or not OrderedIndexNotSorted then - exit; // already sorted - OrderedIndexSort(0,OrderedIndexCount-1); - OrderedIndexNotSorted := false; -end; - -function TSynTableFieldProperties.OrderedIndexFind(Value: pointer): PtrInt; -var L,R: PtrInt; - cmp: PtrInt; -begin - if OrderedIndexNotSorted then - OrderedIndexRefresh; - L := 0; - R := OrderedIndexCount-1; - with Owner do - if (R>=0) and Assigned(GetRecordData) then - repeat - result := (L + R) shr 1; - cmp := SortCompare(GetData(GetRecordData(OrderedIndex[result],DataTemp1),self),Value); - if cmp=0 then - exit; - if cmp<0 then - L := result + 1 else - R := result - 1; - until (L > R); - result := -1 -end; - -function TSynTableFieldProperties.OrderedIndexFindAdd(Value: pointer): PtrInt; -var L,R,i: PtrInt; - cmp: PtrInt; -begin - if OrderedIndexNotSorted then - OrderedIndexRefresh; - R := OrderedIndexCount-1; - if R<0 then - result := 0 else - with Owner do begin - fOrderedIndexFindAdd := -1; - L := 0; - result := -1; // return -1 if found - repeat - i := (L + R) shr 1; - cmp := SortCompare(GetData(GetRecordData(OrderedIndex[i],DataTemp1),self),Value); - if cmp=0 then - exit; - if cmp<0 then - L := i + 1 else - R := i - 1; - until (L > R); - while (i>=0) and - (SortCompare(GetData(GetRecordData(OrderedIndex[i],DataTemp1),self),Value)>=0) do - dec(i); - result := i+1; // return the index where to insert - end; - fOrderedIndexFindAdd := result; // store inserting index for OrderedIndexUpdate -end; - -function TSynTableFieldProperties.OrderedIndexMatch(WhereSBFValue: pointer; - var MatchIndex: TIntegerDynArray; var MatchIndexCount: integer; Limit: Integer=0): Boolean; -var i, L,R: PtrInt; -begin - result := false; - if (self=nil) or (WhereSBFValue=nil) or not Assigned(Owner.GetRecordData) or - (OrderedIndex=nil) or not (tfoIndex in Options) then - exit; - i := OrderedIndexFind(WhereSBFValue); - if i<0 then - exit; // WHERE value not found - if (tfoUnique in Options) or (Limit=1) then begin - // unique index: direct fastest O(log(n)) binary search - AddSortedInteger(MatchIndex,MatchIndexCount,OrderedIndex[i]); - // AddSortedInteger() will fail if OrderedIndex[i] already exists - end else - with Owner do begin - // multiple index matches possible: add matching range - L := i; - repeat - dec(L); - until (L<0) or (SortCompare(GetData(GetRecordData( - OrderedIndex[L],DataTemp1),self),WhereSBFValue)<>0); - R := i; - repeat - inc(R); - until (R>=OrderedIndexCount) or - (SortCompare(GetData(GetRecordData(OrderedIndex[R],DataTemp1),self),WhereSBFValue)<>0); - if Limit=0 then - Limit := MaxInt; // no LIMIT set -> retrieve all rows - for i := L+1 to R-1 do begin - AddSortedInteger(MatchIndex,MatchIndexCount,OrderedIndex[i]); - dec(Limit); - if Limit=0 then - Break; // reach LIMIT upperbound result count - end; - end; - result := true; -end; - -function TSynTableFieldProperties.OrderedIndexUpdate(aOldIndex, aNewIndex: integer; - aOldRecordData, aNewRecordData: pointer): boolean; -var aOldIndexIndex: integer; -begin - result := false; - if (self=nil) or not Assigned(Owner.GetRecordData) then - exit; // avoid GPF - // update content - if aOldIndex<0 then - if aNewIndex<0 then begin - // both indexes equal -1 -> force sort - OrderedIndexSort(0,OrderedIndexCount-1); - OrderedIndexNotSorted := false; - end else begin - // added record - if tfoUnique in Options then begin - if fOrderedIndexFindAdd<0 then - raise ETableDataException.CreateUTF8( - '%.CheckConstraint call needed before %.OrderedIndexUpdate',[self,Name]); - OrderedIndexReverseSet(InsertInteger(OrderedIndex,OrderedIndexCount, - aNewIndex,fOrderedIndexFindAdd)); - end else begin - AddInteger(OrderedIndex,OrderedIndexCount,aNewIndex); - OrderedIndexReverseSet(OrderedIndexCount-1); - OrderedIndexNotSorted := true; // -> OrderedIndexSort() call on purpose - end; - end else begin - // aOldIndex>=0: update a value - // retrieve position in OrderedIndex[] to be deleted/updated - if OrderedIndexReverse=nil then - OrderedIndexReverseSet(0) else // do OrderedIndexReverse[OrderedIndex[i]] := i - {assert(aOldIndexnil) or (aOldIndex<>aNewIndex) then // not in-place update - with Owner do begin - if aOldRecordData=nil then - aOldRecordData := GetRecordData(aOldIndex,DataTemp1); - if aNewRecordData=nil then - aNewRecordData := GetRecordData(aNewIndex,DataTemp2); - if SortCompare(GetData(aOldRecordData,self),GetData(aNewRecordData,self))=0 then begin - // only sort if field content was modified -> MUCH faster in most case - result := true; - exit; - end; - end; - if tfoUnique in Options then begin - if fOrderedIndexFindAdd>=0 then begin - // we know which OrderedIndex[] has to be changed -> manual update - // - this is still a bottleneck in the current implementation, but - // I was not able to find out how to make it faster, and still - // being able to check unique field constraints without changing the - // OrderedIndex[] content from a simple list into e.g. a red-black - // tree: such a structure performs better, but uses much more memory - // and is to be implemented - // - it's still fast, faster than any DB AFAIK, around 500 updates - // per second with 1,000,000 records on a Core i7 - // - it's still faster to refresh OrderedIndex[] than iterating - // through all items to validate the unique constraint - DeleteInteger(OrderedIndex,OrderedIndexCount,aOldIndexIndex); - if fOrderedIndexFindAdd>aOldIndexIndex then - dec(fOrderedIndexFindAdd); - InsertInteger(OrderedIndex,OrderedIndexCount,aNewIndex,fOrderedIndexFindAdd); - Reverse(OrderedIndex,OrderedIndexCount,pointer(OrderedIndexReverse)); - end else - // slow full sort - with 1,000,000 items it's about 100 times slower - // (never called with common usage in SynBigTable unit) - OrderedIndexSort(0,OrderedIndexCount-1); - end else - OrderedIndexNotSorted := true; // will call OrderedIndexSort() on purpose - end; - end; - fOrderedIndexFindAdd := -1; // consume this value - result := true; -end; - -procedure TSynTableFieldProperties.SaveTo(WR: TFileBufferWriter); -begin - WR.Write(Name); - WR.Write(@FieldType,SizeOf(FieldType)); - WR.Write(@Options,SizeOf(Options)); - WR.WriteVarUInt32Array(OrderedIndex,OrderedIndexCount,wkVarUInt32); -end; - -function TSynTableFieldProperties.SBF(const Value: Int64): TSBFString; -var tmp: array[0..15] of AnsiChar; -begin - case FieldType of - tftInt32: begin // special version for handling negative values - PInteger(@tmp)^ := Value; - SetString(Result,tmp,SizeOf(Integer)); - end; - tftUInt8, tftUInt16, tftUInt24, tftInt64: - SetString(Result,PAnsiChar(@Value),FieldSize); - tftVarUInt32: - SetString(Result,tmp,PAnsiChar(ToVarUInt32(Value,@tmp))-tmp); - tftVarInt32: - SetString(Result,tmp,PAnsiChar(ToVarInt32(Value,@tmp))-tmp); - tftVarUInt64: - SetString(Result,tmp,PAnsiChar(ToVarUInt64(Value,@tmp))-tmp); - tftVarInt64: - SetString(Result,tmp,PAnsiChar(ToVarInt64(Value,@tmp))-tmp); - else - result := ''; - end; -end; - -function TSynTableFieldProperties.SBF(const Value: Integer): TSBFString; -var tmp: array[0..15] of AnsiChar; -begin - case FieldType of - tftUInt8, tftUInt16, tftUInt24, tftInt32: - SetString(Result,PAnsiChar(@Value),FieldSize); - tftInt64: begin // special version for handling negative values - PInt64(@tmp)^ := Value; - SetString(Result,tmp,SizeOf(Int64)); - end; - tftVarUInt32: - if Value<0 then // expect an unsigned integer - result := '' else - SetString(Result,tmp,PAnsiChar(ToVarUInt32(Value,@tmp))-tmp); - tftVarInt32: - SetString(Result,tmp,PAnsiChar(ToVarInt32(Value,@tmp))-tmp); - tftVarUInt64: - if cardinal(Value)>cardinal(maxInt) then - result := '' else // expect a 32 bit integer - SetString(Result,tmp,PAnsiChar(ToVarUInt64(Value,@tmp))-tmp); - tftVarInt64: - SetString(Result,tmp,PAnsiChar(ToVarInt64(Value,@tmp))-tmp); - else - result := ''; - end; -end; - -const - SBF_BOOL: array[boolean] of TSBFString = - (#0,#1); - -{$ifndef NOVARIANTS} -function TSynTableFieldProperties.SBF(const Value: Variant): TSBFString; -var V64: Int64; - VC: Currency absolute V64; - VD: Double absolute V64; -begin // VarIsOrdinal/VarIsFloat/VarIsStr are buggy -> use field type - case FieldType of - tftBoolean: - result := SBF_BOOL[boolean(Value)]; - tftUInt8, tftUInt16, tftUInt24, tftInt32, tftInt64, - tftVarUInt32, tftVarInt32, tftVarUInt64, tftVarInt64: begin - if not VariantToInt64(Value,V64) then - V64 := 0; - result := SBF(V64); - end; - tftCurrency: begin - VC := Value; - SetString(result,PAnsiChar(@VC),SizeOf(VC)); - end; - tftDouble: begin - VD := Value; - SetString(result,PAnsiChar(@VD),SizeOf(VD)); - end; - tftWinAnsi: - ToSBFStr(WinAnsiConvert.UTF8ToAnsi(VariantToUTF8(Value)),result); - tftUTF8: - ToSBFStr(VariantToUTF8(Value),result); - else - result := ''; - end; - if result='' then - result := SBFDefault; -end; -{$endif} - -function TSynTableFieldProperties.SBF(const Value: Boolean): TSBFString; -begin - if FieldType<>tftBoolean then - result := '' else - result := SBF_BOOL[Value]; -end; - -function TSynTableFieldProperties.SBFCurr(const Value: Currency): TSBFString; -begin - if FieldType<>tftCurrency then - result := '' else - SetString(Result,PAnsiChar(@Value),SizeOf(Value)); -end; - -procedure ToSBFStr(const Value: RawByteString; out Result: TSBFString); -var tmp: array[0..15] of AnsiChar; - Len, Head: integer; -begin - if PtrUInt(Value)=0 then - Result := #0 else begin - Len := {$ifdef FPC}length(Value){$else}PInteger(PtrUInt(Value)-SizeOf(integer))^{$endif}; - Head := PAnsiChar(ToVarUInt32(Len,@tmp))-tmp; - SetLength(Result,Len+Head); - MoveFast(tmp,PByteArray(Result)[0],Head); - MoveFast(pointer(Value)^,PByteArray(Result)[Head],Len); - end; -end; - -function TSynTableFieldProperties.SBF(const Value: RawUTF8): TSBFString; -begin - case FieldType of - tftUTF8: - ToSBFStr(Value,Result); - tftWinAnsi: - ToSBFStr(Utf8ToWinAnsi(Value),Result); - else - result := ''; - end; -end; - -function TSynTableFieldProperties.SBF(Value: pointer; ValueLen: integer): TSBFString; -var tmp: array[0..15] of AnsiChar; - Head: integer; -begin - if FieldType<>tftBlobInternal then - result := '' else - if (Value=nil) or (ValueLen=0) then - result := #0 else begin // inlined ToSBFStr() code - Head := PAnsiChar(ToVarUInt32(ValueLen,@tmp))-tmp; - SetString(Result,nil,ValueLen+Head); - MoveFast(tmp,PByteArray(Result)[0],Head); - MoveFast(Value^,PByteArray(Result)[Head],ValueLen); - end; -end; - -function TSynTableFieldProperties.SBFFloat(const Value: Double): TSBFString; -begin - if FieldType<>tftDouble then - result := '' else - SetString(Result,PAnsiChar(@Value),SizeOf(Value)); -end; - -function TSynTableFieldProperties.SBFFromRawUTF8(const aValue: RawUTF8): TSBFString; -var Curr: Currency; -begin - case FieldType of - tftBoolean: - if (SynCommons.GetInteger(pointer(aValue))<>0) or IdemPropNameU(aValue,'true') then - result := #1 else - result := #0; // store false by default - tftUInt8, tftUInt16, tftUInt24, tftInt32, tftVarInt32: - result := SBF(SynCommons.GetInteger(pointer(aValue))); - tftVarUInt32, tftInt64, tftVarUInt64, tftVarInt64: - result := SBF(SynCommons.GetInt64(pointer(aValue))); - tftCurrency: begin - PInt64(@Curr)^ := StrToCurr64(pointer(aValue)); - result := SBFCurr(Curr); - end; - tftDouble: - result := SBFFloat(GetExtended(pointer(aValue))); - // text storage - WinAnsi could use less space than UTF-8 - tftUTF8, tftWinAnsi: - result := SBF(aValue); - else - result := ''; // tftBlob* fields e.g. must be handled directly - end; -end; - -function TSynTableFieldProperties.GetInteger(RecordBuffer: pointer): Integer; -begin - if (self=nil) or (RecordBuffer=nil) or (Owner=nil) then - result := 0 else begin - RecordBuffer := Owner.GetData(RecordBuffer,self); - case FieldType of - tftBoolean, tftUInt8: - result := PByte(RecordBuffer)^; - tftUInt16: - result := PWord(RecordBuffer)^; - tftUInt24: - // PInteger()^ and $ffffff -> possible GPF on Memory Mapped file - result := PWord(RecordBuffer)^+integer(PByteArray(RecordBuffer)^[2])shl 16; - tftInt32: - result := PInteger(RecordBuffer)^; - tftInt64: - result := PInt64(RecordBuffer)^; - // some variable-size field value - tftVarUInt32: - result := FromVarUInt32(PByte(RecordBuffer)); - tftVarInt32: - result := FromVarInt32(PByte(RecordBuffer)); - tftVarUInt64: - result := FromVarUInt64(PByte(RecordBuffer)); - tftVarInt64: - result := FromVarInt64(PByte(RecordBuffer)); - else - result := 0; - end; - end; -end; - -function TSynTableFieldProperties.GetInt64(RecordBuffer: pointer): Int64; -var PB: PByte; -begin - if (self=nil) or (RecordBuffer=nil) or (Owner=nil) then - result := 0 else begin - PB := Owner.GetData(RecordBuffer,self); - case FieldType of - tftInt64: - result := PInt64(PB)^; - tftVarUInt64: - result := FromVarUInt64(PB); - tftVarInt64: - result := FromVarInt64(PB); - else - result := GetInteger(RecordBuffer); - end; - end; -end; - -function TSynTableFieldProperties.GetBoolean(RecordBuffer: pointer): Boolean; -begin - result := boolean(GetInteger(RecordBuffer)); -end; - -function TSynTableFieldProperties.GetCurrency(RecordBuffer: pointer): Currency; -begin - if (self=nil) or (RecordBuffer=nil) or (Owner=nil) then - result := 0 else - case FieldType of - tftCurrency: - result := PCurrency(Owner.GetData(RecordBuffer,self))^; - else - result := GetInt64(RecordBuffer); - end; -end; - -function TSynTableFieldProperties.GetDouble(RecordBuffer: pointer): Double; -begin - if (self=nil) or (RecordBuffer=nil) or (Owner=nil) then - result := 0 else - case FieldType of - tftDouble: - result := unaligned(PDouble(Owner.GetData(RecordBuffer,self))^); - else - result := GetInt64(RecordBuffer); - end; -end; - -function TSynTableFieldProperties.GetRawUTF8(RecordBuffer: pointer): RawUTF8; -begin - if (self=nil) or (RecordBuffer=nil) or (Owner=nil) then - result := '' else begin - RecordBuffer := Owner.GetData(RecordBuffer,self); - if RecordBuffer<>nil then - result := GetValue(RecordBuffer) else // will do conversion to text - result := ''; - end; -end; - -function TSynTableFieldProperties.AddFilterOrValidate(aFilter: TSynFilterOrValidate): TSynFilterOrValidate; - procedure Add(var List: TSynObjectList); - begin - if List=nil then - List := TSynObjectList.Create; - List.Add(result); - end; -begin - result := aFilter; - if (self=nil) or (result=nil) then - result := nil else - if aFilter.InheritsFrom(TSynFilter) then - Add(Filters) else - if aFilter.InheritsFrom(TSynValidate) then - Add(Validates) else - result := nil; -end; - -function TSynTableFieldProperties.Validate(RecordBuffer: pointer; - RecordIndex: integer): string; -var i: integer; - Value: RawUTF8; - aValidate: TSynValidate; - aValidateTable: TSynValidateTable absolute aValidate; -begin - result := ''; - if (self=nil) or (Validates=nil) then - exit; - Value := GetRawUTF8(RecordBuffer); // TSynTableValidate needs RawUTF8 text - for i := 0 to Validates.Count-1 do begin - aValidate := Validates.List[i]; - if aValidate.InheritsFrom(TSynValidateTable) then begin - aValidateTable.ProcessField := self; - aValidateTable.ProcessRecordIndex := RecordIndex; - end; - if not aValidate.Process(FieldNumber,Value,result) then begin - if result='' then - // no custom message -> show a default message - result := format(sValidationFailed,[ - GetCaptionFromClass(aValidate.ClassType)]); - break; - end; - end; -end; - -{$ifdef SORTCOMPAREMETHOD} -function TSynTableFieldProperties.SortCompare(P1, P2: PUTF8Char): PtrInt; -var i, L: integer; -label minus,plus,zer; -begin - if P1<>P2 then - if P1<>nil then - if P2<>nil then - case FieldType of - tftBoolean, tftUInt8: - result := PByte(P1)^-PByte(P2)^; - tftUInt16: - result := PWord(P1)^-PWord(P2)^; - tftUInt24: - result := PtrInt(PWord(P1)^)+PtrInt(P1[2])shl 16 - -PtrInt(PWord(P2)^)-PtrInt(P2[2]) shl 16; - tftInt32: - result := PInteger(P1)^-PInteger(P2)^; - tftDouble: begin - unaligned(PDouble(@SortCompareTmp)^) := unaligned(PDouble(P1)^)-unaligned(PDouble(P2)^); - if unaligned(PDouble(@SortCompareTmp)^)<0 then - goto minus else - if unaligned(PDouble(@SortCompareTmp)^)>0 then - goto plus else - goto zer; - end; - tftVarUInt32: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - result := FromVarUInt32(PB1)-FromVarUInt32(PB2); - end; - tftVarInt32: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - result := FromVarInt32(PB1)-FromVarInt32(PB2); - end; - {$ifdef CPUX86} // circumvent comparison slowness (and QWord bug) - tftInt64, tftCurrency: - result := SortInt64(PInt64(P1)^,PInt64(P2)^); - tftVarUInt64: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - result := SortQWord(FromVarUInt64(PB1),FromVarUInt64(PB2)); - end; - tftVarInt64: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - result := SortInt64(FromVarInt64(PB1),FromVarInt64(PB2)); - end; - {$else} - {$ifdef CPU64} // PtrInt = Int64 - tftInt64, tftCurrency: - result := PInt64(P1)^-PInt64(P2)^; - tftVarUInt64: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - result := FromVarUInt64(PB1)-FromVarUInt64(PB2); - end; - tftVarInt64: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - result := FromVarInt64(PB1)-FromVarInt64(PB2); - end; - {$else} - tftInt64, tftCurrency: begin - PInt64(@SortCompareTmp)^ := PInt64(P1)^-PInt64(P2)^; - if PInt64(@SortCompareTmp)^<0 then - goto minus else - if PInt64(@SortCompareTmp)^>0 then - goto plus else - goto zer; - end; - tftVarUInt64: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - PInt64(@SortCompareTmp)^ := FromVarUInt64(PB1)-FromVarUInt64(PB2); - if PInt64(@SortCompareTmp)^<0 then - goto minus else - if PInt64(@SortCompareTmp)^>0 then - goto plus else - goto zer; - end; - tftVarInt64: - with SortCompareTmp do begin - PB1 := Pointer(P1); - PB2 := Pointer(P2); - PInt64(@SortCompareTmp)^ := FromVarInt64(PB1)-FromVarInt64(PB2); - if PInt64(@SortCompareTmp)^<0 then - goto minus else - if PInt64(@SortCompareTmp)^>0 then - goto plus else - goto zer; - end; - {$endif} - {$endif} - tftWinAnsi, tftUTF8, tftBlobInternal: - begin - with SortCompareTmp do begin - if PtrInt(P1^)<=$7F then begin - L1 := PtrInt(P1^); - inc(P1); - end else begin - PB1 := pointer(P1); - L1 := FromVarUInt32High(PB1); - P1 := pointer(PB1); - end; - if PtrInt(P2^)<=$7F then begin - L2 := PtrInt(P2^); - inc(P2); - end else begin - PB2 := pointer(P2); - L2 := FromVarUInt32High(PB2); - P2 := pointer(PB2); - end; - end; - with SortCompareTmp do begin - L := L1; - if L2>L then - L := L2; - end; - if tfoCaseInsensitive in Options then begin - i := 0; - while i0 then - exit else - inc(i); - end; - end else begin - i := 0; - while i0 then - exit else - inc(i); - end; - end; - with SortCompareTmp do - result := L1-L2; - end; - else - goto zer; - end else -plus: result := 1 else // P2=nil -minus:result := -1 else // P1=nil -zer:result := 0; // P1=P2 -end; -{$endif} - -function CompareOperator(FieldType: TSynTableFieldType; SBF, SBFEnd: PUTF8Char; - Value: Int64; Oper: TCompareOperator): boolean; -var V: Int64; - PB: PByte absolute SBF; -begin - result := true; - if PB<>nil then - repeat - case FieldType of - tftBoolean, tftUInt8: - V := PB^; - tftUInt16: - V := PWord(PB)^; - tftUInt24: - // PInteger()^ and $ffffff -> possible GPF on Memory Mapped file - V := PWord(PB)^+integer(PByteArray(PB)^[2])shl 16; - tftInt32: - V := PInteger(PB)^; - tftInt64: - V := PInt64(PB)^; - // some variable-size field value - tftVarUInt32: - V := FromVarUInt32(PB); - tftVarInt32: - V := FromVarInt32(PB); - tftVarUInt64: - V := FromVarUInt64(PB); - tftVarInt64: - V := FromVarInt64(PB); - else V := 0; // makes compiler happy - end; - case Oper of - soEqualTo: if V=Value then exit; - soNotEqualTo: if V<>Value then exit; - soLessThan: if VValue then exit; - soGreaterThanOrEqualTo: if V>=Value then exit; - else break; - end; - // not found: go to next value - if SBFEnd=nil then - break; // only one value to be checked - if FIELD_FIXEDSIZE[FieldType]>0 then - inc(SBF,FIELD_FIXEDSIZE[FieldType]); // FromVar*() already updated PB/SBF - until SBF>=SBFEnd; - result := false; // not found -end; - -function CompareOperator(SBF, SBFEnd: PUTF8Char; - Value: double; Oper: TCompareOperator): boolean; -begin - result := true; - if SBF<>nil then - repeat - case Oper of - soEqualTo: if unaligned(PDouble(SBF)^)=Value then exit; - soNotEqualTo: if unaligned(PDouble(SBF)^)<>Value then exit; - soLessThan: if unaligned(PDouble(SBF)^)Value then exit; - soGreaterThanOrEqualTo: if unaligned(PDouble(SBF)^)>=Value then exit; - else break; - end; - // not found: go to next value - if SBFEnd=nil then - break; // only one value to be checked - inc(SBF,SizeOf(Value)); - until SBF>=SBFEnd; - result := false; // not found -end; - -function CompareOperator(FieldType: TSynTableFieldType; SBF, SBFEnd: PUTF8Char; - Value: PUTF8Char; ValueLen: integer; Oper: TCompareOperator; - CaseSensitive: boolean): boolean; overload; -var L, Cmp: PtrInt; - PB: PByte; - tmp: array[byte] of AnsiChar; -begin - result := true; - if SBF<>nil then - repeat - // get length of text in the SBF encoded buffer - if integer(SBF^)<=$7f then begin - L := integer(SBF^); - inc(SBF); - end else begin - PB := Pointer(SBF); - L := FromVarUInt32(PB); - SBF := pointer(PB); - end; - // perform comparison: returns nil on match - case Oper of - soEqualTo..soGreaterThanOrEqualTo: begin - Cmp := L-ValueLen; - if Cmp<0 then - L := ValueLen; - if CaseSensitive then - Cmp := StrCompL(SBF,Value,L,Cmp) else - Cmp := StrCompIL(SBF,Value,L,Cmp); - case Oper of - soEqualTo: if Cmp=0 then exit; - soNotEqualTo: if Cmp<>0 then exit; - soLessThan: if Cmp<0 then exit; - soLessThanOrEqualTo: if Cmp<=0 then exit; - soGreaterThan: if Cmp>0 then exit; - soGreaterThanOrEqualTo: if Cmp>=0 then exit; - end; - end; - soBeginWith: - if ValueLen>=L then - if CaseSensitive then begin - if StrCompL(SBF,Value,ValueLen,0)=0 then - exit; - end else - if StrCompIL(SBF,Value,ValueLen,0)=0 then - exit; - soContains: begin - dec(L,ValueLen); - while L>=0 do begin - while (L>=0) and not(tcWord in TEXT_CHARS[SBF^]) do begin - dec(L); - inc(SBF); - end; // begin of next word reached - if L<0 then - Break; // not enough chars to contain the Value - if CaseSensitive then begin - if StrCompL(SBF,Value,ValueLen,0)=0 then - exit; - end else - if StrCompIL(SBF,Value,ValueLen,0)=0 then - exit; - while (L>=0) and (tcWord in TEXT_CHARS[SBF^]) do begin - dec(L); - inc(SBF); - end; // end of word reached - end; - if SBFEnd=nil then - break; // only one value to be checked - inc(SBF,ValueLen); // custom inc(SBF,L); - if SBFhigh(tmp) then - Cmp := high(tmp) else - Cmp := L; - tmp[Cmp] := #0; // TSynSoundEx expect the buffer to be #0 terminated - MoveFast(SBF^,tmp,Cmp); - case FieldType of - tftWinAnsi: - if PSynSoundEx(Value)^.Ansi(tmp) then - exit; - tftUTF8: - if PSynSoundEx(Value)^.UTF8(tmp) then - exit; - else break; - end; - end; - else break; - end; - // no match -> go to the end of the SBF buffer - if SBFEnd=nil then - exit; // only one value to be checked - inc(SBF,L); - if SBF>=SBFEnd then - break; - until false; -end; - - -{ TSynValidateTableUniqueField } - -function TSynValidateTableUniqueField.Process(aFieldIndex: integer; - const Value: RawUTF8; var ErrorMsg: string): boolean; -var S: TSBFString; -begin - result := false; - if (self=nil) or (Value='') or (ProcessField=nil) then - exit; // void field can't be unique - if not (tfoIndex in ProcessField.Options) then - exit; // index should be always created by TSynTable.AfterFieldModif - S := ProcessField.SBFFromRawUTF8(Value); - if S='' then - exit; // void field can't be unique - if ProcessField.OrderedIndexFindAdd(Pointer(S))>=0 then - // there is some place to insert the Value -> not existing yet -> OK - result := true else begin - // RecordIndex=-1 in case of adding, or the physical index of the updated record - if (ProcessRecordIndex>=0) and - (ProcessField.OrderedIndex[ProcessField.OrderedIndexFind(Pointer(S))]= - ProcessRecordIndex) then - // allow update of the record - result := true else - // found a dupplicated value - ErrorMsg := sValidationFieldDuplicate; - end; -end; - - -{ TSynTableStatement } - -const - NULL_UPP = ord('N')+ord('U')shl 8+ord('L')shl 16+ord('L')shl 24; - -constructor TSynTableStatement.Create(const SQL: RawUTF8; - GetFieldIndex: TSynTableFieldIndex; SimpleFieldsBits: TSQLFieldBits; - FieldProp: TSynTableFieldProperties); -var Prop, whereBefore: RawUTF8; - P, B: PUTF8Char; - ndx,err,len,selectCount,whereCount: integer; - whereWithOR,whereNotClause: boolean; - -function GetPropIndex: integer; -begin - if not GetNextFieldProp(P,Prop) then - result := -1 else - if IsRowID(pointer(Prop)) then - result := 0 else begin // 0 = ID field - result := GetFieldIndex(Prop); - if result>=0 then // -1 = no valid field name - inc(result); // otherwise: PropertyIndex+1 - end; -end; -function SetFields: boolean; -var select: TSynTableStatementSelect; - B: PUTF8Char; -begin - result := false; - FillcharFast(select,SizeOf(select),0); - select.Field := GetPropIndex; // 0 = ID, otherwise PropertyIndex+1 - if select.Field<0 then begin - if P^<>'(' then // Field not found -> try function(field) - exit; - P := GotoNextNotSpace(P+1); - select.FunctionName := Prop; - inc(fSelectFunctionCount); - if IdemPropNameU(Prop,'COUNT') and (P^='*') then begin - select.Field := 0; // count( * ) -> count(ID) - select.FunctionKnown := funcCountStar; - P := GotoNextNotSpace(P+1); - end else begin - if IdemPropNameU(Prop,'DISTINCT') then - select.FunctionKnown := funcDistinct else - if IdemPropNameU(Prop,'MAX') then - select.FunctionKnown := funcMax; - select.Field := GetPropIndex; - if select.Field<0 then - exit; - end; - if P^<>')' then - exit; - P := GotoNextNotSpace(P+1); - end else - if P^='.' then begin // MongoDB-like field.subfield1.subfield2 - B := P; - repeat - inc(P); - until not (jcJsonIdentifier in JSON_CHARS[P^]); - FastSetString(select.SubField,B,P-B); - fHasSelectSubFields := true; - end; - if P^ in ['+','-'] then begin - select.ToBeAdded := GetNextItemInteger(P,' '); - if select.ToBeAdded=0 then - exit; - P := GotoNextNotSpace(P); - end; - if IdemPChar(P,'AS ') then begin - inc(P,3); - if not GetNextFieldProp(P,select.Alias) then - exit; - end; - SetLength(fSelect,selectCount+1); - fSelect[selectCount] := select; - inc(selectCount); - result := true; -end; -function GetWhereValue(var Where: TSynTableStatementWhere): boolean; -var B: PUTF8Char; -begin - result := false; - P := GotoNextNotSpace(P); - Where.ValueSQL := P; - if PWord(P)^=ord(':')+ord('(') shl 8 then - inc(P,2); // ignore :(...): parameter (no prepared statements here) - if P^ in ['''','"'] then begin - // SQL String statement - P := UnQuoteSQLStringVar(P,Where.Value); - if P=nil then - exit; // end of string before end quote -> incorrect - {$ifndef NOVARIANTS} - RawUTF8ToVariant(Where.Value,Where.ValueVariant); - {$endif} - if FieldProp<>nil then - // create a SBF formatted version of the WHERE value - Where.ValueSBF := FieldProp.SBFFromRawUTF8(Where.Value); - end else - if (PInteger(P)^ and $DFDFDFDF=NULL_UPP) and (P[4] in [#0..' ',';']) then begin - // NULL statement - Where.Value := NULL_STR_VAR; // not void - {$ifndef NOVARIANTS} - SetVariantNull(Where.ValueVariant); - {$endif} - inc(P,4); - end else begin - // numeric statement or 'true' or 'false' (OK for NormalizeValue) - B := P; - repeat - inc(P); - until P^ in [#0..' ',';',')',',']; - SetString(Where.Value,B,P-B); - {$ifndef NOVARIANTS} - Where.ValueVariant := VariantLoadJSON(Where.Value); - {$endif} - Where.ValueInteger := GetInteger(pointer(Where.Value),err); - if FieldProp<>nil then - if Where.Value<>'?' then - if (FieldProp.FieldType in FIELD_INTEGER) and (err<>0) then - // we expect a true INTEGER value here - Where.Value := '' else - // create a SBF formatted version of the WHERE value - Where.ValueSBF := FieldProp.SBFFromRawUTF8(Where.Value); - end; - if PWord(P)^=ord(')')+ord(':')shl 8 then - inc(P,2); // ignore :(...): parameter - Where.ValueSQLLen := P-Where.ValueSQL; - P := GotoNextNotSpace(P); - if (P^=')') and (Where.FunctionName='') then begin - B := P; - repeat - inc(P); - until not (P^ in [#1..' ',')']); - while P[-1]=' ' do dec(P); // trim right space - SetString(Where.ParenthesisAfter,B,P-B); - P := GotoNextNotSpace(P); - end; - result := true; -end; -{$ifndef NOVARIANTS} -function GetWhereValues(var Where: TSynTableStatementWhere): boolean; -var v: TSynTableStatementWhereDynArray; - n, w: integer; - tmp: RawUTF8; -begin - result := false; - if Where.ValueSQLLen<=2 then - exit; - SetString(tmp,PAnsiChar(Where.ValueSQL)+1,Where.ValueSQLLen-2); - P := pointer(tmp); // parse again the IN (...,...,... ) expression - n := 0; - try - repeat - if n=length(v) then - SetLength(v,NextGrow(n)); - if not GetWhereValue(v[n]) then - exit; - inc(n); - if P^=#0 then - break; - if P^<>',' then - exit; - inc(P); - until false; - finally - P := Where.ValueSQL+Where.ValueSQLLen; // continue parsing as usual - end; - with TDocVariantData(Where.ValueVariant) do begin - InitFast(n,dvArray); - for w := 0 to n-1 do - AddItem(v[w].ValueVariant); - Where.Value := ToJSON; - end; - result := true; -end; -{$endif} -function GetWhereExpression(FieldIndex: integer; var Where: TSynTableStatementWhere): boolean; -var B: PUTF8Char; -begin - result := false; - Where.ParenthesisBefore := whereBefore; - Where.JoinedOR := whereWithOR; - Where.NotClause := whereNotClause; - Where.Field := FieldIndex; // 0 = ID, otherwise PropertyIndex+1 - if P^='.' then begin // MongoDB-like field.subfield1.subfield2 - B := P; - repeat - inc(P); - until not (jcJsonIdentifier in JSON_CHARS[P^]); - FastSetString(Where.SubField,B,P-B); - fWhereHasSubFields := true; - P := GotoNextNotSpace(P); - end; - case P^ of - '=': Where.Operator := opEqualTo; - '>': if P[1]='=' then begin - inc(P); - Where.Operator := opGreaterThanOrEqualTo; - end else - Where.Operator := opGreaterThan; - '<': case P[1] of - '=': begin - inc(P); - Where.Operator := opLessThanOrEqualTo; - end; - '>': begin - inc(P); - Where.Operator := opNotEqualTo; - end; - else - Where.Operator := opLessThan; - end; - 'i','I': - case P[1] of - 's','S': begin - P := GotoNextNotSpace(P+2); - if IdemPChar(P,'NULL') then begin - Where.Value := NULL_STR_VAR; - Where.Operator := opIsNull; - Where.ValueSQL := P; - Where.ValueSQLLen := 4; - {$ifndef NOVARIANTS} - TVarData(Where.ValueVariant).VType := varNull; - {$endif} - inc(P,4); - result := true; - end else - if IdemPChar(P,'NOT NULL') then begin - Where.Value := 'not null'; - Where.Operator := opIsNotNull; - Where.ValueSQL := P; - Where.ValueSQLLen := 8; - {$ifndef NOVARIANTS} - TVarData(Where.ValueVariant).VType := varNull; - {$endif} - inc(P,8); - result := true; // leave ValueVariant=unassigned - end; - exit; - end; - {$ifndef NOVARIANTS} - 'n','N': begin - Where.Operator := opIn; - P := GotoNextNotSpace(P+2); - if P^<>'(' then - exit; // incorrect SQL statement - B := P; // get the IN() clause as JSON - inc(P); - while (P^<>')') or (P[1]=':') do // handle :(...): within the clause - if P^=#0 then - exit else - inc(P); - inc(P); - SetString(Where.Value,PAnsiChar(B),P-B); - Where.ValueSQL := B; - Where.ValueSQLLen := P-B; - result := GetWhereValues(Where); - exit; - end; - {$endif} - end; // 'i','I': - 'l','L': - if IdemPChar(P+1,'IKE') then begin - inc(P,3); - Where.Operator := opLike; - end else - exit; - else exit; // unknown operator - end; - // we got 'WHERE FieldName operator ' -> handle value - inc(P); - result := GetWhereValue(Where); -end; - -label lim,lim2; -begin - P := pointer(SQL); - if (P=nil) or (self=nil) then - exit; // avoid GPF - P := GotoNextNotSpace(P); // trim left - if not IdemPChar(P,'SELECT ') then - exit else // handle only SELECT statement - inc(P,7); - // 1. get SELECT clause: set bits in Fields from CSV field IDs in SQL - selectCount := 0; - P := GotoNextNotSpace(P); // trim left - if P^=#0 then - exit; // no SQL statement - if P^='*' then begin // all simple (not TSQLRawBlob/TSQLRecordMany) fields - inc(P); - len := GetBitsCount(SimpleFieldsBits,MAX_SQLFIELDS)+1; - SetLength(fSelect,len); - selectCount := 1; // Select[0].Field := 0 -> ID - for ndx := 0 to MAX_SQLFIELDS-1 do - if ndx in SimpleFieldsBits then begin - fSelect[selectCount].Field := ndx+1; - inc(selectCount); - if selectCount=len then - break; - end; - GetNextFieldProp(P,Prop); - end else - if not SetFields then - exit else // we need at least one field name - if P^<>',' then - GetNextFieldProp(P,Prop) else - repeat - while P^ in [',',#1..' '] do inc(P); // trim left - until not SetFields; // add other CSV field names - // 2. get FROM clause - if not IdemPropNameU(Prop,'FROM') then exit; // incorrect SQL statement - GetNextFieldProp(P,Prop); - fTableName := Prop; - // 3. get WHERE clause - whereCount := 0; - whereWithOR := false; - whereNotClause := false; - whereBefore := ''; - GetNextFieldProp(P,Prop); - if IdemPropNameU(Prop,'WHERE') then begin - repeat - B := P; - if P^='(' then begin - fWhereHasParenthesis := true; - repeat - inc(P); - until not (P^ in [#1..' ','(']); - while P[-1]=' ' do dec(P); // trim right space - SetString(whereBefore,B,P-B); - B := P; - end; - ndx := GetPropIndex; - if ndx<0 then begin - if IdemPropNameU(Prop,'NOT') then begin - whereNotClause := true; - continue; - end; - if P^='(' then begin - inc(P); - SetLength(fWhere,whereCount+1); - with fWhere[whereCount] do begin - ParenthesisBefore := whereBefore; - JoinedOR := whereWithOR; - NotClause := whereNotClause; - FunctionName := UpperCase(Prop); - // Byte/Word/Integer/Cardinal/Int64/CurrencyDynArrayContains(BlobField,I64) - len := length(Prop); - if (len>16) and - IdemPropName('DynArrayContains',PUTF8Char(@PByteArray(Prop)[len-16]),16) then - Operator := opContains else - Operator := opFunction; - B := P; - Field := GetPropIndex; - if Field<0 then - P := B else - if P^<>',' then - break else - P := GotoNextNotSpace(P+1); - if (P^=')') or - (GetWhereValue(fWhere[whereCount]) and (P^=')')) then begin - inc(P); - break; - end; - end; - end; - P := B; - break; - end; - SetLength(fWhere,whereCount+1); - if not GetWhereExpression(ndx,fWhere[whereCount]) then - exit; // invalid SQL statement - inc(whereCount); - GetNextFieldProp(P,Prop); - if IdemPropNameU(Prop,'OR') then - whereWithOR := true else - if IdemPropNameU(Prop,'AND') then - whereWithOR := false else - goto lim2; - whereNotClause := false; - whereBefore := ''; - until false; - // 4. get optional LIMIT/OFFSET/ORDER clause -lim:P := GotoNextNotSpace(P); - while (P<>nil) and not(P^ in [#0,';']) do begin - GetNextFieldProp(P,Prop); -lim2: if IdemPropNameU(Prop,'LIMIT') then - fLimit := GetNextItemCardinal(P,' ') else - if IdemPropNameU(Prop,'OFFSET') then - fOffset := GetNextItemCardinal(P,' ') else - if IdemPropNameU(Prop,'ORDER') then begin - GetNextFieldProp(P,Prop); - if IdemPropNameU(Prop,'BY') then begin - repeat - ndx := GetPropIndex; // 0 = ID, otherwise PropertyIndex+1 - if ndx<0 then - exit; // incorrect SQL statement - AddFieldIndex(fOrderByField,ndx); - if P^<>',' then begin // check ORDER BY ... ASC/DESC - B := P; - if GetNextFieldProp(P,Prop) then - if IdemPropNameU(Prop,'DESC') then - fOrderByDesc := true else - if not IdemPropNameU(Prop,'ASC') then - P := B; - break; - end; - P := GotoNextNotSpace(P+1); - until P^ in [#0,';']; - end else - exit; // incorrect SQL statement - end else - if IdemPropNameU(Prop,'GROUP') then begin - GetNextFieldProp(P,Prop); - if IdemPropNameU(Prop,'BY') then begin - repeat - ndx := GetPropIndex; // 0 = ID, otherwise PropertyIndex+1 - if ndx<0 then - exit; // incorrect SQL statement - AddFieldIndex(fGroupByField,ndx); - if P^<>',' then - break; - P := GotoNextNotSpace(P+1); - until P^ in [#0,';']; - end else - exit; // incorrect SQL statement - end else - if (Prop<>'') or not(GotoNextNotSpace(P)^ in [#0, ';']) then - exit else // incorrect SQL statement - break; // reached the end of the statement - end; - end else - if Prop<>'' then - goto lim2; // handle LIMIT OFFSET ORDER - fSQLStatement := SQL; // make a private copy e.g. for Where[].ValueSQL -end; - -procedure TSynTableStatement.SelectFieldBits(var Fields: TSQLFieldBits; - var withID: boolean; SubFields: PRawUTF8Array); -var i: integer; - f: ^TSynTableStatementSelect; -begin - FillcharFast(Fields,SizeOf(Fields),0); - withID := false; - f := pointer(Select); - for i := 1 to Length(Select) do begin - if f^.Field=0 then - withID := true else - include(Fields,f^.Field-1); - if (SubFields<>nil) and fHasSelectSubFields then - SubFields^[f^.Field] := f^.SubField; - inc(f); - end; -end; - - -{$ifndef DELPHI5OROLDER} - -{ TSynTableData } - -procedure TSynTableData.CheckVTableInitialized; -begin - if VTable=nil then - raise ETableDataException.Create('TSynTableData non initialized'); -end; - -{$ifndef NOVARIANTS} - -function TSynTableData.GetField(const FieldName: RawUTF8): Variant; -begin - GetFieldVariant(FieldName,result); -end; - -function TSynTableData.GetFieldVarData(FieldName: PUTF8Char; FieldNameLen: PtrInt; - var Value: TVarData): boolean; -var aField: TSynTableFieldProperties; -begin - if IsRowID(FieldName,FieldNameLen) then begin - PVariant(@Value)^ := VID; - result := true; - end else begin - CheckVTableInitialized; - aField := VTable.GetFieldFromNameLen(FieldName,FieldNameLen); - if aField<>nil then begin - aField.GetVariant(VTable.GetData(pointer(VValue),aField),PVariant(@Value)^); - result := true; - end else - result := false; - end; -end; - -procedure TSynTableData.GetFieldVariant(const FieldName: RawUTF8; var result: Variant); -var aField: TSynTableFieldProperties; -begin - if IsRowID(Pointer(FieldName)) then - result := VID else begin - CheckVTableInitialized; - aField := VTable.FieldFromName[FieldName]; - if aField=nil then - raise ETableDataException.CreateUTF8('Unknown % property',[FieldName]) else - aField.GetVariant(VTable.GetData(pointer(VValue),aField),result); - end; -end; - -function TSynTableData.GetFieldValue(aField: TSynTableFieldProperties): Variant; -begin - CheckVTableInitialized; - aField.GetVariant(VTable.GetData(pointer(VValue),aField),result); -end; - -{$endif NOVARIANTS} - -procedure TSynTableData.FilterSBFValue; -begin - CheckVTableInitialized; - VTable.Filter(VValue); -end; - -function TSynTableData.GetFieldSBFValue(aField: TSynTableFieldProperties): TSBFString; -var FieldBuffer: PAnsiChar; -begin - CheckVTableInitialized; - FieldBuffer := VTable.GetData(pointer(VValue),aField); - SetString(Result,FieldBuffer,aField.GetLength(FieldBuffer)); -end; - -procedure TSynTableData.Init(aTable: TSynTable; aID: Integer); -begin - VType := SynTableVariantVarType; - VID := aID; - VTable := aTable; - VValue := VTable.DefaultRecordData; -end; - -procedure TSynTableData.Init(aTable: TSynTable; aID: Integer; - RecordBuffer: pointer; RecordBufferLen: integer); -begin - VType := SynTableVariantVarType; - VTable := aTable; - if (RecordBufferLen=0) or (RecordBuffer=nil) then begin - VID := 0; - VValue := VTable.DefaultRecordData; - end else begin - VID := aID; - SetString(VValue,PAnsiChar(RecordBuffer),RecordBufferLen); - end; -end; - -{$ifndef NOVARIANTS} -procedure TSynTableData.SetField(const FieldName: RawUTF8; - const Value: Variant); -var F: TSynTableFieldProperties; -begin - CheckVTableInitialized; - if IsRowID(Pointer(FieldName)) then - VID := Value else begin - F := VTable.FieldFromName[FieldName]; - if F=nil then - raise ETableDataException.CreateUTF8('Unknown % property',[FieldName]) else - SetFieldValue(F,Value); - end; -end; - -procedure TSynTableData.SetFieldValue(aField: TSynTableFieldProperties; const Value: Variant); -begin - SetFieldSBFValue(aField,aField.SBF(Value)); -end; -{$endif} - -procedure TSynTableData.SetFieldSBFValue(aField: TSynTableFieldProperties; - const Value: TSBFString); -var NewValue: TSBFString; -begin - CheckVTableInitialized; - if (aField.FieldSize>0) and (VValue<>'') then begin - // fixed size content: fast in-place update - MoveFast(pointer(Value)^,VValue[aField.Offset+1],aField.FieldSize) - // VValue[F.Offset+1] above will call UniqueString(VValue), even under FPC - end else begin - // variable-length update - VTable.UpdateFieldData(pointer(VValue),length(VValue), - aField.FieldNumber,NewValue,Value); - VValue := NewValue; - end; -end; - -function TSynTableData.ValidateSBFValue(RecordIndex: integer): string; -begin - CheckVTableInitialized; - Result := VTable.Validate(Pointer(VValue),RecordIndex); -end; - -{$endif DELPHI5OROLDER} - - -{ ************ text search and functions ****************** } - -// code below adapted from ZMatchPattern.pas - http://www.zeoslib.sourceforge.net - -procedure TMatch.MatchMain; -var RangeStart, RangeEnd: PtrInt; - c: AnsiChar; - flags: set of(Invert, MemberMatch); -begin - while ((State = sNONE) and (P <= PMax)) do begin - c := Upper[Pattern[P]]; - if T > TMax then begin - if (c = '*') and (P + 1 > PMax) then - State := sVALID else - State := sABORT; - exit; - end else - case c of - '?': ; - '*': - MatchAfterStar; - '[': begin - inc(P); - byte(flags) := 0; - if Pattern[P] in ['!','^'] then begin - include(flags, Invert); - inc(P); - end; - if (Pattern[P] = ']') then begin - State := sPATTERN; - exit; - end; - c := Upper[Text[T]]; - while Pattern[P] <> ']' do begin - RangeStart := P; - RangeEnd := P; - inc(P); - if P > PMax then begin - State := sPATTERN; - exit; - end; - if Pattern[P] = '-' then begin - inc(P); - RangeEnd := P; - if (P > PMax) or (Pattern[RangeEnd] = ']') then begin - State := sPATTERN; - exit; - end; - inc(P); - end; - if P > PMax then begin - State := sPATTERN; - exit; - end; - if RangeStart < RangeEnd then begin - if (c >= Upper[Pattern[RangeStart]]) and (c <= Upper[Pattern[RangeEnd]]) then begin - include(flags, MemberMatch); - break; - end; - end - else - if (c >= Upper[Pattern[RangeEnd]]) and (c <= Upper[Pattern[RangeStart]]) then begin - include(flags, MemberMatch); - break; - end; - end; - if ((Invert in flags) and (MemberMatch in flags)) or - not ((Invert in flags) or (MemberMatch in flags)) then begin - State := sRANGE; - exit; - end; - if MemberMatch in flags then - while (P <= PMax) and (Pattern[P] <> ']') do - inc(P); - if P > PMax then begin - State := sPATTERN; - exit; - end; - end; - else - if c <> Upper[Text[T]] then - State := sLITERAL; - end; - inc(P); - inc(T); - end; - if State = sNONE then - if T <= TMax then - State := sEND else - State := sVALID; -end; - -procedure TMatch.MatchAfterStar; -var retryT, retryP: PtrInt; -begin - if (TMax = 1) or (P = PMax) then begin - State := sVALID; - exit; - end else - if (PMax = 0) or (TMax = 0) then begin - State := sABORT; - exit; - end; - while ((T <= TMax) and (P < PMax)) and (Pattern[P] in ['?', '*']) do begin - if Pattern[P] = '?' then - inc(T); - inc(P); - end; - if T >= TMax then begin - State := sABORT; - exit; - end else - if P >= PMax then begin - State := sVALID; - exit; - end; - repeat - if (Upper[Pattern[P]] = Upper[Text[T]]) or (Pattern[P] = '[') then begin - retryT := T; - retryP := P; - MatchMain; - if State = sVALID then - break; - State := sNONE; // retry until end of Text, (check below) or State valid - T := retryT; - P := retryP; - end; - inc(T); - if (T > TMax) or (P > PMax) then begin - State := sABORT; - exit; - end; - until State <> sNONE; -end; - -function SearchAny(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - aMatch.State := sNONE; - aMatch.P := 0; - aMatch.T := 0; - aMatch.Text := aText; - aMatch.TMax := aTextLen - 1; - aMatch.MatchMain; - result := aMatch.State = sVALID; -end; - -// faster alternative (without recursion) for only * ? (but not [...]) - -function SearchNoRange(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -{$ifdef CPUX86} -var - c: AnsiChar; - pat, txt: PtrInt; // use local registers -begin - aMatch.T := 0; // aMatch.P/T are used for retry positions after * - aMatch.Text := aText; - aMatch.TMax := aTextLen - 1; - pat := 0; - txt := 0; - repeat - if pat <= aMatch.PMax then begin - c := aMatch.Pattern[pat]; - case c of - '?': - if txt <= aMatch.TMax then begin - inc(pat); - inc(txt); - continue; - end; - '*': begin - aMatch.P := pat; - aMatch.T := txt + 1; - inc(pat); - continue; - end; - else if (txt <= aMatch.TMax) and (c = aMatch.Text[txt]) then begin - inc(pat); - inc(txt); - continue; - end; - end; - end - else if txt > aMatch.TMax then - break; - txt := aMatch.T; - if (txt > 0) and (txt <= aMatch.TMax + 1) then begin - inc(aMatch.T); - pat := aMatch.P+1; - continue; - end; - result := false; - exit; - until false; - result := true; -end; -{$else} // optimized for x86_64/ARM with more registers -var - c: AnsiChar; - pat, patend, txtend, txtretry, patretry: PUTF8Char; -label - fin; -begin - pat := pointer(aMatch.Pattern); - if pat = nil then - goto fin; - patend := pat + aMatch.PMax; - patretry := nil; - txtend := aText + aTextLen - 1; - txtretry := nil; - repeat - if pat <= patend then begin - c := pat^; - if c <> '*' then - if c <> '?' then begin - if (aText <= txtend) and (c = aText^) then begin - inc(pat); - inc(aText); - continue; - end; - end - else begin // '?' - if aText <= txtend then begin - inc(pat); - inc(aText); - continue; - end; - end - else begin // '*' - inc(pat); - txtretry := aText + 1; - patretry := pat; - continue; - end; - end - else if aText > txtend then - break; - if (PtrInt(PtrUInt(txtretry)) > 0) and (txtretry <= txtend + 1) then begin - aText := txtretry; - inc(txtretry); - pat := patretry; - continue; - end; -fin:result := false; - exit; - until false; - result := true; -end; -{$endif CPUX86} - -function SearchNoRangeU(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -var - c: AnsiChar; - pat, txt: PtrInt; -begin - aMatch.T := 0; - aMatch.Text := aText; - aMatch.TMax := aTextLen - 1; - pat := 0; - txt := 0; - repeat - if pat <= aMatch.PMax then begin - c := aMatch.Pattern[pat]; - case c of - '?': - if txt <= aMatch.TMax then begin - inc(pat); - inc(txt); - continue; - end; - '*': begin - aMatch.P := pat; - aMatch.T := txt + 1; - inc(pat); - continue; - end; - else if (txt <= aMatch.TMax) and - (aMatch.Upper[c] = aMatch.Upper[aMatch.Text[txt]]) then begin - inc(pat); - inc(txt); - continue; - end; - end; - end - else if txt > aMatch.TMax then - break; - txt := aMatch.T; - if (txt > 0) and (txt <= aMatch.TMax + 1) then begin - inc(aMatch.T); - pat := aMatch.P+1; - continue; - end; - result := false; - exit; - until false; - result := true; -end; - -function SimpleContainsU(t, tend, p: PUTF8Char; pmax: PtrInt; up: PNormTable): boolean; - {$ifdef HASINLINE}inline;{$endif} -// brute force case-insensitive search p[0..pmax] in t..tend-1 -var first: AnsiChar; - i: PtrInt; -label next; -begin - first := up[p^]; - repeat - if up[t^] <> first then begin -next: inc(t); - if t < tend then - continue else - break; - end; - for i := 1 to pmax do - if up[t[i]] <> up[p[i]] then - goto next; - result := true; - exit; - until false; - result := false; -end; - -{$ifdef CPU64} // naive but very efficient code generation on FPC x86-64 -function SimpleContains8(t, tend, p: PUTF8Char; pmax: PtrInt): boolean; inline; -label next; -var i, first: PtrInt; -begin - first := PPtrInt(p)^; - repeat - if PPtrInt(t)^ <> first then begin -next: inc(t); - if t < tend then - continue else - break; - end; - for i := 8 to pmax do - if t[i] <> p[i] then - goto next; - result := true; - exit; - until false; - result := false; -end; -{$endif CPU64} - -function SimpleContains4(t, tend, p: PUTF8Char; pmax: PtrInt): boolean; - {$ifdef HASINLINE}inline;{$endif} -label next; -var i: PtrInt; -{$ifdef CPUX86} // circumvent lack of registers for this CPU -begin - repeat - if PCardinal(t)^ <> PCardinal(p)^ then begin -{$else} - first: cardinal; -begin - first := PCardinal(p)^; - repeat - if PCardinal(t)^ <> first then begin -{$endif} -next: inc(t); - if t < tend then - continue else - break; - end; - for i := 4 to pmax do - if t[i] <> p[i] then - goto next; - result := true; - exit; - until false; - result := false; -end; - -function SimpleContains1(t, tend, p: PUTF8Char; pmax: PtrInt): boolean; - {$ifdef HASINLINE}inline;{$endif} -label next; -var i: PtrInt; -{$ifdef CPUX86} -begin - repeat - if t^ <> p^ then begin -{$else} - first: AnsiChar; -begin - first := p^; - repeat - if t^ <> first then begin -{$endif} -next: inc(t); - if t < tend then - continue else - break; - end; - for i := 1 to pmax do - if t[i] <> p[i] then - goto next; - result := true; - exit; - until false; - result := false; -end; - -function CompareMemU(P1, P2: PUTF8Char; len: PtrInt; U: PNormTable): Boolean; - {$ifdef FPC}inline;{$endif} -begin // here we know that len>0 - result := false; - repeat - dec(len); - if U[P1[len]] <> U[P2[len]] then - exit; - until len = 0; - result := true; -end; - -function SearchVoid(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - result := aTextLen = 0; -end; - -function SearchNoPattern(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - result := (aMatch.PMax + 1 = aTextlen) and CompareMem(aText, aMatch.Pattern, aTextLen); -end; - -function SearchNoPatternU(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - result := (aMatch.PMax + 1 = aTextlen) and CompareMemU(aText, aMatch.Pattern, aTextLen, aMatch.Upper); -end; - -function SearchContainsValid(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - result := true; -end; - -function SearchContainsU(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - dec(aTextLen, aMatch.PMax); - if aTextLen > 0 then - result := SimpleContainsU(aText, aText + aTextLen, aMatch.Pattern, aMatch.PMax, aMatch.Upper) - else - result := false; -end; - -function SearchContains1(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - dec(aTextLen, aMatch.PMax); - if aTextLen > 0 then - result := SimpleContains1(aText, aText + aTextLen, aMatch.Pattern, aMatch.PMax) - else - result := false; -end; - -function SearchContains4(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - dec(aTextLen, aMatch.PMax); - if aTextLen > 0 then - result := SimpleContains4(aText, aText + aTextLen, aMatch.Pattern, aMatch.PMax) - else - result := false; -end; - -{$ifdef CPU64} -function SearchContains8(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin // optimized e.g. to search an IP address as '*12.34.56.78*' in logs - dec(aTextLen, aMatch.PMax); - if aTextLen > 0 then - result := SimpleContains8(aText, aText + aTextLen, aMatch.Pattern, aMatch.PMax) - else - result := false; -end; -{$endif CPU64} - -function SearchStartWith(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - result := (aMatch.PMax < aTextlen) and CompareMem(aText, aMatch.Pattern, aMatch.PMax + 1); -end; - -function SearchStartWithU(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - result := (aMatch.PMax < aTextlen) and CompareMemU(aText, aMatch.Pattern, aMatch.PMax + 1, aMatch.Upper); -end; - -function SearchEndWith(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - dec(aTextLen, aMatch.PMax); - result := (aTextlen >= 0) and CompareMem(aText + aTextLen, aMatch.Pattern, aMatch.PMax); -end; - -function SearchEndWithU(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - dec(aTextLen, aMatch.PMax); - result := (aTextlen >= 0) and CompareMemU(aText + aTextLen, aMatch.Pattern, aMatch.PMax, aMatch.Upper); -end; - -procedure TMatch.Prepare(const aPattern: RawUTF8; aCaseInsensitive, aReuse: boolean); -begin - Prepare(pointer(aPattern), length(aPattern), aCaseInsensitive, aReuse); -end; - -procedure TMatch.Prepare(aPattern: PUTF8Char; aPatternLen: integer; - aCaseInsensitive, aReuse: boolean); -const SPECIALS: PUTF8Char = '*?['; -begin - Pattern := aPattern; - PMax := aPatternLen - 1; // search in Pattern[0..PMax] - if Pattern = nil then begin - Search := SearchVoid; - exit; - end; - if aCaseInsensitive and not IsCaseSensitive(aPattern,aPatternLen) then - aCaseInsensitive := false; // don't slow down e.g. number or IP search - if aCaseInsensitive then - Upper := @NormToUpperAnsi7 else - Upper := @NormToNorm; - Search := nil; - if aReuse then - if strcspn(Pattern, SPECIALS) > PMax then - if aCaseInsensitive then - Search := SearchNoPatternU - else - Search := SearchNoPattern - else if PMax > 0 then begin - if Pattern[PMax] = '*' then begin - if strcspn(Pattern + 1, SPECIALS) = PMax - 1 then - case Pattern[0] of - '*': begin // *something* - inc(Pattern); - dec(PMax, 2); // trim trailing and ending * - if PMax < 0 then - Search := SearchContainsValid - else if aCaseInsensitive then - Search := SearchContainsU - {$ifdef CPU64} - else if PMax >= 7 then - Search := SearchContains8 - {$endif} - else if PMax >= 3 then - Search := SearchContains4 - else - Search := SearchContains1; - end; - '?': // ?something* - if aCaseInsensitive then - Search := SearchNoRangeU - else - Search := SearchNoRange; - '[': - Search := SearchAny; - else begin - dec(PMax); // trim trailing * - if aCaseInsensitive then - Search := SearchStartWithU - else - Search := SearchStartWith; - end; - end; - end - else if (Pattern[0] = '*') and (strcspn(Pattern + 1, SPECIALS) >= PMax) then begin - inc(Pattern); // jump leading * - if aCaseInsensitive then - Search := SearchEndWithU - else - Search := SearchEndWith; - end; - end else - if Pattern[0] in ['*','?'] then - Search := SearchContainsValid; - if not Assigned(Search) then begin - aPattern := PosChar(Pattern, '['); - if (aPattern = nil) or (aPattern - Pattern > PMax) then - if aCaseInsensitive then - Search := SearchNoRangeU - else - Search := SearchNoRange - else - Search := SearchAny; - end; -end; - -type // Holub and Durian (2005) SBNDM2 algorithm - // see http://www.cri.haifa.ac.il/events/2005/string/presentations/Holub.pdf - TSBNDMQ2Mask = array[AnsiChar] of cardinal; - PSBNDMQ2Mask = ^TSBNDMQ2Mask; - -function SearchSBNDMQ2ComputeMask(const Pattern: RawUTF8; u: PNormTable): RawByteString; -var - i: PtrInt; - p: PAnsiChar absolute Pattern; - m: PSBNDMQ2Mask absolute result; - c: PCardinal; -begin - SetString(result, nil, SizeOf(m^)); - FillCharFast(m^, SizeOf(m^), 0); - for i := 0 to length(Pattern) - 1 do begin - c := @m^[u[p[i]]]; // for FPC code generation - c^ := c^ or (1 shl i); - end; -end; - -function SearchSBNDMQ2(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -var - mask: PSBNDMQ2Mask; - max, i, j: PtrInt; - state: cardinal; -begin - mask := pointer(aMatch^.Pattern); // was filled by SearchSBNDMQ2ComputeMask() - max := aMatch^.PMax; - i := max - 1; - dec(aTextLen); - if i < aTextLen then begin - repeat - state := mask[aText[i+1]] shr 1; // in two steps for better FPC codegen - state := state and mask[aText[i]]; - if state = 0 then begin - inc(i, max); // fast skip - if i >= aTextLen then - break; - continue; - end; - j := i - max; - repeat - dec(i); - if i < 0 then - break; - state := (state shr 1) and mask[aText[i]]; - until state = 0; - if i = j then begin - result := true; - exit; - end; - inc(i, max); - if i >= aTextLen then - break; - until false; - end; - result := false; -end; - -function SearchSBNDMQ2U(aMatch: PMatch; aText: PUTF8Char; aTextLen: PtrInt): boolean; -var - u: PNormTable; - mask: PSBNDMQ2Mask; - max, i, j: PtrInt; - state: cardinal; -begin - mask := pointer(aMatch^.Pattern); - max := aMatch^.PMax; - u := aMatch^.Upper; - i := max - 1; - dec(aTextLen); - if i < aTextLen then begin - repeat - state := mask[u[aText[i+1]]] shr 1; - state := state and mask[u[aText[i]]]; - if state = 0 then begin - inc(i, max); - if i >= aTextLen then - break; - continue; - end; - j := i - max; - repeat - dec(i); - if i < 0 then - break; - state := (state shr 1) and mask[u[aText[i]]]; - until state = 0; - if i = j then begin - result := true; - exit; - end; - inc(i, max); - if i >= aTextLen then - break; - until false; - end; - result := false; -end; - -procedure TMatch.PrepareContains(var aPattern: RawUTF8; - aCaseInsensitive: boolean); -begin - PMax := length(aPattern) - 1; - if aCaseInsensitive and not IsCaseSensitive(pointer(aPattern), PMax + 1) then - aCaseInsensitive := false; - if aCaseInsensitive then - Upper := @NormToUpperAnsi7 - else - Upper := @NormToNorm; - if PMax < 0 then - Search := SearchContainsValid - else if PMax > 30 then - if aCaseInsensitive then - Search := SearchContainsU - else - Search := {$ifdef CPU64}SearchContains8{$else}SearchContains4{$endif} - else if PMax >= 1 then begin // len in [2..31] = PMax in [1..30] - aPattern := SearchSBNDMQ2ComputeMask(aPattern, Upper); // lookup table - if aCaseInsensitive then - Search := SearchSBNDMQ2U - else - Search := SearchSBNDMQ2; - end - else if aCaseInsensitive then - Search := SearchContainsU - else - Search := SearchContains1; // todo: use IndexByte() on FPC? - Pattern := pointer(aPattern); -end; - -procedure TMatch.PrepareRaw(aPattern: PUTF8Char; aPatternLen: integer; - aSearch: TMatchSearchFunction); -begin - Pattern := aPattern; - PMax := aPatternLen - 1; // search in Pattern[0..PMax] - Search := aSearch; -end; - -function TMatch.Match(const aText: RawUTF8): boolean; -begin - if aText <> '' then - result := Search(@self, pointer(aText), length(aText)) - else - result := PMax < 0; -end; - -function TMatch.Match(aText: PUTF8Char; aTextLen: PtrInt): boolean; -begin - if (aText <> nil) and (aTextLen > 0) then - result := Search(@self, aText, aTextLen) - else - result := PMax < 0; -end; - -function TMatch.MatchThreadSafe(const aText: RawUTF8): boolean; -var local: TMatch; // thread-safe with no lock! -begin - local := self; - if aText <> '' then - result := local.Search(@local, pointer(aText), length(aText)) - else - result := local.PMax < 0; -end; - -function TMatch.MatchString(const aText: string): boolean; -var - local: TMatch; // thread-safe with no lock! - temp: TSynTempBuffer; - len: integer; -begin - if aText = '' then begin - result := PMax < 0; - exit; - end; - len := length(aText); - temp.Init(len * 3); - {$ifdef UNICODE} - len := RawUnicodeToUtf8(temp.buf, temp.len + 1, pointer(aText), len, [ccfNoTrailingZero]); - {$else} - len := CurrentAnsiConvert.AnsiBufferToUTF8(temp.buf, pointer(aText), len) - temp.buf; - {$endif} - local := self; - result := local.Search(@local, temp.buf, len); - temp.Done; -end; - -function TMatch.Equals(const aAnother{$ifndef DELPHI5OROLDER}: TMatch{$endif}): boolean; -begin - result := (PMax = TMatch(aAnother).PMax) and (Upper = TMatch(aAnother).Upper) and - CompareMem(Pattern, TMatch(aAnother).Pattern, PMax + 1); -end; - -function TMatch.PatternLength: integer; -begin - result := PMax + 1; -end; - -function TMatch.PatternText: PUTF8Char; -begin - result := Pattern; -end; - -function IsMatch(const Pattern, Text: RawUTF8; CaseInsensitive: boolean): boolean; -var match: TMatch; -begin - match.Prepare(Pattern, CaseInsensitive, {reuse=}false); - result := match.Match(Text); -end; - -function IsMatchString(const Pattern, Text: string; CaseInsensitive: boolean): boolean; -var match: TMatch; - pat, txt: RawUTF8; -begin - StringToUTF8(Pattern, pat); // local variable is mandatory for FPC - StringToUTF8(Text, txt); - match.Prepare(pat, CaseInsensitive, {reuse=}false); - result := match.Match(txt); -end; - -function SetMatchs(const CSVPattern: RawUTF8; CaseInsensitive: boolean; - out Match: TMatchDynArray): integer; -var P, S: PUTF8Char; -begin - result := 0; - P := pointer(CSVPattern); - if P <> nil then - repeat - S := P; - while not (P^ in [#0, ',']) do - inc(P); - if P <> S then begin - SetLength(Match, result + 1); - Match[result].Prepare(S, P - S, CaseInsensitive, {reuse=}true); - inc(result); - end; - if P^ = #0 then - break; - inc(P); - until false; -end; - -function SetMatchs(CSVPattern: PUTF8Char; CaseInsensitive: boolean; - Match: PMatch; MatchMax: integer): integer; -var S: PUTF8Char; -begin - result := 0; - if (CSVPattern <> nil) and (MatchMax >= 0) then - repeat - S := CSVPattern; - while not (CSVPattern^ in [#0, ',']) do - inc(CSVPattern); - if CSVPattern <> S then begin - Match^.Prepare(S, CSVPattern - S, CaseInsensitive, {reuse=}true); - inc(result); - if result > MatchMax then - break; - inc(Match); - end; - if CSVPattern^ = #0 then - break; - inc(CSVPattern); - until false; -end; - -function MatchExists(const One: TMatch; const Several: TMatchDynArray): boolean; -var - i: integer; -begin - result := true; - for i := 0 to high(Several) do - if Several[i].Equals(One) then - exit; - result := false; -end; - -function MatchAdd(const One: TMatch; var Several: TMatchDynArray): boolean; -var - n: integer; -begin - result := not MatchExists(One, Several); - if result then begin - n := length(Several); - SetLength(Several, n + 1); - Several[n] := One; - end; -end; - -function MatchAny(const Match: TMatchDynArray; const Text: RawUTF8): boolean; -var - m: PMatch; - i: integer; -begin - result := true; - if Match = nil then - exit; - m := pointer(Match); - for i := 1 to length(Match) do - if m^.Match(Text) then - exit - else - inc(m); - result := false; -end; - -procedure FilterMatchs(const CSVPattern: RawUTF8; CaseInsensitive: boolean; - var Values: TRawUTF8DynArray); -var - match: TMatchDynArray; - m, n, i: integer; -begin - if SetMatchs(CSVPattern, CaseInsensitive, match) = 0 then - exit; - n := 0; - for i := 0 to high(Values) do - for m := 0 to high(match) do - if match[m].Match(Values[i]) then begin - if i <> n then - Values[n] := Values[i]; - inc(n); - break; - end; - if n <> length(Values) then - SetLength(Values, n); -end; - - -{ TMatchs } - -constructor TMatchs.Create(const aPatterns: TRawUTF8DynArray; CaseInsensitive: Boolean); -begin - inherited Create; - Subscribe(aPatterns, CaseInsensitive); -end; - -function TMatchs.Match(const aText: RawUTF8): integer; -begin - result := Match(pointer(aText), length(aText)); -end; - -function TMatchs.Match(aText: PUTF8Char; aLen: integer): integer; -var - one: ^TMatchStore; - local: TMatch; // thread-safe with no lock! -begin - if (self = nil) or (fMatch = nil) then - result := -1 // no filter by name -> allow e.g. to process everything - else begin - one := pointer(fMatch); - if aLen <> 0 then begin - for result := 0 to fMatchCount - 1 do begin - local := one^.Pattern; - if local.Search(@local, aText, aLen) then - exit; - inc(one); - end; - end - else - for result := 0 to fMatchCount - 1 do - if one^.Pattern.PMax < 0 then - exit - else - inc(one); - result := -2; - end; -end; - -function TMatchs.MatchString(const aText: string): integer; -var - temp: TSynTempBuffer; - len: integer; -begin - len := length(aText); - temp.Init(len * 3); - {$ifdef UNICODE} - len := RawUnicodeToUtf8(temp.buf, temp.len + 1, pointer(aText), len, [ccfNoTrailingZero]); - {$else} - len := CurrentAnsiConvert.AnsiBufferToUTF8(temp.buf, pointer(aText), len, true) - temp.buf; - {$endif} - result := Match(temp.buf, len); - temp.Done; -end; - -procedure TMatchs.Subscribe(const aPatternsCSV: RawUTF8; CaseInsensitive: Boolean); -var - patterns: TRawUTF8DynArray; -begin - CSVToRawUTF8DynArray(pointer(aPatternsCSV), patterns); - Subscribe(patterns, CaseInsensitive); -end; - -procedure TMatchs.Subscribe(const aPatterns: TRawUTF8DynArray; CaseInsensitive: Boolean); -var - i, j, m, n: integer; - found: ^TMatchStore; - pat: PRawUTF8; -begin - m := length(aPatterns); - if m = 0 then - exit; - n := fMatchCount; - SetLength(fMatch, n + m); - pat := pointer(aPatterns); - for i := 1 to m do begin - found := pointer(fMatch); - for j := 1 to n do - if StrComp(pointer(found^.PatternInstance), pointer(pat^)) = 0 then begin - found := nil; - break; - end - else - inc(found); - if found <> nil then - with fMatch[n] do begin - PatternInstance := pat^; // avoid GPF if aPatterns[] is released - Pattern.Prepare(PatternInstance, CaseInsensitive, {reuse=}true); - inc(n); - end; - inc(pat); - end; - fMatchCount := n; - if n <> length(fMatch) then - SetLength(fMatch, n); -end; - - -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 (tcWord in TEXT_BYTES[v]) 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; - -procedure SoundExComputeUTF8(var U: PUTF8Char; var result: cardinal; Values: PSoundExValues); -var n,v,old: cardinal; -begin - n := 0; - old := 0; - if Values<>nil then - repeat - v := GetNextUTF8Upper(U); - if not (tcWord in TEXT_BYTES[v]) 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; - - -{ 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(tcWord in TEXT_CHARS[NormToUpper[A^]]) then break else inc(A); -{$else} if not(tcWord in TEXT_CHARS[A^]) then break else inc(A); {$endif} - until false; - // find beginning of next word - repeat - if A^=#0 then exit else -{$ifdef USENORMTOUPPER} - if tcWord in TEXT_CHARS[NormToUpper[A^]] then break else inc(A); -{$else} if tcWord in TEXT_CHARS[A^] 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(tcWord in TEXT_BYTES[c]); - // find beginning of next word - repeat - if U=nil then exit; - V := U; - c := GetNextUTF8Upper(U); - if c=0 then - exit; - until tcWord in TEXT_BYTES[c]; - 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 tcWord in TEXT_CHARS[NormToUpper[A^]] do inc(A); // go to end of word - {$else} - while tcWord in TEXT_CHARS[A^] 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 ASMX64AVX} // AVX2 ASM not available on Delphi yet -// adapted from https://github.com/simdjson/simdjson - Apache License 2.0 -function IsValidUtf8LenAvx2(source: PUtf8Char; sourcelen: PtrInt): boolean; - {$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC} - test source, source - jz @ok - test sourcelen, sourcelen - jle @ok - {$ifdef win64} // this ABI doesn't consider rsi/rdi as volatile - push rsi - push rdi - {$endif} - push rbp - mov r8, source - mov rdx, sourcelen - mov rsi, r8 - mov ecx, 64 - mov rax, rsi - mov rdi, rdx - mov rbp, rsp - and rsp, 0FFFFFFFFFFFFFFE0H // align stack at 32 bytes - sub rsp, 160 - cmp rdx, 64 - cmovnc rcx, rdx - sub rcx, 64 - je @small - vpxor xmm3, xmm3, xmm3 - vmovdqa ymm7, ymmword ptr [rip + @0f] - vmovdqa ymm15, ymmword ptr [rip + @_6] - xor esi, esi - vmovdqa ymm14, ymmword ptr [rip + @_7] - vmovdqa ymm13, ymmword ptr [rip + @_8] - vmovdqa ymm5, ymm3 - vmovdqa ymm2, ymm3 - // main processing loop, 64 bytes per iteration - align 16 -@loop: vmovdqu xmm6, xmmword ptr [rax + rsi] - vinserti128 ymm0, ymm6, xmmword ptr [rax + rsi + 10H], 01H - vmovdqu xmm6, xmmword ptr [rax + rsi + 20H] - vinserti128 ymm1, ymm6, xmmword ptr [rax + rsi + 30H], 01H - add rsi, 64 - vpor ymm4, ymm1, ymm0 - vpmovmskb rdx, ymm4 // check set MSB of each 64 bytes - test edx, edx - jne @check - vpor ymm2, ymm5, ymm2 - vmovdqa ymm4, ymm2 - cmp rcx, rsi - ja @loop - // process trailing 0..63 bytes -@trail: sub rdi, rsi - jz @ended - add rsi, rax - vmovdqa xmm0, xmmword ptr [rip + @20] - lea rdx, qword ptr [rsp + 60H] // copy on stack with space padding - sub rsi, rdx - vmovdqa xmmword ptr [rdx], xmm0 - vmovdqa xmmword ptr [rdx + 10H], xmm0 - vmovdqa xmmword ptr [rdx + 20H], xmm0 - vmovdqa xmmword ptr [rdx + 30H], xmm0 -@by8: sub rdi, 8 - jb @by1 - mov rax, qword ptr [rsi + rdx] - mov qword ptr [rdx], rax - add rdx, 8 // in-order copy to preserve UTF-8 encoding - jmp @by8 -@by1: add rdi, 8 - jz @0 -@sml: mov al, byte ptr [rsi + rdx] - mov byte ptr [rdx], al - add rdx, 1 - sub rdi, 1 - jnz @sml -@0: vmovdqa ymm1, ymmword ptr [rsp + 60H] - vmovdqa ymm2, ymmword ptr [rsp + 80H] - vpor ymm0, ymm1, ymm2 - vpmovmskb rax, ymm0 // check any set MSB - test eax, eax - jne @last -@ended: vpor ymm5, ymm5, ymm4 -@final: vptest ymm5, ymm5 - sete al - vzeroupper - leave // mov rsp,rbp + pop rbp - {$ifdef win64} - pop rdi - pop rsi - {$endif} - ret -@ok: mov al, 1 - ret -@small: vpxor xmm4, xmm4, xmm4 - xor esi, esi - vmovdqa ymm3, ymm4 - vmovdqa ymm5, ymm4 - jmp @trail - // validate UTF-8 extra bytes from main loop - align 8 -@check: vpsrlw ymm9, ymm0, 4 - vpsrlw ymm12, ymm1, 4 - vperm2i128 ymm3, ymm3, ymm0, 21H - vpalignr ymm5, ymm0, ymm3, 0FH - vpalignr ymm11, ymm0, ymm3, 0EH - vpsubusb ymm11, ymm11, ymmword ptr [rip + @_9] - vpalignr ymm3, ymm0, ymm3, 0DH - vperm2i128 ymm0, ymm0, ymm1, 21H - vpsubusb ymm3, ymm3, ymmword ptr [rip + @_10] - vpalignr ymm8, ymm1, ymm0, 0FH - vpsrlw ymm10, ymm5, 4 - vpand ymm5, ymm7, ymm5 - vpsrlw ymm6, ymm8, 4 - vpalignr ymm4, ymm1, ymm0, 0EH - vpsubusb ymm4, ymm4, ymmword ptr [rip + @_9] - vpalignr ymm0, ymm1, ymm0, 0DH - vpsubusb ymm0, ymm0, ymmword ptr [rip + @_10] - vpand ymm10, ymm10, ymm7 - vpand ymm6, ymm6, ymm7 - vpand ymm8, ymm7, ymm8 - vpor ymm3, ymm3, ymm11 - vpor ymm0, ymm4, ymm0 - vpxor xmm11, xmm11, xmm11 - vpshufb ymm10, ymm15, ymm10 - vpshufb ymm5, ymm14, ymm5 - vpand ymm9, ymm9, ymm7 - vpshufb ymm6, ymm15, ymm6 - vpshufb ymm8, ymm14, ymm8 - vpand ymm12, ymm12, ymm7 - vpand ymm5, ymm5, ymm10 - vpcmpgtb ymm3, ymm3, ymm11 - vpcmpgtb ymm0, ymm0, ymm11 - vpshufb ymm9, ymm13, ymm9 - vpand ymm3, ymm3, ymmword ptr [rip + @_11] - vpand ymm0, ymm0, ymmword ptr [rip + @_11] - vpshufb ymm12, ymm13, ymm12 - vpand ymm6, ymm6, ymm8 - vpand ymm9, ymm5, ymm9 - vpsubusb ymm5, ymm1, ymmword ptr [rip + @_12] - vpand ymm12, ymm6, ymm12 - vpxor ymm9, ymm3, ymm9 - vmovdqa ymm3, ymm1 - vpxor ymm12, ymm0, ymm12 - vpor ymm9, ymm9, ymm12 - vpor ymm2, ymm9, ymm2 - vmovdqa ymm4, ymm2 - cmp rcx, rsi - ja @loop - jmp @trail - // validate UTF-8 extra bytes from input ending - align 8 -@last: vmovdqa ymm5, ymmword ptr [rip + @0f] - vperm2i128 ymm3, ymm3, ymm1, 21H - vmovdqa ymm9, ymmword ptr [rip + @_7] - vpsrlw ymm11, ymm1, 4 - vpalignr ymm0, ymm1, ymm3, 0FH - vmovdqa ymm13, ymmword ptr [rip + @_10] - vmovdqa ymm14, ymmword ptr [rip + @_9] - vpsrlw ymm6, ymm0, 4 - vpand ymm0, ymm5, ymm0 - vpand ymm11, ymm11, ymm5 - vmovdqa ymm7, ymmword ptr [rip + @_6] - vpshufb ymm10, ymm9, ymm0 - vpalignr ymm0, ymm1, ymm3, 0EH - vpand ymm6, ymm6, ymm5 - vmovdqa ymm8, ymmword ptr [rip + @_8] - vpalignr ymm3, ymm1, ymm3, 0DH - vperm2i128 ymm1, ymm1, ymm2, 21H - vpsubusb ymm0, ymm0, ymm14 - vpsubusb ymm12, ymm3, ymm13 - vpalignr ymm3, ymm2, ymm1, 0FH - vpshufb ymm6, ymm7, ymm6 - vpsrlw ymm15, ymm3, 4 - vpand ymm3, ymm5, ymm3 - vpor ymm0, ymm0, ymm12 - vpshufb ymm9, ymm9, ymm3 - vpsrlw ymm3, ymm2, 4 - vpand ymm15, ymm15, ymm5 - vpand ymm5, ymm3, ymm5 - vpalignr ymm3, ymm2, ymm1, 0EH - vpxor xmm12, xmm12, xmm12 - vpalignr ymm1, ymm2, ymm1, 0DH - vpsubusb ymm3, ymm3, ymm14 - vpshufb ymm11, ymm8, ymm11 - vpsubusb ymm1, ymm1, ymm13 - vpcmpgtb ymm0, ymm0, ymm12 - vpshufb ymm7, ymm7, ymm15 - vpor ymm1, ymm3, ymm1 - vpshufb ymm8, ymm8, ymm5 - vpsubusb ymm5, ymm2, ymmword ptr [rip + @_12] - vmovdqa ymm2, ymmword ptr [rip + @_11] - vpcmpgtb ymm1, ymm1, ymm12 - vpand ymm6, ymm6, ymm10 - vpand ymm7, ymm7, ymm9 - vpand ymm0, ymm0, ymm2 - vpand ymm11, ymm6, ymm11 - vpand ymm8, ymm7, ymm8 - vpxor ymm0, ymm0, ymm11 - vpor ymm5, ymm4, ymm5 - vpand ymm1, ymm1, ymm2 - vpxor ymm1, ymm1, ymm8 - vpor ymm0, ymm0, ymm1 - vpor ymm5, ymm0, ymm5 - jmp @final - align 16 -@20: dq 2020202020202020H - dq 2020202020202020H - align 32 -@0f: dq 0F0F0F0F0F0F0F0FH - dq 0F0F0F0F0F0F0F0FH - dq 0F0F0F0F0F0F0F0FH - dq 0F0F0F0F0F0F0F0FH -@_6: dq 0202020202020202H - dq 4915012180808080H - dq 0202020202020202H - dq 4915012180808080H -@_7: dq 0CBCBCB8B8383A3E7H - dq 0CBCBDBCBCBCBCBCBH - dq 0CBCBCB8B8383A3E7H - dq 0CBCBDBCBCBCBCBCBH -@_8: dq 0101010101010101H - dq 01010101BABAAEE6H - dq 0101010101010101H - dq 01010101BABAAEE6H -@_9: dq 0DFDFDFDFDFDFDFDFH - dq 0DFDFDFDFDFDFDFDFH - dq 0DFDFDFDFDFDFDFDFH - dq 0DFDFDFDFDFDFDFDFH -@_10: dq 0EFEFEFEFEFEFEFEFH - dq 0EFEFEFEFEFEFEFEFH - dq 0EFEFEFEFEFEFEFEFH - dq 0EFEFEFEFEFEFEFEFH -@_11: dq 8080808080808080H - dq 8080808080808080H - dq 8080808080808080H - dq 8080808080808080H -@_12: db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH - db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH - db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH - db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0EFH, 0DFH, 0BFH -end; - -function IsValidUTF8Avx2(source: PUTF8Char): Boolean; -begin - result := IsValidUTF8LenAvx2(source,StrLen(source)); -end; -{$endif ASMX64AVX} - -function IsValidUTF8Pas(source: PUTF8Char): Boolean; -var extra, i: integer; - c: cardinal; -begin - result := false; - if source<>nil then - repeat - c := byte(source^); - inc(source); - if c=0 then break else - if c and $80<>0 then begin - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - for i := 1 to extra do - if byte(source^) and $c0<>$80 then - exit else - inc(source); // check valid UTF-8 content - end; - until false; - result := true; -end; - -function IsValidUTF8LenPas(source: PUTF8Char; sourcelen: PtrInt): Boolean; -var extra, i: integer; - c: cardinal; -begin - result := false; - inc(sourcelen,PtrInt(source)); - if source<>nil then - while PtrInt(PtrUInt(source))0 then begin - extra := UTF8_EXTRABYTES[c]; - if extra=0 then exit else // invalid leading byte - for i := 1 to extra do - if (PtrInt(PtrUInt(source))>=sourcelen) or (byte(source^) and $c0<>$80) then - exit else - inc(source); // check valid UTF-8 content - end; - end; - result := true; -end; - -function IsValidUTF8(source: PUTF8Char): Boolean; -begin - result := DoIsValidUTF8(source); -end; - -function IsValidUTF8(source: PUTF8Char; sourcelen: PtrInt): Boolean; -begin - result := DoIsValidUTF8Len(source,sourcelen); -end; - -function IsValidUTF8(const source: RawUTF8): Boolean; -begin - result := DoIsValidUTF8Len(pointer(Source),length(Source)); -end; - - -{ ************ filtering and validation classes and functions *************** } - -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; - -function IsValidIP4Address(P: PUTF8Char): boolean; -var ndot: PtrInt; - V: PtrUInt; -begin - result := false; - if (P=nil) or not (P^ in ['0'..'9']) then - exit; - V := 0; - ndot := 0; - repeat - case P^ of - #0: break; - '.': if (P[-1]='.') or (V>255) then - exit else begin - inc(ndot); - V := 0; - end; - '0'..'9': V := (V*10)+ord(P^)-48; - else exit; - end; - inc(P); - until false; - if (ndot=3) and (V<=255) and (P[-1]<>'.') then - result := true; -end; - -function IsValidEmail(P: PUTF8Char): boolean; -// Initial Author: Ernesto D'Spirito - UTF-8 version by AB -// http://www.howtodothings.com/computers/a1169-validating-email-addresses-in-delphi.html -const - // Valid characters in an "atom" - atom_chars: TSynAnsicharSet = [#33..#255] - - ['(', ')', '<', '>', '@', ',', ';', ':', '\', '/', '"', '.', '[', ']', #127]; - // Valid characters in a "quoted-string" - quoted_string_chars: TSynAnsicharSet = [#0..#255] - ['"', #13, '\']; - // Valid characters in a subdomain - letters_digits: TSynAnsicharSet = ['0'..'9', 'A'..'Z', 'a'..'z']; -type - States = (STATE_BEGIN, STATE_ATOM, STATE_QTEXT, STATE_QCHAR, - STATE_QUOTE, STATE_LOCAL_PERIOD, STATE_EXPECTING_SUBDOMAIN, - STATE_SUBDOMAIN, STATE_HYPHEN); -var - State: States; - subdomains: integer; - c: AnsiChar; - ch: PtrInt; -begin - State := STATE_BEGIN; - subdomains := 1; - if P<>nil then - repeat - ch := ord(P^); - if ch and $80=0 then - inc(P) else - ch := GetHighUTF8UCS4(P); - if (ch<=255) and (WinAnsiConvert.AnsiToWide[ch]<=255) then - // convert into WinAnsi char - c := AnsiChar(ch) else - // invalid char - c := #127; - case State of - STATE_BEGIN: - if c in atom_chars then - State := STATE_ATOM else - if c='"' then - State := STATE_QTEXT else - break; - STATE_ATOM: - if c='@' then - State := STATE_EXPECTING_SUBDOMAIN else - if c='.' then - State := STATE_LOCAL_PERIOD else - if not (c in atom_chars) then - break; - STATE_QTEXT: - if c='\' then - State := STATE_QCHAR else - if c='"' then - State := STATE_QUOTE else - if not (c in quoted_string_chars) then - break; - STATE_QCHAR: - State := STATE_QTEXT; - STATE_QUOTE: - if c='@' then - State := STATE_EXPECTING_SUBDOMAIN else - if c='.' then - State := STATE_LOCAL_PERIOD else - break; - STATE_LOCAL_PERIOD: - if c in atom_chars then - State := STATE_ATOM else - if c='"' then - State := STATE_QTEXT else - break; - STATE_EXPECTING_SUBDOMAIN: - if c in letters_digits then - State := STATE_SUBDOMAIN else - break; - STATE_SUBDOMAIN: - if c='.' then begin - inc(subdomains); - State := STATE_EXPECTING_SUBDOMAIN - end else - if c='-' then - State := STATE_HYPHEN else - if not (c in letters_digits) then - break; - STATE_HYPHEN: - if c in letters_digits then - State := STATE_SUBDOMAIN else - if c<>'-' then - break; - end; - if P^=#0 then begin - P := nil; - break; - end; - until false; - result := (State = STATE_SUBDOMAIN) and (subdomains >= 2); -end; - - -{ TSynFilterOrValidate } - -constructor TSynFilterOrValidate.Create(const aParameters: RawUTF8); -begin - inherited Create; - SetParameters(aParameters); // should parse the JSON-encoded parameters -end; - -constructor TSynFilterOrValidate.CreateUTF8(const Format: RawUTF8; - const Args, Params: array of const); -begin - Create(FormatUTF8(Format,Args,Params,true)); -end; - -procedure TSynFilterOrValidate.SetParameters(const value: RawUTF8); -begin - fParameters := value; -end; - -function TSynFilterOrValidate.AddOnce(var aObjArray: TSynFilterOrValidateObjArray; - aFreeIfAlreadyThere: boolean): TSynFilterOrValidate; -var i: integer; -begin - if self<>nil then begin - for i := 0 to length(aObjArray)-1 do - if (PPointer(aObjArray[i])^=PPointer(self)^) and - (aObjArray[i].fParameters=fParameters) then begin - if aFreeIfAlreadyThere then - Free; - result := aObjArray[i]; - exit; - end; - ObjArrayAdd(aObjArray,self); - end; - result := self; -end; - - -{ TSynFilterUpperCase } - -procedure TSynFilterUpperCase.Process(aFieldIndex: integer; var value: RawUTF8); -begin - value := SynCommons.UpperCase(value); -end; - - -{ TSynFilterUpperCaseU } - -procedure TSynFilterUpperCaseU.Process(aFieldIndex: integer; var value: RawUTF8); -begin - value := UpperCaseU(value); -end; - - -{ TSynFilterLowerCase } - -procedure TSynFilterLowerCase.Process(aFieldIndex: integer; var value: RawUTF8); -begin - value := LowerCase(value); -end; - - -{ TSynFilterLowerCaseU } - -procedure TSynFilterLowerCaseU.Process(aFieldIndex: integer; var value: RawUTF8); -begin - value := LowerCaseU(value); -end; - - -{ TSynFilterTrim } - -procedure TSynFilterTrim.Process(aFieldIndex: integer; var value: RawUTF8); -begin - value := Trim(value); -end; - - -{ TSynFilterTruncate} - -procedure TSynFilterTruncate.SetParameters(const value: RawUTF8); -var V: array[0..1] of TValuePUTF8Char; - tmp: TSynTempBuffer; -begin - tmp.Init(value); - JSONDecode(tmp.buf,['MaxLength','UTF8Length'],@V); - fMaxLength := GetCardinalDef(V[0].Value,0); - fUTF8Length := V[1].Idem('1') or V[1].Idem('true'); - tmp.Done; -end; - -procedure TSynFilterTruncate.Process(aFieldIndex: integer; var value: RawUTF8); -begin - if fMaxLength-163 then - break; // exceeded 63-character limit of a DNS name - if (ForbiddenDomains<>'') and (FindCSVIndex(pointer(ForbiddenDomains),DOM)>=0) then - break; - i := length(value); - while (i>0) and (value[i]<>'.') do dec(i); - TLD := lowercase(copy(value,i+1,100)); - if (AllowedTLD<>'') and (FindCSVIndex(pointer(AllowedTLD),TLD)<0) then - break; - if (ForbiddenTLD<>'') and (FindCSVIndex(pointer(ForbiddenTLD),TLD)>=0) then - break; - if not fAnyTLD then - if FastFindPUTF8CharSorted(@TopLevelTLD,high(TopLevelTLD),pointer(TLD))<0 then - if length(TLD)<>2 then - break; // assume a two chars string is a ISO 3166-1 alpha-2 code - result := true; - exit; - until true; - ErrorMsg := Format(sInvalidEmailAddress,[UTF8ToString(value)]); - result := false; -end; - -procedure TSynValidateEmail.SetParameters(const value: RawUTF8); -var V: array[0..3] of TValuePUTF8Char; - tmp: TSynTempBuffer; -begin - inherited; - tmp.Init(value); - JSONDecode(tmp.buf,['AllowedTLD','ForbiddenTLD','ForbiddenDomains','AnyTLD'],@V); - LowerCaseCopy(V[0].Value,V[0].ValueLen,fAllowedTLD); - LowerCaseCopy(V[1].Value,V[1].ValueLen,fForbiddenTLD); - LowerCaseCopy(V[2].Value,V[2].ValueLen,fForbiddenDomains); - AnyTLD := V[3].Idem('1') or V[3].Idem('true'); - tmp.Done; -end; - - -{ TSynValidatePattern } - -procedure TSynValidatePattern.SetParameters(const Value: RawUTF8); -begin - inherited SetParameters(Value); - fMatch.Prepare(Value, ClassType=TSynValidatePatternI, {reuse=}true); -end; - -function TSynValidatePattern.Process(aFieldIndex: integer; const value: RawUTF8; - var ErrorMsg: string): boolean; - procedure SetErrorMsg; - begin - ErrorMsg := Format(sInvalidPattern,[UTF8ToString(value)]); - end; -begin - result := fMatch.Match(value); - if not result then - SetErrorMsg; -end; - - -{ TSynValidateNonVoidText } - -function Character01n(n: integer): string; -begin - if n<0 then - n := 0 else - if n>1 then - n := 2; - result := GetCSVItemString(pointer(string(sCharacter01n)),n); -end; - -procedure InvalidTextLengthMin(min: integer; var result: string); -begin - result := Format(sInvalidTextLengthMin,[min,Character01n(min)]); -end; - -function TSynValidateNonVoidText.Process(aFieldIndex: integer; const value: RawUTF8; - var ErrorMsg: string): boolean; -begin - if value='' then begin - InvalidTextLengthMin(1,ErrorMsg); - result := false; - end else - result := true; -end; - - -{ TSynValidateText } - -procedure TSynValidateText.SetErrorMsg(fPropsIndex, InvalidTextIndex, - MainIndex: integer; var result: string); -var P: PChar; -begin - P := pointer(string(sInvalidTextChar)); - result := GetCSVItemString(P,MainIndex); - if fPropsIndex>0 then - result := Format(result, - [fProps[fPropsIndex],GetCSVItemString(P,InvalidTextIndex), - Character01n(fProps[fPropsIndex])]); -end; - -function TSynValidateText.Process(aFieldIndex: integer; const value: RawUTF8; - var ErrorMsg: string): boolean; -var i, L: cardinal; - Min: array[2..7] of cardinal; -begin - result := false; - if fUTF8Length then - L := length(value) else - L := Utf8ToUnicodeLength(pointer(value)); - if LMaxLength then - ErrorMsg := Format(sInvalidTextLengthMax,[MaxLength,Character01n(MaxLength)]) else begin - FillCharFast(Min,SizeOf(Min),0); - L := length(value); - for i := 1 to L do - case value[i] of - ' ': - inc(Min[7]); - 'a'..'z': begin - inc(Min[2]); - inc(Min[5]); - end; - 'A'..'Z': begin - inc(Min[2]); - inc(Min[6]); - end; - '0'..'9': - inc(Min[3]); - '_','!',';','.',',','/',':','?','%','$','=','"','#','@','(',')','{','}', - '+','''','-','*': - inc(Min[4]); - end; - for i := 2 to 7 do - if Min[i]fProps[i+8] then begin - SetErrorMsg(i+8,i,1,ErrorMsg); - exit; - end; - if value<>'' then begin - if MaxLeftTrimCountMaxLeftTrimCount then begin - SetErrorMsg(0,0,8,ErrorMsg); - exit; - end; - end; - if MaxRightTrimCountMaxRightTrimCount then begin - SetErrorMsg(0,0,9,ErrorMsg); - exit; - end; - end; - end; - result := true; - end; -end; - -procedure TSynValidateText.SetParameters(const value: RawUTF8); -var V: array[0..high(TSynValidateTextProps)+1] of TValuePUTF8Char; - i: integer; - tmp: TSynTempBuffer; -const DEFAULT: TSynValidateTextProps = ( - 1,maxInt,0,0,0,0,0,0,maxInt,maxInt,maxInt,maxInt,maxInt,maxInt,maxInt,maxInt); -begin - if (MinLength=0) and (MaxLength=0) then // if not previously set - fProps := DEFAULT; - inherited SetParameters(value); - if value='' then - exit; - tmp.Init(value); - try - JSONDecode(tmp.buf,['MinLength','MaxLength', - 'MinAlphaCount','MinDigitCount','MinPunctCount', - 'MinLowerCount','MinUpperCount','MinSpaceCount', - 'MaxLeftTrimCount','MaxRightTrimCount', - 'MaxAlphaCount','MaxDigitCount','MaxPunctCount', - 'MaxLowerCount','MaxUpperCount','MaxSpaceCount', - 'UTF8Length'],@V); - for i := 0 to high(fProps) do - fProps[i] := GetCardinalDef(V[i].Value,fProps[i]); - with V[high(V)] do - fUTF8Length := Idem('1') or Idem('true'); - finally - tmp.Done; - end; -end; - - -{ TSynValidatePassWord } - -procedure TSynValidatePassWord.SetParameters(const value: RawUTF8); -const DEFAULT: TSynValidateTextProps = ( - 5,20,1,1,1,1,1,0,maxInt,maxInt,maxInt,maxInt,maxInt,maxInt,maxInt,0); -begin - // set default values for validating a strong password - fProps := DEFAULT; - // read custom parameters - inherited; -end; - - -{ ************ low-level buffer processing functions************************* } - -{ TSynBloomFilter } - -const - BLOOM_VERSION = 0; - BLOOM_MAXHASH = 32; // only 7 is needed for 1% false positive ratio - -constructor TSynBloomFilter.Create(aSize: integer; aFalsePositivePercent: double); -const LN2 = 0.69314718056; -begin - inherited Create; - if aSize < 0 then - fSize := 1000 else - fSize := aSize; - if aFalsePositivePercent<=0 then - fFalsePositivePercent := 1 else - if aFalsePositivePercent>100 then - fFalsePositivePercent := 100 else - fFalsePositivePercent := aFalsePositivePercent; - // see http://stackoverflow.com/a/22467497 - fBits := Round(-ln(fFalsePositivePercent/100)*aSize/(LN2*LN2)); - fHashFunctions := Round(fBits/fSize*LN2); - if fHashFunctions=0 then - fHashFunctions := 1 else - if fHashFunctions>BLOOM_MAXHASH then - fHashFunctions := BLOOM_MAXHASH; - Reset; -end; - -constructor TSynBloomFilter.Create(const aSaved: RawByteString; aMagic: cardinal); -begin - inherited Create; - if not LoadFrom(aSaved,aMagic) then - raise ESynException.CreateUTF8('%.Create with invalid aSaved content',[self]); -end; - -procedure TSynBloomFilter.Insert(const aValue: RawByteString); -begin - Insert(pointer(aValue),length(aValue)); -end; - -procedure TSynBloomFilter.Insert(aValue: pointer; aValueLen: integer); -var h: integer; - h1,h2: cardinal; // https://goo.gl/Pls5wi -begin - if (self=nil) or (aValueLen<=0) or (fBits=0) then - exit; - h1 := crc32c(0,aValue,aValueLen); - if fHashFunctions=1 then - h2 := 0 else - h2 := crc32c(h1,aValue,aValueLen); - Safe.Lock; - try - for h := 0 to fHashFunctions-1 do begin - SetBitPtr(pointer(fStore),h1 mod fBits); - inc(h1,h2); - end; - inc(fInserted); - finally - Safe.UnLock; - end; -end; - -function TSynBloomFilter.GetInserted: cardinal; -begin - Safe.Lock; - try - result := fInserted; // Delphi 5 does not support LockedInt64[] - finally - Safe.UnLock; - end; -end; - -function TSynBloomFilter.MayExist(const aValue: RawByteString): boolean; -begin - result := MayExist(pointer(aValue),length(aValue)); -end; - -function TSynBloomFilter.MayExist(aValue: pointer; aValueLen: integer): boolean; -var h: integer; - h1,h2: cardinal; // https://goo.gl/Pls5wi -begin - result := false; - if (self=nil) or (aValueLen<=0) or (fBits=0) then - exit; - h1 := crc32c(0,aValue,aValueLen); - if fHashFunctions=1 then - h2 := 0 else - h2 := crc32c(h1,aValue,aValueLen); - Safe.Lock; - try - for h := 0 to fHashFunctions-1 do - if GetBitPtr(pointer(fStore),h1 mod fBits) then - inc(h1,h2) else - exit; - finally - Safe.UnLock; - end; - result := true; -end; - -procedure TSynBloomFilter.Reset; -begin - Safe.Lock; - try - if fStore='' then - SetLength(fStore,(fBits shr 3)+1); - FillcharFast(pointer(fStore)^,length(fStore),0); - fInserted := 0; - finally - Safe.UnLock; - end; -end; - -function TSynBloomFilter.SaveTo(aMagic: cardinal): RawByteString; -var W: TFileBufferWriter; - BufLen: integer; - temp: array[word] of byte; -begin - BufLen := length(fStore)+100; - if BufLen<=SizeOf(temp) then - W := TFileBufferWriter.Create(TRawByteStringStream,@temp,SizeOf(temp)) else - W := TFileBufferWriter.Create(TRawByteStringStream,BufLen); - try - SaveTo(W,aMagic); - W.Flush; - result := TRawByteStringStream(W.Stream).DataString; - finally - W.Free; - end; -end; - -procedure TSynBloomFilter.SaveTo(aDest: TFileBufferWriter; aMagic: cardinal=$B1003F11); -begin - aDest.Write4(aMagic); - aDest.Write1(BLOOM_VERSION); - Safe.Lock; - try - aDest.Write8(fFalsePositivePercent); - aDest.Write4(fSize); - aDest.Write4(fBits); - aDest.Write1(fHashFunctions); - aDest.Write4(fInserted); - ZeroCompress(pointer(fStore),Length(fStore),aDest); - finally - Safe.UnLock; - end; -end; - -function TSynBloomFilter.LoadFrom(const aSaved: RawByteString; aMagic: cardinal): boolean; -begin - result := LoadFrom(pointer(aSaved),length(aSaved)); -end; - -function TSynBloomFilter.LoadFrom(P: PByte; PLen: integer; aMagic: cardinal): boolean; -var start: PByte; - version: integer; -begin - result := false; - start := P; - if (P=nil) or (PLen<32) or (PCardinal(P)^<>aMagic) then - exit; - inc(P,4); - version := P^; inc(P); - if version>BLOOM_VERSION then - exit; - Safe.Lock; - try - fFalsePositivePercent := unaligned(PDouble(P)^); inc(P,8); - if (fFalsePositivePercent<=0) or (fFalsePositivePercent>100) then - exit; - fSize := PCardinal(P)^; inc(P,4); - fBits := PCardinal(P)^; inc(P,4); - if fBits=BLOOM_MAXHASH then - exit; - Reset; - fInserted := PCardinal(P)^; inc(P,4); - ZeroDecompress(P,PLen-(PAnsiChar(P)-PAnsiChar(start)),fStore); - result := length(fStore)=integer(fBits shr 3)+1; - finally - Safe.UnLock; - end; -end; - - -{ TSynBloomFilterDiff } - -type - TBloomDiffHeader = packed record - kind: (bdDiff,bdFull,bdUpToDate); - size: cardinal; - inserted: cardinal; - revision: Int64; - crc: cardinal; - end; - -procedure TSynBloomFilterDiff.Insert(aValue: pointer; aValueLen: integer); -begin - Safe.Lock; - try - inherited Insert(aValue,aValueLen); - inc(fRevision); - inc(fSnapshotInsertCount); - finally - Safe.UnLock; - end; -end; - -procedure TSynBloomFilterDiff.Reset; -begin - Safe.Lock; - try - inherited Reset; - fSnapshotAfterInsertCount := fSize shr 5; - fSnapShotAfterMinutes := 30; - fSnapshotTimestamp := 0; - fSnapshotInsertCount := 0; - fRevision := UnixTimeUTC shl 31; - fKnownRevision := 0; - fKnownStore := ''; - finally - Safe.UnLock; - end; -end; - -procedure TSynBloomFilterDiff.DiffSnapshot; -begin - Safe.Lock; - try - fKnownRevision := fRevision; - fSnapshotInsertCount := 0; - SetString(fKnownStore,PAnsiChar(pointer(fStore)),length(fStore)); - if fSnapShotAfterMinutes=0 then - fSnapshotTimestamp := 0 else - fSnapshotTimestamp := GetTickCount64+fSnapShotAfterMinutes*60000; - finally - Safe.UnLock; - end; -end; - -function TSynBloomFilterDiff.SaveToDiff(const aKnownRevision: Int64): RawByteString; -var head: TBloomDiffHeader; - W: TFileBufferWriter; - temp: array[word] of byte; -begin - Safe.Lock; - try - if aKnownRevision=fRevision then - head.kind := bdUpToDate else - if (fKnownRevision=0) or - (fSnapshotInsertCount>fSnapshotAfterInsertCount) or - ((fSnapshotInsertCount>0) and (fSnapshotTimestamp<>0) and - (GetTickCount64>fSnapshotTimestamp)) then begin - DiffSnapshot; - head.kind := bdFull; - end else - if (aKnownRevisionfRevision) then - head.kind := bdFull else - head.kind := bdDiff; - head.size := length(fStore); - head.inserted := fInserted; - head.revision := fRevision; - head.crc := crc32c(0,@head,SizeOf(head)-SizeOf(head.crc)); - if head.kind=bdUpToDate then begin - SetString(result,PAnsiChar(@head),SizeOf(head)); - exit; - end; - if head.size+100<=SizeOf(temp) then - W := TFileBufferWriter.Create(TRawByteStringStream,@temp,SizeOf(temp)) else - W := TFileBufferWriter.Create(TRawByteStringStream,head.size+100); - try - W.Write(@head,SizeOf(head)); - case head.kind of - bdFull: - SaveTo(W); - bdDiff: - ZeroCompressXor(pointer(fStore),pointer(fKnownStore),head.size,W); - end; - W.Flush; - result := TRawByteStringStream(W.Stream).DataString; - finally - W.Free; - end; - finally - Safe.UnLock; - end; -end; - -function TSynBloomFilterDiff.DiffKnownRevision(const aDiff: RawByteString): Int64; -var head: ^TBloomDiffHeader absolute aDiff; -begin - if (length(aDiff)high(head.kind)) or - (head.size<>cardinal(length(fStore))) or - (head.crc<>crc32c(0,pointer(head),SizeOf(head^)-SizeOf(head.crc))) then - result := 0 else - result := head.Revision; -end; - -function TSynBloomFilterDiff.LoadFromDiff(const aDiff: RawByteString): boolean; -var head: ^TBloomDiffHeader absolute aDiff; - P: PByte; - PLen: integer; -begin - result := false; - P := pointer(aDiff); - PLen := length(aDiff); - if (PLenhigh(head.kind)) or - (head.crc<>crc32c(0,pointer(head),SizeOf(head^)-SizeOf(head.crc))) then - exit; - if (fStore<>'') and (head.size<>cardinal(length(fStore))) then - exit; - inc(P,SizeOf(head^)); - dec(PLen,SizeOf(head^)); - Safe.Lock; - try - case head.kind of - bdFull: - result := LoadFrom(P,PLen); - bdDiff: - if fStore<>'' then - result := ZeroDecompressOr(pointer(P),Pointer(fStore),PLen,head.size); - bdUpToDate: - result := true; - end; - if result then begin - fRevision := head.revision; - fInserted := head.inserted; - end; - finally - Safe.UnLock; - end; -end; - -procedure ZeroCompress(P: PAnsiChar; Len: integer; Dest: TFileBufferWriter); -var PEnd,beg,zero: PAnsiChar; - crc: cardinal; -begin - Dest.WriteVarUInt32(Len); - PEnd := P+Len; - beg := P; - crc := 0; - while P#0) and (P3 then begin - Len := zero-beg; - crc := crc32c(crc,beg,Len); - Dest.WriteVarUInt32(Len); - Dest.Write(beg,Len); - Len := P-zero; - crc := crc32c(crc,@Len,SizeOf(Len)); - Dest.WriteVarUInt32(Len-3); - beg := P; - end; - end; - Len := P-beg; - if Len>0 then begin - crc := crc32c(crc,beg,Len); - Dest.WriteVarUInt32(Len); - Dest.Write(beg,Len); - end; - Dest.Write4(crc); -end; - -procedure ZeroCompressXor(New,Old: PAnsiChar; Len: cardinal; Dest: TFileBufferWriter); -var beg,same,index,crc,L: cardinal; -begin - Dest.WriteVarUInt32(Len); - beg := 0; - index := 0; - crc := 0; - while indexOld[index]) and (index3 then begin - Dest.WriteVarUInt32(same-beg); - Dest.WriteXor(New+beg,Old+beg,same-beg,@crc); - crc := crc32c(crc,@L,SizeOf(L)); - Dest.WriteVarUInt32(L-3); - beg := index; - end; - end; - L := index-beg; - if L>0 then begin - Dest.WriteVarUInt32(L); - Dest.WriteXor(New+beg,Old+beg,L,@crc); - end; - Dest.Write4(crc); -end; - -procedure ZeroDecompress(P: PByte; Len: integer; {$ifdef FPC}var{$else}out{$endif} Dest: RawByteString); -var PEnd,D,DEnd: PAnsiChar; - DestLen,crc: cardinal; -begin - PEnd := PAnsiChar(P)+Len-4; - DestLen := FromVarUInt32(P); - SetString(Dest,nil,DestLen); // FPC uses var - D := pointer(Dest); - DEnd := D+DestLen; - crc := 0; - while PAnsiChar(P)DEnd then - break; - MoveFast(P^,D^,Len); - crc := crc32c(crc,D,Len); - inc(P,Len); - inc(D,Len); - if PAnsiChar(P)>=PEnd then - break; - Len := FromVarUInt32(P)+3; - if D+Len>DEnd then - break; - FillCharFast(D^,Len,0); - crc := crc32c(crc,@Len,SizeOf(Len)); - inc(D,Len); - end; - if crc<>PCardinal(P)^ then - Dest := ''; -end; - -function ZeroDecompressOr(P,Dest: PAnsiChar; Len,DestLen: integer): boolean; -var PEnd,DEnd: PAnsiChar; - crc: cardinal; -begin - PEnd := P+Len-4; - if cardinal(DestLen)<>FromVarUInt32(PByte(P)) then begin - result := false; - exit; - end; - DEnd := Dest+DestLen; - crc := 0; - while (PDEnd then - break; - crc := crc32c(crc,P,Len); - OrMemory(pointer(Dest),pointer(P),Len); - inc(P,Len); - inc(Dest,Len); - if P>=PEnd then - break; - Len := FromVarUInt32(PByte(P))+3; - crc := crc32c(crc,@Len,SizeOf(Len)); - inc(Dest,Len); - end; - result := crc=PCardinal(P)^; -end; - - -function Max(a,b: PtrInt): PtrInt; {$ifdef HASINLINE}inline;{$endif} -begin - if a > b then - result := a else - result := b; -end; - -function Min(a,b: PtrInt): PtrInt; {$ifdef HASINLINE}inline;{$endif} -begin - if a < b then - result := a else - result := b; -end; - -function Comp(a,b: PAnsiChar; len: PtrInt): PtrInt; -{$ifdef HASINLINE} inline; -var lenptr: PtrInt; -begin - result := 0; - lenptr := len-SizeOf(PtrInt); - if lenptr>=0 then - repeat - if PPtrInt(a+result)^<>PPtrInt(b+result)^ then - break; - inc(result,SizeOf(PtrInt)); - until result>lenptr; - if resultb[result] then - exit; - inc(result); - until result=len; -end; -{$else} // eax = a, edx = b, ecx = len -asm // the 'rep cmpsb' version is slower on Intel Core CPU (not AMD) - or ecx,ecx - push ebx - push ecx - jz @ok -@1: mov bx,[eax] - lea eax,[eax+2] - cmp bl,[edx] - jne @ok - dec ecx - jz @ok - cmp bh,[edx+1] - lea edx,[edx+2] - jne @ok - dec ecx - jnz @1 -@ok: pop eax - sub eax,ecx - pop ebx -end; -{$endif} - -function CompReverse(a,b: pointer; len: PtrInt): PtrInt; -begin - result := 0; - if len>0 then - repeat - if PByteArray(a)[-result]<>PByteArray(b)[-result] then - exit; - inc(result); - until result=len; -end; - -procedure movechars(s,d: PAnsiChar; t: PtrUInt); - {$ifdef HASINLINE}inline;{$endif} -// this code is sometimes used rather than MoveFast() for overlapping copy -begin - dec(PtrUInt(s), PtrUInt(d)); - inc(t, PtrUInt(d)); - repeat - d^ := s[PtrUInt(d)]; - inc(d); - until PtrUInt(d)=t; -end; - -function WriteCurOfs(curofs,curlen,curofssize: integer; sp: PAnsiChar): PAnsiChar; -begin - if curlen=0 then begin - sp^ := #0; - inc(sp); - end else begin - sp := Pointer(ToVarUInt32(curlen,PByte(sp))); - PInteger(sp)^ := curofs; - inc(sp,curofssize); - end; - result := sp; -end; - -{$ifdef CPUINTEL} // crc32c SSE4.2 hardware accellerated dword hash -function crc32csse42(buf: pointer): cardinal; -{$ifdef CPUX86} {$ifdef FPC} nostackframe; assembler; {$endif} -asm - mov edx, eax - xor eax, eax - {$ifdef ISDELPHI2010} - crc32 eax, dword ptr[edx] - {$else} - db $F2, $0F, $38, $F1, $02 - {$endif} -end; -{$else} {$ifdef FPC}nostackframe; assembler; asm {$else} -asm // ecx=buf (Linux: edi=buf) - .noframe -{$endif FPC} - xor eax, eax - crc32 eax, dword ptr[buf] -end; -{$endif CPUX86} -{$endif CPUINTEL} - -function hash32prime(buf: pointer): cardinal; -begin // xxhash32-inspired - and won't pollute L1 cache with lookup tables - result := PCardinal(buf)^; - result := result xor (result shr 15); - result := result * 2246822519; - result := result xor (result shr 13); - result := result * 3266489917; - result := result xor (result shr 16); -end; - -const - HTabBits = 18; // fits well with DeltaCompress(..,BufSize=2MB) - HTabMask = (1 shl HTabBits)-1; // =$3ffff - HListMask = $ffffff; // HTab[]=($ff,$ff,$ff) - -type - PHTab = ^THTab; // HTabBits=18 -> SizeOf=767KB - THTab = packed array[0..HTabMask] of array[0..2] of byte; - -function DeltaCompute(NewBuf, OldBuf, OutBuf, WorkBuf: PAnsiChar; - NewBufSize, OldBufSize, MaxLevel: PtrInt; HList, HTab: PHTab): PAnsiChar; -var i, curofs, curlen, curlevel, match, curofssize, h, oldh: PtrInt; - sp, pInBuf, pOut: PAnsiChar; - ofs: cardinal; - spb: PByte absolute sp; - hash: function(buf: pointer): cardinal; -begin - // 1. fill HTab[] with hashes for all old data - {$ifdef CPUINTEL} - if cfSSE42 in CpuFeatures then - hash := @crc32csse42 else - {$endif} - hash := @hash32prime; - FillCharFast(HTab^,SizeOf(HTab^),$ff); // HTab[]=HListMask by default - pInBuf := OldBuf; - oldh := -1; // force calculate first hash - sp := pointer(HList); - for i := 0 to OldBufSize-3 do begin - h := hash(pInBuf) and HTabMask; - inc(pInBuf); - if h=oldh then - continue; - oldh := h; - h := PtrInt(@HTab^[h]); // fast 24-bit data process - PCardinal(sp)^ := PCardinal(h)^; - PCardinal(h)^ := cardinal(i) or (PCardinal(h)^ and $ff000000); - inc(sp,3); - end; - // 2. compression init - if OldBufSize<=$ffff then - curofssize := 2 else - curofssize := 3; - curlen := -1; - curofs := 0; - pOut := OutBuf+7; - sp := WorkBuf; - // 3. handle identical leading bytes - match := Comp(OldBuf,NewBuf,Min(OldBufSize,NewBufSize)); - if match>2 then begin - sp := WriteCurOfs(0,match,curofssize,sp); - sp^ := #0; inc(sp); - inc(NewBuf,match); - dec(NewBufSize,match); - end; - pInBuf := NewBuf; - // 4. main loop: identify longest sequences using hash, and store reference - if NewBufSize>=8 then - repeat - // hash 4 next bytes from NewBuf, and find longest match in OldBuf - ofs := PCardinal(@HTab^[hash(NewBuf) and HTabMask])^ and HListMask; - if ofs<>HListMask then begin // brute force search loop of best hash match - curlevel := MaxLevel; - repeat - with PHash128Rec(OldBuf+ofs)^ do - {$ifdef CPU64} // test 8 bytes - if PHash128Rec(NewBuf)^.Lo=Lo then begin - {$else} - if (PHash128Rec(NewBuf)^.c0=c0) and (PHash128Rec(NewBuf)^.c1=c1) then begin - {$endif} - match := Comp(@PHash128Rec(NewBuf)^.c2,@c2,Min(PtrUInt(OldBufSize)-ofs,NewBufSize)-8); - if match>curlen then begin // found a longer sequence - curlen := match; - curofs := ofs; - end; - end; - dec(curlevel); - ofs := PCardinal(@HList^[ofs])^ and HListMask; - until (ofs=HListMask) or (curlevel=0); - end; - // curlen = longest sequence length - if curlen<0 then begin // no sequence found -> copy one byte - dec(NewBufSize); - pOut^ := NewBuf^; - inc(NewBuf); - inc(pOut); - if NewBufSize>8 then // >=8 may overflow - continue else - break; - end; - inc(curlen,8); - sp := WriteCurOfs(curofs,curlen,curofssize,sp); - spb := ToVarUInt32(NewBuf-pInBuf,spb); - inc(NewBuf,curlen); // continue to search after the sequence - dec(NewBufSize,curlen); - curlen := -1; - pInBuf := NewBuf; - if NewBufSize>8 then // >=8 may overflow - continue else - break; - until false; - // 5. write remaining bytes - if NewBufSize>0 then begin - MoveFast(NewBuf^,pOut^,NewBufSize); - inc(pOut,NewBufSize); - inc(newBuf,NewBufSize); - end; - sp^ := #0; inc(sp); - spb := ToVarUInt32(NewBuf-pInBuf,spb); - // 6. write header - PInteger(OutBuf)^ := pOut-OutBuf-7; - h := sp-WorkBuf; - PInteger(OutBuf+3)^ := h; - OutBuf[6] := AnsiChar(curofssize); - // 7. copy commands - MoveFast(WorkBuf^,pOut^,h); - result := pOut+h; -end; - -function ExtractBuf(GoodCRC: cardinal; p: PAnsiChar; var aUpd, Delta: PAnsiChar; - Old: PAnsiChar): TDeltaError; -var pEnd, buf, upd, src: PAnsiChar; - bufsize, datasize, leading, srclen: PtrUInt; - curofssize: byte; -begin - // 1. decompression init - upd := aUpd; - bufsize := PCardinal(p)^ and $00ffffff; inc(p,3); - datasize := PCardinal(p)^ and $00ffffff; inc(p,3); - curofssize := ord(p^); inc(p); - buf := p; inc(p,bufsize); - pEnd := p+datasize; - src := nil; - // 2. main loop - while p0 then - if curofssize=2 then begin - src := Old+PWord(p)^; - inc(p,2); - end else begin - src := Old+PCardinal(p)^ and $00ffffff; - inc(p,3); - end; - // copy leading bytes - leading := FromVarUInt32(PByte(P)); - if leading<>0 then begin - MoveFast(buf^,upd^,leading); - inc(buf,leading); - inc(upd,leading); - end; - // copy sequence - if srclen<>0 then begin - if PtrUInt(upd-src) direct copy of whole block - CreateCopied; - exit; - end; - // 2. compression init - bigfile := OldSize>BufSize; - if BufSize>NewSize then - BufSize := NewSize; - if BufSize>$ffffff then - BufSize := $ffffff; // we store offsets with 2..3 bytes -> max 16MB chunk - Trailing := 0; - Getmem(workbuf,BufSize); // compression temporary buffers - Getmem(HList,BufSize*SizeOf(HList[0])); - Getmem(HTab,SizeOf(HTab^)); - Getmem(Delta,Max(NewSize,OldSize)+4096); // Delta size max evalulation - try - d := Delta; - db := ToVarUInt32(NewSize,db); // Destination Size - // 3. handle leading and trailing identical bytes (for biggest files) - if bigfile then begin - BufRead := Comp(New,Old,Min(NewSize,OldSize)); // test 1st same chars - if BufRead>9 then begin // it happens very often - db := ToVarUInt32(BufRead,db); // blockSize = Size BufIdem - WriteByte(d,FLAG_BEGIN); - WriteInt(d,crc32c(0,New,BufRead)); - inc(New,BufRead); - dec(NewSize,BufRead); - inc(Old,BufRead); - dec(OldSize,BufRead); - end; // test last same chars - BufRead := CompReverse(New+NewSize-1,Old+OldSize-1,Min(NewSize,OldSize)); - if BufRead>5 then begin - if NewSize=BufRead then - dec(BufRead); // avoid block overflow - dec(OldSize,BufRead); - dec(NewSize,BufRead); - Trailing := BufRead; - end; - end; - // 4. main loop - repeat - BufRead := Min(BufSize,NewSize); - dec(NewSize,BufRead); - if (BufRead=0) and (Trailing>0) then begin - db := ToVarUInt32(Trailing,db); - WriteByte(d,FLAG_END); // block idem end flag -> BufRead := 0 not necessary - WriteInt(d,crc32c(0,New,Trailing)); - break; - end; - OldRead := Min(BufSize,OldSize); - dec(OldSize,OldRead); - db := ToVarUInt32(OldRead,db); - If (BufRead<4) or (OldRead<4) or (BufRead div 4>OldRead) then begin - WriteByte(d,FLAG_COPIED); // block copied flag - db := ToVarUInt32(BufRead,db); - if BufRead=0 then - break; - WriteInt(d,crc32c(0,New,BufRead)); - MoveFast(New^,d^,BufRead); - inc(New,BufRead); - inc(d,BufRead); - end else begin - WriteByte(d,FLAG_COMPRESS); // block compressed flag - WriteInt(d,crc32c(0,New,BufRead)); - WriteInt(d,crc32c(0,Old,OldRead)); - d := DeltaCompute(New,Old,d,workbuf,BufRead,OldRead,Level,HList,HTab); - inc(New,BufRead); - inc(Old,OldRead); - end; - until false; - // 5. release temp memory - finally - result := d-Delta; - Freemem(HTab); - Freemem(HList); - Freemem(workbuf); - end; - if result>=NewSizeSave+17 then begin - // Delta didn't compress well -> store it (with 17 bytes overhead) - Freemem(Delta); - CreateCopied; - end; -end; - -function DeltaCompress(const New, Old: RawByteString; - Level, BufSize: integer): RawByteString; -begin - result := DeltaCompress(pointer(New),pointer(Old), - length(New),length(Old),Level,BufSize); -end; - -function DeltaCompress(New, Old: PAnsiChar; NewSize, OldSize: integer; - Level, BufSize: integer): RawByteString; -var Delta: PAnsiChar; - DeltaLen: integer; -begin - DeltaLen := DeltaCompress(New,Old,Newsize,OldSize,Delta,Level,BufSize); - SetString(result,Delta,DeltaLen); - Freemem(Delta); -end; - -function DeltaExtract(Delta,Old,New: PAnsiChar): TDeltaError; -var BufCRC: Cardinal; - Code: Byte; - Len, BufRead, OldRead: PtrInt; - db: PByte absolute Delta; - Upd: PAnsiChar; -begin - Result := dsSuccess; - Len := FromVarUInt32(db); - Upd := New; - repeat - OldRead := FromVarUInt32(db); - Code := db^; inc(db); - Case Code of - FLAG_COPIED: begin // block copied flag - copy new from Delta - BufRead := FromVarUInt32(db); - If BufRead=0 then - break; - If crc32c(0,Delta+4,BufRead)<>PCardinal(Delta)^ then begin - result := dsCrcCopy; - exit; - end; - inc(Delta,4); - MoveFast(Delta^,New^,BufRead); - if BufRead>=Len then - exit; // if Old=nil -> only copy new - inc(Delta,BufRead); - inc(New,BufRead); - end; - FLAG_COMPRESS: begin // block compressed flag - extract Delta from Old - BufCRC := PCardinal(Delta)^; inc(Delta,4); - if crc32c(0,Old,OldRead)<>PCardinal(Delta)^ then begin - result := dsCrcComp; - exit; - end; - inc(Delta,4); - result := ExtractBuf(BufCRC,Delta,New,Delta,Old); - if result<>dsSuccess then - exit; - end; - FLAG_BEGIN: begin // block idem begin flag - if crc32c(0,Old,OldRead)<>PCardinal(Delta)^ then begin - result := dsCrcBegin; - exit; - end; - inc(Delta,4); - MoveFast(Old^,New^,OldRead); - inc(New,OldRead); - end; - FLAG_END: begin // block idem end flag - if crc32c(0,Old,OldRead)<>PCardinal(Delta)^ then - Result := dsCrcEnd; - MoveFast(Old^,New^,OldRead); - inc(New,OldRead); - break; - end; - else begin - result := dsFlag; - exit; - end; - end; // Case Code of - inc(Old,OldRead); - until false; - if New-Upd<>Len then - result := dsLen; -end; - -function DeltaExtract(const Delta,Old: RawByteString; out New: RawByteString): TDeltaError; -begin - if (Delta='') or (Delta='=') then begin - New := Old; - result := dsSuccess; - end else begin - SetLength(New,DeltaExtractSize(pointer(Delta))); - result := DeltaExtract(pointer(Delta),pointer(Old),pointer(New)); - end; -end; - -function DeltaExtractSize(const Delta: RawByteString): integer; -begin - result := DeltaExtractSize(pointer(Delta)); -end; - -function DeltaExtractSize(Delta: PAnsiChar): integer; -begin - if Delta=nil then - result := 0 else - result := FromVarUInt32(PByte(Delta)); -end; - -function ToText(err: TDeltaError): PShortString; -begin - result := GetEnumName(TypeInfo(TDeltaError),ord(err)); -end; - - -{ TFastReader } - -procedure TFastReader.Init(Buffer: pointer; Len: integer); -begin - P := Buffer; - Last := P+Len; - OnErrorOverflow := nil; - OnErrorData := nil; - Tag := 0; -end; - -procedure TFastReader.Init(const Buffer: RawByteString); -begin - Init(pointer(Buffer),length(Buffer)); -end; - -procedure TFastReader.ErrorOverflow; -begin - if Assigned(OnErrorOverflow) then - OnErrorOverflow else - raise EFastReader.Create('Reached End of Input'); -end; - -procedure TFastReader.ErrorData(const fmt: RawUTF8; const args: array of const); -begin - if Assigned(OnErrorData) then - OnErrorData(fmt,args) else - raise EFastReader.CreateUTF8('Incorrect Data: '+fmt,args); -end; - -function TFastReader.EOF: boolean; -begin - result := P>=Last; -end; - -function TFastReader.RemainingLength: PtrUInt; -begin - result := PtrUInt(Last)-PtrUInt(P); -end; - -function TFastReader.NextByte: byte; -begin - if P>=Last then - ErrorOverflow; - result := ord(P^); - inc(P); -end; - -function TFastReader.NextByteSafe(dest: pointer): boolean; -begin - if P>=Last then - result := false - else begin - PAnsiChar(dest)^ := P^; - inc(P); - result := true; - end; -end; - -function TFastReader.Next4: cardinal; -begin - if P+3>=Last then - ErrorOverflow; - result := PCardinal(P)^; - inc(P,4); -end; - -function TFastReader.Next8: QWord; -begin - if P+7>=Last then - ErrorOverflow; - result := PQWord(P)^; - inc(P,8); -end; - -function TFastReader.NextByteEquals(Value: byte): boolean; -begin - if P>=Last then - ErrorOverflow; - if ord(P^) = Value then begin - inc(P); - result := true; - end else - result := false; -end; - -function TFastReader.Next(DataLen: PtrInt): pointer; -begin - if P+DataLen>Last then - ErrorOverflow; - result := P; - inc(P,DataLen); -end; - -function TFastReader.NextSafe(out Data: Pointer; DataLen: PtrInt): boolean; -begin - if P+DataLen>Last then - result := false else begin - Data := P; - inc(P,DataLen); - result := true; - end; -end; - -procedure TFastReader.Copy(out Dest; DataLen: PtrInt); -begin - if P+DataLen>Last then - ErrorOverflow; - MoveFast(P^,Dest,DataLen); - inc(P,DataLen); -end; - -function TFastReader.CopySafe(out Dest; DataLen: PtrInt): boolean; -begin - if P+DataLen>Last then - result := false else begin - MoveFast(P^,Dest,DataLen); - inc(P,DataLen); - result := true; - end; -end; - -procedure TFastReader.VarBlob(out result: TValueResult); -begin - result.Len := VarUInt32; - if P+result.Len>Last then - ErrorOverflow; - result.Ptr := P; - inc(P,result.Len); -end; - -function TFastReader.VarBlob: TValueResult; -begin - result.Len := VarUInt32; - if P+result.Len>Last then - ErrorOverflow; - result.Ptr := P; - inc(P,result.Len); -end; - -{$ifndef NOVARIANTS} -procedure TFastReader.NextVariant(var Value: variant; - CustomVariantOptions: PDocVariantOptions); -begin - P := VariantLoad(Value,P,CustomVariantOptions,Last); - if P=nil then - ErrorData('VariantLoad=nil',[]) else - if P>Last then - ErrorOverFlow; -end; - -procedure TFastReader.NextDocVariantData(out Value: variant; - CustomVariantOptions: PDocVariantOptions); -var json: TValueResult; - temp: TSynTempBuffer; -begin - VarBlob(json); - if json.Len<=0 then - exit; - temp.Init(json.Ptr,json.Len); // parsing will modify input buffer in-place - try - if CustomVariantOptions=nil then - CustomVariantOptions := @JSON_OPTIONS[true]; - TDocVariantData(Value).InitJSONInPlace(temp.buf,CustomVariantOptions^); - finally - temp.Done; - end; -end; -{$endif NOVARIANTS} - -function TFastReader.VarInt32: integer; -begin - result := VarUInt32; - 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 TFastReader.VarInt64: Int64; -begin - result := VarUInt64; - 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 TFastReader.VarUInt32: cardinal; -var c: cardinal; -{$ifdef CPUX86} // not enough CPU registers -label err; -begin - result := ord(P^); - if P>=Last then - goto err; - inc(P); - if result<=$7f then - exit; - if P>=Last then - goto err; - c := ord(P^) shl 7; - inc(P); - result := result and $7F or c; - if c<=$7f shl 7 then - exit; // Values between 128 and 16256 - if P>=Last then - goto err; - c := ord(P^) shl 14; - inc(P); - result := result and $3FFF or c; - if c<=$7f shl 14 then - exit; // Values between 16257 and 2080768 - if P>=Last then - goto err; - c := ord(P^) shl 21; - inc(P); - result := result and $1FFFFF or c; - if c<=$7f shl 21 then - exit; // Values between 2080769 and 266338304 - if P>=Last then -err:ErrorOverflow; - c := ord(P^) shl 28; - inc(P); - result := result and $FFFFFFF or c; -{$else} - s,l: PByte; -label err,fin; -begin - s := pointer(P); - l := pointer(Last); - result := s^; - if PAnsiChar(s)>=PAnsiChar(l) then - goto err; - inc(s); - if result<=$7f then - goto fin; - if PAnsiChar(s)>=PAnsiChar(l) then - goto err; - c := s^ shl 7; - inc(s); - result := result and $7F or c; - if c<=$7f shl 7 then - goto fin; // Values between 128 and 16256 - if PAnsiChar(s)>=PAnsiChar(l) then - goto err; - c := s^ shl 14; - inc(s); - result := result and $3FFF or c; - if c<=$7f shl 14 then - goto fin; // Values between 16257 and 2080768 - if PAnsiChar(s)>=PAnsiChar(l) then - goto err; - c := s^ shl 21; - inc(s); - result := result and $1FFFFF or c; - if c<=$7f shl 21 then - goto fin; // Values between 2080769 and 266338304 - if PAnsiChar(s)>=PAnsiChar(l) then -err:ErrorOverflow; - c := s^ shl 28; - inc(s); - result := result and $FFFFFFF or c; -fin: - P := pointer(s); -{$endif} -end; - -procedure TFastReader.VarNextInt; -{$ifdef CPUX86} // not enough CPU registers -begin - repeat - if P>=Last then - break; // reached end of input - if P^<=#$7f then - break; // reached end of VarUInt32/VarUInt64 - inc(P); - until false; - inc(P); -{$else} -var s: PAnsiChar; -begin - s := P; - repeat - if s>=Last then - break; // reached end of input - if s^<=#$7f then - break; // reached end of VarUInt32/VarUInt64 - inc(s); - until false; - P := s+1; -{$endif CPUX86} -end; - -procedure TFastReader.VarNextInt(count: integer); -{$ifdef CPUX86} // not enough CPU registers -begin - if count=0 then - exit; - repeat - if P>=Last then - break; // reached end of input - if P^>#$7f then begin - inc(P); - continue; // didn't reach end of VarUInt32/VarUInt64 - end; - inc(P); - dec(count); - if count=0 then - break; - until false; -{$else} -var s, max: PAnsiChar; -begin - if count=0 then - exit; - s := P; - max := Last; - repeat - if s>=max then - break; // reached end of input - if s^>#$7f then begin - inc(s); - continue; // didn't reach end of VarUInt32/VarUInt64 - end; - inc(s); - dec(count); - if count=0 then - break; - until false; - P := s; -{$endif CPUX86} -end; - -function TFastReader.PeekVarInt32(out value: PtrInt): boolean; -begin - result := PeekVarUInt32(PtrUInt(value)); - if result then - if value and 1<>0 then - // 1->1, 3->2.. - value := value shr 1+1 else - // 0->0, 2->-1, 4->-2.. - value := -(value shr 1); -end; - -function TFastReader.PeekVarUInt32(out value: PtrUInt): boolean; -var s: PAnsiChar; -begin - result := false; - s := P; - repeat - if s>=Last then - exit; // reached end of input -> returns false - if s^<=#$7f then - break; // reached end of VarUInt32 - inc(s); - until false; - s := P; - value := VarUInt32; // fast value decode - P := s; // rewind - result := true; -end; - -function TFastReader.VarUInt32Safe(out Value: cardinal): boolean; -var c, n, v: cardinal; -begin - result := false; - if P>=Last then - exit; - v := ord(P^); - inc(P); - if v>$7f then begin - n := 0; - v := v and $7F; - repeat - if P>=Last then - exit; - c := ord(P^); - inc(P); - inc(n,7); - if c<=$7f then break; - v := v or ((c and $7f) shl n); - until false; - v := v or (c shl n); - end; - Value := v; - result := true; // success -end; - -function TFastReader.VarUInt64: QWord; -label err; -var c, n: PtrUInt; -begin - if P>=Last then -err: ErrorOverflow; - c := ord(P^); - inc(P); - if c>$7f then begin - result := c and $7F; - n := 0; - repeat - if P>=Last then - goto err; - c := ord(P^); - inc(P); - 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 else - result := c; -end; - -function TFastReader.VarString: RawByteString; -begin - with VarBlob do - SetString(result,Ptr,Len); -end; - -procedure TFastReader.VarUTF8(out result: RawUTF8); -begin - with VarBlob do - FastSetString(result,Ptr,Len); -end; - -function TFastReader.VarUTF8: RawUTF8; -begin - with VarBlob do - FastSetString(result,Ptr,Len); -end; - -function TFastReader.VarShortString: shortstring; -begin - with VarBlob do - SetString(result,Ptr,Len); -end; - -function TFastReader.VarUTF8Safe(out Value: RawUTF8): boolean; -var len: cardinal; -begin - if VarUInt32Safe(len) then - if len=0 then - result := true else - if P+len<=Last then begin - FastSetString(Value,P,len); - inc(P,len); - result := true; - end else - result := false else - result := false; -end; - -procedure TFastReader.Read(var DA: TDynArray; NoCheckHash: boolean); -begin - P := DA.LoadFrom(P,nil,NoCheckHash,Last); - if P=nil then - ErrorData('TDynArray.LoadFrom %',[DA.ArrayTypeShort^]); -end; - -function TFastReader.ReadVarUInt32Array(var Values: TIntegerDynArray): PtrInt; -var i: integer; - k: TFileBufferWriterKind; -begin - result := VarUInt32; - SetLength(Values,result); - Copy(k,1); - if k=wkUInt32 then begin - Copy(Values[0],result*4); - exit; - end; - Next(4); // format: Isize+varUInt32s - case k of - wkVarInt32: for i := 0 to result-1 do Values[i] := VarInt32; - wkVarUInt32: for i := 0 to result-1 do Values[i] := VarUInt32; - else ErrorData('ReadVarUInt32Array: unhandled kind=%', [ord(k)]); - end; -end; - -function TFastReader.ReadCompressed(Load: TAlgoCompressLoad; BufferOffset: integer): RawByteString; -var comp: PAnsiChar; - complen: PtrUInt; -begin - complen := VarUInt32; - comp := Next(complen); - TAlgoCompress.Algo(comp,complen).Decompress(comp,complen,result,Load,BufferOffset); -end; - - -{ TSynTempWriter } - -procedure TSynTempWriter.Init(maxsize: integer); -begin - if maxsize<=0 then - pos := tmp.InitOnStack else - pos := tmp.Init(maxsize); -end; - -procedure TSynTempWriter.Done; -begin - tmp.Done; -end; - -function TSynTempWriter.AsBinary: RawByteString; -begin - FastSetStringCP(result,tmp.buf,pos-PAnsiChar(tmp.buf),CP_RAWBYTESTRING); -end; - -procedure TSynTempWriter.AsUTF8(var result: RawUTF8); -begin - FastSetString(result,tmp.buf,pos-PAnsiChar(tmp.buf)); -end; - -function TSynTempWriter.Position: PtrInt; -begin - result := pos-PAnsiChar(tmp.buf); -end; - -procedure TSynTempWriter.wr(const val; len: PtrInt); -begin - if len<=0 then - exit; - if pos-PAnsiChar(tmp.buf)+len>tmp.len then - raise ESynException.CreateUTF8('TSynTempWriter(%) overflow',[tmp.len]); - MoveSmall(@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.wrs(const str: RawByteString); -begin - if str<>'' then - wr(pointer(str),length(str)); -end; - -procedure TSynTempWriter.wrw(w: word); -begin - wr(w,2); -end; - -function TSynTempWriter.wrfillchar(count: integer; value: byte): PAnsiChar; -begin - if pos-PAnsiChar(tmp.buf)+count>tmp.len then - raise ESynException.CreateUTF8('TSynTempWriter(%) overflow',[tmp.len]); - FillCharFast(pos^,count,value); - result := pos; - inc(pos,count); -end; - - - -{ 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,soEnd); - 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; - -procedure TFileBufferWriter.InternalFlush; -begin - fStream.WriteBuffer(fBuffer^,fPos); - fPos := 0; -end; - -function TFileBufferWriter.Flush: Int64; -begin - if fPos>0 then - InternalFlush; - 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: PtrInt); -begin - if (DataLen<=0) or (Data=nil) then - exit; - inc(fTotalWritten,DataLen); - if fPos+DataLen>fBufLen then begin - if fPos>0 then - InternalFlush; - if DataLen>fBufLen then begin - fStream.WriteBuffer(Data^,DataLen); - exit; - end; - end; - MoveFast(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 - InternalFlush; - FillCharFast(fBuffer^[fPos],len,Data); - inc(fPos,len); - dec(Count,len); - end; -end; - -procedure TFileBufferWriter.Write1(Data: Byte); -begin - if fPos+1>fBufLen then - InternalFlush; - fBuffer^[fPos] := Data; - inc(fPos); - inc(fTotalWritten); -end; - -procedure TFileBufferWriter.Write2(Data: Word); -begin - if fPos+2>fBufLen then - InternalFlush; - PWord(@fBuffer^[fPos])^ := Data; - inc(fPos,SizeOf(Word)); - inc(fTotalWritten,SizeOf(Word)); -end; - -procedure TFileBufferWriter.Write4(Data: integer); -begin - if fPos+4>fBufLen then - InternalFlush; - PInteger(@fBuffer^[fPos])^ := Data; - inc(fPos,SizeOf(integer)); - inc(fTotalWritten,SizeOf(integer)); -end; - -procedure TFileBufferWriter.Write4BigEndian(Data: integer); -begin - Write4(bswap32(Data)); -end; - -procedure TFileBufferWriter.Write8(const Data8Bytes); -begin - if fPos+8>fBufLen then - InternalFlush; - PInt64(@fBuffer^[fPos])^ := PInt64(@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; - -function TFileBufferWriter.DirectWritePrepare(len: PtrInt; out tmp: RawByteString): PAnsiChar; -begin - if (len<=fBufLen) and (fPos+len>fBufLen) then - InternalFlush; - if fPos+len>fBufLen then begin - SetLength(tmp,len); - result := pointer(tmp); - end else - result := @fBuffer^[fPos]; // write directly into the buffer -end; - -procedure TFileBufferWriter.DirectWriteFlush(len: PtrInt; const tmp: RawByteString); -begin - if tmp='' then begin - inc(fPos,len); - inc(fTotalWritten,len); - end else - Write(pointer(tmp),len); -end; - -procedure TFileBufferWriter.WriteRecord(const Rec; RecTypeInfo: pointer); -var len: integer; - tmp: RawByteString; - P: PAnsiChar; -begin - len := RecordSaveLength(Rec,RecTypeInfo); - P := DirectWritePrepare(len,tmp); - if RecordSave(Rec,P,RecTypeInfo)-P<>len then - raise ESynException.CreateUTF8('%.WriteRecord: RecordSave?',[self]); - DirectWriteFlush(len,tmp); -end; - -procedure TFileBufferWriter.WriteDynArray(const DA: TDynArray); -var len: integer; - tmp: RawByteString; - P: PAnsiChar; -begin - len := DA.SaveToLength; - P := DirectWritePrepare(len,tmp); - if DA.SaveTo(P)-P<>len then - raise ESynException.CreateUTF8('%.WriteDynArray: DA.SaveTo?',[self]); - DirectWriteFlush(len,tmp); -end; - -{$ifndef NOVARIANTS} -procedure TFileBufferWriter.Write(const Value: variant); -var buf: PAnsiChar; - vt,len: integer; - tmp: RawByteString; -begin - vt := TVarData(Value).VType; - if vt>varAny then begin // avoid VariantSaveLength() call - Write(@TVarData(Value).VType,SizeOf(TVarData(Value).VType)); - tmp := VariantSaveJSON(Value); - Write(tmp); - exit; - end; - len := VariantSaveLength(Value); - if len=0 then - raise ESynException.CreateUTF8('%.Write(VType=%) VariantSaveLength=0',[self,vt]); - buf := DirectWritePrepare(len,tmp); - if VariantSave(Value,buf)=nil then - raise ESynException.CreateUTF8('%.Write(VType=%) VariantSave=nil',[self,vt]); - DirectWriteFlush(len,tmp); -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: PtrInt; 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 - InternalFlush 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); -begin - WriteRawUTF8Array(pointer(Values),ValuesCount); -end; - -procedure TFileBufferWriter.WriteRawUTF8Array(Values: PPtrUIntArray; ValuesCount: integer); -var n, i: integer; - fixedsize, len: PtrUInt; - P, PEnd: PByte; - PBeg: PAnsiChar; -begin - WriteVarUInt32(ValuesCount); - if ValuesCount=0 then - exit; - fixedsize := Values^[0]; - if fixedsize<>0 then begin - fixedsize := PStrLen(fixedsize-_STRLEN)^; - for i := 1 to ValuesCount-1 do - if (Values^[i]=0) or (PStrLen(Values^[i]-_STRLEN)^<>TStrLen(fixedsize)) then begin - fixedsize := 0; - break; - end; - 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 := PStrLen(Values^[i]-_STRLEN)^; - if PtrUInt(PEnd)-PtrUInt(P)<=len then begin - n := i; - break; // avoid buffer overflow - end; - P := ToVarUInt32(len,P); - MoveFast(pointer(Values^[i])^,P^,len); // here len>0 - inc(P,len); - end else // fixedsize<>0: - for i := 0 to ValuesCount-1 do begin - if PtrUInt(PEnd)-PtrUInt(P)<=fixedsize then begin - n := i; - break; // avoid buffer overflow - end; - MoveFast(pointer(Values^[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(Values),n*SizeOf(PtrInt)); - dec(ValuesCount,n); - if ValuesCount=0 then - break; - end; - InternalFlush; - until false; -end; - -procedure TFileBufferWriter.WriteRawUTF8List(List: TRawUTF8List; - StoreObjectsAsVarUInt32: Boolean); -var i: integer; - o: PPointerArray; -begin - if List=nil then - WriteVarUInt32(0) else begin - List.Safe.Lock; - try - WriteRawUTF8Array(pointer(List.TextPtr),List.Count); - o := List.ObjectPtr; - if o=nil then - StoreObjectsAsVarUInt32 := false; // no Objects[] values - Write(@StoreObjectsAsVarUInt32,1); - if StoreObjectsAsVarUInt32 then - for i := 0 to List.Count-1 do - WriteVarUInt32(PtrUInt(o[i])); - finally - List.Safe.UnLock; - end; - 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 - InternalFlush; - 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 - InternalFlush; - 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 - InternalFlush; - 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; - InternalFlush; - 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; - InternalFlush; - 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; - - -{ 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; aFileNotMapped: boolean); -begin - fCurrentPos := 0; - if aFileNotMapped then - FillcharFast(fMap,SizeOf(fMap),0) else - fMap.Map(aFile) - // if Windows failed to find a contiguous VA space -> fall back on direct read -end; - -function TFileBufferReader.Read(Data: pointer; DataLen: PtrInt): integer; -var len: PtrInt; -begin - if DataLen>0 then - if fMap.Buffer<>nil then begin - // file up to 2 GB: use fast memory map - len := fMap.Size-fCurrentPos; - if len>DataLen then - len := DataLen; - if Data<>nil then - MoveFast(fMap.Buffer[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 - FileSeek64(fMap.FileHandle,DataLen,soFromCurrent); - result := DataLen; - end else - result := FileRead(fMap.FileHandle,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; PEnd: PPAnsiChar): pointer; -begin - if (fMap.Buffer=nil) or (fCurrentPos+DataLen>=fMap.Size) then - result := nil else begin - result := @fMap.Buffer[fCurrentPos]; - if PEnd<>nil then - PEnd^ := @fMap.Buffer[fMap.Size]; - inc(fCurrentPos,DataLen); - end; -end; - -function TFileBufferReader.CurrentPosition: integer; -begin - if (fMap.Buffer=nil) or (fCurrentPos>=fMap.Size) then - result := -1 else - result := fCurrentPos; -end; - -function TFileBufferReader.FileSize: Int64; -begin - result := fMap.FileSize; -end; - -function TFileBufferReader.MappedBuffer: PAnsiChar; -begin - result := fMap.Buffer; -end; - -function TFileBufferReader.ReadPointer(DataLen: PtrUInt; - var aTempData: RawByteString): pointer; -begin - if fMap.Buffer=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.FileHandle,pointer(aTempData)^,DataLen))<>DataLen then - result := nil else // invalid content - result := pointer(aTempData); - end else - if DataLen+fCurrentPos>fMap.Size then - // invalid request - result := nil else begin - // get pointer to data from current memory map (no data copy) - result := @fMap.Buffer[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.Buffer=nil then begin - FileCurrentPos := FileSeek64(fMap.FileHandle,0,soFromCurrent); - if FileCurrentPos+DataLen>fMap.Size then - // invalid content - result := nil else begin - // create a temporary memory map buffer stream - result := TSynMemoryStreamMapped.Create(fMap.FileHandle,DataLen,FileCurrentPos); - FileSeek64(fMap.FileHandle,DataLen,soFromCurrent); - end; - end else - if PtrUInt(DataLen)+fCurrentPos>fMap.Size then - // invalid content - result := nil else begin - // get pointer to data from current memory map (no data copy) - result := TSynMemoryStream.Create(@fMap.Buffer[fCurrentPos],DataLen); - inc(fCurrentPos,DataLen); - end else - // DataLen=0 -> invalid content - result := nil; -end; - -function TFileBufferReader.ReadByte: PtrUInt; -begin - if fMap.Buffer<>nil then - if fCurrentPos>=fMap.Size then - // invalid request - result := 0 else begin - // read 8-bit from current memory map - result := ord(fMap.Buffer[fCurrentPos]); - inc(fCurrentPos); - end else begin - // read from file if >= 2 GB (slow, but works) - result := 0; - if FileRead(fMap.FileHandle,result,1)<>1 then - result := 0; - end; -end; - -function TFileBufferReader.ReadCardinal: cardinal; -begin - if fMap.Buffer<>nil then - if fCurrentPos+3>=fMap.Size then - // invalid request - result := 0 else begin - // read 32-bit from current memory map - result := PCardinal(fMap.Buffer+fCurrentPos)^; - inc(fCurrentPos,4); - end else begin - // read from file if >= 2 GB (slow, but works) - result := 0; - if FileRead(fMap.FileHandle,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, i: integer; - P, PEnd: PByte; - v: PQWordArray; - diff: QWord; - BufTemp: RawByteString; -begin - result := ReadVarUInt32; - if result=0 then - exit; - count := result; - if count>length(Values) then // only set length if not big enough - SetLength(Values,count); - v := pointer(Values); - if boolean(ReadByte) then begin // values were stored as offsets - v^[0] := 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 begin - List.BeginUpdate; - try - List.Clear; - n := ReadVarRawUTF8DynArray(v); - result := true; - if n=0 then - exit; - Read(@StoreObjectsAsVarUInt32,1); - if StoreObjectsAsVarUInt32 then begin - List.Flags := List.Flags-[fObjectsOwned]; // Int32 here, not instances - SetLength(o,length(v)); - for i := 0 to n-1 do - o[i] := TObject(ReadVarUInt32); - end; - List.SetFrom(v,o); // fast assignment using refcnt - finally - List.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 // change Values[] length only if 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.Size) then - result := False else - if fMap.Buffer=nil then - result := FileSeek64(fMap.FileHandle,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.Buffer=nil then - Result := FileSeek(fMap.FileHandle,Offset,0)=Offset else - if (fMap.Buffer<>nil) and (PtrUInt(Offset)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 (fFindLastKey='') then - exit; - ResetIfNeeded; - inc(fRamUsed,length(aValue)); - fNameValue.Add(fFindLastKey,aValue,aTag); - fFindLastKey := ''; -end; - -function TSynCache.Find(const aKey: RawUTF8; aResultTag: PPtrInt): RawUTF8; -var ndx: integer; -begin - result := ''; - if self=nil then - exit; - fFindLastKey := aKey; - if aKey='' then - exit; - ndx := fNameValue.Find(aKey); - if ndx<0 then - exit; - with fNameValue.List[ndx] do begin - result := Value; - if aResultTag<>nil then - aResultTag^ := Tag; - 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.DynArray.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 - fNameValue.DynArray.Clear; - fNameValue.DynArray.ReHash; - result := true; // mark something was flushed - end; - 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; - - -{ 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.PopEquals(aAnother: pointer; aCompare: TDynArraySortCompare; - out aValue): boolean; -begin - fSafe.Lock; - try - result := (fFirst>=0) and Assigned(aCompare) and Assigned(aAnother) and - (aCompare(fValues.ElemPtr(fFirst)^,aAnother^)=0) and Pop(aValue); - 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 - SleepHiRes(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; aCompared: pointer; aCompare: TDynArraySortCompare): boolean; -var endtix: Int64; -begin - result := false; - if not InternalDestroying(+1) then - try - endtix := GetTickCount64+aTimeoutMS; - repeat - if Assigned(aCompared) and Assigned(aCompare) then - result := PopEquals(aCompared,aCompare,aValue) else - 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(aTimeoutMS: integer); -var endtix: Int64; // never wait forever -begin - fSafe.Lock; - try - include(fWaitPopFlags,wpfDestroying); - if fWaitPopCounter=0 then - exit; - finally - fSafe.UnLock; - end; - endtix := GetTickCount64+aTimeoutMS; - repeat - SleepHiRes(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; - - -{ 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 - MoveFast(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; - - - -{ TSynPersistentStore } - -constructor TSynPersistentStore.Create(const aName: RawUTF8); -begin - Create; - fName := aName; -end; - -constructor TSynPersistentStore.CreateFrom(const aBuffer: RawByteString; - aLoad: TAlgoCompressLoad); -begin - CreateFromBuffer(pointer(aBuffer),length(aBuffer),aLoad); -end; - -constructor TSynPersistentStore.CreateFromBuffer( - aBuffer: pointer; aBufferLen: integer; aLoad: TAlgoCompressLoad); -begin - Create(''); - LoadFrom(aBuffer,aBufferLen,aLoad); -end; - -constructor TSynPersistentStore.CreateFromFile(const aFileName: TFileName; - aLoad: TAlgoCompressLoad); -begin - Create(''); - LoadFromFile(aFileName,aLoad); -end; - -procedure TSynPersistentStore.LoadFromReader; -begin - fReader.VarUTF8(fName); -end; - -procedure TSynPersistentStore.SaveToWriter(aWriter: TFileBufferWriter); -begin - aWriter.Write(fName); -end; - -procedure TSynPersistentStore.LoadFrom(const aBuffer: RawByteString; - aLoad: TAlgoCompressLoad); -begin - if aBuffer <> '' then - LoadFrom(pointer(aBuffer),length(aBuffer),aLoad); -end; - -procedure TSynPersistentStore.LoadFrom(aBuffer: pointer; aBufferLen: integer; - aLoad: TAlgoCompressLoad); -var localtemp: RawByteString; - p: pointer; - temp: PRawByteString; -begin - if (aBuffer=nil) or (aBufferLen<=0) then - exit; // nothing to load - fLoadFromLastAlgo := TAlgoCompress.Algo(aBuffer,aBufferLen); - if fLoadFromLastAlgo = nil then - fReader.ErrorData('%.LoadFrom unknown TAlgoCompress AlgoID=%', - [self,PByteArray(aBuffer)[4]]); - temp := fReaderTemp; - if temp=nil then - temp := @localtemp; - p := fLoadFromLastAlgo.Decompress(aBuffer,aBufferLen,fLoadFromLastUncompressed,temp^,aLoad); - if p=nil then - fReader.ErrorData('%.LoadFrom %.Decompress failed',[self,fLoadFromLastAlgo]); - fReader.Init(p,fLoadFromLastUncompressed); - LoadFromReader; -end; - -function TSynPersistentStore.LoadFromFile(const aFileName: TFileName; - aLoad: TAlgoCompressLoad): boolean; -var temp: RawByteString; -begin - temp := StringFromFile(aFileName); - result := temp<>''; - if result then - LoadFrom(temp,aLoad); -end; - -procedure TSynPersistentStore.SaveTo(out aBuffer: RawByteString; nocompression: boolean; - BufLen: integer; ForcedAlgo: TAlgoCompress; BufferOffset: integer); -var writer: TFileBufferWriter; - temp: array[word] of byte; -begin - if BufLen<=SizeOf(temp) then - writer := TFileBufferWriter.Create(TRawByteStringStream,@temp,SizeOf(temp)) else - writer := TFileBufferWriter.Create(TRawByteStringStream,BufLen); - try - SaveToWriter(writer); - fSaveToLastUncompressed := writer.TotalWritten; - aBuffer := writer.FlushAndCompress(nocompression,ForcedAlgo,BufferOffset); - finally - writer.Free; - end; -end; - -function TSynPersistentStore.SaveTo(nocompression: boolean; BufLen: integer; - ForcedAlgo: TAlgoCompress; BufferOffset: integer): RawByteString; -begin - SaveTo(result,nocompression,BufLen,ForcedAlgo,BufferOffset); -end; - -function TSynPersistentStore.SaveToFile(const aFileName: TFileName; - nocompression: boolean; BufLen: integer; ForcedAlgo: TAlgoCompress): PtrUInt; -var temp: RawByteString; -begin - SaveTo(temp,nocompression,BufLen,ForcedAlgo); - if FileFromString(temp,aFileName) then - result := length(temp) else - result := 0; -end; - - -{ TSynPersistentStoreJson } - -procedure TSynPersistentStoreJson.AddJSON(W: TTextWriter); -begin - W.AddPropJSONString('name', fName); -end; - -function TSynPersistentStoreJson.SaveToJSON(reformat: TTextWriterJSONFormat): RawUTF8; -var - W: TTextWriter; -begin - W := DefaultTextWriterSerializer.CreateOwnedStream(65536); - try - W.Add('{'); - AddJSON(W); - W.CancelLastComma; - W.Add('}'); - W.SetText(result, reformat); - finally - W.Free; - end; -end; - - -{ TRawByteStringGroup } - -procedure TRawByteStringGroup.Add(const aItem: RawByteString); -begin - if Values=nil then - Clear; // ensure all fields are initialized, even if on stack - if Count=Length(Values) then - SetLength(Values,NextGrow(Count)); - with Values[Count] do begin - Position := self.Position; - Value := aItem; - end; - LastFind := Count; - inc(Count); - inc(Position,Length(aItem)); -end; - -procedure TRawByteStringGroup.Add(aItem: pointer; aItemLen: integer); -var tmp: RawByteString; -begin - SetString(tmp,PAnsiChar(aItem),aItemLen); - Add(tmp); -end; - -{$ifndef DELPHI5OROLDER} // circumvent Delphi 5 compiler bug - -procedure TRawByteStringGroup.Add(const aAnother: TRawByteStringGroup); -var i: integer; - s,d: PRawByteStringGroupValue; -begin - if aAnother.Values=nil then - exit; - if Values=nil then - Clear; // ensure all fields are initialized, even if on stack - if Count+aAnother.Count>Length(Values) then - SetLength(Values,Count+aAnother.Count); - s := pointer(aAnother.Values); - d := @Values[Count]; - for i := 1 to aAnother.Count do begin - d^.Position := Position; - d^.Value := s^.Value; - inc(Position,length(s^.Value)); - inc(s); - inc(d); - end; - inc(Count,aAnother.Count); - LastFind := Count-1; -end; - -procedure TRawByteStringGroup.RemoveLastAdd; -begin - if Count>0 then begin - dec(Count); - dec(Position,Length(Values[Count].Value)); - Values[Count].Value := ''; // release memory - LastFind := Count-1; - end; -end; - -function TRawByteStringGroup.Equals(const aAnother: TRawByteStringGroup): boolean; -begin - if ((Values=nil) and (aAnother.Values<>nil)) or ((Values<>nil) and (aAnother.Values=nil)) or - (Position<>aAnother.Position) then - result := false else - if (Count<>1) or (aAnother.Count<>1) or (Values[0].Value<>aAnother.Values[0].Value) then - result := AsText=aAnother.AsText else - result := true; -end; - -{$endif DELPHI5OROLDER} - -procedure TRawByteStringGroup.Clear; -begin - Values := nil; - Position := 0; - Count := 0; - LastFind := 0; -end; - -procedure TRawByteStringGroup.AppendTextAndClear(var aDest: RawByteString); -var d,i: integer; - v: PRawByteStringGroupValue; -begin - d := length(aDest); - SetLength(aDest,d+Position); - v := pointer(Values); - for i := 1 to Count do begin - MoveFast(pointer(v^.Value)^,PByteArray(aDest)[d+v^.Position],length(v^.Value)); - inc(v); - end; - Clear; -end; - -function TRawByteStringGroup.AsText: RawByteString; -begin - if Values=nil then - result := '' else begin - if Count>1 then - Compact; - result := Values[0].Value; - end; -end; - -procedure TRawByteStringGroup.Compact; -var i: integer; - v: PRawByteStringGroupValue; - tmp: RawByteString; -begin - if (Values<>nil) and (Count>1) then begin - SetString(tmp,nil,Position); - v := pointer(Values); - for i := 1 to Count do begin - MoveFast(pointer(v^.Value)^,PByteArray(tmp)[v^.Position],length(v^.Value)); - {$ifdef FPC}Finalize(v^.Value){$else}v^.Value := ''{$endif}; // free chunks - inc(v); - end; - Values[0].Value := tmp; // use result for absolute compaction ;) - if Count>128 then - SetLength(Values,128); - Count := 1; - LastFind := 0; - end; -end; - -function TRawByteStringGroup.AsBytes: TByteDynArray; -var i: integer; -begin - result := nil; - if Values=nil then - exit; - SetLength(result,Position); - for i := 0 to Count-1 do - with Values[i] do - MoveFast(pointer(Value)^,PByteArray(result)[Position],length(Value)); -end; - -procedure TRawByteStringGroup.Write(W: TTextWriter; Escape: TTextWriterKind); -var i: integer; -begin - if Values<>nil then - for i := 0 to Count-1 do - with Values[i] do - W.Add(PUTF8Char(pointer(Value)),length(Value),Escape); -end; - -procedure TRawByteStringGroup.WriteBinary(W: TFileBufferWriter); -var i: integer; -begin - if Values<>nil then - for i := 0 to Count-1 do - W.WriteBinary(Values[i].Value); -end; - -procedure TRawByteStringGroup.WriteString(W: TFileBufferWriter); -begin - if Values=nil then begin - W.Write1(0); - exit; - end; - W.WriteVarUInt32(Position); - WriteBinary(W); -end; - -procedure TRawByteStringGroup.AddFromReader(var aReader: TFastReader); -var complexsize: integer; -begin - complexsize := aReader.VarUInt32; - if complexsize>0 then // directly create a RawByteString from aReader buffer - Add(aReader.Next(complexsize),complexsize); -end; - -function TRawByteStringGroup.Find(aPosition: integer): PRawByteStringGroupValue; -var i: integer; -begin - if (pointer(Values)<>nil) and (cardinal(aPosition)=result^.Position) and (aPositionaPosition then begin - dec(result); - LastFind := i; - exit; - end else - inc(result); - dec(result); - LastFind := Count-1; - end - else - result := nil; -end; - -function TRawByteStringGroup.Find(aPosition, aLength: integer): pointer; -var P: PRawByteStringGroupValue; - i: integer; -label found; -begin - if (pointer(Values)<>nil) and (cardinal(aPosition)=0) and (i+aLengthaPosition then begin - LastFind := i; -found: dec(P); - dec(aPosition,P^.Position); - if aLength-aPosition<=length(P^.Value) then - result := @PByteArray(P^.Value)[aPosition] else - result := nil; - exit; - end else - inc(P); - LastFind := Count-1; - goto found; - end - else - result := nil; -end; - -procedure TRawByteStringGroup.FindAsText(aPosition, aLength: integer; out aText: RawByteString); -var P: PRawByteStringGroupValue; -begin - P := Find(aPosition); - if P=nil then - exit; - dec(aPosition,P^.Position); - if (aPosition=0) and (length(P^.Value)=aLength) then - aText := P^.Value else // direct return if not yet compacted - if aLength-aPosition<=length(P^.Value) then - SetString(aText,PAnsiChar(@PByteArray(P^.Value)[aPosition]),aLength); -end; - -function TRawByteStringGroup.FindAsText(aPosition, aLength: integer): RawByteString; -begin - FindAsText(aPosition,aLength,result); -end; - -{$ifndef NOVARIANTS} -procedure TRawByteStringGroup.FindAsVariant(aPosition, aLength: integer; out aDest: variant); -var tmp: RawByteString; -begin - tmp := FindAsText(aPosition,aLength); - if tmp <> '' then - RawUTF8ToVariant(tmp,aDest); -end; -{$endif NOVARIANTS} - -procedure TRawByteStringGroup.FindWrite(aPosition, aLength: integer; - W: TTextWriter; Escape: TTextWriterKind; TrailingCharsToIgnore: integer); -var P: pointer; -begin - P := Find(aPosition,aLength); - if P<>nil then - W.Add(PUTF8Char(P)+TrailingCharsToIgnore,aLength-TrailingCharsToIgnore,Escape); -end; - -procedure TRawByteStringGroup.FindWriteBase64(aPosition, aLength: integer; - W: TTextWriter; withMagic: boolean); -var P: pointer; -begin - P := Find(aPosition,aLength); - if P<>nil then - W.WrBase64(P,aLength,withMagic); -end; - -procedure TRawByteStringGroup.FindMove(aPosition, aLength: integer; aDest: pointer); -var P: pointer; -begin - P := Find(aPosition,aLength); - if P<>nil then - MoveFast(P^,aDest^,aLength); -end; - - -{ TPropNameList } - -procedure TPropNameList.Init; -begin - Count := 0; -end; - -function TPropNameList.FindPropName(const Value: RawUTF8): Integer; -begin - result := SynCommons.FindPropName(Pointer(Values),Value,Count); -end; - -function TPropNameList.AddPropName(const Value: RawUTF8): Boolean; -begin - if (Value<>'') and (SynCommons.FindPropName(pointer(Values),Value,Count)<0) then begin - if Count=length(Values) then - SetLength(Values,NextGrow(Count)); - Values[Count] := Value; - inc(Count); - result := true; - end else - result := false; -end; - - -{ ************ Security and Identifiers classes ************************** } - -{ TSynUniqueIdentifierBits } - -function TSynUniqueIdentifierBits.Counter: word; -begin - result := PWord(@Value)^ and $7fff; -end; - -function TSynUniqueIdentifierBits.ProcessID: TSynUniqueIdentifierProcess; -begin - result := (PCardinal(@Value)^ shr 15) and $ffff; -end; - -function TSynUniqueIdentifierBits.CreateTimeUnix: TUnixTime; -begin - result := Value shr 31; -end; - -{$ifndef NOVARIANTS} -function TSynUniqueIdentifierBits.AsVariant: variant; -begin - ToVariant(result); -end; - -procedure TSynUniqueIdentifierBits.ToVariant(out result: variant); -begin - TDocVariantData(result).InitObject(['Created',DateTimeToIso8601Text(CreateDateTime), - 'Identifier',ProcessID,'Counter',Counter,'Value',Value, - 'Hex',Int64ToHex(Value)],JSON_OPTIONS_FAST); -end; -{$endif NOVARIANTS} - -{$ifndef DELPHI5OROLDER} -function TSynUniqueIdentifierBits.Equal(const Another: TSynUniqueIdentifierBits): boolean; -begin - result := Value=Another.Value; -end; -{$endif} - -procedure TSynUniqueIdentifierBits.From(const AID: TSynUniqueIdentifier); -begin - Value := AID; -end; - -function TSynUniqueIdentifierBits.CreateTimeLog: TTimeLog; -begin - PTimeLogBits(@result)^.From(UnixTimeToDateTime(Value shr 31)); -end; - -function TSynUniqueIdentifierBits.CreateDateTime: TDateTime; -begin - result := UnixTimeToDateTime(Value shr 31); -end; - -function TSynUniqueIdentifierBits.ToHexa: RawUTF8; -begin - Int64ToHex(Value,result); -end; - -function TSynUniqueIdentifierBits.FromHexa(const hexa: RawUTF8): boolean; -begin - result := (Length(hexa)=16) and HexDisplayToBin(pointer(hexa),@Value,SizeOf(Value)); -end; - -procedure TSynUniqueIdentifierBits.FromDateTime(const aDateTime: TDateTime); -begin - Value := DateTimeToUnixTime(aDateTime) shl 31; -end; - -procedure TSynUniqueIdentifierBits.FromUnixTime(const aUnixTime: TUnixTime); -begin - Value := aUnixTime shl 31; -end; - - -{ TSynUniqueIdentifierGenerator } - -const // fSafe.Padding[] slots - SYNUNIQUEGEN_COMPUTECOUNT = 0; - -procedure TSynUniqueIdentifierGenerator.ComputeNew( - out result: TSynUniqueIdentifierBits); -var currentTime: cardinal; -begin - currentTime := UnixTimeUTC; // under Windows faster than GetTickCount64 - fSafe.Lock; - try - if currentTime>fUnixCreateTime then begin - fUnixCreateTime := currentTime; - fLastCounter := 0; // reset - end; - if fLastCounter=$7fff then begin // collision (unlikely) -> cheat on timestamp - inc(fUnixCreateTime); - fLastCounter := 0; - end else - inc(fLastCounter); - result.Value := Int64(fLastCounter or fIdentifierShifted) or - (Int64(fUnixCreateTime) shl 31); - inc(fSafe.Padding[SYNUNIQUEGEN_COMPUTECOUNT].VInt64); - finally - fSafe.UnLock; - end; -end; - -function TSynUniqueIdentifierGenerator.ComputeNew: Int64; -begin - ComputeNew(PSynUniqueIdentifierBits(@result)^); -end; - -function TSynUniqueIdentifierGenerator.GetComputedCount: Int64; -begin - {$ifdef NOVARIANTS} - fSafe.Lock; - result := fSafe.Padding[SYNUNIQUEGEN_COMPUTECOUNT].VInt64; - fSafe.Unlock; - {$else} - result := fSafe.LockedInt64[SYNUNIQUEGEN_COMPUTECOUNT]; - {$endif} -end; - -procedure TSynUniqueIdentifierGenerator.ComputeFromDateTime(const aDateTime: TDateTime; - out result: TSynUniqueIdentifierBits); -begin // assume fLastCounter=0 - ComputeFromUnixTime(DateTimeToUnixTime(aDateTime),result); -end; - -procedure TSynUniqueIdentifierGenerator.ComputeFromUnixTime(const aUnixTime: TUnixTime; - out result: TSynUniqueIdentifierBits); -begin // assume fLastCounter=0 - result.Value := aUnixTime shl 31; - if self<>nil then - result.Value := result.Value or fIdentifierShifted; -end; - -constructor TSynUniqueIdentifierGenerator.Create(aIdentifier: TSynUniqueIdentifierProcess; - const aSharedObfuscationKey: RawUTF8); -var i, len: integer; - crc: cardinal; -begin - fIdentifier := aIdentifier; - fIdentifierShifted := aIdentifier shl 15; - fSafe.Init; - fSafe.Padding[SYNUNIQUEGEN_COMPUTECOUNT].VType := varInt64; // reset to 0 - // compute obfuscation key using hash diffusion of the supplied text - len := length(aSharedObfuscationKey); - crc := crc32ctab[0,len and 1023]; - for i := 0 to high(fCrypto)+1 do begin - crc := crc32ctab[0,crc and 1023] xor crc32ctab[3,i] xor - kr32(crc,pointer(aSharedObfuscationKey),len) xor - crc32c(crc,pointer(aSharedObfuscationKey),len) xor - fnv32(crc,pointer(aSharedObfuscationKey),len); - // do not modify those hashes above or you will break obfuscation pattern! - if i<=high(fCrypto) then - fCrypto[i] := crc else - fCryptoCRC := crc; - end; - // due to the weakness of the hash algorithms used, this approach is a bit - // naive and would be broken easily with brute force - but point here is to - // hide/obfuscate public values at end-user level (e.g. when publishing URIs), - // not implement strong security, so it sounds good enough for our purpose -end; - -destructor TSynUniqueIdentifierGenerator.Destroy; -begin - fSafe.Done; - FillCharFast(fCrypto,SizeOf(fCrypto),0); - fCryptoCRC := 0; - inherited Destroy; -end; - -type // compute a 24 hexadecimal chars (96 bits) obfuscated pseudo file name - TSynUniqueIdentifierObfuscatedBits = packed record - crc: cardinal; - id: TSynUniqueIdentifierBits; - end; - -function TSynUniqueIdentifierGenerator.ToObfuscated( - const aIdentifier: TSynUniqueIdentifier): TSynUniqueIdentifierObfuscated; -var bits: TSynUniqueIdentifierObfuscatedBits; - key: cardinal; -begin - result := ''; - if aIdentifier=0 then - exit; - bits.id.Value := aIdentifier; - if self=nil then - key := 0 else - key := crc32ctab[0,bits.id.ProcessID and 1023] xor fCryptoCRC; - bits.crc := crc32c(bits.id.ProcessID,@bits.id,SizeOf(bits.id)) xor key; - if self<>nil then - bits.id.Value := bits.id.Value xor PInt64(@fCrypto[high(fCrypto)-1])^; - result := BinToHex(@bits,SizeOf(bits)); -end; - -function TSynUniqueIdentifierGenerator.FromObfuscated( - const aObfuscated: TSynUniqueIdentifierObfuscated; - out aIdentifier: TSynUniqueIdentifier): boolean; -var bits: TSynUniqueIdentifierObfuscatedBits; - len: integer; - key: cardinal; -begin - result := false; - len := PosExChar('.',aObfuscated); - if len=0 then - len := Length(aObfuscated) else - dec(len); // trim right '.jpg' - if (len<>SizeOf(bits)*2) or - not SynCommons.HexToBin(pointer(aObfuscated),@bits,SizeOf(bits)) then - exit; - if self=nil then - key := 0 else begin - bits.id.Value := bits.id.Value xor PInt64(@fCrypto[high(fCrypto)-1])^; - key := crc32ctab[0,bits.id.ProcessID and 1023] xor fCryptoCRC; - end; - if crc32c(bits.id.ProcessID,@bits.id,SizeOf(bits.id)) xor key=bits.crc then begin - aIdentifier := bits.id.Value; - result := true; - end; -end; - - -{ TSynPersistentWithPassword } - -destructor TSynPersistentWithPassword.Destroy; -begin - UniqueRawUTF8(fPassword); - FillZero(fPassword); - inherited Destroy; -end; - -class function TSynPersistentWithPassword.ComputePassword(const PlainPassword: RawUTF8; - CustomKey: cardinal): RawUTF8; -var instance: TSynPersistentWithPassword; -begin - instance := TSynPersistentWithPassword.Create; - try - instance.Key := CustomKey; - instance.SetPassWordPlain(PlainPassword); - result := instance.fPassWord; - finally - instance.Free; - end; -end; - -class function TSynPersistentWithPassword.ComputePassword(PlainPassword: pointer; - PlainPasswordLen: integer; CustomKey: cardinal): RawUTF8; -begin - result := ComputePassword(BinToBase64uri(PlainPassword,PlainPasswordLen)); -end; - -class function TSynPersistentWithPassword.ComputePlainPassword(const CypheredPassword: RawUTF8; - CustomKey: cardinal; const AppSecret: RawUTF8): RawUTF8; -var instance: TSynPersistentWithPassword; -begin - instance := TSynPersistentWithPassword.Create; - try - instance.Key := CustomKey; - instance.fPassWord := CypheredPassword; - result := instance.GetPassWordPlainInternal(AppSecret); - finally - instance.Free; - end; -end; - -function TSynPersistentWithPassword.GetPasswordFieldAddress: pointer; -begin - result := @fPassword; -end; - -function TSynPersistentWithPassword.GetKey: cardinal; -begin - if self=nil then - result := 0 else - result := fKey xor $A5abba5A; -end; - -function TSynPersistentWithPassword.GetPassWordPlain: RawUTF8; -begin - result := GetPassWordPlainInternal(''); -end; - -function TSynPersistentWithPassword.GetPassWordPlainInternal(AppSecret: RawUTF8): RawUTF8; -var value,pass: RawByteString; - usr: RawUTF8; - i,j: integer; -begin - result := ''; - if (self=nil) or (fPassWord='') then - exit; - if Assigned(TSynPersistentWithPasswordUserCrypt) then begin - if AppSecret='' then - ToText(ClassType,AppSecret); - usr := ExeVersion.User+':'; - i := PosEx(usr,fPassword); - if (i=1) or ((i>0) and (fPassword[i-1]=',')) then begin - inc(i,length(usr)); - j := PosEx(',',fPassword,i); - if j=0 then - j := length(fPassword)+1; - Base64ToBin(@fPassword[i],j-i,pass); - if pass<>'' then - result := TSynPersistentWithPasswordUserCrypt(pass,AppSecret,false); - end else begin - i := PosExChar(':',fPassword); - if i>0 then - raise ESynException.CreateUTF8('%.GetPassWordPlain unable to retrieve the '+ - 'stored value: current user is [%], but password in % was encoded for [%]', - [self,ExeVersion.User,AppSecret,copy(fPassword,1,i-1)]); - end; - end; - if result='' then begin - value := Base64ToBin(fPassWord); - SymmetricEncrypt(GetKey,value); - result := value; - end; -end; - -procedure TSynPersistentWithPassword.SetPassWordPlain(const value: RawUTF8); -var tmp: RawByteString; -begin - if self=nil then - exit; - if value='' then begin - fPassWord := ''; - exit; - end; - SetString(tmp,PAnsiChar(pointer(value)),Length(value)); // private copy - SymmetricEncrypt(GetKey,tmp); - fPassWord := BinToBase64(tmp); -end; - - -{ TSynConnectionDefinition } - -constructor TSynConnectionDefinition.CreateFromJSON(const JSON: RawUTF8; - Key: cardinal); -var privateCopy: RawUTF8; - values: array[0..4] of TValuePUTF8Char; -begin - fKey := Key; - privateCopy := JSON; - JSONDecode(privateCopy,['Kind','ServerName','DatabaseName','User','Password'],@values); - fKind := values[0].ToString; - values[1].ToUTF8(fServerName); - values[2].ToUTF8(fDatabaseName); - values[3].ToUTF8(fUser); - values[4].ToUTF8(fPassWord); -end; - -function TSynConnectionDefinition.SaveToJSON: RawUTF8; -begin - result := JSONEncode(['Kind',fKind,'ServerName',fServerName, - 'DatabaseName',fDatabaseName,'User',fUser,'Password',fPassword]); -end; - - -{ TSynAuthenticationAbstract } - -constructor TSynAuthenticationAbstract.Create; -begin - fSafe.Init; - fTokenSeed := Random32gsl; - fSessionGenerator := abs(fTokenSeed*PPtrInt(self)^); - fTokenSeed := abs(fTokenSeed*Random32gsl); -end; - -destructor TSynAuthenticationAbstract.Destroy; -begin - fSafe.Done; - inherited; -end; - -class function TSynAuthenticationAbstract.ComputeHash(Token: Int64; - const UserName,PassWord: RawUTF8): cardinal; -begin // rough authentication - xxHash32 is less reversible than crc32c - result := xxHash32(xxHash32(xxHash32(Token,@Token,SizeOf(Token)), - pointer(UserName),length(UserName)),pointer(Password),length(PassWord)); -end; - -function TSynAuthenticationAbstract.ComputeCredential(previous: boolean; - const UserName,PassWord: RawUTF8): cardinal; -var tok: Int64; -begin - tok := GetTickCount64 div 10000; - if previous then - dec(tok); - result := ComputeHash(tok xor fTokenSeed,UserName,PassWord); -end; - -function TSynAuthenticationAbstract.CurrentToken: Int64; -begin - result := (GetTickCount64 div 10000) xor fTokenSeed; -end; - -procedure TSynAuthenticationAbstract.AuthenticateUser(const aName, aPassword: RawUTF8); -begin - raise ESynException.CreateUTF8('%.AuthenticateUser() is not implemented',[self]); -end; - -procedure TSynAuthenticationAbstract.DisauthenticateUser(const aName: RawUTF8); -begin - raise ESynException.CreateUTF8('%.DisauthenticateUser() is not implemented',[self]); -end; - -function TSynAuthenticationAbstract.CheckCredentials(const UserName: RaWUTF8; - Hash: cardinal): boolean; -var password: RawUTF8; -begin - result := GetPassword(UserName,password) and - ((ComputeCredential(false,UserName,password)=Hash) or - (ComputeCredential(true,UserName,password)=Hash)); -end; - -function TSynAuthenticationAbstract.CreateSession(const User: RawUTF8; - Hash: cardinal): integer; -begin - result := 0; - fSafe.Lock; - try - if not CheckCredentials(User,Hash) then - exit; - repeat - result := fSessionGenerator; - inc(fSessionGenerator); - until result<>0; - AddSortedInteger(fSessions,fSessionsCount,result); - finally - fSafe.UnLock; - end; -end; - -function TSynAuthenticationAbstract.SessionExists(aID: integer): boolean; -begin - fSafe.Lock; - try - result := FastFindIntegerSorted(pointer(fSessions),fSessionsCount-1,aID)>=0; - finally - fSafe.UnLock; - end; -end; - -procedure TSynAuthenticationAbstract.RemoveSession(aID: integer); -var i: integer; -begin - fSafe.Lock; - try - i := FastFindIntegerSorted(pointer(fSessions),fSessionsCount-1,aID); - if i>=0 then - DeleteInteger(fSessions,fSessionsCount,i); - finally - fSafe.UnLock; - end; -end; - - -{ TSynAuthentication } - -constructor TSynAuthentication.Create(const aUserName,aPassword: RawUTF8); -begin - inherited Create; - fCredentials.Init(true); - if aUserName<>'' then - AuthenticateUser(aUserName,aPassword); -end; - -function TSynAuthentication.GetPassword(const UserName: RawUTF8; - out Password: RawUTF8): boolean; -var i: integer; -begin // caller did protect this method via fSafe.Lock - i := fCredentials.Find(UserName); - if i<0 then begin - result := false; - exit; - end; - password := fCredentials.List[i].Value; - result := true; -end; - -function TSynAuthentication.GetUsersCount: integer; -begin - fSafe.Lock; - try - result := fCredentials.Count; - finally - fSafe.UnLock; - end; -end; - -procedure TSynAuthentication.AuthenticateUser(const aName, aPassword: RawUTF8); -begin - fSafe.Lock; - try - fCredentials.Add(aName,aPassword); - finally - fSafe.UnLock; - end; -end; - -procedure TSynAuthentication.DisauthenticateUser(const aName: RawUTF8); -begin - fSafe.Lock; - try - fCredentials.Delete(aName); - finally - fSafe.UnLock; - end; -end; - - -{ TIPBan } - -procedure TIPBan.LoadFromReader; -begin - inherited; - fReader.ReadVarUInt32Array(fIP4); - fCount := length(fIP4); -end; - -procedure TIPBan.SaveToWriter(aWriter: TFileBufferWriter); -begin // wkSorted not efficient: too big diffs between IPs - aWriter.WriteVarUInt32Array(fIP4, fCount, wkUInt32); -end; - -function TIPBan.Add(const aIP: RawUTF8): boolean; -var ip4: cardinal; -begin - result := false; - if (self=nil) or not IPToCardinal(aIP,ip4) then - exit; - fSafe.Lock; - try - AddSortedInteger(fIP4,fCount,ip4); - result := true; - finally - fSafe.UnLock; - end; -end; - -function TIPBan.Delete(const aIP: RawUTF8): boolean; -var ip4: cardinal; - i: integer; -begin - result := false; - if (self=nil) or not IPToCardinal(aIP,ip4) then - exit; - fSafe.Lock; - try - i := FastFindIntegerSorted(pointer(fIP4),fCount-1,ip4); - if i<0 then - exit; - DeleteInteger(fIP4,fCount,i); - result := true; - finally - fSafe.UnLock; - end; -end; - -function TIPBan.Exists(const aIP: RawUTF8): boolean; -var ip4: cardinal; -begin - result := false; - if (self=nil) or (fCount=0) or not IPToCardinal(aIP,ip4) then - exit; - fSafe.Lock; - try - if FastFindIntegerSorted(pointer(fIP4),fCount-1,ip4)>=0 then - result := true; - finally - fSafe.UnLock; - end; -end; - -function TIPBan.DynArrayLocked: TDynArray; -begin - fSafe.Lock; - result.InitSpecific(TypeInfo(TCardinalDynArray),fIP4,djCardinal,@fCount); -end; - - -{ ************ Database types and classes ************************** } - -{$ifdef FPC}{$push}{$endif} -{$WARNINGS OFF} // yes, we know there will be dead code below: we rely on it ;) - -function IsZero(const Fields: TSQLFieldBits): boolean; -var f: TPtrIntArray absolute Fields; -begin - {$ifdef CPU64} - if MAX_SQLFIELDS=64 then - result := (f[0]=0) else - if MAX_SQLFields=128 then - result := (f[0]=0) and (f[1]=0) else - if MAX_SQLFields=192 then - result := (f[0]=0) and (f[1]=0) and (f[2]=0) else - if MAX_SQLFields=256 then - result := (f[0]=0) and (f[1]=0) and (f[2]=0) and (f[3]=0) else - {$else} - if MAX_SQLFIELDS=64 then - result := (f[0]=0) and (f[1]=0) else - if MAX_SQLFields=128 then - result := (f[0]=0) and (f[1]=0) and (f[2]=0) and (f[3]=0) else - if MAX_SQLFields=192 then - result := (f[0]=0) and (f[1]=0) and (f[2]=0) and (f[3]=0) - and (f[4]=0) and (f[5]=0) else - if MAX_SQLFields=256 then - result := (f[0]=0) and (f[1]=0) and (f[2]=0) and (f[3]=0) - and (f[4]=0) and (f[5]=0) and (f[6]=0) and (f[7]=0) else - {$endif} - result := IsZero(@Fields,SizeOf(Fields)) -end; - -function IsEqual(const A,B: TSQLFieldBits): boolean; -var a_: TPtrIntArray absolute A; - b_: TPtrIntArray absolute B; -begin - {$ifdef CPU64} - if MAX_SQLFIELDS=64 then - result := (a_[0]=b_[0]) else - if MAX_SQLFields=128 then - result := (a_[0]=b_[0]) and (a_[1]=b_[1]) else - if MAX_SQLFields=192 then - result := (a_[0]=b_[0]) and (a_[1]=b_[1]) and (a_[2]=b_[2]) else - if MAX_SQLFields=256 then - result := (a_[0]=b_[0]) and (a_[1]=b_[1]) and (a_[2]=b_[2]) and (a_[3]=b_[3]) else - {$else} - if MAX_SQLFIELDS=64 then - result := (a_[0]=b_[0]) and (a_[1]=b_[1]) else - if MAX_SQLFields=128 then - result := (a_[0]=b_[0]) and (a_[1]=b_[1]) and (a_[2]=b_[2]) and (a_[3]=b_[3]) else - if MAX_SQLFields=192 then - result := (a_[0]=b_[0]) and (a_[1]=b_[1]) and (a_[2]=b_[2]) and (a_[3]=b_[3]) - and (a_[4]=b_[4]) and (a_[5]=b_[5]) else - if MAX_SQLFields=256 then - result := (a_[0]=b_[0]) and (a_[1]=b_[1]) and (a_[2]=b_[2]) and (a_[3]=b_[3]) - and (a_[4]=b_[4]) and (a_[5]=b_[5]) and (a_[6]=b_[6]) and (a_[7]=b_[7]) else - {$endif} - result := CompareMemFixed(@A,@B,SizeOf(TSQLFieldBits)) -end; - -procedure FillZero(var Fields: TSQLFieldBits); -begin - if MAX_SQLFIELDS=64 then - PInt64(@Fields)^ := 0 else - if MAX_SQLFields=128 then begin - PInt64Array(@Fields)^[0] := 0; - PInt64Array(@Fields)^[1] := 0; - end else - if MAX_SQLFields=192 then begin - PInt64Array(@Fields)^[0] := 0; - PInt64Array(@Fields)^[1] := 0; - PInt64Array(@Fields)^[2] := 0; - end else - if MAX_SQLFields=256 then begin - PInt64Array(@Fields)^[0] := 0; - PInt64Array(@Fields)^[1] := 0; - PInt64Array(@Fields)^[2] := 0; - PInt64Array(@Fields)^[3] := 0; - end else - FillCharFast(Fields,SizeOf(Fields),0); -end; - -{$ifdef FPC}{$pop}{$else}{$WARNINGS ON}{$endif} - -procedure FieldBitsToIndex(const Fields: TSQLFieldBits; var Index: TSQLFieldIndexDynArray; - MaxLength,IndexStart: integer); -var i,n: integer; - sets: array[0..MAX_SQLFIELDS-1] of TSQLFieldIndex; // to avoid memory reallocation -begin - n := 0; - for i := 0 to MaxLength-1 do - if i in Fields then begin - sets[n] := i; - inc(n); - end; - SetLength(Index,IndexStart+n); - for i := 0 to n-1 do - Index[IndexStart+i] := sets[i]; -end; - -function FieldBitsToIndex(const Fields: TSQLFieldBits; - MaxLength: integer): TSQLFieldIndexDynArray; -begin - FieldBitsToIndex(Fields,result,MaxLength); -end; - -function AddFieldIndex(var Indexes: TSQLFieldIndexDynArray; Field: integer): integer; -begin - result := length(Indexes); - SetLength(Indexes,result+1); - Indexes[result] := Field; -end; - -function SearchFieldIndex(var Indexes: TSQLFieldIndexDynArray; Field: integer): integer; -begin - for result := 0 to length(Indexes)-1 do - if Indexes[result]=Field then - exit; - result := -1; -end; - -procedure FieldIndexToBits(const Index: TSQLFieldIndexDynArray; var Fields: TSQLFieldBits); -var i: integer; -begin - FillCharFast(Fields,SizeOf(Fields),0); - for i := 0 to Length(Index)-1 do - if Index[i]>=0 then - include(Fields,Index[i]); -end; - -function FieldIndexToBits(const Index: TSQLFieldIndexDynArray): TSQLFieldBits; -begin - FieldIndexToBits(Index,result); -end; - -function DateToSQL(Date: TDateTime): RawUTF8; -begin - result := ''; - if Date<=0 then - exit; - FastSetString(result,nil,13); - PCardinal(pointer(result))^ := JSON_SQLDATE_MAGIC; - DateToIso8601PChar(Date,PUTF8Char(pointer(result))+3,True); -end; - -function DateToSQL(Year,Month,Day: Cardinal): RawUTF8; -begin - result := ''; - if (Year=0) or (Month-1>11) or (Day-1>30) then - exit; - FastSetString(result,nil,13); - PCardinal(pointer(result))^ := JSON_SQLDATE_MAGIC; - DateToIso8601PChar(PUTF8Char(pointer(result))+3,True,Year,Month,Day); -end; - -var - JSON_SQLDATE_MAGIC_TEXT: RawUTF8; - -function DateTimeToSQL(DT: TDateTime; WithMS: boolean): RawUTF8; -begin - if DT<=0 then - result := '' else begin - if frac(DT)=0 then - result := JSON_SQLDATE_MAGIC_TEXT+DateToIso8601(DT,true) else - if trunc(DT)=0 then - result := JSON_SQLDATE_MAGIC_TEXT+TimeToIso8601(DT,true,'T',WithMS) else - result := JSON_SQLDATE_MAGIC_TEXT+DateTimeToIso8601(DT,true,'T',WithMS); - end; -end; - -function TimeLogToSQL(const Timestamp: TTimeLog): RawUTF8; -begin - if Timestamp=0 then - result := '' else - result := JSON_SQLDATE_MAGIC_TEXT+PTimeLogBits(@Timestamp)^.Text(true); -end; - -function Iso8601ToSQL(const S: RawByteString): RawUTF8; -begin - if IsIso8601(pointer(S),length(S)) then - result := JSON_SQLDATE_MAGIC_TEXT+S else - result := ''; -end; - -function SQLToDateTime(const ParamValueWithMagic: RawUTF8): TDateTime; -begin - result := Iso8601ToDateTimePUTF8Char(PUTF8Char(pointer(ParamValueWithMagic))+3, - length(ParamValueWithMagic)-3); -end; - -const - NULL_LOW = ord('n')+ord('u')shl 8+ord('l')shl 16+ord('l')shl 24; - -function SQLParamContent(P: PUTF8Char; out ParamType: TSQLParamType; out ParamValue: RawUTF8; - out wasNull: boolean): PUTF8Char; -var PBeg: PAnsiChar; - L: integer; - c: cardinal; -begin - ParamType := sptUnknown; - wasNull := false; - result := nil; - if P=nil then - exit; - while (P^<=' ') and (P^<>#0) do inc(P); - case P^ of - '''','"': begin - P := UnQuoteSQLStringVar(P,ParamValue); - if P=nil then - exit; // not a valid quoted string (e.g. unexpected end in middle of it) - ParamType := sptText; - L := length(ParamValue)-3; - if L>0 then begin - c := PInteger(ParamValue)^ and $00ffffff; - if c=JSON_BASE64_MAGIC then begin - // ':("\uFFF0base64encodedbinary"):' format -> decode - Base64MagicDecode(ParamValue); // wrapper function to avoid temp. string - ParamType := sptBlob; - end else - if (c=JSON_SQLDATE_MAGIC) and // handle ':("\uFFF112012-05-04"):' format - IsIso8601(PUTF8Char(pointer(ParamValue))+3,L) then begin - Delete(ParamValue,1,3); // return only ISO-8601 text - ParamType := sptDateTime; // identified as Date/Time - end; - end; - end; - '-','+','0'..'9': begin // allow 0 or + in SQL - // check if P^ is a true numerical value - PBeg := pointer(P); - ParamType := sptInteger; - repeat inc(P) until not (P^ in ['0'..'9']); // check digits - if P^='.' then begin - inc(P); - if P^ in ['0'..'9'] then begin - ParamType := sptFloat; - repeat inc(P) until not (P^ in ['0'..'9']); // check fractional digits - end else begin - ParamType := sptUnknown; // invalid '23023.' value - exit; - end; - end; - if byte(P^) and $DF=ord('E') then begin - ParamType := sptFloat; - inc(P); - if P^='+' then inc(P) else - if P^='-' then inc(P); - while P^ in ['0'..'9'] do inc(P); - end; - FastSetString(ParamValue,PBeg,P-PBeg); - end; - 'n': - if PInteger(P)^=NULL_LOW then begin - inc(P,4); - wasNull := true; - end else - exit; // invalid content (only :(null): expected) - else - exit; // invalid content - end; - while (P^<=' ') and (P^<>#0) do inc(P); - if PWord(P)^<>Ord(')')+Ord(':')shl 8 then - // we expect finishing with P^ pointing at '):' - ParamType := sptUnknown else - // result<>nil only if value content in P^ - result := P+2; -end; - -function ExtractInlineParameters(const SQL: RawUTF8; - var Types: TSQLParamTypeDynArray; var Values: TRawUTF8DynArray; - var maxParam: integer; var Nulls: TSQLFieldBits): RawUTF8; -var ppBeg: integer; - P, Gen: PUTF8Char; - wasNull: boolean; -begin - maxParam := 0; - FillCharFast(Nulls,SizeOf(Nulls),0); - ppBeg := PosEx(RawUTF8(':('),SQL,1); - if (ppBeg=0) or (PosEx(RawUTF8('):'),SQL,ppBeg+2)=0) then begin - // SQL code with no valid :(...): internal parameters -> leave maxParam=0 - result := SQL; - exit; - end; - // compute GenericSQL from SQL, converting :(...): into ? - FastSetString(result,pointer(SQL),length(SQL)); // private copy for unescape - P := pointer(result); // in-place string unescape (keep SQL untouched) - Gen := P+ppBeg-1; // Gen^ just before :( - inc(P,ppBeg+1); // P^ just after :( - repeat - Gen^ := '?'; // replace :(...): by ? - inc(Gen); - if length(Values)<=maxParam then - SetLength(Values,maxParam+16); - if length(Types)<=maxParam then - SetLength(Types,maxParam+64); - P := SQLParamContent(P,Types[maxParam],Values[maxParam],wasNull); - if P=nil then begin - maxParam := 0; - result := SQL; - exit; // any invalid parameter -> try direct SQL - end; - if wasNull then - include(Nulls,maxParam); - while (P^<>#0) and (PWord(P)^<>Ord(':')+Ord('(')shl 8) do begin - Gen^ := P^; - inc(Gen); - inc(P); - end; - if P^=#0 then - Break; - inc(P,2); - inc(maxParam); - until false; - // return generic SQL statement, with ? place-holders and params in Values[] - SetLength(result,Gen-pointer(result)); - inc(maxParam); -end; - -function InlineParameter(ID: Int64): shortstring; -begin - FormatShort(':(%):',[ID],result); -end; - -function InlineParameter(const value: RawUTF8): RawUTF8; -begin - QuotedStrJSON(value,result,':(','):'); -end; - -function SQLVarLength(const Value: TSQLVar): integer; -begin - case Value.VType of - ftBlob: - result := Value.VBlobLen; - ftUTF8: - result := StrLen(Value.VText); // fast enough for our purpose - else - result := 0; // simple/ordinal values, or ftNull - end; -end; - -{$ifndef NOVARIANTS} - -procedure VariantToSQLVar(const Input: variant; var temp: RawByteString; - var Output: TSQLVar); -var wasString: boolean; -begin - Output.Options := []; - with TVarData(Input) do - if VType=varVariant or varByRef then - VariantToSQLVar(PVariant(VPointer)^,temp,Output) else - case VType of - varEmpty, varNull: - Output.VType := ftNull; - varByte: begin - Output.VType := ftInt64; - Output.VInt64 := VByte; - end; - varInteger: begin - Output.VType := ftInt64; - Output.VInt64 := VInteger; - end; - {$ifndef DELPHI5OROLDER} - varLongWord: begin - Output.VType := ftInt64; - Output.VInt64 := VLongWord; - end; - {$endif} - varWord64, varInt64: begin - Output.VType := ftInt64; - Output.VInt64 := VInt64; - end; - varSingle: begin - Output.VType := ftDouble; - Output.VDouble := VSingle; - end; - varDouble: begin // varDate would be converted into ISO8601 by VariantToUTF8() - Output.VType := ftDouble; - Output.VDouble := VDouble; - end; - varCurrency: begin - Output.VType := ftCurrency; - Output.VInt64 := VInt64; - end; - varString: begin // assume RawUTF8 - Output.VType := ftUTF8; - Output.VText := VPointer; - end; - else // handle less current cases - if VariantToInt64(Input,Output.VInt64) then - Output.VType := ftInt64 else begin - VariantToUTF8(Input,RawUTF8(temp),wasString); - if wasString then begin - Output.VType := ftUTF8; - Output.VText := pointer(temp); - end else - Output.VType := ftNull; - end; - end; -end; - -function VariantVTypeToSQLDBFieldType(VType: cardinal): TSQLDBFieldType; -begin - case VType of - varNull: - result := ftNull; - {$ifndef DELPHI5OROLDER}varShortInt, varWord, varLongWord,{$endif} - varSmallInt, varByte, varBoolean, varInteger, varInt64, varWord64: - result := ftInt64; - varSingle,varDouble: - result := ftDouble; - varDate: - result := ftDate; - varCurrency: - result := ftCurrency; - varString: - result := ftUTF8; - else - result := ftUnknown; // includes varEmpty - end; -end; - -function VariantTypeToSQLDBFieldType(const V: Variant): TSQLDBFieldType; -var VD: TVarData absolute V; - tmp: TVarData; -begin - result := VariantVTypeToSQLDBFieldType(VD.VType); - case result of - ftUnknown: - if VD.VType=varEmpty then - result := ftUnknown else - if SetVariantUnRefSimpleValue(V,tmp) then - result := VariantTypeToSQLDBFieldType(variant(tmp)) else - result := ftUTF8; - ftUTF8: - if (VD.VString<>nil) and (PCardinal(VD.VString)^ and $ffffff=JSON_BASE64_MAGIC) then - result := ftBlob; - end; -end; - -function TextToSQLDBFieldType(json: PUTF8Char): TSQLDBFieldType; -begin - if json=nil then - result := ftNull else - result := VariantVTypeToSQLDBFieldType(TextToVariantNumberType(json)); -end; - -function NullableInteger(const Value: Int64): TNullableInteger; -begin - PVariant(@result)^ := Value; -end; - -function NullableIntegerIsEmptyOrNull(const V: TNullableInteger): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function NullableIntegerToValue(const V: TNullableInteger; out Value: Int64): Boolean; -begin - Value := 0; - result := not VarDataIsEmptyOrNull(@V) and VariantToInt64(PVariant(@V)^,Value); -end; - -function NullableIntegerToValue(const V: TNullableInteger): Int64; -begin - VariantToInt64(PVariant(@V)^,result); -end; - -function NullableBoolean(Value: boolean): TNullableBoolean; -begin - PVariant(@result)^ := Value; -end; - -function NullableBooleanIsEmptyOrNull(const V: TNullableBoolean): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function NullableBooleanToValue(const V: TNullableBoolean; out Value: Boolean): Boolean; -begin - Value := false; - result := not VarDataIsEmptyOrNull(@V) and VariantToBoolean(PVariant(@V)^,Value); -end; - -function NullableBooleanToValue(const V: TNullableBoolean): Boolean; -begin - VariantToBoolean(PVariant(@V)^,result); -end; - - -function NullableFloat(const Value: double): TNullableFloat; -begin - PVariant(@result)^ := Value; -end; - -function NullableFloatIsEmptyOrNull(const V: TNullableFloat): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function NullableFloatToValue(const V: TNullableFloat; out Value: Double): Boolean; -begin - Value := 0; - result := not VarDataIsEmptyOrNull(@V) and VariantToDouble(PVariant(@V)^,Value); -end; - -function NullableFloatToValue(const V: TNullableFloat): Double; -begin - VariantToDouble(PVariant(@V)^,result); -end; - - -function NullableCurrency(const Value: currency): TNullableCurrency; -begin - PVariant(@result)^ := Value; -end; - -function NullableCurrencyIsEmptyOrNull(const V: TNullableCurrency): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function NullableCurrencyToValue(const V: TNullableCurrency; out Value: currency): Boolean; -begin - Value := 0; - result := not VarDataIsEmptyOrNull(@V) and VariantToCurrency(PVariant(@V)^,Value); -end; - -function NullableCurrencyToValue(const V: TNullableCurrency): currency; -begin - VariantToCurrency(PVariant(@V)^,result); -end; - - -function NullableDateTime(const Value: TDateTime): TNullableDateTime; -begin - PVariant(@result)^ := Value; -end; - -function NullableDateTimeIsEmptyOrNull(const V: TNullableDateTime): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function NullableDateTimeToValue(const V: TNullableDateTime; out Value: TDateTime): Boolean; -begin - Value := 0; - result := not VarDataIsEmptyOrNull(@V) and VariantToDouble(PVariant(@V)^,Double(Value)); -end; - -function NullableDateTimeToValue(const V: TNullableDateTime): TDateTime; -begin - VariantToDouble(PVariant(@V)^,Double(result)); -end; - - -function NullableTimeLog(const Value: TTimeLog): TNullableTimeLog; -begin - PVariant(@result)^ := Value; -end; - -function NullableTimeLogIsEmptyOrNull(const V: TNullableTimeLog): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function NullableTimeLogToValue(const V: TNullableTimeLog; out Value: TTimeLog): Boolean; -begin - Value := 0; - result := not VarDataIsEmptyOrNull(@V) and VariantToInt64(PVariant(@V)^,PInt64(@Value)^); -end; - -function NullableTimeLogToValue(const V: TNullableTimeLog): TTimeLog; -begin - VariantToInt64(PVariant(@V)^,PInt64(@result)^); -end; - - -function NullableUTF8Text(const Value: RawUTF8): TNullableUTF8Text; -begin - VarClear(PVariant(@result)^); - TVarData(result).VType := varString; - TVarData(result).VAny := nil; // avoid GPF below - RawUTF8(TVarData(result).VAny) := Value; -end; - -function NullableUTF8TextIsEmptyOrNull(const V: TNullableUTF8Text): Boolean; -begin - result := VarDataIsEmptyOrNull(@V); -end; - -function NullableUTF8TextToValue(const V: TNullableUTF8Text; out Value: RawUTF8): boolean; -begin - result := not VarDataIsEmptyOrNull(@V) and VariantToUTF8(PVariant(@V)^,Value); -end; - -function NullableUTF8TextToValue(const V: TNullableUTF8Text): RawUTF8; -var dummy: boolean; -begin - if VarDataIsEmptyOrNull(@V) then // VariantToUTF8() will return 'null' - result := '' else - VariantToUTF8(PVariant(@V)^,result,dummy); -end; - - -{$endif NOVARIANTS} - -{ TJSONWriter } - -procedure TJSONWriter.CancelAllVoid; -const VOIDARRAY: PAnsiChar = '[]'#10; - VOIDFIELD: PAnsiChar = '{"FieldCount":0}'; -begin - CancelAll; // rewind JSON - if fExpand then // same as sqlite3_get_table() - inc(fTotalFileSize,fStream.Write(VOIDARRAY^,3)) else - inc(fTotalFileSize,fStream.Write(VOIDFIELD^,16)); -end; - -constructor TJSONWriter.Create(aStream: TStream; Expand, withID: boolean; - const Fields: TSQLFieldBits; aBufSize: integer); -begin - Create(aStream,Expand,withID,FieldBitsToIndex(Fields),aBufSize); -end; - -constructor TJSONWriter.Create(aStream: TStream; Expand, withID: boolean; - const Fields: TSQLFieldIndexDynArray; aBufSize: integer; - aStackBuffer: PTextWriterStackBuffer); -begin - if aStream=nil then - if aStackBuffer<>nil then - CreateOwnedStream(aStackBuffer^) else - CreateOwnedStream(aBufSize) else - if aStackBuffer<>nil then - inherited Create(aStream,aStackBuffer,SizeOf(aStackBuffer^)) else - inherited Create(aStream,aBufSize); - fExpand := Expand; - fWithID := withID; - fFields := Fields; -end; - -procedure TJSONWriter.AddColumns(aKnownRowsCount: integer); -var i: integer; -begin - if fExpand then begin - if twoForceJSONExtended in CustomOptions then - for i := 0 to High(ColNames) do - ColNames[i] := ColNames[i]+':' else - for i := 0 to High(ColNames) do - ColNames[i] := '"'+ColNames[i]+'":'; - end else begin - AddShort('{"fieldCount":'); - Add(length(ColNames)); - if aKnownRowsCount>0 then begin - AddShort(',"rowCount":'); - Add(aKnownRowsCount); - end; - AddShort(',"values":["'); - // first row is FieldNames - for i := 0 to High(ColNames) do begin - AddString(ColNames[i]); - AddNoJSONEscape(PAnsiChar('","'),3); - end; - CancelLastChar('"'); - fStartDataPosition := fStream.Position+(B-fTempBuf); - // B := buf-1 at startup -> need ',val11' position in - // "values":["col1","col2",val11,' i.e. current pos without the ',' - end; -end; - -procedure TJSONWriter.ChangeExpandedFields(aWithID: boolean; - const aFields: TSQLFieldIndexDynArray); -begin - if not Expand then - raise ESynException.CreateUTF8( - '%.ChangeExpandedFields() called with Expanded=false',[self]); - fWithID := aWithID; - fFields := aFields; -end; - -procedure TJSONWriter.EndJSONObject(aKnownRowsCount,aRowsCount: integer; - aFlushFinal: boolean); -begin - CancelLastComma; // cancel last ',' - Add(']'); - if not fExpand then begin - if aKnownRowsCount=0 then begin - AddShort(',"rowCount":'); - Add(aRowsCount); - end; - Add('}'); - end; - Add(#10); - if aFlushFinal then - FlushFinal; -end; - -procedure TJSONWriter.TrimFirstRow; -var P, PBegin, PEnd: PUTF8Char; -begin - if (self=nil) or not fStream.InheritsFrom(TMemoryStream) or - fExpand or (fStartDataPosition=0) then - exit; - // go to begin of first row - FlushToStream; // we need the data to be in fStream memory - // PBegin^=val11 in { "fieldCount":1,"values":["col1","col2",val11,"val12",val21,..] } - PBegin := TMemoryStream(fStream).Memory; - PEnd := PBegin+fStream.Position; - PEnd^ := #0; // mark end of current values - inc(PBegin,fStartDataPosition+1); // +1 to include ',' of ',val11' - // jump to end of first row - P := GotoNextJSONItem(PBegin,length(ColNames)); - if P=nil then exit; // unexpected end - // trim first row data - if P^<>#0 then - MoveFast(P^,PBegin^,PEnd-P); // erase content - fStream.Seek(PBegin-P,soCurrent); // adjust current stream position -end; - - -{ ************ Expression Search Engine ************************** } - -function ToText(r: TExprParserResult): PShortString; -begin - result := GetEnumName(TypeInfo(TExprParserResult), ord(r)); -end; - -function ToUTF8(r: TExprParserResult): RawUTF8; -begin - result := UnCamelCase(TrimLeftLowerCaseShort(ToText(r))); -end; - - -{ TExprNode } - -function TExprNode.Append(node: TExprNode): boolean; -begin - result := node <> nil; - if result then - Last.fNext := node; -end; - -constructor TExprNode.Create(nodeType: TExprNodeType); -begin - inherited Create; - fNodeType := nodeType; -end; - -destructor TExprNode.Destroy; -begin - fNext.Free; - inherited Destroy; -end; - -function TExprNode.Last: TExprNode; -begin - result := self; - while result.Next <> nil do - result := result.Next; -end; - - -{ TParserAbstract } - -constructor TParserAbstract.Create; -begin - inherited Create; - Initialize; -end; - -destructor TParserAbstract.Destroy; -begin - Clear; - inherited Destroy; -end; - -procedure TParserAbstract.Clear; -begin - fWordCount := 0; - fWords := nil; - fExpression := ''; - FreeAndNil(fFirstNode); -end; - -function TParserAbstract.ParseExpr: TExprNode; -begin - result := ParseFactor; - ParseNextCurrentWord; - if (fCurrentWord = '') or (fCurrentWord = ')') then - exit; - if IdemPropNameU(fCurrentWord, fAndWord) then begin // w1 & w2 = w1 AND w2 - ParseNextCurrentWord; - if result.Append(ParseExpr) then - result.Append(TExprNode.Create(entAnd)); - exit; - end - else if IdemPropNameU(fCurrentWord, fOrWord) then begin // w1 + w2 = w1 OR w2 - ParseNextCurrentWord; - if result.Append(ParseExpr) then - result.Append(TExprNode.Create(entOr)); - exit; - end - else if fNoWordIsAnd and result.Append(ParseExpr) then // 'w1 w2' = 'w1 & w2' - result.Append(TExprNode.Create(entAnd)); -end; - -function TParserAbstract.ParseFactor: TExprNode; -begin - if fCurrentError <> eprSuccess then - result := nil - else if IdemPropNameU(fCurrentWord, fNotWord) then begin - ParseNextCurrentWord; - result := ParseFactor; - if fCurrentError <> eprSuccess then - exit; - result.Append(TExprNode.Create(entNot)); - end - else - result := ParseTerm; -end; - -function TParserAbstract.ParseTerm: TExprNode; -begin - result := nil; - if fCurrentError <> eprSuccess then - exit; - if fCurrentWord = '(' then begin - ParseNextCurrentWord; - result := ParseExpr; - if fCurrentError <> eprSuccess then - exit; - if fCurrentWord <> ')' then begin - FreeAndNil(result); - fCurrentError := eprMissingParenthesis; - end; - end - else if fCurrentWord = '' then begin - result := nil; - fCurrentError := eprMissingFinalWord; - end - else - try // calls meta-class overriden constructor - result := fWordClass.Create(self, fCurrentWord); - fCurrentError := TExprNodeWordAbstract(result).ParseWord; - if fCurrentError <> eprSuccess then begin - FreeAndNil(result); - exit; - end; - SetLength(fWords, fWordCount + 1); - fWords[fWordCount] := TExprNodeWordAbstract(result); - inc(fWordCount); - except - FreeAndNil(result); - fCurrentError := eprInvalidExpression; - end; -end; - -function TParserAbstract.Parse(const aExpression: RawUTF8): TExprParserResult; -var - depth: integer; - n: TExprNode; -begin - Clear; - fCurrentError := eprSuccess; - fCurrent := pointer(aExpression); - ParseNextCurrentWord; - if fCurrentWord = '' then begin - result := eprNoExpression; - exit; - end; - fFirstNode := ParseExpr; - result := fCurrentError; - if result = eprSuccess then begin - depth := 0; - n := fFirstNode; - while n <> nil do begin - case n.NodeType of - entWord: begin - inc(depth); - if depth > high(fFoundStack) then begin - result := eprTooManyParenthesis; - break; - end; - end; - entOr, entAnd: - dec(depth); - end; - n := n.Next; - end; - end; - if result = eprSuccess then - fExpression := aExpression - else - Clear; - fCurrent := nil; -end; - -class function TParserAbstract.ParseError(const aExpression: RawUTF8): RawUTF8; -var - parser: TParserAbstract; - res: TExprParserResult; -begin - parser := Create; - try - res := parser.Parse(aExpression); - if res = eprSuccess then - result := '' - else - result := ToUTF8(res); - finally - parser.Free; - end; -end; - -function TParserAbstract.Execute: boolean; -var - n: TExprNode; - st: PBoolean; -begin // code below compiles very efficiently on FPC/x86-64 - st := @fFoundStack; - n := fFirstNode; - repeat - case n.NodeType of - entWord: begin - st^ := TExprNodeWordAbstract(n).fFound; - inc(st); // see eprTooManyParenthesis above to avoid buffer overflow - end; - entNot: - PAnsiChar(st)[-1] := AnsiChar(ord(PAnsiChar(st)[-1]) xor 1); - entOr: begin - dec(st); - PAnsiChar(st)[-1] := AnsiChar(st^ or boolean(PAnsiChar(st)[-1])); - end; { TODO : optimize TExprParser OR when left member is already TRUE } - entAnd: begin - dec(st); - PAnsiChar(st)[-1] := AnsiChar(st^ and boolean(PAnsiChar(st)[-1])); - end; - end; - n := n.Next; - until n = nil; - result := boolean(PAnsiChar(st)[-1]); -end; - - -{ TExprParserAbstract } - -procedure TExprParserAbstract.Initialize; -begin - fAndWord := '&'; - fOrWord := '+'; - fNotWord := '-'; - fNoWordIsAnd := true; -end; - -procedure TExprParserAbstract.ParseNextCurrentWord; -var - P: PUTF8Char; -begin - fCurrentWord := ''; - P := fCurrent; - if P = nil then - exit; - while P^ in [#1..' '] do - inc(P); - if P^ = #0 then - exit; - if P^ in PARSER_STOPCHAR then begin - FastSetString(fCurrentWord, P, 1); - fCurrent := P + 1; - end - else begin - fCurrent := P; - ParseNextWord; - end; -end; - -procedure TExprParserAbstract.ParseNextWord; -const - STOPCHAR = PARSER_STOPCHAR + [#0, ' ']; -var - P: PUTF8Char; -begin - P := fCurrent; - while not(P^ in STOPCHAR) do - inc(P); - FastSetString(fCurrentWord, fCurrent, P - fCurrent); - fCurrent := P; -end; - - -{ TExprNodeWordAbstract } - -constructor TExprNodeWordAbstract.Create(aOwner: TParserAbstract; const aWord: RawUTF8); -begin - inherited Create(entWord); - fWord := aWord; - fOwner := aOwner; -end; - - -{ TExprParserMatchNode } - -type - TExprParserMatchNode = class(TExprNodeWordAbstract) - protected - fMatch: TMatch; - function ParseWord: TExprParserResult; override; - end; - PExprParserMatchNode = ^TExprParserMatchNode; - -function TExprParserMatchNode.ParseWord: TExprParserResult; -begin - fMatch.Prepare(fWord, (fOwner as TExprParserMatch).fCaseSensitive, {reuse=}true); - result := eprSuccess; -end; - - -{ TExprParserMatch } - -constructor TExprParserMatch.Create(aCaseSensitive: boolean); -begin - inherited Create; - fCaseSensitive := aCaseSensitive; -end; - -procedure TExprParserMatch.Initialize; -begin - inherited Initialize; - fWordClass := TExprParserMatchNode; -end; - -function TExprParserMatch.Search(const aText: RawUTF8): boolean; -begin - result := Search(pointer(aText), length(aText)); -end; - -function TExprParserMatch.Search(aText: PUTF8Char; aTextLen: PtrInt): boolean; -const // rough estimation of UTF-8 characters - IS_UTF8_WORD = ['0' .. '9', 'A' .. 'Z', 'a' .. 'z', #$80 ..#$ff]; -var - P, PEnd: PUTF8Char; - n: PtrInt; -begin - P := aText; - if (P = nil) or (fWords = nil) then begin - result := false; - exit; - end; - if fMatchedLastSet > 0 then begin - n := fWordCount; - repeat - dec(n); - fWords[n].fFound := false; - until n = 0; - fMatchedLastSet := 0; - end; - PEnd := P + aTextLen; - while (P < PEnd) and (fMatchedLastSet < fWordCount) do begin - while not(P^ in IS_UTF8_WORD) do begin - inc(P); - if P = PEnd then - break; - end; - if P = PEnd then - break; - aText := P; - repeat - inc(P); - until (P = PEnd) or not(P^ in IS_UTF8_WORD); - aTextLen := P - aText; // now aText/aTextLen point to a word - n := fWordCount; - repeat - dec(n); - with TExprParserMatchNode(fWords[n]) do - if not fFound and fMatch.Match(aText, aTextLen) then begin - fFound := true; - inc(fMatchedLastSet); - end; - until n = 0; - end; - result := Execute; -end; - -{ ************ Multi-Threading classes ************************** } - -{ TPendingTaskList } - -constructor TPendingTaskList.Create; -begin - inherited Create; - fTasks.InitSpecific(TypeInfo(TPendingTaskListItemDynArray),fTask,djInt64,@fCount); -end; - -function TPendingTaskList.GetTimestamp: Int64; -begin - result := {$ifdef FPCLINUX}SynFPCLinux.{$endif}GetTickCount64; -end; - -procedure TPendingTaskList.AddTask(aMilliSecondsDelayFromNow: integer; - const aTask: RawByteString); -var item: TPendingTaskListItem; - ndx: integer; -begin - item.Timestamp := GetTimestamp+aMilliSecondsDelayFromNow; - item.Task := aTask; - fSafe.Lock; - try - if fTasks.FastLocateSorted(item,ndx) then - inc(ndx); // always insert just after any existing timestamp - fTasks.FastAddSorted(ndx,item); - finally - fSafe.UnLock; - end; -end; - -procedure TPendingTaskList.AddTasks( - const aMilliSecondsDelays: array of integer; - const aTasks: array of RawByteString); -var item: TPendingTaskListItem; - i,ndx: integer; -begin - if length(aTasks)<>length(aMilliSecondsDelays) then - exit; - item.Timestamp := GetTimestamp; - fSafe.Lock; - try - for i := 0 to High(aTasks) do begin - inc(item.Timestamp,aMilliSecondsDelays[i]); - item.Task := aTasks[i]; - if fTasks.FastLocateSorted(item,ndx) then - inc(ndx); // always insert just after any existing timestamp - fTasks.FastAddSorted(ndx,item); - end; - finally - fSafe.UnLock; - end; -end; - -function TPendingTaskList.GetCount: integer; -begin - if self=nil then - result := 0 else begin - fSafe.Lock; - try - result := fCount; - finally - fSafe.UnLock; - end; - end; -end; - -function TPendingTaskList.NextPendingTask: RawByteString; -begin - result := ''; - if (self=nil) or (fCount=0) then - exit; - fSafe.Lock; - try - if fCount>0 then - if GetTimestamp>=fTask[0].Timestamp then begin - result := fTask[0].Task; - fTasks.FastDeleteSorted(0); - end; - finally - fSafe.UnLock; - end; -end; - -procedure TPendingTaskList.Clear; -begin - if (self=nil) or (fCount=0) then - exit; - fSafe.Lock; - try - fTasks.Clear; - finally - fSafe.UnLock; - end; -end; - - -{$ifndef LVCL} // LVCL does not implement TEvent - -{ TSynBackgroundThreadAbstract } - -constructor TSynBackgroundThreadAbstract.Create(const aThreadName: RawUTF8; - OnBeforeExecute,OnAfterExecute: TNotifyThreadEvent; CreateSuspended: boolean); -begin - fProcessEvent := TEvent.Create(nil,false,false,''); - fThreadName := aThreadName; - fOnBeforeExecute := OnBeforeExecute; - fOnAfterExecute := OnAfterExecute; - inherited Create(CreateSuspended{$ifdef FPC},512*1024{$endif}); // DefaultStackSize=512KB -end; - -{$ifndef HASTTHREADSTART} -procedure TSynBackgroundThreadAbstract.Start; -begin - Resume; -end; -{$endif} - -{$ifndef HASTTHREADTERMINATESET} -procedure TSynBackgroundThreadAbstract.Terminate; -begin - inherited Terminate; // FTerminated := True - TerminatedSet; -end; -{$endif} - -procedure TSynBackgroundThreadAbstract.TerminatedSet; -begin - fProcessEvent.SetEvent; // ExecuteLoop should handle Terminated flag -end; - -procedure TSynBackgroundThreadAbstract.WaitForNotExecuting(maxMS: integer); -var endtix: Int64; -begin - if fExecute=exRun then begin - endtix := SynCommons.GetTickCount64+maxMS; - repeat - SleepHiRes(1); // wait for Execute to finish - until (fExecute<>exRun) or (SynCommons.GetTickCount64>=endtix); - end; -end; - -destructor TSynBackgroundThreadAbstract.Destroy; -begin - if fExecute=exRun then begin - Terminate; - WaitForNotExecuting(100); - end; - inherited Destroy; - FreeAndNil(fProcessEvent); -end; - -procedure TSynBackgroundThreadAbstract.SetExecuteLoopPause(dopause: boolean); -begin - if Terminated or (dopause=fExecuteLoopPause) or (fExecute=exFinished) then - exit; - fExecuteLoopPause := dopause; - fProcessEvent.SetEvent; // notify Execute main loop -end; - -procedure TSynBackgroundThreadAbstract.Execute; -begin - try - if fThreadName='' then - SetCurrentThreadName('%(%)',[self,pointer(self)]) else - SetCurrentThreadName('%',[fThreadName]); - if Assigned(fOnBeforeExecute) then - fOnBeforeExecute(self); - try - fExecute := exRun; - while not Terminated do - if fExecuteLoopPause then - FixedWaitFor(fProcessEvent,100) else - ExecuteLoop; - finally - if Assigned(fOnAfterExecute) then - fOnAfterExecute(self); - end; - finally - fExecute := exFinished; - end; -end; - -{ TSynBackgroundThreadMethodAbstract } - -constructor TSynBackgroundThreadMethodAbstract.Create(aOnIdle: TOnIdleSynBackgroundThread; - const aThreadName: RawUTF8; OnBeforeExecute,OnAfterExecute: TNotifyThreadEvent); -begin - fOnIdle := aOnIdle; // cross-platform may run Execute as soon as Create is called - fCallerEvent := TEvent.Create(nil,false,false,''); - fPendingProcessLock.Init; - inherited Create(aThreadName,OnBeforeExecute,OnAfterExecute); -end; - -destructor TSynBackgroundThreadMethodAbstract.Destroy; -begin - SetPendingProcess(flagDestroying); - fProcessEvent.SetEvent; // notify terminated - FixedWaitForever(fCallerEvent); // wait for actual termination - FreeAndNil(fCallerEvent); - inherited Destroy; - fPendingProcessLock.Done; -end; - -function TSynBackgroundThreadMethodAbstract.GetPendingProcess: TSynBackgroundThreadProcessStep; -begin - fPendingProcessLock.Lock; - result := fPendingProcessFlag; - fPendingProcessLock.UnLock; -end; - -procedure TSynBackgroundThreadMethodAbstract.SetPendingProcess(State: TSynBackgroundThreadProcessStep); -begin - fPendingProcessLock.Lock; - fPendingProcessFlag := State; - fPendingProcessLock.UnLock; -end; - -procedure TSynBackgroundThreadMethodAbstract.ExecuteLoop; -{$ifndef DELPHI5OROLDER} -var E: TObject; -{$endif} -begin - case FixedWaitFor(fProcessEvent,INFINITE) of - wrSignaled: - case GetPendingProcess of - flagDestroying: begin - fCallerEvent.SetEvent; // abort caller thread process - Terminate; // forces Execute loop ending - exit; - end; - flagStarted: - if not Terminated then - if fExecuteLoopPause then // pause -> try again later - fProcessEvent.SetEvent else - try - fBackgroundException := nil; - try - if Assigned(fOnBeforeProcess) then - fOnBeforeProcess(self); - try - Process; - finally - if Assigned(fOnAfterProcess) then - fOnAfterProcess(self); - end; - except - {$ifdef DELPHI5OROLDER} - on E: Exception do - fBackgroundException := ESynException.CreateUTF8( - 'Redirected % [%]',[E,E.Message]); - {$else} - E := AcquireExceptionObject; - if E.InheritsFrom(Exception) then - fBackgroundException := Exception(E); - {$endif} - end; - finally - SetPendingProcess(flagFinished); - fCallerEvent.SetEvent; - end; - end; - end; -end; - -function TSynBackgroundThreadMethodAbstract.AcquireThread: TSynBackgroundThreadProcessStep; -begin - fPendingProcessLock.Lock; - try - result := fPendingProcessFlag; - if result=flagIdle then begin // we just acquired the thread! congrats! - fPendingProcessFlag := flagStarted; // atomic set "started" flag - fCallerThreadID := ThreadID; - end; - finally - fPendingProcessLock.UnLock; - end; -end; - -function TSynBackgroundThreadMethodAbstract.OnIdleProcessNotify(start: Int64): integer; -begin - result := {$ifdef FPCLINUX}SynFPCLinux.{$else}SynCommons.{$endif}GetTickCount64-start; - if result<0 then - result := MaxInt; // should happen only under XP -> ignore - if Assigned(fOnIdle) then - fOnIdle(self,result) ; -end; - -procedure TSynBackgroundThreadMethodAbstract.WaitForFinished(start: Int64; - const onmainthreadidle: TNotifyEvent); -var E: Exception; -begin - if (self=nil) or not(fPendingProcessFlag in [flagStarted, flagFinished]) then - exit; // nothing to wait for - try - if Assigned(onmainthreadidle) then begin - while FixedWaitFor(fCallerEvent,100)=wrTimeout do - onmainthreadidle(self); - end else - {$ifdef MSWINDOWS} // do process the OnIdle only if UI - if Assigned(fOnIdle) then begin - while FixedWaitFor(fCallerEvent,100)=wrTimeout do - OnIdleProcessNotify(start); - end else - {$endif} - FixedWaitForever(fCallerEvent); - if fPendingProcessFlag<>flagFinished then - ESynException.CreateUTF8('%.WaitForFinished: flagFinished?',[self]); - if fBackgroundException<>nil then begin - E := fBackgroundException; - fBackgroundException := nil; - raise E; // raise background exception in the calling scope - end; - finally - fParam := nil; - fCallerThreadID := 0; - FreeAndNil(fBackgroundException); - SetPendingProcess(flagIdle); - if Assigned(fOnIdle) then - fOnIdle(self,-1); // notify finished - end; -end; - -function TSynBackgroundThreadMethodAbstract.RunAndWait(OpaqueParam: pointer): boolean; -var start: Int64; - ThreadID: TThreadID; -begin - result := false; - ThreadID := GetCurrentThreadId; - if (self=nil) or (ThreadID=fCallerThreadID) then - // avoid endless loop when waiting in same thread (e.g. UI + OnIdle) - exit; - // 1. wait for any previous request to be finished (should not happen often) - if Assigned(fOnIdle) then - fOnIdle(self,0); // notify started - start := {$ifdef FPCLINUX}SynFPCLinux.{$else}SynCommons.{$endif}GetTickCount64; - repeat - case AcquireThread of - flagDestroying: - exit; - flagIdle: - break; // we acquired the background thread - end; - case OnIdleProcessNotify(start) of // Windows.GetTickCount64 res is 10-16 ms - 0..20: SleepHiRes(0); // 10 microsec delay on POSIX - 21..100: SleepHiRes(1); - 101..900: SleepHiRes(5); - else SleepHiRes(50); - end; - until false; - // 2. process execution in the background thread - fParam := OpaqueParam; - fProcessEvent.SetEvent; // notify background thread for Call pending process - WaitForFinished(start,nil); // wait for flagFinished, then set flagIdle - result := true; -end; - -function TSynBackgroundThreadMethodAbstract.GetOnIdleBackgroundThreadActive: boolean; -begin - result := (self<>nil) and Assigned(fOnIdle) and (GetPendingProcess<>flagIdle); -end; - - -{ TSynBackgroundThreadEvent } - -constructor TSynBackgroundThreadEvent.Create(aOnProcess: TOnProcessSynBackgroundThread; - aOnIdle: TOnIdleSynBackgroundThread; const aThreadName: RawUTF8); -begin - inherited Create(aOnIdle,aThreadName); - fOnProcess := aOnProcess; -end; - -procedure TSynBackgroundThreadEvent.Process; -begin - if not Assigned(fOnProcess) then - raise ESynException.CreateUTF8('Invalid %.RunAndWait() call',[self]); - fOnProcess(self,fParam); -end; - - -{ TSynBackgroundThreadMethod } - -procedure TSynBackgroundThreadMethod.Process; -var Method: ^TThreadMethod; -begin - if fParam=nil then - raise ESynException.CreateUTF8('Invalid %.RunAndWait() call',[self]); - Method := fParam; - Method^(); -end; - -procedure TSynBackgroundThreadMethod.RunAndWait(Method: TThreadMethod); -var Met: TMethod absolute Method; -begin - inherited RunAndWait(@Met); -end; - - -{ TSynBackgroundThreadProcedure } - -constructor TSynBackgroundThreadProcedure.Create(aOnProcess: TOnProcessSynBackgroundThreadProc; - aOnIdle: TOnIdleSynBackgroundThread; const aThreadName: RawUTF8); -begin - inherited Create(aOnIdle,aThreadName); - fOnProcess := aOnProcess; -end; - -procedure TSynBackgroundThreadProcedure.Process; -begin - if not Assigned(fOnProcess) then - raise ESynException.CreateUTF8('Invalid %.RunAndWait() call',[self]); - fOnProcess(fParam); -end; - - -{ TSynParallelProcessThread } - -procedure TSynParallelProcessThread.Process; -begin - if not Assigned(fMethod) then - exit; - fMethod(fIndexStart,fIndexStop); - fMethod := nil; -end; - -procedure TSynParallelProcessThread.Start( - Method: TSynParallelProcessMethod; IndexStart, IndexStop: integer); -begin - fMethod := Method; - fIndexStart := IndexStart; - fIndexStop := IndexStop; - fProcessEvent.SetEvent; // notify execution -end; - - -{ TSynBackgroundThreadProcess } - -constructor TSynBackgroundThreadProcess.Create(const aThreadName: RawUTF8; - aOnProcess: TOnSynBackgroundThreadProcess; aOnProcessMS: cardinal; - aOnBeforeExecute, aOnAfterExecute: TNotifyThreadEvent; - aStats: TSynMonitorClass; CreateSuspended: boolean); -begin - if not Assigned(aOnProcess) then - raise ESynException.CreateUTF8('%.Create(aOnProcess=nil)',[self]); - if aStats<>nil then - fStats := aStats.Create(aThreadName); - fOnProcess := aOnProcess; - fOnProcessMS := aOnProcessMS; - if fOnProcessMS=0 then - fOnProcessMS := INFINITE; // wait until ProcessEvent.SetEvent or Terminated - inherited Create(aThreadName,aOnBeforeExecute,aOnAfterExecute,CreateSuspended); -end; - -destructor TSynBackgroundThreadProcess.Destroy; -begin - if fExecute=exRun then begin - Terminate; - WaitForNotExecuting(10000); // expect the background task to be finished - end; - inherited Destroy; - fStats.Free; -end; - -procedure TSynBackgroundThreadProcess.ExecuteLoop; -var wait: TWaitResult; -begin - wait := FixedWaitFor(fProcessEvent,fOnProcessMS); - if not Terminated and (wait in [wrSignaled,wrTimeout]) then - if fExecuteLoopPause then // pause -> try again later - fProcessEvent.SetEvent else - try - if fStats<>nil then - fStats.ProcessStartTask; - try - fOnProcess(self,wait); - finally - if fStats<>nil then - fStats.ProcessEnd; - end; - except - on E: Exception do begin - if fStats<>nil then - fStats.ProcessErrorRaised(E); - if Assigned(fOnException) then - fOnException(E); - end; - end; -end; - - -{ TSynBackgroundTimer } - -var - ProcessSystemUse: TSystemUse; - -constructor TSynBackgroundTimer.Create(const aThreadName: RawUTF8; - aOnBeforeExecute, aOnAfterExecute: TNotifyThreadEvent; aStats: TSynMonitorClass); -begin - fTasks.Init(TypeInfo(TSynBackgroundTimerTaskDynArray),fTask); - fTaskLock.Init; - {$ifndef NOVARIANTS} - fTaskLock.LockedBool[0] := false; - {$endif} - inherited Create(aThreadName,EverySecond,1000,aOnBeforeExecute,aOnAfterExecute,aStats); -end; - -destructor TSynBackgroundTimer.Destroy; -begin - if (ProcessSystemUse<>nil) and (ProcessSystemUse.fTimer=self) then - ProcessSystemUse.fTimer := nil; // allows processing by another background timer - inherited Destroy; - fTaskLock.Done; -end; - -const - TIXPRECISION = 32; // GetTickCount64 resolution (for aOnProcessSecs=1) - -procedure TSynBackgroundTimer.EverySecond( - Sender: TSynBackgroundThreadProcess; Event: TWaitResult); -var tix: Int64; - i,f,n: integer; - t: ^TSynBackgroundTimerTask; - todo: TSynBackgroundTimerTaskDynArray; // avoid lock contention -begin - if (fTask=nil) or Terminated then - exit; - tix := {$ifdef FPCLINUX}SynFPCLinux.{$else}SynCommons.{$endif}GetTickCount64; - n := 0; - fTaskLock.Lock; - try - variant(fTaskLock.Padding[0]) := true; // = fTaskLock.LockedBool[0] - try - for i := 0 to length(fTask)-1 do begin - t := @fTask[i]; - if tix>=t^.NextTix then begin - SetLength(todo,n+1); - todo[n] := t^; - inc(n); - t^.FIFO := nil; // now owned by todo[n].FIFO - t^.NextTix := tix+((t^.Secs*1000)-TIXPRECISION); - end; - end; - finally - fTaskLock.UnLock; - end; - for i := 0 to n-1 do - with todo[i] do - if FIFO<>nil then - for f := 0 to length(FIFO)-1 do - try - OnProcess(self,Event,FIFO[f]); - except - end - else - try - OnProcess(self,Event,''); - except - end; - finally - {$ifdef NOVARIANTS} - fTaskLock.Lock; - variant(fTaskLock.Padding[0]) := false; - fTaskLock.UnLock; - {$else} - fTaskLock.LockedBool[0] := false; - {$endif} - end; -end; - -function TSynBackgroundTimer.Find(const aProcess: TMethod): integer; -begin // caller should have made fTaskLock.Lock; - for result := length(fTask)-1 downto 0 do - with TMethod(fTask[result].OnProcess) do - if (Code=aProcess.Code) and (Data=aProcess.Data) then - exit; - result := -1; -end; - -procedure TSynBackgroundTimer.Enable( - aOnProcess: TOnSynBackgroundTimerProcess; aOnProcessSecs: cardinal); -var task: TSynBackgroundTimerTask; - found: integer; -begin - if (self=nil) or Terminated or not Assigned(aOnProcess) then - exit; - if aOnProcessSecs=0 then begin - Disable(aOnProcess); - exit; - end; - task.OnProcess := aOnProcess; - task.Secs := aOnProcessSecs; - task.NextTix := {$ifdef FPCLINUX}SynFPCLinux.{$else}SynCommons.{$endif}GetTickCount64+ - (aOnProcessSecs*1000-TIXPRECISION); - fTaskLock.Lock; - try - found := Find(TMethod(aOnProcess)); - if found>=0 then - fTask[found] := task else - fTasks.Add(task); - finally - fTaskLock.UnLock; - end; -end; - -function TSynBackgroundTimer.Processing: boolean; -begin - {$ifdef NOVARIANTS} - with fTaskLock.Padding[0] do - result := (VType=varBoolean) and VBoolean; - {$else} - result := fTaskLock.LockedBool[0]; - {$endif} -end; - -procedure TSynBackgroundTimer.WaitUntilNotProcessing(timeoutsecs: integer); -var timeout: Int64; -begin - if not Processing then - exit; - timeout := {$ifdef FPCLINUX}SynFPCLinux.{$else}SynCommons.{$endif}GetTickCount64+timeoutsecs*1000; - repeat - SleepHiRes(1); - until not Processing or - ({$ifdef FPCLINUX}SynFPCLinux.{$else}SynCommons.{$endif}GetTickcount64>timeout); -end; - -function TSynBackgroundTimer.ExecuteNow(aOnProcess: TOnSynBackgroundTimerProcess): boolean; -begin - result := Add(aOnProcess,#0,true); -end; - -function TSynBackgroundTimer.EnQueue(aOnProcess: TOnSynBackgroundTimerProcess; - const aMsg: RawUTF8; aExecuteNow: boolean): boolean; -begin - result := Add(aOnProcess,aMsg,aExecuteNow); -end; - -function TSynBackgroundTimer.EnQueue(aOnProcess: TOnSynBackgroundTimerProcess; - const aMsgFmt: RawUTF8; const Args: array of const; aExecuteNow: boolean): boolean; -var msg: RawUTF8; -begin - FormatUTF8(aMsgFmt,Args,msg); - result := Add(aOnProcess,msg,aExecuteNow); -end; - -function TSynBackgroundTimer.Add(aOnProcess: TOnSynBackgroundTimerProcess; - const aMsg: RawUTF8; aExecuteNow: boolean): boolean; -var found: integer; -begin - result := false; - if (self=nil) or Terminated or not Assigned(aOnProcess) then - exit; - fTaskLock.Lock; - try - found := Find(TMethod(aOnProcess)); - if found>=0 then begin - with fTask[found] do begin - if aExecuteNow then - NextTix := 0; - if aMsg<>#0 then - AddRawUTF8(FIFO,aMsg); - end; - if aExecuteNow then - ProcessEvent.SetEvent; - result := true; - end; - finally - fTaskLock.UnLock; - end; -end; - -function TSynBackgroundTimer.DeQueue(aOnProcess: TOnSynBackgroundTimerProcess; - const aMsg: RawUTF8): boolean; -var found: integer; -begin - result := false; - if (self=nil) or Terminated or not Assigned(aOnProcess) then - exit; - fTaskLock.Lock; - try - found := Find(TMethod(aOnProcess)); - if found>=0 then - with fTask[found] do - result := DeleteRawUTF8(FIFO,FindRawUTF8(FIFO,aMsg)); - finally - fTaskLock.UnLock; - end; -end; - -function TSynBackgroundTimer.Disable(aOnProcess: TOnSynBackgroundTimerProcess): boolean; -var found: integer; -begin - result := false; - if (self=nil) or Terminated or not Assigned(aOnProcess) then - exit; - fTaskLock.Lock; - try - found := Find(TMethod(aOnProcess)); - if found>=0 then begin - fTasks.Delete(found); - result := true; - end; - finally - fTaskLock.UnLock; - end; -end; - -{ TSynParallelProcess } - -constructor TSynParallelProcess.Create(ThreadPoolCount: integer; const ThreadName: RawUTF8; - OnBeforeExecute, OnAfterExecute: TNotifyThreadEvent; - MaxThreadPoolCount: integer); -var i: integer; -begin - inherited Create; - if ThreadPoolCount<0 then - raise ESynParallelProcess.CreateUTF8('%.Create(%,%)',[Self,ThreadPoolCount,ThreadName]); - if ThreadPoolCount>MaxThreadPoolCount then - ThreadPoolCount := MaxThreadPoolCount; - fThreadPoolCount := ThreadPoolCount; - fThreadName := ThreadName; - SetLength(fPool,fThreadPoolCount); - for i := 0 to fThreadPoolCount-1 do - fPool[i] := TSynParallelProcessThread.Create(nil,FormatUTF8('%#%/%', - [fThreadName,i+1,fThreadPoolCount]),OnBeforeExecute,OnAfterExecute); -end; - -destructor TSynParallelProcess.Destroy; -begin - ObjArrayClear(fPool); - inherited; -end; - -procedure TSynParallelProcess.ParallelRunAndWait(const Method: TSynParallelProcessMethod; - MethodCount: integer; const OnMainThreadIdle: TNotifyEvent); -var use,t,n,perthread: integer; - error: RawUTF8; -begin - if (MethodCount<=0) or not Assigned(Method) then - exit; - if not Assigned(OnMainThreadIdle) then - if (self=nil) or (MethodCount=1) or (fThreadPoolCount=0) then begin - Method(0,MethodCount-1); // no need (or impossible) to use background thread - exit; - end; - use := MethodCount; - t := fThreadPoolCount; - if not Assigned(OnMainThreadIdle) then - inc(t); // include current thread - if use>t then - use := t; - try - // start secondary threads - perthread := MethodCount div use; - if perthread=0 then - use := 1; - n := 0; - for t := 0 to use-2 do begin - repeat - case fPool[t].AcquireThread of - flagDestroying: // should not happen - raise ESynParallelProcess.CreateUTF8( - '%.ParallelRunAndWait [%] destroying',[self,fPool[t].fThreadName]); - flagIdle: - break; // acquired (should always be the case) - end; - SleepHiRes(1); - if Assigned(OnMainThreadIdle) then - OnMainThreadIdle(self); - until false; - fPool[t].Start(Method,n,n+perthread-1); - inc(n,perthread); - inc(fParallelRunCount); - end; - // run remaining items in the current/last thread - if n'' then - raise ESynParallelProcess.CreateUTF8('%.ParallelRunAndWait: %',[self,error]); - end; -end; - - -{ TBlockingProcess } - -constructor TBlockingProcess.Create(aTimeOutMs: integer; aSafe: PSynLocker); -begin - inherited Create(nil,false,false,''); - if aTimeOutMs<=0 then - fTimeOutMs := 3000 else // never wait for ever - fTimeOutMs := aTimeOutMs; - fSafe := aSafe; -end; - -constructor TBlockingProcess.Create(aTimeOutMs: integer); -begin - fOwnedSafe := true; - Create(aTimeOutMS,NewSynLocker); -end; - -destructor TBlockingProcess.Destroy; -begin - inherited Destroy; - if fOwnedSafe then - fSafe^.DoneAndFreeMem; -end; - -function TBlockingProcess.WaitFor: TBlockingEvent; -begin - fSafe^.Lock; - try - result := fEvent; - if fEvent in [evRaised,evTimeOut] then - exit; - fEvent := evWaiting; - finally - fSafe^.UnLock; - end; - FixedWaitFor(self,fTimeOutMs); - fSafe^.Lock; - try - if fEvent<>evRaised then - fEvent := evTimeOut; - result := fEvent; - finally - fSafe^.UnLock; - end; -end; - -function TBlockingProcess.WaitFor(TimeOutMS: integer): TBlockingEvent; -begin - if TimeOutMS <= 0 then - fTimeOutMs := 3000 // never wait for ever - else - fTimeOutMs := TimeOutMS; - result := WaitFor; -end; - -function TBlockingProcess.NotifyFinished(alreadyLocked: boolean): boolean; -begin - result := false; - if not alreadyLocked then - fSafe^.Lock; - try - if fEvent in [evRaised,evTimeOut] then - exit; // ignore if already notified - fEvent := evRaised; - SetEvent; // notify caller to unlock "WaitFor" method - result := true; - finally - fSafe^.UnLock; - end; -end; - -procedure TBlockingProcess.ResetInternal; -begin - ResetEvent; - fEvent := evNone; -end; - -function TBlockingProcess.Reset: boolean; -begin - fSafe^.Lock; - try - result := fEvent<>evWaiting; - if result then - ResetInternal; - finally - fSafe^.UnLock; - end; -end; - -procedure TBlockingProcess.Lock; -begin - fSafe^.Lock; -end; - -procedure TBlockingProcess.Unlock; -begin - fSafe^.Unlock; -end; - - -{ TBlockingProcessPoolItem } - -procedure TBlockingProcessPoolItem.ResetInternal; -begin - inherited ResetInternal; // set fEvent := evNone - fCall := 0; -end; - - -{ TBlockingProcessPool } - -constructor TBlockingProcessPool.Create(aClass: TBlockingProcessPoolItemClass); -begin - inherited Create; - if aClass=nil then - fClass := TBlockingProcessPoolItem else - fClass := aClass; - fPool := TSynObjectListLocked.Create; -end; - -const - CALL_DESTROYING = -1; - -destructor TBlockingProcessPool.Destroy; -var i: integer; - someWaiting: boolean; -begin - fCallCounter := CALL_DESTROYING; - someWaiting := false; - for i := 0 to fPool.Count-1 do - with TBlockingProcessPoolItem(fPool.List[i]) do - if Event=evWaiting then begin - SetEvent; // release WaitFor (with evTimeOut) - someWaiting := true; - end; - if someWaiting then - SleepHiRes(10); // propagate the pending evTimeOut to the WaitFor threads - fPool.Free; - inherited; -end; - -function TBlockingProcessPool.NewProcess(aTimeOutMs: integer): TBlockingProcessPoolItem; -var i: integer; - p: ^TBlockingProcessPoolItem; -begin - result := nil; - if fCallCounter=CALL_DESTROYING then - exit; - if aTimeOutMs<=0 then - aTimeOutMs := 3000; // never wait for ever - fPool.Safe.Lock; - try - p := pointer(fPool.List); - for i := 1 to fPool.Count do - if p^.Call=0 then begin - result := p^; // found a non-used entry - result.fTimeOutMs := aTimeOutMS; - break; - end else - inc(p); - if result=nil then begin - result := fClass.Create(aTimeOutMS); - fPool.Add(result); - end; - inc(fCallCounter); // 1,2,3,... - result.fCall := fCallCounter; - finally - fPool.Safe.UnLock; - end; -end; - -function TBlockingProcessPool.FromCall(call: TBlockingProcessPoolCall; - locked: boolean): TBlockingProcessPoolItem; -var i: integer; - p: ^TBlockingProcessPoolItem; -begin - result := nil; - if (fCallCounter=CALL_DESTROYING) or (call<=0) then - exit; - fPool.Safe.Lock; - try - p := pointer(fPool.List); - for i := 1 to fPool.Count do - if p^.Call=call then begin - result := p^; - if locked then - result.Lock; - exit; - end else - inc(p); - finally - fPool.Safe.UnLock; - end; -end; - -{$ifdef KYLIX3} -type - // see http://stackoverflow.com/a/3085509 about this known Kylix bug - TEventHack = class(THandleObject) // should match EXACTLY SyncObjs.pas source! - private - FEvent: TSemaphore; - FManualReset: Boolean; - end; - -function FixedWaitFor(Event: TEvent; Timeout: LongWord): TWaitResult; -var E: TEventHack absolute Event; - procedure SetResult(res: integer); - begin - if res=0 then - result := wrSignaled else - if errno in [EAGAIN,ETIMEDOUT] then - result := wrTimeOut else begin - write(TimeOut,':',errno,' '); - result := wrError; - end; - end; -{.$define USESEMTRYWAIT} -// sem_timedwait() is slower than sem_trywait(), but consuming much less CPU -{$ifdef USESEMTRYWAIT} -var time: timespec; -{$else} -var start,current: Int64; - elapsed: LongWord; -{$endif} -begin - if Timeout=INFINITE then begin - SetResult(sem_wait(E.FEvent)); - exit; - end; - if TimeOut=0 then begin - SetResult(sem_trywait(E.FEvent)); - exit; - end; - {$ifdef USESEMTRYWAIT} - clock_gettime(CLOCK_REALTIME,time); - inc(time.tv_sec,TimeOut div 1000); - inc(time.tv_nsec,(TimeOut mod 1000)*1000000); - while time.tv_nsec>1000000000 do begin - inc(time.tv_sec); - dec(time.tv_nsec,1000000000); - end; - SetResult(sem_timedwait(E.FEvent,time)); - {$else} - start := GetTickCount64; - repeat - if sem_trywait(E.FEvent)=0 then begin - result := wrSignaled; - break; - end; - current := GetTickCount64; - elapsed := current-start; - if elapsed=0 then - usleep(1) else - if elapsed>TimeOut then begin - result := wrTimeOut; - break; - end else - if elapsed<5 then - usleep(50) else - usleep(1000); - until false; - {$endif} - if E.FManualReset then begin - repeat until sem_trywait(E.FEvent)<>0; // reset semaphore state - sem_post(E.FEvent); - end; -end; - -{$else KYLIX3} // original FPC or Windows implementation is OK - -function FixedWaitFor(Event: TEvent; Timeout: LongWord): TWaitResult; -begin - result := Event.WaitFor(TimeOut); -end; - -{$endif KYLIX3} - -procedure FixedWaitForever(Event: TEvent); -begin - FixedWaitFor(Event,INFINITE); -end; - -{$endif LVCL} // LVCL does not implement TEvent - - -{ ************ System Analysis types and classes ************************** } - - -function SystemInfoJson: RawUTF8; -var cpu,mem: RawUTF8; -begin - cpu := TSystemUse.Current(false).HistoryText(0,15,@mem); - with SystemInfo do - result := JSONEncode([ - 'host',ExeVersion.Host,'user',ExeVersion.User,'os',OSVersionText, - 'cpu',CpuInfoText,'bios',BiosInfoText, - {$ifdef MSWINDOWS}{$ifndef CPU64}'wow64',IsWow64,{$endif}{$endif MSWINDOWS} - {$ifdef CPUINTEL}'cpufeatures', LowerCase(ToText(CpuFeatures, ' ')),{$endif} - 'processcpu',cpu,'processmem',mem, - 'freemem',TSynMonitorMemory.FreeAsText, - 'disk',GetDiskPartitionsText(false,true)]); -end; - - -{ TProcessInfo } - -{$ifdef MSWINDOWS} -type - TProcessMemoryCounters = record - cb: DWORD; - PageFaultCount: DWORD; - PeakWorkingSetSize: PtrUInt; - WorkingSetSize: PtrUInt; - QuotaPeakPagedPoolUsage: PtrUInt; - QuotaPagedPoolUsage: PtrUInt; - QuotaPeakNonPagedPoolUsage: PtrUInt; - QuotaNonPagedPoolUsage: PtrUInt; - PagefileUsage: PtrUInt; - PeakPagefileUsage: PtrUInt; - end; -const - PROCESS_QUERY_LIMITED_INFORMATION = $1000; -var - // PROCESS_QUERY_INFORMATION or PROCESS_QUERY_LIMITED_INFORMATION - OpenProcessAccess: DWORD; - // late-binding of Windows version specific API entries - GetSystemTimes: function(var lpIdleTime, lpKernelTime, lpUserTime: TFileTime): BOOL; stdcall; - GetProcessTimes: function(hProcess: THandle; - var lpCreationTime, lpExitTime, lpKernelTime, lpUserTime: TFileTime): BOOL; stdcall; - GetProcessMemoryInfo: function(Process: THandle; - var ppsmemCounters: TProcessMemoryCounters; cb: DWORD): BOOL; stdcall; - EnumProcessModules: function (hProcess: THandle; var lphModule: HMODULE; cb: DWORD; - var lpcbNeeded: DWORD): BOOL; stdcall; - EnumProcesses: function(lpidProcess: PDWORD; cb: DWORD; var cbNeeded: DWORD): BOOL; stdcall; - GetModuleFileNameExW: function(hProcess: THandle; hModule: HMODULE; - lpBaseName: PWideChar; nSize: DWORD): DWORD; stdcall; - // Vista+/WS2008+ (use GetModuleFileNameEx on XP) - QueryFullProcessImageNameW: function(hProcess: THandle; dwFlags: DWORD; - lpExeName: PWideChar; lpdwSize: PDWORD): BOOL; stdcall; - -procedure InitWindowsAPI; -var Kernel, Psapi: THandle; -begin - if OSVersion>=wVista then - OpenProcessAccess := PROCESS_QUERY_LIMITED_INFORMATION else - OpenProcessAccess := PROCESS_QUERY_INFORMATION or PROCESS_VM_READ; - Kernel := GetModuleHandle(kernel32); - @GetSystemTimes := GetProcAddress(Kernel,'GetSystemTimes'); - @GetProcessTimes := GetProcAddress(Kernel,'GetProcessTimes'); - @QueryFullProcessImageNameW := GetProcAddress(Kernel,'QueryFullProcessImageNameW'); - Psapi := LoadLibrary('Psapi.dll'); - if Psapi>=32 then begin - @EnumProcesses := GetProcAddress(Psapi,'EnumProcesses'); - @GetModuleFileNameExW := GetProcAddress(Psapi,'GetModuleFileNameExW'); - @EnumProcessModules := GetProcAddress(Psapi, 'EnumProcessModules'); - @GetProcessMemoryInfo := GetProcAddress(Psapi,'GetProcessMemoryInfo'); - end; -end; - -function EnumAllProcesses(out Count: Cardinal): TCardinalDynArray; -var n: cardinal; -begin - result := nil; - n := 2048; - repeat - SetLength(result, n); - if EnumProcesses(pointer(result), n * 4, Count) then - Count := Count shr 2 else - Count := 0; - if Count < n then begin - if Count = 0 then - result := nil; - exit; - end; - inc(n, 1024); // (very unlikely) too small buffer - until n>8192; -end; - -function EnumProcessName(PID: Cardinal): RawUTF8; -var h: THandle; - len: DWORD; - name: array[0..4095] of WideChar; -begin - result := ''; - if PID = 0 then - exit; - h := OpenProcess(OpenProcessAccess, false, PID); - if h <> 0 then - try - if Assigned(QueryFullProcessImageNameW) then begin - len := high(name); - if QueryFullProcessImageNameW(h, 0, name, @len) then - RawUnicodeToUtf8(name, len, result); - end else - if GetModuleFileNameExW(h,0,name,high(name))<>0 then - RawUnicodeToUtf8(name, StrLenW(name), result); - finally - CloseHandle(h); - end; -end; - -function TProcessInfo.Init: boolean; -begin - FillCharFast(self,SizeOf(self),0); - result := Assigned(GetSystemTimes) and Assigned(GetProcessTimes) and - Assigned(GetProcessMemoryInfo); // no monitoring API under oldest Windows -end; - -function TProcessInfo.Start: boolean; -var ftidl,ftkrn,ftusr: TFileTime; - sidl,skrn,susr: Int64; -begin - result := Assigned(GetSystemTimes) and GetSystemTimes(ftidl,ftkrn,ftusr); - if not result then - exit; - FileTimeToInt64(ftidl,sidl); - FileTimeToInt64(ftkrn,skrn); - FileTimeToInt64(ftusr,susr); - fDiffIdle := sidl-fSysPrevIdle; - fDiffKernel := skrn-fSysPrevKernel; - fDiffUser := susr-fSysPrevUser; - fDiffTotal := fDiffKernel+fDiffUser; // kernel time also includes idle time - dec(fDiffKernel, fDiffIdle); - fSysPrevIdle := sidl; - fSysPrevKernel := skrn; - fSysPrevUser := susr; -end; - -function TProcessInfo.PerProcess(PID: cardinal; Now: PDateTime; - out Data: TSystemUseData; var PrevKernel, PrevUser: Int64): boolean; -var - h: THandle; - ftkrn,ftusr,ftp,fte: TFileTime; - pkrn,pusr: Int64; - mem: TProcessMemoryCounters; -begin - result := false; - FillCharFast(Data,SizeOf(Data),0); - h := OpenProcess(OpenProcessAccess,false,PID); - if h<>0 then - try - if GetProcessTimes(h,ftp,fte,ftkrn,ftusr) then begin - if Now<>nil then - Data.Timestamp := Now^; - FileTimeToInt64(ftkrn,pkrn); - FileTimeToInt64(ftusr,pusr); - if (PrevKernel<>0) and (fDiffTotal>0) then begin - Data.Kernel := ((pkrn-PrevKernel)*100)/fDiffTotal; - Data.User := ((pusr-PrevUser)*100)/fDiffTotal; - end; - PrevKernel := pkrn; - PrevUser := pusr; - FillCharFast(mem,SizeOf(mem),0); - mem.cb := SizeOf(mem); - if GetProcessMemoryInfo(h,mem,SizeOf(mem)) then begin - Data.WorkKB := mem.WorkingSetSize shr 10; - Data.VirtualKB := mem.PagefileUsage shr 10; - end; - result := true; - end; - finally - CloseHandle(h); - end; -end; - -function TProcessInfo.PerSystem(out Idle,Kernel,User: currency): boolean; -begin - if fDiffTotal<=0 then begin - Idle := 0; - Kernel := 0; - User := 0; - result := false; - end else begin - Kernel := SimpleRoundTo2Digits((fDiffKernel*100)/fDiffTotal); - User := SimpleRoundTo2Digits((fDiffUser*100)/fDiffTotal); - Idle := 100-Kernel-User; // ensure sum is always 100% - result := true; - end; -end; -{$else} // not implemented yet (use /proc ?) -function TProcessInfo.Init: boolean; -begin - FillCharFast(self,SizeOf(self),0); - result := false; -end; - -function TProcessInfo.Start: boolean; -begin - result := false; -end; - -function TProcessInfo.PerProcess(PID: cardinal; Now: PDateTime; - out Data: TSystemUseData; var PrevKernel, PrevUser: Int64): boolean; -begin - result := false; -end; - -function TProcessInfo.PerSystem(out Idle,Kernel,User: currency): boolean; -var P: PUTF8Char; - U, K, I, S: cardinal; -begin // see http://www.linuxhowtos.org/System/procstat.htm - result := false; - P := pointer(StringFromFile('/proc/stat', {nosize=}true)); - if P=nil then - exit; - U := GetNextItemCardinal(P,' '){=user}+GetNextItemCardinal(P,' '){=nice}; - K := GetNextItemCardinal(P,' '){=system}; - I := GetNextItemCardinal(P,' '){=idle}; - S := U+K+I; - Kernel := SimpleRoundTo2Digits((K*100)/S); - User := SimpleRoundTo2Digits((U*100)/S); - Idle := 100-Kernel-User; // ensure sum is always 100% - result := S<>0; -end; { TODO : use a diff approach for TProcessInfo.PerSystem on Linux } -{$endif MSWINDOWS} - - -{ TSystemUse } - -procedure TSystemUse.BackgroundExecute(Sender: TSynBackgroundTimer; - Event: TWaitResult; const Msg: RawUTF8); -var i: integer; - now: TDateTime; -begin - if (fProcess=nil) or (fHistoryDepth=0) or not fProcessInfo.Start then - exit; - fTimer := Sender; - now := NowUTC; - fSafe.Lock; - try - inc(fDataIndex); - if fDataIndex>=fHistoryDepth then - fDataIndex := 0; - for i := high(fProcess) downto 0 do // backwards for fProcesses.Delete(i) - with fProcess[i] do - if fProcessInfo.PerProcess(ID,@now,Data[fDataIndex],PrevKernel,PrevUser) then begin - if Assigned(fOnMeasured) then - fOnMeasured(ID,Data[fDataIndex]); - end else - if UnsubscribeProcessOnAccessError then - // if GetLastError=ERROR_INVALID_PARAMETER then - fProcesses.Delete(i); - finally - fSafe.UnLock; - end; -end; - -procedure TSystemUse.OnTimerExecute(Sender: TObject); -begin - BackgroundExecute(nil,wrSignaled,''); -end; - -constructor TSystemUse.Create(const aProcessID: array of integer; - aHistoryDepth: integer); -var i: integer; -begin - inherited Create; - fProcesses.Init(TypeInfo(TSystemUseProcessDynArray),fProcess); - {$ifdef MSWINDOWS} - if not Assigned(GetSystemTimes) or not Assigned(GetProcessTimes) or - not Assigned(GetProcessMemoryInfo) then - exit; // no system monitoring API under oldest Windows - {$else} - exit; // not implemented yet - {$endif} - if aHistoryDepth<=0 then - aHistoryDepth := 1; - fHistoryDepth := aHistoryDepth; - SetLength(fProcess,length(aProcessID)); - for i := 0 to high(aProcessID) do begin - {$ifdef MSWINDOWS} - if aProcessID[i]=0 then - fProcess[i].ID := GetCurrentProcessID else - {$endif} - fProcess[i].ID := aProcessID[i]; - SetLength(fProcess[i].Data,fHistoryDepth); - end; -end; - -constructor TSystemUse.Create(aHistoryDepth: integer); -begin - Create([0],aHistoryDepth); -end; - -procedure TSystemUse.Subscribe(aProcessID: integer); -var i,n: integer; -begin - if self=nil then - exit; - {$ifdef MSWINDOWS} - if aProcessID=0 then - aProcessID := GetCurrentProcessID; - {$endif} - fSafe.Lock; - try - n := length(fProcess); - for i := 0 to n-1 do - if fProcess[i].ID=aProcessID then - exit; // already subscribed - SetLength(fProcess,n+1); - fProcess[n].ID := aProcessID; - SetLength(fProcess[n].Data,fHistoryDepth); - finally - fSafe.UnLock; - end; -end; - -function TSystemUse.Unsubscribe(aProcessID: integer): boolean; -var i: integer; -begin - result := false; - if self=nil then - exit; - fSafe.Lock; - try - i := ProcessIndex(aProcessID); - if i>=0 then begin - fProcesses.Delete(i); - result := true; - end; - finally - fSafe.UnLock; - end; -end; - -function TSystemUse.ProcessIndex(aProcessID: integer): integer; -begin // caller should have made fSafe.Enter - {$ifdef MSWINDOWS} - if aProcessID=0 then - aProcessID := GetCurrentProcessID; - {$endif} - if self<>nil then - for result := 0 to high(fProcess) do - if fProcess[result].ID=aProcessID then - exit; - result := -1; -end; - -function TSystemUse.Data(out aData: TSystemUseData; aProcessID: integer=0): boolean; -var i: integer; -begin - result := false; - if self<>nil then begin - fSafe.Lock; - try - i := ProcessIndex(aProcessID); - if i>=0 then begin - with fProcess[i] do - aData := Data[fDataIndex]; - result := aData.Timestamp<>0; - if result then - exit; - end; - finally - fSafe.UnLock; - end; - end; - FillCharFast(aData,SizeOf(aData),0); -end; - -function TSystemUse.Data(aProcessID: integer): TSystemUseData; -begin - Data(result,aProcessID); -end; - -function TSystemUse.KB(aProcessID: integer=0): cardinal; -begin - with Data(aProcessID) do - result := WorkKB+VirtualKB; -end; - -function TSystemUse.Percent(aProcessID: integer): single; -begin - with Data(aProcessID) do - result := Kernel+User; -end; - -function TSystemUse.PercentKernel(aProcessID: integer): single; -begin - result := Data(aProcessID).Kernel; -end; - -function TSystemUse.PercentUser(aProcessID: integer): single; -begin - result := Data(aProcessID).User; -end; - -function TSystemUse.PercentSystem(out Idle,Kernel,User: currency): boolean; -begin - result := fProcessInfo.PerSystem(Idle,Kernel,User); -end; - -function TSystemUse.HistoryData(aProcessID,aDepth: integer): TSystemUseDataDynArray; -var i,n,last: integer; -begin - result := nil; - if self=nil then - exit; - fSafe.Lock; - try - i := ProcessIndex(aProcessID); - if i>=0 then - with fProcess[i] do begin - n := length(Data); - last := n-1; - if (aDepth>0) and (n>aDepth) then - n := aDepth; - SetLength(result,n); // make ordered copy - for i := 0 to n-1 do begin - if i<=fDataIndex then - result[i] := Data[fDataIndex-i] else begin - result[i] := Data[last]; - dec(last); - end; - if PInt64(@result[i].Timestamp)^=0 then begin - SetLength(result,i); // truncate to latest available sample - break; - end; - end; - end; - finally - fSafe.UnLock; - end; -end; - -function TSystemUse.History(aProcessID,aDepth: integer): TSingleDynArray; -var i,n: integer; - data: TSystemUseDataDynArray; -begin - result := nil; - data := HistoryData(aProcessID,aDepth); - n := length(data); - SetLength(result,n); - for i := 0 to n-1 do - result[i] := data[i].Kernel+data[i].User; -end; - -class function TSystemUse.Current(aCreateIfNone: boolean): TSystemUse; -begin - if (ProcessSystemUse=nil) and aCreateIfNone then - GarbageCollectorFreeAndNil(ProcessSystemUse,TSystemUse.Create(60)); - result := ProcessSystemUse; -end; - -function TSystemUse.HistoryText(aProcessID,aDepth: integer; - aDestMemoryMB: PRawUTF8): RawUTF8; -var data: TSystemUseDataDynArray; - mem: RawUTF8; - i: integer; -begin - result := ''; - data := HistoryData(aProcessID,aDepth); - {$ifdef LINUXNOTBSD} // bsd: see VM_LOADAVG - // https://www.retro11.de/ouxr/211bsd/usr/src/lib/libc/gen/getloadavg.c.html - if data = nil then - result := StringFromFile('/proc/loadavg',{HasNoSize=}true) else - {$endif LINUXNOTBSD} - for i := 0 to high(data) do - with data[i] do begin - result := FormatUTF8('%% ',[result,TruncTo2Digits(Kernel+User)]); - if aDestMemoryMB<>nil then - mem := FormatUTF8('%% ',[mem,TruncTo2Digits(WorkKB/1024)]); - end; - result := trim(result); - if aDestMemoryMB<>nil then - aDestMemoryMB^ := trim(mem); -end; - -{$ifndef NOVARIANTS} - -function TSystemUse.HistoryVariant(aProcessID,aDepth: integer): variant; -var res: TDocVariantData absolute result; - data: TSystemUseDataDynArray; - i: integer; -begin - VarClear(result); - data := HistoryData(aProcessID,aDepth); - res.InitFast(length(data),dvArray); - for i := 0 to high(data) do - res.AddItem(TruncTo2Digits(data[i].Kernel+data[i].User)); -end; - -{$endif NOVARIANTS} - -function SortDynArrayDiskPartitions(const A,B): integer; -begin - result := SortDynArrayString(TDiskPartition(A).mounted,TDiskPartition(B).mounted); -end; - -function GetDiskPartitions: TDiskPartitions; -{$ifdef MSWINDOWS} // DeviceIoControl(IOCTL_DISK_GET_PARTITION_INFO) requires root -var drives, drive, m, n: integer; - fn, volume: TFileName; -{$else} -var mounts, fs, mnt, typ: RawUTF8; - p: PUTF8Char; - fn: TFileName; - n: integer; -{$endif} - av, fr, tot: QWord; -begin - result := nil; - n := 0; -{$ifdef MSWINDOWS} - fn := '#:\'; - drives := GetLogicalDrives; - m := 1 shl 2; - for drive := 3 to 26 do begin // retrieve partitions mounted as C..Z drives - if drives and m <> 0 then begin - fn[1] := char(64+drive); - if GetDiskInfo(fn,av,fr,tot,@volume) then begin - SetLength(result,n+1); - StringToUTF8(volume,result[n].name); - volume := ''; - result[n].mounted := fn; - result[n].size := tot; - inc(n); - end; - end; - m := m shl 1; - end; -{$else} // see https://github.com/gagern/gnulib/blob/master/lib/mountlist.c - mounts := StringFromFile({$ifdef BSD}'/etc/mtab'{$else}'/proc/self/mounts'{$endif}, - {hasnosize=}true); - p := pointer(mounts); - repeat - fs := ''; - mnt := ''; - typ := ''; - ScanUTF8(GetNextLine(p,p),'%S %S %S',[@fs,@mnt,@typ]); - if (fs<>'') and (fs<>'rootfs') and (IdemPCharArray(pointer(fs),['/DEV/LOOP'])<0) and - (mnt<>'') and (mnt<>'/mnt') and (typ<>'') and - (IdemPCharArray(pointer(mnt),['/PROC/','/SYS/','/RUN/'])<0) and - (FindPropName(['autofs','proc','subfs','debugfs','devpts','fusectl','mqueue', - 'rpc-pipefs','sysfs','devfs','kernfs','ignore','none','tmpfs','securityfs', - 'ramfs','rootfs','devtmpfs','hugetlbfs','iso9660'],typ)<0) then begin - fn := UTF8ToString(mnt); - if GetDiskInfo(fn,av,fr,tot) and (tot>1 shl 20) then begin - //writeln('fs=',fs,' mnt=',mnt,' typ=',typ, ' av=',KB(av),' fr=',KB(fr),' tot=',KB(tot)); - SetLength(result,n+1); - result[n].name := fs; - result[n].mounted := fn; - result[n].size := tot; - inc(n); - end; - end; - until p=nil; - DynArray(TypeInfo(TDiskPartitions),result).Sort(SortDynArrayDiskPartitions); - {$endif} -end; - -var - _DiskPartitions: TDiskPartitions; - -function GetDiskPartitionsText(nocache, withfreespace, nospace: boolean): RawUTF8; -const F: array[boolean] of RawUTF8 = ({$ifdef MSWINDOWS}'%: % (% / %)', '%: % (%/%)' - {$else}'% % (% / %)', '% % (%/%)'{$endif}); -var i: integer; - parts: TDiskPartitions; - function GetInfo(var p: TDiskPartition): shortstring; - var av, fr, tot: QWord; - begin - if not withfreespace or not GetDiskInfo(p.mounted,av,fr,tot) then - {$ifdef MSWINDOWS} - FormatShort('%: % (%)',[p.mounted[1],p.name,KB(p.size,nospace)],result) else - FormatShort(F[nospace],[p.mounted[1],p.name,KB(fr,nospace),KB(tot,nospace)],result); - {$else} - FormatShort('% % (%)',[p.mounted,p.name,KB(p.size,nospace)],result) else - FormatShort(F[nospace],[p.mounted,p.name,KB(fr,nospace),KB(tot,nospace)],result); - {$endif} - end; -begin - if (_DiskPartitions=nil) or nocache then - _DiskPartitions := GetDiskPartitions; - parts := _DiskPartitions; - if parts=nil then - result := '' else - ShortStringToAnsi7String(GetInfo(parts[0]),result); - for i := 1 to high(parts) do - result := FormatUTF8('%, %',[result,GetInfo(parts[i])]); -end; - -{ TSynMonitorMemory } - -constructor TSynMonitorMemory.Create(aTextNoSpace: boolean); -begin - FAllocatedUsed := TSynMonitorOneSize.Create(aTextNoSpace); - FAllocatedReserved := TSynMonitorOneSize.Create(aTextNoSpace); - FPhysicalMemoryFree := TSynMonitorOneSize.Create(aTextNoSpace); - FVirtualMemoryFree := TSynMonitorOneSize.Create(aTextNoSpace); - FPagingFileTotal := TSynMonitorOneSize.Create(aTextNoSpace); - FPhysicalMemoryTotal := TSynMonitorOneSize.Create(aTextNoSpace); - FVirtualMemoryTotal := TSynMonitorOneSize.Create(aTextNoSpace); - FPagingFileFree := TSynMonitorOneSize.Create(aTextNoSpace); -end; - -destructor TSynMonitorMemory.Destroy; -begin - FAllocatedReserved.Free; - FAllocatedUsed.Free; - FPhysicalMemoryFree.Free; - FVirtualMemoryFree.Free; - FPagingFileTotal.Free; - FPhysicalMemoryTotal.Free; - FVirtualMemoryTotal.Free; - FPagingFileFree.Free; - inherited Destroy; -end; - -class function TSynMonitorMemory.FreeAsText(nospace: boolean): ShortString; -const F: array[boolean] of RawUTF8 = ('% / %', '%/%'); -begin - with TSynMonitorMemory.Create(nospace) do - try - RetrieveMemoryInfo; - FormatShort(F[nospace],[fPhysicalMemoryFree.Text,fPhysicalMemoryTotal.Text],result); - finally - Free; - end; -end; - -var - PhysicalAsTextCache: TShort16; // this value doesn't change usually - -class function TSynMonitorMemory.PhysicalAsText(nospace: boolean): TShort16; -begin - if PhysicalAsTextCache='' then - with TSynMonitorMemory.Create(nospace) do - try - PhysicalAsTextCache := PhysicalMemoryTotal.Text; - finally - Free; - end; - result := PhysicalAsTextCache; -end; - -class function TSynMonitorMemory.ToJSON: RawUTF8; -begin - with TSynMonitorMemory.Create(false) do - try - RetrieveMemoryInfo; - FormatUTF8('{Allocated:{reserved:%,used:%},Physical:{total:%,free:%,percent:%},'+ - {$ifdef MSWINDOWS}'Virtual:{total:%,free:%},'+{$endif}'Paged:{total:%,free:%}}', - [fAllocatedReserved.Bytes shr 10,fAllocatedUsed.Bytes shr 10, - fPhysicalMemoryTotal.Bytes shr 10,fPhysicalMemoryFree.Bytes shr 10, fMemoryLoadPercent, - {$ifdef MSWINDOWS}fVirtualMemoryTotal.Bytes shr 10,fVirtualMemoryFree.Bytes shr 10,{$endif} - fPagingFileTotal.Bytes shr 10,fPagingFileFree.Bytes shr 10],result); - finally - Free; - end; -end; - -{$ifndef NOVARIANTS} -class function TSynMonitorMemory.ToVariant: variant; -begin - result := _JsonFast(ToJSON); -end; -{$endif} - -function TSynMonitorMemory.GetAllocatedUsed: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FAllocatedUsed; -end; - -function TSynMonitorMemory.GetAllocatedReserved: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FAllocatedReserved; -end; - -function TSynMonitorMemory.GetMemoryLoadPercent: integer; -begin - RetrieveMemoryInfo; - result := FMemoryLoadPercent; -end; - -function TSynMonitorMemory.GetPagingFileFree: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FPagingFileFree; -end; - -function TSynMonitorMemory.GetPagingFileTotal: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FPagingFileTotal; -end; - -function TSynMonitorMemory.GetPhysicalMemoryFree: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FPhysicalMemoryFree; -end; - -function TSynMonitorMemory.GetPhysicalMemoryTotal: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FPhysicalMemoryTotal; -end; - -function TSynMonitorMemory.GetVirtualMemoryFree: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FVirtualMemoryFree; -end; - -function TSynMonitorMemory.GetVirtualMemoryTotal: TSynMonitorOneSize; -begin - RetrieveMemoryInfo; - result := FVirtualMemoryTotal; -end; - -{$ifdef MSWINDOWS} -{$ifndef UNICODE} // missing API for oldest Delphi -type - DWORDLONG = Int64; - TMemoryStatusEx = record - dwLength: DWORD; - dwMemoryLoad: DWORD; - ullTotalPhys: DWORDLONG; - ullAvailPhys: DWORDLONG; - ullTotalPageFile: DWORDLONG; - ullAvailPageFile: DWORDLONG; - ullTotalVirtual: DWORDLONG; - ullAvailVirtual: DWORDLONG; - ullAvailExtendedVirtual: DWORDLONG; - end; - -// information about the system's current usage of both physical and virtual memory -function GlobalMemoryStatusEx(var lpBuffer: TMemoryStatusEx): BOOL; - stdcall; external kernel32; -{$endif} -{$endif} - -function GetMemoryInfo(out info: TMemoryInfo; withalloc: boolean): boolean; -{$ifdef WITH_FASTMM4STATS} -var Heap: TMemoryManagerState; - sb: integer; -{$endif} -{$ifdef MSWINDOWS} -var global: TMemoryStatusEx; - {$ifdef FPC}mem: TProcessMemoryCounters;{$endif} -begin - FillCharFast(global,SizeOf(global),0); - global.dwLength := SizeOf(global); - result := GlobalMemoryStatusEx(global); - info.percent := global.dwMemoryLoad; - info.memtotal := global.ullTotalPhys; - info.memfree := global.ullAvailPhys; - info.filetotal := global.ullTotalPageFile; - info.filefree := global.ullAvailPageFile; - info.vmtotal := global.ullTotalVirtual; - info.vmfree := global.ullAvailVirtual; - {$ifdef FPC} // GetHeapStatus is only about current thread -> use WinAPI - if withalloc and Assigned(GetProcessMemoryInfo) then begin - FillcharFast(mem,SizeOf(mem),0); - mem.cb := SizeOf(mem); - GetProcessMemoryInfo(GetCurrentProcess,mem,SizeOf(mem)); - info.allocreserved := mem.PeakWorkingSetSize; - info.allocused := mem.WorkingSetSize; - end; - {$endif FPC} -{$else} -{$ifdef BSD} -begin - FillCharFast(info,SizeOf(info),0); - info.memtotal := fpsysctlhwint({$ifdef DARWIN}HW_MEMSIZE{$else}HW_PHYSMEM{$endif}); - info.memfree := info.memtotal-fpsysctlhwint(HW_USERMEM); - if info.memtotal<>0 then // avoid div per 0 exception - info.percent := ((info.memtotal-info.memfree)*100)div info.memtotal; -{$else} -var si: TSysInfo; // Linuxism - P: PUTF8Char; - {$ifdef FPC}mu: cardinal{$else}const mu=1{$endif}; -begin - FillCharFast(info,SizeOf(info),0); - {$ifdef FPC} - result := SysInfo(@si)=0; - mu := si.mem_unit; - {$else} - result := SysInfo(si)=0; // some missing fields in Kylix' Libc - {$endif} - if si.totalram<>0 then // avoid div per 0 exception - info.percent := ((si.totalram-si.freeram)*100)div si.totalram; - info.memtotal := si.totalram*mu; - info.memfree := si.freeram*mu; - info.filetotal := si.totalswap*mu; - info.filefree := si.freeswap*mu; - if withalloc then begin - // virtual memory information is not available under Linux - P := pointer(StringFromFile('/proc/self/statm',{hasnosize=}true)); - info.allocreserved := GetNextItemCardinal(P,' ')*SystemInfo.dwPageSize; // VmSize - info.allocused := GetNextItemCardinal(P,' ')*SystemInfo.dwPageSize; // VmRSS - end; - // GetHeapStatus is only about current thread -> use /proc/[pid]/statm -{$endif BSD} -{$endif MSWINDOWS} -{$ifdef WITH_FASTMM4STATS} // override OS information by actual FastMM4 - if withalloc then begin - GetMemoryManagerState(Heap); // direct raw FastMM4 access - info.allocused := Heap.TotalAllocatedMediumBlockSize+Heap.TotalAllocatedLargeBlockSize; - info.allocreserved := Heap.ReservedMediumBlockAddressSpace+Heap.ReservedLargeBlockAddressSpace; - for sb := 0 to high(Heap.SmallBlockTypeStates) do - with Heap.SmallBlockTypeStates[sb] do begin - inc(info.allocused,UseableBlockSize*AllocatedBlockCount); - inc(info.allocreserved,ReservedAddressSpace); - end; - end; -{$endif WITH_FASTMM4STATS} -end; - -procedure TSynMonitorMemory.RetrieveMemoryInfo; -var tix: cardinal; - info: TMemoryInfo; -begin - tix := GetTickCount64 shr 7; // allow 128 ms resolution for updates - if fLastMemoryInfoRetrievedTix<>tix then begin - fLastMemoryInfoRetrievedTix := tix; - if not GetMemoryInfo(info,{withalloc=}true) then - exit; - FMemoryLoadPercent := info.percent; - FPhysicalMemoryTotal.Bytes := info.memtotal; - FPhysicalMemoryFree.Bytes := info.memfree; - FPagingFileTotal.Bytes := info.filetotal; - FPagingFileFree.Bytes := info.filefree; - FVirtualMemoryTotal.Bytes := info.vmtotal; - FVirtualMemoryFree.Bytes := info.vmfree; - FAllocatedReserved.Bytes := info.allocreserved; - FAllocatedUsed.Bytes := info.allocused; - end; -end; - - -{ TSynMonitorDisk } - -constructor TSynMonitorDisk.Create; -begin - fAvailableSize := TSynMonitorOneSize.Create({nospace=}false); - fFreeSize := TSynMonitorOneSize.Create({nospace=}false); - fTotalSize := TSynMonitorOneSize.Create({nospace=}false); -end; - -destructor TSynMonitorDisk.Destroy; -begin - fAvailableSize.Free; - fFreeSize.Free; - fTotalSize.Free; - inherited; -end; - -function TSynMonitorDisk.GetName: TFileName; -begin - RetrieveDiskInfo; - result := fName; -end; - -function TSynMonitorDisk.GetAvailable: TSynMonitorOneSize; -begin - RetrieveDiskInfo; - result := fAvailableSize; -end; - -function TSynMonitorDisk.GetFree: TSynMonitorOneSize; -begin - RetrieveDiskInfo; - result := fFreeSize; -end; - -function TSynMonitorDisk.GetTotal: TSynMonitorOneSize; -begin - RetrieveDiskInfo; - result := fTotalSize; -end; - -class function TSynMonitorDisk.FreeAsText: RawUTF8; -var name: TFileName; - avail,free,total: QWord; -begin - GetDiskInfo(name,avail,free,total); - FormatUTF8('% % / %',[name, KB(free),KB(total)],result); -end; - -{$ifdef MSWINDOWS} -function GetDiskFreeSpaceExA(lpDirectoryName: PAnsiChar; - var lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes, - lpTotalNumberOfFreeBytes: QWord): LongBool; stdcall; external kernel32; -function GetDiskFreeSpaceExW(lpDirectoryName: PWideChar; - var lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes, - lpTotalNumberOfFreeBytes: QWord): LongBool; stdcall; external kernel32; -function DeviceIoControl(hDevice: THandle; dwIoControlCode: DWORD; lpInBuffer: Pointer; - nInBufferSize: DWORD; lpOutBuffer: Pointer; nOutBufferSize: DWORD; - var lpBytesReturned: DWORD; lpOverlapped: POverlapped): BOOL; stdcall; external kernel32; -{$endif} - -function GetDiskInfo(var aDriveFolderOrFile: TFileName; - out aAvailableBytes, aFreeBytes, aTotalBytes: QWord - {$ifdef MSWINDOWS}; aVolumeName: PFileName = nil{$endif}): boolean; -{$ifdef MSWINDOWS} -var tmp: array[0..MAX_PATH-1] of Char; - dummy,flags: DWORD; - dn: TFileName; -begin - if aDriveFolderOrFile='' then - aDriveFolderOrFile := SysUtils.UpperCase(ExtractFileDrive(ExeVersion.ProgramFilePath)); - dn := aDriveFolderOrFile; - if (dn<>'') and (dn[2]=':') and (dn[3]=#0) then - dn := dn+'\'; - if (aVolumeName<>nil) and (aVolumeName^='') then begin - tmp[0] := #0; - GetVolumeInformation(pointer(dn),tmp,MAX_PATH,nil,dummy,flags,nil,0); - aVolumeName^ := tmp; - end; - result := {$ifdef UNICODE}GetDiskFreeSpaceExW{$else}GetDiskFreeSpaceExA{$endif}( - pointer(dn),aAvailableBytes,aTotalBytes,aFreeBytes); -{$else} -{$ifdef KYLIX3} -var fs: TStatFs64; - h: THandle; -begin - if aDriveFolderOrFile='' then - aDriveFolderOrFile := '.'; - h := FileOpen(aDriveFolderOrFile,fmShareDenyNone); - result := fstatfs64(h,fs)=0; - FileClose(h); - aAvailableBytes := fs.f_bavail*fs.f_bsize; - aFreeBytes := aAvailableBytes; - aTotalBytes := fs.f_blocks*fs.f_bsize; -{$endif} -{$ifdef FPC} -var fs: tstatfs; -begin - if aDriveFolderOrFile='' then - aDriveFolderOrFile := '.'; - result := fpStatFS(aDriveFolderOrFile,@fs)=0; - aAvailableBytes := QWord(fs.bavail)*QWord(fs.bsize); - aFreeBytes := aAvailableBytes; // no user Quota involved here - aTotalBytes := QWord(fs.blocks)*QWord(fs.bsize); -{$endif FPC} -{$endif MSWINDOWS} -end; - -procedure TSynMonitorDisk.RetrieveDiskInfo; -var tix: cardinal; -begin - tix := GetTickCount64 shr 7; // allow 128 ms resolution for updates - if fLastDiskInfoRetrievedTix<>tix then begin - fLastDiskInfoRetrievedTix := tix; - GetDiskInfo(fName,PQWord(@fAvailableSize.Bytes)^,PQWord(@fFreeSize.Bytes)^, - PQWord(@fTotalSize.Bytes)^{$ifdef MSWINDOWS},@fVolumeName{$endif}); - end; -end; - - -{ TTimeZoneData } - -function TTimeZoneData.GetTziFor(year: integer): PTimeZoneInfo; -var i,last: PtrInt; -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} -procedure TSynTimeZone.LoadFromRegistry; -const REGKEY = 'Software\Microsoft\Windows NT\CurrentVersion\Time Zones\'; -var reg: TWinRegistry; - keys: TRawUTF8DynArray; - i,first,last,year,n: integer; - itemsize: DWORD; - item: TTimeZoneData; -begin - fZones.Clear; - if reg.ReadOpen(HKEY_LOCAL_MACHINE,REGKEY) then - keys := reg.ReadEnumEntries else - keys := nil; // make Delphi 6 happy - n := length(keys); - fZones.Capacity := n; - for i := 0 to n-1 do begin - Finalize(item); - FillcharFast(item.tzi,SizeOf(item.tzi),0); - if reg.ReadOpen(HKEY_LOCAL_MACHINE,REGKEY+keys[i],true) then begin - item.id := keys[i]; - item.Display := reg.ReadString('Display'); - itemsize := SizeOf(item.tzi); - RegQueryValueExW(reg.key,'TZI',nil,nil,@item.tzi,@itemsize); - if reg.ReadOpen(HKEY_LOCAL_MACHINE,REGKEY+keys[i]+'\Dynamic DST',true) then begin - // warning: never defined on XP/2003, and not for all entries - first := reg.ReadDword('FirstEntry'); - last := reg.ReadDword('LastEntry'); - if (first>0) and (last>=first) then begin - n := 0; - SetLength(item.dyn,last-first+1); - for year := first to last do begin - itemsize := SizeOf(TTimeZoneInfo); - if RegQueryValueExA(reg.key,pointer(UInt32ToUTF8(year)),nil,nil, - @item.dyn[n].tzi,@itemsize)=0 then begin - item.dyn[n].year := year; - inc(n); - end; - end; - SetLength(item.dyn,n); - end; - end; - fZones.Add(item); - end; - end; - reg.Close; - fZones.ReHash; - FreeAndNil(fIds); - FreeAndNil(fDisplays); -end; -{$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 - if TzID='UTC' then // e.g. on XP - result := TzID else - result := '' else - result := fZone[ndx].display; -end; - -function TSynTimeZone.GetBiasForDateTime(const Value: TDateTime; - const TzId: TTimeZoneID; out Bias: integer; out HaveDaylight: boolean; - DateIsUTC: boolean): boolean; -var ndx: integer; - d: TSynSystemTime; - 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 := TzID='UTC'; // e.g. on XP - exit; - end; - d.FromDate(Value); // faster than DecodeDate - tzi := fZone[ndx].GetTziFor(d.Year); - 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(d.Year); - dlt := tzi.change_time_dlt.EncodeForTimeChange(d.Year); - if DateIsUTC then begin // std shifts by the DST bias, dst by STD - std := ((std*MinsPerDay)+tzi.Bias+tzi.bias_dlt)/MinsPerDay; - dlt := ((dlt*MinsPerDay)+tzi.Bias+tzi.bias_std)/MinsPerDay; - end; - if std' ' do inc(P); - W.AddShort(''); - W.AddHtmlEscape(B,P-B); - W.AddShort(''); -end; - -function TTextWriterEscape.ProcessLink: boolean; -begin - inc(P); - B2 := P; - while not (P^ in [#0,']']) do inc(P); - P2 := P; - if PWord(P)^=ord(']')+ord('(')shl 8 then begin - inc(P,2); - B := P; - while not (P^ in [#0,')']) do inc(P); - if P^=')' then begin // [GitHub](https://github.com) - result := true; - exit; - end; - end; - P := B2; // rollback - result := false; -end; - -procedure TTextWriterEscape.ProcessEmoji; -begin - if heEmojiToUTF8 in esc then - EmojiParseDots(P,W) else begin - W.Add(':'); - inc(P); - end; -end; - -procedure TTextWriterEscape.Toggle(style: TTextWriterEscapeStyle); -const HTML: array[tweBold..tweCode] of string[7] = ('strong>','em>','code>'); -begin - W.Add('<'); - if style in st then begin - W.Add('/'); - exclude(st,style); - end else - include(st,style); - W.AddShort(HTML[style]); -end; - -procedure TTextWriterEscape.EndOfParagraph; -begin - if tweBold in st then - Toggle(tweBold); - if tweItalic in st then - Toggle(tweItalic); - if P<>nil then - if PWord(P)^=$0a0d then - inc(P,2) else - inc(P); -end; - -procedure TTextWriterEscape.SetLine(style: TTextWriterEscapeLineStyle); -const HTML: array[twlParagraph..twlCode3] of string[5] = ('p>','li>','li>','p>','code>','code>'); - HTML2: array[twlOrderedList..twlCode3] of string[11] = ('ol>','ul>','blockquote>','pre>','pre>'); -begin - if lst>=low(HTML) then begin - if (lststyle) then begin - W.Add('<','/'); - W.AddShort(HTML[lst]); - end; - if (lst>=low(HTML2)) and (lst<>style) then begin - W.Add('<','/'); - W.AddShort(HTML2[lst]); - end; - end; - if style>=low(HTML) then begin - if (style>=low(HTML2)) and (lst<>style) then begin - W.Add('<'); - W.AddShort(HTML2[style]); - end; - if (stylestyle) then begin - W.Add('<'); - W.AddShort(HTML[style]); - end; - end; - lst := style; -end; - -procedure TTextWriterEscape.NewMarkdownLine; -label none; -var c: cardinal; -begin - if P=nil then - exit; - c := PCardinal(P)^; - if c and $ffffff=ord('`')+ord('`')shl 8+ord('`')shl 16 then begin - inc(P,3); - if lst=twlCode3 then begin - lst := twlCode4; // to close - NewMarkdownLine; - exit; - end; - SetLine(twlCode3); - end; - if lst=twlCode3 then - exit; // no prefix process within ``` code blocks - if c=$20202020 then begin - SetLine(twlCode4); - inc(P,4); - exit; - end; - P := GotoNextNotSpaceSameLine(P); // don't implement nested levels yet - case P^ of - '*','+','-': - if P[1]=' ' then - SetLine(twlUnorderedList) else - goto none; - '1'..'9': begin // first should be 1. then any ##. number to continue - B := P; - repeat inc(P) until not (P^ in ['0'..'9']); - if (P^='.') and ((lst=twlOrderedList) or (PWord(B)^=ord('1')+ord('.')shl 8)) then - SetLine(twlOrderedList) else begin - P := B; -none: if lst=twlParagraph then begin - c := PWord(P)^; // detect blank line to separate paragraphs - if c=$0a0d then - inc(P,2) else - if c and $ff=$0a then - inc(P) else begin - W.AddOnce(' '); - exit; - end; - end; - SetLine(twlParagraph); - exit; - end; - end; - '>': - if P[1]=' ' then - SetLine(twlBlockquote) else - goto none; - else - goto none; - end; - P := GotoNextNotSpaceSameLine(P+1); -end; - -procedure TTextWriterEscape.AddHtmlEscapeWiki(dest: TTextWriter; src: PUTF8Char; - escape: TTextWriterHTMLEscape); -begin - Start(dest,src,escape); - SetLine(twlParagraph); - repeat - case ProcessText([0,10,13,ord('*'),ord('+'),ord('`'),ord('\'),ord(':')]) of - #0: break; - #10,#13: begin - EndOfParagraph; - SetLine(twlParagraph); - continue; - end; - '\': if P[1] in ['\','`','*','+'] then begin - inc(P); - W.Add(P^); - end else - W.Add('\'); - '*': - Toggle(tweItalic); - '+': - Toggle(tweBold); - '`': - Toggle(tweCode); - 'h': begin - ProcessHRef; - continue; - end; - ':': begin - ProcessEmoji; - continue; - end; - end; - inc(P); - until false; - EndOfParagraph; - SetLine(twlNone); -end; - -procedure TTextWriterEscape.AddHtmlEscapeMarkdown(dest: TTextWriter; - src: PUTF8Char; escape: TTextWriterHTMLEscape); -begin - Start(dest,src,escape); - NewMarkDownLine; - repeat - if lst>=twlCode4 then // no Markdown tags within code blocks - if ProcessText([0,10,13])=#0 then - break else begin - if PWord(P)^=$0a0d then - inc(P,2) else - inc(P); - W.AddCR; // keep LF within 
-        NewMarkdownLine;
-        continue;
-      end else
-    case ProcessText([0,10,13,ord('*'),ord('_'),ord('`'),ord('\'),ord('['),ord('!'),ord(':')]) of
-    #0: break;
-    #10,#13: begin
-      EndOfParagraph;
-      NewMarkdownLine;
-      continue;
-    end;
-    '\': if P[1] in ['\','`','*','_','[',']','{','}','(',')','#','+','-','.','!'] then begin
-      inc(P);
-      W.Add(P^); // backslash escape
-    end else
-      W.Add('\');
-    '*','_':
-      if P[1]=P[0] then begin
-        inc(P); // **This text will be bold** or __This text will be bold__
-        Toggle(tweBold);
-      end else  // *This text will be italic* or _This text will be italic_
-        Toggle(tweItalic);
-    '`':
-      Toggle(tweCode);  // `This text will be code`
-    '[':
-       if ProcessLink then begin // [GitHub](https://github.com)
-         W.AddShort('') else
-           W.Add('"','>');
-         W.AddHtmlEscape(B2,P2-B2,fmt);
-         W.AddShort(''); // no continune -> need inc(P) over ending )
-       end else
-         W.Add('['); // not a true link -> just append
-    '!': begin
-      if P[1]='[' then begin
-       inc(P);
-       if ProcessLink then begin
-         W.AddShort('');
-         W.AddHtmlEscape(B2,P2-B2,hfWithinAttributes);
-         W.AddShort('');
-         inc(P);
-         continue;
-       end;
-       dec(P);
-      end;
-      W.Add('!'); // not a true image
-    end;
-    'h': begin
-      ProcessHRef;
-      continue;
-    end;
-    ':': begin
-      ProcessEmoji;
-      continue;
-    end;
-    end;
-    inc(P);
-  until false;
-  EndOfParagraph;
-  SetLine(twlNone);
-end;
-
-function HtmlEscapeWiki(const wiki: RawUTF8; esc: TTextWriterHTMLEscape): RawUTF8;
-var temp: TTextWriterStackBuffer;
-    W: TTextWriter;
-begin
-  W := TTextWriter.CreateOwnedStream(temp);
-  try
-    AddHtmlEscapeWiki(W,pointer(wiki),esc);
-    W.SetText(result);
-  finally
-    W.Free;
-  end;
-end;
-
-function HtmlEscapeMarkdown(const md: RawUTF8; esc: TTextWriterHTMLEscape): RawUTF8;
-var temp: TTextWriterStackBuffer;
-    W: TTextWriter;
-begin
-  W := TTextWriter.CreateOwnedStream(temp);
-  try
-    AddHtmlEscapeMarkdown(W,pointer(md),esc);
-    W.SetText(result);
-  finally
-    W.Free;
-  end;
-end;
-
-procedure AddHtmlEscapeWiki(W: TTextWriter; P: PUTF8Char; esc: TTextWriterHTMLEscape);
-var doesc: TTextWriterEscape;
-begin
-  doesc.AddHtmlEscapeWiki(W,P,esc);
-end;
-
-procedure AddHtmlEscapeMarkdown(W: TTextWriter; P: PUTF8Char; esc: TTextWriterHTMLEscape);
-var doesc: TTextWriterEscape;
-begin
-  doesc.AddHtmlEscapeMarkdown(W,P,esc);
-end;
-
-
-function EmojiFromText(P: PUTF8Char; len: PtrInt): TEmoji;
-begin // RTTI has shortstrings in adjacent L1 cache lines -> faster than EMOJI_TEXT[]
-  result := TEmoji(FindShortStringListTrimLowerCase(EMOJI_RTTI,ord(high(TEmoji))-1,P,len)+1);
-end;
-
-function EmojiParseDots(var P: PUTF8Char; W: TTextWriter): TEmoji;
-var c: PUTF8Char;
-begin
-  result := eNone;
-  inc(P); // ignore trailing ':'
-  c := P;
-  if c[-2]<=' ' then begin
-    if (c[1]<=' ') and (c^ in ['('..'|']) then
-      result := EMOJI_AFTERDOTS[c^]; // e.g. :)
-    if result=eNone then begin
-      while c^ in ['a'..'z','A'..'Z','_'] do
-        inc(c);
-      if (c^=':') and (c[1]<=' ') then // try e.g. :joy_cat:
-        result := EmojiFromText(P,c-P);
-    end;
-    if result<>eNone then begin
-      P := c+1; // continue parsing after the Emoji text
-      if W<>nil then
-        W.AddNoJSONEscape(pointer(EMOJI_UTF8[result]),4);
-      exit;
-    end;
-  end;
-  if W<>nil then
-    W.Add(':');
-end;
-
-procedure EmojiToDots(P: PUTF8Char; W: TTextWriter);
-var B: PUTF8Char;
-    c: cardinal;
-begin
-  if (P<>nil) and (W<>nil) then
-    repeat
-      B := P;
-      while (P^<>#0) and (PWord(P)^<>$9ff0) do
-        inc(P);
-      W.AddNoJSONEscape(B,P-B);
-      if P^=#0 then
-        break;
-      B := P;
-      c := NextUTF8UCS4(P)-$1f5ff;
-      if c<=cardinal(high(TEmoji)) then
-        W.AddNoJSONEscapeUTF8(EMOJI_TAG[TEmoji(c)]) else
-        W.AddNoJSONEscape(B,P-B);
-    until P^=#0;
-end;
-
-function EmojiToDots(const text: RawUTF8): RawUTF8;
-var W: TTextWriter;
-    tmp: TTextWriterStackBuffer;
-begin
-  if PosExChar(#$f0,text)=0 then begin
-    result := text; // no UTF-8 smiley for sure
-    exit;
-  end;
-  W := TTextWriter.CreateOwnedStream(tmp);
-  try
-    EmojiToDots(pointer(text),W);
-    W.SetText(result);
-  finally
-    W.Free;
-  end;
-end;
-
-procedure EmojiFromDots(P: PUTF8Char; W: TTextWriter);
-var B: PUTF8Char;
-begin
-  if (P<>nil) and (W<>nil) then
-    repeat
-      B := P;
-      while not(P^ in [#0,':']) do
-        inc(P);
-      W.AddNoJSONEscape(B,P-B);
-      if P^=#0 then
-        break;
-      EmojiParseDots(P,W);
-    until P^=#0;
-end;
-
-function EmojiFromDots(const text: RawUTF8): RawUTF8;
-var W: TTextWriter;
-    tmp: TTextWriterStackBuffer;
-begin
-  W := TTextWriter.CreateOwnedStream(tmp);
-  try
-    EmojiFromDots(pointer(text),W);
-    W.SetText(result);
-  finally
-    W.Free;
-  end;
-end;
-
-
-{ ************ Command Line and Console process ************************** }
-
-var
-  TextAttr: integer = ord(ccDarkGray);
-
-{$I-}
-{$ifdef MSWINDOWS}
-
-procedure InitConsole;
-begin
- StdOut := GetStdHandle(STD_OUTPUT_HANDLE);
- if StdOut=INVALID_HANDLE_VALUE then
-   StdOut := 0;
-end;
-
-procedure TextColor(Color: TConsoleColor);
-var oldAttr: integer;
-begin
-  if StdOut=0 then
-    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
-  if StdOut=0 then
-    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}
-
-function Utf8ToConsole(const S: RawUTF8): RawByteString;
-begin
-  result := TSynAnsiConvert.Engine(CP_OEMCP).UTF8ToAnsi(S);
-end;
-
-{$else MSWINDOWS}
-
-// we bypass crt.pp since this unit cancels the SIGINT signal
-
-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;
-
-procedure TextBackground(Color: TConsoleColor);
-begin // not implemented yet - but not needed either
-end;
-
-procedure ConsoleWaitForEnterKey;
-var c: AnsiChar;
-begin
-  {$ifdef FPC}
-  if IsMultiThread and (GetCurrentThreadID=MainThreadID) then
-    repeat
-      CheckSynchronize(100);
-      if UnixKeyPending then
-        repeat
-          c := #0;
-          if FpRead(StdInputHandle,c,1)<>1 then
-            break;
-          if c in [#10,#13] then
-            exit;
-        until false;
-    until false else
-  {$endif FPC}
-    ReadLn;
-end;
-
-function Utf8ToConsole(const S: RawUTF8): RawByteString;
-begin
-  result := S; // expect a UTF-8 console under Linux/BSD
-end;
-
-{$endif MSWINDOWS}
-
-function ConsoleReadBody: RawByteString;
-var len, n: integer;
-    P: PByte;
-    {$ifndef FPC}StdInputHandle: THandle;{$endif}
-begin
-  result := '';
-  {$ifdef MSWINDOWS}
-  {$ifndef FPC}StdInputHandle := GetStdHandle(STD_INPUT_HANDLE);{$endif}
-  if not PeekNamedPipe(StdInputHandle,nil,0,nil,@len,nil) then
-  {$else}
-  if fpioctl(StdInputHandle,FIONREAD,@len)<0 then
-  {$endif}
-    len := 0;
-  SetLength(result,len);
-  P := pointer(result);
-  while len>0 do begin
-    n := FileRead(StdInputHandle,P^,len);
-    if n<=0 then begin
-      result := ''; // read error
-      break;
-    end;
-    dec(len,n);
-    inc(P,n);
-  end;
-end;
-
-function StringToConsole(const S: string): RawByteString;
-begin
-  result := Utf8ToConsole(StringToUTF8(S));
-end;
-
-procedure ConsoleWrite(const Text: RawUTF8; Color: TConsoleColor; NoLineFeed, NoColor: boolean);
-begin
-  if not NoColor then
-    TextColor(Color);
-  write(Utf8ToConsole(Text));
-  if not NoLineFeed then
-    writeln;
-  ioresult;
-end;
-
-procedure ConsoleWrite(const Fmt: RawUTF8; const Args: array of const;
-  Color: TConsoleColor; NoLineFeed: boolean);
-var tmp: RawUTF8;
-begin
-  FormatUTF8(Fmt,Args,tmp);
-  ConsoleWrite(tmp,Color,NoLineFeed);
-end;
-
-procedure ConsoleShowFatalException(E: Exception; WaitForEnterKey: boolean);
-begin
-  ConsoleWrite(#13#10'Fatal exception ',cclightRed,true);
-  ConsoleWrite('%',[E.ClassName],ccWhite,true);
-  ConsoleWrite(' raised with message ',ccLightRed,true);
-  ConsoleWrite('%',[E.Message],ccLightMagenta);
-  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
-    SynTable.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}
-
-procedure InitInternalTables;
-var e: TEmoji;
-begin
-  {$ifdef MSWINDOWS}
-  InitWindowsAPI;
-  {$else}
-  stdoutIsTTY := IsATTY(StdOutputHandle)=1;
-  {$endif MSWINDOWS}
-  SetLength(JSON_SQLDATE_MAGIC_TEXT,3);
-  PCardinal(pointer(JSON_SQLDATE_MAGIC_TEXT))^ := JSON_SQLDATE_MAGIC;
-  Assert(ord(high(TEmoji))=$4f+1);
-  EMOJI_RTTI := GetEnumName(TypeInfo(TEmoji),1); // ignore eNone=0
-  GetEnumTrimmedNames(TypeInfo(TEmoji),@EMOJI_TEXT);
-  EMOJI_TEXT[eNone] := '';
-  for e := succ(low(e)) to high(e) do begin
-    LowerCaseSelf(EMOJI_TEXT[e]);
-    EMOJI_TAG[e] := ':'+EMOJI_TEXT[e]+':';
-    SetLength(EMOJI_UTF8[e],4);
-    UCS4ToUTF8(ord(e)+$1f5ff,pointer(EMOJI_UTF8[e]));
-  end;
-  EMOJI_AFTERDOTS[')'] := eSmiley;
-  EMOJI_AFTERDOTS['('] := eFrowning;
-  EMOJI_AFTERDOTS['|'] := eExpressionless;
-  EMOJI_AFTERDOTS['/'] := eConfused;
-  EMOJI_AFTERDOTS['D'] := eLaughing;
-  EMOJI_AFTERDOTS['o'] := eOpen_mouth;
-  EMOJI_AFTERDOTS['O'] := eOpen_mouth;
-  EMOJI_AFTERDOTS['p'] := eYum;
-  EMOJI_AFTERDOTS['P'] := eYum;
-  EMOJI_AFTERDOTS['s'] := eScream;
-  EMOJI_AFTERDOTS['S'] := eScream;
-  DoIsValidUTF8 := IsValidUTF8Pas;
-  DoIsValidUTF8Len := IsValidUTF8LenPas;
-  {$ifdef ASMX64AVX}
-  if CpuFeatures * [cfAVX2, cfSSE42, cfBMI1, cfBMI2, cfCLMUL] =
-                   [cfAVX2, cfSSE42, cfBMI1, cfBMI2, cfCLMUL] then begin
-    // Haswell CPUs can use simdjson AVX2 asm for IsValidUtf8()
-    DoIsValidUTF8 := IsValidUTF8Avx2;
-    DoIsValidUTF8Len := IsValidUTF8LenAvx2;
-  end;
-  {$endif ASMX64AVX}
-end;
-
-
-initialization
-  Assert(SizeOf(TSynTableFieldType)=1); // as expected by TSynTableFieldProperties
-  Assert(SizeOf(TSynTableFieldOptions)=1);
-  {$ifndef NOVARIANTS}
-  Assert(SizeOf(TSynTableData)=SizeOf(TVarData));
-  {$endif NOVARIANTS}
-  Assert(SizeOf(THTab)=$40000*3); // 786,432 bytes
-  Assert(SizeOf(TSynUniqueIdentifierBits)=SizeOf(TSynUniqueIdentifier));
-  InitInternalTables;
-  TTextWriter.RegisterCustomJSONSerializerFromText([
-    TypeInfo(TDiskPartitions),
-     'name:RawUTF8 mounted:string size:QWord',
-    TypeInfo(TSystemUseDataDynArray),
-     'Timestamp:TDateTime Kernel,User:single WorkDB,VirtualKB:cardinal']);
-end.
-
diff --git a/lib/dmustache/Synopse.inc b/lib/dmustache/Synopse.inc
deleted file mode 100644
index 626b7321..00000000
--- a/lib/dmustache/Synopse.inc
+++ /dev/null
@@ -1,736 +0,0 @@
-{
-    This file is part of Synopse framework.
-
-    Synopse framework. Copyright (C) 2022 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) 2022
-  the Initial Developer. All Rights Reserved.
-
-  Contributor(s):
-   Alfred Glaenzer (alf)
-
-  Alternatively, the contents of this file may be used under the terms of
-  either the GNU General Public License Version 2 or later (the "GPL"), or
-  the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
-  in which case the provisions of the GPL or the LGPL are applicable instead
-  of those above. If you wish to allow use of your version of this file only
-  under the terms of either the GPL or the LGPL, and not to allow others to
-  use your version of this file under the terms of the MPL, indicate your
-  decision by deleting the provisions above and replace them with the notice
-  and other provisions required by the GPL or the LGPL. If you do not delete
-  the provisions above, a recipient may use your version of this file under
-  the terms of any one of the MPL, the GPL or the LGPL.
-
-  ***** END LICENSE BLOCK *****
-}
-
-
-(********************** User-Trigerred Conditionals **********************)
-
-{  Those conditionals below can be enabled in your project Options,
-   to tune the compilation depending your setup or your project expectations. }
-
-{.$define PUREPASCAL}
-// define this if your compiler doesn't support Delphi's x86 asm
-// - is set automaticaly in case of a 64 bits compiler (only FPC exists now)
-
-{$define USENORMTOUPPER}
-// if defined, text functions will use the NormToUpper[] array, as defined
-// in our custom SysUtils.pas (not the LVCL version) -> when using LVCL,
-// define the global LVCL compiler directive, and this unit will initialize
-// its own NormToUpper[] array
-// -> define ENHANCEDRTL conditional below if our Enhanced RTL IS installed
-// -> in practice, this conditional is ALWAYS DEFINED, since needed by SQLite3
-
-{.$define ENHANCEDRTL}
-// define this if you DID install our Enhanced Runtime library or the LVCL:
-// - it's better to define this conditional globaly in the Project/Options window
-// - we need to hack the "legacy" LoadResString() procedure and add a
-//   LoadResStringTranslate() function, for on the fly resourcestring i18n
-// - it will also define the TwoDigitLookup[] array and some very fast x86 asm
-//   IntToStr() and other functions, available in our Enhanced Runtime library
-//   (and our LVCL library)
-// - it will be unset automaticaly (see below) for Delphi 2009 and up
-// - this conditional must be defined in both SQLite3Commons and SQLite3i18n units,
-//   or (even better) globally in the Project options
-
-{.$define USEPACKAGES}
-// define this if you compile the unit within a Delphi package
-// - it will avoid error like "[DCC Error] E2201 Need imported data reference ($G)
-//   to access 'VarCopyProc' from unit 'SynCommons'"
-// - shall be set at the package options level, and left untouched by default
-// - note: you should probably also set "Generate DCUs only" in Project Options
-// -> Delphi Compiler -> Output C/C++ -> C/C++ output file generation
-
-{.$define DOPATCHTRTL}
-// if defined, some low-level patches are applied to Delphi or FPC RTL
-// - you should better use it, but we have unset it by default
-
-{.$define NEWRTTINOTUSED}
-// if defined, the new RTTI (available since Delphi 2010) won't be linked to
-// the executable: resulting file size will be much smaller, and mORMot won't
-// be affected (unless you use the enhanced RTTI for record/dynamic array JSON
-// serialization) - left undefined by default to ensure minimal impact
-
-{.$define NOSETTHREADNAME}
-// if defined, SetThreadName() would not raise the exception used to set the
-// thread name: to be defined if you have issues when debugging your application
-
-{.$define NOEXCEPTIONINTERCEPT}
-// if defined, exceptions shall not be intercepted and logged
-
-{.$define USELOCKERDEBUG}
-// by default, some IAutoLocker instances would use TAutoLocker, unless this
-// conditional is defined to use more verbose TAutoLockerDebug
-// (may be used for race condition debugging, in multi-threaded apps)
-
-{.$define OLDTEXTWRITERFORMAT}
-// force TTextWriter.Add(Format) to handle the alternate deprecated $ % tags
-
-{.$define FORCE_STRSSE42}
-// sse4.2 string instructions may read up to 16 bytes after the actual end buffer
-// -> define this if you want StrLen/StrComp/strspn/strcspn to use SSE4.2 opcodes
-// but you would eventually experiment weird random GPF in your project, raising
-// unexpected SIGABRT/SIGSEGV under POSIX system: so is disabled below for our
-// LINUX conditional - and use at your own risk under Windows!
-
-{.$define DISABLE_SSE42}
-// if defined, no SSE4.2 nor AES-NI instruction will be used, i.e. disable
-// FORCE_STRSSE42 and all crc32c opcodes - is set for FPC DARWIN target
-
-{.$define WITH_ERMS}
-// you may define this to enable REP MOVSB/STOSB for Fillchar/Move if cfERMS
-// flag is available in Intel's CpuFeatures
-// -> disabled by default, since in practice it is (much) slower for small blocks
-
-{.$define NOXPOWEREDNAME}
-// define this to avoid sending "X-Powered-By: Synopse mORMot" HTTP header
-
-{.$define SQLVIRTUALLOGS}
-// enable low-level logging of SQlite3 virtual table query planner costs
-// -> to be defined only for internal debugging
-
-{.$define NOSYNDBZEOS}
-// made SynDBZeos.pas a "void" unit - defined for FPC/Lazarus packages only
-
-{.$define DDDNOSYNDB}
-// SynDB / external SQL DB won't be linked to the executable by dddInfraSettings
-{.$define DDDNOMONGODB}
-// Mongo DB client won't be linked to the executable by dddInfraSettings
-
-
-{$ifdef FPC}
-
-(********************** FPC Conditionals **********************)
-
-{ Free Pascal adaptation notes:
-  - we use the Delphi compatibility mode
-  - from system.pp use these constants (Win32/64 values listed):
-      LineEnding = #13#10;
-      DirectorySeparator = '\';
-  - for Cross-Platform and all CPU:
-      integer is NOT CPU-dependent (thanks to objpas), i.e. always 32 bits
-      cardinal is NOT CPU-dependent (thanks to objpas), i.e. always 32 bits
-      PtrUInt is an unsigned integer type of same size as a pointer / register
-        -> must be used for pointer arithmetic
-        -> may be used in loops
-      PtrInt is a signed integer type of same size as a pointer / register
-        -> must be used for pointer arithmetic
-        -> may be used in loops
-      all 32 bits x86 asm code is replaced by a pascal only version, if the
-      conditional PUREPASCAL is defined (e.g. for CPUX64)
-}
-
-  {$ifndef FPC_DELPHI}
-    {$MODE DELPHI} // e.g. for asm syntax - disabled for FPC 2.6 compatibility
-  {$endif}
-
-  {$INLINE ON}
-  {$MINENUMSIZE 1}
-  {$PACKRECORDS DEFAULT} // force normal alignment
-  {$PACKSET 1}
-  {$PACKENUM 1}
-  {$CODEPAGE UTF8} // otherwise unexpected behavior occurs in most cases
-
-  {$undef ENHANCEDRTL}    // there is no version of our Enhanced RTL for FPC
-  {$define HASINLINE}
-  {$define HASUINT64}
-  {$define HASINLINENOTX86}
-  {$define NODELPHIASM}   // ignore low-level System.@LStrFromPCharLen calls
-  {$define HASTTHREADSTART}
-  {$define HASINTERFACEASTOBJECT}
-  {$define EXTENDEDTOSHORT_USESTR} // FloatToText uses str() in FPC
-  {$define DOUBLETOSHORT_USEGRISU} // fast double to text
-  {$define DELPHI5ORFPC}
-  {$define FPC_OR_PUREPASCAL}
-  {$define FPC_OR_KYLIX}
-  {$define FPC_OR_UNICODE}
-  {$define USERECORDWITHMETHODS}
-  {$define FPC_OR_DELPHIXE}
-  {$define FPC_OR_DELPHIXE4}
-  {$define FPC_ENUMHASINNER}
-  {$define USE_VTYPE_STATIC} // in our inlined VarClear()
-
-  // $if FPC_FULLVERSION>20700 breaks Delphi 6-7 and SynProject :(
-  {$ifdef VER2_7}
-    {$define ISFPC27}
-  {$endif}
-  {$ifdef VER3_0}
-    {$define ISFPC27}
-    {$define ISFPC30}
-    {$define HASDIRECTTYPEINFO}
-    // PTypeInfo would be stored with no pointer de-reference
-    // => Delphi and newer FPC uses a pointer reference to ease exe linking
-  {$endif}
-  {$ifdef VER3_1} // trunk before 3.2
-    {$define ISFPC27}
-    {$define ISFPC30}
-    {.$define HASDIRECTTYPEINFO}
-    // define this for trunk revisions older than June 2016 - see
-    // http://wiki.freepascal.org/User_Changes_Trunk#RTTI_Binary_format_change
-  {$endif}
-  {$ifdef VER3_1_1} // if FPC_FULLVERSION>30100 ... ifend is not Delphi 5 compatible :(
-    {$define ISFPC32}
-  {$endif}
-  {$ifdef VER3_2}
-    {$define ISFPC27}
-    {$define ISFPC30}
-    {$define ISFPC32}
-    {$ifdef VER3_2_2}
-      {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet
-    {$endif VER3_2_2}
-  {$endif}
-  {$ifdef VER3_3} // trunk before 3.4
-    {$define ISFPC27}
-    {$define ISFPC30}
-    {$define ISFPC32}
-    {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet
-  {$endif}
-  {$ifdef VER3_4}
-    {$define ISFPC27}
-    {$define ISFPC30}
-    {$define ISFPC32}
-    {$define ISFPC34}
-    {$define FPC_PROVIDE_ATTR_TABLE} // introducing TTypeData.AttributeTable
-    {$define STRCNT32} // 32-bit TAnsiRec.RefCnt even on 64-bit CPU
-    {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet
-  {$endif}
-  {$if not defined(VER3_0) and not defined(VER3_2) and not defined(VER2)}
-    {.$define FPC_PROVIDE_ATTR_TABLE} // to be defined since SVN 42356-42411
-    // on compilation error in SynFPCTypInfo, undefine the above conditional
-    // see https://lists.freepascal.org/pipermail/fpc-announce/2019-July/000612.html
-    {$define STRCNT32} // 32-bit TAnsiRec.RefCnt even on 64-bit CPU
-    // see https://gitlab.com/freepascal.org/fpc/source/-/issues/38018
-  {$ifend}
-
-  {$ifdef ANDROID}
-    {$define LINUX} // a Linux-based system
-  {$endif}
-
-  // define FPCSQLITE3STATIC to enable static-linked SQLite3 engine for FPC
-  // -> expect *.o files download from https://synopse.info/files/sqlite3fpc.7z
-  // -> could be disabled to force external .so/.dll linking
-  {$ifdef MSWINDOWS}
-  {$ifdef CPUX86}
-    {$define FPCSQLITE3STATIC}   // use static\i386-win32\sqlite3.o
-  {$else}
-    {$define FPCSQLITE3STATIC}   // use static\x86_64-win64\sqlite3.o
-  {$endif}
-  {$endif}
-  {$ifdef LINUX}
-    {$ifdef CPUX86}
-      {$define FPCSQLITE3STATIC} // use static/i386-linux\sqlite3.o
-    {$endif}
-    {$ifdef CPUX64}
-      {$define FPCSQLITE3STATIC} // use static/x86_64-linux\sqlite3.o
-    {$endif}
-    {$ifdef CPUARM}
-      {$define FPCSQLITE3STATIC} // use static/arm-linux\sqlite3.o
-    {$endif}
-    {$ifdef CPUAARCH64}
-      {$define FPCSQLITE3STATIC} // use:static/aarch64-linux\sqlite3.o
-    {$endif}
-  {$endif}
-
-  {$ifdef BSD}
-    // LINUX conditional includes Darwin and BSD family like FreeBSD
-    {$define LINUX} // not true, but a POSIX/BSD system - see LINUXNOTBSD
-    {$undef FORCE_STRSSE42}  // fails otherwise for sure
-    {$define ABSOLUTEPASCAL} // NO asm nor redirection (until stabilized)
-    {$ifdef DARWIN}
-      {$define FPCSQLITE3STATIC} // we supply Darwin static libs
-      {$ifdef CPUINTEL}
-        {$define FPC_PIC} // may have not be defined by the compiler options
-      {$endif}
-    {$else}
-      {$define BSDNOTDARWIN}   // OSX has some non-standard API calls
-    {$endif}
-    {$ifdef FREEBSD}
-      {$ifdef CPUX86}
-        {$define FPCSQLITE3STATIC} // we supply i386 static libs
-      {$endif CPUX86}
-      {$ifdef CPUX64}
-        {$define FPCSQLITE3STATIC} // we supply x64 static libs
-      {$endif CPUX64}
-    {$endif}
-    {$ifdef OPENBSD}
-      {$ifdef CPUX86}
-        {$define FPCSQLITE3STATIC} // we supply i386 static libs
-      {$endif CPUX86}
-      {$ifdef CPUX64}
-        {$define FPCSQLITE3STATIC} // we supply x64 static libs
-      {$endif CPUX64}
-    {$endif}
-  {$else}
-    {$ifdef LINUX}
-      {$define LINUXNOTBSD} // e.g. to disable epoll API
-      {$define FPCLINUXNOTBSD}
-    {$endif}
-  {$endif}
-
-  {$ifdef LINUX}
-     {$undef FORCE_STRSSE42}  // avoid fatal SIGABRT/SIGSEGV on POSIX systems
-     {$define FPCLINUX}
-     {$ifdef CPUX64}
-       {$define CPUX64LINUX}  // e.g. for tuned server-side asm
-     {$endif CPUX64}
-  {$endif}
-  {$ifdef FPC_PIC}
-    {$define PUREPASCAL} // most asm code is not PIC-safe with global constants
-  {$endif}
-
-  {$ifdef MSWINDOWS}
-    {$ifdef FPC_X64MM}
-      {$ifndef FPC_X64MM_WIN} // SynFPCx64MM not yet fully validated on Windows
-         {$undef FPC_X64MM}
-      {$endif FPC_X64MM_WIN}
-    {$endif FPC_X64MM}
-  {$endif MSWINDOWS}
-
-  {$ifdef CPU64}
-    {$define FPC_64}
-    {$define PUREPASCAL} // e.g. x64, AARCH64
-    {$ifdef CPUX64}
-      {$define CPUINTEL}
-      {$define FPC_CPUINTEL}
-      {$ifndef BSD}
-        {$define CPUX64ASM} // Delphi XE4 or Darwin asm are buggy :(
-        {$define ASMX64AVX} // only FPC supports AVX/AVX2/AVX512
-        {$define HASAESNI}  // SynCrypto rejected by Darwin asm
-      {$endif BSD}
-      {$define FPC_X64}   // supports AVX/AVX2/AVX512 - which Delphi doesn't
-      {$ASMMODE INTEL}    // to share asm code with Delphi
-    {$endif CPUX64}
-    {$ifdef CPUAARCH64}
-      {$define CPUARM3264}
-    {$endif CPUAARCH64}
-  {$else}
-    {$define FPC_32}
-    {$define STRCNT32} // 32-bit TAnsiRec.RefCnt on 32-bit CPU
-    {$define DACNT32}  // 32-bit dynarray refcnt on 32-bit CPU
-    {$ifdef CPUARM}
-      {$define PUREPASCAL} // ARM32
-      {$define CPUARM3264}
-    {$endif CPUARM}
-    {$ifdef CPUX86}
-      {$define CPUINTEL}
-      {$define FPC_CPUINTEL}
-      {$define FPC_X86}
-      {$define TSYNEXTENDED80} // only 32-bit has a true x87 extended type
-      {$ASMMODE INTEL}   // as Delphi expects
-      {$define HASAESNI} // should be commented to test project with valgrind
-      {$ifndef FPC_PIC}
-        {$define CPUX86NOTPIC} // use "absolute" instead of local register
-      {$endif FPC_PIC}
-      {$ifndef OPENBSD}
-        {$define FPC_X86ASM} // if assembler knows popcnt/crc32c opcodes
-      {$endif OPENBSD}
-    {$endif CPUX86}
-  {$endif CPU64}
-
-  {$ifdef CPUARM3264}
-    {$ifdef BSD}
-      {$undef USE_VTYPE_STATIC} // circumvent bug in VarClear() on BSD + ARM
-    {$endif BSD}
-  {$endif CPUARM3264}
-
-  {$ifdef ISFPC30}
-    {$ifndef MSWINDOWS}
-      // define FPCUSEVERSIONINFO to link low-level executable file information
-      // units in SynCommons.pas
-      // => disabled by default, to reduce the executable overhead
-      {.$define FPCUSEVERSIONINFO}
-    {$endif MSWINDOWS}
-  {$endif ISFPC30}
-
-  {$ifdef ISFPC32}
-    // FPC has its own RTTI layout only since late 3.x
-    {$define FPC_NEWRTTI}
-    // when http://bugs.freepascal.org/view.php?id=26774 has been fixed
-    {$ifdef CPUINTEL}
-      {$define HASINTERFACERTTI}
-    {$endif}
-    {$ifdef CPUARM3264}
-      {$define HASINTERFACERTTI}
-    {$endif}
-  {$endif}
-
-  {$ifdef FPC_NEWRTTI}
-    {$define ISDELPHI2010_OR_FPC_NEWRTTI}
-  {$else}
-    {$define DELPHI_OR_FPC_OLDRTTI}
-    {$define FPC_OLDRTTI}
-  {$endif}
-  {$define ISDELPHI2010_OR_FPC} // eltype2 field
-
-  {$ifdef FPC_HAS_CPSTRING}
-    // see http://wiki.freepascal.org/FPC_Unicode_support
-    {$define HASCODEPAGE} // UNICODE means {$mode delphiunicode}
-  {$endif}
-  {$ifdef ISFPC27}
-    {$define ISFPC271}
-    {$define HASVARUSTRING}
-    {$define HASVARUSTRARG}
-    // defined if the http://mantis.freepascal.org/view.php?id=26773 bug is fixed
-    // you should use 2.7.1/trunk branch in revision 28995 from 2014-11-05T22:17:54
-    // => this will change the TInvokeableVariantType.SetProperty() signature
-    {$define FPC_VARIANTSETVAR}
-  {$endif ISFPC27}
-  {$ifdef FPC_PROVIDE_ATTR_TABLE}
-    {$define HASALIGNTYPEDATA} // to ignore attributes RTTI table
-  {$endif FPC_PROVIDE_ATTR_TABLE}
-  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
-    {$define FPC_ENUMHASINNER}
-    {$define HASALIGNTYPEDATA} // to ensure proper RTTI alignment
-  {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
-
-
-{$else FPC}
-
-(********************** Delphi Conditionals **********************)
-
-  {$define DELPHI_OR_FPC_OLDRTTI}
-  {$define USE_VTYPE_STATIC} // "and VTYPE_STATIC" test before VarClear()
-  {$define STRCNT32} // always 32-bit TAnsiRec.RefCnt on Delphi
-  {$define DACNT32}  // always 32-bit dynarray refcnt on Delphi
-  {$undef FPC_X64MM} // this is a FPC-specific memory manager
-
-  {$A+} // force normal alignment
-
-  {$ifdef LVCL}
-    {$define OWNNORMTOUPPER} // NormToUpper[] exists only in our enhanced RTL
-    {$define NOVARIANTS} // LVCL does not support variants
-    {$define EXTENDEDTOSHORT_USESTR} // no FloatToText implemented in LVCL
-  {$endif LVCL}
-
-  {$ifdef UNICODE}
-    {$undef ENHANCEDRTL} // Delphi 2009 and up don't have our Enhanced Runtime library
-    {$define HASVARUSTRING}
-    {$define HASCODEPAGE}
-    {$define FPC_OR_UNICODE}
-    {$define USERECORDWITHMETHODS}
-    { due to a bug in Delphi 2009+, we need to fake inheritance of record,
-      since TDynArrayHashed = object(TDynArray) fails to initialize
-      http://blog.synopse.info/post/2011/01/29/record-and-object-issue-in-Delphi-2010 }
-    {$define UNDIRECTDYNARRAY}
-  {$endif UNICODE}
-
-  {$ifndef PUREPASCAL}
-    {$define CPUINTEL} // Delphi only for Intel by now
-  {$endif}
-  {$ifdef CPUX64}
-    {$define CPU64} // Delphi compiler for 64 bit CPU
-    {$define CPU64DELPHI}
-    {$undef CPU32}
-    {$define PUREPASCAL}   // no x86 32 bit asm to be used
-    {$define EXTENDEDTOSHORT_USESTR} // FloatToText() much slower in x64 mode
-    {$define DOUBLETOSHORT_USEGRISU} // fast double to text
-  {$else CPUX64}
-    {$define CPU32} // Delphi compiler for 32 bit CPU
-    {$define CPU32DELPHI}
-    {$undef CPU64}
-    {$define CPUX86} // for compatibility with older versions of Delphi
-    {$define CPUX86NOTPIC} // use "absolute" instead of local register
-    {$define TSYNEXTENDED80} // only 32-bit has a true x87 extended type
-  {$endif CPUX64}
-
-  {$IFDEF CONDITIONALEXPRESSIONS}  // Delphi 6 or newer
-    {$define HASINTERFACERTTI} // interface RTTI (not FPC)
-    {$ifdef LINUX}
-      {$if RTLVersion = 14.5}
-        {$define KYLIX3}
-        {$define FPC_OR_KYLIX}
-        // Kylix 3 will be handled just like Delphi 7
-        {$undef ENHANCEDRTL}   // Enhanced Runtime library not fully tested yet
-        {$define EXTENDEDTOSHORT_USESTR}
-        {$define DOPATCHTRTL}  // nice speed up for server apps
-        {$define NOVARCOPYPROC}
-        {$define NOSQLITE3STATIC} // Kylix will use external sqlite3.so
-        {$define LINUXNOTBSD}     // e.g. to disable epoll API
-      {$else}
-      Kylix1/2 or Delphi Tokyo/ARC are unsupported
-      {$ifend}
-    {$else}
-      {$ifdef VER140}
-        {$define ISDELPHI6ANDUP} // Delphi 6 or newer
-        {$define DELPHI6OROLDER}
-        {$define NOVARCOPYPROC}
-        {$undef ENHANCEDRTL} // Delphi 6 doesn't have our Enhanced Runtime library
-        {$define EXTENDEDTOSHORT_USESTR} // no TFormatSettings before Delphi 7
-      {$else}
-        {$define ISDELPHI7ANDUP} // Delphi 7 or newer
-        {$define WITHUXTHEME}   // VCL handle UI theming
-        {$define HASUINT64}
-        {$warn UNSAFE_CODE OFF} // Delphi for .Net does not exist any more!
-        {$warn UNSAFE_TYPE OFF}
-        {$warn UNSAFE_CAST OFF}
-        {$warn DUPLICATE_CTOR_DTOR OFF} // avoid W1029 unneeded hints
-      {$endif}
-      {$ifdef USEPACKAGES}
-        {$undef DOPATCHTRTL}
-      {$endif}
-    {$endif LINUX}
-    {$if CompilerVersion >= 17}
-      {$define ISDELPHI2005ANDUP} // Delphi 2005 or newer
-      {$if CompilerVersion >= 18}
-        {$define ISDELPHI2006ANDUP} // Delphi 2006 or newer
-        {$define HASNEWFILEAGE}
-        {$define HASINLINE}
-        {$define HASINLINEDELPHI}
-        {$define HASINLINENOTX86}
-        {$define HASREGION}
-        {$define HASFASTMM4}
-        // try to define this so that GetMemoryInfo/TSynMonitorMemory returns
-        // low-level FastMM4 information
-        {.$define WITH_FASTMM4STATS}
-      {$ifend}
-      {$ifdef VER180}
-        {$define ISDELPHI20062007} // to circumvent some specific bugs
-      {$endif}
-      {$ifdef VER185}
-        {$define ISDELPHI20062007}
-      {$endif}
-      {$if CompilerVersion > 18}
-        {$define ISDELPHI2007ANDUP} // Delphi 2007 or newer
-      {$ifend}
-      {$if CompilerVersion = 20}
-        {$define ISDELPHI20092010} // specific compilation issues
-      {$ifend}
-      {$if CompilerVersion = 21}
-        {$define ISDELPHI20092010} //specific compilation issues
-      {$ifend}
-      {$if CompilerVersion >= 21.0}
-        {$define ISDELPHI2010}
-        {$define ISDELPHI2010_OR_FPC} // eltype2 field
-        {$define ISDELPHI2010_OR_FPC_NEWRTTI}
-        {$define HASTTHREADSTART}
-        {$define HASINTERFACEASTOBJECT}
-        {$ifdef NEWRTTINOTUSED} // option reduce EXE size by disabling much RTTI
-          {$WEAKLINKRTTI ON}
-          {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
-        {$endif NEWRTTINOTUSED}
-      {$ifend}
-      {$if CompilerVersion >= 22.0}
-        {$define FPC_OR_DELPHIXE} // Delphi 2007/2009/2010 inlining bugs
-        {$define ISDELPHIXE}
-      {$ifend}
-      {$if CompilerVersion >= 23.0}
-        // Delphi XE2 has some cross-platform features
-        // e.g. {$ifdef ISDELPHIXE2}VCL.Graphics{$else}Graphics{$endif}
-        {$define ISDELPHIXE2}
-        {$define HASVARUSTRARG}
-        {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet
-      {$ifend}
-      {$if CompilerVersion >= 24.0}
-        {$define ISDELPHIXE3}
-      {$ifend}
-      {$if CompilerVersion >= 25.0}
-        {$define ISDELPHIXE4}
-        {$define FPC_OR_DELPHIXE4} // circumvent Internal Error: C2130 on XE3
-        {$define HASAESNI}
-      {$ifend}
-      {$if CompilerVersion >= 26.0}
-        {$define ISDELPHIXE5}
-        {$define PUBLISHRECORD}
-        // if defined, will handle RTTI available only since Delphi XE5 for
-        // record published properties
-      {$ifend}
-      {$if CompilerVersion >= 27.0}
-        {$define ISDELPHIXE6}
-      {$ifend}
-      {$if CompilerVersion >= 28.0}
-        {$define ISDELPHIXE7}
-        {$ifdef CPU64}
-          {$define CPUX64ASM} // e.g. Delphi XE4 SSE asm is buggy :(
-        {$endif}
-      {$ifend}
-      {$if CompilerVersion >= 29.0}
-        {$define ISDELPHIXE8}
-      {$ifend}
-      {$if CompilerVersion >= 30.0}
-        {$define ISDELPHI10}
-      {$ifend}
-      {$if CompilerVersion >= 31.0}
-        {$define ISDELPHI101}
-      {$ifend}
-      {$if CompilerVersion >= 32.0}
-        {$define ISDELPHI102}
-        {$ifdef CPUX64}
-        {$ifdef VER320withoutAprilUpdate}
-          // circumvent early Delphi 10.2 Tokyo Win64 compiler bug
-          {$undef HASINLINE}
-          {$define HASINLINENOTX86}
-        {$endif}
-        {$endif}
-      {$ifend}
-      {$if CompilerVersion >= 33.0}
-        {$define ISDELPHI103}
-      {$ifend}
-      {$if CompilerVersion >= 34.0}
-        {$define ISDELPHI104}
-      {$ifend}
-      {$if CompilerVersion >= 35.0}
-        {$define ISDELPHI11}
-      {$ifend}
-    {$ifend CompilerVersion >= 17}
-    {$ifopt O-} // if we don't expect fast code, don't optimize the framework
-      {$undef ENHANCEDRTL}
-      {$undef DOPATCHTRTL}
-    {$endif}
-  {$ELSE}
-    // Delphi 5 or older
-    {$define DELPHI6OROLDER}
-    {$define DELPHI5OROLDER}
-    {$define DELPHI5ORFPC}
-    {$define MSWINDOWS}
-    {$define NOVARIANTS}
-    {$define NOVARCOPYPROC}
-    {$undef ENHANCEDRTL} // Delphi 5 doesn't have our Enhanced Runtime library
-    {$define EXTENDEDTOSHORT_USESTR} // no TFormatSettings before Delphi 7
-    {$undef DOPATCHTRTL}
-  {$ENDIF CONDITIONALEXPRESSIONS}
-
-{$endif FPC}
-
-
-(********************** Shared Conditionals **********************)
-
-{$ifdef PUREPASCAL}
-  {$define NODELPHIASM}
-  {$define FPC_OR_PUREPASCAL}
-{$else}
-{$endif PUREPASCAL}
-
-{$H+} // we use long strings
-{$R-} // disable Range checking in our code
-{$S-} // disable Stack checking in our code
-{$X+} // expect extended syntax
-{$W-} // disable stack frame generation
-{$Q-} // disable overflow checking in our code
-{$B-} // expect short circuit boolean
-{$V-} // disable Var-String Checking
-{$T-} // Typed @ operator
-{$Z1} // enumerators stored as byte by default
-
-{$ifndef FPC}
-  {$P+} // Open string params
-  {$ifdef VER150}
-    {$WARN SYMBOL_DEPRECATED OFF}
-    {$WARN UNSAFE_TYPE OFF}
-    {$WARN UNSAFE_CODE OFF}
-    {$WARN UNSAFE_CAST OFF}
-  {$ENDIF}
-  {$ifdef CONDITIONALEXPRESSIONS}  // Delphi 6 or newer
-    {$WARN SYMBOL_PLATFORM OFF}
-    {$WARN UNIT_PLATFORM OFF}
-  {$endif}
-{$endif FPC}
-
-{$ifdef CPUINTEL}
-  {$ifdef CPUX86} // safest to reset x87 exceptions
-    {$ifndef PUREPASCAL}
-      {$ifndef DELPHI5OROLDER}
-        {$define RESETFPUEXCEPTION}
-      {$endif}
-    {$endif}
-  {$endif}
-  {$ifdef DISABLE_SSE42}
-    {$undef FORCE_STRSSE42}
-  {$endif DISABLE_SSE42}
-{$else}
-  {$undef HASAESNI} // AES-NI is an Intel-specific feature
-  {$define ABSOLUTEPASCALORNOTINTEL}
-{$endif CPUINTEL}
-
-{$ifdef ABSOLUTEPASCAL}
-  {$define ABSOLUTEORPUREPASCAL}
-  {$define ABSOLUTEPASCALORNOTINTEL}
-  {$define PUREPASCAL}
-{$endif ABSOLUTEPASCAL}
-{$ifdef PUREPASCAL}
-  {$define ABSOLUTEORPUREPASCAL}
-{$endif PUREPASCAL}
-
-{$define WITHLOG}
-// if defined, logging will be supported via the TSQLLog family
-// - should be left defined: TSQLog.Family.Level default setting won't log
-// anything, so there won't be any noticeable performance penalty to have
-// this WITHLOG conditional defined, which is expected by high-level part
-// of the framework, like DDD or UI units
-
-{$ifdef FPC}
-  {$ifndef FPCSQLITE3STATIC} // see above about this FPC-specific conditional
-    {$define NOSQLITE3STATIC}
-  {$endif}
-{$else}
-  // there is a linking bug with Delphi XE4 on Win64
-  {$ifdef CPUX64}
-    {$if CompilerVersion = 25.0} // exactly XE4
-      {$define NOSQLITE3STATIC}
-      // :( to avoid "Fatal: F2084 Internal Error: AV004A7B1F-R03BDA7B0-0"
-    {$ifend}
-  {$endif} // other Win32/Win64 Delphi platforms should work as expected
-{$endif FPC}
-
-{$ifdef NOSQLITE3STATIC}
-  // our proprietary crypto expects a statically linked custom sqlite3.c
-  {$define NOSQLITE3ENCRYPT}
-{$endif NOSQLITE3STATIC}
-
-{$ifdef MSWINDOWS}
-  {$define USEWININET}         // publish TWinINet/TWinHttp/TWinHttpAPI classes
-  {.$define ONLYUSEHTTPSOCKET} // for testing (no benefit vs http.sys)
-  {.$define USELIBCURL}        // for testing (no benefit vs WinHTTP)
-{$else}
-  {$define ONLYUSEHTTPSOCKET}  // http.sys server is Windows-specific
-  // cross-platform libcurl for https -> TCurlHttp and TSQLHttpClientCurl
-  {$define USELIBCURL}
-  {$ifdef ANDROID}
-    // for Android, consider using https://github.com/gcesarmza/curl-android-ios
-    // static libraries and force USELIBCURL in the project conditionals
-    {$define LIBCURLSTATIC}
-  {$endif ANDROID}
-{$endif MSWINDOWS}
-
-{$ifdef USELIBCURL}
-  {.$define LIBCURLMULTI}
-  // enable https://curl.haxx.se/libcurl/c/libcurl-multi.html interface
-{$endif USELIBCURL}
-
diff --git a/lib/dmustache/SynopseCommit.inc b/lib/dmustache/SynopseCommit.inc
deleted file mode 100644
index 2f88f37d..00000000
--- a/lib/dmustache/SynopseCommit.inc
+++ /dev/null
@@ -1 +0,0 @@
-'1.18.6381'
diff --git a/lib/dmustache/mormot.commit.inc b/lib/dmustache/mormot.commit.inc
new file mode 100644
index 00000000..b7ee0be7
--- /dev/null
+++ b/lib/dmustache/mormot.commit.inc
@@ -0,0 +1 @@
+'2.2.7423'
diff --git a/lib/dmustache/mormot.core.base.asmx64.inc b/lib/dmustache/mormot.core.base.asmx64.inc
new file mode 100644
index 00000000..7e181bb6
--- /dev/null
+++ b/lib/dmustache/mormot.core.base.asmx64.inc
@@ -0,0 +1,2939 @@
+{
+  This file is a part of the Open Source Synopse mORMot framework 2,
+  licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+
+   x86_64 assembly used by mormot.core.base.pas
+}
+
+{$ifdef FPC}
+  // disabled some FPC paranoid warnings
+  {$WARN 7119 off : Exported/global symbols should be accessed via the GOT }
+  {$WARN 7121 off : Check size of memory operand "$1: memory-operand-size is $2 bits, but expected [$3 bits]" }
+  {$WARN 7122 off : Check size of memory operand "$1: memory-operand-size is $2 bits, but expected [$3 bits + $4 byte offset]" }
+  {$WARN 7123 off : Check "$1: offset of memory operand is negative "$2 byte" }
+{$endif FPC}
+
+{$ifdef ASMX64}
+
+{
+ FillCharFast/MoveFast implementation notes:
+ - assume ERBMS is available (cpuid flag may not be propagated within VMs)
+ - use branchless sub-functions for smallest buffers, then SSE2 up to 255 bytes
+ - use "rep movsb" for 256..512K input (should work on all CPUs, even oldest)
+ - don't use backward "std rep movsb" since it is not involved by ERMBS (slow)
+ - use non-temporal SSE2 or AVX loop >= 512KB (to not pollute the CPU cache)
+ - will check X64CpuFeatures global to adjust the algorithm if cpuAVX is set
+ - regarding benchmark, run TTestLowLevelCommon.CustomRTL on x86_64
+  -> FillCharFast/MoveFast seems faster, especially for small lengths (strings)
+  -> Delphi RTL is slower than FPC's, and it does not support AVX assembly yet
+}
+
+const
+  // non-temporal writes should bypass the cache when the size is bigger than
+  // half the size of the largest level cache = 512KB, assuming a low 1MB cache
+  // - today CPUs could have 144MB of (3D) cache (!) so we favor a fixed value
+  // and rely on the CPU hardware cache prefetch when accessing the data
+  NONTEMPORALSIZE = 512 * 1024;
+
+  {$ifdef NO_ERMS}
+    {$undef WITH_ERMS}
+  {$else}
+    {$define WITH_ERMS}
+    // we enable forward rep movsb/stosb over SSE2MAXSIZE=256 bytes on x86_64
+    // and we don't try to detect it because CPUID is unset in some VMs
+  {$endif NO_ERMS}
+
+  // minimum size triggering ASMX64AVXNOCONST or WITH_ERMS optimized asm
+  // - pre-ERMS expects at least 144/256 bytes, IvyBridge+ with ERMS is good
+  // from 64 - copy_user_enhanced_fast_string() in recent Linux kernel uses 64
+  // see https://stackoverflow.com/a/43837564/458259 for explanations and timing
+  // - see also mormot.core.fpcx64mm.pas as reference
+  SSE2MAXSIZE = 256;
+
+  // identify Intel/AMD AVX2+BMI support at Haswell level
+  CPUAVX2HASWELL = [cfAVX2, cfSSE42, cfBMI1, cfBMI2, cfCLMUL];
+
+procedure MoveFast(const src; var dst; cnt: PtrInt);
+{$ifdef FPC}nostackframe; assembler;
+asm {$else} asm .noframe {$endif} // rcx/rdi=src rdx/rsi=dst r8/rdx=cnt
+        mov     rax, cnt             // rax=r8/rdx=cnt
+        lea     r10, [rip + @jmptab] // 0..16 dedicated sub-functions
+        sub     rax, 16
+        ja      @up16                // >16 or <0
+        {$ifdef WIN64ABI}    // circumvent FPC asm bug and adapt to xmm ABI
+        jmp     qword ptr [r10 + r8 * 8]
+@up16:  // >16 or <0
+        jng     @z  // <0
+        movups  xmm0, oword ptr [src + rax]    // last 16   = xmm0
+        movups  xmm1, oword ptr [src]          // first 16  = xmm1
+        cmp     rax, 96 - 16
+        {$else}
+        jmp     qword ptr [r10 + rdx * 8]
+@neg:   ret
+@up16:  // >16 or <0
+        jng     @neg  // <0
+        mov     r8, rdx
+        movups  xmm0, oword ptr [src + rax]    // last 16   = xmm0
+        movups  xmm1, oword ptr [src]          // first 16  = xmm1
+        cmp     rdx, 144  // more volatile xmm registers on SystemV ABI
+        {$endif WIN64ABI}
+        ja      @lrg         // >96/144
+        // cnt = 17..96/144
+        cmp     al, $10
+        jbe     @sml10
+        movups  xmm2, oword ptr [src + $10]    // second 16
+        cmp     al, $20
+        jbe     @sml20
+        movups  xmm3, oword ptr [src + $20]    // third 16
+        cmp     al, $30
+        jbe     @sml30
+        movups  xmm4, oword ptr [src + $30]    // fourth 16
+        cmp     al, $40
+        jbe     @sml40
+        movups  xmm5, oword ptr [src + $40]    // fifth 16
+        // xmm0..xmm5 are volatile on both Win64 and SystemV ABI
+        // xmm6 and up are also volatile on SystemV ABI so allow more bytes
+        {$ifdef SYSVABI}
+        cmp     al, $50
+        jbe     @sml50
+        movups  xmm6, oword ptr [src + $50]
+        cmp     al, $60
+        jbe     @sml60
+        movups  xmm7, oword ptr [src + $60]
+        cmp     al, $70
+        jbe     @sml70
+        movups  xmm8, oword ptr [src + $70]
+        // more registers increases code size ([dst+$80]) so are not used
+        movups  oword ptr [dst + $70], xmm8
+@sml70: movups  oword ptr [dst + $60], xmm7
+@sml60: movups  oword ptr [dst + $50], xmm6
+@sml50: {$endif SYSVABI}
+        movups  oword ptr [dst + $40], xmm5    // fifth 16
+@sml40: movups  oword ptr [dst + $30], xmm4    // fourth 16
+@sml30: movups  oword ptr [dst + $20], xmm3    // third 16
+@sml20: movups  oword ptr [dst + $10], xmm2    // second 16
+@sml10: movups  oword ptr [dst],       xmm1    // first 16
+        movups  oword ptr [dst + rax], xmm0    // last 16 (may be overlapping)
+@z:     ret
+@lrg:   // cnt > 96/144 or cnt < 0
+        mov     r11d, NONTEMPORALSIZE
+        mov     r10, dst
+        add     rax, 16       // restore rax=cnt as expected below
+        jl      @z            // cnt < 0
+        sub     r10, src
+        jz      @z            // src=dst
+        cmp     r10, cnt      // move backwards if unsigned(dst-src) < cnt
+        jb      @lrgbwd
+        // forward ERMSB/SSE2/AVX move for cnt > 96/144 bytes
+        mov     r9, dst       // dst will be 16/32 bytes aligned for writes
+        {$ifdef WITH_ERMS}
+        {$ifdef WIN64ABI}   // 145 bytes seems good enough for ERMSB on a server
+        cmp     rax, SSE2MAXSIZE
+        jb      @fsse2      // 97..255 bytes may be not enough for ERMSB nor AVX
+        {$endif WIN64ABI}
+        cmp     rax, r11
+        jae     @lrgfwd       // non-temporal move > 512KB is better than ERMSB
+        // 256/145..512K could use the "rep movsb" ERMSB pattern on all CPUs
+        cld
+        {$ifdef WIN64ABI}
+        push    rsi
+        push    rdi
+        mov     rsi, src
+        mov     rdi, dst
+        mov     rcx, r8
+        rep movsb
+        pop     rdi
+        pop     rsi
+        {$else}
+        xchg    rsi, rdi // dst=rsi and src=rdi -> swap
+        mov     rcx, r8
+        rep movsb
+        {$endif WIN64ABI}
+        ret
+        {$else}
+        jmp     @lrgfwd
+        {$endif WITH_ERMS}
+        {$ifdef ASMX64AVXNOCONST} // limited AVX asm on Delphi 11
+@lrgbwd:// backward SSE2/AVX move
+        cmp     rax, SSE2MAXSIZE
+        jb      @bsse2 // 97/129..255 bytes is not worth AVX context transition
+        test    byte ptr [rip + X64CpuFeatures], 1 shl cpuAVX
+        jz      @bsse2
+        jmp     @bavx
+@lrgfwd:// forward SSE2/AVX move
+        test    byte ptr [rip + X64CpuFeatures], 1 shl cpuAVX
+        jnz     @favx
+        {$else}
+@lrgfwd:{$endif ASMX64AVXNOCONST}
+@fsse2: // forward SSE2 move
+        lea     src, [src + rax - 16]
+        lea     rax, [rax + dst - 16]
+        mov     r10, rax
+        neg     rax
+        and     dst, -16                     // 16-byte aligned writes
+        lea     rax, [rax + dst + 16]
+        cmp     r8, r11
+        jb      @fwd                         // bypass cache for cnt>512KB
+        jmp     @fwdnt
+        // backward SSE2/AVX move for cnt > 96/144 bytes
+        // note: ERMSB is not available on "std rep move" which is slower
+        {$ifndef ASMX64AVXNOCONST}
+@lrgbwd:{$endif ASMX64AVXNOCONST}
+@bsse2: // backward SSE2 move
+        sub     rax, 16
+        mov     r9, rax
+        add     rax, dst
+        and     rax, -16                     // 16-byte aligned writes
+        sub     rax, dst
+        cmp     r8, r11
+        jae     @bwdnt                       // bypass cache for cnt>512KB
+        jmp     @bwd
+        {$ifdef ASMX64AVXNOCONST}
+@bavx:  // backward AVX move
+        sub     rax, 32
+        mov     r9, rax
+        vmovups ymm2, yword ptr [src + rax]  // last 32
+        vmovups ymm1, yword ptr [src]        // first 32
+        add     rax, dst
+        and     rax, -32                     // 32-byte aligned writes
+        sub     rax, dst
+        cmp     r8, r11
+        jae     @bavxn                       // bypass cache for cnt>512KB
+        jmp     @bavxr
+@favx:  // forward AVX move
+        vmovups ymm2, yword ptr [src]        // first 32
+        lea     src, [src + rax - 32]
+        lea     dst, [dst + rax - 32]
+        vmovups ymm1, yword ptr [src]        // last 32
+        neg     rax
+        add     rax, dst
+        and     rax, -32                     // 32-byte aligned writes
+        sub     rax, dst
+        add     rax, 64
+        cmp     r8, r11
+        jb      @favxr                       // bypass cache for cnt>512KB
+        jmp     @favxn
+        // forward temporal AVX loop
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@favxr: vmovups ymm0, yword ptr [src + rax]
+        vmovaps yword ptr [dst + rax], ymm0  // most CPUs have one store unit
+        add     rax, 32
+        jl      @favxr
+@favxe: vmovups yword ptr [dst], ymm1        // last 32
+        vmovups yword ptr [r9], ymm2         // first 32
+// https://software.intel.com/en-us/articles/avoiding-avx-sse-transition-penalties
+        vzeroupper
+        ret
+        // forward non-temporal AVX loop
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@favxn: vmovups ymm0, yword ptr [src + rax]
+        // circumvent FPC inline asm bug with vmovntps [dst + rax], ymm0
+        {$ifdef WIN64ABI}
+        vmovntps [rdx + rax], ymm0           // rdx=dst on Win64
+        {$else}
+        vmovntps [rsi + rax], ymm0           // rsi=dst on POSIX
+        {$endif WIN64ABI}
+        add     rax, 32
+        jl      @favxn
+        sfence
+        jmp     @favxe
+        {$endif ASMX64AVXNOCONST}
+        // forward temporal SSE2 loop
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@fwd:   movups  xmm2, oword ptr [src + rax]
+        movaps  [r10 + rax], xmm2
+        add     rax, 16
+        jl      @fwd
+        movups  oword ptr [r10], xmm0        // last 16
+        movups  oword ptr [r9], xmm1         // first 16
+        ret
+        // forward non-temporal SSE2 loop
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@fwdnt: movups  xmm2, oword ptr [src + rax]
+        movntdq [r10 + rax], xmm2
+        add     rax, 16
+        jl      @fwdnt
+        sfence
+        movups  oword ptr [r10], xmm0        // last 16
+        movups  oword ptr [r9], xmm1         // first 16
+        ret
+        // backward temporal SSE2 loop
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@bwd:   movups  xmm2, oword ptr [src + rax]
+        movaps  oword ptr [dst + rax], xmm2
+        sub     rax, 16
+        jg      @bwd
+        movups  oword ptr [dst], xmm1        // first 16
+        movups  oword ptr [dst + r9], xmm0   // last 16
+        ret
+        // backward non-temporal SSE2 loop
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@bwdnt: movups  xmm2, oword ptr [src + rax]
+        movntdq oword ptr [dst + rax], xmm2
+        sub     rax, 16
+        jg      @bwdnt
+        sfence
+        movups  oword ptr [dst], xmm1        // first 16
+        movups  oword ptr [dst + r9], xmm0   // last 16
+        ret
+        {$ifdef ASMX64AVXNOCONST}
+        // backward temporal AVX loop
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@bavxr: vmovups ymm0, yword ptr [src + rax]
+        vmovaps yword ptr [dst + rax], ymm0
+        sub     rax, 32
+        jg      @bavxr
+@bavxe: vmovups yword ptr [dst], ymm1        // first 32
+        vmovups yword ptr [dst + r9], ymm2   // last 32
+        vzeroupper
+        ret
+        // backward non-temporal AVX loop
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@bavxn: vmovups ymm0, yword ptr [src + rax]
+        // circumvent FPC inline asm bug with vmovntps [dst + rax], ymm0
+        {$ifdef WIN64ABI}
+        vmovntps [rdx + rax], ymm0           // rdx=dst on Win64
+        {$else}
+        vmovntps [rsi + rax], ymm0           // rsi=dst on POSIX
+        {$endif WIN64ABI}
+        sub     rax, 32
+        jg      @bavxn
+        sfence
+        jmp     @bavxe
+        {$endif ASMX64AVXNOCONST}
+        // dedicated branchless sub-functions for 0..16 bytes
+{$ifdef FPC} align 8 {$else} .align 8 {$endif}
+@jmptab:dq      @00, @01, @02, @03, @04, @05, @06, @07
+        dq      @08, @09, @10, @11, @12, @13, @14, @15, @16
+@01:    mov     al, byte ptr [src]
+        mov     byte ptr [dst], al
+@00:    ret
+@02:    movzx   eax, word ptr [src]
+        mov     word ptr [dst], ax
+        ret
+@03:    movzx   eax, word ptr [src]
+        mov     cl, byte ptr [src + 2]
+        mov     word ptr [dst], ax
+        mov     byte ptr [dst + 2], cl
+        ret
+@04:    mov     eax, dword ptr [src]
+        mov     dword ptr [dst], eax
+        ret
+@05:    mov     eax, dword ptr [src]
+        mov     cl, byte ptr [src + 4]
+        mov     dword ptr [dst], eax
+        mov     byte ptr [dst + 4], cl
+        ret
+@06:    mov     eax, dword ptr [src]
+        movzx   ecx, word ptr [src + 4]
+        mov     dword ptr [dst], eax
+        mov     word ptr [dst + 4], cx
+        ret
+@07:    mov     r8d, dword ptr [src]         // faster with no overlapping
+        movzx   eax, word ptr [src + 4]
+        mov     cl, byte ptr [src + 6]
+        mov     dword ptr [dst], r8d
+        mov     word ptr [dst + 4], ax
+        mov     byte ptr [dst + 6], cl
+        ret
+@08:    mov     rax, qword ptr [src]
+        mov     [dst], rax
+        ret
+@09:    mov     rax, qword ptr [src]
+        mov     cl, byte ptr [src + 8]
+        mov     [dst], rax
+        mov     byte ptr [dst + 8], cl
+        ret
+@10:    mov     rax, qword ptr [src]
+        movzx   ecx, word ptr [src + 8]
+        mov     [dst], rax
+        mov     word ptr [dst + 8], cx
+        ret
+@11:    mov     r8, qword ptr [src]
+        movzx   eax, word ptr [src + 8]
+        mov     cl, byte ptr [src + 10]
+        mov     [dst], r8
+        mov     word ptr [dst + 8], ax
+        mov     byte ptr [dst + 10], cl
+        ret
+@12:    mov     rax, qword ptr [src]
+        mov     ecx, dword ptr [src + 8]
+        mov     [dst], rax
+        mov     dword ptr [dst + 8], ecx
+        ret
+@13:    mov     r8, qword ptr [src]
+        mov     eax, dword ptr [src + 8]
+        mov     cl, byte ptr [src + 12]
+        mov     [dst], r8
+        mov     dword ptr [dst + 8], eax
+        mov     byte ptr [dst + 12], cl
+        ret
+@14:    mov     r8, qword ptr [src]
+        mov     eax, dword ptr [src + 8]
+        movzx   ecx, word ptr [src + 12]
+        mov     [dst], r8
+        mov     dword ptr [dst + 8], eax
+        mov     word ptr [dst + 12], cx
+        ret
+@15:    mov     r8, qword ptr [src]
+        mov     rax, qword ptr [src + 7] // overlap is the easiest solution
+        mov     [dst], r8
+        mov     [dst + 7], rax
+        ret
+@16:    movups  xmm0, oword ptr [src]
+        movups  oword [dst], xmm0
+end;
+
+procedure FillCharFast(var dst; cnt: PtrInt; value: byte);
+{$ifdef FPC}nostackframe; assembler;
+asm {$else} asm .noframe {$endif} // rcx/rdi=dst rdx/rsi=cnt r8b/dl=val
+        mov     r9, $0101010101010101
+        lea     r10, [rip + @jmptab]
+        {$ifdef WIN64ABI}
+        movzx   eax, r8b
+        {$else}
+        movzx   eax, dl
+        mov     rdx, rsi // rdx=cnt
+        {$endif WIN64ABI}
+        imul    rax, r9  // broadcast value into all bytes of rax (in 1 cycle)
+        cmp     cnt, 32
+        ja      @abv32   // >32 or <0
+        sub     rdx, 8
+        jg      @sml32   // 9..32
+        jmp     qword ptr [r10 + 64 + rdx * 8] // tinest 0..8 bytes
+@sml32: cmp     dl, 8  // 9..32 bytes
+        jle     @sml16
+        cmp     dl, 16
+        jle     @sml24
+        mov     qword ptr [dst + 16], rax
+@sml24: mov     qword ptr [dst + 8], rax
+@sml16: mov     qword ptr [dst + rdx], rax // last 8 (may be overlapping)
+@08:    mov     qword ptr [dst], rax
+@00:    ret
+@abv32: jng     @00  // < 0
+        // cnt > 32 bytes
+        movd    xmm0, eax
+        lea     r8, [dst + cnt]        // r8 point to end
+        mov     r9d, NONTEMPORALSIZE
+        pshufd  xmm0, xmm0, 0          // broadcast value into all bytes of xmm0
+        mov     r10, rdx               // save rdx=cnt
+        cmp     rdx, 255 // = SSE2MAXSIZE-1, but hardcoded in move below
+        ja      @abv255
+        // 33..255 bytes is not good for ERMSB or AVX, and need no alignment
+        test    dl, $80
+        jz      @sml80
+        movups  oword ptr [dst], xmm0
+        movups  oword ptr [dst + $10], xmm0
+        movups  oword ptr [dst + $20], xmm0
+        movups  oword ptr [dst + $30], xmm0
+        movups  oword ptr [dst + $40], xmm0
+        movups  oword ptr [dst + $50], xmm0
+        movups  oword ptr [dst + $60], xmm0
+        movups  oword ptr [dst + $70], xmm0
+        add     dst, $80
+@sml80: test    dl, $40
+        jz      @sml40
+        movups  oword ptr [dst], xmm0
+        movups  oword ptr [dst + $10], xmm0
+        movups  oword ptr [dst + $20], xmm0
+        movups  oword ptr [dst + $30], xmm0
+        add     dst, $40
+@sml40: test    dl, $20
+        jz      @sml20
+        movups  oword ptr [dst], xmm0
+        movups  oword ptr [dst + $10], xmm0
+        add     dst, $20
+@sml20: test    dl, $10
+        jz      @sml10
+        movups  oword ptr [dst], xmm0
+@sml10: movups  oword ptr [r8 - 16], xmm0 // last 16 bytes (may be overlapping)
+        ret
+@abv255:{$ifdef WITH_ERMS}
+        cmp     rax, r9                   // non-temporal move > 512KB
+        {$ifdef ASMX64AVXNOCONST}
+        jae     @avx
+        {$else}
+        jae     @sse2
+        {$endif ASMX64AVXNOCONST}
+        // 256..512K could use the "rep stosb" ERMSB pattern on all CPUs
+        cld
+        {$ifdef WIN64ABI}
+        mov     r8, rdi
+        mov     rdi, dst
+        mov     rcx, cnt
+        rep     stosb
+        mov     rdi, r8
+        {$else}
+        mov     rcx, cnt
+        rep stosb
+        {$endif WIN64ABI}
+        ret
+        {$endif WITH_ERMS}
+@sse2:  movups  oword ptr [dst], xmm0  // first unaligned 16 bytes
+        lea     rdx, [dst + rdx - 1]
+        and     rdx, -16
+        add     dst, 16
+        and     dst, -16               // dst is 16-bytes aligned
+        sub     dst, rdx
+        jnb     @last
+        cmp     r10, r9
+        jae     @sse2nt                // bypass cache for cnt>512KB
+        jmp     @reg
+        {$ifdef ASMX64AVXNOCONST}
+@avx:   test    byte ptr [rip + X64CpuFeatures], 1 shl cpuAVX
+        jz      @sse2
+        movups  oword ptr [dst], xmm0  // first unaligned 1..16 bytes
+        add     dst, 16
+        and     dst, -16
+        movaps  oword ptr [dst], xmm0  // aligned 17..32 bytes
+        vinsertf128 ymm0, ymm0, xmm0, 1
+        add     dst, 16
+        and     dst, -32               // dst is 32-bytes aligned
+        mov     rdx, r8
+        and     rdx, -32
+        sub     dst, rdx
+        cmp     r10, r9
+        jb      @avxreg
+        jmp     @avxnt
+        {$endif ASMX64AVXNOCONST}
+        // temporal SSE2 loop
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@reg:   movaps  oword ptr [rdx + dst], xmm0  // regular loop
+        add     dst, 16
+        jnz     @reg
+@last:  movups  oword ptr [r8 - 16], xmm0 // last unaligned 16 bytes
+        ret
+        // non-temporal SSE2 loop
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@sse2nt:movntdq [rdx + dst], xmm0      // non-temporal loop
+        add     dst, 16
+        jnz     @sse2nt
+        sfence
+        movups  oword ptr [r8 - 16], xmm0
+        ret
+        {$ifdef ASMX64AVXNOCONST}
+        // temporal AVX loop
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@avxreg:vmovaps yword ptr [rdx + dst], ymm0  // regular loop
+        add     dst, 32
+        jnz     @avxreg
+@avxok: vmovups yword ptr [r8 - 32], ymm0    // last unaligned 32 bytes
+        vzeroupper
+        ret
+        // non-temporal AVX loop
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+        {$ifdef WIN64}
+@avxnt: vmovntps [rdx + rcx], ymm0 // non-temporal loop - rcx=dst on Win64
+        {$else}
+@avxnt: vmovntps [rdx + rdi], ymm0 // non-temporal loop - rdi=dst on POSIX
+        {$endif WIN64}
+        add      dst, 32
+        jnz      @avxnt
+        sfence
+        jmp      @avxok
+        {$endif ASMX64AVXNOCONST}
+        // dedicated branchless sub-functions for 0..8 bytes
+{$ifdef FPC} align 8 {$else} .align 8 {$endif}
+@jmptab:dq @00, @01, @02, @03, @04, @05, @06, @07, @08
+@07:    mov     dword ptr [dst + 3], eax
+@03:    mov     word ptr [dst + 1], ax
+@01:    mov     byte ptr [dst], al
+        ret
+@06:    mov     dword ptr [dst + 2], eax
+@02:    mov     word ptr [dst], ax
+        ret
+@05:    mov     byte ptr [dst + 4], al
+@04:    mov     dword ptr [dst], eax
+end;
+
+function crc32fasttab(crc: cardinal; buf: PAnsiChar; len: cardinal;
+  tab: PCrc32tab): cardinal;
+{$ifdef FPC} nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        {$ifdef SYSVABI}
+        mov     r8, rdx
+        mov     r9, tab
+        {$endif SYSVABI}
+        mov     eax, crc
+        xor     ecx, ecx
+        test    buf, buf // crc=eax buf=rdx/rsi len=r8 tab=r9
+        jz      @z
+        neg     r8
+        jz      @z
+        not     eax
+        cmp     r8, -8
+        jb      @head
+@sml:   mov     cl, byte ptr [buf]
+        add     buf, 1
+        xor     cl, al
+        shr     eax, 8
+        xor     eax, dword ptr [rcx * 4 + r9]
+        add     r8, 1
+        jnz     @sml
+@0:     not     eax
+@z:     ret
+@head:  {$ifdef SYSVABI}
+        test    sil, 7
+        {$else}
+        test    dl, 7
+        {$endif SYSVABI}
+        jz      @align
+        mov     cl, byte ptr [buf]
+        add     buf, 1
+        xor     cl, al
+        shr     eax, 8
+        xor     eax, dword ptr [rcx * 4 + r9]
+        add     r8, 1
+        jnz     @head
+        not     eax
+        ret
+@align: sub     buf, r8
+        add     r8, 8
+        jg      @done
+        push    rbx
+@by8:   mov     r10d, eax
+        mov     rcx, qword ptr [buf + r8 - 8]
+        xor     r10, rcx
+        shr     rcx, 32
+        movzx   ebx, cl
+        mov     eax, dword ptr [rbx * 4 + r9 + 1024 * 3]
+        movzx   ebx, ch
+        shr     ecx, 16
+        xor     eax, dword ptr [rbx * 4 + r9 + 1024 * 2]
+        movzx   ebx, cl
+        xor     eax, dword ptr [rbx * 4 + r9 + 1024 * 1]
+        movzx   ebx, ch
+        xor     eax, dword ptr [rbx * 4 + r9 + 1024 * 0]
+        mov     rcx, r10
+        movzx   ebx, cl
+        xor     eax, dword ptr [rbx * 4 + r9 + 1024 * 7]
+        movzx   ebx, ch
+        shr     ecx, 16
+        xor     eax, dword ptr [rbx * 4 + r9 + 1024 * 6]
+        movzx   ebx, cl
+        xor     eax, dword ptr [rbx * 4 + r9 + 1024 * 5]
+        movzx   ebx, ch
+        xor     eax, dword ptr [rbx * 4 + r9 + 1024 * 4]
+        add     r8, 8
+        jle     @by8
+        xor     ecx, ecx
+        pop     rbx
+@done:  sub     r8, 8
+        jge     @e
+@tail:  mov     cl, byte ptr [buf + r8]
+        xor     cl, al
+        shr     eax, 8
+        xor     eax, dword ptr [rcx * 4 + r9]
+        add     r8, 1
+        jnz     @tail
+@e:     not     eax
+end;
+
+function StrInt32(P: PAnsiChar; val: PtrInt): PAnsiChar;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     r10, val
+        sar     r10, 63         // r10=0 if val>=0 or -1 if val<0
+        xor     val, r10
+        sub     val, r10        // val=abs(val)
+        mov     rax, val
+        cmp     val, 10
+        jb      @1              // direct process of common val<10
+        lea     r8, [rip + TwoDigitLookup]
+{$ifdef FPC} align 8 {$else} .align 8 {$endif}
+@s:     lea     P, [P - 2]
+        cmp     rax, 100
+        jb      @2
+        lea     r9, [rax * 2]
+        shr     rax, 2
+        mov     rdx, 2951479051793528259
+        mul     rdx  // use power of two reciprocal to avoid division
+        shr     rdx, 2
+        mov     rax, rdx
+        imul    rdx, -200
+        lea     rdx, [rdx + r8]
+        movzx   edx, word ptr [rdx + r9]
+        mov     word ptr [P], dx
+        cmp     rax, 10
+        jae     @s
+@1:     or      al, '0'
+        mov     byte ptr [P - 2], '-'
+        mov     byte ptr [P - 1], al
+        lea     rax, [P + r10 - 1]       // includes '-' if val<0
+        ret
+        {$ifdef FPC} align 8 {$else} .align 8 {$endif}
+@2:     movzx   eax, word ptr [r8 + rax * 2]
+        mov     byte ptr [P - 1], '-'
+        mov     word ptr [P], ax
+        lea     rax, [P + r10]           // includes '-' if val<0
+end;
+
+function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     rax, val
+        cmp     val, 10
+        jb      @1  // direct process of common val<10
+        lea     r8, [rip + TwoDigitLookup]
+@s:     lea     P, [P - 2]
+        cmp     rax, 100
+        jb      @2
+        lea     r9, [rax * 2]
+        shr     rax, 2
+        mov     rdx, 2951479051793528259
+        mul     rdx  // use power of two reciprocal to avoid division
+        shr     rdx, 2
+        mov     rax, rdx
+        imul    rdx, -200
+        add     rdx, r8
+        movzx   rdx, word ptr [rdx + r9]
+        mov     word ptr [P], dx
+        cmp     rax, 10
+        jae     @s
+@1:     sub     P, 1
+        or      al, '0'
+        mov     byte ptr [P], al
+@0:     mov     rax, P
+        ret
+@2:     movzx   eax, word ptr [r8 + rax * 2]
+        mov     word ptr [P], ax
+        mov     rax, P
+end;
+
+{$endif ASMX64}
+
+{$ifdef CPUX64ASM} /// proper compilation on FPC and Delphi XE7+
+
+{$ifdef FPC}
+
+procedure fpc_freemem; external name 'FPC_FREEMEM'; // access to RTL from asm
+
+procedure FastAssignNew(var d; s: pointer); nostackframe; assembler;
+asm
+        mov     rax, qword ptr [d]
+        mov     qword ptr [d], s
+        test    rax, rax
+        jz      @z
+        lea     d, qword ptr [rax - _STRRECSIZE] // for fpc_freemem() below
+        {$ifdef STRCNT32}
+        cmp     dword ptr [rax - _STRCNT], 0 // refcnt=-1 for const
+        jl      @z
+   lock dec     dword ptr [rax - _STRCNT]
+        {$else}
+        cmp     qword ptr [rax - _STRCNT], 0 // refcnt=-1 for const
+        jl      @z
+   lock dec     qword ptr [rax - _STRCNT]
+        {$endif STRCNT32}
+        jbe     fpc_freemem
+@z:
+end;
+
+procedure FastAssignNewNotVoid(var d; s: pointer);
+nostackframe; assembler;
+asm
+        mov     rax, qword ptr [d]
+        mov     qword ptr [d], s
+        lea     d, qword ptr [rax - _STRRECSIZE] // for fpc_freemem() below
+        {$ifdef STRCNT32}
+        cmp     dword ptr [rax - _STRCNT], 0 // refcnt=-1 for const
+        jl      @z
+   lock dec     dword ptr [rax - _STRCNT]
+        {$else}
+        cmp     qword ptr [rax - _STRCNT], 0 // refcnt=-1 for const
+        jl      @z
+   lock dec     qword ptr [rax - _STRCNT]
+        {$endif STRCNT32}
+        jbe     fpc_freemem
+@z:
+end;
+
+{$endif FPC}
+
+{
+  Some numbers, with CITIES_MAX=200000, deleting 1/128 entries
+  first column (3..23) is the max number of indexes[] chunk to rehash
+  #abc is the number of slots in the hash table
+  adjust=.. match DynArrayHashTableAdjust() time fixing the indexes
+  hash=ms is the time needed to hash input (not impacted by adjusting algorithm)
+  -> TDynArray.Delete move() now takes more time than the HashTable update :)
+  1. naive loop
+    for i := 0 to HashTableSize-1 do
+      if HashTable[i]>aArrayIndex then
+        dec(HashTable[i]);
+    3 #257  adjust=7.95ms 191.7MB/s hash=8us
+    23 #195075  adjust=4.27s 548.6MB/s hash=2.47ms
+  2. branchless pure pascal code is about 10x faster!
+    3 #257  adjust=670us 2.2GB hash=8us
+    23 #195075  adjust=520.85ms 4.3GB/s hash=2.45ms
+  3. SSE2 simd assembly makes about 3x improvement
+    3 #257  adjust=290us 5.1GB hash=8us
+    23 #195075  adjust=201.53ms 11.3GB/s hash=2.44ms
+  4. AVX2 simd assembly gives some additional 40% (on my iCore3 cpu)
+    3 #257  adjust=262us 5.6GB hash=8us
+    23 #195075  adjust=161.73ms 14.1GB/s hash=2.57ms
+}
+
+// brute force O(n) indexes fix after deletion (much faster than full ReHash)
+procedure DynArrayHashTableAdjust(P: PIntegerArray; deleted: integer; count: PtrInt);
+{$ifdef WIN64ABI}
+var
+  bak6, bak7, bak8: THash128;
+asm     // Windows x64 calling convention expects to preserve XMM6-XMM15
+        movups  dqword ptr [bak6], xmm6
+        movups  dqword ptr [bak7], xmm7
+        movups  dqword ptr [bak8], xmm8
+{$else}  {$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif}
+        mov     r8, rdx
+        mov     rcx, rdi
+        mov     rdx, rsi
+{$endif WIN64ABI}
+        xor     eax, eax    // reset eax high bits for setg al below
+        movq    xmm0, rdx   // xmm0 = 128-bit of quad deleted
+        pshufd  xmm0, xmm0, 0
+        test    cl, 3
+        jnz     @1  // paranoid: a dword dynamic array is always dword-aligned
+        // ensure P is 256-bit aligned (for avx2)
+@align: test    cl, 31
+        jz      @ok
+        cmp     dword ptr [rcx], edx
+        setg    al                     // P[]>deleted -> al=1, 0 otherwise
+        sub     dword ptr [rcx], eax   // branchless dec(P[])
+        add     rcx, 4
+        sub     r8, 1
+        jmp     @align
+@ok:    {$ifdef ASMX64AVXNOCONST}
+        test    byte ptr [rip + X64CpuFeatures], 1 shl cpuAVX2
+        jz      @sse2
+        vpshufd ymm0, ymm0, 0          // shuffle to ymm0 128-bit low lane
+        vperm2f128 ymm0, ymm0, ymm0, 0 // copy to ymm0 128-bit high lane
+        // avx process of 128 bytes (32 indexes) per loop iteration
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@avx2:  sub      r8, 32
+        vmovdqa  ymm1, [rcx]           // 4 x 256-bit process = 4 x 8 integers
+        vmovdqa  ymm3, [rcx + 32]
+        vmovdqa  ymm5, [rcx + 64]
+        vmovdqa  ymm7, [rcx + 96]
+        vpcmpgtd ymm2, ymm1, ymm0      // compare P[]>deleted -> -1, 0 otherwise
+        vpcmpgtd ymm4, ymm3, ymm0
+        vpcmpgtd ymm6, ymm5, ymm0
+        vpcmpgtd ymm8, ymm7, ymm0
+        vpaddd   ymm1, ymm1, ymm2      // adjust by adding -1 / 0
+        vpaddd   ymm3, ymm3, ymm4
+        vpaddd   ymm5, ymm5, ymm6
+        vpaddd   ymm7, ymm7, ymm8
+        vmovdqa  [rcx], ymm1
+        vmovdqa  [rcx + 32], ymm3
+        vmovdqa  [rcx + 64], ymm5
+        vmovdqa  [rcx + 96], ymm7
+        add      rcx, 128
+        cmp      r8, 32
+        jae      @avx2
+        vzeroupper
+        jmp      @2
+        {$endif ASMX64AVXNOCONST}
+        // SSE2 process of 64 bytes (16 indexes) per loop iteration
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@sse2:  sub     r8, 16
+        movaps  xmm1, dqword [rcx]     // 4 x 128-bit process = 4 x 4 integers
+        movaps  xmm3, dqword [rcx + 16]
+        movaps  xmm5, dqword [rcx + 32]
+        movaps  xmm7, dqword [rcx + 48]
+        movaps  xmm2, xmm1             // keep copy for paddd below
+        movaps  xmm4, xmm3
+        movaps  xmm6, xmm5
+        movaps  xmm8, xmm7
+        pcmpgtd xmm1, xmm0             // quad compare P[]>deleted -> -1 / 0
+        pcmpgtd xmm3, xmm0
+        pcmpgtd xmm5, xmm0
+        pcmpgtd xmm7, xmm0
+        paddd   xmm1, xmm2             // quad adjust by adding -1 / 0
+        paddd   xmm3, xmm4
+        paddd   xmm5, xmm6
+        paddd   xmm7, xmm8
+        movaps  dqword [rcx], xmm1     // quad store back
+        movaps  dqword [rcx + 16], xmm3
+        movaps  dqword [rcx + 32], xmm5
+        movaps  dqword [rcx + 48], xmm7
+        add     rcx, 64
+        cmp     r8, 16
+        jae     @sse2
+        jmp     @2
+        // trailing indexes (never appearing within DYNARRAYHASH_PO2 range)
+@1:     sub     r8, 1
+        cmp     dword ptr [rcx + r8 * 4], edx
+        setg    al
+        sub     dword ptr [rcx + r8 * 4], eax
+@2:     test    r8, r8
+        jnz     @1
+{$ifdef WIN64ABI}
+        movups  xmm6, dqword ptr [bak6]
+        movups  xmm7, dqword ptr [bak7]
+        movups  xmm8, dqword ptr [bak8]
+{$endif WIN64ABI}
+end;
+
+// DYNARRAYHASH_16BIT version for 16-bit HashTable[] - no AVX2 since count < 64K
+procedure DynArrayHashTableAdjust16(P: PWordArray; deleted: cardinal; count: PtrInt);
+{$ifdef WIN64ABI}
+var
+  bak6, bak7, bak8: THash128;
+asm     // Windows x64 calling convention expects to preserve XMM6-XMM15
+        movups  dqword ptr [bak6], xmm6
+        movups  dqword ptr [bak7], xmm7
+        movups  dqword ptr [bak8], xmm8
+{$else} {$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif}
+        mov     r8, rdx
+        mov     rcx, rdi
+        mov     rdx, rsi
+{$endif WIN64ABI}
+        mov     eax, deleted
+        shl     eax, 16     // for pshufd (inline asm doesn't know about pshufw)
+        or      edx, eax               // edx = 32-bit of 2x 16-bit deleted
+        movq    xmm0, rdx              // xmm0 = 128-bit of 8x deleted
+        pshufd  xmm0, xmm0, 0
+        xor     eax, eax               // reset eax high bits for setg al below
+        test    cl, 1
+        jnz     @1  // paranoid: a dword dynamic array is always word-aligned
+        // ensure P is 128-bit aligned (for movaps)
+@align: test    cl, 15
+        jz      @sse2
+        cmp     word ptr [rcx], dx
+        setg    al                     // P[]>deleted -> al=1, 0 otherwise
+        sub     word ptr [rcx], ax     // branchless dec(P[])
+        add     rcx, 2
+        sub     r8, 1
+        jmp     @align
+        // SSE2 process of 64 bytes (32 indexes) per loop iteration
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@sse2:  sub     r8, 32
+        movaps  xmm1, dqword [rcx]     // 4 x 128-bit process = 4 x 8 words
+        movaps  xmm3, dqword [rcx + 16]
+        movaps  xmm5, dqword [rcx + 32]
+        movaps  xmm7, dqword [rcx + 48]
+        movaps  xmm2, xmm1             // keep copy for paddd below
+        movaps  xmm4, xmm3
+        movaps  xmm6, xmm5
+        movaps  xmm8, xmm7
+        pcmpgtw xmm1, xmm0             // 8x compare P[]>deleted -> -1 / 0
+        pcmpgtw xmm3, xmm0
+        pcmpgtw xmm5, xmm0
+        pcmpgtw xmm7, xmm0
+        paddw   xmm1, xmm2             // 8x adjust by adding -1 / 0
+        paddw   xmm3, xmm4
+        paddw   xmm5, xmm6
+        paddw   xmm7, xmm8
+        movaps  dqword [rcx], xmm1     // 8x store back
+        movaps  dqword [rcx + 16], xmm3
+        movaps  dqword [rcx + 32], xmm5
+        movaps  dqword [rcx + 48], xmm7
+        add     rcx, 64
+        cmp     r8, 32
+        jae     @sse2
+        jmp     @2
+        // trailing indexes (never appearing within DYNARRAYHASH_PO2 range)
+@1:     sub     r8, 1
+        cmp     word ptr [rcx + r8 * 4], dx
+        setg    al
+        sub     word ptr [rcx + r8 * 4], ax
+@2:     test    r8, r8
+        jnz     @1
+{$ifdef WIN64ABI}
+        movups  xmm6, dqword ptr [bak6]
+        movups  xmm7, dqword ptr [bak7]
+        movups  xmm8, dqword ptr [bak8]
+{$endif WIN64ABI}
+end;
+
+{$ifdef ASMX64AVXNOCONST}
+// AVX2 ASM .align 32 for const is not available on Delphi :(
+
+// adapted from https://github.com/simdjson/simdjson - Apache License 2.0
+function IsValidUtf8Avx2(source: PUtf8Char; sourcelen: PtrInt): boolean;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        test    source, source
+        jz      @ok
+        test    sourcelen, sourcelen
+        jle     @ok
+        {$ifdef WIN64ABI} // Win64 ABI doesn't consider rsi/rdi as volatile
+        push    rsi
+        push    rdi
+        {$endif WIN64ABI}
+        push    rbp
+        mov     r8, source
+        mov     rdx, sourcelen
+        mov     rsi, r8
+        mov     ecx, 64
+        mov     rax, rsi
+        mov     rdi, rdx
+        mov     rbp, rsp
+        and     rsp, 0FFFFFFFFFFFFFFE0H // align stack at 32 bytes
+        sub     rsp, 160
+        {$ifdef WIN64ABI}
+        movaps  dqword ptr [rsp + 00H], xmm6
+        movaps  dqword ptr [rsp + 10H], xmm7
+        movaps  dqword ptr [rsp + 20H], xmm8
+        movaps  dqword ptr [rsp + 30H], xmm9
+        movaps  dqword ptr [rsp + 40H], xmm10
+        movaps  dqword ptr [rsp + 50H], xmm11
+        movaps  dqword ptr [rsp + 60H], xmm12
+        movaps  dqword ptr [rsp + 70H], xmm13
+        movaps  dqword ptr [rsp + 80H], xmm14
+        movaps  dqword ptr [rsp + 90H], xmm15
+        sub     rsp, 100H
+        {$endif WIN64ABI}
+        cmp     rdx, 64
+        cmovnc  rcx, rdx
+        sub     rcx, 64
+        je      @small
+        vpxor   xmm3, xmm3, xmm3
+        xor     esi, esi
+        vmovdqu ymm7,  yword ptr [rip + @0f]
+        vmovdqu ymm15, yword ptr [rip + @_6]
+        vmovdqu ymm14, yword ptr [rip + @_7]
+        vmovdqu ymm13, yword ptr [rip + @_8]
+        vmovdqa ymm5, ymm3
+        vmovdqa ymm2, ymm3
+        // main processing loop, 64 bytes per iteration
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@loop:  vmovdqu xmm6, oword ptr [rax + rsi]
+        vinserti128 ymm0, ymm6, [rax + rsi + 10H], 01H
+        vmovdqu xmm6, oword ptr [rax + rsi + 20H]
+        vinserti128 ymm1, ymm6, [rax + rsi + 30H], 01H
+        add     rsi, 64
+        vpor    ymm4, ymm1, ymm0
+        vpmovmskb rdx, ymm4 // check set MSB of each 64 bytes
+        test    edx, edx
+        jne     @check
+        vpor    ymm2, ymm5, ymm2
+        vmovdqa ymm4, ymm2
+        cmp     rcx, rsi
+        ja      @loop
+        // process trailing 0..63 bytes
+@trail: sub     rdi, rsi
+        jz      @ended
+        add     rsi, rax
+        vmovdqu xmm0, oword ptr [rip + @20]
+        lea     rdx, qword ptr [rsp + 60H] // copy on stack with space padding
+        sub     rsi, rdx
+        vmovdqa oword ptr [rdx], xmm0
+        vmovdqa oword ptr [rdx + 10H], xmm0
+        vmovdqa oword ptr [rdx + 20H], xmm0
+        vmovdqa oword ptr [rdx + 30H], xmm0
+@by8:   sub     rdi, 8
+        jb      @by1
+        mov     rax, qword ptr [rsi + rdx]
+        mov     qword ptr [rdx], rax
+        add     rdx, 8 // in-order copy to preserve UTF-8 encoding
+        jmp     @by8
+@by1:   add     rdi, 8
+        jz      @0
+@sml:   mov     al, byte ptr [rsi + rdx]
+        mov     byte ptr [rdx], al
+        add     rdx, 1
+        sub     rdi, 1
+        jnz     @sml
+@0:     vmovdqa ymm1, yword ptr [rsp + 60H]
+        vmovdqa ymm2, yword ptr [rsp + 80H]
+        vpor    ymm0, ymm1, ymm2
+        vpmovmskb rax, ymm0 // check any set MSB
+        test    eax, eax
+        jne     @last
+@ended: vpor    ymm5, ymm5, ymm4
+@final: vptest  ymm5, ymm5
+        sete    al
+        vzeroupper
+        {$ifdef WIN64ABI}
+        add     rsp, 100H
+        movaps  xmm6, dqword ptr [rsp + 00H]
+        movaps  xmm7, dqword ptr [rsp + 10H]
+        movaps  xmm8, dqword ptr [rsp + 20H]
+        movaps  xmm9, dqword ptr [rsp + 30H]
+        movaps  xmm10, dqword ptr [rsp + 40H]
+        movaps  xmm11, dqword ptr [rsp + 50H]
+        movaps  xmm12, dqword ptr [rsp + 60H]
+        movaps  xmm13, dqword ptr [rsp + 70H]
+        movaps  xmm14, dqword ptr [rsp + 80H]
+        movaps  xmm15, dqword ptr [rsp + 90H]
+        leave      // mov rsp,rbp + pop rbp
+        pop     rdi
+        pop     rsi
+        {$else}
+        leave
+        {$endif WIN64ABI}
+        ret
+@ok:    mov     al, 1
+        ret
+@small: vpxor   xmm4, xmm4, xmm4
+        xor     esi, esi
+        vmovdqa ymm3, ymm4
+        vmovdqa ymm5, ymm4
+        jmp     @trail
+        // validate UTF-8 extra bytes from main loop
+{$ifdef FPC} align 8 {$else} .align 8 {$endif}
+@check: vpsrlw  ymm9, ymm0, 4
+        vpsrlw  ymm12, ymm1, 4
+        vperm2i128 ymm3, ymm3, ymm0, 21H
+        vpalignr ymm5, ymm0, ymm3, 0FH
+        vpalignr ymm11, ymm0, ymm3, 0EH
+        vpsubusb ymm11, ymm11, yword ptr [rip + @_9]
+        vpalignr ymm3, ymm0, ymm3, 0DH
+        vperm2i128 ymm0, ymm0, ymm1, 21H
+        vpsubusb ymm3, ymm3, yword ptr [rip + @_10]
+        vpalignr ymm8, ymm1, ymm0, 0FH
+        vpsrlw  ymm10, ymm5, 4
+        vpand   ymm5, ymm7, ymm5
+        vpsrlw  ymm6, ymm8, 4
+        vpalignr ymm4, ymm1, ymm0, 0EH
+        vpsubusb ymm4, ymm4, yword ptr [rip + @_9]
+        vpalignr ymm0, ymm1, ymm0, 0DH
+        vpsubusb ymm0, ymm0, yword ptr [rip + @_10]
+        vpand   ymm10, ymm10, ymm7
+        vpand   ymm6, ymm6, ymm7
+        vpand   ymm8, ymm7, ymm8
+        vpor    ymm3, ymm3, ymm11
+        vpor    ymm0, ymm4, ymm0
+        vpxor   xmm11, xmm11, xmm11
+        vpshufb ymm10, ymm15, ymm10
+        vpshufb ymm5, ymm14, ymm5
+        vpand   ymm9, ymm9, ymm7
+        vpshufb ymm6, ymm15, ymm6
+        vpshufb ymm8, ymm14, ymm8
+        vpand   ymm12, ymm12, ymm7
+        vpand   ymm5, ymm5, ymm10
+        vpcmpgtb ymm3, ymm3, ymm11
+        vpcmpgtb ymm0, ymm0, ymm11
+        vpshufb ymm9, ymm13, ymm9
+        vpand   ymm3, ymm3, yword ptr [rip + @_11]
+        vpand   ymm0, ymm0, yword ptr [rip + @_11]
+        vpshufb ymm12, ymm13, ymm12
+        vpand   ymm6, ymm6, ymm8
+        vpand   ymm9, ymm5, ymm9
+        vpsubusb ymm5, ymm1, yword ptr [rip + @_12]
+        vpand   ymm12, ymm6, ymm12
+        vpxor   ymm9, ymm3, ymm9
+        vmovdqa ymm3, ymm1
+        vpxor   ymm12, ymm0, ymm12
+        vpor    ymm9, ymm9, ymm12
+        vpor    ymm2, ymm9, ymm2
+        vmovdqa ymm4, ymm2
+        cmp     rcx, rsi
+        ja      @loop
+        jmp     @trail
+        // validate UTF-8 extra bytes from input ending
+{$ifdef FPC} align 8 {$else} .align 8 {$endif}
+@last:  vmovdqu ymm5, yword ptr [rip + @0f]
+        vperm2i128 ymm3, ymm3, ymm1, 21H
+        vmovdqu ymm9, yword ptr [rip + @_7]
+        vpsrlw  ymm11, ymm1, 4
+        vpalignr ymm0, ymm1, ymm3, 0FH
+        vmovdqu ymm13, yword ptr [rip + @_10]
+        vmovdqu ymm14, yword ptr [rip + @_9]
+        vpsrlw  ymm6, ymm0, 4
+        vpand   ymm0, ymm5, ymm0
+        vpand   ymm11, ymm11, ymm5
+        vmovdqu ymm7, yword ptr [rip + @_6]
+        vpshufb ymm10, ymm9, ymm0
+        vpalignr ymm0, ymm1, ymm3, 0EH
+        vpand   ymm6, ymm6, ymm5
+        vmovdqu ymm8, yword ptr [rip + @_8]
+        vpalignr ymm3, ymm1, ymm3, 0DH
+        vperm2i128 ymm1, ymm1, ymm2, 21H
+        vpsubusb ymm0, ymm0, ymm14
+        vpsubusb ymm12, ymm3, ymm13
+        vpalignr ymm3, ymm2, ymm1, 0FH
+        vpshufb ymm6, ymm7, ymm6
+        vpsrlw  ymm15, ymm3, 4
+        vpand   ymm3, ymm5, ymm3
+        vpor    ymm0, ymm0, ymm12
+        vpshufb ymm9, ymm9, ymm3
+        vpsrlw  ymm3, ymm2, 4
+        vpand   ymm15, ymm15, ymm5
+        vpand   ymm5, ymm3, ymm5
+        vpalignr ymm3, ymm2, ymm1, 0EH
+        vpxor   xmm12, xmm12, xmm12
+        vpalignr ymm1, ymm2, ymm1, 0DH
+        vpsubusb ymm3, ymm3, ymm14
+        vpshufb ymm11, ymm8, ymm11
+        vpsubusb ymm1, ymm1, ymm13
+        vpcmpgtb ymm0, ymm0, ymm12
+        vpshufb ymm7, ymm7, ymm15
+        vpor    ymm1, ymm3, ymm1
+        vpshufb ymm8, ymm8, ymm5
+        vpsubusb ymm5, ymm2, yword ptr [rip + @_12]
+        vmovdqu ymm2, yword ptr [rip + @_11]
+        vpcmpgtb ymm1, ymm1, ymm12
+        vpand   ymm6, ymm6, ymm10
+        vpand   ymm7, ymm7, ymm9
+        vpand   ymm0, ymm0, ymm2
+        vpand   ymm11, ymm6, ymm11
+        vpand   ymm8, ymm7, ymm8
+        vpxor   ymm0, ymm0, ymm11
+        vpor    ymm5, ymm4, ymm5
+        vpand   ymm1, ymm1, ymm2
+        vpxor   ymm1, ymm1, ymm8
+        vpor    ymm0, ymm0, ymm1
+        vpor    ymm5, ymm0, ymm5
+        jmp     @final
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@20:    dq 2020202020202020H
+        dq 2020202020202020H
+{$ifdef FPC} align 32 {$else} .align 16 {Delphi doesn't allow 32 :(} {$endif}
+@0f:    dq 0F0F0F0F0F0F0F0FH
+        dq 0F0F0F0F0F0F0F0FH
+        dq 0F0F0F0F0F0F0F0FH
+        dq 0F0F0F0F0F0F0F0FH
+@_6:    dq 0202020202020202H
+        dq 4915012180808080H
+        dq 0202020202020202H
+        dq 4915012180808080H
+@_7:    dq 0CBCBCB8B8383A3E7H
+        dq 0CBCBDBCBCBCBCBCBH
+        dq 0CBCBCB8B8383A3E7H
+        dq 0CBCBDBCBCBCBCBCBH
+@_8:    dq 0101010101010101H
+        dq 01010101BABAAEE6H
+        dq 0101010101010101H
+        dq 01010101BABAAEE6H
+@_9:    dq 0DFDFDFDFDFDFDFDFH
+        dq 0DFDFDFDFDFDFDFDFH
+        dq 0DFDFDFDFDFDFDFDFH
+        dq 0DFDFDFDFDFDFDFDFH
+@_10:   dq 0EFEFEFEFEFEFEFEFH
+        dq 0EFEFEFEFEFEFEFEFH
+        dq 0EFEFEFEFEFEFEFEFH
+        dq 0EFEFEFEFEFEFEFEFH
+@_11:   dq 8080808080808080H
+        dq 8080808080808080H
+        dq 8080808080808080H
+        dq 8080808080808080H
+@_12:   db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH
+        db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH
+        db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0FFH
+        db 0FFH, 0FFH, 0FFH, 0FFH, 0FFH, 0EFH, 0DFH, 0BFH
+end;
+
+// inspired by https://github.com/aklomp/base64 - BSD-2-Clause License
+// - less unrolled, but (much) faster thanks to manually tuned asm
+
+procedure Base64EncodeAvx2(var b: PAnsiChar; var blen: PtrUInt;
+  var b64: PAnsiChar);
+{$ifdef WIN64ABI}
+var
+  bak6, bak7, bak8, bak9, bak10, bak11, bak12, bak13, bak14, bak15: THash128;
+asm     // Windows x64 calling convention expects to preserve XMM6-XMM15
+        movups  dqword ptr [bak6], xmm6
+        movups  dqword ptr [bak7], xmm7
+        movups  dqword ptr [bak8], xmm8
+        movups  dqword ptr [bak9], xmm9
+        movups  dqword ptr [bak10], xmm10
+        movups  dqword ptr [bak11], xmm11
+        movups  dqword ptr [bak12], xmm12
+        movups  dqword ptr [bak13], xmm13
+        movups  dqword ptr [bak14], xmm14
+        movups  dqword ptr [bak15], xmm15
+        push    rsi         // Win64 ABI doesn't consider rsi/rdi as volatile
+        push    rdi
+        mov     rsi, r8     // rsi = b64
+        mov     r8, rdx     // r8 = blen
+        mov     rdi, rcx    // rdi = b
+{$else} {$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif}
+        mov     r8, rsi     // r8 = blen
+        mov     rsi, rdx    // rsi = b64   rdi = b
+{$endif WIN64ABI}
+        mov     rcx, qword ptr [r8]
+        cmp     rcx, 31
+        jbe     @done
+        lea     rdx, qword ptr [rcx - 4]
+        vmovdqu ymm0,  yword ptr [rip + @c9]
+        mov     r10, 0AAAAAAAAAAAAAAABH
+        vmovdqu ymm7,  yword ptr [rip + @c10]
+        mov     rax, rdx
+        vmovdqu ymm5,  yword ptr [rip + @c11]
+        vmovdqu ymm8,  yword ptr [rip + @c12]
+        mul     r10
+        vmovdqu ymm9,  yword ptr [rip + @c13]
+        vmovdqu ymm10, yword ptr [rip + @c14]
+        vmovdqu ymm6,  yword ptr [rip + @c16]
+        vmovdqu ymm4,  yword ptr [rip + @c15]
+        vmovdqu ymm11, yword ptr [rip + @c17]
+        shr     rdx, 4                  // rdx = rounds = (blen - 4) / 24
+        lea     rax, qword ptr [rdx + rdx * 2]
+        shl     rax, 3
+        sub     rcx, rax
+        mov     qword ptr [r8], rcx     // blen = rounds * 24
+        mov     rcx, qword ptr [rdi]    // rcx = [rdi] = b
+        mov     rax, qword ptr [rsi]    // rax = [rsi] = b64
+        // initial 24 bytes output process
+        vmovdqu xmm3, oword ptr [rcx]
+        vinserti128 ymm1, ymm3, oword ptr [rcx + 16], 1
+        vpermd  ymm1, ymm0, ymm1
+        vpshufb ymm1, ymm1, ymm7
+        vpand   ymm0, ymm5, ymm1
+        vpmulhuw ymm2, ymm0, ymm8
+        vpand   ymm0, ymm9, ymm1
+        vpmullw ymm0, ymm10, ymm0
+        vpor    ymm0, ymm0, ymm2
+        vpcmpgtb ymm2, ymm0, ymm6
+        vpsubusb ymm1, ymm0, ymm4
+        vpsubb  ymm1, ymm1, ymm2
+        vpshufb ymm1, ymm11, ymm1
+        vpaddb  ymm0, ymm1, ymm0
+        vmovdqu oword ptr [rax], xmm0
+        vextracti128 oword ptr [rax + 16], ymm0, 1
+        add     rax, 32
+        add     rcx, 20
+        sub     rdx, 1
+        je      @10
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+        // process 48 input bytes per loop iteration into 64 encoded bytes
+@9:     cmp     rdx, 1
+        je      @12
+        // whole loop logic is fully interlaced to unleash future CPU potential
+        vmovdqu xmm1, oword ptr [rcx]
+        vmovdqu xmm3, oword ptr [rcx + 24]
+        vinserti128 ymm1, ymm1, oword ptr [rcx + 16], 1
+        vinserti128 ymm3, ymm3, oword ptr [rcx + 24 + 16], 1
+        vpshufb ymm1, ymm1, ymm7
+        vpshufb ymm3, ymm3, ymm7
+        vpand   ymm0, ymm5, ymm1
+        vpand   ymm12, ymm5, ymm3
+        vpmulhuw ymm2, ymm0, ymm8
+        vpmulhuw ymm14, ymm12, ymm8
+        vpand   ymm0, ymm9, ymm1
+        vpand   ymm12, ymm9, ymm3
+        vpmullw ymm0, ymm10, ymm0
+        vpmullw ymm12, ymm10, ymm12
+        vpor    ymm0, ymm0, ymm2
+        vpor    ymm12, ymm12, ymm14
+        vpcmpgtb ymm2, ymm0, ymm6
+        vpcmpgtb ymm15, ymm12, ymm6
+        vpsubusb ymm1, ymm0, ymm4
+        vpsubusb ymm14, ymm12, ymm4
+        vpsubb  ymm1, ymm1, ymm2
+        vpsubb  ymm14, ymm14, ymm15
+        vpshufb ymm1, ymm11, ymm1
+        vpshufb ymm14, ymm11, ymm14
+        vpaddb  ymm0, ymm1, ymm0
+        vpaddb  ymm12, ymm14, ymm12
+        vmovdqu oword ptr [rax], xmm0
+        vextracti128 oword ptr [rax + 16], ymm0, 1
+        vmovdqu oword ptr [rax + 32], xmm12
+        vextracti128 oword ptr [rax + 48], ymm12, 1
+        add     rcx, 48
+        add     rax, 64
+        sub     rdx, 2
+        jne     @9
+@10:    add     rcx, 4
+        mov     qword ptr [rsi], rax
+        mov     qword ptr [rdi], rcx
+        vzeroupper
+        {$ifdef WIN64ABI}
+        jmp     @done
+        {$else}
+        ret
+        {$endif WIN64ABI}
+        // trailing 24 bytes
+@12:    vmovdqu xmm3, oword ptr [rcx]
+        vinserti128 ymm1, ymm3, oword ptr [rcx + 16], 1
+        vpshufb ymm1, ymm1, ymm7
+        vpand   ymm0, ymm5, ymm1
+        vpmulhuw ymm8, ymm0, ymm8
+        vpand   ymm0, ymm9, ymm1
+        vpmullw ymm0, ymm10, ymm0
+        vpor    ymm0, ymm0, ymm8
+        vpcmpgtb ymm6, ymm0, ymm6
+        vpsubusb ymm4, ymm0, ymm4
+        vpsubb  ymm4, ymm4, ymm6
+        vpshufb ymm11, ymm11, ymm4
+        vpaddb  ymm0, ymm11, ymm0
+        vmovdqu oword ptr [rax], xmm0
+        vextracti128 oword ptr [rax + 16], ymm0, 1
+        add     rcx, 24
+        add     rax, 32
+        jmp     @10
+{$ifdef FPC} align 32 {$else} .align 16 {Delphi doesn't allow 32 :(} {$endif}
+@c9:    dq 0000000000000000H
+        dq 0000000200000001H
+        dq 0000000400000003H
+        dq 0000000600000005H
+@c10:   dq 0809070805060405H
+        dq 0E0F0D0E0B0C0A0BH
+        dq 0405030401020001H
+        dq 0A0B090A07080607H
+@c11:   dq 0FC0FC000FC0FC00H
+        dq 0FC0FC000FC0FC00H
+        dq 0FC0FC000FC0FC00H
+        dq 0FC0FC000FC0FC00H
+@c12:   dq 0400004004000040H
+        dq 0400004004000040H
+        dq 0400004004000040H
+        dq 0400004004000040H
+@c13:   dq 003F03F0003F03F0H
+        dq 003F03F0003F03F0H
+        dq 003F03F0003F03F0H
+        dq 003F03F0003F03F0H
+@c14:   dq 0100001001000010H
+        dq 0100001001000010H
+        dq 0100001001000010H
+        dq 0100001001000010H
+@c15:   dq 3333333333333333H
+        dq 3333333333333333H
+        dq 3333333333333333H
+        dq 3333333333333333H
+@c16:   dq 1919191919191919H
+        dq 1919191919191919H
+        dq 1919191919191919H
+        dq 1919191919191919H
+@c17:   dq 0FCFCFCFCFCFC4741H
+        dq 0000F0EDFCFCFCFCH
+        dq 0FCFCFCFCFCFC4741H
+        dq 0000F0EDFCFCFCFCH
+@done:  {$ifdef WIN64ABI}
+        pop     rdi
+        pop     rsi
+        movups  xmm6, dqword ptr [bak6]
+        movups  xmm7, dqword ptr [bak7]
+        movups  xmm8, dqword ptr [bak8]
+        movups  xmm9, dqword ptr [bak9]
+        movups  xmm10, dqword ptr [bak10]
+        movups  xmm11, dqword ptr [bak11]
+        movups  xmm12, dqword ptr [bak12]
+        movups  xmm13, dqword ptr [bak13]
+        movups  xmm14, dqword ptr [bak14]
+        movups  xmm15, dqword ptr [bak15]
+        {$endif WIN64ABI}
+end;
+
+procedure Base64DecodeAvx2(var b64: PAnsiChar; var b64len: PtrInt;
+  var b: PAnsiChar);
+{$ifdef WIN64ABI}
+var
+  bak6, bak7, bak8, bak9, bak10, bak11, bak12: THash128;
+asm     // Windows x64 calling convention expects to preserve XMM6-XMM15
+        movups  dqword ptr [bak6], xmm6
+        movups  dqword ptr [bak7], xmm7
+        movups  dqword ptr [bak8], xmm8
+        movups  dqword ptr [bak9], xmm9
+        movups  dqword ptr [bak10], xmm10
+        movups  dqword ptr [bak11], xmm11
+        movups  dqword ptr [bak12], xmm12
+        push    rsi         // Win64 ABI doesn't consider rsi/rdi as volatile
+        push    rdi
+        mov     rsi, rdx
+        mov     rdx, r8
+        mov     rdi, rcx
+{$else} {$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif}
+{$endif WIN64ABI}
+        // rcx/rdi=b64 rdx/rsi=b64len r8/rdx=b
+        // on decoding error, b64 will point to the faulty input
+        mov     r8, qword ptr [rsi]
+        cmp     r8, 44
+        jbe     @done
+        lea     r9, qword ptr [r8 - 0DH]
+        vmovdqu ymm1, yword ptr [rip + @c0]
+        vmovdqu ymm5, yword ptr [rip + @c1]
+        mov     rax, r9
+        and     r9, 0FFFFFFFFFFFFFFE0H
+        vmovdqu ymm4, yword ptr [rip + @c2]
+        vmovdqu ymm9, yword ptr [rip + @c3]
+        sub     r8, r9
+        shr     rax, 5                         // rax = rounds
+        vmovdqu ymm8, yword ptr [rip + @c4]
+        vmovdqu ymm3, yword ptr [rip + @c5]
+        mov     qword ptr [rsi], r8            // set final b64len
+        vmovdqu ymm2, yword ptr [rip + @c6]
+        vmovdqu ymm7, yword ptr [rip + @c7]
+        vmovdqu ymm6, yword ptr [rip + @c8]
+        mov     r8, qword ptr [rdi]            // r8 = [rdi] = b64
+        mov     r9, qword ptr [rdx]            // r9 = [rdx] = b
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+        // decode 32 bytes on input into 24 binary bytes per loop iteration
+@1:     vmovdqu xmm0, oword ptr [r8]
+        vinserti128 ymm10, ymm0, oword ptr [r8 + 16], 1
+        vpsrld  ymm0, ymm10, 4
+        vpand   ymm11, ymm1, ymm0
+        vpand   ymm0, ymm1, ymm10
+        vpshufb ymm12, ymm5, ymm11
+        vpshufb ymm0, ymm4, ymm0
+        vptest  ymm0, ymm12
+        jnz     @err
+        add     r8, 32
+        vpcmpeqb ymm0, ymm10, ymm9
+        vpaddb  ymm0, ymm0, ymm11
+        vpshufb ymm0, ymm8, ymm0
+        vpaddb  ymm0, ymm0, ymm10
+        vpmaddubsw ymm0, ymm0, ymm3
+        vpmaddwd ymm0, ymm0, ymm2
+        vpshufb ymm0, ymm0, ymm7
+        vpermd  ymm0, ymm6, ymm0
+        vmovdqu oword ptr [r9], xmm0
+        vextracti128 oword ptr [r9 + 16], ymm0, 1
+        add     r9, 24
+        sub     rax, 1
+        jne     @1
+        jmp     @8
+@err:   shl     rax, 5
+        add     qword ptr [rsi], rax // restore proper b64len on error
+@8:     mov     qword ptr [rdi], r8
+        mov     qword ptr [rdx], r9
+        vzeroupper
+        {$ifdef WIN64ABI}
+        jmp     @done
+        {$else}
+        ret
+        {$endif WIN64ABI}
+{$ifdef FPC} align 32 {$else} .align 16 {Delphi doesn't allow 32 :(} {$endif}
+@c0:    dq 2F2F2F2F2F2F2F2FH
+        dq 2F2F2F2F2F2F2F2FH
+        dq 2F2F2F2F2F2F2F2FH
+        dq 2F2F2F2F2F2F2F2FH
+@c1:    dq 0804080402011010H
+        dq 1010101010101010H
+        dq 0804080402011010H
+        dq 1010101010101010H
+@c2:    dq 1111111111111115H
+        dq 1A1B1B1B1A131111H
+        dq 1111111111111115H
+        dq 1A1B1B1B1A131111H
+@c3:    dq 2F2F2F2F2F2F2F2FH
+        dq 2F2F2F2F2F2F2F2FH
+        dq 2F2F2F2F2F2F2F2FH
+        dq 2F2F2F2F2F2F2F2FH
+@c4:    dq 0B9B9BFBF04131000H
+        dq 0000000000000000H
+        dq 0B9B9BFBF04131000H
+        dq 0000000000000000H
+@c5:    dq 0140014001400140H
+        dq 0140014001400140H
+        dq 0140014001400140H
+        dq 0140014001400140H
+@c6:    dq 0001100000011000H
+        dq 0001100000011000H
+        dq 0001100000011000H
+        dq 0001100000011000H
+@c7:    dq 090A040506000102H
+        dq 0FFFFFFFF0C0D0E08H
+        dq 090A040506000102H
+        dq 0FFFFFFFF0C0D0E08H
+@c8:    dq 0000000100000000H
+        dq 0000000400000002H
+        dq 0000000600000005H
+        dq 0FFFFFFFFFFFFFFFFH
+@done:  {$ifdef WIN64ABI}
+        pop     rdi
+        pop     rsi
+        movups  xmm6, dqword ptr [bak6]
+        movups  xmm7, dqword ptr [bak7]
+        movups  xmm8, dqword ptr [bak8]
+        movups  xmm9, dqword ptr [bak9]
+        movups  xmm10, dqword ptr [bak10]
+        movups  xmm11, dqword ptr [bak11]
+        movups  xmm12, dqword ptr [bak12]
+        {$endif WIN64ABI}
+end;
+
+{$endif ASMX64AVXNOCONST}
+
+{$endif CPUX64ASM} // SSE2 asm is invalid prior to Delphi XE7 (to be refined)
+
+
+// functions below are always available, even on DARWIN
+
+function SortDynArrayInteger(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     r8d, dword ptr [A]
+        mov     edx, dword ptr [B]
+        xor     eax, eax
+        xor     ecx, ecx
+        cmp     r8d, edx
+        setl    cl
+        setg    al
+        sub     eax, ecx
+end;
+
+function SortDynArrayCardinal(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     ecx, dword ptr [A]
+        mov     edx, dword ptr [B]
+        xor     eax, eax
+        cmp     ecx, edx
+        seta    al
+        sbb     eax, 0
+end;
+
+function SortDynArrayInt64(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     r8,  qword ptr [A]
+        mov     rdx, qword ptr [B]
+        xor     eax, eax
+        xor     ecx, ecx
+        cmp     r8, rdx
+        setl    cl
+        setg    al
+        sub     eax, ecx
+end;
+
+function SortDynArrayQWord(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     rcx, qword ptr [A]
+        mov     rdx, qword ptr [B]
+        xor     eax, eax
+        cmp     rcx, rdx
+        seta    al
+        sbb     eax, 0
+end;
+
+function SortDynArrayPointer(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     rcx, qword ptr [A]
+        mov     rdx, qword ptr [B]
+        xor     eax, eax
+        cmp     rcx, rdx
+        seta    al
+        sbb     eax, 0
+end;
+
+function SortDynArrayDouble(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        movsd   xmm0, qword ptr [A]
+        movsd   xmm1, qword ptr [B]
+        xor     eax, eax
+        xor     edx, edx
+        comisd  xmm0, xmm1
+        seta    al
+        setb    dl
+        sub     eax, edx
+end;
+
+function SortDynArraySingle(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        movss   xmm0, dword ptr [A]
+        movss   xmm1, dword ptr [B]
+        xor     eax, eax
+        xor     edx, edx
+        comiss  xmm0, xmm1
+        seta    al
+        setb    dl
+        sub     eax, edx
+end;
+
+function SortDynArrayAnsiString(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        // x86_64 version optimized for AnsiString/RawUtf8/RawByteString types
+        mov     rax, qword ptr [A]
+        mov     rdx, qword ptr [B]
+        cmp     rax, rdx
+        je      @z
+        test    rax, rdx
+        jz      @maynil
+@f:     movzx   ecx, byte ptr [rax]    // first char comparison
+        movzx   r8d, byte ptr [rdx]    // 32-bit to avoid overflow
+        sub     ecx, r8d
+        je      @s
+        mov     eax, ecx              // branchless execution on Quicksort
+        ret
+@1:     mov     eax, 1
+        ret
+@z:     xor     eax, eax
+        ret
+@maynil:test    rdx, rdx       // A or B may be ''
+        jz      @1
+        test    rax, rax
+        jnz     @f
+        dec     eax
+        ret
+        {$ifdef FPC}
+@s:     mov     r9, qword ptr [rax - _STRLEN]   // TStrLen=SizeInt on FPC
+        mov     r8, r9
+        sub     r9, qword ptr [rdx - _STRLEN]   // r9 = length(A)-length(B)
+        {$else}
+        .align 16
+@s:     mov     r9d, dword ptr [rax - _STRLEN]  // TStrLen=integer on Delphi
+        mov     r8, r9
+        mov     r10d, dword ptr [rdx - _STRLEN]
+        sub     r9, r10                         // r9 = length(A)-length(B)
+        {$endif FPC}
+        adc     rcx, -1
+        and     rcx, r9
+        sub     rcx, r8                  // rcx = -min(length(A),length(B))
+        sub     rax, rcx
+        sub     rdx, rcx
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@by8:   mov     r10, qword ptr [rax + rcx]  // compare 8 bytes at once
+        xor     r10, qword ptr [rdx + rcx]
+        jnz     @d
+        add     rcx, 8
+        js      @by8
+@eq:    mov     eax, r9d    // all chars equal -> returns length(A)-length(B)
+        ret
+@d:     bsf     r10, r10    // char differs -> returns pbyte(A)^-pbyte(B)^
+        shr     r10, 3
+        add     rcx, r10
+        jns     @eq
+        movzx   eax, byte ptr [rax + rcx]
+        movzx   edx, byte ptr [rdx + rcx]
+        sub     eax, edx
+end; // note: SSE4.2 read up to 16 bytes after buffer, this version won't
+
+function Hash32(Data: PCardinalArray; Len: integer): cardinal;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif}
+        xor     eax, eax
+        xor     r9d, r9d
+        test    Data, Data
+        jz      @z
+        {$ifdef WIN64ABI}  // rcx/rdi=Data edx/esi=Len
+        mov     r8, rdx
+        shr     r8, 4
+        {$else}
+        mov     edx, esi
+        shr     esi, 4
+        {$endif WIN64ABI}
+        jz      @by4
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@by16:  add     eax, dword ptr [Data]
+        add     r9d, eax
+        add     eax, dword ptr [Data + 4]
+        add     r9d, eax
+        add     eax, dword ptr [Data + 8]
+        add     r9d, eax
+        add     eax, dword ptr [Data + 12]
+        add     r9d, eax
+        add     Data, 16
+        {$ifdef WIN64ABI}
+        sub     r8d, 1
+        {$else}
+        sub     esi, 1
+        {$endif WIN64ABI}
+        jnz     @by16
+@by4:   mov     dh, dl
+        and     dl, 15
+        jz      @0
+        shr     dl, 2
+        jz      @rem
+@4:     add     eax, dword ptr [Data]
+        add     r9d, eax
+        add     Data, 4
+        dec     dl
+        jnz     @4
+@rem:   and     dh, 3
+        jz      @0
+        dec     dh
+        jz      @1
+        dec     dh
+        jz      @2
+        mov     ecx, dword ptr [Data]
+        and     ecx, $ffffff
+        jmp     @e
+@2:     movzx   ecx, word ptr [Data]
+        jmp     @e
+@1:     movzx   ecx, byte ptr [Data]
+@e:     add     eax, ecx
+@0:     add     r9d, eax
+        shl     r9d, 16
+        xor     eax, r9d
+@z:
+end;
+
+function xxHash32(crc: cardinal; P: PAnsiChar; len: cardinal): cardinal;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe{$endif}
+        {$ifdef SYSVABI} // 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 SYSVABI}
+        // 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 - 16]
+        lea     ebx, [r8 + 24234428H]
+        lea     edi, [r8 - 7A143589H]
+        lea     eax, [r8 + 61C8864FH]
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@1:     imul    r9d, dword ptr [rcx], -2048144777
+        add     rcx, 16
+        imul    r11d, dword ptr [rcx - 12], -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 - 8], -2048144777
+        add     r8d, r9d
+        imul    r9d, dword ptr [rcx - 4], -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 - 4], -1028477379
+        add     r8, 4
+        add     eax, edx
+        ror     eax, 15
+        imul    eax, 668265263
+        cmp     r10, r8
+        jnc     @3
+        lea     rdx, [r10 - 4]
+        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 SYSVABI}
+        pop     rdi
+        pop     rsi
+        {$endif SYSVABI}
+end;
+
+function GetBitsCountPas(value: PtrInt): PtrInt;
+{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif}
+        mov     rax, value
+        mov     rdx, value
+        shr     rax, 1
+        mov     rcx, $5555555555555555
+        mov     r8,  $3333333333333333
+        mov     r10, $0f0f0f0f0f0f0f0f
+        mov     r11, $0101010101010101
+        and     rax, rcx
+        sub     rdx, rax
+        mov     rax, rdx
+        shr     rdx, 2
+        and     rax, r8
+        and     rdx, r8
+        add     rax, rdx
+        mov     rdx, rax
+        shr     rax, 4
+        add     rax, rdx
+        and     rax, r10
+        imul    rax, r11
+        shr     rax, 56
+end;
+
+procedure mul64x64(const left, right: QWord; out product: THash128Rec);
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif}
+        // uses built-in 64-bit -> 128-bit multiplication
+        {$ifdef WIN64ABI}
+        mov     rax, rcx
+        mul     rdx
+        {$else}
+        mov     r8, rdx
+        mov     rax, rdi
+        mul     rsi
+        {$endif WIN64ABI}
+        mov     qword ptr [r8], rax
+        mov     qword ptr [r8 + 8], rdx
+end;
+
+function bswap32(a: cardinal): cardinal;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     eax, a
+        bswap   eax
+end;
+
+function bswap64(const a: QWord): QWord;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     rax, a
+        bswap   rax
+end;
+
+procedure bswap64array(a, b: PQWordArray; n: PtrInt);
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+@1:     mov     rax, qword ptr [a]
+        bswap   rax
+        mov     qword ptr [b], rax
+        add     a, 8
+        add     b, 8
+        sub     n, 1
+        jnz @1
+end;
+
+function StrLen(S: pointer): PtrInt;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        // from GPL strlen64.asm by Agner Fog - www.agner.org/optimize
+        {$ifdef WIN64ABI}
+        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 WIN64ABI}
+        jz      @null                // returns 0 if S=nil
+        // rax=s,ecx=32-bit of s
+        pxor    xmm0, xmm0           // set to zero
+        and     ecx, 15              // lower 4 bits indicate misalignment
+        and     rax, -16             // align pointer by 16
+        // will never read outside a memory page boundary, so won't trigger GPF
+        movaps  xmm1, [rax]          // read from nearest preceding boundary
+        pcmpeqb xmm1, xmm0           // compare 16 bytes with zero
+        pmovmskb edx, xmm1           // get one bit for each byte result
+        shr     edx, cl              // shift out false bits
+        shl     edx, cl              // shift back again
+        bsf     edx, edx             // find first 1-bit
+        jnz     @L2                  // found
+        // Main loop, search 16 bytes at a time
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@L1:    add     rax, 10H             // increment pointer by 16
+        movaps  xmm1, [rax]          // read 16 bytes aligned
+        pcmpeqb xmm1, xmm0           // compare 16 bytes with zero
+        pmovmskb edx, xmm1           // get one bit for each byte result
+        bsf     edx, edx             // find first 1-bit
+        // (moving the bsf out of the loop and using test here would be faster
+        // for long strings on old processors, but we are assuming that most
+        // strings are short, and newer processors have higher priority)
+        jz      @L1                  // loop if not found
+@L2:    // Zero-byte found. Compute string length
+        {$ifdef WIN64ABI}
+        sub     rax, r8              // subtract start address
+        {$else}
+        sub     rax, rdi
+        {$endif WIN64ABI}
+        add     rax, rdx             // add byte index
+@null:
+end;
+
+function PosChar(Str: PUtf8Char; Chr: AnsiChar): PUtf8Char;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        // fast SSE2 version searching for both Chr and #0 over 16 bytes at once
+        {$ifdef WIN64ABI}
+        movzx   edx, dl
+        mov     rax, rcx             // get pointer to string from rcx
+        imul    edx, $01010101
+        test    rcx, rcx
+        {$else}
+        imul    edx, esi, $01010101
+        mov     rax, rdi
+        mov     ecx, edi
+        test    rdi, rdi
+        {$endif WIN64ABI}
+        jz      @null                // returns 0 if S=nil
+        movd    xmm1, edx
+        // rax=Str, ecx=32-bit of Str, xmm1=Chr
+        pxor    xmm0, xmm0           // set xmm0 to zero
+        pshufd  xmm1, xmm1, 0        // set Chr into all bytes of xmm1
+        and     ecx, 15              // lower 4 bits indicate misalignment
+        and     rax, -16             // align pointer by 16
+        // will never read outside a memory page boundary, so won't trigger GPF
+        movaps  xmm2, [rax]          // read from nearest preceding boundary
+        movaps  xmm3, xmm2
+        pcmpeqb xmm2, xmm0           // compare 16 bytes with zero
+        pcmpeqb xmm3, xmm1           // compare 16 bytes with Chr
+        por     xmm2, xmm3
+        pmovmskb edx, xmm2           // get one bit for each byte result
+        shr     edx, cl              // shift out false bits
+        shl     edx, cl              // shift back again
+        bsf     edx, edx             // find first 1-bit
+        jnz     @L2                  // found
+        // Main loop, search 16 bytes at a time
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@L1:    add     rax, 10H             // increment pointer by 16
+        movaps  xmm2, [rax]          // read 16 bytes aligned
+        movaps  xmm3, xmm2
+        pcmpeqb xmm2, xmm0           // compare 16 bytes with zero
+        pcmpeqb xmm3, xmm1           // compare 16 bytes with Chr
+        por     xmm2, xmm3
+        pmovmskb edx, xmm2           // 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 or Chr byte found
+        add     rax, rdx             // add byte index for rax = match address
+        cmp     byte ptr [rax], 0
+        jz      @z                   // return nil if zero was reached
+@null:  ret
+@z:     xor     eax, eax
+end;
+
+function BufferLineLength(Text, TextEnd: PUtf8Char): PtrInt;
+{$ifdef FPC} nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        {$ifdef WIN64ABI} // Win64 ABI to System-V ABI
+        push    rsi
+        push    rdi
+        mov     rdi, rcx
+        mov     rsi, rdx
+        {$endif WIN64ABI}
+        mov     r8, rsi
+        sub     r8, rdi            // rdi=Text, rsi=TextEnd, r8=TextLen
+        jz      @fail
+        mov     ecx, edi
+        movaps  xmm0, [rip + @for10]
+        movaps  xmm1, [rip + @for13]
+        and     rdi, -16           // check first aligned 16 bytes
+        and     ecx, 15            // lower cl 4 bits indicate misalignment
+        movaps  xmm2, [rdi]
+        movaps  xmm3, xmm2
+        pcmpeqb xmm2, xmm0
+        pcmpeqb xmm3, xmm1
+        por     xmm3, xmm2
+        pmovmskb eax, xmm3
+        shr     eax, cl            // shift out unaligned bytes
+        bsf     eax, eax
+        jz      @main
+        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 WIN64ABI}
+        pop     rdi
+        pop     rsi
+        {$endif WIN64ABI}
+        ret
+@main:  add     rdi, 16
+        sub     rdi, rsi
+        jae     @fail
+        jmp     @by16
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@for10: dq      $0a0a0a0a0a0a0a0a
+        dq      $0a0a0a0a0a0a0a0a
+@for13: dq      $0d0d0d0d0d0d0d0d
+        dq      $0d0d0d0d0d0d0d0d
+@by16:  movaps  xmm2, [rdi + rsi]  // check 16 bytes per loop
+        movaps  xmm3, xmm2
+        pcmpeqb xmm2, xmm0
+        pcmpeqb xmm3, xmm1
+        por     xmm3, xmm2
+        pmovmskb eax, xmm3
+        test    eax, eax
+        jnz     @found
+        add     rdi, 16
+        jnc     @by16
+@fail:  mov     rax, r8            // returns TextLen if no CR/LF found
+        {$ifdef WIN64ABI}
+        pop     rdi
+        pop     rsi
+        {$endif WIN64ABI}
+        ret
+@found: bsf     eax, eax
+        add     rax, rdi
+        jc      @fail
+        add     rax, r8
+        {$ifdef WIN64ABI}
+        pop     rdi
+        pop     rsi
+        {$endif WIN64ABI}
+end;
+
+function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: byte): PtrInt;
+{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif}
+        {$ifdef WIN64ABI}
+        movzx   eax, r8b
+        mov     r8, rcx
+        test    rdx, rdx
+        {$else}
+        movzx   eax, dl
+        mov     rcx, rdi
+        mov     r8, rdi
+        mov     rdx, rsi
+        test    rsi, rsi
+        {$endif WIN64ABI}
+        jbe     @no
+        // eax=Value, rcx=P rdx=Count
+        imul    eax, $01010101
+        and     rcx, -16
+        movd    xmm1, eax
+        movaps  xmm0, [rcx]      // check first aligned 16 bytes
+        add     rcx, 16
+        pshufd  xmm1, xmm1, 0
+        sub     rcx, r8
+        pcmpeqb xmm0, xmm1
+        pmovmskb eax, xmm0
+        shl     eax, cl
+        and     eax, $FFFF0000
+        shr     eax, cl
+        jnz     @fnd
+        cmp     rdx, rcx
+        jbe     @no
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@by16:  movaps  xmm0, [r8 + rcx]  // next 16 bytes
+        add     rcx, 16
+        pcmpeqb xmm0, xmm1
+        pmovmskb eax, xmm0
+        test    eax, eax
+        jnz     @fnd
+        cmp     rdx, rcx
+        ja      @by16
+@no:    mov     rax, -1
+        ret
+@fnd:   bsf     eax, eax
+        lea     rax, qword ptr [rcx + rax - 16]
+        cmp     rdx, rax
+        jbe     @no
+end;
+
+function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): PtrInt;
+{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif}
+        {$ifdef WIN64ABI}
+        movzx   eax, r8w
+        mov     r8, rcx
+        test    rdx, rdx
+        {$else}
+        movzx   eax, dx
+        mov     rcx, rdi
+        mov     r8, rdi
+        mov     rdx, rsi
+        test    rsi, rsi
+        {$endif WIN64ABI}
+        jbe     @no
+        test    rcx, 1
+        jnz     @unal
+        // eax=Value, rcx=P rdx=Count
+        movd    xmm1, eax
+        and     rcx, -16
+        punpcklwd xmm1, xmm1
+        movaps  xmm0, [rcx]      // check first aligned 16 bytes
+        add     rcx, 16
+        pshufd  xmm1, xmm1, 0
+        sub     rcx, r8
+        pcmpeqw xmm0, xmm1
+        pmovmskb eax, xmm0
+        shl     eax, cl
+        and     eax, $FFFF0000
+        shr     eax, cl
+        shr     ecx, 1
+        bsf     eax, eax
+        jnz     @fnd
+        cmp     rdx, rcx
+        jbe     @no
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@by16:  movaps  xmm0, [r8 + rcx * 2]  // next 16 bytes
+        add     rcx, 8
+        pcmpeqw xmm0, xmm1
+        pmovmskb eax, xmm0
+        bsf     eax, eax
+        jnz     @fnd
+        cmp     rdx, rcx
+        ja      @by16
+@no:    mov     rax, -1
+        ret
+        bsf     eax, eax
+@fnd:   shr     eax, 1
+        lea     rax, qword ptr [rcx + rax - 8]
+        cmp     rdx, rax
+        jbe     @no
+        ret
+        // 16bit-unaligned loop (seldom called)
+{$ifdef FPC} align 8 {$else} .align 8 {$endif}
+@unal:  lea     rcx, [rcx + rdx * 2]
+        neg     rdx
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@unals: cmp     word ptr [rcx + rdx * 2], ax
+        jz      @unale
+        add     rdx, 1
+        jnz     @unals
+        jmp     @no
+@unale: lea     rax, [rcx + rdx * 2]
+        sub     rax, r8
+        shr     rax, 1
+end;
+
+function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt;
+{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif}
+        {$ifdef WIN64ABI}
+        mov     eax, r8d
+        movd    xmm1, r8d
+        mov     r8, rcx
+        test    rdx, rdx
+        {$else}
+        mov     eax, edx
+        movd    xmm1, edx
+        mov     rcx, rdi
+        mov     r8, rdi
+        mov     rdx, rsi
+        test    rsi, rsi
+        {$endif WIN64ABI}
+        jbe     @no
+        test    rcx, 3
+        jnz     @unal
+        // eax=Value, rcx=P rdx=Count
+        and     rcx, -16
+        movaps  xmm0, [rcx]      // check first aligned 16 bytes
+        add     rcx, 16
+        pshufd  xmm1, xmm1, 0
+        sub     rcx, r8
+        pcmpeqd xmm0, xmm1
+        pmovmskb eax, xmm0
+        shl     eax, cl
+        and     eax, $FFFF0000
+        shr     eax, cl
+        shr     ecx, 2
+        bsf     eax, eax
+        jnz     @fnd
+        cmp     rdx, rcx
+        jbe     @no
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@by16:  movaps  xmm0, [r8 + rcx * 4]  // next 16 bytes
+        add     rcx, 4
+        pcmpeqd xmm0, xmm1
+        pmovmskb eax, xmm0
+        bsf     eax, eax
+        jnz     @fnd
+        cmp     rdx, rcx
+        ja      @by16
+@no:    mov     rax, -1
+        ret
+        bsf     eax, eax
+@fnd:   shr     eax, 2
+        lea     rax, qword ptr [rcx + rax - 4]
+        cmp     rdx, rax
+        jbe     @no
+        ret
+        // 32bit-unaligned loop (seldom called)
+{$ifdef FPC} align 8 {$else} .align 8 {$endif}
+@unal:  lea     rcx, [rcx + rdx * 4]
+        neg     rdx
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@unals: cmp     dword ptr [rcx + rdx * 4], eax
+        jz      @unale
+        add     rdx, 1
+        jnz     @unals
+        jmp     @no
+@unale: lea     rax, [rcx + rdx * 4]
+        sub     rax, r8
+        shr     rax, 2
+end;
+
+function MemCmp(P1, P2: PByteArray; L: PtrInt): integer;
+{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif}
+// from GPL memcmp64.asm by Agner Fog - www.agner.org/optimize
+          add     P1, L    // use negative index from end of memory block
+          add     P2, L
+          neg     L
+          jge     @eq
+          mov     r9d, $FFFF             // 16 bits mask = 16 bytes
+          cmp     L, -16
+          ja      @sml
+{$ifdef FPC} align 8 {$else} .align 8 {$endif}
+@by16:    // loop comparing 16 bytes
+          movups  xmm1, oword ptr [P1 + L]
+          movups  xmm2, oword ptr [P2 + L]
+          pcmpeqb xmm1, xmm2             // compare 16 bytes
+          pmovmskb eax, xmm1             // get byte mask
+          xor     eax, r9d               // not ax
+          jnz     @diff                  // difference found
+          add     L, 16
+          jz      @eq                    // finished, equal
+          cmp     L, -16
+          jna     @by16                  // next 16 bytes
+          jmp     @sml
+@diff:    // difference found: find position
+          bsf     eax, eax
+          add     L, rax
+@last:    movzx   eax, byte ptr [P1 + L]
+          movzx   r9d, byte ptr [P2 + L]
+          sub     eax, r9d               // return result
+          ret
+@eq:      // equal
+          xor     eax, eax
+          ret
+@sml:     // less than 16 bytes left
+          cmp     L, -8
+          ja      @less8
+          // compare 8 bytes
+          movq    xmm1, qword ptr [P1 + L]
+          movq    xmm2, qword ptr [P2 + L]
+          pcmpeqb xmm1, xmm2             // compare 8 bytes
+          pmovmskb eax, xmm1             // get byte mask
+          xor     eax, r9d               // not ax
+          jnz     @diff                  // difference found
+          add     L, 8
+          jz      @eq
+@less8:   // less than 8 bytes left
+          cmp     L, -4
+          ja      @less4
+          // compare 4 bytes
+          movd    xmm1, dword ptr [P1 + L]
+          movd    xmm2, dword ptr [P2 + L]
+          pcmpeqb xmm1, xmm2             // compare 4 bytes
+          pmovmskb eax, xmm1             // get byte mask
+          xor     eax, r9d               // not ax
+          jnz     @diff                  // difference found
+          add     L, 4
+          jz      @eq
+@less4:   // less than 4 bytes left
+          cmp     L, -2
+          ja      @less2
+          movzx   eax, word ptr [P1 + L]
+          movzx   r9d, word ptr [P2 + L]
+          sub     eax, r9d
+          jnz     @last2                 // difference in byte 0 or 1
+          add     L, 2
+          jz      @eq
+@less2:   // less than 2 bytes left
+          test    L, L
+          jz      @eq                    // no bytes left
+          jmp     @last                  // one byte left
+@last2:   // difference in byte 0 or 1
+          neg     al
+          sbb     L, -1                  // add 1 to L if al == 0
+          jmp     @last
+end;
+
+function FastFindWordSorted(P: PWordArray; R: PtrInt; Value: Word): PtrInt;
+{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif}
+        {$ifdef WIN64ABI}
+        push    rdi
+        mov     rdi, P  // rdi=P - we use ecx to read the word ptr value
+        {$endif WIN64ABI}
+        xor     r9, r9  // r9=L rax=result
+        test    R, R
+        jl      @ko
+{$ifdef FPC} align 8 {$else} .align 8 {$endif}
+@s:     lea     rax, [r9 + R]
+        shr     rax, 1
+        lea     r10, qword ptr [rax - 1] // branchless loop
+        lea     r11, qword ptr [rax + 1]
+        movzx   ecx, word ptr [rdi + rax * 2]
+        {$ifdef WIN64ABI}
+        cmp     ecx, r8d
+        {$else}
+        cmp     ecx, edx // 'cmp cx,Value' is silently rejected by Darwin asm
+        {$endif WIN64ABI}
+        je      @ok
+        cmovg   R, r10
+        cmovl   r9, r11
+        cmp     r9, R
+        jle     @s
+@ko:    mov     rax, -1
+@ok:    {$ifdef WIN64ABI}
+        pop     rdi
+        {$endif WIN64ABI}
+end;
+
+function FastFindIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt;
+{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif}
+        xor     r9, r9  // r9=L rax=result
+        test    R, R
+        jl      @ko
+        lea     rax, [r9 + R]
+{$ifdef FPC} align 8 {$else} .align 8 {$endif}
+@s:     shr     rax, 1
+        lea     r10, qword ptr [rax - 1]  // efficient branchless binary search
+        lea     r11, qword ptr [rax + 1]
+        cmp     Value, dword ptr [P + rax * 4]
+        je      @ok
+        cmovl   R, r10
+        cmovg   r9, r11
+        lea     rax, [r9 + R]
+        cmp     r9, R
+        jle     @s
+@ko:    mov     rax, -1
+@ok:
+end;
+
+function FastFindInt64Sorted(P: PInt64Array; R: PtrInt; const Value: Int64): PtrInt;
+{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif}
+        xor     r9, r9  // r9=L rax=result
+        test    R, R
+        jl      @ko
+        lea     rax, [r9 + R]
+{$ifdef FPC} align 8 {$else} .align 8 {$endif}
+@s:     shr     rax, 1
+        lea     r10, qword ptr [rax - 1]  // efficient branchless binary search
+        lea     r11, qword ptr [rax + 1]
+        cmp     Value, qword ptr [P + rax * 8]
+        je      @ok
+        cmovl   R, r10
+        cmovg   r9, r11
+        lea     rax, [r9 + R]
+        cmp     r9, R
+        jle     @s
+@ko:    mov     rax, -1
+@ok:
+end;
+
+function GetBitsCountSse42(value: PtrInt): PtrInt;
+{$ifdef FPC} assembler; nostackframe;
+asm
+        popcnt  rax, value
+{$else} // oldest Delphi don't support this opcode
+asm     .noframe
+        {$ifdef WIN64ABI}
+        db $f3,$48,$0f,$B8,$c1
+        {$else}
+        db $f3,$48,$0f,$B8,$c7
+        {$endif WIN64ABI}
+{$endif FPC}
+end;
+
+function crc32cby4sse42(crc, value: cardinal): cardinal;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     eax, crc
+        crc32   eax, value
+end;
+
+procedure crcblocksse42(crc128, data128: PBlock128);
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     eax,  dword ptr [crc128] // we can't use two qword ptr here
+        mov     r8d,  dword ptr [crc128 + 4]
+        mov     r9d,  dword ptr [crc128 + 8]
+        mov     r10d, dword ptr [crc128 + 12]
+        crc32   eax,  dword ptr [data128]
+        crc32   r8d,  dword ptr [data128 + 4]
+        crc32   r9d,  dword ptr [data128 + 8]
+        crc32   r10d, dword ptr [data128 + 12]
+        mov     dword ptr [crc128],      eax
+        mov     dword ptr [crc128 + 4],  r8d
+        mov     dword ptr [crc128 + 8],  r9d
+        mov     dword ptr [crc128 + 12], r10d
+end;
+
+procedure crcblockssse42(crc128, data128: PBlock128; count: integer);
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        test    count, count
+        jle     @z
+        mov     rax, data128
+        {$ifdef WIN64ABI}
+        mov     rdx, rcx
+        mov     ecx, r8d
+        {$else}
+        mov     ecx, edx
+        mov     rdx, rdi
+        {$endif WIN64ABI}
+        mov     r8d,  dword ptr [rdx] // we can't use qword ptr here
+        mov     r9d,  dword ptr [rdx + 4]
+        mov     r10d, dword ptr [rdx + 8]
+        mov     r11d, dword ptr [rdx + 12]
+{$ifdef FPC} align 16 {$else} .align 16 {$endif}
+@s:     crc32   r8d,  dword ptr [rax]
+        crc32   r9d,  dword ptr [rax + 4]
+        crc32   r10d, dword ptr [rax + 8]
+        crc32   r11d, dword ptr [rax + 12]
+        add     rax, 16
+        sub     ecx, 1
+        jnz     @s
+        mov     dword ptr [rdx], r8d
+        mov     dword ptr [rdx + 4], r9d
+        mov     dword ptr [rdx + 8], r10d
+        mov     dword ptr [rdx + 12], r11d
+@z:
+end;
+
+function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     eax, crc
+        test    len, len
+        jz      @z
+        test    buf, buf
+        jz      @z
+        not     eax
+        mov     ecx, len
+        shr     len, 3
+        jnz     @by8 // no read alignment care here - but in crypto.core
+@0:     test    cl, 4
+        jz      @4
+        crc32   eax, dword ptr [buf]
+        add     buf, 4
+@4:     test    cl, 2
+        jz      @2
+        crc32   eax, word ptr [buf]
+        add     buf, 2
+@2:     test    cl, 1
+        jz      @1
+        crc32   eax, byte ptr [buf]
+@1:     not     eax
+@z:     ret
+        {$ifdef FPC}
+        align 16
+@by8:   crc32   rax, qword ptr [buf] // hash 8 bytes per loop
+        {$else}
+        .align 16
+@by8:   db $F2,$48,$0F,$38,$F1,$02 // circumvent Delphi inline asm compiler bug
+        {$endif FPC}
+        add     buf, 8
+        sub     len, 1
+        jnz     @by8
+        jmp     @0
+end;
+
+function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
+var
+  off: TOffsets;
+  cache: array[0..4095] of cardinal; // uses 32KB+16KB=48KB on stack
+asm // rcx=src, edx=size, r8=dest
+        {$ifdef WIN64ABI} // additional registers to preserve
+        push    rdi
+        push    rsi
+        {$else} // Linux 64-bit ABI
+        mov     r8, rdx
+        mov     rdx, rsi
+        mov     rcx, rdi
+        {$endif WIN64ABI}
+        push    rbx
+        push    r12
+        push    r13
+        push    r14
+        push    r15
+        mov     r15, r8            // r8=dest r15=dst_beg
+        mov     rbx, rcx           // rbx=src
+        cmp     edx, 32768
+        jc      @03
+        mov     eax, edx
+        and     eax, 7FFFH
+        or      eax, 8000H
+        mov     word ptr [r8], ax
+        mov     eax, edx
+        shr     eax, 15
+        mov     word ptr [r8 + 2], ax
+        add     r8, 4
+        jmp     @05
+@03:    mov     word ptr [r8], dx
+        test    edx, edx
+        jnz     @04
+        mov     r15d, 2
+        jmp     @19
+        nop
+@04:    add     r8, 2
+@05:    lea     r9, [rdx + rbx]    // r9=src_end
+        lea     r10, [r9 - 11]     // r10=src_endmatch
+        mov     ecx, 1             // ecx=CWBits
+        mov     r11, r8            // r11=CWpoint
+        mov     dword ptr [r8], 0
+        add     r8, 4
+        pxor    xmm0, xmm0
+        mov     eax, 32768 - 64
+@06:    movaps  dqword ptr [off + rax - 48], xmm0 // stack is 16 bytes aligned
+        movaps  dqword ptr [off + rax - 32], xmm0
+        movaps  dqword ptr [off + rax - 16], xmm0
+        movaps  dqword ptr [off + rax], xmm0
+        sub     eax, 64
+        jae     @06
+        cmp     rbx, r10
+        ja      @15
+@07:    mov     edx, dword ptr [rbx]
+        mov     rax, rdx
+        mov     r12, rdx
+        shr     rax, 12
+        xor     rax, rdx
+        and     rax, 0FFFH                     // rax=h
+        mov     r14, qword ptr [off + rax * 8] // r14=o
+        mov     edx, dword ptr [cache + rax * 4]
+        mov     qword ptr [off + rax * 8], rbx
+        mov     dword ptr [cache + rax * 4], r12d
+        xor     rdx, r12
+        test    r14, r14
+        lea     rdi, [r9-1]
+        je      @12
+        and     rdx, 0FFFFFFH
+        jne     @12
+        mov     rdx, rbx
+        sub     rdx, r14
+        cmp     rdx, 2
+        jbe     @12
+        or      dword ptr [r11], ecx
+        add     rbx, 2
+        add     r14, 2
+        mov     esi, 1
+        sub     rdi, rbx
+        cmp     rdi, 271
+        jc      @09
+        mov     edi, 271
+        jmp     @09
+@08:    add     rsi, 1
+@09:    mov     edx, dword ptr [r14 + rsi]
+        cmp     dl, byte ptr [rbx + rsi]
+        jnz     @10
+        cmp     rsi, rdi
+        jge     @10
+        add     rsi, 1
+        cmp     dh, byte ptr [rbx + rsi]
+        jnz     @10
+        shr     edx, 16
+        cmp     rsi, rdi
+        jge     @10
+        add     rsi, 1
+        cmp     dl, byte ptr [rbx + rsi]
+        jnz     @10
+        cmp     rsi, rdi
+        jge     @10
+        add     rsi, 1
+        cmp     dh, byte ptr [rbx + rsi]
+        jnz     @10
+        cmp     rsi, rdi
+        jc      @08
+@10:    add     rbx, rsi
+        shl     rax, 4
+        cmp     rsi, 15
+        ja      @11
+        or      rax, rsi
+        mov     word ptr [r8], ax
+        add     r8, 2
+        jmp     @13
+@11:    sub     rsi, 16
+        mov     word ptr [r8], ax
+        mov     byte ptr [r8 + 2], sil
+        add     r8, 3
+        jmp     @13
+@12:    mov     al, byte ptr [rbx]
+        mov     byte ptr [r8], al
+        add     rbx, 1
+        add     r8, 1
+@13:    add     ecx, ecx
+        jnz     @14
+        mov     r11, r8
+        mov     [r8], ecx
+        add     r8, 4
+        add     ecx, 1
+@14:    cmp     rbx, r10
+        jbe     @07
+@15:    cmp     rbx, r9
+        jnc     @18
+@16:    mov     al, byte ptr [rbx]
+        mov     byte ptr [r8], al
+        add     rbx, 1
+        add     r8, 1
+        add     ecx, ecx
+        jnz     @17
+        mov     [r8], ecx
+        add     r8, 4
+        add     ecx, 1
+@17:    cmp     rbx, r9
+        jc      @16
+@18:    sub     r8, r15
+        mov     r15, r8
+@19:    mov     rax, r15
+        pop     r15
+        pop     r14
+        pop     r13
+        pop     r12
+        pop     rbx
+        {$ifdef WIN64ABI} // additional registers to preserve
+        pop     rsi
+        pop     rdi
+        {$endif WIN64ABI}
+end;
+
+function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
+var
+  off: TOffsets;
+asm     // rcx=src, edx=size, r8=dest
+        {$ifdef WIN64ABI} // additional registers to preserve
+        push    rsi
+        push    rdi
+        {$else} // Linux 64-bit ABI
+        mov     r8, rdx
+        mov     rdx, rsi
+        mov     rcx, rdi
+        {$endif WIN64ABI}
+        push    rbx
+        push    r12
+        push    r13
+        push    r14
+        push    r15
+        movzx   eax, word ptr [rcx]    // rcx=src   eax=result
+        lea     r9, [rcx + rdx]        // r9=src_end
+        test    eax, eax
+        je      @35
+        add     rcx, 2
+        mov     r10d, eax
+        and     r10d, 8000H
+        jz      @21
+        movzx   ebx, word ptr [rcx]
+        shl     ebx, 15
+        mov     r10d, eax
+        and     r10d, 7FFFH
+        or      r10d, ebx
+        mov     eax, r10d
+        add     rcx, 2
+@21:    lea     r10, [r8 - 1]          // r10=last_hashed  r8=dest
+@22:    mov     edi, dword ptr [rcx]   // edi=CW
+        add     rcx, 4
+        mov     r13d, 1                // r13d=CWBit
+        cmp     rcx, r9
+        jnc     @35
+@23:    test    r13d, edi
+        jnz     @25
+        mov     bl, byte ptr [rcx]
+        mov     byte ptr [r8], bl
+        add     rcx, 1
+        lea     rbx, [r8 - 2]
+        add     r8, 1
+        cmp     rcx, r9
+        jnc     @35
+        cmp     rbx, r10
+        jbe     @24
+        add     r10, 1
+        mov     esi, dword ptr [r10]
+        mov     rbx, rsi
+        shr     esi, 12
+        xor     ebx, esi
+        and     ebx, 0FFFH
+        mov     qword ptr [off + rbx * 8], r10
+@24:    shl     r13d, 1
+        jnz     @23
+        jmp     @22
+@25:    movzx   r11, word ptr [rcx]    // r11=t
+        add     rcx, 2
+        mov     ebx, r11d              // ebx=h
+        shr     ebx, 4
+        and     r11, 0FH
+        lea     r11, [r11 + 2]
+        jnz     @26
+        movzx   r11, byte ptr [rcx]
+        add     rcx, 1
+        lea     r11, [r11 + 12H]
+@26:    mov     r14, qword ptr [off + rbx * 8] // r14=o
+        mov     rbx, r8
+        xor     rsi, rsi
+        sub     rbx, r14
+        mov     r12, r11
+        mov     r15, r11
+        cmp     rbx, r11
+        jc      @29
+        shr     r12, 3
+        jz      @30
+{$ifdef FPC} align 8 {$else} .align 8 {$endif}
+@27:    mov     rbx, qword ptr [r14 + rsi] // inline move by 8 bytes
+        mov     qword ptr [r8 + rsi], rbx
+        add     rsi, 8
+        sub     r12, 1
+        jnz     @27
+        mov     rbx, qword ptr [r14 + rsi] // 1..7 remaining bytes
+        and     r15, 7
+        jz      @31
+@28:    mov     byte ptr [r8 + rsi], bl
+        shr     rbx, 8
+        add     rsi, 1
+        sub     r15, 1
+        jnz     @28
+        jmp     @31
+{$ifdef FPC} align 8 {$else} .align 8 {$endif}
+@29:    mov     bl, byte ptr [r14 + rsi] // overlaping move
+        mov     byte ptr [r8 + rsi], bl
+        add     rsi, 1
+        sub     r12, 1
+        jnz     @29
+        cmp     rcx, r9
+        jnz     @33
+        jmp     @35
+@30:    mov     rbx, qword ptr [r14]
+        mov     qword ptr [r8], rbx
+@31:    cmp     rcx, r9
+        jz      @35
+        cmp     r10, r8
+        jnc     @34
+@32:    add     r10, 1
+        mov     ebx, dword ptr [r10]
+        mov     rsi, rbx
+        shr     ebx, 12
+        xor     esi, ebx
+        and     esi, 0FFFH
+        mov     qword ptr [off + rsi * 8], r10
+@33:    cmp     r10, r8
+        jc      @32
+@34:    add     r8, r11
+        lea     r10, [r8 - 1]
+        shl     r13d, 1
+        jnz     @23
+        jmp     @22
+@35:    pop     r15
+        pop     r14
+        pop     r13
+        pop     r12
+        pop     rbx
+        {$ifdef WIN64ABI} // additional registers to preserve
+        pop     rdi
+        pop     rsi
+        {$endif WIN64ABI}
+end;
+
+function RdRand32: cardinal;
+{$ifdef FPC}nostackframe; assembler; asm{$else} asm .noframe {$endif FPC}
+        // rdrand eax: same opcodes for x86 and x64
+        db $0f, $c7, $f0
+        // we ignore the carry flag (handled once in TestIntelCpuFeatures)
+end;
+
+function Rdtsc: Int64;
+{$ifdef FPC}nostackframe; assembler; asm{$else} asm .noframe {$endif FPC}
+        rdtsc // returns the TSC in EDX:EAX
+        shl     rdx, 32
+        or      rax, rdx
+end;
+
+procedure LockedInc32(int32: PInteger);
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+   lock inc     dword ptr [int32]
+end;
+
+procedure LockedDec32(int32: PInteger);
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+   lock dec     dword ptr [int32]
+end;
+
+procedure LockedInc64(int64: PInt64);
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+   lock inc     qword ptr [int64]
+end;
+
+function InterlockedIncrement(var I: integer): integer;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     eax, 1
+   lock xadd    dword ptr [I], eax // atomic eax=[I] + [I]:=[I]+eax
+        add     eax, 1
+end;
+
+function InterlockedDecrement(var I: integer): integer;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     eax, -1
+   lock xadd    dword ptr [I], eax // atomic eax=[I] + [I]:=[I]+eax
+        sub     eax, 1
+end;
+
+function StrCntDecFree(var refcnt: TStrCnt): boolean;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        {$ifdef STRCNT32}
+   lock dec dword ptr [refcnt]  // TStrCnt=longint on Delphi Win64 and FPC>=3.4
+        {$else}
+   lock dec qword ptr [refcnt]  // on FPC<3.4
+        {$endif STRCNT32}
+        setbe   al
+end; // don't check for ismultithread global since lock is cheaper on new CPUs
+
+function DACntDecFree(var refcnt: TDACnt): boolean;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        {$ifdef DACNT32}
+   lock dec dword ptr [refcnt]  // TDACnt=longint on Delphi
+        {$else}
+   lock dec qword ptr [refcnt]
+        {$endif DACNT32}
+        setbe   al
+end;
+
+function LockedExc(var Target: PtrUInt; NewValue, Comperand: PtrUInt): boolean;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     rax, Comperand
+   lock cmpxchg qword ptr [Target], NewValue
+        setz    al
+end;
+
+procedure LockedAdd(var Target: PtrUInt; Increment: PtrUInt);
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+   lock add     qword ptr [Target], Increment
+end;
+
+procedure LockedAdd32(var Target: cardinal; Increment: cardinal);
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+   lock add     dword ptr [Target], Increment
+end;
+
+procedure LockedDec(var Target: PtrUInt; Decrement: PtrUInt);
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+   lock sub     qword ptr [Target], Decrement
+end;
+
+{$ifdef ISDELPHI}
+
+// those functions are intrinsics with FPC :)
+
+function BSRdword(c: cardinal): cardinal;
+asm
+        .noframe
+        mov     eax, c
+        bsr     eax, eax
+        jnz     @nz
+        mov     eax, 255
+@nz:
+end;
+
+function BSRqword(const q: qword): cardinal;
+asm
+        .noframe
+        mov     rax, q
+        bsr     rax, rax
+        jnz     @nz
+        mov     eax, 255
+@nz:
+end;
+
+// FPC will properly inline multiplication by reciprocal
+procedure Div100(Y: cardinal; var res: TDiv100Rec);
+asm
+        .noframe
+        mov     r8, res
+        mov     edx, Y
+        mov     dword ptr [r8].TDiv100Rec.M,edx
+        mov     eax, 1374389535
+        mul     edx
+        shr     edx, 5
+        mov     dword ptr [r8].TDiv100Rec.D, edx
+        imul    eax, edx, 100
+        sub     dword ptr [r8].TDiv100Rec.M, eax
+end;
+
+{$endif ISDELPHI}
+
+function IsXmmYmmOSEnabled: boolean;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+// see https://software.intel.com/en-us/blogs/2011/04/14/is-avx-enabled
+        xor     ecx, ecx  // specify control register XCR0=XFEATURE_ENABLED_MASK
+        db $0f, $01, $d0  // XGETBV opcode reads XCR0 into EDX:EAX
+        and     eax, 6
+        cmp     al, 6     // check XMM (bit 1=2) and YMM (bit 2=4)
+        sete    al        // true if OS enabled both XMM and YMM
+end;
+
+procedure GetCpuid(cpueax, cpuecx: cardinal; var regs: TIntelRegisters);
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     eax, cpueax
+        mov     ecx, cpuecx
+        mov     r9, regs
+        mov     r10, rbx  // preserve rbx
+        xor     ebx, ebx
+        xor     edx, edx
+        cpuid
+        mov     TIntelRegisters(r9).&eax, eax
+        mov     TIntelRegisters(r9).&ebx, ebx
+        mov     TIntelRegisters(r9).&ecx, ecx
+        mov     TIntelRegisters(r9).&edx, edx
+        mov     rbx, r10
+end;
+
diff --git a/lib/dmustache/mormot.core.base.asmx86.inc b/lib/dmustache/mormot.core.base.asmx86.inc
new file mode 100644
index 00000000..f5e7585d
--- /dev/null
+++ b/lib/dmustache/mormot.core.base.asmx86.inc
@@ -0,0 +1,2602 @@
+{
+  This file is a part of the Open Source Synopse mORMot framework 2,
+  licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+
+   x86 32-bit assembly used by mormot.core.base.pas
+}
+
+{$ifdef FPC}
+  // disabled some FPC paranoid warnings
+  {$WARN 7102 off : Use of +offset(%ebp) for parameters invalid here }
+  {$WARN 7104 off : Use of -offset(%ebp) is not recommended for local variable access }
+  {$WARN 7121 off : Check size of XMM memory operand }
+  {$WARN 7122 off : Check size of XMM memory operand }
+{$endif FPC}
+
+{$ifdef ASMX86} // i386 asm with global - disabled on PIC targets
+
+{
+ FillCharFast/MoveFast implementation notes:
+ - use SS2 and not FPU fld/fst which may trigger unexpected exceptions (Agner)
+ - use dedicated branchless sub-functions for small buffers of 0..32 bytes
+ - use simple SSE2 loop for 33..255 bytes
+ - assume ERBMS is available (cpuid flag may not be propagated within VMs)
+ - use "rep movsb" for 256..512K input (should work on all CPUs, even older with
+ no ERBMS), or as fallback if no SSE2 CPU is used
+ - use non volatile SSE2 loop when >= 512KB (to not pollute the CPU cache)
+ - don't use backward "std rep movsb" since it is not involved by ERMBS (slow)
+ - note: Delphi Win32 x87 RTL code by John O'Harrow seems deprecated
+}
+
+{$define WITH_ERMS} // we need it as fallback on old CPU without SSE2
+
+{$ifdef WITH_ERMS}
+var
+  // "rep stosb/movsb" enabled for len >= 4096 on ERMSB CPUs
+  // it has been reported that "on 32-bit strings have to be at least 4KB"
+  // see https://stackoverflow.com/a/43837564/458259 for explanations and timing
+  ERMSB_MIN_SIZE_FWD: integer = maxInt; // maxInt = disabled by default
+  {$ifndef FPC_X86}
+  ERMSB_MIN_SIZE_BWD: integer = maxInt; // used for no-SSE2, not for ERMSB
+  {$endif FPC_X86}
+  {$define WITH_ERMSASM} // include "rep movsb" asm blocks
+{$endif WITH_ERMS}
+
+{$ifdef HASNOSSE2}
+  {$define WITH_ERMSASM} // "rep movsd" is used as fallback on oldest CPU
+{$endif HASNOSSE2}
+
+const
+  // non-temporal writes should bypass the cache when the size is bigger than
+  // half the size of the largest level cache - we assume low 1MB cache here
+  NONTEMPORALSIZE = 1 shl 20;
+
+// fast SSE2 version - force define HASNOSSE2 when run any very old CPU
+procedure FillcharFast(var dst; cnt: PtrInt; value: byte);
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=Dest edx=Count cl=Value
+        movzx   ecx, cl
+        imul    ecx, ecx, $01010101
+        cmp     edx, 32
+        jg      @32up
+        test    edx, edx
+        jle     @00        
+        mov     [eax + edx - 1], cl     // fill last byte
+        shr     edx, 1                  // how many words to fill
+        jmp     dword ptr [edx * 4 + @jmptab]
+@00:    ret
+@32up:
+{$ifndef HASNOSSE2}
+        {$ifdef WITH_ERMS}
+        cmp     edx, NONTEMPORALSIZE
+        jae     @noerms // movntdq was reported to be faster than ERMSB
+        cmp     edx, ERMSB_MIN_SIZE_FWD
+        ja      @ermsb
+@noerms:{$endif WITH_ERMS}
+        sub     edx, 16
+        movd    xmm0, ecx
+        mov     ecx, eax
+        pshufd  xmm0, xmm0, 0
+        and     ecx, 15                      // 16-byte align writes
+        movups  dqword ptr [eax], xmm0       // fill first 16 bytes
+        movups  dqword ptr [eax + edx], xmm0 // fill last 16 bytes
+        sub     ecx, 16
+        sub     eax, ecx
+        add     edx, ecx
+        add     eax, edx
+        neg     edx
+        cmp     edx, -NONTEMPORALSIZE        // assume > 512KB bypass the cache
+        jl      @nv
+{$ifdef FPC} align 16 {$else} {$ifdef HASALIGN} .align 16 {$endif}{$endif}
+@loop:  movaps  dqword ptr [eax + edx], xmm0 // fill 16 bytes per loop
+        add     edx, 16
+        jl      @loop
+        ret
+{$ifdef FPC} align 16 {$else} {$ifdef HASALIGN} .align 16 {$endif}{$endif}
+@nv:    movntdq dqword ptr [eax + edx], xmm0 // non-temporal fill 16 bytes
+        add     edx, 16
+        jl      @nv
+        ret
+{$endif HASNOSSE2}
+{$ifdef WITH_ERMSASM}
+@ermsb: push    edi
+        cld
+{$ifdef HASNOSSE2}
+@ermsa: test    al, 3   // aligned stosd is better on old CPUs
+        jz      @erms3
+        mov     byte ptr [eax], cl
+        inc     eax
+        dec     edx
+        jmp     @ermsa
+@erms3: mov     edi, eax
+        mov     eax, ecx
+        mov     ecx, edx
+        shr     ecx, 2
+        jz      @erms2
+        rep     stosd    // no SSE2 version
+@erms2: test    dl, 2
+        jz      @erms1
+        mov     word ptr [edi], ax
+        add     edi, 2
+@erms1: test    dl, 1
+        jz      @erms0
+        mov     byte ptr [edi], al
+{$else} // ERMSB favors stosb and will properly align writes
+        mov     edi, eax
+        mov     eax, ecx
+        mov     ecx, edx
+        rep     stosb
+{$endif HASNOSSE2}
+@erms0: pop     edi
+        ret
+{$endif WITH_ERMSASM}
+{$ifdef FPC} align 4 {$else} nop {$ifdef HASNOSSE2} nop; nop {$endif} {$endif}
+@jmptab:dd      @00, @02, @04, @06, @08, @10, @12, @14, @16
+        dd      @18, @20, @22, @24, @26, @28, @30, @32
+        // Delphi RTL uses 16-bit "mov [eax + ...], cx" which are slower
+@32:    mov     [eax + 28], ecx
+@28:    mov     [eax + 24], ecx
+@24:    mov     [eax + 20], ecx
+@20:    mov     [eax + 16], ecx
+@16:    mov     [eax + 12], ecx
+@12:    mov     [eax + 8], ecx
+@08:    mov     [eax + 4], ecx
+@04:    mov     [eax], ecx
+        ret
+@30:    mov     [eax + 26], ecx
+@26:    mov     [eax + 22], ecx
+@22:    mov     [eax + 18], ecx
+@18:    mov     [eax + 14], ecx
+@14:    mov     [eax + 10], ecx
+@10:    mov     [eax + 6], ecx
+@06:    mov     [eax + 2], ecx
+@02:    mov     word ptr [eax], cx
+end;
+
+{$ifndef FPC_X86} // FPC RTL has fastmove.inc -> our SSE2/ERMS asm is slower
+
+// fast SSE2 version - force define HASNOSSE2 when run any very old CPU
+procedure MoveFast(const src; var dst; cnt: PtrInt);
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=source edx=dest ecx=count
+        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
+{$ifdef HASNOSSE2}
+@sml:   fild    qword ptr [eax + ecx]   // last 8
+        fild    qword ptr [eax]         // first 8
+        cmp     ecx, 8
+        jle     @sml16
+        fild    qword ptr [eax + 8]     // second 8
+        cmp     ecx, 16
+        jle     @sml24
+        fild    qword ptr [eax + 16]    // third 8
+        fistp   qword ptr [edx + 16]    // third 8
+@sml24: fistp   qword ptr [edx + 8]     // second 8
+@sml16: fistp   qword ptr [edx]         // first 8
+        fistp   qword ptr [edx + ecx]   // last 8
+{$else}
+@sml:   movq    xmm0, qword ptr [eax + ecx]   // last 8
+        movq    xmm1, qword ptr [eax]         // first 8
+        cmp     ecx, 8
+        jle     @sml16
+        movq    xmm2, qword ptr [eax + 8]     // second 8
+        cmp     ecx, 16
+        jle     @sml24
+        movq    xmm3, qword ptr [eax + 16]    // third 8
+        movq    qword ptr [edx + 16], xmm3    // third 8
+@sml24: movq    qword ptr [edx + 8], xmm2     // second 8
+@sml16: movq    qword ptr [edx], xmm1         // first 8
+        movq    qword ptr [edx + ecx], xmm0   // last 8
+        ret
+{$endif HASNOSSE2}
+@exit:  rep     ret
+{$ifdef FPC} align 4 {$else} {$ifdef HASALIGN} .align 4 {$endif}{$endif}
+@table: dd      @exit, @m01, @m02, @m03, @m04, @m05, @m06, @m07, @m08
+{$ifdef WITH_ERMSASM}
+@ermsf: push    esi
+        push    edi
+        mov     esi, eax
+        mov     edi, edx
+        cld
+        rep     movsb  // ERMSB forward move
+        pop     edi
+        pop     esi
+        ret
+@ermsb: push    esi
+        push    edi
+        lea     esi, [eax + ecx - 1]
+        lea     edi, [edx + ecx - 1]
+        std
+        rep     movsb  // backward move is slow even if ERMSB is set
+        pop     edi
+        pop     esi
+        cld            // FPC requires this
+        ret
+{$endif WITH_ERMSASM}
+{$ifdef HASNOSSE2}
+@lrg:   jng    @exit   // count < 0
+        sub    edx, eax
+        jz     @exit
+        cmp    edx, ecx
+        lea    edx, [edx + eax]
+        jb     @ermsb  // move backwards if unsigned(dest-source) < count
+        jmp    @ermsf
+{$else}
+@lrgfwd:// large forward move
+        {$ifdef WITH_ERMS}
+        cmp     ecx, NONTEMPORALSIZE
+        jae     @noermf // movntdq was reported to be faster than ERMSB
+        cmp     ecx, ERMSB_MIN_SIZE_FWD
+        ja      @ermsf
+@noermf:{$endif WITH_ERMS}
+        push    edx
+        movups  xmm2, dqword ptr [eax]       // first 16
+        lea     eax, [eax + ecx - 16]
+        lea     ecx, [ecx + edx - 16]
+        movups  xmm1, dqword ptr [eax]       // last 16
+        push    ecx
+        neg     ecx
+        and     edx, -16                     // 16-byte align writes
+        lea     ecx, [ecx + edx + 16]
+        pop     edx
+        cmp     ecx, -NONTEMPORALSIZE        // assume > 512KB bypass the cache
+        jl      @fwnv
+{$ifdef FPC} align 16 {$else} {$ifdef HASALIGN} .align 16 {$endif}{$endif}
+@fwd:   movups  xmm0, dqword ptr [eax + ecx] // move by 16 bytes
+        movaps  dqword ptr [edx + ecx], xmm0
+        add     ecx, 16
+        jl      @fwd
+@fwde:  movups  dqword ptr [edx], xmm1       // last 16
+        pop     edx
+        movups  dqword ptr [edx], xmm2       // first 16
+        ret
+{$ifdef FPC} align 16 {$else} {$ifdef HASALIGN} .align 16 {$endif}{$endif}
+@fwnv:  movups  xmm0, dqword ptr [eax + ecx]
+        movntdq dqword ptr [edx + ecx], xmm0 // non-temporal move by 16 bytes
+        add     ecx, 16
+        jl      @fwnv
+        sfence
+        jmp     @fwde
+@lrg:   jng     @exit      // count < 0
+        sub     edx, eax
+        jz      @exit      // source=dest
+        cmp     edx, ecx
+        lea     edx, [edx + eax]
+        jae     @lrgfwd   // move backwards if unsigned(dest-source) < count
+        // large backward/overlapping move
+@lrgbwd:{$ifdef WITH_ERMS}
+        cmp     ecx, ERMSB_MIN_SIZE_BWD // enabled for no-SSE2, not for ERMSB
+        ja      @ermsb
+        {$endif WITH_ERMS}
+        sub     ecx, 16
+        push    ecx
+        movups  xmm2, dqword ptr [eax + ecx] // last 16
+        movups  xmm1, dqword ptr [eax]       // first 16
+        add     ecx, edx
+        and     ecx, -16              // 16-byte align writes
+        sub     ecx, edx
+        // non-volatile backward is not efficient since we overlap data
+{$ifdef FPC} align 16 {$else} {$ifdef HASALIGN} .align 16 {$endif}{$endif}
+@bwd:   movups  xmm0, dqword ptr [eax + ecx]
+        movaps  dqword ptr [edx + ecx], xmm0
+        sub     ecx, 16
+        jg      @bwd
+        pop     ecx
+        movups  dqword ptr [edx], xmm1       // first 16
+        movups  dqword ptr [edx + ecx], xmm2 // last 16
+        ret
+{$endif HASNOSSE2}
+@m01:   mov     al, [eax]
+        mov     [edx], al
+        ret
+@m02:   movzx   eax, word ptr [eax]
+        mov     [edx], ax
+        ret
+@m03:   movzx   ecx, word ptr [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]
+        movzx   eax, word ptr [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;
+
+{$endif FPC_X86}
+
+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 crc32fasttab(crc: cardinal; buf: PAnsiChar; len: cardinal;
+  tab: PCrc32tab): cardinal;
+asm
+        // adapted from Aleksandr Sharahov code and Maxim Masiutin remarks
+        push    ebx
+        push    ebp
+        mov     ebp, tab
+        not     eax
+        neg     ecx       // eax=crc edx=buf ecx=-len ebp=tab
+        jz      @z
+        test    edx, edx
+        jz      @z
+@head:  test    dl, 3
+        jz      @align
+        movzx   ebx, byte ptr [edx]
+        inc     edx
+        xor     bl, al
+        shr     eax, 8
+        xor     eax, dword ptr [ebx * 4 + ebp]
+        inc     ecx
+        jnz     @head
+@z:     jmp     @e
+@align: sub     edx, ecx
+        add     ecx, 8
+        jg      @done
+        push    esi
+        push    edi
+        mov     edi, edx
+        {$ifdef FPC} align   8 {$endif FPC}
+@by8:   mov     edx, eax
+        mov     ebx, [edi + ecx - 4]
+        xor     edx, [edi + ecx - 8]
+        movzx   esi, bl
+        mov     eax, dword ptr [esi * 4 + ebp + 1024 * 3]
+        movzx   esi, bh
+        xor     eax, dword ptr [esi * 4 + ebp + 1024 * 2]
+        shr     ebx, 16
+        movzx   esi, bl
+        xor     eax, dword ptr [esi * 4 + ebp + 1024 * 1]
+        movzx   esi, bh
+        xor     eax, dword ptr [esi * 4 + ebp + 1024 * 0]
+        movzx   esi, dl
+        xor     eax, dword ptr [esi * 4 + ebp + 1024 * 7]
+        movzx   esi, dh
+        xor     eax, dword ptr [esi * 4 + ebp + 1024 * 6]
+        shr     edx, 16
+        movzx   esi, dl
+        xor     eax, dword ptr [esi * 4 + ebp + 1024 * 5]
+        movzx   esi, dh
+        xor     eax, dword ptr [esi * 4 + ebp + 1024 * 4]
+        add     ecx, 8
+        jle     @by8
+        mov     edx, edi
+        pop     edi
+        pop     esi
+@done:  sub     ecx, 8
+        jge     @e
+@tail:  movzx   ebx, byte[edx + ecx]
+        xor     bl, al
+        shr     eax, 8
+        xor     eax, dword ptr [ebx * 4 + ebp]
+        inc     ecx
+        jnz     @tail
+@e:     pop     ebp
+        pop     ebx
+        not     eax
+end;
+
+procedure crcblockfast(crc128, data128: PBlock128);
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // Delphi is not efficient about corresponding 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
+        // note: since we have "+ 1024 * n" offsets, crc32ctab is left immediate
+        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 fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=crc, edx=buf, ecx=len
+        push    ebx
+        test    edx, edx
+        jz      @0
+        neg     ecx
+        jz      @0
+        sub     edx, ecx
+@1:     movzx   ebx, byte ptr [edx + ecx]
+        xor     eax, ebx
+        imul    eax, eax, 16777619
+        inc     ecx
+        jnz     @1
+@0:     pop     ebx
+end; // we tried an unrolled version, but it was slower on our Core i7!
+
+function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=crc, edx=buf, ecx=len
+        test    ecx, ecx
+        push    edi
+        push    esi
+        push    ebx
+        push    ebp
+        jz      @z
+        cmp     ecx, 4
+        jb      @s
+@8:     mov     ebx, [edx] // unrolled version reading per dword
+        add     edx, 4
+        mov     esi, eax
+        movzx   edi, bl
+        movzx   ebp, bh
+        shr     ebx, 16
+        shl     eax, 5
+        sub     eax, esi
+        add     eax, edi
+        mov     esi, eax
+        shl     eax, 5
+        sub     eax, esi
+        lea     esi, [eax + ebp]
+        add     eax, ebp
+        movzx   edi, bl
+        movzx   ebx, bh
+        shl     eax, 5
+        sub     eax, esi
+        lea     ebp, [eax + edi]
+        add     eax, edi
+        shl     eax, 5
+        sub     eax, ebp
+        add     eax, ebx
+        cmp     ecx, 8
+        lea     ecx, [ecx - 4]
+        jae     @8
+        test    ecx, ecx
+        jz      @z
+@s:     mov     esi, eax
+@1:     shl     eax, 5
+        movzx   ebx, byte ptr [edx]
+        inc     edx
+        sub     eax, esi
+        lea     esi, [eax + ebx]
+        add     eax, ebx
+        dec     ecx
+        jnz     @1
+@z:     pop     ebp
+        pop     ebx
+        pop     esi
+        pop     edi
+end;
+
+function StrLenSSE2(S: pointer): PtrInt;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // from GPL strlen32.asm by Agner Fog - www.agner.org/optimize
+        mov     ecx, eax            // copy pointer
+        test    eax, eax
+        jz      @null               // returns 0 if S=nil
+        push    eax                 // save start address
+        pxor    xmm0, xmm0          // set to zero
+        and     ecx, 15             // lower 4 bits indicate misalignment
+        and     eax, -16            // align pointer by 16
+        // will never read outside a memory page boundary, so won't trigger GPF
+        movaps  xmm1, [eax]         // read from nearest preceding boundary
+        pcmpeqb xmm1, xmm0          // compare 16 bytes with zero
+        pmovmskb edx, xmm1          // get one bit for each byte result
+        shr     edx, cl             // shift out false bits
+        shl     edx, cl             // shift back again
+        bsf     edx, edx            // find first 1-bit
+        jnz     @A200               // found
+        // Main loop, search 16 bytes at a time
+@A100:  add     eax, 10H            // increment pointer by 16
+        movaps  xmm1, [eax]         // read 16 bytes aligned
+        pcmpeqb xmm1, xmm0          // compare 16 bytes with zero
+        pmovmskb edx, xmm1          // get one bit for each byte result
+        bsf     edx, edx            // find first 1-bit
+        // (moving the bsf out of the loop and using test here would be faster
+        // for long strings on old processors, but we are assuming that most
+        // strings are short, and newer processors have higher priority)
+        jz      @A100               // loop if not found
+@A200:  // Zero-byte found. Compute string length
+        pop     ecx                 // restore start address
+        sub     eax, ecx            // subtract start address
+        add     eax, edx            // add byte index
+@null:
+end;
+
+function StrInt32(P: PAnsiChar; val: PtrInt): PAnsiChar;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=P, edx=val
+        mov     ecx, edx
+        sar     ecx, 31         // 0 if val>=0 or -1 if val<0
+        push    ecx
+        xor     edx, ecx
+        sub     edx, ecx        // edx=abs(val)
+        cmp     edx, 10
+        jb      @3  // direct process of common val<10
+        push    edi
+        mov     edi, eax
+        mov     eax, edx
+@s:     sub     edi, 2
+        cmp     eax, 100
+        jb      @2
+        mov     ecx, eax
+        mov     edx, 1374389535 // use power of two reciprocal to avoid division
+        mul     edx
+        shr     edx, 5          // now edx=eax div 100
+        mov     eax, edx
+        imul    edx, -200
+        movzx   edx, word ptr [TwoDigitLookup + ecx * 2 + edx]
+        mov     [edi], dx
+        cmp     eax, 10
+        jae     @s
+@1:     dec     edi
+        or      al, '0'
+        mov     byte ptr [edi - 1], '-'
+        mov     [edi], al
+        mov     eax, edi
+        pop     edi
+        pop     ecx
+        add     eax, ecx // includes '-' if val<0
+        ret
+@2:     movzx   eax, word ptr [TwoDigitLookup + eax * 2]
+        mov     byte ptr [edi - 1], '-'
+        mov     [edi], ax
+        mov     eax, edi
+        pop     edi
+        pop     ecx
+        add     eax, ecx // includes '-' if val<0
+        ret
+@3:     dec     eax
+        pop     ecx
+        or      dl, '0'
+        mov     byte ptr [eax - 1], '-'
+        mov     [eax], dl
+        add     eax, ecx // includes '-' if val<0
+end;
+
+function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=P, edx=val
+        cmp     edx, 10
+        jb      @3  // direct process of common val=0 (or val<10)
+        push    edi
+        mov     edi, eax
+        mov     eax, edx
+@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;
+
+procedure YearToPChar(Y: PtrUInt; P: PUtf8Char);
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=Y, edx=P
+        push    edx
+        mov     ecx, eax
+        mov     edx, 1374389535 // use power of two reciprocal to avoid division
+        mul     edx
+        shr     edx, 5          // now edx=Y div 100
+        movzx   eax, word ptr [TwoDigitLookup + edx * 2]
+        imul    edx, -200
+        movzx   edx, word ptr [TwoDigitLookup + ecx * 2 + edx]
+        pop     ecx
+        shl     edx, 16
+        or      eax, edx
+        mov     [ecx], eax
+end;
+
+{$endif ASMX86}
+
+// functions below are always available, even on DARWIN
+
+function Hash32(Data: PCardinalArray; Len: integer): cardinal;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=Data edx=Len
+        push    esi
+        push    edi
+        mov     cl, dl
+        mov     ch, dl
+        xor     esi, esi
+        xor     edi, edi
+        test    eax, eax
+        jz      @z
+        shr     edx, 4
+        jz      @by4
+        nop
+@by16:  add     esi, dword ptr [eax]
+        add     edi, esi
+        add     esi, dword ptr [eax+4]
+        add     edi, esi
+        add     esi, dword ptr [eax+8]
+        add     edi, esi
+        add     esi, dword ptr [eax+12]
+        add     edi, esi
+        add     eax, 16
+        dec     edx
+        jnz     @by16
+@by4:   and     cl, 15
+        jz      @0
+        shr     cl, 2
+        jz      @rem
+@4:     add     esi, dword ptr [eax]
+        add     edi, esi
+        add     eax, 4
+        dec     cl
+        jnz     @4
+@rem:   and     ch, 3
+        jz      @0
+        dec     ch
+        jz      @1
+        dec     ch
+        jz      @2
+        mov     eax, dword ptr [eax]
+        and     eax, $ffffff
+        jmp     @e
+@2:     movzx   eax, word ptr [eax]
+        jmp     @e
+@1:     movzx   eax, byte ptr [eax]
+@e:     add     esi, eax
+@0:     add     edi, esi
+        mov     eax, esi
+        shl     edi, 16
+        xor     eax, edi
+@z:     pop     edi
+        pop     esi
+end;
+
+function xxHash32(crc: cardinal; P: PAnsiChar; len: cardinal): 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;
+
+function GetBitsCountPas(value: PtrInt): PtrInt;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // branchless Wilkes-Wheeler-Gill i386 asm implementation
+        mov     edx, eax
+        shr     eax, 1
+        and     eax, $55555555
+        sub     edx, eax
+        mov     eax, edx
+        shr     edx, 2
+        and     eax, $33333333
+        and     edx, $33333333
+        add     eax, edx
+        mov     edx, eax
+        shr     eax, 4
+        add     eax, edx
+        and     eax, $0f0f0f0f
+        mov     edx, eax
+        shr     edx, 8
+        add     eax, edx
+        mov     edx, eax
+        shr     edx, 16
+        add     eax, edx
+        and     eax, $3f
+end;
+
+{$ifdef HASNOSSE2} // fallback to simple pascal code if no SSE2 available
+
+function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: byte): PtrInt;
+begin
+  result := 0;
+  if P <> nil then
+    repeat
+      if result >= Count then
+        break;
+      if P^[result] = Value then
+        exit;
+      inc(result);
+    until false;
+  result := -1;
+end;
+
+function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): PtrInt;
+begin
+  result := 0;
+  if P <> nil then
+    repeat
+      if result >= Count then
+        break;
+      if P^[result] = Value then
+        exit;
+      inc(result);
+    until false;
+  result := -1;
+end;
+
+function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt;
+begin
+  result := PtrUInt(IntegerScan(P, Count, Value));
+  if result = 0 then
+    dec(result)
+  else
+  begin
+    dec(result, PtrUInt(P));
+    result := result shr 2;
+  end;
+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]
+{$ifdef FPC} align   4 {$endif FPC}
+@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;
+
+{$else}
+
+function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: byte): PtrInt;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=P, edx=Count, cl=Value
+        push    ebx
+        mov     ebx, eax
+        movzx   eax, cl
+        mov     ecx, ebx
+        test    edx, edx
+        jbe     @no
+        // eax=Value, ecx=P edx=Count
+        imul    eax, $01010101
+        and     ecx, -16
+        movd    xmm1, eax
+        movaps  xmm0, [ecx]
+        add     ecx, 16
+        pshufd  xmm1, xmm1, 0
+        sub     ecx, ebx
+        pcmpeqb xmm0, xmm1
+        pmovmskb eax, xmm0
+        shl     eax, cl
+        and     eax, $FFFF0000
+        shr     eax, cl
+        jnz     @fnd
+        cmp     edx, ecx
+        jbe     @no
+{$ifdef FPC} align 16 {$else} {$ifdef HASALIGN} .align 16 {$endif}{$endif}
+@by16:  movaps  xmm0, [ebx + ecx]
+        add     ecx, 16
+        pcmpeqb xmm0, xmm1
+        pmovmskb eax, xmm0
+        bsf     eax, eax
+        jnz     @fnd2
+        cmp     edx, ecx
+        ja      @by16
+@no:    mov     eax, -1
+        pop     ebx
+        ret
+@fnd:   bsf     eax, eax
+@fnd2:  lea     eax, [ecx + eax - 16]
+        cmp     edx, eax
+        jbe     @no
+        pop     ebx
+end;
+
+function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): PtrInt;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=P, edx=Count, cx=Value
+        push    ebx
+        mov     ebx, eax
+        movzx   eax, cx
+        mov     ecx, ebx
+        test    edx, edx
+        jbe     @no
+        test    cl, 1
+        jnz     @unal
+        // eax=Value, ecx=P edx=Count
+        movd    xmm1, eax
+        and     ecx, -16
+        punpcklwd xmm1, xmm1
+        movaps  xmm0, [ecx]
+        add     ecx, 16
+        pshufd  xmm1, xmm1, 0
+        sub     ecx, ebx
+        pcmpeqw xmm0, xmm1
+        pmovmskb eax, xmm0
+        shl     eax, cl
+        and     eax, $FFFF0000
+        shr     eax, cl
+        shr     ecx, 1
+        test    eax, eax
+        jz      @nxt
+        bsf     eax, eax
+@fnd:   shr     eax, 1
+        lea     eax, [ecx + eax - 8]
+        cmp     edx, eax
+        jbe     @no
+        pop     ebx
+        ret
+        nop // manual loop alignment
+@by16:  movaps  xmm0, [ebx + ecx * 2]
+        add     ecx, 8
+        pcmpeqw xmm0, xmm1
+        pmovmskb eax, xmm0
+        bsf     eax, eax
+        jnz     @fnd
+@nxt:   cmp     edx, ecx
+        ja      @by16
+@no:    mov     eax, -1
+        pop     ebx
+        ret
+        // 16bit-unaligned loop (seldom called)
+@unal:  lea     ecx, [ecx + edx * 2]
+        neg     edx
+@unals: cmp     word ptr [ecx + edx * 2], ax
+        jz      @unale
+        inc     edx
+        jnz     @unals
+        jmp     @no
+@unale: lea     eax, [ecx + edx * 2]
+        sub     eax, ebx
+        shr     eax, 1
+        pop     ebx
+end;
+
+function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=P, edx=Count, ecx=Value
+        push    ebx
+        movd    xmm1, ecx
+        mov     ebx, eax
+        mov     eax, ecx
+        mov     ecx, ebx
+        test    edx, edx
+        jbe     @no
+        test    cl, 3
+        jnz     @unal
+        // eax=Value, ecx=P edx=Count
+        and     ecx, -16
+        movaps  xmm0, [ecx]
+        add     ecx, 16
+        pshufd  xmm1, xmm1, 0
+        sub     ecx, ebx
+        pcmpeqd xmm0, xmm1
+        pmovmskb eax, xmm0
+        shl     eax, cl
+        and     eax, $FFFF0000
+        shr     eax, cl
+        shr     ecx, 2
+        bsf     eax, eax
+        jz      @nxt
+@fnd:   shr     eax, 2
+        lea     eax, [ecx + eax - 4]
+        cmp     edx, eax
+        jbe     @no
+        pop     ebx
+        ret
+{$ifdef FPC} align 16 {$else} nop;nop;nop;nop;nop;nop {$endif FPC}
+@by16:  movaps  xmm0, [ebx + ecx * 4]
+        add     ecx, 4
+        pcmpeqd xmm0, xmm1
+        pmovmskb eax, xmm0
+        bsf     eax, eax
+        jnz     @fnd
+@nxt:   cmp     edx, ecx
+        ja      @by16
+@no:    mov     eax, -1
+        pop     ebx
+        ret
+        // 32bit-unaligned loop (seldom called)
+@unal:  lea     ecx, [ecx + edx * 4]
+        neg     edx
+@unals: cmp     dword ptr [ecx + edx * 4], eax
+        jz      @unale
+        inc     edx
+        jnz     @unals
+        jmp     @no
+@unale: lea     eax, [ecx + edx * 4]
+        sub     eax, ebx
+        shr     eax, 2
+        pop     ebx
+end;
+
+{$endif HASNOSSE2}
+
+procedure mul64x64(const left, right: QWord; out product: THash128Rec);
+{$ifdef FPC}nostackframe; assembler; {$endif}
+asm
+        // adapted from FPC compiler output, which is much better than Delphi's here
+        {$ifdef FPC}
+        push    ebp
+        mov     ebp, esp
+        {$endif FPC}
+        mov     ecx, eax
+        mov     eax, dword ptr [ebp+8H]
+        mul     dword ptr [ebp+10H]
+        mov     dword ptr [ecx], eax
+        mov     dword ptr [ebp-4H], edx
+        mov     eax, dword ptr [ebp+8H]
+        mul     dword ptr [ebp+14H]
+        add     eax, dword ptr [ebp-4H]
+        adc     edx, 0
+        mov     dword ptr [ebp-10H], eax
+        mov     dword ptr [ebp-0CH], edx
+        mov     eax, dword ptr [ebp+0CH]
+        mul     dword ptr [ebp+10H]
+        add     eax, dword ptr [ebp-10H]
+        adc     edx, 0
+        mov     dword ptr [ecx+4H], eax
+        mov     dword ptr [ebp-14H], edx
+        mov     eax, dword ptr [ebp+0CH]
+        mul     dword ptr [ebp+14H]
+        add     eax, dword ptr [ebp-0CH]
+        adc     edx, 0
+        add     eax, dword ptr [ebp-14H]
+        adc     edx, 0
+        mov     dword ptr [ecx+8H], eax
+        mov     dword ptr [ecx+0CH], edx
+        {$ifdef FPC}
+        pop     ebp
+        {$endif FPC}
+end;
+
+function bswap32(a: cardinal): cardinal;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        bswap eax
+end;
+
+function bswap64({$ifdef FPC}constref{$else}const{$endif} a: QWord): QWord;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        {$ifdef FPC}
+        mov     edx, dword ptr [eax]
+        mov     eax, dword ptr [eax + 4]
+        {$else}
+        mov     edx, a.TQWordRec.L
+        mov     eax, a.TQWordRec.H
+        {$endif FPC}
+        bswap   edx
+        bswap   eax
+end;
+
+procedure bswap64array(A, B: PQWordArray; n: PtrInt);
+{$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;
+
+procedure LockedInc32(int32: PInteger);
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+   lock inc     dword ptr [int32]
+end;
+
+procedure LockedDec32(int32: PInteger);
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+   lock dec     dword ptr [int32]
+end;
+
+procedure LockedInc64(int64: PInt64);
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+   lock inc     dword ptr [int64]
+        jz      @h
+        ret
+@h:lock inc     dword ptr [int64 + 4] // collision is very unlikely
+end;
+
+function InterlockedIncrement(var I: integer): integer;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        mov     edx, 1
+        xchg    eax, edx
+   lock xadd    [edx], eax
+        inc     eax
+end;
+
+function InterlockedDecrement(var I: integer): integer;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        mov     edx, -1
+        xchg    eax, edx
+   lock xadd    [edx], eax
+        dec     eax
+end;
+
+function StrLenSafe(S: pointer): PtrInt;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // slower than StrLenSSE2(), but won't read any byte beyond the page
+        test  eax, eax
+        jz    @z
+        cmp   byte ptr [eax], 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
+        nop                          // @s loop code alignment
+@s:     add   eax, 4
+        mov   edx, dword ptr [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    @s                     // loop until any #0 found
+@set:   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               // length
+@z:     ret
+@0:     xor   eax, eax
+        ret
+@1:     mov   eax, 1
+        ret
+@2:     mov   eax, 2
+        ret
+@3:     mov   eax, 3
+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 StrComp(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, byte ptr [eax]
+        mov     ch, byte ptr [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;
+
+function SortDynArrayInteger(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        mov     ecx, dword ptr [eax]
+        mov     edx, dword ptr[edx]
+        xor     eax, eax
+        cmp     ecx, edx
+        setl    cl
+        setg    al
+        movzx   ecx, cl
+        sub     eax, ecx
+end;
+
+function SortDynArrayCardinal(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        mov     ecx, [eax]
+        mov     edx, [edx]
+        xor     eax, eax
+        cmp     ecx, edx
+        seta    al
+        sbb     eax,0
+end;
+
+function SortDynArrayPointer(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        mov     ecx, [eax]
+        mov     edx, [edx]
+        xor     eax, eax
+        cmp     ecx, edx
+        seta    al
+        sbb     eax,0
+end;
+
+function SortDynArrayInt64(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // Delphi x86 compiler is not efficient at compiling Int64 comparisons
+        mov     ecx, [eax]
+        mov     eax, [eax + 4]
+        cmp     eax, [edx + 4]
+        jnz     @nz
+        cmp     ecx, [edx]
+        jz      @0
+        jnb     @p
+@n:     mov     eax, -1
+        ret
+@0:     xor     eax, eax
+        ret
+@nz:    jl      @n
+@p:     mov     eax, 1
+end;
+
+function SortDynArrayQWord(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+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
+        mov     eax, -1
+        ret
+@0:     xor     eax, eax
+        ret
+@p:     mov     eax, 1
+end;
+
+function SortDynArrayAnsiString(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // x86 version optimized for AnsiString/RawUtf8/RawByteString types
+        mov     eax, dword ptr [eax]
+        mov     edx, dword ptr [edx]
+        cmp     eax, edx
+        je      @0
+        test    eax, edx
+        jz      @maynil
+@f:     mov     cl, byte ptr [eax] // first char comparison (quicksort speedup)
+        mov     ch, byte ptr [edx]
+        cmp     cl, ch
+        je      @s
+        movzx   eax, cl
+        movzx   edx, ch
+        sub     eax, edx            // branchless execution on Quicksort/ReHash
+        ret
+@0:     xor     eax, eax
+        ret
+@maynil:test    edx, edx       // A or B may be ''
+        jz      @1
+        test    eax, eax
+        jnz     @f
+        dec     eax
+        ret
+@s:     push    ebx
+        xor     ecx, ecx
+        mov     ebx, dword ptr [eax - 4]
+        sub     ebx, dword ptr [edx - 4]   // ebx = length(A)-length(B)
+        push    ebx
+        adc     ecx, -1
+        and     ecx, ebx
+        sub     ecx, dword ptr [eax - 4]   // ecx = -min(length(A),length(B))
+        sub     eax, ecx
+        sub     edx, ecx
+{$ifdef FPC} align 16 {$endif} // is naturally aligned anyway
+@by4:   mov     ebx, dword ptr [eax + ecx]  // compare 4 bytes per iteration
+        xor     ebx, dword ptr [edx + ecx]
+        jnz     @d
+        add     ecx, 4
+        js      @by4
+@eq:    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     @eq
+        movzx   eax, byte ptr [eax + ecx]
+        movzx   edx, byte ptr [edx + ecx]
+        pop     ebx
+        pop     ebx
+        sub     eax, edx
+        ret
+@1:     mov     eax, 1
+end;
+
+function SortDynArrayDouble(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        fld     qword ptr [eax]
+        fcomp   qword ptr [edx]
+        fstsw   ax
+        sahf
+        jz      @0
+@nz:    jnb     @p
+        mov     eax, -1
+        ret
+@0:     xor     eax, eax
+        ret
+@p:     mov     eax, 1
+end;
+
+function SortDynArraySingle(const A, B): integer;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        fld     dword ptr [eax]
+        fcomp   dword ptr [edx]
+        fstsw   ax
+        sahf
+        jz      @0
+@nz:    jnb     @p
+        mov     eax, -1
+        ret
+@0:     xor     eax, eax
+        ret
+@p:     mov     eax, 1
+end;
+
+procedure DynArrayHashTableAdjust(P: PIntegerArray; deleted: integer; count: PtrInt);
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=P edx=deleted ecx=count
+        push    ebx
+        mov     ebx, eax
+        xor     eax, eax
+@by8:   sub     ecx, 8
+        cmp     edx, dword ptr [ebx]
+        setl    al
+        sub     dword ptr [ebx], eax
+        cmp     edx, dword ptr [ebx + 4H]
+        setl    al
+        sub     dword ptr [ebx + 4H], eax
+        cmp     edx, dword ptr [ebx + 8H]
+        setl    al
+        sub     dword ptr [ebx + 8H], eax
+        cmp     edx, dword ptr [ebx + 0CH]
+        setl    al
+        sub     dword ptr [ebx + 0CH], eax
+        cmp     edx, dword ptr [ebx + 10H]
+        setl    al
+        sub     dword ptr [ebx + 10H], eax
+        cmp     edx, dword ptr [ebx + 14H]
+        setl    al
+        sub     dword ptr [ebx + 14H], eax
+        cmp     edx, dword ptr [ebx + 18H]
+        setl    al
+        sub     dword ptr [ebx + 18H], eax
+        cmp     edx, dword ptr [ebx + 1CH]
+        setl    al
+        sub     dword ptr [ebx + 1CH], eax
+        add     ebx, 32
+        cmp     ecx, 8
+        jge     @by8
+        test    ecx, ecx
+        jz      @ok
+        // trailing indexes (never appearing within DYNARRAYHASH_PO2 range)
+@by1:   cmp     edx, dword ptr [ebx]
+        setl    al
+        sub     dword ptr [ebx], eax
+        add     ebx, 4
+        dec     ecx
+        jnz     @by1
+@ok:    pop     ebx
+end;
+
+procedure DynArrayHashTableAdjust16(P: PWordArray; deleted: cardinal; count: PtrInt);
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=P dx=deleted ecx=count
+        push    ebx
+        mov     ebx, eax
+        xor     eax, eax
+@by8:   sub     ecx, 8
+        cmp     dx, word ptr [ebx]
+        setl    al
+        sub     word ptr [ebx], ax
+        cmp     dx, word ptr [ebx + 2]
+        setl    al
+        sub     word ptr [ebx + 2], ax
+        cmp     dx, word ptr [ebx + 4]
+        setl    al
+        sub     word ptr [ebx + 4], ax
+        cmp     dx, word ptr [ebx + 6]
+        setl    al
+        sub     word ptr [ebx + 6], ax
+        cmp     dx, word ptr [ebx + 8]
+        setl    al
+        sub     word ptr [ebx + 8], ax
+        cmp     dx, word ptr [ebx + 10]
+        setl    al
+        sub     word ptr [ebx + 10], ax
+        cmp     dx, word ptr [ebx + 12]
+        setl    al
+        sub     word ptr [ebx + 12], ax
+        cmp     dx, word ptr [ebx + 14]
+        setl    al
+        sub     word ptr [ebx + 14], ax
+        add     ebx, 16
+        cmp     ecx, 8
+        jge     @by8
+        test    ecx, ecx
+        jz      @ok
+        // trailing indexes (never appearing within DYNARRAYHASH_PO2 range)
+@by1:   cmp     dx, word ptr [ebx]
+        setl    al
+        sub     word ptr [ebx], ax
+        add     ebx, 2
+        dec     ecx
+        jnz     @by1
+@ok:    pop     ebx
+end;
+
+function GetBitsCountSse42(value: PtrInt): PtrInt;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=value
+        {$ifdef HASAESNI}
+        popcnt  eax, eax
+        {$else} // oldest Delphi don't support this opcode
+        db      $f3,$0f,$B8,$c0
+        {$endif HASAESNI}
+end;
+
+function crc32cby4sse42(crc, value: cardinal): cardinal;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=crc, edx=value
+        {$ifdef HASAESNI}
+        crc32   eax, edx
+        {$else} // oldest Delphi don't support this opcode
+        db      $F2, $0F, $38, $F1, $C2
+        {$endif HASAESNI}
+end;
+
+procedure crcblocksse42(crc128, data128: PBlock128);
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=crc128, edx=data128
+        mov     ecx, eax
+        {$ifdef HASAESNI}
+        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} // oldest Delphi don't support these opcodes
+        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 HASAESNI}
+end;
+
+procedure crcblockssse42(crc128, data128: PBlock128; count: integer);
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+          // eax=crc128 edx=data128 ecx=count
+          push    ebx
+          push    esi
+          push    edi
+          push    ebp
+          test    count, count
+          jle     @z
+          mov     ebp, count
+          mov     esi, crc128
+          mov     edi, data128
+          mov     eax, dword ptr [esi]
+          mov     ebx, dword ptr [esi + 4]
+          mov     ecx, dword ptr [esi + 8]
+          mov     edx, dword ptr [esi + 12]
+          {$ifdef HASAESNI}
+{$ifdef FPC} align 16 {$else} {$ifdef HASALIGN} .align 16 {$endif}{$endif}
+@s:       crc32   eax, dword ptr [edi]
+          crc32   ebx, dword ptr [edi + 4]
+          crc32   ecx, dword ptr [edi + 8]
+          crc32   edx, dword ptr [edi + 12]
+          {$else}  // oldest Delphi don't support these opcodes
+@s:       db $F2, $0F, $38, $F1, $07
+          db $F2, $0F, $38, $F1, $5F, $04
+          db $F2, $0F, $38, $F1, $4F, $08
+          db $F2, $0F, $38, $F1, $57, $0C
+          {$endif HASAESNI}
+          add     edi, 16
+          dec     ebp
+          jnz     @s
+          mov     dword ptr [esi], eax
+          mov     dword ptr [esi + 4], ebx
+          mov     dword ptr [esi + 8], ecx
+          mov     dword ptr [esi + 12], edx
+@z:       pop     ebp
+          pop     edi
+          pop     esi
+          pop     ebx
+end;
+
+function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // eax=crc, edx=buf, ecx=len
+        not     eax
+        test    ecx, ecx
+        jz      @0
+        test    edx, edx
+        jz      @0
+        jmp     @align
+@a:     {$ifdef HASAESNI}
+        crc32   eax, byte ptr [edx]
+        {$else} // oldest Delphi don't support these opcodes
+        db      $F2, $0F, $38, $F0, $02
+        {$endif HASAESNI}
+        inc     edx
+        dec     ecx
+        jz      @0
+@align: test    dl, 3
+        jnz     @a
+        push    ecx
+        shr     ecx, 3
+        jnz     @by8
+@rem:   pop     ecx
+        test    cl, 4
+        jz      @4
+        {$ifdef HASAESNI}
+        crc32   eax, dword ptr [edx]
+        {$else}
+        db      $F2, $0F, $38, $F1, $02
+        {$endif HASAESNI}
+        add     edx, 4
+@4:     test    cl, 2
+        jz      @2
+        {$ifdef HASAESNI}
+        crc32   eax, word ptr [edx]
+        {$else}
+        db      $66, $F2, $0F, $38, $F1, $02
+        {$endif HASAESNI}
+        add     edx, 2
+@2:     test    cl, 1
+        jz      @0
+        {$ifdef HASAESNI}
+        crc32   eax, byte ptr [edx]
+        {$else}
+        db      $F2, $0F, $38, $F0, $02
+        {$endif HASAESNI}
+@0:     not     eax
+        ret
+        {$ifdef HASAESNI}
+@by8:   crc32   eax, dword ptr [edx]
+        crc32   eax, dword ptr [edx + 4]
+        {$else}
+@by8:   db      $F2, $0F, $38, $F1, $02
+        db      $F2, $0F, $38, $F1, $42, $04
+        {$endif HASAESNI}
+        add     edx, 8
+        dec     ecx
+        jnz     @by8
+        jmp     @rem
+end;
+
+function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        push    ebp
+        push    ebx
+        push    esi
+        push    edi
+        push    eax
+        add     esp, -4092
+        push    eax
+        add     esp, -4092
+        push    eax
+        add     esp, -4092
+        push    eax
+        add     esp, -4092
+        push    eax
+        add     esp, -24
+        mov     esi, ecx
+        mov     ebx, eax
+        add     edx, eax
+        mov     [esp+8H], esi
+        mov     [esp+10H], edx
+        movzx   eax, word ptr [ebx]
+        mov     [esp], eax
+        or      eax,eax
+        je      @@0917
+        add     ebx, 2
+        mov     eax, [esp]
+        test    ah, 80H
+        jz      @@0907
+        and     eax, 7FFFH
+        movzx   edx, word ptr [ebx]
+        shl     edx, 15
+        or      eax, edx
+        mov     [esp], eax
+        add     ebx, 2
+@@0907: lea     ebp, [esi - 1]
+@@0908: mov     ecx, [ebx]
+        add     ebx, 4
+        mov     [esp+14H], ecx
+        mov     edi, 1             // edi=CWbit
+        cmp     ebx, [esp+10H]
+        jnc     @@0917
+@@0909: mov     ecx, [esp+14H]
+@@090A: test    ecx, edi
+        jnz     @@0911
+        mov     al, [ebx]
+        inc     ebx
+        mov     [esi], al
+        inc     esi
+        cmp     ebx, [esp+10H]
+        lea     eax, [esi-3]
+        jnc     @@0917
+        cmp     eax, ebp
+        jbe     @@0910
+        inc     ebp
+        mov     eax, [ebp]
+        mov     edx, eax
+        shr     eax, 12
+        xor     eax, edx
+        and     eax, 0FFFH
+        mov     [esp+1CH + eax * 4], ebp
+@@0910: add     edi, edi
+        jnz     @@090A
+        jmp     @@0908
+@@0911: movzx   edx, word ptr [ebx]
+        add     ebx, 2
+        mov     eax, edx
+        and     edx, 0FH
+        add     edx, 2
+        shr     eax, 4
+        cmp     edx,2
+        jnz     @@0912
+        movzx   edx, byte ptr [ebx]
+        inc     ebx
+        add     edx, 18
+@@0912: mov     eax, [esp+1CH + eax * 4]
+        mov     ecx, esi
+        mov     [esp+18H], edx
+        sub     ecx, eax
+        // inlined optimized move()
+        cmp     ecx, edx
+        jl      @@ovlap   // overlapping content requires per-byte copy
+        cmp     edx, 32
+        ja      @large
+        sub     edx, 8
+        jg      @9_32
+{$ifdef HASNOSSE2}
+        // slowest x87 FPU code on very old CPU with no SSE2 support
+        mov     ecx, [eax]
+        mov     eax, [eax + 4]     // always copy 8 bytes for 0..8
+        mov     [esi], ecx         // safe since src_endmatch := src_end-(6+5)
+        mov     [esi + 4], eax
+        jmp     @movend
+@9_32:  fild    qword ptr [eax + edx]
+        fild    qword ptr [eax]
+        cmp     edx, 8
+        jle     @16
+        fild    qword ptr [eax + 8]
+        cmp     edx, 16
+        jle     @24
+        fild    qword ptr [eax + 16]
+        fistp   qword ptr [esi + 16]
+@24:    fistp   qword ptr [esi + 8]
+@16:    fistp   qword ptr [esi]
+        fistp   qword ptr [esi + edx]
+        jmp     @movend
+        nop
+@large: push    esi
+        fild    qword ptr [eax]
+        lea     eax, [eax + edx - 8]
+        lea     edx, [esi + edx - 8]
+        fild    qword ptr [eax]
+        push    edx
+        neg     edx
+        and     esi, -8
+        lea     edx, [edx + esi + 8]
+        pop     esi
+@lrgnxt:fild    qword ptr [eax + edx]
+        fistp   qword ptr [esi + edx]
+        add     edx, 8
+        jl      @lrgnxt
+        fistp   qword ptr [esi]
+        pop     esi
+        fistp   qword ptr [esi]
+{$else} // inlined SSE2 move
+        movq    xmm0, qword ptr [eax]
+        movq    qword ptr [esi], xmm0
+        jmp     @movend
+@9_32:  movq    xmm0, qword ptr [eax + edx]
+        movq    xmm1, qword ptr [eax]
+        cmp     edx, 8
+        jle     @16
+        movq    xmm2, qword ptr [eax + 8]
+        cmp     edx, 16
+        jle     @24
+        movq    xmm3, qword ptr [eax + 16]
+        movq    qword ptr [esi + 16], xmm3
+@24:    movq    qword ptr [esi + 8], xmm2
+@16:    movq    qword ptr [esi], xmm1
+        movq    qword ptr [esi + edx], xmm0
+        jmp     @movend
+@large: push    esi
+        movups  xmm2, dqword ptr [eax]
+        lea     eax, [eax + edx - 16]
+        lea     edx, [esi + edx - 16]
+        movups  xmm1, dqword ptr [eax]
+        push    edx
+        neg     edx
+        and     esi, -16
+        lea     edx, [edx + esi + 16]
+        pop     esi
+@lrgnxt:movups  xmm0, dqword ptr [eax + edx]
+        movaps  dqword ptr [esi + edx], xmm0
+        add     edx, 16
+        jl      @lrgnxt
+        movups  dqword ptr [esi], xmm1
+        pop     esi
+        movups  dqword ptr [esi], xmm2
+{$endif HASNOSSE2}
+@movend:cmp     esi, ebp
+        jbe     @@0916
+@@0915: inc     ebp
+        mov     edx, [ebp]
+        mov     eax, edx
+        shr     edx, 12
+        xor     eax, edx
+        and     eax, 0FFFH
+        mov     [esp+1CH + eax * 4], ebp
+        cmp     esi, ebp
+        ja      @@0915
+@@0916: add     esi, [esp+18H]
+        cmp     ebx, [esp+10H]
+        jnc     @@0917
+        add     edi, edi
+        lea     ebp, [esi - 1]
+        jz      @@0908
+        jmp     @@0909
+@@ovlap:push    ebx
+        push    esi
+        lea     ebx, [eax + edx]
+        add     esi, edx
+        neg     edx
+@s:     mov     al, [ebx + edx]
+        mov     [esi + edx], al
+        inc     edx
+        jnz     @s
+        pop     esi
+        pop     ebx
+        jmp     @movend
+@@0917: mov     eax, [esp]
+        add     esp, 16412
+        pop     edi
+        pop     esi
+        pop     ebx
+        pop     ebp
+end;
+
+function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        push    ebp
+        push    ebx
+        push    esi
+        push    edi
+        push    eax
+        add     esp, -4092
+        push    eax
+        add     esp, -4092
+        push    eax
+        add     esp, -4092
+        push    eax
+        add     esp, -4092
+        push    eax
+        add     esp, -4092
+        push    eax
+        add     esp, -4092
+        push    eax
+        add     esp, -4092
+        push    eax
+        add     esp, -4092
+        push    eax
+        add     esp, -32
+        mov     esi, eax // esi=src
+        mov     edi, ecx // edi=dst
+        mov     [esp+08H], ecx
+        mov     eax, edx
+        cmp     eax, 32768
+        jl      @@0889
+        or      ax, 8000H
+        mov     [edi], eax
+        mov     eax, edx
+        shr     eax, 15
+        mov     [edi + 2], eax
+        add     edi, 4
+        jmp     @@0891
+@@0890: mov     eax, 2
+        jmp     @@0904
+@@0889: mov     [edi], eax
+        test    eax, eax
+        jz      @@0890
+        add     edi, 2
+@@0891: lea     eax, [edx + esi]
+        mov     [esp+18H], edi
+        mov     [esp+0CH], eax
+        sub     eax, 11
+        mov     [esp+4], eax
+        xor     eax, eax
+        lea     ebx, [esp+24H] // reset offsets lookup table
+        {$ifdef HASNOSSE2}
+        mov     ecx, 1024
+@@089I: mov     [ebx], eax
+        mov     [ebx + 4], eax
+        mov     [ebx + 8], eax
+        mov     [ebx + 12], eax
+        add     ebx, 16
+        {$else}
+        pxor    xmm0, xmm0
+        mov     ecx, 256
+@@089I: movups  dqword ptr [ebx], xmm0
+        movups  dqword ptr [ebx + 16], xmm0
+        movups  dqword ptr [ebx + 32], xmm0
+        movups  dqword ptr [ebx + 48], xmm0
+        add     ebx, 64
+        {$endif HASNOSSE2}
+        dec     ecx
+        jnz     @@089I
+        mov     [edi], eax
+        add     edi, 4
+        mov     ebx, 1 // ebx=1 shl CWbit
+        // main loop:
+        cmp     esi, [esp+4]
+        ja      @@0900
+@@0892: mov     edx, [esi]
+        mov     eax, edx
+        shr     edx, 12
+        xor     edx, eax
+        and     edx, 0FFFH
+        mov     ebp, [esp+24H + edx * 4]
+        mov     ecx, [esp+4024H + edx * 4]
+        mov     [esp+24H + edx * 4], esi
+        xor     ecx, eax
+        test    ecx, 0FFFFFFH
+        mov     [esp+4024H + edx * 4], eax
+        jnz     @@0897
+        mov     eax, esi
+        or      ebp, ebp
+        jz      @@0897
+        sub     eax, ebp
+        mov     ecx, [esp+18H]
+        cmp     eax, 2
+        jle     @@0897
+        add     esi, 2
+        or      dword ptr [ecx], ebx
+        mov     ecx, [esp+0CH]
+        add     ebp, 2
+        mov     eax, 1
+        sub     ecx, esi
+        dec     ecx
+        mov     [esp], ecx
+        cmp     ecx, 271
+        jl      @@0894
+        mov     dword ptr [esp], 271
+        jmp     @@0894
+@@0893: inc     eax
+@@0894: mov     ecx, [ebp + eax]
+        cmp     cl, [esi + eax]
+        jnz     @@0895
+        cmp     eax, [esp]
+        jge     @@0895
+        inc     eax
+        cmp     ch, [esi + eax]
+        jnz     @@0895
+        shr     ecx, 16
+        cmp     eax, [esp]
+        jge     @@0895
+        inc     eax
+        cmp     cl, [esi + eax]
+        jnz     @@0895
+        cmp     eax, [esp]
+        jge     @@0895
+        inc     eax
+        cmp     ch, [esi + eax]
+        jnz     @@0895
+        cmp     eax, [esp]
+        jl      @@0893
+@@0895: add     esi, eax
+        shl     edx, 4
+        cmp     eax, 15
+        jg      @@0896
+        or      eax, edx
+        mov     word ptr [edi], ax
+        add     edi, 2
+        jmp     @@0898
+@@0896: sub     eax, 16
+        mov     [edi], dx
+        mov     [edi + 2H], al
+        add     edi, 3
+        jmp     @@0898
+@@0897: mov     al, [esi] // movsb is actually slower!
+        mov     [edi], al
+        inc     esi
+        inc     edi
+@@0898: add     ebx, ebx
+        jz      @@0899
+        cmp     esi, [esp+4]
+        jbe     @@0892
+        jmp     @@0900
+@@0899: mov     [esp+18H], edi
+        mov     [edi], ebx
+        inc     ebx
+        add     edi, 4
+        cmp     esi, [esp+4]
+        jbe     @@0892
+@@0900: cmp     esi, [esp+0CH]
+        jnc     @@0903
+@@0901: mov     al, [esi]
+        mov     [edi], al
+        inc     esi
+        inc     edi
+        add     ebx, ebx
+        jz      @@0902
+        cmp     esi, [esp+0CH]
+        jc      @@0901
+        jmp     @@0903
+@@0902: mov     [edi], ebx
+        inc     ebx
+        add     edi, 4
+        cmp     esi, [esp+0CH]
+        jc      @@0901
+@@0903: mov     eax, edi
+        sub     eax, [esp+08H]
+@@0904: add     esp, 32804
+        pop     edi
+        pop     esi
+        pop     ebx
+        pop     ebp
+end;
+
+function RdRand32: cardinal;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // rdrand eax: same opcodes for x86 and x64
+        db $0f, $c7, $f0
+        // returns in eax, ignore carry flag (eax=0 won't hurt)
+end;
+
+function Rdtsc: Int64;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        // returns the TSC in EDX:EAX
+        rdtsc
+end;
+
+function StrCntDecFree(var refcnt: TStrCnt): boolean;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+   lock dec dword ptr [refcnt]  // =longint on Delphi and FPC 32-bit
+        setbe   al
+end; // don't check for ismultithread global since lock is cheaper on new CPUs
+
+function DACntDecFree(var refcnt: TDACnt): boolean;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+   lock dec dword ptr [refcnt]  // =longint on Delphi and FPC 32-bit
+        setbe   al
+end; // don't check for ismultithread global since lock is cheaper on new CPUs
+
+function LockedExc(var Target: PtrUInt; NewValue, Comperand: PtrUInt): boolean;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        xchg    eax, ecx
+   lock cmpxchg dword ptr [ecx], edx
+        setz    al
+end;
+
+procedure LockedAdd(var Target: PtrUInt; Increment: PtrUInt);
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+   lock add     dword ptr [Target], Increment
+end;
+
+procedure LockedAdd32(var Target: cardinal; Increment: cardinal);
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+   lock add     dword ptr [Target], Increment
+end;
+
+procedure LockedDec(var Target: PtrUInt; Decrement: PtrUInt);
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+   lock sub     dword ptr [Target], Decrement
+end;
+
+function IsXmmYmmOSEnabled: boolean;
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm // see https://software.intel.com/en-us/blogs/2011/04/14/is-avx-enabled
+        xor     ecx, ecx  // get control register XCR0 = XFEATURE_ENABLED_MASK
+        db  $0f, $01, $d0 // XGETBV reads XCR0 into EDX:EAX
+        and     eax, 6    // check OS enabled both XMM (bit 1) and YMM (bit 2)
+        cmp     al, 6
+        sete    al
+end;
+
+procedure GetCpuid(cpueax, cpuecx: cardinal; var Registers: TIntelRegisters);
+{$ifdef FPC}nostackframe; assembler;{$endif}
+asm
+        push    esi
+        push    edi
+        push    ebx
+        mov     edi, cpueax
+        mov     ebx, cpuecx
+        mov     esi, Registers
+        pushfd
+        pop     eax
+        mov     edx, eax
+        xor     eax, $200000
+        push    eax
+        popfd
+        pushfd
+        pop     eax
+        xor     eax, edx // does this CPU support the cpuid opcode?
+        jz      @nocpu
+        mov     eax, edi
+        mov     ecx, ebx
+        cpuid
+        mov     TIntelRegisters(esi).&eax, eax
+        mov     TIntelRegisters(esi).&ebx, ebx
+        mov     TIntelRegisters(esi).&ecx, ecx
+        mov     TIntelRegisters(esi).&edx, edx
+@nocpu: pop     ebx
+        pop     edi
+        pop     esi
+end;
+
+{$ifdef CPU32DELPHI}
+
+// inspired by ValExt_JOH_PAS_8_a by John O'Harrow - calls Delphi System.@Pow10
+function GetExtended(P: PUtf8Char; out err: integer): TSynExtended;
+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
+        cmp     eax, 308
+        jge     @oor                // limit to < 1.7 x 10^308 double range
+        cmp     eax, -324
+        jle     @oor                // limit to > 5.0 x 10^-324 range
+@oors:  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
+@oor:   inc     esi                 // force result code = 1
+        mov     [edx], esi          // set result code
+        xor     eax, eax            // set exponent = 0 (as pure pascal version)
+        jmp     @oors
+@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;
+
+// FPC will properly inline multiplication by reciprocal
+procedure Div100(Y: cardinal; var res: TDiv100Rec);
+asm
+        mov     dword ptr [edx].TDiv100Rec.M, eax
+        mov     ecx, edx
+        mov     edx, eax
+        mov     eax, 1374389535
+        mul     edx
+        shr     edx, 5
+        mov     dword ptr [ecx].TDiv100Rec.D, edx
+        imul    eax, edx, 100
+        sub     dword ptr [ecx].TDiv100Rec.M, eax
+end;
+
+// those functions are intrinsics with FPC :)
+
+function BSRdword(c: cardinal): cardinal;
+asm
+        bsr     eax, eax
+        jnz     @nz
+        mov     eax, 255
+@nz:
+end;
+
+function BSRqword(const q: qword): cardinal;
+asm
+        bsr     eax, [esp + 8]
+        jz      @1
+        add     eax, 32
+        ret
+@1:     bsr     eax, [esp + 4]
+        jnz     @2
+        mov     eax, 255
+@2:
+end;
+
+{$endif CPU32DELPHI}
+
+
diff --git a/lib/dmustache/mormot.core.base.pas b/lib/dmustache/mormot.core.base.pas
new file mode 100644
index 00000000..941945bc
--- /dev/null
+++ b/lib/dmustache/mormot.core.base.pas
@@ -0,0 +1,12238 @@
+/// Framework Core Shared Types and RTL-like Functions
+// - this unit is a part of the Open Source Synopse mORMot framework 2,
+// licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+unit mormot.core.base;
+
+{
+  *****************************************************************************
+
+   Basic types and reusable stand-alone functions shared by all framework units
+    - Framework Version and Information
+    - Common Types Used for Compatibility Between Compilers and CPU
+    - Numbers (floats and integers) Low-level Definitions
+    - Integer Arrays Manipulation
+    - ObjArray PtrArray InterfaceArray Wrapper Functions
+    - Low-level Types Mapping Binary or Bits Structures
+    - Buffers (e.g. Hashing and SynLZ compression) Raw Functions
+    - Efficient Variant Values Conversion
+    - Sorting/Comparison Functions
+    - Some Convenient TStream descendants and File access functions
+    - Faster Alternative to RTL Standard Functions
+    - Raw Shared Constants / Types Definitions
+
+   Aim of those types and functions is to be cross-platform and cross-compiler,
+  without any dependency but the main FPC/Delphi RTL. It also detects the
+  kind of CPU it runs on, to adapt to the fastest asm version available.
+   It is the main unit where x86_64 or i386 asm stubs are included.
+
+  *****************************************************************************
+}
+
+interface
+
+{$I mormot.defines.inc}
+
+uses
+  variants,
+  classes,
+  contnrs,
+  types,
+  sysutils;
+
+
+{ ************ Framework Version and Information }
+
+const
+  /// the full text of the Synopse mORMot framework
+  // - note: we don't supply full version number with build revision for
+  // HTTP servers, to reduce potential attack surface
+  SYNOPSE_FRAMEWORK_NAME = 'mORMot';
+
+  /// the corresponding version of the mORMot framework, as '2.#.#'
+  // - 2nd digit is minor version, increased at each framework release,
+  // when adding functionality in a stable enough manner
+  // - 3rd digit is a globally increasing git commit number (as generated by the
+  // commit.sh script) - so won't be reset when minor is up
+  SYNOPSE_FRAMEWORK_VERSION = {$I mormot.commit.inc};
+
+  /// a text including the version and the main active conditional options
+  // - usefull for low-level debugging purpose
+  SYNOPSE_FRAMEWORK_FULLVERSION  = SYNOPSE_FRAMEWORK_VERSION
+    {$ifdef FPC}
+      {$ifdef FPC_X64MM}      + ' x64MM'
+        {$ifdef FPCMM_BOOST}  + 'b'     {$endif}
+        {$ifdef FPCMM_SERVER} + 's'     {$endif}
+      {$else}
+        {$ifdef FPC_LIBCMM}   + ' CM'   {$endif}
+      {$endif FPC_X64MM}
+    {$else}
+      {$ifdef FullDebugMode}         + ' FDM'  {$endif}
+    {$endif FPC};
+
+
+{ ************ Common Types Used for Compatibility Between Compilers and CPU }
+
+const
+  /// internal Code Page for UTF-8 Unicode encoding
+  // - as used by RawUtf8 and all our internal framework text process
+  CP_UTF8 = 65001;
+
+  /// internal Code Page for UTF-16 Unicode encoding
+  // - used e.g. for Delphi 2009+ UnicodeString=String type
+  CP_UTF16 = 1200;
+
+  /// internal Code Page for RawByteString undefined string
+  CP_RAWBYTESTRING = 65535;
+
+  /// fake code page used to recognize RawBlob
+  // - RawBlob internal code page will be CP_RAWBYTESTRING = 65535, but our ORM
+  // will identify the RawBlob type and unserialize it using CP_RAWBLOB instead
+  // - TJsonWriter.AddAnyAnsiBuffer will recognize it and use Base-64 encoding
+  CP_RAWBLOB = 65534;
+
+  /// US English Windows Code Page, i.e. WinAnsi standard character encoding
+  CP_WINANSI = 1252;
+
+  /// Latin-1 ISO/IEC 8859-1 Code Page
+  // - map low 8-bit Unicode CodePoints
+  CP_LATIN1 = 819;
+
+  /// internal Code Page for System AnsiString encoding
+  CP_ACP = 0;
+
+  /// internal Code Page for System Console encoding
+  CP_OEM = 1;
+
+  /// use rather CP_WINANSI with mORMot 2
+  CODEPAGE_US = CP_WINANSI;
+
+  /// use rather CP_LATIN1 with mORMot 2
+  CODEPAGE_LATIN1 = CP_LATIN1;
+
+{$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 CPU64}
+  /// 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
+  // - use UInt64 explicitly in your computation (like in mormot.crypt.ecc),
+  // 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 = type Int64;
+  {$endif UNICODE}
+  /// points to an unsigned Int64
+  PQWord = ^QWord;
+  
+  // redefined here to not use the unexpected PWord definition from Windows unit
+  PWord = System.PWord;
+  // redefined here to not use the unexpected PSingle definition from Windows unit
+  PSingle = System.PSingle;
+
+  // this pointer is not defined on older Delphi revisions
+  PMethod = ^TMethod;
+
+  {$ifndef ISDELPHIXE2}
+  /// used to store the handle of a system Thread
+  TThreadID = cardinal;
+  /// compatibility definition with FPC and newer Delphi
+  PUInt64 = ^UInt64;
+  {$endif ISDELPHIXE2}
+
+{$endif FPC}
+
+type
+  /// RawUtf8 is an UTF-8 String stored in an AnsiString, alias to System.UTF8String
+  // - all conversion to/from string or WinAnsiString must be explicit on
+  // Delphi 7/2007, and it will be faster anyway to use our optimized functions
+  // from mormot.core.unicode.pas unit like StringToUtf8/Utf8ToString
+  RawUtf8 = System.UTF8String; // CP_UTF8 Codepage
+
+  /// a RawUtf8 value which may contain Sensitive Personal Information
+  // (e.g. a bank card number or a plain password)
+  // - identified as a specific type e.g. to be hidden in the logs - when the
+  // woHideSensitivePersonalInformation TTextWriterWriteObjectOption is set
+  SpiUtf8 = type RawUtf8;
+
+  /// 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 string or RawUtf8/UTF8String must be explicit on
+  // Delphi 7/2007, and it will be faster anyway to use our optimized functions
+  // from mormot.core.unicode.pas unit like StringToUtf8/Utf8ToString
+  {$ifdef HASCODEPAGE}
+  WinAnsiString = type AnsiString(CP_WINANSI); // WinAnsi 1252 Codepage
+  {$else}
+  WinAnsiString = type AnsiString;
+  {$endif HASCODEPAGE}
+
+  {$ifdef HASCODEPAGE}
+  {$ifdef FPC}
+  // missing declaration
+  PRawByteString = ^RawByteString;
+  {$endif FPC}
+  {$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 HASCODEPAGE}
+
+  /// RawJson will indicate that this variable content would stay as raw JSON
+  // - i.e. won't be serialized into values
+  // - could be any JSON content: number, boolean, null, string, object or array
+  // - e.g. interface-based service will use it for efficient and AJAX-ready
+  // transmission of TOrmTableJson result
+  RawJson = type RawUtf8;
+
+  /// a RawByteString sub-type used to store the BLOB content in our ORM
+  // - equals RawByteString for byte storage
+  // - TRttiInfo.AnsiStringCodePage will identify this type, and return
+  // CP_RAWBLOB fake codepage for such a published property, even if it is
+  // just an alias to CP_RAWBYTESTRING
+  // - our ORM will therefore identify such properties as BLOB
+  // - by default, the BLOB fields are not retrieved or updated with raw
+  // TRest.Retrieve() method, that is "Lazy loading" is enabled by default
+  // for blobs, unless TRestClientUri.ForceBlobTransfert property is TRUE
+  // (for all tables), or ForceBlobTransfertTable[] (for a particular table);
+  // so use RetrieveBlob() methods for handling BLOB fields
+  // - could be defined as value in a TOrm property as such:
+  // ! property Blob: RawBlob read fBlob write fBlob;
+  // - is defined here for proper TRttiProp.WriteAsJson serialization
+  RawBlob = type RawByteString;
+
+  /// 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 the faster UnicodeString type, which
+  // allow Copy On Write, Reference Counting and fast heap memory allocation
+  // - on recent FPC, HASVARUSTRING is defined and native UnicodeString is set
+  {$ifdef HASVARUSTRING}
+  SynUnicode = UnicodeString;
+  {$else}
+  SynUnicode = WideString;
+  {$endif HASVARUSTRING}
+
+  {$ifndef PUREMORMOT2}
+  /// low-level RawUnicode as an Unicode String stored in an AnsiString
+  // - DEPRECATED TYPE, introduced in Delphi 7/2007 days: SynUnicode is to be used
+  // - 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 may not be able to perform implicit conversions on CP_UTF16
+  {$ifdef HASCODEPAGE}
+  RawUnicode = type AnsiString(CP_UTF16); // Codepage for an "Unicode" String
+  {$else}
+  RawUnicode = type AnsiString;
+  {$endif HASCODEPAGE}
+  PRawUnicode = ^RawUnicode;
+  {$endif PUREMORMOT2}
+
+  /// low-level storage of UCS4 CodePoints, stored as 32-bit integers
+  RawUcs4 = TIntegerDynArray;
+
+  /// store one 32-bit UCS4 CodePoint (with a better naming than UCS4 "Char")
+  // - RTL's Ucs4Char is buggy, especially on oldest Delphi
+  Ucs4CodePoint = cardinal;
+
+  {$ifdef CPU64}
+  HalfInt = integer;
+  HalfUInt = cardinal;
+  {$else}
+  /// a CPU-dependent signed integer type cast of half a pointer
+  HalfInt = smallint;
+  /// a CPU-dependent unsigned integer type cast of half a pointer
+  HalfUInt = word;
+  {$endif CPU64}
+  /// a CPU-dependent signed integer type cast of a pointer to half a pointer
+  PHalfInt = ^HalfInt;
+  /// a CPU-dependent unsigned integer type cast of a pointer to half a pointer
+  PHalfUInt = ^HalfUInt;
+
+  PRawJson = ^RawJson;
+  PPRawJson = ^PRawJson;
+  PRawUtf8 = ^RawUtf8;
+  PPRawUtf8 = ^PRawUtf8;
+  PWinAnsiString = ^WinAnsiString;
+  PWinAnsiChar = type PAnsiChar;
+  PSynUnicode = ^SynUnicode;
+  PFileName = ^TFileName;
+
+  /// 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 internally stored and expected to be UTF-8 encoded
+  PUtf8Char = type PAnsiChar;
+  PPUtf8Char = ^PUtf8Char;
+  PPPUtf8Char = ^PPUtf8Char;
+
+  /// 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;
+
+  /// a TVarData values array
+  // - is not called TVarDataArray to avoid confusion with the corresponding
+  // type already defined in RTL Variants.pas, and used for custom late-binding
+  TVarDataStaticArray = array[ 0 .. MaxInt div SizeOf(TVarData) - 1 ] of TVarData;
+  PVarDataStaticArray = ^TVarDataStaticArray;
+  TVariantArray = array[ 0 .. MaxInt div SizeOf(Variant) - 1 ] of Variant;
+  PVariantArray = ^TVariantArray;
+  TVariantDynArray = array of variant;
+  PPVariant = ^PVariant;
+  PPVarData = ^PVarData;
+
+  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;
+  THalfUIntDynArray = array of HalfUInt;
+  PDoubleDynArray = ^TDoubleDynArray;
+  TDoubleDynArray = array of double;
+  PCurrencyDynArray = ^TCurrencyDynArray;
+  TCurrencyDynArray = array of currency;
+  PExtendedDynArray = ^TExtendedDynArray;
+  TExtendedDynArray = array of Extended;
+  TWordDynArray = array of word;
+  PWordDynArray = ^TWordDynArray;
+  TByteDynArray = array of byte;
+  PByteDynArray = ^TByteDynArray;
+  {$ifndef ISDELPHI2007ANDUP}
+  TBytes = array of byte;
+  {$endif ISDELPHI2007ANDUP}
+  TBytesDynArray = array of TBytes;
+  PBytesDynArray = ^TBytesDynArray;
+  TObjectDynArray = array of TObject;
+  PObjectDynArray = ^TObjectDynArray;
+  TPersistentDynArray = array of TPersistent;
+  PPersistentDynArray = ^TPersistentDynArray;
+  TPointerDynArray = array of pointer;
+  PPointerDynArray = ^TPointerDynArray;
+  TPointerDynArrayDynArray = array of 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;
+  TStringDynArray = array of string;
+  PStringDynArray = ^TStringDynArray;
+  PShortStringDynArray = array of PShortString;
+  PPShortStringArray = ^PShortStringArray;
+  TShortStringDynArray = array of ShortString;
+  TDateTimeDynArray = array of TDateTime;
+  PDateTimeDynArray = ^TDateTimeDynArray;
+  {$ifndef FPC_OR_UNICODE}
+  TDate = type TDateTime;
+  TTime = type TDateTime;
+  {$endif FPC_OR_UNICODE}
+  TDateDynArray = array of TDate;
+  PDateDynArray = ^TDateDynArray;
+  TTimeDynArray = array of TTime;
+  PTimeDynArray = ^TTimeDynArray;
+  TWideStringDynArray = array of WideString;
+  PWideStringDynArray = ^TWideStringDynArray;
+  TSynUnicodeDynArray = array of SynUnicode;
+  PSynUnicodeDynArray = ^TSynUnicodeDynArray;
+  TRawByteStringDynArray = array of RawByteString;
+  PRawByteStringDynArray = ^TRawByteStringDynArray;
+  {$ifdef HASVARUSTRING}
+  TUnicodeStringDynArray = array of UnicodeString;
+  PUnicodeStringDynArray = ^TUnicodeStringDynArray;
+  {$endif HASVARUSTRING}
+  TRawJsonDynArray = array of RawJson;
+  PRawJsonDynArray = ^TRawJsonDynArray;
+  TGuidDynArray = array of TGuid;
+  PGuidDynArray = array of PGuid;
+
+  PObject = ^TObject;
+  PClass = ^TClass;
+  PList = ^TList;
+  PObjectList = ^TObjectList;
+  PCollection = ^TCollection;
+  PStrings = ^TStrings;
+  PPByte = ^PByte;
+  PPPByte = ^PPByte;
+  PPInteger = ^PInteger;
+  PPCardinal = ^PCardinal;
+  PPPointer = ^PPointer;
+  PByteArray = ^TByteArray;
+  TByteArray = array[ 0 .. MaxInt - 1 ] of byte; // redefine here with {$R-}
+  PBooleanArray = ^TBooleanArray;
+  TBooleanArray = array[ 0 .. MaxInt - 1 ] of boolean;
+  PPWord = ^PWord;
+  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;
+  THalfUIntArray = array[ 0 .. MaxInt div SizeOf(HalfUInt) - 1 ] of HalfUInt;
+  PHalfUIntArray = ^THalfUIntArray;
+  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;
+  TPointerArray = array[ 0 .. MaxInt div SizeOf(Pointer) - 1 ] of Pointer;
+  PPointerArray = ^TPointerArray;
+  TClassArray = array[ 0 .. MaxInt div SizeOf(TClass) - 1 ] of TClass;
+  PClassArray = ^TClassArray;
+  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;
+  PLongRec = ^LongRec;
+  PPShortString = ^PShortString;
+  PTextFile = ^TextFile;
+
+  PInterface = ^IInterface;
+  TInterfaceDynArray = array of IInterface;
+  PInterfaceDynArray = ^TInterfaceDynArray;
+
+  TStreamClass = class of TStream;
+  TInterfacedObjectClass = class of TInterfacedObject;
+  TListClass = class of TList;
+  TObjectListClass = class of TObjectList;
+  TCollectionClass = class of TCollection;
+  TCollectionItemClass = class of TCollectionItem;
+  ExceptionClass = class of Exception;
+  {$M+}
+  ExceptionWithProps = class(Exception); // not as good as ESynException
+  {$M-}
+
+type
+  /// used e.g. to serialize up to 256-bit as hexadecimal
+  TShort64 = string[64];
+  PShort64 = ^TShort64;
+
+  /// a shortstring which only takes 48 bytes of memory
+  TShort47 = string[47];
+  PShort47 = ^TShort47;
+
+  /// used e.g. for SetThreadName/GetCurrentThreadName
+  TShort31 = string[31];
+  PShort31 = ^TShort31;
+
+  /// 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;
+
+  /// used e.g. for TTextWriter.AddShorter small text constants
+  TShort8 = string[8];
+  PShort8 = ^TShort8;
+
+  /// stack-allocated ASCII string, used by GuidToShort() function
+  TGuidShortString = string[38];
+
+  /// cross-compiler type used for string length
+  // - FPC uses PtrInt/SizeInt, Delphi uses longint even on CPU64
+  TStrLen = {$ifdef FPC} SizeInt {$else} longint {$endif};
+  /// pointer to cross-compiler type used for string length
+  PStrLen = ^TStrLen;
+  
+  /// cross-compiler type used for dynamic array length
+  // - both FPC and Delphi uses PtrInt/NativeInt for dynamic array high/length
+  TDALen = PtrInt;
+  /// pointer to cross-compiler type used for dynamic array length
+  PDALen = ^TDALen;
+
+  /// cross-compiler type used for string reference counter
+  // - FPC and Delphi don't always use the same type
+  TStrCnt = {$ifdef STRCNT32} integer {$else} SizeInt {$endif};
+  /// pointer to cross-compiler type used for string reference counter
+  PStrCnt = ^TStrCnt;
+
+  /// cross-compiler type used for dynarray reference counter
+  // - FPC uses PtrInt/SizeInt, Delphi uses longint even on CPU64
+  TDACnt = {$ifdef DACNT32} integer {$else} SizeInt {$endif};
+  /// pointer to cross-compiler type used for dynarray reference counter
+  PDACnt = ^TDACnt;
+
+  /// cross-compiler return type of IUnknown._AddRef/_Release methods
+  // - used to reduce the $ifdef when implementing interfaces in Delphi and FPC
+  TIntCnt = {$ifdef FPC} longint {$else} integer {$endif};
+  /// cross-compiler return type of IUnknown.QueryInterface method
+  // - used to reduce the $ifdef when implementing interfaces in Delphi and FPC
+  TIntQry = {$ifdef FPC} longint {$else} HRESULT {$endif};
+
+  {$ifdef FPC}
+
+  TStrRec = record // see TAnsiRec/TUnicodeRec in astrings/ustrings.inc
+  case integer of
+    0: (
+        {$ifdef HASCODEPAGE}
+        codePage: TSystemCodePage; // =Word
+        elemSize: Word;
+        {$ifndef STRCNT32}
+        {$ifdef CPU64}
+        _PaddingToQWord: DWord;
+        {$endif CPU64}
+        {$endif STRCNT32}
+        {$endif HASCODEPAGE}
+        refCnt: TStrCnt; // =SizeInt on older FPC, =longint since FPC 3.4
+        length: TStrLen;
+      );
+    {$ifdef HASCODEPAGE}
+    1: (
+        codePageElemSize: cardinal;
+      );
+    {$endif HASCODEPAGE}
+  end;
+
+  TDynArrayRec = record
+    refCnt: TDACnt; // =SizeInt
+    high: TDALen;   // =SizeInt (differs from Delphi: equals length-1)
+    function GetLength: TDALen; inline;
+    procedure SetLength(len: TDALen); inline;
+    property length: TDALen // Delphi compatibility wrapper
+      read GetLength write SetLength;
+  end;
+
+  {$else not FPC}
+
+  /// map the Delphi/FPC string header (stored before each instance)
+  TStrRec = packed record
+  {$ifdef HASCODEPAGE}
+    {$ifdef CPU64}
+    /// padding bytes for 16 byte alignment of the header
+    _Padding: cardinal;
+    {$endif CPU64}
+    /// the string code page - e.g. CP_UTF8 for RawUtf8
+    codePage: Word;
+    /// 1 for AnsiString/RawByteString/RawUtf8, 2 for UnicodeString
+    elemSize: Word;
+  {$endif HASCODEPAGE}
+    /// string reference count (basic garbage memory mechanism)
+    refCnt: TStrCnt; // 32-bit longint with Delphi
+    /// equals length(s) - i.e. size in AnsiChar/WideChar, not bytes
+    length: TStrLen; // 32-bit longint with Delphi
+  end;
+
+  /// map the Delphi/FPC dynamic array header (stored before each instance)
+  TDynArrayRec = packed record
+    {$ifdef CPUX64}
+    /// padding bytes for 16 byte alignment of the header
+    _Padding: cardinal;
+    {$endif}
+    /// dynamic array reference count (basic garbage memory mechanism)
+    refCnt: TDACnt; // 32-bit longint with Delphi
+    /// length in element count
+    // - size in bytes = length*ElemSize
+    length: TDALen; // PtrInt/NativeInt
+  end;
+
+  {$endif FPC}
+
+  PStrRec = ^TStrRec;
+  PDynArrayRec = ^TDynArrayRec;
+
+const
+  /// codePage offset = string header size
+  // - used to calc the beginning of memory allocation of a string
+  _STRRECSIZE = SizeOf(TStrRec);
+
+  /// cross-compiler negative offset to TStrRec.length field
+  // - to be used inlined e.g. as PStrLen(p - _STRLEN)^
+  _STRLEN = SizeOf(TStrLen);
+
+  /// cross-compiler negative offset to TStrRec.refCnt field
+  // - to be used inlined e.g. as PStrCnt(p - _STRCNT)^
+  _STRCNT = SizeOf(TStrCnt) + _STRLEN;
+
+  /// used to calc the beginning of memory allocation of a dynamic array
+  _DARECSIZE = SizeOf(TDynArrayRec);
+
+  /// cross-compiler negative offset to TDynArrayRec.high/length field
+  // - to be used inlined e.g. as
+  // ! PDALen(PAnsiChar(Values) - _DALEN)^ + _DAOFF
+  // - both FPC and Delphi uses PtrInt/NativeInt for dynamic array high/length
+  _DALEN = SizeOf(TDALen);
+
+  /// cross-compiler adjuster to get length from TDynArrayRec.high/length field
+  _DAOFF = {$ifdef FPC} 1 {$else} 0 {$endif};
+  
+  /// cross-compiler negative offset to TDynArrayRec.refCnt field
+  // - to be used inlined e.g. as PDACnt(PAnsiChar(Values) - _DACNT)^
+  _DACNT = SizeOf(TDACnt) + _DALEN;
+
+  /// in-memory string process will allow up to 800 MB
+  // - used as high limit e.g. for TBufferWriter over a TRawByteStringStream
+  // - Delphi strings have a 32-bit length so you should change your algorithm
+  // - even if FPC on CPU64 can handle bigger strings, consider other patterns
+  _STRMAXSIZE = $5fffffff;
+
+  /// in-memory TBytes process will allow up to 800 MB
+  // - used as high limit e.g. for TBufferWriter.FlushToBytes
+  // - even if a dynamic array can handle PtrInt length, consider other patterns
+  _DAMAXSIZE = $5fffffff;
+
+/// like SetLength() but without any memory resize - WARNING: len should be > 0
+procedure DynArrayFakeLength(arr: pointer; len: TDALen);
+  {$ifdef HASINLINE} inline; {$endif}
+
+{$ifndef CPUARM}
+type
+  /// used as ToByte() to properly truncate any integer into 8-bit
+  // - is defined as an inlined "and 255" function under ARM to work as expected
+  ToByte = byte;
+{$else}
+function ToByte(value: cardinal): cardinal; inline;
+{$endif CPUARM}
+
+const
+  /// used to mark the end of ASCIIZ buffer, or return a void ShortString
+  NULCHAR: AnsiChar = #0;
+
+  /// a TGuid containing '{00000000-0000-0000-0000-00000000000}'
+  GUID_NULL: TGuid = ({%H-});
+
+  NULL_LOW   = ord('n') + ord('u') shl 8 + ord('l') shl 16 + ord('l') shl 24;
+  FALSE_LOW  = ord('f') + ord('a') shl 8 + ord('l') shl 16 + ord('s') shl 24;
+  FALSE_LOW2 = ord('a') + ord('l') shl 8 + ord('s') shl 16 + ord('e') shl 24;
+  TRUE_LOW   = ord('t') + ord('r') shl 8 + ord('u') shl 16 + ord('e') shl 24;
+
+/// fill a TGuid with 0
+procedure FillZero(var result: TGuid); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// compare two TGuid values
+// - this version is faster than the one supplied by SysUtils
+function IsEqualGuid(guid1, guid2: PGuid): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// returns the index of a matching TGuid in an array
+// - returns -1 if no item matched
+function IsEqualGuidArray(const guid: TGuid; const guids: array of TGuid): integer;
+
+/// check if a TGuid value contains only 0 bytes
+// - this version is faster than the one supplied by SysUtils
+function IsNullGuid({$ifdef FPC_HAS_CONSTREF}constref{$else}const{$endif} guid: TGuid): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// append one TGuid item to a TGuid dynamic array
+// - returning the newly inserted index in guids[], or an existing index in
+// guids[] if NoDuplicates is TRUE and TGuid already exists
+function AddGuid(var guids: TGuidDynArray; const guid: TGuid;
+  NoDuplicates: boolean = false): integer;
+
+/// compute a random UUid value from the RandomBytes() generator and RFC 4122
+procedure RandomGuid(out result: TGuid); overload;
+
+/// compute a random UUid value from the RandomBytes() generator and RFC 4122
+function RandomGuid: TGuid; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// compute the new capacity when expanding an array of items
+// - handle tiny, small, medium, large and huge sizes properly to reduce
+// memory usage and maximize performance
+// - initial steps are 4, 8, 12, 28, 40, 56, 72, 88, 104, 120, 136, 170, 212,
+// 265, 331, 413, 516, 645, 806, 1007, 1258, 1572, ...
+function NextGrow(capacity: integer): integer;
+
+/// equivalence to SetString(s,pansichar,len) function but from a raw pointer
+// - so works with both PAnsiChar and PUtf8Char input buffer (or even PByteArray)
+// - faster especially under FPC
+procedure FastSetString(var s: RawUtf8; p: pointer; len: PtrInt); overload;
+  {$ifndef HASCODEPAGE} {$ifdef HASINLINE}inline;{$endif} {$endif}
+
+/// faster equivalence to SetString(s,nil,len) function
+procedure FastSetString(var s: RawUtf8; len: PtrInt); overload;
+  {$ifndef HASCODEPAGE} {$ifdef HASINLINE}inline;{$endif} {$endif}
+
+/// equivalence to SetString(s,pansichar,len) function but from a raw pointer
+// - so works with both PAnsiChar and PUtf8Char input buffer (or even PByteArray)
+// - faster especially under FPC
+procedure FastSetRawByteString(var s: RawByteString; p: pointer; len: PtrInt);
+  {$ifndef HASCODEPAGE} {$ifdef HASINLINE}inline;{$endif} {$endif}
+
+/// equivalence to SetString(s,nil,len) function to allocate a new RawByteString
+// - faster especially under FPC
+procedure FastNewRawByteString(var s: RawByteString; len: PtrInt);
+  {$ifndef HASCODEPAGE} {$ifdef HASINLINE}inline;{$endif} {$endif}
+
+/// equivalence to SetString(s,pansichar,len) function with a specific code page
+// - faster especially under FPC
+procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt);
+  {$ifndef HASCODEPAGE} {$ifdef HASINLINE}inline;{$endif} {$endif}
+
+/// assign any constant or already ref-counted AnsiString/RawUtf8
+// - by default, called with s = nil, is an equivalence to Finalize(d) or d := ''
+// - is also called by FastSetString/FastSetStringCP to setup its allocated value
+// - faster especially under FPC
+procedure FastAssignNew(var d; s: pointer = nil);
+  {$ifndef FPC_CPUX64} {$ifdef HASINLINE}inline;{$endif} {$endif}
+
+/// internal function to assign any constant or ref-counted AnsiString/RawUtf8
+// - caller should have tested that pointer(d) <> nil
+procedure FastAssignNewNotVoid(var d; s: pointer); overload;
+  {$ifndef FPC_CPUX64}{$ifdef HASINLINE}inline;{$endif}{$endif}
+
+/// internal function used by FastSetString/FastSetStringCP
+function FastNewString(len, codepage: PtrInt): PAnsiChar;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// ensure the supplied variable will have a CP_UTF8 - making it unique if needed
+procedure EnsureRawUtf8(var s: RawByteString); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// ensure the supplied variable will have a CP_UTF8 - making it unique if needed
+procedure EnsureRawUtf8(var s: RawUtf8); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// internal function which could be used instead of SetLength() if RefCnt = 1
+procedure FakeLength(var s: RawUtf8; len: PtrInt); overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// internal function which could be used instead of SetLength() if RefCnt = 1
+procedure FakeLength(var s: RawUtf8; endChar: PUtf8Char); overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// internal function which could be used instead of SetLength() if RefCnt = 1
+procedure FakeLength(var s: RawByteString; len: PtrInt); overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// internal function which could be used instead of SetLength() if RefCnt = 1
+// - FakeLength() don't handle len = 0, whereas this function will
+procedure FakeSetLength(var s: RawUtf8; len: PtrInt); overload;
+
+/// internal function which could be used instead of SetLength() if RefCnt = 1
+// - FakeLength() don't handle len = 0, whereas this function will
+procedure FakeSetLength(var s: RawByteString; len: PtrInt); overload;
+
+/// internal function which could be used instead of SetCodePage() if RefCnt = 1
+// - do nothing if HASCODEPAGE is not defined, e.g. on Delphi 7-2007
+// - warning: s should NOT be read-only (i.e. assigned from a constant), but
+// a just-allocated string with RefCnt <> -1
+procedure FakeCodePage(var s: RawByteString; cp: cardinal);
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// internal function which assign src to dest, force CP_UTF8 and set src to ''
+// - warning: calls FakeCodePage(CP_UTF8) so requires src to have a RefCnt of 1
+procedure FastAssignUtf8(var dest: RawUtf8; var src: RawByteString);
+  {$ifdef HASINLINE} inline; {$endif}
+
+{$ifdef HASCODEPAGE}
+/// retrieve the code page of a non void string
+// - caller should have ensure that s <> ''
+function GetCodePage(const s: RawByteString): cardinal; inline;
+{$endif HASCODEPAGE}
+
+/// initialize a RawByteString, ensuring returned "aligned" pointer
+// is 16-bytes aligned
+// - to be used e.g. for proper SIMD process
+// - you can specify an alternate alignment, but it should be a power of two
+procedure GetMemAligned(var holder: RawByteString; fillwith: pointer; len: PtrUInt;
+  out aligned: pointer; alignment: PtrUInt = 16);
+
+/// equivalence to @u[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, @u[1] does not call UniqueString() as it does with Delphi
+// - if u is a constant (refcount=-1), will allocate a temporary copy in heap
+function UniqueRawUtf8(var u: RawUtf8): pointer;
+  {$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
+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}
+
+/// direct conversion of an ANSI-7 AnsiString into an ShortString
+// - can be used e.g. for names retrieved from RTTI
+procedure Ansi7StringToShortString(const source: RawUtf8; var result: ShortString);
+  {$ifdef FPC}inline;{$endif}
+
+/// simple concatenation of a 32-bit unsigned integer as text into a shorstring
+procedure AppendShortCardinal(value: cardinal; var dest: ShortString);
+
+/// simple concatenation of a 64-bit integer as text into a shorstring
+procedure AppendShortInt64(value: Int64; var dest: ShortString);
+
+/// simple concatenation of a character into a shorstring
+procedure AppendShortChar(chr: AnsiChar; var dest: ShortString);
+  {$ifdef FPC} inline; {$endif}
+
+/// simple concatenation of a byte as hexadecimal into a shorstring
+procedure AppendShortByteHex(value: byte; var dest: ShortString);
+
+/// simple concatenation of a ShortString text into a shorstring
+procedure AppendShort(const src: ShortString; var dest: ShortString);
+  {$ifdef FPC} inline; {$endif}
+
+/// simple concatenation of a #0 ending text into a shorstring
+// - if Len is < 0, will use StrLen(buf)
+procedure AppendShortBuffer(buf: PAnsiChar; len: integer; var dest: ShortString);
+
+/// simple concatenation of an ANSI-7 AnsiString into a shorstring
+// - if Len is < 0, will use StrLen(buf)
+procedure AppendShortAnsi7String(const buf: RawByteString; var dest: ShortString);
+  {$ifdef FPC}inline;{$endif}
+
+/// 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 conversion
+procedure ClassToText(C: TClass; var result: RawUtf8);
+
+/// just a wrapper around ClassToText() to avoid a string conversion
+function ToText(C: TClass): RawUtf8; overload;
+  {$ifdef HASSAFEINLINE}inline;{$endif}
+
+
+var
+  /// retrieve the unit name where a given class is implemented
+  // - is implemented in mormot.core.rtti.pas; so may be nil otherwise
+  // - is needed since Delphi 7-2009 do not define TObject.UnitName (because
+  // there is no such information available in RTTI)
+  ClassUnit: function(C: TClass): PShortString;
+
+/// just a wrapper around vmtParent to avoid a function call
+// - slightly faster than TClass.ClassParent thanks to proper inlining
+function GetClassParent(C: TClass): TClass;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// case-insensitive comparison of two shortstrings only containing ASCII 7-bit
+// - use e.g. with RTTI property names values only including A..Z,0..9,_ chars
+// - will make the "XOR AND $DF" trick to quickly test A-Z / a-z characters
+// - behavior is undefined with UTF-8 encoding (some false positive may occur)
+// - see IdemPropName/IdemPropNameU functions in mormot.core.text for a similar
+// comparison with other kind of input variables
+function PropNameEquals(P1, P2: PShortString): boolean; overload;
+  {$ifdef FPC}inline;{$endif} // Delphi has troubles inlining goto/label
+
+/// case-insensitive comparison of two RawUtf8 only containing ASCII 7-bit
+// - use e.g. with RTTI property names values only including A..Z,0..9,_ chars
+// - will make the "XOR AND $DF" trick to quickly test A-Z / a-z characters
+// - behavior is undefined with UTF-8 encoding (some false positive may occur)
+// - see IdemPropName/IdemPropNameU functions in mormot.core.text for a similar
+// comparison with other kind of input variables
+function PropNameEquals(const P1, P2: RawUtf8): boolean; overload;
+
+/// raw internal method as published by FindNonVoid[false]
+function FindNonVoidRawUtf8(n: PPointerArray; name: pointer; len: TStrLen;
+  count: PtrInt): PtrInt;
+
+/// raw internal method as published by FindNonVoid[true]
+function FindNonVoidRawUtf8I(n: PPointerArray; name: pointer; len: TStrLen;
+  count: PtrInt): PtrInt;
+
+type
+  TFindNonVoid =
+    function(p: PPointerArray; n: pointer; l: TStrLen; c: PtrInt): PtrInt;
+const
+  /// raw internal methods for case sensitive (or not) search for a RawUtf8
+  // - expects non-void RawUtf8 values, with ASCII-7 encoding, e.g. as with
+  // TDocVariantData.GetValueIndex() property names
+  FindNonVoid: array[{casesensitive:}boolean] of TFindNonVoid = (
+    FindNonVoidRawUtf8I,
+    FindNonVoidRawUtf8);
+
+/// return the case-insensitive ASCII 7-bit index of Value in non-void Values[]
+// - typical use with a TRawUtf8DynArray is like this:
+// ! index := FindPropName(pointer(aDynArray), aValue, length(aDynArray));
+// - by design, this function expects Values[] to not contain any void ''
+function FindPropName(Values: PRawUtf8Array; const Value: RawUtf8;
+  ValuesCount: PtrInt): PtrInt; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// return the index of Value in Values[], -1 if not found
+// - here name search would use fast IdemPropNameU() function
+function FindPropName(const Names: array of RawUtf8; const Name: RawUtf8): integer; overload;
+
+/// use the RTL to return a date/time as ISO-8601 text
+// - slow function, here to avoid linking mormot.core.datetime
+function DateTimeToIsoString(dt: TDateTime): string;
+
+/// convert a binary into its human-friendly per-byte hexadecimal lowercase text
+// - returns e.g. '12:50:b6:1e:c6:aa', i.e. the DN/MAC format
+// - used e.g. in mormot.lib.openssl11 and mormot.net.sock
+procedure ToHumanHex(var result: RawUtf8; bin: PByteArray; len: PtrInt);
+
+/// convert a binary into its human-friendly hexadecimal in reverse order
+procedure ToHumanHexReverse(var result: RawUtf8; bin: PByteArray; len: PtrInt);
+
+// backward compatibility types redirections
+{$ifndef PUREMORMOT2}
+
+type
+  TSqlRawBlob = RawBlob;
+
+{$endif PUREMORMOT2}
+
+
+
+{ ************ Numbers (floats and integers) Low-level Definitions }
+
+const
+  /// fast lookup table for converting any decimal number from
+  // 0 to 99 into their ASCII equivalence
+  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');
+
+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;
+
+  /// best possible precision when rendering a "single" kind of float
+  // - can be used as parameter for ExtendedToShort/ExtendedToStr
+  // - is defined as a var, so that you may be able to override the default
+  // settings, for the whole process
+  SINGLE_PRECISION: integer = 8;
+  /// best possible precision when rendering a "double" kind of float
+  // - can be used as parameter for ExtendedToShort/ExtendedToStr
+  // - is defined as a var, so that you may be able to override the default
+  // settings, for the whole process
+  DOUBLE_PRECISION: integer = 15;
+  /// best possible precision when rendering a "extended" kind of float
+  // - can be used as parameter for ExtendedToShort/ExtendedToStr
+  // - is defined as a var, so that you may be able to override the default
+  // settings, for the whole process
+  EXTENDED_PRECISION: integer = 18;
+
+type
+  /// small structure used as convenient result to Div100() procedure
+  TDiv100Rec = packed record
+    /// contains V div 100 after Div100(V)
+    D: cardinal;
+    /// contains V mod 100 after Div100(V)
+    M: cardinal;
+  end;
+
+  {$ifdef TSYNEXTENDED80}
+  /// the floating-point type to be used for best precision and speed
+  // - will allow to fallback to double e.g. on x64 and ARM CPUs
+  TSynExtended = extended;
+
+  TSynExtendedDynArray = array of TSynExtended;
+  PSynExtendedDynArray = ^TSynExtendedDynArray;
+  PSynExtended = ^TSynExtended;
+  {$else}
+  /// ARM/Delphi 64-bit does not support 80bit extended -> double is enough
+  TSynExtended = double;
+
+  TSynExtendedDynArray = TDoubleDynArray;
+  PSynExtendedDynArray = PDoubleDynArray;
+  PSynExtended = PDouble;
+  {$endif TSYNEXTENDED80}
+
+  /// the non-number values potentially stored in an IEEE floating point
+  TFloatNan = (
+    fnNumber, fnNan, fnInf, fnNegInf);
+
+  {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+  /// unaligned() will be defined and useful only on FPC ARM/Aarch64 plaforms
+  unaligned = Double;
+  {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+
+const
+  /// used e.g. to convert a currency (via PInt64) into a double
+  // - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
+  // values properly -> use FPC Win32 compiler only on Windows
+  CURR_RES = 10000;
+
+/// convert a currency value into a double
+// - using PInt64() division by CURR_RES (=10000)
+// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
+// values properly -> use FPC Win32 compiler only on Windows
+procedure CurrencyToDouble(const c: currency; out d: double); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a currency value pointer into a double
+// - using PInt64() division by CURR_RES (=10000)
+// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
+// values properly -> use FPC Win32 compiler only on Windows
+procedure CurrencyToDouble(c: PCurrency; out d: double); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a currency value pointer into a double
+// - using PInt64() division by CURR_RES (=10000)
+// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
+// values properly -> use FPC Win32 compiler only on Windows
+function CurrencyToDouble(c: PCurrency): double; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fill a variant value from a currency value
+// - as compatible with VariantToCurrency/VariantToDouble
+// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
+// values properly -> use FPC Win32 compiler only on Windows
+procedure CurrencyToVariant(const c: currency; var v: variant);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a double value into a currency
+// - using truncated multiplication by CURR_RES (=10000)
+// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
+// values properly -> use FPC Win32 compiler only on Windows
+procedure DoubleToCurrency(const d: double; out c: currency); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a double value into a currency
+// - using truncated multiplication by CURR_RES (=10000)
+// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
+// values properly -> use FPC Win32 compiler only on Windows
+procedure DoubleToCurrency(const d: double; c: PCurrency); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a double value into a currency
+// - using truncated multiplication by CURR_RES (=10000)
+// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
+// values properly -> use FPC Win32 compiler only on Windows
+function DoubleToCurrency(const d: double): currency; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a currency value into a Int64
+// - using PInt64() division by CURR_RES (=10000)
+// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
+// values properly -> use FPC Win32 compiler only on Windows
+procedure CurrencyToInt64(c: PCurrency; var i: Int64); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a Int64 value into a currency
+// - using multiplication by CURR_RES (=10000)
+// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
+// values properly -> use FPC Win32 compiler only on Windows
+procedure Int64ToCurrency(const i: Int64; out c: currency); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a Int64 value into a currency
+// - using multiplication by CURR_RES (=10000)
+// - warning: FPC Win64 to Win32 cross-compiler doesn't support currency
+// values properly -> use FPC Win32 compiler only on Windows
+procedure Int64ToCurrency(const i: Int64; c: PCurrency); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// no banker rounding into two digits after the decimal point
+// - #.##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;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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);
+
+/// no banker rounding into text, with two digits after the decimal point
+// - #.##51 will round to #.##+0.01 and #.##50 will be truncated to #.##
+// - this function will only allow 2 digits in the returned text
+function TwoDigits(const d: double): TShort31;
+
+/// truncate a currency value to only 2 digits
+// - implementation will use fast Int64 math to avoid any precision loss due to
+// temporary floating-point conversion
+function TruncTo2Digits(Value: currency): currency;
+
+/// truncate a currency value, stored as Int64, to only 2 digits
+// - implementation will use fast Int64 math to avoid any precision loss due to
+// temporary floating-point conversion
+procedure TruncTo2DigitsCurr64(var Value: Int64);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// truncate a Currency value, stored as Int64, to only 2 digits
+// - implementation will use fast Int64 math to avoid any precision loss due to
+// temporary floating-point conversion
+function TruncTo2Digits64(Value: Int64): Int64;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// simple wrapper to efficiently compute both division and modulo per 100
+// - compute result.D = Y div 100 and result.M = Y mod 100
+// - under FPC, will use fast multiplication by reciprocal so can be inlined
+// - under Delphi, we use our own optimized asm version (which can't be inlined)
+procedure Div100(Y: cardinal; var res: TDiv100Rec);
+  {$ifdef FPC} inline; {$endif}
+
+/// 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 occurred, 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; 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, PEnd: PUtf8Char): PtrUInt; overload;
+
+/// 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, or false if P = nil
+// - see relaxed GetInt64Bool() to recognize e.g. 'TRUE' or 'yes'/'YES'
+function GetBoolean(P: PUtf8Char): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// get a boolean value stored as 'true'/'false' text in input variable
+// - would also recognize any non '0' integer as true, or false if P is ''
+function GetBoolean(const value: RawUtf8): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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;
+
+/// return 1 if 'TRUE' or 'YES', or 0 otherwise
+function GetTrue(P: PUtf8Char): integer;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// get the 64-bit integer value from P^, recognizing true/false/yes/no input
+// - return true on correct parsing, false if P is no number or boolean
+function GetInt64Bool(P: PUtf8Char; out V: Int64): boolean;
+
+/// 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); overload;
+  {$ifdef CPU64}inline;{$endif}
+
+/// get the 64-bit unsigned integer value stored in P^
+procedure SetQWord(P, PEnd: PUtf8Char; var result: QWord); overload;
+  {$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)
+// - this optimized function is consistent on all platforms/compilers and return
+// the decoded value even if err is not 0 (e.g. if P^ is not #0 ended)
+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}
+
+type
+  TPow10 = array[-31..55] of TSynExtended;
+  PPow10 = ^TPow10;
+
+const
+  /// most common 10 ^ exponent constants, ending with values for HugePower10*()
+  POW10: TPow10 = (
+    1E-31, 1E-30, 1E-29, 1E-28, 1E-27, 1E-26, 1E-25, 1E-24, 1E-23, 1E-22,
+    1E-21, 1E-20, 1E-19, 1E-18, 1E-17, 1E-16, 1E-15, 1E-14, 1E-13, 1E-12,
+    1E-11, 1E-10, 1E-9,  1E-8,  1E-7,  1E-6,  1E-5,  1E-4,  1E-3,  1E-2,
+    1E-1,  1E0,   1E1,   1E2,   1E3,   1E4,   1E5,   1E6,   1E7,   1E8,
+    1E9,   1E10,  1E11,  1E12,  1E13,  1E14,  1E15,  1E16,  1E17,  1E18,
+    1E19,  1E20,  1E21,  1E22,  1E23,  1E24,  1E25,  1E26,  1E27,  1E28,
+    1E29,  1E30,  1E31,  0,{32} -1,{33} 1E0,{34} 1E32, 1E64, 1E96, 1E128,
+    1E160, 1E192, 1E224, 1E256, 1E288, 1E320, 1E-0,{45} 1E-32, 1E-64,
+    1E-96, 1E-128, 1E-160, 1E-192, 1E-224, 1E-256, 1E-288, 1E-320);
+
+/// low-level computation of 10 ^ positive exponent, if POW10[] is not enough
+function HugePower10Pos(exponent: PtrInt; pow10: PPow10): TSynExtended;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// low-level computation of 10 ^ negative exponent, if POW10[] is not enough
+function HugePower10Neg(exponent: PtrInt; pow10: PPow10): TSynExtended;
+  {$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 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;
+
+/// get and check range of a signed 32-bit integer stored in a RawUtf8 string
+// - we use the PtrInt result type, even if expected to be 32-bit, to use
+// native CPU register size (don't want any 32-bit overflow here)
+function Utf8ToInteger(const value: RawUtf8; min, max: PtrInt;
+  default: PtrInt = 0): PtrInt; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// get the signed 32-bit integer value stored in a RawUtf8 string
+// - returns TRUE if the supplied text was successfully converted into an integer
+function ToInteger(const text: RawUtf8; out value: integer): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// get the unsigned 32-bit cardinal value stored in a RawUtf8 string
+// - returns TRUE if the supplied text was successfully converted into a cardinal
+function ToCardinal(const text: RawUtf8; out value: cardinal;
+  minimal: cardinal = 0): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// get the signed 64-bit integer value stored in a RawUtf8 string
+// - returns TRUE if the supplied text was successfully converted into an Int64
+function ToInt64(const text: RawUtf8; out value: Int64): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// get a 64-bit floating-point value stored in a RawUtf8 string
+// - returns TRUE if the supplied text was successfully converted into a double
+function ToDouble(const text: RawUtf8; out value: double): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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}
+
+/// add the 4 digits of integer Y to P^ as '0000'..'9999'
+procedure YearToPChar(Y: PtrUInt; P: PUtf8Char);
+  {$ifndef ASMX86} {$ifdef HASINLINE}inline;{$endif} {$endif}
+
+const
+  /// a typical error allowed when working with double floating-point values
+  // - 1E-12 is too small, and triggers sometimes some unexpected errors;
+  // FPC RTL uses 1E-4 so we are paranoid enough
+  DOUBLE_SAME = 1E-11;
+
+/// 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 on Delphi 7-2007
+function CompareQWord(const A, B: QWord): integer;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast search of an unsigned integer item in a 32-bit integer array
+// - Count is the number of cardinal entries in P^
+// - returns P where P^=Value
+// - returns nil if Value was not found
+// - is implemented via IntegerScanIndex() SSE2 asm on i386 and x86_64
+function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal;
+  {$ifdef CPUINTEL} {$ifndef HASNOSSE2} {$ifdef HASINLINE}inline;{$endif} {$endif} {$endif}
+
+/// fast search of an unsigned integer position in a 32-bit integer array
+// - Count is the number of integer entries in P^
+// - return index of P^[index]=Value
+// - return -1 if Value was not found
+// - is implemented with SSE2 asm on i386 and x86_64
+function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt;
+  {$ifndef CPUINTEL}inline;{$endif}
+
+/// fast search of an unsigned integer in a 32-bit integer array
+// - returns true if P^=Value within Count entries
+// - returns false if Value was not found
+// - is implemented via IntegerScanIndex() SSE2 asm on i386 and x86_64
+function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean;
+  {$ifdef CPUINTEL} {$ifndef HASNOSSE2} {$ifdef HASINLINE}inline;{$endif} {$endif} {$endif}
+
+/// 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;
+  {$ifdef HASSAFEINLINE}inline;{$endif}
+
+/// 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 integer value in a 64-bit integer array
+// - returns true if P^=Value within Count entries
+// - returns false if Value was not found
+function Int64ScanExists(P: PInt64Array; Count: PtrInt; const Value: Int64): boolean;
+
+/// fast search of a pointer-sized unsigned integer position
+// in an pointer-sized integer array
+// - Count is the number of pointer-sized integer entries in P^
+// - return index of P^[index]=Value
+// - return -1 if Value was not found
+function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast search of a pointer-sized unsigned integer in an pointer-sized integer array
+// - Count is the number of pointer-sized integer entries in P^
+// - returns true if P^=Value within Count entries
+// - returns false if Value was not found
+function PtrUIntScan(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): pointer;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast search of a pointer-sized unsigned integer position
+// in an pointer-sized integer array
+// - Count is the number of pointer-sized integer entries in P^
+// - returns true if P^=Value within Count entries
+// - returns false if Value was not found
+function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast search of an unsigned byte value position in a byte array
+// - Count is the number of byte entries in P^
+// - return index of P^[index]=Value, -1 if Value was not found
+// - is implemented with SSE2 asm on i386 and x86_64
+function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: byte): PtrInt;
+  {$ifndef CPUINTEL} 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, -1 if Value was not found
+// - is implemented with SSE2 asm on i386 and x86_64
+function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): PtrInt;
+  {$ifndef CPUINTEL} 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;
+
+/// sort a PtrInt array, low values first
+procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// sort a pointer array, low values first
+procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// sort a double array, low values first
+procedure QuickSortDouble(ID: PDoubleArray; L, R: PtrInt);
+
+/// 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
+// - use branchless asm on x86_64
+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
+// - use branchless asm on x86_64
+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
+// - use branchless asm on x86_64
+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;
+
+/// 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}
+
+/// 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 -(foundindex+1) i.e. <0 if the specified Value was found
+function FastLocateIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt;
+
+/// retrieve the matching index or where to insert an integer value
+function FastSearchIntegerSorted(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 -(foundindex+1) i.e. <0 if the specified Value was found
+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 -(foundindex+1) i.e. <0 if the specified Value was already present
+// - 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);
+
+/// add a pointer-sized integer array at the end of a dynamic array
+function AddPtrUInt(var Values: TPtrUIntDynArray;
+  var ValuesCount: integer; Value: PtrUInt): PtrInt;
+
+/// 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;
+
+/// 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;
+
+/// fill some values with i,i+1,i+2...i+Count-1
+procedure FillIncreasing(Values: PIntegerArray; StartValue: integer; Count: PtrUInt);
+
+/// 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 an Exception 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
+  // - ensure Count=0 before use - if not defined as a private member of a class
+  {$ifdef USERECORDWITHMETHODS}
+  TSortedWordArray = record
+  {$else}
+  TSortedWordArray = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// the actual 16-bit word storage
+    Values: TWordDynArray;
+    /// how many items are currently in Values[]
+    Count: PtrInt;
+    /// add a value into the sorted array
+    // - return the index of the new inserted value into the Values[] array
+    // - return -(foundindex+1) if this value is already in the Values[] array
+    function Add(aValue: Word): PtrInt;
+    /// return the index if the supplied value in the Values[] array
+    // - return -1 if not found
+    function IndexOf(aValue: Word): PtrInt; {$ifdef HASINLINE}inline;{$endif}
+    /// save the internal array into a TWordDynArray variable
+    procedure SetArray(out aValues: TWordDynArray);
+  end;
+  PSortedWordArray = ^TSortedWordArray;
+
+  /// used to store and retrieve Integers in a sorted array
+  // - ensure Count=0 before use - if not defined as a private member of a class
+  {$ifdef USERECORDWITHMETHODS}
+  TSortedIntegerArray = record
+  {$else}
+  TSortedIntegerArray = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// the actual 32-bit integers storage
+    Values: TIntegerDynArray;
+    /// how many items are currently in Values[]
+    Count: PtrInt;
+    /// add a value into the sorted array
+    // - return the index of the new inserted value into the Values[] array
+    // - return -(foundindex+1) if this value is already in the Values[] array
+    function Add(aValue: integer): PtrInt;
+    /// return the index if the supplied value in the Values[] array
+    // - return -1 if not found
+    function IndexOf(aValue: integer): PtrInt; {$ifdef HASINLINE}inline;{$endif}
+    /// save the internal array into a TWordDynArray variable
+    procedure SetArray(out aValues: TIntegerDynArray);
+  end;
+  PSortedIntegerArray = ^TSortedIntegerArray;
+
+/// compute GCD of two integers using modulo-based Euclidean algorithm
+function gcd(a, b: PtrUInt): PtrUInt;
+
+
+
+{ ************ ObjArray PtrArray InterfaceArray Wrapper Functions }
+
+/// wrapper to add an item to a array of pointer dynamic array storage
+function PtrArrayAdd(var aPtrArray; aItem: pointer): integer; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// wrapper to add an item to a array of pointer dynamic array storage
+function PtrArrayAdd(var aPtrArray; aItem: pointer;
+  var aPtrArrayCount: integer): PtrInt; overload;
+
+/// wrapper to add once an item to a array of pointer dynamic array storage
+function PtrArrayAddOnce(var aPtrArray; aItem: pointer): PtrInt; overload;
+
+/// wrapper to add once an item to a array of pointer dynamic array storage
+function PtrArrayAddOnce(var aPtrArray; aItem: pointer;
+  var aPtrArrayCount: integer): PtrInt; overload;
+
+/// wrapper to insert an item to a array of pointer dynamic array storage
+function PtrArrayInsert(var aPtrArray; aItem: pointer; aIndex: PtrInt;
+  var aPtrArrayCount: integer): PtrInt; overload;
+
+/// wrapper to delete an item from a array of pointer dynamic array storage
+function PtrArrayDelete(var aPtrArray; aItem: pointer; aCount: PInteger = nil): PtrInt; overload;
+
+/// wrapper to delete an item from a array of pointer dynamic array storage
+procedure PtrArrayDelete(var aPtrArray; aIndex: PtrInt; aCount: PInteger = nil); overload;
+
+/// wrapper to find an item to a array of pointer dynamic array storage
+function PtrArrayFind(var aPtrArray; aItem: pointer): integer;
+  {$ifdef HASINLINE}inline;{$endif}
+
+
+/// wrapper to add an item to a T*ObjArray dynamic array storage
+// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
+// - 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; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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 a stand-alone array as expected by our ORM/SOA serialziation
+// - return the index of the item in the dynamic array
+function ObjArrayAddCount(var aObjArray; aItem: TObject;
+  var aObjArrayCount: integer): PtrInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// wrapper to add items to a T*ObjArray dynamic array storage
+// - aSourceObjArray[] items are just copied to aDestObjArray, which remains untouched
+// - return the new number of the items in aDestObjArray
+function ObjArrayAddFrom(var aDestObjArray; const aSourceObjArray): PtrInt;
+
+/// wrapper to add and move items to a T*ObjArray dynamic array storage
+// - aSourceObjArray[] items will be owned by aDestObjArray[], therefore
+// aSourceObjArray is set to nil
+// - return the new number of the items in aDestObjArray
+function ObjArrayAppend(var aDestObjArray, aSourceObjArray): PtrInt;
+
+/// wrapper to add once an item to a T*ObjArray dynamic array storage
+// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
+// - 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
+function ObjArrayAddOnce(var aObjArray; aItem: TObject): PtrInt; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// wrapper to add once an item to a T*ObjArray dynamic array storage and Count
+function ObjArrayAddOnce(var aObjArray; aItem: TObject;
+  var aObjArrayCount: integer): PtrInt; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+// - aSourceObjArray[] items are just copied to aDestObjArray, which remains untouched
+// - will first check if aSourceObjArray[] items are not already in aDestObjArray
+// - return the new number of the items in aDestObjArray
+function ObjArrayAddOnceFrom(var aDestObjArray; const aSourceObjArray): PtrInt;
+
+/// wrapper to set the length of a T*ObjArray dynamic array storage
+// - could be used as an alternative to SetLength() when you do not
+// know the exact T*ObjArray type
+procedure ObjArraySetLength(var aObjArray; aLength: integer);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// wrapper to search an item in a T*ObjArray dynamic array storage
+// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
+// - search is performed by address/reference, not by content
+// - returns -1 if the item is not found in the dynamic array
+function ObjArrayFind(const aObjArray; aItem: TObject): PtrInt; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// wrapper to search an item in a T*ObjArray dynamic array storage
+// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
+// - search is performed by address/reference, not by content
+// - returns -1 if the item is not found in the dynamic array
+function ObjArrayFind(const aObjArray; aCount: integer; aItem: TObject): PtrInt; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// wrapper to count all not nil items in a T*ObjArray dynamic array storage
+// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
+function ObjArrayNotNilCount(const aObjArray): integer;
+
+/// wrapper to delete an item in a T*ObjArray dynamic array storage
+// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
+// - do nothing if the index is out of range in the dynamic array
+procedure ObjArrayDelete(var aObjArray; aItemIndex: PtrInt;
+  aContinueOnException: boolean = false; aCount: PInteger = nil); overload;
+
+/// wrapper to delete an item in a T*ObjArray dynamic array storage
+// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
+// - search is performed by address/reference, not by content
+// - do nothing if the item is not found in the dynamic array
+function ObjArrayDelete(var aObjArray; aItem: TObject): PtrInt; overload;
+
+/// wrapper to delete an item in a T*ObjArray dynamic array storage
+// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
+// - search is performed by address/reference, not by content
+// - do nothing if the item is not found in the dynamic array
+function ObjArrayDelete(var aObjArray; aCount: integer; aItem: TObject): PtrInt; overload;
+
+/// wrapper to release all items stored in a T*ObjArray dynamic array
+// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
+// - you should always use ObjArrayClear() before the array storage is released,
+// e.g. in the owner class destructor
+// - when T*ObjArray are used as SOA parameters, no need to release the values
+// - 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
+// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
+// - you should always use ObjArrayClear() before the array storage is released,
+// e.g. in the owner class destructor
+// - will also set the dynamic array length to 0, so could be used to re-use
+// an existing T*ObjArray
+procedure ObjArrayClear(var aObjArray; aContinueOnException: boolean;
+  aCount: PInteger = nil); overload;
+
+/// wrapper to release all items stored in an array of T*ObjArray dynamic array
+// - e.g. aObjArray may be defined as "array of array of TSynFilter"
+procedure ObjArrayObjArrayClear(var aObjArray);
+
+/// wrapper to release all items stored in several T*ObjArray dynamic arrays
+// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
+procedure ObjArraysClear(const aObjArray: array of pointer);
+
+/// low-level function calling FreeAndNil(o^) successively n times
+procedure RawObjectsClear(o: PObject; n: integer);
+
+/// same as FreeAndNil() but catching and ignoring any exception
+// - only difference is that aObj is set to nil AFTER being destroyed
+procedure FreeAndNilSafe(var aObj);
+
+/// same as aInterface := nil but ignoring any exception
+procedure InterfaceNilSafe(var aInterface);
+
+/// same as aInterface := nil but ignoring any exception
+procedure InterfacesNilSafe(const aInterfaces: array of pointer);
+
+/// wrapper to add an item to a T*InterfaceArray dynamic array storage
+function InterfaceArrayAdd(var aInterfaceArray; const aItem: IUnknown): PtrInt;
+
+/// wrapper to add an item to a T*InterfaceArray dynamic array storage
+function InterfaceArrayAddCount(var aInterfaceArray; var aCount: integer;
+  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;
+
+
+{ ************ Low-level Types Mapping Binary Structures }
+
+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: (
+           Li, Hi: integer);
+      3: (
+           W: array[0..3] of word);
+      4: (
+           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 224-bit hash value
+  // - consumes 28 bytes of memory
+  THash224 = array[0..27] of byte;
+  /// pointer to a 224-bit hash value
+  PHash224 = ^THash224;
+
+  /// store a 256-bit hash value
+  // - e.g. a SHA-256 digest, a TEccSignature result, or array[0..7] of cardinal
+  // - consumes 32 bytes of memory
+  THash256 = array[0..31] of byte;
+  /// pointer to a 256-bit hash value
+  PHash256 = ^THash256;
+
+  /// store a 384-bit hash value
+  // - e.g. a SHA-384 digest
+  // - consumes 48 bytes of memory
+  THash384 = array[0..47] of byte;
+  /// pointer to a 384-bit hash value
+  PHash384 = ^THash384;
+
+  /// store a 512-bit hash value
+  // - e.g. a SHA-512 digest, a TEccSignature result, or array[0..15] of cardinal
+  // - consumes 64 bytes of memory
+  THash512 = array[0..63] of byte;
+  /// pointer to a 512-bit hash value
+  PHash512 = ^THash512;
+
+  /// store a 128-bit buffer
+  // - e.g. an AES block
+  // - consumes 16 bytes of memory
+  TBlock128 = array[0..3] of cardinal;
+  /// pointer to a 128-bit buffer
+  PBlock128 = ^TBlock128;
+
+  /// map an infinite array of 128-bit hash values
+  // - each item consumes 16 bytes of memory
+  THash128Array = array[ 0 .. MaxInt div SizeOf(THash128) - 1 ] of THash128;
+  /// pointer to an infinite array of 128-bit hash values
+  PHash128Array = ^THash128Array;
+  /// store several 128-bit hash values
+  // - e.g. MD5 digests
+  // - consumes 16 bytes of memory per item
+  THash128DynArray = array of THash128;
+
+  /// map a 128-bit hash as an array of lower bit size values
+  // - consumes 16 bytes of memory
+  THash128Rec = packed record
+  case integer of
+  0: (
+      Lo, Hi: Int64);
+  1: (
+      L, H: QWord);
+  2: (
+      i0, i1, i2, i3: integer);
+  3: (
+      c0, c1, c2 ,c3: cardinal);
+  4: (
+      c: TBlock128);
+  5: (
+      b: THash128);
+  6: (
+      w: array[0..7] of word);
+  7: (
+      l64, h64: Int64Rec);
+  8: (
+      guid: TGuid);
+  end;
+  /// pointer to 128-bit hash map variable record
+  PHash128Rec = ^THash128Rec;
+
+  /// map an infinite array of 256-bit hash values
+  // - each item consumes 32 bytes of memory
+  THash256Array = array[ 0 .. MaxInt div SizeOf(THash256) - 1 ] of THash256;
+  /// pointer to an infinite array of 256-bit hash values
+  PHash256Array = ^THash256Array;
+  /// store several 256-bit hash values
+  // - e.g. SHA-256 digests, TEccSignature results, or array[0..7] of cardinal
+  // - consumes 32 bytes of memory per item
+  THash256DynArray = array of THash256;
+
+  /// map a 256-bit hash as an array of lower bit size values
+  // - consumes 32 bytes of memory
+  THash256Rec = packed record
+  case integer of
+  0: (
+      Lo, Hi: THash128);
+  1: (
+      d0, d1, d2, d3: Int64);
+  2: (
+      i0, i1, i2, i3, i4, i5, i6, i7: integer);
+  3: (
+      c0, c1: TBlock128);
+  4: (
+      b: THash256);
+  5: (
+      q: array[0..3] of QWord);
+  6: (
+      c: array[0..7] of cardinal);
+  7: (
+      w: array[0..15] of word);
+  8: (
+     l, h: THash128Rec);
+  9: (
+     sha1: THash160);
+  end;
+  /// pointer to 256-bit hash map variable record
+  PHash256Rec = ^THash256Rec;
+
+  /// map an infinite array of 512-bit hash values
+  // - each item consumes 64 bytes of memory
+  THash512Array = array[ 0 .. MaxInt div SizeOf(THash512) - 1 ] of THash512;
+  /// pointer to an infinite array of 512-bit hash values
+  PHash512Array = ^THash512Array;
+  /// store several 512-bit hash values
+  // - e.g. SHA-512 digests, or array[0..15] of cardinal
+  // - consumes 64 bytes of memory per item
+  THash512DynArray = array of THash512;
+
+  /// map a 512-bit hash as an array of lower bit size values
+  // - consumes 64 bytes of memory
+  THash512Rec = packed record
+  case integer of
+  0: (
+      Lo, Hi: THash256);
+  1: (
+      h0, h1, h2, h3: THash128);
+  2: (
+      d0, d1, d2, d3, d4, d5, d6, d7: Int64);
+  3: (
+      i0, i1, i2, i3, i4, i5, i6, i7,
+      i8, i9, i10, i11, i12, i13, i14, i15: integer);
+  4: (
+      c0, c1, c2, c3: TBlock128);
+  5: (
+      b: THash512);
+  6: (
+      b160: THash160);
+  7: (
+      b384: THash384);
+  8: (
+      w: array[0..31] of word);
+  9: (
+      c: array[0..15] of cardinal);
+  10: (
+       i: array[0..7] of Int64);
+  11: (
+       q: array[0..7] of QWord);
+  12: (
+       r: array[0..3] of THash128Rec);
+  13: (
+       l, h: THash256Rec);
+  end;
+  /// pointer to 512-bit hash map variable record
+  PHash512Rec = ^THash512Rec;
+
+/// returns TRUE if all 16 bytes of this 128-bit buffer equal zero
+// - e.g. a MD5 digest, or an AES block
+function IsZero(const dig: THash128): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// returns TRUE if all 16 bytes of both 128-bit buffers do match
+// - e.g. a MD5 digest, or an AES block
+// - this function is not sensitive to any timing attack, so is designed
+// for cryptographic purpose - and it is also branchless therefore fast
+function IsEqual(const A, B: THash128): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fill all 16 bytes of this 128-bit buffer with zero
+// - may be used to cleanup stack-allocated content
+// ! ... finally FillZero(digest); end;
+procedure FillZero(out dig: THash128); overload;
+
+/// fast O(n) search of a 128-bit item in an array of such values
+function Hash128Index(P: PHash128Rec; Count: integer; h: PHash128Rec): integer;
+
+/// add a 128-bit item in an array of such values
+function AddHash128(var Arr: THash128DynArray; const V: THash128; var Count: integer): PtrInt;
+
+/// 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}
+
+/// fast O(n) search of a 256-bit item in an array of such values
+function Hash256Index(P: PHash256Rec; Count: integer; h: PHash256Rec): integer;
+
+/// 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;
+
+/// returns TRUE if all bytes of both buffers do match
+// - this function is not sensitive to any timing attack, so is designed
+// for cryptographic purposes - use CompareMem/CompareMemSmall/CompareMemFixed
+// as faster alternatives for general-purpose code
+function IsEqual(const A, B; count: PtrInt): boolean; overload;
+
+/// 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);
+
+{$ifdef ISDELPHI}
+/// this function is an intrinsic in FPC
+procedure ReadBarrier; {$ifndef CPUINTEL} inline; {$endif}
+{$endif ISDELPHI}
+
+/// fast computation of two 64-bit unsigned integers into a 128-bit value
+{$ifdef CPUINTEL}
+procedure mul64x64(const left, right: QWord; out product: THash128Rec);
+{$else}
+procedure mul64x64(constref left, right: QWord; out product: THash128Rec); inline;
+{$endif CPUINTEL}
+
+
+{ ************ Low-level Functions Manipulating Bits }
+
+/// 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 number of BITS to check, not the byte size
+// - will use fast SSE4.2 popcnt instruction if available on the CPU
+function GetBitsCount(const Bits; Count: PtrInt): PtrInt;
+
+/// pure pascal version of GetBitsCountPtrInt()
+// - defined just for regression tests - call GetBitsCountPtrInt() instead
+// - has optimized asm on x86_64 and i386
+function GetBitsCountPas(value: PtrInt): PtrInt;
+
+/// compute how many bits are set in a given pointer-sized integer
+// - the PopCnt() intrinsic under FPC doesn't have any fallback on older CPUs,
+// and default implementation is 5 times slower than our GetBitsCountPas() on x64
+// - this redirected function will use fast SSE4.2 "popcnt" opcode, if available
+var GetBitsCountPtrInt: function(value: PtrInt): PtrInt = GetBitsCountPas;
+
+/// compute how many bytes are needed to store a given number of bits
+// - e.g. 0 returns 0, 1..8 returns 1, 9..16 returns 2, and so on
+function BitsToBytes(bits: byte): byte;
+  {$ifdef HASINLINE}inline;{$endif}
+
+const
+  /// could be used to compute the index in a pointer list from its byte position
+  POINTERSHR =     {$ifdef CPU64}  3 {$else}  2 {$endif};
+  /// could be used to compute the bitmask of a pointer integer
+  POINTERAND =     {$ifdef CPU64}  7 {$else}  3 {$endif};
+  /// could be used to check all bits on a pointer
+  POINTERBITS =    {$ifdef CPU64} 64 {$else} 32 {$endif};
+  /// could be used to check all bytes on a pointer
+  POINTERBYTES =   {$ifdef CPU64}  8 {$else}  4 {$endif};
+  /// could be used to compute the index in a pointer list from its bits position
+  POINTERSHRBITS = {$ifdef CPU64}  6 {$else}  5 {$endif};
+
+  /// 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
+  // - compiler will generate bt/btr/bts opcodes - note: they may be slow when
+  // applied on a memory location, but not on a byte value (register)
+  TBits8 = set of 0..7;
+  PBits8 = ^TBits8;
+  TBits8Array = array[ 0 .. MaxInt - 1 ] of TBits8;
+
+  /// fast access to 32-bit integer bits
+  // - compiler will generate bt/btr/bts opcodes - note: they may be slow when
+  // applied on a memory location, but not on an integer value (register)
+  TBits32 = set of 0..31;
+  PBits32 = ^TBits32;
+
+  /// fast access to 64-bit integer bits
+  // - compiler will generate bt/btr/bts opcodes - note: they may be slow when
+  // applied on a memory location, but not on a Int64 value (register)
+  // - 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}
+
+
+
+{ ************ Faster Alternative to RTL Standard Functions }
+
+type
+  /// the potential features, retrieved from an Intel/AMD CPU
+  // - cf https://en.wikipedia.org/wiki/CPUID#EAX.3D1:_Processor_Info_and_Feature_Bits
+  // - is defined on all platforms, so that e.g. an ARM desktop may browse
+  // Intel-generated logs using TSynLogFile from mormot.core.log.pas
+  TIntelCpuFeature = (
+   { CPUID EAX=1 into EDX, ECX }
+   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,
+   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 EAX=7,ECX=0 into EBX, ECX, EDX }
+   cfFSGS, cfTSCADJ, cfSGX, cfBMI1, cfHLE, cfAVX2, cfFDPEO, cfSMEP,
+   cfBMI2, cfERMS, cfINVPCID, cfRTM, cfPQM, cfFPUSEG, cfMPX, cfPQE,
+   cfAVX512F, cfAVX512DQ, cfRDSEED, cfADX, cfSMAP, cfAVX512IFMA, cfPCOMMIT,
+   cfCLFLUSH, cfCLWB, cfIPT, cfAVX512PF, cfAVX512ER, cfAVX512CD, cfSHA,
+   cfAVX512BW, cfAVX512VL, cfPREFW1, cfAVX512VBMI, cfUMIP, cfPKU, cfOSPKE,
+   cfWAITPKG, cfAVX512VBMI2, cfCETSS, cfGFNI, cfVAES, cfVCLMUL, cfAVX512NNI,
+   cfAVX512BITALG, cfTMEEN, cfAVX512VPC, cf_c15, cfFLP, cfMPX0, cfMPX1,
+   cfMPX2, cfMPX3, cfMPX4, cfRDPID, cfKL, cfBUSLOCK, cfCLDEMOTE, cf_c26,
+   cfMOVDIRI, cfMOVDIR64B, cfENQCMD, cfSGXLC, cfPKS, cf_d0, cfSGXKEYS,
+   cfAVX512NNIW, cfAVX512MAPS, cfFSRM, cfUINTR, cf_d6, cf_d7, cfAVX512VP2I,
+   cfSRBDS, cfMDCLR, cfTSXABRT, cf_d12, cfTSXFA, cfSER, cfHYBRID,
+   cfTSXLDTRK, cf_d17, cfPCFG, cfLBR, cfIBT, cf_d21, cfAMXBF16, cfAVX512FP16,
+   cfAMXTILE, cfAMXINT8, cfIBRSPB, cfSTIBP, cfL1DFL, cfARCAB, cfCORCAB, cfSSBD,
+   { extended features CPUID EAX=7,ECX=1 into EAX, EDX }
+   cfSHA512, cfSM3, cfSM4, cfRAOINT, cfAVXVNNI, cfAVX512BF16, cfLASS,
+   cfCMPCCXADD, cfAPMEL, cf_a9, cfFZLREPM, cfFSREPS, cfFSREPC, cf_a13, cf_a14,
+   cf_a15, cf_a16, cfFRED, cfLKGS, cfWRMSRNS, cf_a20, cfAMXFP16, cfHRESET,
+   cfAVXIFMA, cf_a24, cf_a25, cfLAM, cfMSRLIST, cf_a28, cf_a29, cf_a30, cf_a31,
+   cf__d0, cf_d1, cf_d2, cf_d3, cfAVXVNN8, cfAVXNECVT, cf__d6, cf__d7, cfAMXCPLX,
+   cf_d9, cfAVXVNNI16, cf_d11, cf__d12, cf_d13, cfPREFETCHI, cf_d15, cf_d16,
+   cfUIRETUIF, cfCETSSS, cfAVX10, cf__d20, cf_APXF, cf_d22, cf_d23, cf_d24,
+   cf_d25, cf_d26, cf_d27, cf_d28, cf_d29, cf_d30, cf_d31);
+
+
+  /// all CPU features flags, as retrieved from an Intel/AMD CPU
+  TIntelCpuFeatures = set of TIntelCpuFeature;
+
+  /// the supported AVX10 Converged Vector ISA bit sizes
+  TIntelAvx10Vector = set of (
+    av128, av256, av512);
+  /// the AVX10 Converged Vector ISA features
+  TIntelAvx10Features = record
+    /// maximum supported sub-leaf
+    MaxSubLeaf: cardinal;
+    /// the ISA version (>= 1)
+    Version: byte;
+    /// bit vector size support
+    Vector: TIntelAvx10Vector;
+  end;
+
+  /// 32-bit ARM Hardware capabilities
+  // - merging AT_HWCAP and AT_HWCAP2 flags as reported by
+  // github.com/torvalds/linux/blob/master/arch/arm/include/uapi/asm/hwcap.h
+  // - is defined on all platforms for cross-system use
+  TArm32HwCap = (
+    // HWCAP_* constants
+    arm32SWP, arm32HALF, arm32THUMB, arm3226BIT, arm32FAST_MULT, arm32FPA,
+    arm32VFP, arm32EDSP, arm32JAVA, arm32IWMMXT, arm32CRUNCH, arm32THUMBEE,
+    arm32NEON, arm32VFPv3, arm32VFPv3D16, arm32TLS, arm32VFPv4, arm32IDIVA,
+    arm32IDIVT, arm32VFPD32, arm32LPAE, arm32EVTSTRM,
+    arm32_22, arm32_23, arm32_24, arm32_25, arm32_26, arm32_27, arm32_28,
+    arm32_29, arm32_30, arm32_31,
+    // HWCAP2_* constants
+    arm32AES, arm32PMULL, arm32SHA1, arm32SHA2, arm32CRC32);
+  TArm32HwCaps = set of TArm32HwCap;
+
+  /// 64-bit AARCH64 Hardware capabilities
+  // - merging AT_HWCAP and AT_HWCAP2 flags as reported by
+  // github.com/torvalds/linux/blob/master/arch/arm64/include/uapi/asm/ahccap.h
+  // - is defined on all platforms for cross-system use
+  TArm64HwCap = (
+    // HWCAP_* constants
+    arm64FP, arm64ASIMD, arm64EVTSTRM, arm64AES, arm64PMULL,
+    arm64SHA1, arm64SHA2, arm64CRC32, arm64ATOMICS, arm64FPHP, arm64ASIMDHP,
+    arm64CPUID, arm64ASIMDRDM, arm64JSCVT, arm64FCMA, arm64LRCPC, arm64DCPOP,
+    arm64SHA3, arm64SM3, arm64SM4, arm64ASIMDDP, arm64SHA512, arm64SVE,
+    arm64ASIMDFHM, arm64DIT, arm64USCAT, arm64ILRCPC, arm64FLAGM, arm64SSBS,
+    arm64SB, arm64PACA, arm64PACG,
+    // HWCAP2_* constants
+    arm64DCPODP, arm64SVE2, arm64SVEAES, arm64SVEPMULL, arm64SVEBITPERM,
+    arm64SVESHA3, arm64SVESM4, arm64FLAGM2, arm64FRINT, arm64SVEI8MM,
+    arm64SVEF32MM, arm64SVEF64MM, arm64SVEBF16, arm64I8MM,
+    arm64BF16, arm64DGH, arm64RNG, arm64BTI, arm64MTE);
+  TArm64HwCaps = set of TArm64HwCap;
+
+{$ifdef CPUARM}
+  TArmHwCap = TArm32HwCap;
+  TArmHwCaps = TArm32HwCaps;
+
+const
+  ahcAES   = arm32AES;
+  ahcPMULL = arm32PMULL;
+  ahcSHA1  = arm32SHA1;
+  ahcSHA2  = arm32SHA2;
+  ahcCRC32 = arm32CRC32;
+{$endif CPUARM}
+
+{$ifdef CPUAARCH64}
+  TArmHwCap = TArm64HwCap;
+  TArmHwCaps = TArm64HwCaps;
+
+const
+  ahcAES   = arm64AES;
+  ahcPMULL = arm64PMULL;
+  ahcSHA1  = arm64SHA1;
+  ahcSHA2  = arm64SHA2;
+  ahcCRC32 = arm64CRC32;
+{$endif CPUAARCH64}
+
+{$ifdef CPUARM3264}
+var
+  /// the low-level ARM/AARCH64 CPU features retrieved from system.envp
+  // - text from CpuInfoFeatures may not be accurate on oldest kernels
+  CpuFeatures: TArmHwCaps;
+{$endif CPUARM3264}
+
+/// cross-platform wrapper function to check AES HW support on Intel or ARM
+function HasHWAes: boolean;
+
+{$ifdef CPUINTEL}
+
+var
+  /// the available Intel/AMD CPU features, as recognized at program startup
+  // - on LINUX, consider CpuInfoArm or the textual CpuInfoFeatures from
+  // mormot.core.os.pas
+  CpuFeatures: TIntelCpuFeatures;
+
+  /// the detected AVX10 Converged Vector ISA features
+  // - only set if cfAVX10 is part of CpuFeatures
+  CpuAvx10: TIntelAvx10Features;
+
+/// compute 32-bit random number generated by modern Intel CPU hardware
+// - using NIST SP 800-90A and FIPS 140-2 compliant RDRAND Intel x86/x64 opcode
+// - caller should ensure that cfSSE42 is included in CpuFeatures flags
+// - you should rather call XorEntropy() which offers additional sources
+function RdRand32: cardinal; overload;
+
+/// XOR a memory buffer with some random generated by modern Intel CPU
+// - n is the number of 32-bit slots in the supplied buffer to fill
+// - will do nothing if cfSSE42 is not available on this CPU
+procedure RdRand32(buffer: PCardinal; n: integer); overload;
+
+/// returns the 64-bit Intel Time Stamp Counter (TSC)
+// - could be used as entropy source for randomness - use TPrecisionTimer if
+// you expect a cross-platform and cross-CPU high resolution performance counter
+function Rdtsc: Int64;
+
+/// compatibility function, to be implemented according to the running CPU
+// - expect the same result as the homonymous Win32 API function, i.e.
+// returns I + 1, and store I + 1 within I in an atomic/tread-safe way
+// - FPC will define this function as intrinsic for non-Intel CPUs
+function InterlockedIncrement(var I: integer): integer;
+
+/// compatibility function, to be implemented according to the running CPU
+// - expect the same result as the homonymous Win32 API function, i.e.
+// returns I - 1, and store I - 1 within I in an atomic/tread-safe way
+// - FPC will define this function as intrinsic for non-Intel CPUs
+function InterlockedDecrement(var I: integer): integer;
+
+/// slightly faster than InterlockedIncrement() when you don't need the result
+procedure LockedInc32(int32: PInteger);
+
+/// slightly faster than InterlockedDecrement() when you don't need the result
+procedure LockedDec32(int32: PInteger);
+
+/// slightly faster than InterlockedIncrement64()
+procedure LockedInc64(int64: PInt64);
+
+// defined here for mormot.test.base only
+function GetBitsCountSSE42(value: PtrInt): PtrInt;
+
+// defined here for mormot.test.base only
+// - use instead global crc32c() variable
+function crc32csse42(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
+
+{$else}
+
+/// redirect to FPC InterlockedIncrement() on non Intel CPU
+procedure LockedInc32(int32: PInteger); inline;
+
+/// redirect to FPC InterlockedDecrement() on non Intel CPU
+procedure LockedDec32(int32: PInteger); inline;
+
+/// redirect to FPC InterlockedIncrement64() on non Intel CPU
+procedure LockedInc64(int64: PInt64); inline;
+
+{$endif CPUINTEL}
+
+/// low-level string reference counter unprocess
+// - caller should have tested that refcnt>=0
+// - returns true if the managed variable should be released (i.e. refcnt was 1)
+function StrCntDecFree(var refcnt: TStrCnt): boolean;
+  {$ifndef CPUINTEL} inline; {$endif}
+
+/// low-level dynarray reference counter unprocess
+// - caller should have tested that refcnt>=0
+function DACntDecFree(var refcnt: TDACnt): boolean;
+  {$ifndef CPUINTEL} inline; {$endif}
+
+/// low-level string reference counter process
+procedure StrCntAdd(var refcnt: TStrCnt; increment: TStrCnt);
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// low-level dynarray reference counter process
+procedure DACntAdd(var refcnt: TDACnt; increment: TDACnt);
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// fast atomic compare-and-swap operation on a pointer-sized integer value
+// - via Intel/AMD custom asm or FPC RTL InterlockedCompareExchange(pointer)
+// - true if Target was equal to Comparand, and Target set to NewValue
+// - used e.g. as thread-safe atomic operation for TLightLock/TRWLock
+// - Target should be aligned, which is the case when defined as a class field
+function LockedExc(var Target: PtrUInt; NewValue, Comperand: PtrUInt): boolean;
+  {$ifndef CPUINTEL} inline; {$endif}
+
+/// fast atomic addition operation on a pointer-sized integer value
+// - via Intel/AMD custom asm or FPC RTL InterlockedExchangeAdd(pointer)
+// - Target should be aligned, which is the case when defined as a class field
+procedure LockedAdd(var Target: PtrUInt; Increment: PtrUInt);
+  {$ifndef CPUINTEL} inline; {$endif}
+
+/// fast atomic substraction operation on a pointer-sized integer value
+// - via Intel/AMD custom asm or FPC RTL InterlockedExchangeAdd(-pointer)
+// - Target should be aligned, which is the case when defined as a class field
+procedure LockedDec(var Target: PtrUInt; Decrement: PtrUInt);
+  {$ifndef CPUINTEL} inline; {$endif}
+
+/// fast atomic addition operation on a 32-bit integer value
+// - via Intel/AMD custom asm or FPC RTL InterlockedExchangeAdd(pointer)
+// - Target should be aligned, which is the case when defined as a class field
+procedure LockedAdd32(var Target: cardinal; Increment: cardinal);
+  {$ifndef CPUINTEL} inline; {$endif}
+
+{$ifdef ISDELPHI}
+
+/// return the position of the leftmost set bit in a 32-bit value
+// - returns 255 if c equals 0
+// - this function is an intrinsic on FPC
+function BSRdword(c: cardinal): cardinal;
+
+/// return the position of the leftmost set bit in a 64-bit value
+// - returns 255 if q equals 0
+// - this function is an intrinsic on FPC
+function BSRqword(const q: Qword): cardinal;
+
+{$endif ISDELPHI}
+
+{$ifdef ASMINTEL}
+
+{$ifdef ASMX64} // will define its own self-dispatched SSE2/AVX functions
+
+type
+  /// most common x86_64 CPU abilities, used e.g. by FillCharFast/MoveFast
+  // - cpuHaswell identifies Intel/AMD AVX2+BMI support at Haswell level
+  // as expected e.g. by IsValidUtf8Avx2/Base64EncodeAvx2 dedicated asm
+  // - won't include ERMSB flag because it is not propagated within some VMs
+  TX64CpuFeatures = set of (
+    cpuAVX, cpuAVX2, cpuHaswell);
+
+var
+  /// internal flags used by FillCharFast - easier from asm that CpuFeatures
+  X64CpuFeatures: TX64CpuFeatures;
+
+{$ifdef ASMX64AVXNOCONST}
+/// simdjson asm as used by mormot.core.unicode on Haswell for FPC IsValidUtf8()
+function IsValidUtf8Avx2(source: PUtf8Char; sourcelen: PtrInt):  boolean;
+// avx2 asm as used by mormot.core.buffers for Base64EncodeMain/Base64DecodeMain
+procedure Base64EncodeAvx2(var b: PAnsiChar; var blen: PtrUInt; var b64: PAnsiChar);
+procedure Base64DecodeAvx2(var b64: PAnsiChar; var b64len: PtrInt; var b: PAnsiChar);
+{$endif ASMX64AVXNOCONST}
+
+{$endif ASMX64}
+
+/// our fast version of FillChar() on Intel/AMD
+// - on Intel i386/x86_64, will use fast SSE2/AVX instructions (if available)
+// - on non-Intel CPUs, it will fallback to the default RTL FillChar()
+// - note: Delphi RTL is far from efficient: on i386 the FPU is slower/unsafe,
+// and on x86_64, ERMS is wrongly used even for small blocks
+// - on ARM/AARCH64 POSIX, mormot.core.os would redirect to optimized libc
+procedure FillcharFast(var dst; cnt: PtrInt; value: byte);
+
+/// our fast version of move() on Intel/AMD
+// - on Delphi Intel i386/x86_64, will use fast SSE2 instructions (if available)
+// - FPC i386 has fastmove.inc which is faster than our SSE2/ERMS version
+// - FPC x86_64 RTL is slower than our SSE2/AVX asm
+// - on non-Intel CPUs, it will fallback to the default RTL Move()
+// - on ARM/AARCH64 POSIX, mormot.core.os would redirect to optimized libc
+{$ifdef FPC_X86}
+var MoveFast: procedure(const Source; var Dest; Count: PtrInt) = Move;
+{$else}
+procedure MoveFast(const src; var dst; cnt: PtrInt);
+{$endif FPC_X86}
+
+{$else}
+
+// fallback to RTL versions on non-INTEL or PIC platforms by default
+// and mormot.core.os.posix.inc redirects them to libc memset/memmove
+var FillcharFast: procedure(var Dest; count: PtrInt; Value: byte) = FillChar;
+var MoveFast: procedure(const Source; var Dest; Count: PtrInt) = Move;
+
+{$endif ASMINTEL}
+
+/// Move() with one-by-one byte copy
+// - never redirect to MoveFast() so could be used when data overlaps
+procedure MoveByOne(Source, Dest: Pointer; Count: PtrUInt);
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// perform a MoveFast then fill the Source buffer with zeros
+// - could be used e.g. to quickly move a managed record content into a newly
+// allocated stack variable with no reference counting
+procedure MoveAndZero(Source, Dest: Pointer; Count: PtrUInt);
+
+/// fill all bytes of a memory buffer with zero
+// - just redirect to FillCharFast(..,...,0)
+procedure FillZero(var dest; count: PtrInt); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fill first bytes of a memory buffer with zero
+// - Length is expected to be not 0, typically in 1..8 range
+// - when inlined, is slightly more efficient than regular FillZero/FillCharFast
+procedure FillZeroSmall(P: pointer; Length: PtrInt);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// binary comparison of buffers, returning <0, 0 or >0 results
+// - caller should ensure that P1<>nil, P2<>nil and L>0
+// - on x86_64, will use a fast SSE2 asm version of the C function memcmp()
+// (which is also used by CompareMem and CompareBuf)
+// - on other platforms, run a simple but efficient per-byte comparison
+function MemCmp(P1, P2: PByteArray; L: PtrInt): integer;
+  {$ifndef CPUX64} {$ifdef HASINLINE} inline; {$endif} {$endif}
+
+/// our fast version of CompareMem()
+// - tuned asm for x86, call MemCmpSse2 for x64, or fallback to tuned pascal
+function CompareMem(P1, P2: Pointer; Length: PtrInt): boolean;
+  {$ifdef CPUX64}inline;{$endif}
+
+/// overload wrapper of MemCmp() to compare a RawByteString vs a memory buffer
+// - will first check length(P1)=P2Len then call MemCmp()
+function CompareBuf(const P1: RawByteString; P2: Pointer; P2Len: PtrInt): integer;
+  overload; {$ifdef HASINLINE}inline;{$endif}
+
+/// overload wrapper to SortDynArrayRawByteString(P1, P2)
+// - won't involve any code page - so may be safer e.g. on FPC
+function CompareBuf(const P1, P2: RawByteString): integer;
+  overload; {$ifdef HASINLINE}inline;{$endif}
+
+/// overload wrapper to SortDynArrayRawByteString(P1, P2) = 0
+// - won't involve any code page - so may be safer e.g. on FPC
+function EqualBuf(const P1, P2: RawByteString): boolean;
+  overload; {$ifdef HASINLINE}inline;{$endif}
+
+{$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
+// - to be efficiently inlined in processing code
+function CompareMemSmall(P1, P2: Pointer; Length: PtrInt): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+{$ifndef CPUX86}
+/// low-level efficient pure pascal function used when inlining PosEx()
+// - not to be called directly
+function PosExPas(pSub, p: PUtf8Char; Offset: PtrUInt): PtrInt;
+{$endif CPUX86}
+
+{$ifdef UNICODE}
+/// low-level efficient pure pascal function used when inlining PosExString()
+// - not to be called directly
+function PosExStringPas(pSub, p: PChar; Offset: PtrUInt): PtrInt;
+{$endif UNICODE}
+
+/// faster RawUtf8 Equivalent of standard StrUtils.PosEx
+function PosEx(const SubStr, S: RawUtf8; Offset: PtrUInt = 1): PtrInt;
+  {$ifndef CPUX86}{$ifdef HASINLINE}inline;{$endif}{$endif}
+
+/// our own PosEx() function dedicated to RTL string process
+// - Delphi XE or older don't support Pos() with an Offset
+function PosExString(const SubStr, S: string; Offset: PtrUInt = 1): PtrInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// optimized version of PosEx() with search text as one AnsiChar
+// - will use fast SSE2 asm on i386 and x86_64
+function PosExChar(Chr: AnsiChar; const Str: RawUtf8): PtrInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast retrieve the position of a given character in a #0 ended buffer
+// - will use fast SSE2 asm on i386 and x86_64
+function PosChar(Str: PUtf8Char; Chr: AnsiChar): PUtf8Char; overload;
+  {$ifndef CPUX64}{$ifdef FPC}inline;{$endif}{$endif}
+
+/// fast retrieve the position of a given character in a #0 ended buffer
+// - will use fast SSE2 asm on i386 and x86_64
+function PosChar(Str: PUtf8Char; StrLen: PtrInt; Chr: AnsiChar): PUtf8Char; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+{$ifndef PUREMORMOT2}
+/// fast dedicated RawUtf8 version of Trim()
+// - in the middle of UI code, consider using TrimU() which won't have name
+// collision ambiguity as with SysUtils' homonymous function
+function Trim(const S: RawUtf8): RawUtf8;
+  {$ifdef HASINLINE}inline;{$endif}
+{$endif PUREMORMOT2}
+
+/// fast dedicated RawUtf8 version of Trim()
+// - should be used for RawUtf8 instead of SysUtils' Trim() which is ambiguous
+// with the main String/UnicodeString type of Delphi 2009+
+// - in mORMot 1.18, there was a Trim() function but it was confusing
+function TrimU(const S: RawUtf8): RawUtf8;
+
+/// fast dedicated RawUtf8 version of s := Trim(s)
+procedure TrimSelf(var S: RawUtf8);
+
+/// single-allocation (therefore faster) alternative to Trim(copy())
+procedure TrimCopy(const S: RawUtf8; start, count: PtrInt;
+  var result: RawUtf8);
+
+/// 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: PtrInt = 1): RawUtf8; overload;
+
+/// buffer-overflow safe version of StrComp(), to be used with PUtf8Char/PAnsiChar
+function StrComp(Str1, Str2: pointer): PtrInt;
+  {$ifndef CPUX86}{$ifdef HASINLINE}inline;{$endif}{$endif}
+
+/// our fast version of StrComp(), to be used with PWideChar
+function StrCompW(Str1, Str2: PWideChar): PtrInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// simple 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 e.g. with valgrid
+// - SSE2 StrLen() versions would never read outside a memory page boundary,
+// so are safe to use in practice, but may read outside the string buffer
+// itself, so may not please paranoid tools like valgrid
+function StrLenSafe(S: pointer): PtrInt;
+  {$ifdef CPU64}inline;{$endif}
+
+/// our fast version of StrLen(), to be used with PUtf8Char/PAnsiChar
+// - under x86, will detect SSE2 and use it if available, reaching e.g.
+// 37.5 GB/s on a Core i5-13500 under Linux x86_64
+// - on ARM/AARCH64 POSIX, mormot.core.os would redirect to optimized libc
+{$ifdef CPUX64}
+function StrLen(S: pointer): PtrInt;
+{$else}
+var StrLen: function(S: pointer): PtrInt = StrLenSafe;
+{$endif CPUX64}
+
+/// our fast version of StrLen(), to be used with PWideChar
+function StrLenW(S: PWideChar): PtrInt;
+
+/// fast go to next text line, ended by #13 or #13#10
+// - source is expected to be not nil
+// - returns the beginning of next line, or nil if source^=#0 was reached
+function GotoNextLine(source: PUtf8Char): PUtf8Char;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast go to the first char <= #13
+// - source is expected to be not nil
+function GotoNextControlChar(source: PUtf8Char): PUtf8Char;
+  {$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: PtrUInt): boolean; overload;
+
+/// return TRUE if the supplied UTF-16 buffer only contains 7-bits Ansi characters
+function IsAnsiCompatibleW(PW: PWideChar): boolean; overload;
+
+/// return TRUE if the supplied text only contains 7-bits Ansi characters
+function IsAnsiCompatible(const Text: RawByteString): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// return TRUE if the supplied UTF-16 buffer only contains 7-bits Ansi characters
+function IsAnsiCompatibleW(PW: PWideChar; Len: PtrInt): boolean; overload;
+
+type
+  /// 32-bit Pierre L'Ecuyer software (random) generator
+  // - cross-compiler and cross-platform efficient randomness generator, very
+  // fast with a much better distribution than Delphi system's Random() function
+  // see https://www.gnu.org/software/gsl/doc/html/rng.html#c.gsl_rng_taus2
+  // - used by thread-safe Random32/RandomBytes, storing 16 bytes per thread - a
+  // stronger algorithm like Mersenne Twister (as used by FPC RTL) requires 5KB
+  // - SeedGenerator() makes it a sequence generator - or encryptor via Fill()
+  // - when used as random generator (default when initialized with 0), Seed()
+  // will gather and hash some system entropy to initialize the internal state
+  {$ifdef USERECORDWITHMETHODS}
+  TLecuyer = record
+  {$else}
+  TLecuyer = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    rs1, rs2, rs3, seedcount: cardinal;
+    /// force a random seed of the generator from current system state
+    // - as executed by the Next method at thread startup, and after 2^32 values
+    // - calls XorEntropy(), so RdRand32/Rdtsc opcodes on Intel/AMD CPUs
+    procedure Seed(entropy: PByteArray = nil; entropylen: PtrInt = 0);
+    /// force a well-defined seed of the generator from a fixed initial point
+    // - to be called before Next/Fill to generate the very same output
+    // - will generate up to 16GB of predictable output, then switch to random
+    procedure SeedGenerator(fixedseed: QWord); overload;
+    /// force a well-defined seed of the generator from a buffer initial point
+    // - apply crc32c() over the fixedseed buffer to initialize the generator
+    procedure SeedGenerator(fixedseed: pointer; fixedseedbytes: integer); overload;
+    /// compute the next 32-bit generated value with no Seed - internal call
+    function RawNext: cardinal;
+    /// compute the next 32-bit generated value
+    // - will automatically reseed after around 2^32 generated values, which is
+    // huge but very conservative since this generator has a period of 2^88
+    function Next: cardinal; overload;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// compute the next 32-bit generated value, in range [0..max-1]
+    function Next(max: cardinal): cardinal; overload;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// compute a 64-bit integer value
+    function NextQWord: QWord;
+    /// compute a 64-bit floating point value
+    function NextDouble: double;
+    /// XOR some memory buffer with random bytes
+    // - when used as sequence generator after SeedGenerator(), dest buffer
+    // should be filled with zeros before the call if you want to use it as
+    // generator, but could be applied on any memory buffer for encryption
+    procedure Fill(dest: pointer; bytes: integer);
+    /// fill some string[0..size] with 7-bit ASCII random text
+    procedure FillShort(var dest: ShortString; size: PtrUInt = 255);
+    /// fill some string[0..31] with 7-bit ASCII random text
+    procedure FillShort31(var dest: TShort31);
+  end;
+  PLecuyer = ^TLecuyer;
+
+/// return the 32-bit Pierre L'Ecuyer software generator for the current thread
+// - can be used as an alternative to several Random32 function calls
+function Lecuyer: PLecuyer;
+
+/// internal function used e.g. by TLecuyer.FillShort/FillShort31
+procedure FillAnsiStringFromRandom(dest: PByteArray; size: PtrUInt);
+
+/// fast compute of some 32-bit random value, using the gsl_rng_taus2 generator
+// - this function will use well documented and proven Pierre L'Ecuyer software
+// generator - which happens to be faster (and safer) than RDRAND opcode (which
+// is used for seeding anyway)
+// - consider using TAesPrng.Main.Random32(), which offers cryptographic-level
+// randomness, but is twice slower (even with AES-NI)
+// - thread-safe and non-blocking function: each thread will maintain its own
+// TLecuyer table (note that RTL's system.Random function is not thread-safe)
+function Random32: cardinal; overload;
+
+/// fast compute of some 31-bit random value, using the gsl_rng_taus2 generator
+// - thread-safe function: each thread will maintain its own TLecuyer table
+function Random31: integer;
+
+/// fast compute of a 64-bit random value, using the gsl_rng_taus2 generator
+// - thread-safe function: each thread will maintain its own TLecuyer table
+function Random64: QWord;
+
+/// fast compute of bounded 32-bit random value, using the gsl_rng_taus2 generator
+// - calls internally the overloaded Random32 function, ensuring Random32(max) 0
+// - warning: on x86, a should be <> b
+procedure bswap64array(a, b: PQWordArray; n: PtrInt);
+
+/// copy one memory buffer to another, swapping the bytes order
+// - used e.g. by TBigInt.Load/Save to follow DER big-endian encoding
+// - warning: src and dst should not overlap
+procedure MoveSwap(dst, src: PByte; n: PtrInt);
+
+/// 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 TJsonWriter as such:
+// ! ...
+// !   fEchos: array of TOnTextWriterEcho;
+// ! ...
+// !   procedure EchoAdd(const aEcho: TOnTextWriterEcho);
+// ! ...
+// ! procedure TEchoWriter.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 TJsonWriter as such:
+// ! ...
+// !   fEchos: array of TOnTextWriterEcho;
+// ! ...
+// !   procedure EchoRemove(const aEcho: TOnTextWriterEcho);
+// ! ...
+// ! procedure TJsonWriter.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): PtrInt;
+
+/// 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}
+
+
+{ ************ Buffers (e.g. Hashing and SynLZ compression) Raw Functions }
+
+type
+  /// implements a 4KB stack-based storage of some (UTF-8 or binary) content
+  // - 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 USERECORDWITHMETHODS}
+  TSynTempBuffer = record
+  {$else}
+  TSynTempBuffer = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// the text/binary length, in bytes, excluding the trailing #0
+    len: PtrInt;
+    /// where the text/binary is available (and any Source has been copied)
+    // - equals nil if len=0
+    buf: pointer;
+    /// default 4KB buffer allocated on stack - after the len/buf main fields
+    // - 16 last bytes are reserved to prevent potential buffer overflow,
+    // so usable length is 4080 bytes
+    tmp: array[0..4095] of AnsiChar;
+    /// 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
+    // - also include ending #0 at SourceLen position
+    procedure Init(Source: pointer; SourceLen: PtrInt); overload;
+    /// initialize a new temporary buffer of a given number of bytes
+    // - also include ending #0 at SourceLen position
+    function Init(SourceLen: PtrInt): pointer; overload;
+    /// initialize a temporary buffer with the length of the internal stack
+    function InitOnStack: pointer;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// initialize the buffer returning the internal buffer size (4080 bytes)
+    // - also set len to the internal buffer size
+    // - 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 returns an insufficient buffer error
+    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 RandomBytes() call
+    function InitRandom(RandomLen: integer): pointer;
+    /// initialize a new temporary buffer filled with 32-bit integer increasing values
+    function InitIncreasing(Count: PtrInt; Start: PtrInt = 0): PIntegerArray;
+    /// initialize a new temporary buffer of a given number of zero bytes
+    // - if ZeroLen=0, will initialize the whole tmp[] stack buffer to 0
+    function InitZero(ZeroLen: PtrInt): pointer;
+    /// inlined wrapper around buf + len
+    function BufEnd: pointer;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// 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;
+  end;
+  PSynTempBuffer = ^TSynTempBuffer;
+
+/// logical OR of two memory buffers
+// - will perform on all buffer bytes:
+// ! Dest[i] := Dest[i] or Source[i];
+procedure OrMemory(Dest, Source: PByteArray; size: PtrInt);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// logical XOR of two memory buffers
+// - will perform on all buffer bytes:
+// ! Dest[i] := Dest[i] xor Source[i];
+procedure XorMemory(Dest, Source: PByteArray; size: PtrInt); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// logical XOR of two memory buffers into a third
+// - will perform on all buffer bytes:
+// ! Dest[i] := Source1[i] xor Source2[i];
+procedure XorMemory(Dest, Source1, Source2: PByteArray; size: PtrInt); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// logical AND of two memory buffers
+// - will perform on all buffer bytes:
+// ! Dest[i] := Dest[i] and Source[i];
+procedure AndMemory(Dest, Source: PByteArray; size: PtrInt);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// returns TRUE if all bytes equal zero
+function IsZero(P: pointer; Length: integer): boolean; overload;
+
+/// returns TRUE if all of a few bytes equal zero
+// - to be called instead of IsZero() e.g. for 1..8 bytes
+function IsZeroSmall(P: pointer; Length: PtrInt): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// compute the line length from a size-delimited source array of chars
+// - will use fast SSE2 assembly on x86-64 CPU
+// - is likely to read some bytes after the TextEnd buffer, so GetLineSize()
+// from mormot.core.text may be preferred, e.g. on memory mapped files
+// - expects Text and TextEnd to be not nil - see GetLineSize() instead
+function BufferLineLength(Text, TextEnd: PUtf8Char): PtrInt;
+  {$ifndef CPUX64}{$ifdef HASINLINE}inline;{$endif}{$endif}
+  
+type
+  TCrc32tab = array[0..7, byte] of cardinal;
+  PCrc32tab = ^TCrc32tab;
+
+  /// function prototype to be used for 32-bit hashing of an element
+  // - it must return a cardinal hash, with as less collision as possible
+  // - is the function signature of DefaultHasher and InterningHasher
+  THasher = function(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
+
+  /// function prototype to be used for 64-bit hashing of an element
+  // - it must return a QWord hash, with as less collision as possible
+  // - is the function signature of DefaultHasher64
+  THasher64 = function(crc: QWord; buf: PAnsiChar; len: cardinal): QWord;
+
+  /// function prototype to be used for 128-bit hashing of an element
+  // - the input hash buffer is used as seed, and contains the 128-bit result
+  // - is the function signature of DefaultHasher128
+  THasher128 = procedure(hash: PHash128; buf: PAnsiChar; len: cardinal);
+
+var
+  /// 8KB 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 and
+  // TSynUniqueIdentifierGenerator as 1KB master/reference key tables
+  crc32ctab: TCrc32tab;
+  /// 8KB tables used by crc32fast() function
+  crc32tab: TCrc32tab;
+
+/// compute CRC32C checksum on the supplied buffer on processor-neutral code
+// - result is compatible with SSE 4.2 based hardware accelerated instruction
+// - will use fast x86/x64 asm or efficient pure pascal implementation on ARM
+// - result is not compatible with zlib's crc32() - not the same polynom
+// - crc32cfast() is 1.7 GB/s, crc32csse42() is 4.3 GB/s
+// - you should use crc32c() function instead of crc32cfast() or crc32csse42()
+function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
+
+/// compute CRC32 checksum on the supplied buffer on processor-neutral code
+// - result is compatible with zlib's crc32() but not with crc32c/crc32cfast()
+function crc32fast(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, or if you don't want to pollute the CPU L1 cache with
+// crc32cfast() bigger lookup tables
+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 or ARMv8 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;
+
+/// expand a CRC32C checksum on the supplied buffer for 64-bit hashing
+// - will use SSE 4.2 or ARMv8 hardware accelerated instruction, if available
+// - is the default implementation of DefaultHasher64
+function crc32ctwice(seed: QWord; buf: PAnsiChar; len: cardinal): QWord;
+
+/// 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 or ARMv8 hardware accelerated instruction, if available
+// - will combine two crc32c() calls into an unsigned 63-bit Int64 result
+// - by design, such combined hashes cannot be cascaded
+function crc63c(buf: PAnsiChar; len: cardinal): Int64;
+
+/// compute a 128-bit checksum on the supplied buffer, cascading two crc32c
+// - will use SSE 4.2 or ARMv8 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 256-bit checksum on the supplied buffer using crc32c
+// - will use SSE 4.2 or ARMv8 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);
+
+/// pure pascal function implementing crc32cBy4()
+function crc32cBy4fast(crc, value: cardinal): cardinal;
+
+/// compute a proprietary 128-bit CRC of 128-bit binary buffers
+// - to be used for regression tests only: crcblocks will use the fastest
+// implementation available on the current CPU (e.g. with SSE 4.2 or ARMv8)
+procedure crcblocksfast(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 (e.g. with SSE 4.2 or ARMv8)
+procedure crcblockfast(crc128, data128: PBlock128);
+
+/// compute a 128-bit CRC of any binary buffers
+// - combine crcblocks() with 4 parallel crc32c() for 1..15 trailing bytes
+procedure crc32c128(hash: PHash128; buf: PAnsiChar; len: cardinal);
+
+var
+  /// compute CRC32C checksum on the supplied buffer
+  // - result is not compatible with zlib's crc32() - Intel/SCSI CRC32C has not
+  // same polynom - but will use the fastest mean available, e.g. SSE 4.2 or ARMv8,
+  // achieve up to 16GB/s with the optimized implementation from mormot.crypt.core
+  // - you should use this function instead of crc32cfast() or crc32csse42()
+  crc32c: THasher = crc32cfast;
+
+  /// 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 or ARMv8
+  crc32cBy4: function(crc, value: cardinal): cardinal = crc32cBy4fast;
+
+  /// 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 or ARMv8 hardware accelerated instruction, if available
+  // - is used e.g. by mormot.crypt.core's TAesCfc/TAesOfc/TAesCtc to 
+  // check for data integrity
+  crcblock: procedure(crc128, data128: PBlock128)  = crcblockfast;
+
+  /// 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 or ARMv8 hardware accelerated instruction, if available
+  // - is used e.g. by crc32c128 or mormot.crypt.ecc's TEcdheProtocol.ComputeMAC
+  // for macCrc128c or TAesAbstractAead.MacCheckError
+  crcblocks: procedure(crc128, data128: PBlock128; count: integer) = crcblocksfast;
+
+  /// compute CRC32 checksum on the supplied buffer
+  // -  mormot.lib.z.pas will replace with its official (may be faster) version
+  crc32: THasher = crc32fast;
+
+  /// compute ADLER32 checksum on the supplied buffer
+  // - is only available if mormot.lib.z.pas unit is included in the project
+  adler32: THasher;
+
+/// compute CRC16-CCITT checkum on the supplied buffer
+// - i.e. 16-bit CRC-CCITT, with polynomial x^16 + x^12 + x^5 + 1 ($1021)
+// and $ffff as initial value
+// - this version is not optimized for speed, but for correctness
+function crc16(Data: PAnsiChar; Len: integer): cardinal;
+
+// our custom efficient 32-bit hash/checksum function
+// - a Fletcher-like checksum algorithm, not a hash function: has less colisions
+// than Adler32 for short strings, but more than xxhash32 or crc32/crc32c
+// - written in simple plain pascal, with no L1 CPU cache pollution, but we
+// also provide optimized x86/x64 assembly versions, since the algorithm is used
+// heavily e.g. for TDynArray binary serialization, TRestStorageInMemory
+// binary persistence, or CompressSynLZ/StreamSynLZ/FileSynLZ
+// - some numbers on Linux x86_64:
+// $ 2500 xxhash32 in 1.34ms i.e. 1861504/s or 3.8 GB/s
+// $ 2500 crc32c in 943us i.e. 2651113/s or 5.5 GB/s  (SSE4.2 disabled)
+// $ 2500 hash32 in 707us i.e. 3536067/s or 7.3 GB/s
+// $ 2500 crc32c in 387us i.e. 6459948/s or 13.4 GB/s (SSE4.2 enabled)
+function Hash32(Data: PCardinalArray; Len: integer): cardinal; overload;
+
+// our custom efficient 32-bit hash/checksum function
+// - a Fletcher-like checksum algorithm, not a hash function: has less colisions
+// than Adler32 for short strings, but more than xxhash32 or crc32/crc32c
+// - overloaded function using RawByteString for binary content hashing,
+// whatever the codepage is
+function Hash32(const Text: RawByteString): cardinal; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// standard Kernighan & Ritchie hash from "The C programming Language", 3rd edition
+// - simple and efficient code, but too much collisions for THasher
+// - kr32() is 898.8 MB/s - crc32cfast() 1.7 GB/s, crc32csse42() 4.3 GB/s
+function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
+
+/// simple FNV-1a hashing function
+// - when run over our regression suite, is similar to crc32c() about collisions,
+// and 4 times better than kr32(), but also slower than the others
+// - fnv32() is 715.5 MB/s - kr32() 898.8 MB/s
+// - this hash function should not be usefull, unless you need several hashing
+// algorithms at once (e.g. if crc32c with diverse seeds is not enough)
+function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
+
+/// perform very fast xxHash hashing in 32-bit mode
+// - will use optimized asm for x86/x64, or a pascal version on other CPUs
+function xxHash32(crc: cardinal; P: PAnsiChar; len: cardinal): cardinal;
+
+/// shuffle a 32-bit value using the last stage of xxHash32 algorithm
+// - is a cascade of binary shifts and multiplications by prime numbers
+// - see also (c * KNUTH_HASH32_MUL) shr (32 - bits) as weaker alternative
+function xxHash32Mixup(crc: cardinal): cardinal;
+  {$ifdef HASINLINE}inline;{$endif}
+
+const
+  /// Knuth's magic number for hashing a 32-bit value, using the golden ratio
+  // - then use the result high bits, i.e. via "shr" not via "and"
+  // - for instance, mormot.core.log uses it to hash the TThreadID:
+  // $ hash := cardinal(cardinal(id) * KNUTH_HASH32_MUL) shr (32 - MAXLOGTHREADBITS);
+  KNUTH_HASH32_MUL = $9E3779B1;
+
+  /// Knuth's magic number for hashing a 64-bit value, using the golden ratio
+  KNUTH_HASH64_MUL = $9E3779B97F4A7C15;
+
+  /// Knuth's magic number for hashing a PtrUInt, using the golden ratio
+  {$ifdef CPU32}
+  KNUTH_HASHPTR_MUL = KNUTH_HASH32_MUL;
+  KNUTH_HASHPTR_SHR = 32;
+  {$else}
+  KNUTH_HASHPTR_MUL = KNUTH_HASH64_MUL;
+  KNUTH_HASHPTR_SHR = 64;
+  {$endif CPU32}
+
+var
+  /// the 32-bit default hasher used by TDynArrayHashed
+  // - set to crc32csse42() if SSE4.2 or ARMv8 are available on this CPU,
+  // or fallback to xxHash32() which is faster than crc32cfast() e.g. on ARM
+  // - mormot.crypt.core may assign safer and faster AesNiHash32() if available
+  // - so the hash value may change on another computer or after program restart
+  DefaultHasher: THasher = xxHash32;
+
+  /// the 32-bit hash function used by TRawUtf8Interning
+  // - set to crc32csse42() if SSE4.2 or ARMv8 are available on this CPU,
+  // or fallback to xxHash32() which performs better than crc32cfast()
+  // - mormot.crypt.core may assign safer and faster AesNiHash32() if available
+  // - so the hash value may change on another computer or after program restart
+  InterningHasher: THasher = xxHash32;
+
+  /// a 64-bit hasher function
+  // - crc32cTwice() by default, but mormot.crypt.core may assign AesNiHash64()
+  // - so the hash value may change on another computer or after program restart
+  DefaultHasher64: THasher64 = crc32cTwice;
+
+  /// a 128-bit hasher function
+  // - crc32c128() by default, but mormot.crypt.core may assign AesNiHash128()
+  // - so the hash value may change on another computer or after program restart
+  DefaultHasher128: THasher128 = crc32c128;
+
+/// compute a 32-bit hash of any string using DefaultHasher()
+// - so the hash value may change on another computer or after program restart
+function DefaultHash(const s: RawByteString): cardinal; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// compute a 32-bit hash of any array of bytes using DefaultHasher()
+// - so the hash value may change on another computer or after program restart
+function DefaultHash(const b: TBytes): cardinal; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// compute a 32-bit hash of any string using the CRC32C checksum
+// - the returned hash value will be stable on all platforms, and use HW opcodes
+// if available on the current CPU
+function crc32cHash(const s: RawByteString): cardinal; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// compute a 32-bit hash of any array of bytes using the CRC32C checksum
+// - the returned hash value will be stable on all platforms, and use HW opcodes
+// if available on the current CPU
+function crc32cHash(const b: TBytes): cardinal; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// combine/reduce a 128-bit hash into a 64-bit hash
+// - e.g. from non cryptographic 128-bit hashers with linked lower/higher 64-bit
+function Hash128To64(const b: THash128): QWord;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// get maximum possible (worse) SynLZ compressed size
+function SynLZcompressdestlen(in_len: integer): integer;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// get exact uncompressed size from SynLZ-compressed buffer (to reserve memory, e.g.)
+function SynLZdecompressdestlen(in_p: PAnsiChar): integer;
+
+/// raw SynLZ compression algorithm implemented in pascal
+// - you should rather call SynLZcompress1() which is likely to be much faster
+function SynLZcompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
+
+/// raw SynLZ decompression algorithm implemented in pascal
+// - you should rather call SynLZdecompress1() which is likely to be much faster
+function SynLZdecompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
+
+/// SynLZ decompression algorithm with memory boundaries check
+// - this function is slower, but will allow to uncompress only the start
+// of the content (e.g. to read some metadata header)
+// - it will also check for dst buffer overflow, so will be more secure than
+// other functions, which expect the content to be verified (e.g. via CRC)
+function SynLZdecompress1partial(src: PAnsiChar; size: integer; dst: PAnsiChar;
+  maxDst: integer): integer;
+
+/// raw SynLZ compression algorithm
+// - includes optimized x86/x64 asm version on Intel/AMD
+// - just redirects to SynLZcompress1pas on other CPUs
+// - note that SynLZ is not very good at compressing a lot of zeros: it excels
+// with somewhat already pre-encoded data like text, JSON or our mormot.core.data
+// binary serialization
+function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
+  {$ifndef CPUINTEL} inline; {$endif}
+
+/// raw SynLZ decompression algorithm
+// - includes optimized x86/x64 asm version on Intel/AMD
+// - just redirects to SynLZcompress1pas on other CPUs
+function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
+  {$ifndef CPUINTEL} inline; {$endif}
+
+/// 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 Data: RawByteString; Compress: boolean): RawUtf8;
+
+/// return the Hash32() 32-bit CRC of CompressSynLZ() uncompressed data
+// - will first check the CRC of the supplied compressed Data
+// - returns 0 if the CRC of the compressed Data is not correct
+function CompressSynLZGetHash32(const Data: RawByteString): cardinal;
+
+/// simple Run-Length-Encoding compression of a memory buffer
+// - SynLZ is not good with input of a lot of redundant bytes, e.g. chunks of
+// zeros: you could pre-process RleCompress/RleUnCompress such data before SynLZ
+// - see AlgoRleLZ as such a RLE + SynLZ algorithm
+// - returns the number of bytes written to dst, or -1 on dstsize overflow
+function RleCompress(src, dst: PByteArray; srcsize, dstsize: PtrUInt): PtrInt;
+
+/// simple Run-Length-Encoding uncompression of a memory buffer
+// - SynLZ is not good with input of a lot of redundant bytes, e.g. chunks of
+// zeros: you could pre-process RleCompress/RleUnCompress such data before SynLZ
+// - see AlgoRleLZ as such a RLE + SynLZ algorithm
+function RleUnCompress(src, dst: PByteArray; size: PtrUInt): PtrUInt;
+
+/// partial Run-Length-Encoding uncompression of a memory buffer
+function RleUnCompressPartial(src, dst: PByteArray; size, max: PtrUInt): PtrUInt;
+
+/// internal hash table adjustment as called from TDynArrayHasher.HashDelete
+// - decrement any integer greater or equal to a deleted value
+// - brute force O(n) indexes fix after deletion (much faster than full ReHash)
+// - we offer very optimized SSE2 and AVX2 versions on x86_64 - therefore is
+// defined in this unit to put this asm code in mormot.core.base.asmx64.inc
+procedure DynArrayHashTableAdjust(P: PIntegerArray; deleted: integer; count: PtrInt);
+
+/// DynArrayHashTableAdjust() version for 16-bit HashTable[] - SSE2 asm on x86_64
+procedure DynArrayHashTableAdjust16(P: PWordArray; deleted: cardinal; count: PtrInt);
+
+
+{ ************ Efficient Variant Values Conversion }
+
+type
+  PVarType = ^TVarType;
+
+const
+  /// unsigned 64bit integer variant type
+  // - currently called varUInt64 in Delphi (not defined in older versions),
+  // and varQWord in FPC
+  varWord64 = 21;
+  /// map the Windows VT_INT extended VARENUM, i.e. a 32-bit signed integer
+  // - also detected and handled by VariantToInteger/VariantToInt64
+  varOleInt = 22;
+  /// map the Windows VT_UINT extended VARENUM, i.e. a 32-bit unsigned integer
+  // - also detected and handled by VariantToInteger/VariantToInt64
+  varOleUInt = 23;
+  /// map the Windows VT_LPSTR extended VARENUM, i.e. a PAnsiChar
+  // - also detected and handled by VariantToUtf8
+  varOlePAnsiChar = 30;
+  /// map the Windows VT_LPWSTR extended VARENUM, i.e. a PWideChar
+  // - also detected and handled by VariantToUtf8
+  varOlePWideChar = 31;
+  /// map the Windows VT_FILETIME extended VARENUM, i.e. a 64-bit TFileTime
+  // - also detected and handled by VariantToDateTime
+  varOleFileTime = 64;
+  /// map the Windows VT_CLSID extended VARENUM, i.e. a by-reference PGuid
+  varOleClsid = 72;
+
+  varVariantByRef = varVariant or varByRef;
+  varStringByRef  = varString or varByRef;
+  varOleStrByRef  = varOleStr or varByRef;
+
+  /// this variant type will map the current SynUnicode type
+  // - depending on the compiler version
+  {$ifdef HASVARUSTRING}
+  varSynUnicode   = varUString;
+  varUStringByRef = varUString or varByRef;
+  {$else}
+  varSynUnicode = varOleStr;
+  {$endif HASVARUSTRING}
+
+  /// this variant type will map the current string type
+  // - depending on the compiler string definition (UnicodeString or AnsiString)
+  {$ifdef UNICODE}
+  varNativeString = varUString;
+  {$else}
+  varNativeString = varString;
+  {$endif UNICODE}
+
+  {$ifdef ISDELPHI}
+  CFirstUserType = $10F;
+  {$endif ISDELPHI}
+
+  /// those TVarData.VType values are meant to be direct values
+  VTYPE_SIMPLE = [varEmpty..varDate, varBoolean, varShortInt..varWord64,
+    {$ifdef OSWINDOWS} varOleInt, varOleUInt, varOlePAnsiChar, varOlePWideChar,
+      varOleFileTime, {$endif OSWINDOWS} varUnknown];
+  /// bitmask used by our inlined VarClear() to avoid unneeded VarClearProc()
+  VTYPE_STATIC = $BFE8;
+
+  /// a slightly faster alternative to Variants.Null function with TVarData
+  NullVarData:  TVarData = (VType: varNull{%H-});
+  FalseVarData: TVarData = (VType: varBoolean{%H-});
+  TrueVarData:  TVarData = (VType: varBoolean; VInteger: {%H-}1);
+
+var
+  /// a slightly faster alternative to Variants.Null function
+  Null: variant absolute NullVarData;
+  /// a slightly faster alternative to false constant when assigned to a variant
+  VarFalse: variant absolute FalseVarData;
+  /// a slightly faster alternative to true constant when assigned to a variant
+  VarTrue: variant absolute TrueVarData;
+
+{$ifdef HASINLINE}
+/// overloaded function which can be properly inlined to clear a variant
+procedure VarClear(var v: variant); inline;
+{$endif HASINLINE}
+
+/// overloaded function which can be properly inlined to clear a variant
+procedure VarClearAndSetType(var v: variant; vtype: integer);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// internal efficient wrapper of VarClear() + set VType=varString and VAny=nil
+// - used e.g. by RawUtf8ToVariant() functions
+// - could also be used as a faster alternative to Value := ''
+procedure ClearVariantForString(var Value: variant);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// same as Value := Null, but slightly faster
+procedure SetVariantNull(var Value: variant);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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);
+
+/// get the root PVarData of a variant, redirecting any varByRef
+// - if result^.VPointer=nil, returns varEmpty
+function VarDataFromVariant(const Value: variant): PVarData;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// same as VarIsEmpty(V) or VarIsNull(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 VarIsNull(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}
+
+/// 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}
+
+/// convert any numerical Variant into a 32-bit integer
+// - it will expect true numerical Variant and won't convert any string nor
+// floating-pointer Variant, which will return FALSE and won't change the
+// Value variable content
+function VariantToInteger(const V: Variant; var Value: integer): boolean;
+
+/// convert any numerical Variant into a 64-bit integer
+// - it will expect true numerical Variant and won't convert any string nor
+// floating-pointer Variant, which will return FALSE and won't change the
+// Value variable content
+function VariantToInt64(const V: Variant; var Value: Int64): boolean;
+
+/// convert any numerical Variant into a 64-bit integer
+// - it will expect true numerical Variant and won't convert any string nor
+// floating-pointer Variant, which will return the supplied DefaultValue
+function VariantToInt64Def(const V: Variant; DefaultValue: Int64): Int64;
+
+/// convert any numerical Variant into a floating point value
+function VariantToDouble(const V: Variant; var Value: double): boolean;
+
+/// convert any numerical Variant into a floating point value
+function VariantToDoubleDef(const V: Variant; const default: double = 0): double;
+
+/// convert any numerical Variant into a fixed decimals floating point value
+function VariantToCurrency(const V: Variant; var Value: currency): boolean;
+
+/// convert any numerical Variant into a boolean value
+// - text content will return true after case-sensitive 'true' comparison
+function VariantToBoolean(const V: Variant; var Value: boolean): boolean;
+
+/// convert any numerical Variant into an integer
+// - it will expect true numerical Variant and won't convert any string nor
+// floating-pointer Variant, which will return the supplied DefaultValue
+function VariantToIntegerDef(const V: Variant; DefaultValue: integer): integer; overload;
+
+/// convert 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 an UTF-8 encoded string into a variant RawUtf8 varString
+function RawUtf8ToVariant(const Txt: RawUtf8): variant; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a Variant varString value into RawUtf8 encoded String
+// - works as the exact reverse of RawUtf8ToVariant() function
+// - non varString variants (e.g. UnicodeString, WideString, numbers, empty and
+// null) will be returned as ''
+// - use VariantToUtf8() instead if you need to convert numbers or other strings
+// - use VariantSaveJson() instead if you need a conversion to JSON with
+// custom parameters
+procedure VariantStringToUtf8(const V: Variant; var result: RawUtf8); overload;
+
+/// convert Variant string values into RawUtf8 encoded String
+// - works as the exact reverse of RawUtf8ToVariant() function
+// - non varString variants (e.g. UnicodeString, WideString, numbers, empty and
+// null) will be returned as ''
+function VariantStringToUtf8(const V: Variant): RawUtf8; overload;
+
+var
+  /// efficient finalization of successive variant items from a (dynamic) array
+  // - this unit will include a basic version calling VarClear()
+  // - mormot.core.variants will assign a more efficient implementation
+  VariantClearSeveral: procedure(V: PVarData; n: integer);
+
+  /// compare two variant/TVarData values, with or without case sensitivity
+  // - this unit registers the basic VariantCompSimple() case-sensitive comparer
+  // - mormot.core.variants will assign the much better FastVarDataComp()
+  // - called e.g. by SortDynArrayVariant/SortDynArrayVariantI functions
+  SortDynArrayVariantComp: function(
+    const A, B: TVarData; caseInsensitive: boolean): integer;
+
+/// basic default case-sensitive variant comparison function
+// - try as VariantToInt64/VariantToDouble, then RTL VarCompareValue()
+function VariantCompSimple(const A, B: variant): integer;
+
+
+{ ************ Sorting/Comparison Functions }
+
+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
+  // - simple types are compared within this unit (with proper optimized asm
+  // if possible), whereas more complex types are implemented in other units -
+  // e.g. SortDynArrayVariant/SortDynArrayVariantI are in mormot.core.variants
+  // and SortDynArrayPUtf8CharI/SortDynArrayStringI in mormot.core.text
+  TDynArraySortCompare = function(const A, B): integer;
+
+  /// the recognized operators for comparison functions results match
+  TCompareOperator = (
+    coEqualTo,
+    coNotEqualTo,
+    coLessThan,
+    coLessThanOrEqualTo,
+    coGreaterThan,
+    coGreaterThanOrEqualTo);
+
+/// fast search if a comparison function result (<0,0,>0) match an operator
+function SortMatch(CompareResult: integer; CompareOperator: TCompareOperator): boolean;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// 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 extended" elements
+function SortDynArrayExtended(const A, B): integer;
+
+/// compare two "array of AnsiString" elements, with case sensitivity
+// - on Intel/AMD will use efficient i386/x86_64 assembly using length
+// - on other CPU, will redirect to inlined StrComp() using #0 trailing char
+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
+// - on Intel/AMD, the more efficient SortDynArrayAnsiString asm is used instead
+{$ifdef CPUINTEL}
+var SortDynArrayRawByteString: TDynArraySortCompare = SortDynArrayAnsiString;
+{$else}
+function SortDynArrayRawByteString(const A, B): integer;
+{$endif CPUINTEL}
+
+/// compare two "array of PUtf8Char/PAnsiChar" elements, with case sensitivity
+function SortDynArrayPUtf8Char(const A, B): integer;
+
+/// compare two "array of WideString/UnicodeString" elements, with case sensitivity
+function SortDynArrayUnicodeString(const A, B): integer;
+
+/// compare two "array of RTL string" elements, with case sensitivity
+// - the expected string type is the RTL string
+function SortDynArrayString(const A, B): integer;
+
+/// compare two "array of shortstring" elements, with case sensitivity
+function SortDynArrayShortString(const A, B): integer;
+
+/// compare two "array of variant" elements, with case sensitivity
+// - just a wrapper around SortDynArrayVariantComp(A,B,false)
+function SortDynArrayVariant(const A, B): integer;
+
+/// compare two "array of variant" elements, with no case sensitivity
+// - just a wrapper around SortDynArrayVariantComp(A,B,true)
+function SortDynArrayVariantI(const A, B): integer;
+
+/// low-level inlined function for exchanging two pointers
+// - used e.g. during sorting process
+procedure ExchgPointer(n1, n2: PPointer);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// low-level inlined function for exchanging two sets of pointers
+// - used e.g. during sorting process
+procedure ExchgPointers(n1, n2: PPointer; count: PtrInt);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// low-level inlined function for exchanging two variants
+// - used e.g. during sorting process
+procedure ExchgVariant(v1, v2: PPtrIntArray);
+  {$ifdef CPU64} inline;{$endif}
+
+/// low-level inlined function for exchanging two memory buffers
+// - used e.g. during sorting process
+procedure Exchg(P1, P2: PAnsiChar; count: PtrInt);
+  {$ifdef HASINLINE}inline;{$endif}
+
+
+{ ************ Some Convenient TStream descendants and File access functions }
+
+type
+  /// a dynamic array of TStream instances
+  TStreamDynArray = array of TStream;
+
+  {$M+}
+  /// TStream with a protected fPosition field
+  TStreamWithPosition = class(TStream)
+  protected
+    fPosition: Int64;
+    {$ifdef FPC}
+    function GetPosition: Int64; override;
+    {$endif FPC}
+  public
+    /// change the current Read/Write position, within current GetSize
+    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
+    /// call the 64-bit Seek() overload
+    function Seek(Offset: Longint; Origin: Word): Longint; override;
+  end;
+  {$M-}
+
+  /// TStream with two protected fPosition/fSize fields
+  TStreamWithPositionAndSize = class(TStreamWithPosition)
+  protected
+    fSize: Int64;
+    function GetSize: Int64; override;
+  end;
+
+  /// TStream using a RawByteString as internal storage
+  // - default TStringStream uses UTF-16 WideChars since Delphi 2009, so it is
+  // not compatible with previous versions or FPC, and it makes more sense to
+  // work with RawByteString/RawUtf8 in our UTF-8 oriented framework
+  // - just like TStringStream, is designed for appending data, not modifying
+  // in-place, as requested e.g. by TJsonWriter or TBufferWriter classes
+  TRawByteStringStream = class(TStreamWithPosition)
+  protected
+    fDataString: RawByteString;
+    function GetSize: Int64; override;
+    procedure SetSize(NewSize: Longint); override;
+  public
+    /// initialize the storage, optionally with some RawByteString content
+    // - to be used for Read() from this memory buffer
+    constructor Create(const aString: RawByteString); overload;
+    /// read some bytes from the internal storage
+    // - returns the number of bytes filled into Buffer (<=Count)
+    function Read(var Buffer; Count: Longint): Longint; override;
+    /// append some data to the buffer
+    // - will resize the buffer, i.e. will replace the end of the string from
+    // the current position with the supplied data
+    function Write(const Buffer; Count: Longint): Longint; override;
+    /// retrieve the stored content from a given position, as UTF-8 text
+    // - warning: may directly return DataString and reset its value to ''
+    procedure GetAsText(StartPos, Len: PtrInt; var Text: RawUtf8);
+    /// reset the internal DataString content and the current position
+    procedure Clear;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// direct low-level access to the internal RawByteString storage
+    property DataString: RawByteString
+      read fDataString write fDataString;
+  end;
+
+  /// TStream pointing to some existing in-memory data, for instance UTF-8 text
+  // - warning: there is no local copy of the supplied content: the
+  // source data must be available during all the TSynMemoryStream usage
+  TSynMemoryStream = class(TCustomMemoryStream)
+  public
+    /// create a TStream with the supplied text data
+    // - warning: there is no local copy of the supplied content: the aText
+    // variable must be available during all the TSynMemoryStream usage:
+    // don't release aText before calling TSynMemoryStream.Free
+    // - aText can be on any AnsiString format, e.g. RawUtf8 or RawByteString
+    constructor Create(const aText: RawByteString); overload;
+    /// create a TStream with the supplied data buffer
+    // - warning: there is no local copy of the supplied content: the
+    // Data/DataLen buffer must be available during all the TSynMemoryStream usage:
+    // don't release the source Data before calling TSynMemoryStream.Free
+    constructor Create(Data: pointer; DataLen: PtrInt); overload;
+    /// this TStream is read-only: calling this method will raise an exception
+    function Write(const Buffer; Count: Longint): Longint; override;
+  end;
+
+/// raise a EStreamError exception - e.g. from TSynMemoryStream.Write
+function RaiseStreamError(Caller: TObject; const Context: shortstring): PtrInt;
+
+
+{ ************ Raw Shared Constants / Types Definitions }
+
+  { some types defined here, but implemented in mormot.core.datetime or
+    mormot.core.log, so that they may be used and identified by
+    mormot.core.rtti or mormot.core.os }
+
+type
+  /// the available logging events, as handled by mormot.core.log
+  // - defined in mormot.core.base so that it may be used by the core units,
+  // even if mormot.core.log is not explicitely linked
+  // - limited to 32 items, to efficiently fit in a 32-bit set
+  // - 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 (in MB units)
+  // - 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
+  TSynLogLevel = (
+    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
+  TSynLogLevels = set of TSynLogLevel;
+
+  /// a dynamic array of logging event levels
+  TSynLogLevelDynArray = array of TSynLogLevel;
+
+  /// callback definition used to abstractly log some events
+  // - defined as TMethod to avoid dependency with the mormot.core.log unit
+  // - match class procedure TSynLog.DoLog
+  // - used e.g. by global variables like WindowsServiceLog in mormot.core.os
+  // or TCrtSocket.OnLog in mormot.net.sock
+  TSynLogProc = procedure(Level: TSynLogLevel; const Fmt: RawUtf8;
+     const Args: array of const; Instance: TObject = nil) of object;
+
+{$ifndef PUREMORMOT2}
+  TSynLogInfo  = TSynLogLevel;
+  TSynLogInfos = TSynLogLevels;
+  TSynLogInfoDynArray = TSynLogLevelDynArray;
+{$endif PUREMORMOT2}
+
+type
+  /// fast bit-encoded date and time value
+  // - see TTimeLog helper functions and types in mormot.core.datetime
+  // - faster than Iso-8601 text and TDateTime, e.g. can be used as published
+  // property field in mORMot's TOrm (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
+  // - recognized e.g. by TDynArray JSON serialization
+  TTimeLogDynArray = array of TTimeLog;
+
+  /// 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;
+  /// pointer to a dynamic array of TDateTimeMS values
+  PDateTimeMSDynArray = ^TDateTimeMSDynArray;
+
+  /// a 64-bit identifier, as used for our ORM primary key, i.e. TOrm.ID
+  // - also maps the SQLite3 64-bit RowID definition
+  TID = type Int64;
+  /// a pointer to TOrm.ID, i.e. our ORM primary key
+  PID = ^TID;
+  /// used to store a dynamic array of ORM primary keys, i.e. TOrm.ID
+  TIDDynArray = array of TID;
+  /// pointer to a dynamic array of ORM primary keys, i.e. TOrm.ID
+  PIDDynArray = ^TIDDynArray;
+
+  /// timestamp stored as second-based Unix Time
+  // - see Unix Time helper functions and types in mormot.core.datetime
+  // - 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;
+  /// pointer to a timestamp stored as second-based Unix Time
+  PUnixTime = ^TUnixTime;
+  /// dynamic array of timestamps stored as second-based Unix Time
+  TUnixTimeDynArray = array of TUnixTime;
+
+  /// timestamp stored as millisecond-based Unix Time
+  // - see Unix Time helper functions and types in mormot.core.datetime
+  // - 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 millisecond-based Unix Time
+  PUnixMSTime = ^TUnixMSTime;
+  /// dynamic array of timestamps stored as millisecond-based Unix Time
+  TUnixMSTimeDynArray = array of TUnixMSTime;
+
+const
+  /// may be used to log as Trace or Warning event, depending on an Error: boolean
+  LOG_TRACEWARNING: array[boolean] of TSynLogLevel = (
+    sllTrace,
+    sllWarning);
+
+
+implementation
+
+{$ifdef ISDELPHI20062007}
+uses
+  Windows; // circumvent unexpected warning about inlining (WTF!)
+{$endif ISDELPHI20062007}
+
+{$ifdef FPC}
+  // globally disable some FPC paranoid warnings - rely on x86_64 as reference
+  {$WARN 4056 off : Conversion between ordinals and pointers is not portable }
+{$endif FPC}
+
+
+{ ************ Common Types Used for Compatibility Between Compilers and CPU }
+
+procedure VarClearAndSetType(var v: variant; vtype: integer);
+var
+  p: PInteger; // more efficient generated asm with an explicit temp variable
+begin
+  p := @v;
+  {$if defined(OSBSDDARWIN) and defined(ARM3264)}
+  if PVarData(p)^.VType and VTYPE_STATIC <> 0 then // just like in Variants.pas
+  {$else}
+  if p^ and VTYPE_STATIC <> 0 then
+  {$ifend}
+    VarClearProc(PVarData(p)^);
+  p^ := vtype;
+end;
+
+{$ifdef HASINLINE}
+procedure VarClear(var v: variant); // defined here for proper inlining
+var
+  p: PInteger; // more efficient generated asm with an explicit temp variable
+begin
+  p := @v;
+  {$if defined(OSBSDDARWIN) and defined(ARM3264)}
+  if PVarData(p)^.VType and VTYPE_STATIC = 0 then // just like in Variants.pas
+  {$else}
+  if p^ and VTYPE_STATIC = 0 then
+  {$ifend}
+    p^ := 0
+  else
+    VarClearProc(PVarData(p)^);
+end;
+{$endif HASINLINE}
+
+{$ifdef CPUARM}
+function ToByte(value: cardinal): cardinal;
+begin
+  result := value and $ff;
+end;
+{$endif CPUARM}
+
+{$ifdef CPUX86} // directly use the x87 FPU stack
+
+procedure CurrencyToDouble(const c: currency; out d: double);
+begin
+  d := c;
+end;
+
+procedure CurrencyToDouble(c: PCurrency; out d: double);
+begin
+  d := c^;
+end;
+
+function CurrencyToDouble(c: PCurrency): double;
+begin
+  result := c^;
+end;
+
+procedure DoubleToCurrency(const d: double; out c: currency);
+begin
+  c := d;
+end;
+
+procedure DoubleToCurrency(const d: double; c: PCurrency);
+begin
+  c^ := d;
+end;
+
+function DoubleToCurrency(const d: double): currency;
+begin
+  result := d;
+end;
+
+{$else} // efficient inlined 64-bit integer version
+
+procedure CurrencyToDouble(const c: currency; out d: double);
+begin
+  unaligned(d{%H-}) := PInt64(@c)^ / CURR_RES;
+end;
+
+procedure CurrencyToDouble(c: PCurrency; out d: double);
+begin
+  unaligned(d{%H-}) := PInt64(c)^ / CURR_RES;
+end;
+
+function CurrencyToDouble(c: PCurrency): double;
+begin
+  result := PInt64(c)^ / CURR_RES;
+end;
+
+procedure DoubleToCurrency(const d: double; out c: currency);
+begin
+  PInt64(@c)^ := trunc(d * CURR_RES);
+end;
+
+procedure DoubleToCurrency(const d: double; c: PCurrency);
+begin
+  PInt64(c)^ := trunc(d * CURR_RES);
+end;
+
+function DoubleToCurrency(const d: double): currency;
+begin
+  result := trunc(d * CURR_RES);
+end;
+
+{$endif CPUX86}
+
+procedure CurrencyToInt64(c: PCurrency; var i: Int64);
+begin
+  i := PInt64(c)^ div CURR_RES;
+end;
+
+procedure CurrencyToVariant(const c: currency; var v: variant);
+begin
+  VarClearAndSetType(v, varCurrency);
+  PVarData(@v).VCurrency := c;
+end;
+
+function SimpleRoundTo2Digits(Value: Currency): Currency;
+begin
+  SimpleRoundTo2DigitsCurr64(PInt64(@Value)^);
+  result := Value;
+end;
+
+procedure SimpleRoundTo2DigitsCurr64(var Value: Int64);
+var
+  Spare: PtrInt;
+begin
+  Spare := Value mod 100;
+  if Spare <> 0 then
+    if Spare > 50 then
+      {%H-}inc(Value, 100 - Spare)
+    else if Spare < -50 then
+      {%H-}dec(Value, 100 + Spare)
+    else
+      dec(Value, Spare);
+end;
+
+function TwoDigits(const d: double): TShort31;
+var
+  v: Int64;
+  m, L: PtrInt;
+  tmp: array[0..23] of AnsiChar;
+  P: PAnsiChar;
+begin
+  v := trunc(d * CURR_RES);
+  m := v mod 100;
+  if m <> 0 then
+    if m > 50 then
+      {%H-}inc(v, 100 - m)
+    else if m < -50 then
+      {%H-}dec(v, 100 + m)
+    else
+      dec(v, m);
+  P := {%H-}StrInt64(@tmp[23], v);
+  L := @tmp[22] - P;
+  m := PWord(@tmp[L - 2])^;
+  if m = ord('0') or ord('0') shl 8 then
+    // '300' -> '3'
+    dec(L, 3)
+  else
+  begin
+    // '301' -> '3.01'
+    PWord(@tmp[L - 1])^ := m;
+    tmp[L - 2] := '.';
+  end;
+  SetString(result, P, L);
+end;
+
+function TruncTo2Digits(Value: Currency): Currency;
+var
+  V64: Int64 absolute Value; // to avoid any floating-point precision issues
+begin
+  dec(V64, V64 mod 100);
+  result := Value;
+end;
+
+procedure TruncTo2DigitsCurr64(var Value: Int64);
+begin
+  dec(Value, Value mod 100);
+end;
+
+function TruncTo2Digits64(Value: Int64): Int64;
+begin
+  result := Value - Value mod 100;
+end;
+
+procedure Int64ToCurrency(const i: Int64; out c: currency);
+begin
+  PInt64(@c)^ := i * CURR_RES;
+end;
+
+procedure Int64ToCurrency(const i: Int64; c: PCurrency);
+begin
+  PInt64(c)^ := i * CURR_RES;
+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 IsEqualGuid(guid1, guid2: PGuid): boolean;
+begin
+  result := (PHash128Rec(guid1).L = PHash128Rec(guid2).L) and
+            (PHash128Rec(guid1).H = PHash128Rec(guid2).H);
+end;
+
+function IsEqualGuidArray(const guid: TGuid; const guids: array of TGuid): integer;
+begin
+  result := Hash128Index(@guids[0], length(guids), @guid);
+end;
+
+function IsNullGuid({$ifdef FPC_HAS_CONSTREF}constref{$else}const{$endif} guid: TGuid): boolean;
+var
+  a: TPtrIntArray absolute Guid;
+begin
+  result := (a[0] = 0) and
+            (a[1] = 0) {$ifdef CPU32} and
+            (a[2] = 0) and
+            (a[3] = 0) {$endif CPU32};
+end;
+
+function AddGuid(var guids: TGuidDynArray; const guid: TGuid; NoDuplicates: boolean): integer;
+begin
+  if NoDuplicates then
+  begin
+    result := Hash128Index(pointer(guids), length(guids), @guid);
+    if result>=0 then
+      exit;
+  end;
+  result := length(guids);
+  SetLength(guids, result + 1);
+  guids[result] := guid;
+end;
+
+procedure FillZero(var result: TGuid);
+var
+  d: TInt64Array absolute result;
+begin
+  d[0] := 0;
+  d[1] := 0;
+end;
+
+function RandomGuid: TGuid;
+begin
+  RandomGuid(result);
+end;
+
+procedure RandomGuid(out result: TGuid);
+begin // see https://datatracker.ietf.org/doc/html/rfc4122#section-4.4
+  RandomBytes(@result, SizeOf(TGuid));
+  result.D3 := (result.D3 and $0FFF) + $4000; // version bits 12-15 = 4 (random)
+  result.D4[0] := byte(result.D4[0] and $3F) + $80; // reserved bits 6-7 = 1
+end;
+
+function NextGrow(capacity: integer): integer;
+begin
+  // algorithm similar to TFPList.Expand for the increasing ranges
+  result := capacity;
+  if result < 8 then
+    inc(result, 4) // faster for smaller capacity (called often)
+  else if result <= 128 then
+    inc(result, 16)
+  else if result < 8 shl 20 then
+    inc(result, result shr 2)
+  else if result < 128 shl 20 then
+    inc(result, result shr 3)
+  else
+    inc(result, 16 shl 20);
+end;
+
+{$ifndef FPC_ASMX64}
+
+procedure FastAssignNew(var d; s: pointer);
+var
+  sr: PStrRec; // local copy to use register
+begin
+  sr := Pointer(d);
+  Pointer(d) := s;
+  if sr = nil then
+    exit;
+  dec(sr);
+  if (sr^.refcnt >= 0) and
+     StrCntDecFree(sr^.refcnt) then
+    FreeMem(sr);
+end;
+
+procedure FastAssignNewNotVoid(var d; s: pointer);
+var
+  sr: PStrRec; // local copy to use register
+begin
+  sr := Pointer(d);
+  Pointer(d) := s;
+  dec(sr);
+  if (sr^.refcnt >= 0) and
+     StrCntDecFree(sr^.refcnt) then
+    FreeMem(sr);
+end;
+
+{$endif FPC_ASMX64}
+
+function FastNewString(len, codepage: PtrInt): PAnsiChar;
+var
+  P: PStrRec;
+begin
+  result := nil;
+  if len > 0 then
+  begin
+    {$ifdef FPC}
+    P := GetMem(len + (_STRRECSIZE + 4));
+    result := PAnsiChar(P) + _STRRECSIZE;
+    {$else}
+    GetMem(result, len + (_STRRECSIZE + 4));
+    P := pointer(result);
+    inc(PStrRec(result));
+    {$endif FPC}
+    {$ifdef HASCODEPAGE} // also set elemSize := 1
+    {$ifdef FPC}
+    P^.codePageElemSize := codepage + (1 shl 16);
+    {$else}
+    PCardinal(@P^.codePage)^ := codepage + (1 shl 16);
+    {$endif FPC}
+    {$endif HASCODEPAGE}
+    P^.refCnt := 1;
+    P^.length := len;
+    PCardinal(PAnsiChar(P) + len + _STRRECSIZE)^ := 0; // ends with four #0
+  end;
+end;
+
+{$ifdef HASCODEPAGE}
+
+procedure EnsureRawUtf8(var s: RawByteString);
+begin
+  if s <> '' then
+    with PStrRec(PAnsiChar(pointer(s)) - _STRRECSIZE)^ do
+      if CodePage <> CP_UTF8 then
+        if refCnt <> 1 then
+          FastSetString(RawUtf8(s), pointer(s), length) // make copy
+        else
+          CodePage := CP_UTF8; // just replace in-place
+end;
+
+procedure EnsureRawUtf8(var s: RawUtf8);
+begin
+  EnsureRawUtf8(RawByteString(s));
+end;
+
+procedure FakeCodePage(var s: RawByteString; cp: cardinal);
+var
+  p: PAnsiChar;
+begin
+  p := pointer(s);
+  if p <> nil then
+    PStrRec(p - _STRRECSIZE)^.CodePage := cp;
+end;
+
+function GetCodePage(const s: RawByteString): cardinal;
+begin
+  result := PStrRec(PAnsiChar(pointer(s)) - _STRRECSIZE)^.CodePage;
+end;
+
+procedure FastAssignUtf8(var dest: RawUtf8; var src: RawByteString);
+begin
+  FakeCodePage(RawByteString(src), CP_UTF8);
+  FastAssignNew(dest, pointer(src));
+  pointer(src) := nil; // was assigned with no ref-counting involved
+end;
+
+{$else} // do nothing on Delphi 7-2007
+procedure FakeCodePage(var s: RawByteString; cp: cardinal);
+begin
+end;
+procedure EnsureRawUtf8(var s: RawByteString);
+begin
+end;
+procedure EnsureRawUtf8(var s: RawUtf8);
+begin
+end;
+procedure FastAssignUtf8(var dest: RawUtf8; var src: RawByteString);
+begin
+  FastAssignNew(dest, pointer(src));
+  pointer(src) := nil; // was assigned with no ref-counting involved
+end;
+{$endif HASCODEPAGE}
+
+procedure FakeLength(var s: RawUtf8; len: PtrInt);
+var
+  p: PAnsiChar; // faster with a temp variable
+begin
+  p := pointer(s);
+  p[len] := #0;
+  PStrLen(p - _STRLEN)^ := len; // in-place SetLength()
+end;
+
+procedure FakeLength(var s: RawUtf8; endChar: PUtf8Char);
+var
+  p: PAnsiChar;
+begin
+  p := pointer(s);
+  endChar^ := #0;
+  PStrLen(p - _STRLEN)^ := endChar - p;
+end;
+
+procedure FakeLength(var s: RawByteString; len: PtrInt);
+var
+  p: PAnsiChar;
+begin
+  p := pointer(s);
+  p[len] := #0;
+  PStrLen(p - _STRLEN)^ := len; // in-place SetLength()
+end;
+
+procedure FakeSetLength(var s: RawUtf8; len: PtrInt);
+begin
+  if len <= 0 then
+    FastAssignNew(s)
+  else
+    FakeLength(s, len);
+end;
+
+procedure FakeSetLength(var s: RawByteString; len: PtrInt); overload;
+begin
+  if len <= 0 then
+    FastAssignNew(s)
+  else
+    FakeLength(s, len);
+end;
+
+procedure FastSetStringCP(var s; p: pointer; len, codepage: PtrInt);
+var
+  r: pointer;
+begin
+  r := FastNewString(len, codepage);
+  if (p <> nil) and
+     (r <> nil) then
+    MoveFast(p^, r^, len);
+  if pointer(s) = nil then
+    pointer(s) := r
+  else
+    FastAssignNewNotVoid(s, r);
+end;
+
+procedure FastSetString(var s: RawUtf8; p: pointer; len: PtrInt);
+var
+  r: pointer;
+begin
+  r := FastNewString(len, CP_UTF8); // FPC will do proper constant propagation
+  if (p <> nil) and
+     (r <> nil) then
+    MoveFast(p^, r^, len);
+  if pointer(s) = nil then
+    pointer(s) := r
+  else
+    FastAssignNewNotVoid(s, r);
+end;
+
+procedure FastSetString(var s: RawUtf8; len: PtrInt);
+var
+  r: pointer;
+begin
+  r := FastNewString(len, CP_UTF8);
+  if pointer(s) = nil then
+    pointer(s) := r
+  else
+    FastAssignNewNotVoid(s, r);
+end;
+
+procedure FastSetRawByteString(var s: RawByteString; p: pointer; len: PtrInt);
+var
+  r: pointer;
+begin
+  r := FastNewString(len, CP_RAWBYTESTRING); // FPC does constant propagation
+  if (p <> nil) and
+     (r <> nil) then
+    MoveFast(p^, r^, len);
+  if pointer(s) = nil then
+    pointer(s) := r
+  else
+    FastAssignNewNotVoid(s, r);
+end;
+
+procedure FastNewRawByteString(var s: RawByteString; len: PtrInt);
+var
+  r: pointer;
+begin
+  r := FastNewString(len, CP_RAWBYTESTRING);
+  if pointer(s) = nil then
+    pointer(s) := r
+  else
+    FastAssignNewNotVoid(s, r);
+end;
+
+procedure GetMemAligned(var holder: RawByteString; fillwith: pointer;
+  len: PtrUInt; out aligned: pointer; alignment: PtrUInt);
+begin
+  dec(alignment); // expected to be a power of two
+  FastNewRawByteString(holder, len + alignment);
+  aligned := pointer(holder);
+  while PtrUInt(aligned) and alignment <> 0 do
+    inc(PByte(aligned));
+  if fillwith <> nil then
+    MoveFast(fillwith^, aligned^, len);
+end;
+
+// CompareMemSmall/MoveByOne defined now for proper inlining below
+
+// warning: Delphi has troubles inlining goto/label
+function CompareMemSmall(P1, P2: Pointer; Length: PtrInt): boolean;
+var
+  c: AnsiChar;
+begin
+  result := false;
+  inc(PtrUInt(P1), PtrUInt(Length));
+  inc(PtrUInt(P2), PtrUInt(Length));
+  Length := -Length;
+  if Length <> 0 then
+    repeat
+      c := PAnsiChar(P1)[Length];
+      if c <> PAnsiChar(P2)[Length] then
+        exit;
+      inc(Length);
+    until Length = 0;
+  result := true;
+end;
+
+procedure MoveByOne(Source, Dest: Pointer; Count: PtrUInt);
+var
+  c: AnsiChar; // better code generation on FPC
+begin
+  inc(PtrUInt(Source), Count);
+  inc(PtrUInt(Dest), Count);
+  PtrInt(Count) := -PtrInt(Count);
+  repeat
+    c := PAnsiChar(Source)[Count];
+    PAnsiChar(Dest)[Count] := c;
+    inc(Count);
+  until Count = 0;
+end;
+
+function UniqueRawUtf8(var u: RawUtf8): pointer;
+begin
+  {$ifdef FPC}
+  UniqueString(u); // @u[1] won't call UniqueString() under FPC :(
+  {$endif FPC}
+  result := @u[1];
+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 Ansi7StringToShortString(const source: RawUtf8; var result: ShortString);
+begin
+  SetString(result, PAnsiChar(pointer(source)), length(source));
+end;
+
+procedure AppendShort(const src: ShortString; var dest: ShortString);
+var
+  len: PtrInt;
+begin
+  len := ord(src[0]);
+  if (len = 0) or
+     (len + ord(dest[0]) > 255) then
+    exit;
+  MoveFast(src[1], dest[ord(dest[0]) + 1], len);
+  inc(dest[0], len);
+end;
+
+procedure AppendShortChar(chr: AnsiChar; var dest: ShortString);
+begin
+  if dest[0] = #255 then
+    exit;
+  inc(dest[0]);
+  dest[ord(dest[0])] := chr;
+end;
+
+const
+  HexChars: array[0..15] of AnsiChar = '0123456789ABCDEF';
+  HexCharsLower: array[0..15] of AnsiChar = '0123456789abcdef';
+
+procedure AppendShortByteHex(value: byte; var dest: ShortString);
+var
+  len: PtrInt;
+begin
+  len := ord(dest[0]);
+  if len >= 254 then
+    exit;
+  dest[len + 1] := HexChars[value shr 4];
+  inc(len, 2);
+  value := value and $0f;
+  dest[len] := HexChars[value];
+  dest[0] := AnsiChar(len);
+end;
+
+procedure AppendShortTemp24(value, temp: PAnsiChar; dest: PAnsiChar);
+  {$ifdef HASINLINE} inline; {$endif}
+var
+  valuelen, destlen, newlen: PtrInt;
+begin
+  valuelen := temp - value;
+  destlen := ord(dest[0]);
+  newlen := valuelen + destlen;
+  if newlen > 255 then
+    exit;
+  dest[0] := AnsiChar(newlen);
+  MoveFast(value^, dest[destlen + 1], valuelen);
+end;
+
+procedure AppendShortCardinal(value: cardinal; var dest: ShortString);
+var
+  tmp: array[0..23] of AnsiChar;
+begin
+  AppendShortTemp24(StrUInt32(@tmp[23], value), @tmp[23], @dest);
+end;
+
+procedure AppendShortInt64(value: Int64; var dest: ShortString);
+var
+  tmp: array[0..23] of AnsiChar;
+begin
+  AppendShortTemp24(StrInt64(@tmp[23], value), @tmp[23], @dest);
+end;
+
+procedure AppendShortBuffer(buf: PAnsiChar; len: integer; var dest: ShortString);
+begin
+  if len < 0 then
+    len := StrLen(buf);
+  if (len = 0) or
+     (len + ord(dest[0]) > 255) then
+    exit;
+  MoveFast(buf^, dest[ord(dest[0]) + 1], len);
+  inc(dest[0], len);
+end;
+
+procedure AppendShortAnsi7String(const buf: RawByteString; var dest: ShortString);
+begin
+  if buf <> '' then
+    AppendShortBuffer(pointer(buf), PStrLen(PtrUInt(buf) - _STRLEN)^, dest);
+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
+  if Instance = nil then
+    result := @NULCHAR // avoid GPF
+  else
+    result := PPointer(PPtrInt(Instance)^ + vmtClassName)^;
+end;
+
+procedure ClassToText(C: TClass; var result: RawUtf8);
+var
+  P: PShortString;
+begin
+  if C = nil then
+    result := '' // avoid GPF
+  else
+  begin
+    P := PPointer(PtrInt(PtrUInt(C)) + vmtClassName)^;
+    FastSetString(result, @P^[1], ord(P^[0]));
+  end;
+end;
+
+function ToText(C: TClass): RawUtf8;
+begin
+  ClassToText(C, result);
+end;
+
+function GetClassParent(C: TClass): TClass;
+begin
+  result := PPointer(PtrInt(PtrUInt(C)) + vmtParent)^;
+  {$ifndef HASDIRECTTYPEINFO} // e.g. for Delphi and newer FPC
+  if result <> nil then
+    result := PPointer(result)^;
+  {$endif HASDIRECTTYPEINFO}
+end;
+
+function PropNameEquals(P1, P2: PShortString): boolean;
+var
+  P1P2Len: PtrInt;
+label
+  zero;
+begin
+  P1P2Len := ord(P1^[0]);
+  if P1P2Len <> ord(P2^[0]) then
+    goto zero;
+  inc(PByte(P1));
+  inc(PByte(P2));
+  P1P2Len := PtrInt(@PByteArray(P1)[P1P2Len - SizeOf(cardinal)]); // 32-bit end
+  if P1P2Len >= PtrInt(PtrUInt(P1)) then
+    repeat // case-insensitive compare 4 bytes per loop
+      if (PCardinal(P1)^ xor PCardinal(P2)^) and $dfdfdfdf <> 0 then
+        goto zero;
+      inc(PCardinal(P1));
+      inc(PCardinal(P2));
+    until P1P2Len < PtrInt(PtrUInt(P1));
+  inc(PCardinal(P1P2Len));
+  dec(PtrUInt(P2), PtrUInt(P1));
+  if PtrInt(PtrUInt(P1)) < P1P2Len then
+    repeat
+      if (PByte(P1)^ xor PByteArray(P2)[PtrUInt(P1)]) and $df <> 0 then
+        goto zero;
+      inc(PByte(P1));
+    until PtrInt(PtrUInt(P1)) >= P1P2Len;
+  result := true;
+  exit;
+zero:
+  result := false;
+end;
+
+function PropNameEquals(const P1, P2: RawUtf8): boolean;
+var
+  P1P2Len, _1, _2: PtrInt;
+label
+  zero;
+begin
+  P1P2Len := length(P1);
+  if P1P2Len <> length(P2) then
+    goto zero;
+  _1 := PtrUInt(P1);
+  _2 := PtrUInt(P2);
+  P1P2Len := PtrInt(@PByteArray(_1)[P1P2Len - SizeOf(cardinal)]); // 32-bit end
+  if P1P2Len >= _1 then
+    repeat // case-insensitive compare 4 bytes per loop
+      if (PCardinal(_1)^ xor PCardinal(_2)^) and $dfdfdfdf <> 0 then
+        goto zero;
+      inc(PCardinal(_1));
+      inc(PCardinal(_2));
+    until P1P2Len < _1;
+  inc(PCardinal(P1P2Len));
+  dec(_2, _1);
+  if _1 < P1P2Len then
+    repeat
+      if (PByte(_1)^ xor PByteArray(_2)[PtrUInt(_1)]) and $df <> 0 then
+        goto zero;
+      inc(PByte(_1));
+    until _1 >= P1P2Len;
+  result := true;
+  exit;
+zero:
+  result := false;
+end;
+
+{$ifdef HASINLINE} // defined here for proper inlining
+function CompareMemFixed(P1, P2: Pointer; Length: PtrInt): boolean;
+label
+  zero;
+begin
+  // cut-down version of our pure pascal CompareMem() function
+  {$ifndef CPUX86}
+  result := false;
+  {$endif CPUX86}
+  Length := PtrInt(@PAnsiChar(P1)[Length - SizeOf(PtrInt)]);
+  if Length >= PtrInt(PtrUInt(P1)) then
+    repeat // compare one PtrInt per loop
+      if PPtrInt(P1)^ <> PPtrInt(P2)^ then
+        goto zero;
+      inc(PPtrInt(P1));
+      inc(PPtrInt(P2));
+    until Length < PtrInt(PtrUInt(P1));
+  inc(Length, SizeOf(PtrInt));
+  dec(PtrUInt(P2), PtrUInt(P1));
+  if PtrInt(PtrUInt(P1)) < Length then
+    repeat
+      if PByte(P1)^ <> PByteArray(P2)[PtrUInt(P1)] then
+        goto zero;
+      inc(PByte(P1));
+    until PtrInt(PtrUInt(P1)) >= Length;
+  result := true;
+  exit;
+zero:
+  {$ifdef CPUX86}
+  result := false;
+  {$endif CPUX86}
+end;
+{$endif HASINLINE}
+
+function FindNonVoidRawUtf8(n: PPointerArray; name: pointer; len: TStrLen;
+  count: PtrInt): PtrInt;
+var
+  p: PUtf8Char;
+begin
+  // FPC does proper inlining in this loop
+  result := 0;
+  repeat
+    p := n[result]; // all VName[]<>'' so p=n^<>nil
+    if (PStrLen(p - _STRLEN)^ = len) and
+       (p^ = PAnsiChar(name)^) and
+       ((len = 1) or
+        CompareMemFixed(p + 1, PAnsiChar(name) + 1, len - 1)) then
+      exit;
+    inc(result);
+    dec(count);
+  until count = 0;
+  result := -1;
+end;
+
+function FindNonVoidRawUtf8I(n: PPointerArray; name: pointer; len: TStrLen;
+  count: PtrInt): PtrInt;
+var
+  p1, p2, l: PUtf8Char;
+label
+  no;
+begin
+  result := 0;
+  p2 := name;
+  repeat
+    // inlined IdemPropNameUSameLenNotNull(p, name, len)
+    p1 := n[result]; // all VName[]<>'' so p1<>nil
+    if (PStrLen(p1 - _STRLEN)^ = len) and
+       ((ord(p1^) xor ord(p2^)) and $df = 0) then
+    begin
+      if len = 1 then
+        exit;
+      inc(p1);
+      inc(p2);
+      l := @p1[len - (SizeOf(cardinal) + 1)];
+      dec(p2, PtrUInt(p1));
+      while PtrUInt(l) >= PtrUInt(p1) do
+        // compare 4 Bytes per loop
+        if (PCardinal(p1)^ xor PCardinal(@p2[PtrUInt(p1)])^) and $dfdfdfdf <> 0 then
+          goto no
+        else
+          inc(PCardinal(p1));
+      inc(PCardinal(l));
+      while PtrUInt(p1) < PtrUInt(l) do
+        // remaining bytes
+        if (ord(p1^) xor ord(p2[PtrUInt(p1)])) and $df <> 0 then
+          goto no
+        else
+          inc(PByte(p1));
+      exit; // match found
+no:   p2 := name;
+    end;
+    inc(result);
+    dec(count);
+  until count = 0;
+  result := -1;
+end;
+
+function FindPropName(Values: PRawUtf8Array; const Value: RawUtf8;
+  ValuesCount: PtrInt): PtrInt;
+begin
+  if (Values <> nil) and
+     (ValuesCount > 0) and
+     (Value <> '') then
+    result := FindNonVoidRawUtf8I(pointer(Values), pointer(Value),
+      PStrLen(PAnsiChar(pointer(Value)) - _STRLEN)^, ValuesCount)
+  else
+    result := -1;
+end;
+
+function FindPropName(const Names: array of RawUtf8; const Name: RawUtf8): integer;
+begin
+  result := high(Names);
+  if result >= 0 then
+    result := FindPropName(@Names[0], Name, result + 1);
+end;
+
+function DateTimeToIsoString(dt: TDateTime): string;
+begin
+  // avoid to link mormot.core.datetime
+  DateTimeToString(result, 'yyyy-mm-dd hh:nn:ss', dt);
+end;
+
+procedure ToHumanHex(var result: RawUtf8; bin: PByteArray; len: PtrInt);
+var
+  P: PAnsiChar;
+  i, c: PtrInt;
+  tab: PAnsichar;
+begin
+  if len <= 0 then
+  begin
+    result := '';
+    exit;
+  end;
+  FastSetString(result, (len * 3) - 1);
+  dec(len);
+  tab := @HexCharsLower;
+  P := pointer(result);
+  i := 0;
+  repeat
+    c := bin[i];
+    P[0] := tab[c shr 4];
+    c := c and 15;
+    P[1] := tab[c];
+    if i = len then
+      break;
+    P[2] := ':'; // to please (most) human limited hexadecimal capabilities
+    inc(P, 3);
+    inc(i);
+  until false;
+end;
+
+procedure ToHumanHexReverse(var result: RawUtf8; bin: PByteArray; len: PtrInt);
+var
+  P: PAnsiChar;
+  i, c: PtrInt;
+  tab: PAnsichar;
+begin
+  if len <= 0 then
+  begin
+    result := '';
+    exit;
+  end;
+  FastSetString(result, (len * 3) - 1);
+  tab := @HexCharsLower;
+  P := pointer(result);
+  i := len;
+  repeat
+    dec(i);
+    c := bin[i];
+    P[0] := tab[c shr 4];
+    c := c and 15;
+    P[1] := tab[c];
+    if i = 0 then
+      break;
+    P[2] := ':';
+    inc(P, 3);
+  until false;
+end;
+
+
+{ ************ Numbers (floats and integers) Low-level Definitions }
+
+function GetInteger(P: PUtf8Char): PtrInt;
+var
+  c: byte;
+  minus: boolean;
+begin
+  result := 0;
+  if P = nil then
+    exit;
+  c := byte(P^);
+  repeat
+    if c = 0 then
+      exit;
+    if c > ord(' ') then
+      break;
+    inc(P);
+    c := byte(P^);
+  until false;
+  if c = ord('-') then
+  begin
+    minus := true;
+    repeat
+      inc(P);
+      c := byte(P^);
+    until c <> ord(' ');
+  end
+  else
+  begin
+    minus := false;
+    if c = ord('+') then
+      repeat
+        inc(P);
+        c := byte(P^);
+      until c <> ord(' ');
+  end;
+  dec(c, 48);
+  if c > 9 then
+    exit;
+  result := c;
+  repeat
+    inc(P);
+    c := byte(P^);
+    dec(c, 48);
+    if c > 9 then
+      break;
+    result := result * 10 + PtrInt(c);
+  until false;
+  if minus then
+    result := -result;
+end;
+
+function GetInteger(P, PEnd: PUtf8Char): PtrInt;
+var
+  c: byte;
+  minus: boolean;
+begin
+  result := 0;
+  if (P = nil) or
+     (P >= PEnd) then
+    exit;
+  c := byte(P^);
+  repeat
+    if c = 0 then
+      exit;
+    if c > ord(' ') then
+      break;
+    inc(P);
+    if P = PEnd then
+      exit;
+    c := byte(P^);
+  until false;
+  if c = ord('-') then
+  begin
+    minus := true;
+    repeat
+      inc(P);
+      if P = PEnd then
+        exit;
+      c := byte(P^);
+    until c <> ord(' ');
+  end
+  else
+  begin
+    minus := false;
+    if c = ord('+') then
+      repeat
+        inc(P);
+        if P = PEnd then
+          exit;
+        c := byte(P^);
+      until c <> ord(' ');
+  end;
+  dec(c, 48);
+  if c > 9 then
+    exit;
+  result := c;
+  repeat
+    inc(P);
+    if P = PEnd then
+      break;
+    c := byte(P^);
+    dec(c, 48);
+    if c > 9 then
+      break;
+    result := result * 10 + PtrInt(c);
+  until false;
+  if minus then
+    result := -result;
+end;
+
+function GetInteger(P: PUtf8Char; var err: integer): PtrInt;
+var
+  c: byte;
+  minus: boolean;
+begin
+  result := 0;
+  err := 1; // don't return the exact index, just 1 as error flag
+  if P = nil then
+    exit;
+  c := byte(P^);
+  repeat
+    if c = 0 then
+      exit;
+    if c > ord(' ') then
+      break;
+    inc(P);
+    c := byte(P^);
+  until false;
+  if c = ord('-') then
+  begin
+    minus := true;
+    repeat
+      inc(P);
+      c := byte(P^);
+    until c <> ord(' ');
+  end
+  else
+  begin
+    minus := false;
+    if c = ord('+') then
+      repeat
+        inc(P);
+        c := byte(P^);
+      until c <> ord(' ');
+  end;
+  dec(c, 48);
+  if c > 9 then
+    exit;
+  result := c;
+  repeat
+    inc(P);
+    c := byte(P^);
+    dec(c, 48);
+    if c <= 9 then
+      result := result * 10 + PtrInt(c)
+    else if c <> 256 - 48 then
+      exit
+    else
+      break;
+  until false;
+  err := 0; // success
+  if minus then
+    result := -result;
+end;
+
+function GetIntegerDef(P: PUtf8Char; Default: PtrInt): PtrInt;
+var
+  err: integer;
+begin
+  result := GetInteger(P, err);
+  if err <> 0 then
+    result := Default;
+end;
+
+function GetBoolean(P: PUtf8Char): boolean;
+begin
+  result := (P <> nil) and
+            (PInteger(P)^ <> FALSE_LOW) and
+            ((PInteger(P)^ = TRUE_LOW) or
+             ((PInteger(P)^ and $ffff) <> ord('0')));
+end;
+
+function GetBoolean(const value: RawUtf8): boolean;
+begin
+  result := GetBoolean(pointer(value));
+end;
+
+function GetTrue(P: PUtf8Char): integer;
+begin
+  result := PInteger(P)^ and $dfdfdfdf;
+  if (result = ord('T') + ord('R') shl 8 + ord('U') shl 16 + ord('E') shl 24) or
+     (result = ord('Y') + ord('E') shl 8 + ord('S') shl 16) then
+    result := 1
+  else
+    result := 0;
+end;
+
+function GetInt64Bool(P: PUtf8Char; out V: Int64): boolean;
+var
+  err, c: integer;
+begin
+  result := P <> nil;
+  if not result then
+    exit;
+  V := GetInt64(P, err);
+  if err = 0 then
+    exit;
+  c := PInteger(P)^ and $dfdfdfdf;
+  if (c = ord('F') + ord('A') shl 8 + ord('L') shl 16 + ord('S') shl 24) or
+     (c and $ffffff = ord('N') + ord('O') shl 8) then
+    V := 0
+  else if (c = ord('T') + ord('R') shl 8 + ord('U') shl 16 + ord('E') shl 24) or
+          (c = ord('Y') + ord('E') shl 8 + ord('S') shl 16) then
+    V := 1
+  else
+    result := false;
+end;
+
+function GetCardinalDef(P: PUtf8Char; Default: PtrUInt): PtrUInt;
+var
+  c: byte;
+begin
+  result := Default;
+  if P = nil then
+    exit;
+  c := byte(P^);
+  repeat
+    if c = 0 then
+      exit;
+    if c > ord(' ') then
+      break;
+    inc(P);
+    c := byte(P^);
+  until false;
+  dec(c, 48);
+  if c > 9 then
+    exit;
+  result := c;
+  repeat
+    inc(P);
+    c := byte(P^) - 48;
+    if c > 9 then
+      break;
+    result := result * 10 + PtrUInt(c);
+  until false;
+end;
+
+function GetCardinal(P: PUtf8Char): PtrUInt;
+var
+  c: byte;
+begin
+  result := 0;
+  if P = nil then
+    exit;
+  c := byte(P^);
+  repeat
+    if c = 0 then
+      exit;
+    if c > ord(' ') then
+      break;
+    inc(P);
+    c := byte(P^);
+  until false;
+  dec(c, 48);
+  if c > 9 then
+    exit;
+  result := c;
+  repeat
+    inc(P);
+    c := byte(P^);
+    dec(c, 48);
+    if c > 9 then
+      break;
+    result := result * 10 + PtrUInt(c);
+  until false;
+end;
+
+function GetCardinal(P, PEnd: PUtf8Char): PtrUInt;
+var
+  c: byte;
+begin
+  result := 0;
+  if (P = nil) or
+     (P >= PEnd) then
+    exit;
+  c := byte(P^);
+  repeat
+    if c = 0 then
+      exit;
+    if c > ord(' ') then
+      break;
+    inc(P);
+    if P = PEnd then
+      exit;
+    c := byte(P^);
+  until false;
+  dec(c, 48);
+  if c > 9 then
+    exit;
+  result := c;
+  repeat
+    inc(P);
+    if P = PEnd then
+      break;
+    c := byte(P^);
+    dec(c, 48);
+    if c > 9 then
+      break;
+    result := result * 10 + PtrUInt(c);
+  until false;
+end;
+
+function GetCardinalW(P: PWideChar): PtrUInt;
+var
+  c: PtrUInt;
+begin
+  result := 0;
+  if P = nil then
+    exit;
+  c := ord(P^);
+  repeat
+    if c = 0 then
+      exit;
+    if c > ord(' ') then
+      break;
+    inc(P);
+    c := ord(P^);
+  until false;
+  dec(c, 48);
+  if c > 9 then
+    exit;
+  result := c;
+  repeat
+    inc(P);
+    c := ord(P^);
+    dec(c, 48);
+    if c > 9 then
+      break;
+    result := result * 10 + c;
+  until false;
+end;
+
+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}
+// PtrInt/PtrUInt are already Int64/QWord
+
+procedure SetInt64(P: PUtf8Char; var result: Int64);
+begin
+  result := GetInteger(P);
+end;
+
+procedure SetQWord(P: PUtf8Char; var result: QWord);
+begin
+  result := GetCardinal(P);
+end;
+
+procedure SetQWord(P, PEnd: PUtf8Char; var result: QWord);
+begin
+  result := GetCardinal(P, PEnd);
+end;
+
+function GetInt64(P: PUtf8Char): Int64;
+begin
+  result := GetInteger(P);
+end;
+
+function GetInt64(P: PUtf8Char; var err: integer): Int64;
+begin
+  result := GetInteger(P, err);
+end;
+
+function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar;
+begin
+  result := StrUInt32(P, val); // StrUInt32 converts PtrUInt=QWord on 64-bit CPU
+end;
+
+function StrInt64(P: PAnsiChar; const val: Int64): PAnsiChar;
+begin
+  result := StrInt32(P, val); // StrInt32 converts PtrInt=Int64 on 64-bit CPU
+end;
+
+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;
+  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
+end;
+
+{$else}
+// 32-bit dedicated code - use integer/cardinal as much as possible
+
+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;
+
+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;
+
+procedure SetQWord(P, PEnd: PUtf8Char; var result: QWord);
+var
+  c: cardinal;
+begin
+  result := 0;
+  if (P = nil) or
+     (P >= PEnd) then
+    exit;
+  while P^ <= ' ' do
+    if P = PEnd then
+      exit
+    else
+      inc(P);
+  if P^ = '+' then
+    repeat
+      inc(P);
+      if P = PEnd then
+        exit;
+    until P^ <> ' ';
+  c := byte(P^) - 48;
+  if c > 9 then
+    exit;
+  PCardinal(@result)^ := c;
+  inc(P);
+  repeat // fast 32-bit loop
+    if P = PEnd then
+      break;
+    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
+        if P = PEnd then
+          exit;
+        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;
+
+function GetInt64(P: PUtf8Char): Int64;
+begin
+  SetInt64(P, result);
+end;
+
+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 CPU32DELPHI}
+          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;
+
+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;
+  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 CPU32DELPHI}
+          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;
+end;
+
+function StrUInt64(P: PAnsiChar; const val: QWord): PAnsiChar;
+var
+  c, c100: QWord;
+  {$ifdef CPUX86NOTPIC}
+  tab: TWordArray absolute TwoDigitLookupW;
+  {$else}
+  tab: PWordArray;
+  {$endif CPUX86NOTPIC}
+begin
+  if PCardinalArray(@val)^[1] = 0 then
+    P := StrUInt32(P, PCardinal(@val)^)
+  else
+  begin
+    {$ifndef CPUX86NOTPIC}
+    tab := @TwoDigitLookupW;
+    {$endif CPUX86NOTPIC}
+    c := val;
+    repeat
+      {$ifdef CPUX86}
+      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;
+      {$else}
+      c100 := c div 100;   // one div by two digits
+      dec(c, c100 * 100);  // fast c := c mod 100
+      {$endif CPUX86}
+      dec(P, 2);
+      PWord(P)^ := tab[c];
+      c := c100;
+      if (PCardinalArray(@c)^[1] = 0) then
+      begin
+        if PCardinal(@c)^ <> 0 then
+          P := StrUInt32(P, PCardinal(@c)^);
+        break;
+      end;
+    until false;
+  end;
+  result := P;
+end;
+
+function StrInt64(P: PAnsiChar; const val: Int64): PAnsiChar;
+begin
+  if val < 0 then
+  begin
+    P := StrUInt64(P, -val) - 1;
+    P^ := '-';
+  end
+  else
+    P := StrUInt64(P, val);
+  result := P;
+end;
+
+{$endif CPU64}
+
+function GetExtended(P: PUtf8Char): TSynExtended;
+var
+  err: integer;
+begin
+  result := GetExtended(P, err);
+  if err <> 0 then
+    result := 0;
+end;
+
+function HugePower10Pos(exponent: PtrInt; pow10: PPow10): TSynExtended;
+begin
+  result := pow10[(exponent and not 31) shr 5 + 34] * pow10[exponent and 31];
+end;
+
+function HugePower10Neg(exponent: PtrInt; pow10: PPow10): TSynExtended;
+begin
+  exponent := -exponent;
+  result := pow10[(exponent and not 31) shr 5 + 45] / pow10[exponent and 31];
+end;
+
+{$ifndef CPU32DELPHI}
+
+function GetExtended(P: PUtf8Char; out err: integer): TSynExtended;
+var
+  remdigit: integer;
+  frac, exp: PtrInt;
+  c: AnsiChar;
+  flags: set of (fNeg, fNegExp, fValid);
+  v64: Int64; // allows 64-bit resolution for the digits (match 80-bit extended)
+label
+  e;
+begin
+  byte(flags) := 0;
+  v64 := 0;
+  frac := 0;
+  if P = nil then
+    goto e; // will return 0 but err=1
+  c := P^;
+  if c = ' ' then
+    repeat
+      inc(P);
+      c := P^;
+    until c <> ' '; // trailing spaces
+  if c = '+' then
+  begin
+    inc(P);
+    c := P^;
+  end
+  else if c = '-' then
+  begin
+    inc(P);
+    c := P^;
+    include(flags, fNeg);
+  end;
+  remdigit := 19; // max Int64 resolution
+  repeat
+    inc(P);
+    if (c >= '0') and
+       (c <= '9') then
+    begin
+      dec(remdigit);
+      if remdigit >= 0 then // over-required digits are just ignored
+      begin
+        dec(c, ord('0'));
+        {$ifdef CPU64}
+        v64 := v64 * 10;
+        {$else}
+        v64 := v64 shl 3 + v64 + v64;
+        {$endif CPU64}
+        inc(v64, byte(c));
+        c := P^;
+        include(flags, fValid);
+        if frac <> 0 then
+          dec(frac); // digits after '.'
+        continue;
+      end;
+      if frac >= 0 then
+        inc(frac); // handle #############00000
+      c := P^;
+      continue;
+    end;
+    if c <> '.' then
+      break;
+    if frac > 0 then
+      goto e; // will return partial value but err=1
+    dec(frac);
+    c := P^;
+  until false;
+  if frac < 0 then
+    inc(frac); // adjust digits after '.'
+  if (c = 'E') or
+     (c = 'e') then
+  begin
+    exp := 0;
+    exclude(flags, fValid);
+    c := P^;
+    if c = '+' then
+      inc(P)
+    else if c = '-' then
+    begin
+      inc(P);
+      include(flags, fNegExp);
+    end;
+    repeat
+      c := P^;
+      inc(P);
+      if (c < '0') or
+         (c > '9') then
+        break;
+      dec(c, ord('0'));
+      exp := (exp * 10) + byte(c);
+      include(flags, fValid);
+    until false;
+    if fNegExp in flags then
+      dec(frac, exp)
+    else
+      inc(frac, exp);
+    if (frac <= -324) or
+       (frac >= 308) then
+    begin
+      frac := 0;
+      goto e; // limit to 5.0 x 10^-324 .. 1.7 x 10^308 double range
+    end;
+  end;
+  if (fValid in flags) and
+     (c = #0) then
+    err := 0
+  else
+e:  err := 1; // return the (partial) value even if not ended with #0
+  exp := PtrUInt(@POW10);
+  if frac >= -31 then
+    if frac <= 31 then
+      result := PPow10(exp)[frac] // -31 .. + 31
+    else
+      result := HugePower10Pos(frac, PPow10(exp)) // +32 ..
+  else
+    result := HugePower10Neg(frac, PPow10(exp));  // .. -32
+  if fNeg in flags then
+    result := result * PPow10(exp)[33]; // * -1
+  result := result * v64;
+end;
+
+{$endif CPU32DELPHI}
+
+function Utf8ToInteger(const value: RawUtf8; Default: PtrInt): PtrInt;
+var
+  err: integer;
+begin
+  result := GetInteger(pointer(value), err);
+  if err <> 0 then
+    result := Default;
+end;
+
+function Utf8ToInteger(const value: RawUtf8; min, max, default: PtrInt): PtrInt;
+var
+  err: integer;
+begin
+  result := GetInteger(pointer(value), err);
+  if (err <> 0) or
+     (result < min) or
+     (result > max) then
+    result := default;
+end;
+
+function ToInteger(const text: RawUtf8; out value: integer): boolean;
+var
+  v, err: integer;
+begin
+  v := GetInteger(pointer(text), err);
+  result := err = 0;
+  if result then
+    value := v;
+end;
+
+function ToCardinal(const text: RawUtf8; out value: cardinal; minimal: cardinal): boolean;
+var
+  v: cardinal;
+begin
+  v := GetCardinalDef(pointer(text), cardinal(-1));
+  result := (v <> cardinal(-1)) and
+            (v >= minimal);
+  if result then
+    value := v;
+end;
+
+function ToInt64(const text: RawUtf8; out value: Int64): boolean;
+var
+  err: integer;
+  v: Int64;
+begin
+  v := GetInt64(pointer(text), err);
+  result := err = 0;
+  if result then
+    value := v;
+end;
+
+function ToDouble(const text: RawUtf8; out value: double): boolean;
+var
+  err: integer;
+  v: double;
+begin
+  v := GetExtended(pointer(text), err);
+  result := err = 0;
+  if result then
+    value := v;
+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;
+
+
+{ ************ integer arrays manipulation }
+
+function IsZero(const Values: TIntegerDynArray): boolean;
+var
+  i: PtrInt;
+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: PtrInt;
+begin
+  result := false;
+  for i := 0 to length(Values) - 1 do
+    if Values[i] <> 0 then
+      exit;
+  result := true;
+end;
+
+procedure FillZero(var Values: TIntegerDynArray);
+begin
+  FillCharFast(Values[0], length(Values) * SizeOf(integer), 0);
+end;
+
+procedure FillZero(var Values: TInt64DynArray);
+begin
+  FillCharFast(Values[0], length(Values) * SizeOf(Int64), 0);
+end;
+
+function CompareInteger(const A, B: integer): integer;
+begin
+  result := ord(A > B) - ord(A < B);
+end;
+
+function CompareCardinal(const A, B: cardinal): integer;
+begin
+  result := ord(A > B) - ord(A < B);
+end;
+
+function ComparePtrInt(const A, B: PtrInt): integer;
+begin
+  result := ord(A > B) - ord(A < B);
+end;
+
+function ComparePointer(const A, B: pointer): integer;
+begin
+  result := ord(PtrUInt(A) > PtrUInt(B)) - ord(PtrUInt(A) < PtrUInt(B));
+end;
+
+{$ifdef FPC_OR_UNICODE} // recent compilers are able to generate correct code
+
+function CompareInt64(const A, B: Int64): integer;
+begin
+  result := ord(A > B) - ord(A < B);
+end;
+
+function CompareQword(const A, B: QWord): integer;
+begin
+  result := ord(A > B) - ord(A < B);
+end;
+
+{$else}
+
+function CompareInt64(const A, B: Int64): integer;
+begin
+  // Delphi x86 compiler is not efficient at compiling Int64 comparisons
+  result := SortDynArrayInt64(A, B);
+end;
+
+function CompareQword(const A, B: QWord): integer;
+begin
+  // Delphi x86 compiler is not efficient, and oldest even incorrect
+  result := SortDynArrayQWord(A, B);
+end;
+
+{$endif FPC_OR_UNICODE}
+
+function Int64ScanExists(P: PInt64Array; Count: PtrInt; const Value: Int64): boolean;
+begin
+  if P <> nil then
+  begin
+    result := true;
+    Count := PtrUInt(@P[Count - 4]);
+    repeat
+      if PtrUInt(P) > PtrUInt(Count) then
+        break;
+      if (P^[0] = Value) or
+         (P^[1] = Value) or
+         (P^[2] = Value) or
+         (P^[3] = Value) then
+        exit;
+      P := @P[4];
+    until false;
+    inc(Count, 4 * SizeOf(Value));
+    repeat
+      if PtrUInt(P) >= PtrUInt(Count) then
+        break;
+      if P^[0] = Value then
+        exit;
+      P := @P[1];
+    until false;
+  end;
+  result := false;
+end;
+
+function Int64Scan(P: PInt64Array; Count: PtrInt; const Value: Int64): PInt64;
+begin
+  result := nil;
+  if P = nil then
+    exit;
+  Count := PtrUInt(@P[Count - 4]);
+  repeat
+    if PtrUInt(P) > PtrUInt(Count) then
+      break;
+    if P^[0] <> Value then
+      if P^[1] <> Value then
+        if P^[2] <> Value then
+          if P^[3] <> Value then
+          begin
+            P := @P[4];
+            continue;
+          end
+          else
+            result := @P[3]
+        else
+          result := @P[2]
+      else
+        result := @P[1]
+    else
+      result := pointer(P);
+    exit;
+  until false;
+  inc(Count, 4 * SizeOf(Value));
+  result := pointer(P);
+  repeat
+    if PtrUInt(result) >= PtrUInt(Count) then
+      break;
+    if result^ = Value then
+      exit;
+    inc(result);
+  until false;
+  result := nil;
+end;
+
+function Int64ScanIndex(P: PInt64Array; Count: PtrInt; const Value: Int64): PtrInt;
+begin
+  result := PtrUInt(Int64Scan(P, Count, Value));
+  if result = 0 then
+    dec(result)
+  else
+  begin
+    dec(result, PtrUInt(P));
+    result := result shr 3;
+  end;
+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;
+
+{$ifdef CPU64}
+// PtrInt = Int64 and PtrUInt = QWord
+
+function PtrUIntScan(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): pointer;
+begin
+  result := Int64Scan(pointer(P), Count, Value);
+end;
+
+function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean;
+begin
+  result := Int64ScanExists(pointer(P), Count, Value);
+end;
+
+function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt;
+begin
+  result := Int64ScanIndex(pointer(P), Count, Value);
+end;
+
+procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt);
+begin
+  QuickSortInt64(PInt64Array(P), L, R);
+end;
+
+procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt);
+begin
+  QuickSortInt64(PInt64Array(P), L, R);
+end;
+
+function FastFindPtrIntSorted(P: PPtrIntArray; R: PtrInt; Value: PtrInt): PtrInt;
+begin
+  result := FastFindInt64Sorted(PInt64Array(P), R, Value);
+end;
+
+function FastFindPointerSorted(P: PPointerArray; R: PtrInt; Value: pointer): PtrInt;
+begin
+  result := FastFindInt64Sorted(PInt64Array(P), R, Int64(Value));
+end;
+
+{$else}
+// PtrInt = integer and PtrUInt = cardinal
+
+function PtrUIntScan(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): pointer;
+begin
+  result := IntegerScan(pointer(P), Count, Value);
+end;
+
+function PtrUIntScanExists(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): boolean;
+begin
+  result := IntegerScanExists(pointer(P), Count, Value);
+end;
+
+function PtrUIntScanIndex(P: PPtrUIntArray; Count: PtrInt; Value: PtrUInt): PtrInt;
+begin
+  result := IntegerScanIndex(pointer(P), Count, Value);
+end;
+
+procedure QuickSortPtrInt(P: PPtrIntArray; L, R: PtrInt);
+begin
+  QuickSortInteger(PIntegerArray(P), L, R);
+end;
+
+procedure QuickSortPointer(P: PPointerArray; L, R: PtrInt);
+begin
+  QuickSortInteger(PIntegerArray(P), L, R);
+end;
+
+function FastFindPtrIntSorted(P: PPtrIntArray; R: PtrInt; Value: PtrInt): PtrInt;
+begin
+  result := FastFindIntegerSorted(PIntegerArray(P), R, Value);
+end;
+
+function FastFindPointerSorted(P: PPointerArray; R: PtrInt; Value: pointer): PtrInt;
+begin
+  result := FastFindIntegerSorted(PIntegerArray(P), R, integer(Value));
+end;
+
+{$endif CPU64}
+
+procedure DynArrayFakeLength(arr: pointer; len: TDALen);
+begin
+  PDALen(PAnsiChar(arr) - _DALEN)^ := len - _DAOFF;
+end;
+
+{$ifdef FPC} // some FPC-specific low-level code due to diverse compiler or RTL
+
+function TDynArrayRec.GetLength: TDALen;
+begin
+  result := high + 1;
+end;
+
+procedure TDynArrayRec.SetLength(len: TDALen);
+begin
+  high := len - 1;
+end;
+
+procedure Div100(Y: cardinal; var res: TDiv100Rec); // Delphi=asm, FPC=inlined
+var
+  Y100: cardinal;
+begin
+  Y100 := Y div 100; // FPC will use fast reciprocal
+  res.D := Y100;
+  res.M := Y {%H-}- Y100 * 100; // avoid div twice
+end;
+
+{$endif FPC}
+
+function AddInteger(var Values: TIntegerDynArray; Value: integer; NoDuplicates: boolean): boolean;
+var
+  n: PtrInt;
+begin
+  n := Length(Values);
+  if NoDuplicates and
+     IntegerScanExists(pointer(Values), n, Value) then
+  begin
+    result := false;
+    exit;
+  end;
+  SetLength(Values, n + 1);
+  Values[n] := Value;
+  result := true
+end;
+
+procedure AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer; Value: integer);
+begin
+  if ValuesCount = Length(Values) then
+    SetLength(Values, NextGrow(ValuesCount));
+  Values[ValuesCount] := Value;
+  inc(ValuesCount);
+end;
+
+function AddInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
+  Value: integer; NoDuplicates: boolean): boolean;
+begin
+  if NoDuplicates and
+     IntegerScanExists(pointer(Values), ValuesCount, Value) then
+  begin
+    result := false;
+    exit;
+  end;
+  if ValuesCount = Length(Values) then
+    SetLength(Values, NextGrow(ValuesCount));
+  Values[ValuesCount] := Value;
+  inc(ValuesCount);
+  result := true;
+end;
+
+function AddInteger(var Values: TIntegerDynArray; const Another: TIntegerDynArray): PtrInt;
+var
+  v, a: PtrInt;
+begin
+  v := Length(Values);
+  a := Length(Another);
+  if a > 0 then
+  begin
+    SetLength(Values, v + a);
+    MoveFast(Another[0], Values[v], a * SizeOf(integer));
+  end;
+  result := v + a;
+end;
+
+function AddWord(var Values: TWordDynArray; var ValuesCount: integer; Value: Word): PtrInt;
+begin
+  result := ValuesCount;
+  if result = Length(Values) then
+    SetLength(Values, NextGrow(result));
+  Values[result] := Value;
+  inc(ValuesCount);
+end;
+
+function AddInt64(var Values: TInt64DynArray; var ValuesCount: integer; Value: Int64): PtrInt;
+begin
+  result := ValuesCount;
+  if result = Length(Values) then
+    SetLength(Values, NextGrow(result));
+  Values[result] := Value;
+  inc(ValuesCount);
+end;
+
+function AddInt64(var Values: TInt64DynArray; Value: Int64): PtrInt;
+begin
+  result := Length(Values);
+  SetLength(Values, result + 1);
+  Values[result] := Value;
+end;
+
+function AddInt64(var Values: TInt64DynArray; const Another: TInt64DynArray): PtrInt;
+var
+  v, a: PtrInt;
+begin
+  v := Length(Values);
+  a := Length(Another);
+  if a > 0 then
+  begin
+    SetLength(Values, v + a);
+    MoveFast(Another[0], Values[v], a * SizeOf(Int64));
+  end;
+  result := v + a;
+end;
+
+function AddPtrUInt(var Values: TPtrUIntDynArray;
+  var ValuesCount: integer; Value: PtrUInt): PtrInt;
+begin
+  result := ValuesCount;
+  if result = Length(Values) then
+    SetLength(Values, NextGrow(result));
+  Values[result] := Value;
+  inc(ValuesCount);
+end;
+
+procedure AddInt64Sorted(var Values: TInt64DynArray; Value: Int64);
+var
+  last: integer;
+begin
+  last := high(Values);
+  if FastFindInt64Sorted(pointer(Values), last, Value) >= 0 then
+    exit; // found
+  inc(last);
+  SetLength(Values, last + 1);
+  Values[last] := Value;
+  QuickSortInt64(pointer(Values), 0, last);
+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 MakeUniqueArray(old: PDynArrayRec; ItemSizeShl: TDALen);
+var
+  new: PDynArrayRec;
+  n: PtrInt;
+begin
+  dec(old);
+  dec(old^.refCnt);
+  n := (old^.length shl ItemSizeShl) + SizeOf(new^);
+  new := AllocMem(n);
+  MoveFast(old^, new^, n); // copy header + all ordinal values
+  new^.refCnt := 1;
+end;
+
+procedure DeleteWord(var Values: TWordDynArray; Index: PtrInt);
+var
+  n: PtrInt;
+begin
+  n := Length(Values);
+  if PtrUInt(Index) >= PtrUInt(n) then
+    exit; // wrong Index
+  dec(n);
+  if n > Index then
+  begin
+    if PDACnt(PAnsiChar(Values) - _DACNT)^ > 1 then
+      MakeUniqueArray(pointer(Values), {shl=}1);
+    MoveFast(Values[Index + 1], Values[Index], (n - Index) * SizeOf(Word));
+  end;
+  SetLength(Values, n);
+end;
+
+procedure DeleteInteger(var Values: TIntegerDynArray; Index: PtrInt);
+var
+  n: PtrInt;
+begin
+  n := Length(Values);
+  if PtrUInt(Index) >= PtrUInt(n) then
+    exit; // wrong Index
+  dec(n);
+  if n > Index then
+  begin
+    if PDACnt(PAnsiChar(Values) - _DACNT)^ > 1 then
+      MakeUniqueArray(pointer(Values), {shl=}2);
+    MoveFast(Values[Index + 1], Values[Index], (n - Index) * SizeOf(integer));
+  end;
+  SetLength(Values, n);
+end;
+
+procedure DeleteInteger(var Values: TIntegerDynArray; var ValuesCount: integer; Index: PtrInt);
+var
+  n: PtrInt;
+begin
+  n := ValuesCount;
+  if PtrUInt(Index) >= PtrUInt(n) then
+    exit; // wrong Index
+  dec(n, Index + 1);
+  if n > 0 then
+  begin
+    if PDACnt(PAnsiChar(Values) - _DACNT)^ > 1 then
+      MakeUniqueArray(pointer(Values), {shl=}2);
+    MoveFast(Values[Index + 1], Values[Index], n * SizeOf(integer));
+  end;
+  dec(ValuesCount);
+end;
+
+procedure DeleteInt64(var Values: TInt64DynArray; Index: PtrInt);
+var
+  n: PtrInt;
+begin
+  n := Length(Values);
+  if PtrUInt(Index) >= PtrUInt(n) then
+    exit; // wrong Index
+  dec(n);
+  if n > Index then
+  begin
+    if PDACnt(PAnsiChar(Values) - _DACNT)^ > 1 then
+      MakeUniqueArray(pointer(Values), {shl=}3);
+    MoveFast(Values[Index + 1], Values[Index], (n - Index) * SizeOf(Int64));
+  end;
+  SetLength(Values, n);
+end;
+
+procedure DeleteInt64(var Values: TInt64DynArray; var ValuesCount: integer; Index: PtrInt);
+var
+  n: PtrInt;
+begin
+  n := ValuesCount;
+  if PtrUInt(Index) >= PtrUInt(n) then
+    exit; // wrong Index
+  dec(n, Index + 1);
+  if n > 0 then
+  begin
+    if PDACnt(PAnsiChar(Values) - _DACNT)^ > 1 then
+      MakeUniqueArray(pointer(Values), {shl=}3);
+    MoveFast(Values[Index + 1], Values[Index], n * SizeOf(Int64));
+  end;
+  dec(ValuesCount);
+end;
+
+procedure FillIncreasing(Values: PIntegerArray; StartValue: integer; Count: PtrUInt);
+var
+  i: PtrUInt;
+begin
+  if Count > 0 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 QuickSortInteger(ID: PIntegerArray; L, R: PtrInt);
+var
+  I, J, P: PtrInt;
+  tmp: integer;
+begin
+  if L < R then
+    repeat
+      I := L;
+      J := R;
+      P := (L + R) shr 1;
+      repeat
+        tmp := ID[P];
+        if ID[I] < tmp then
+          repeat
+            inc(I)
+          until ID[I] >= 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 < R then
+    repeat
+      I := L;
+      J := R;
+      P := (L + R) shr 1;
+      repeat
+        tmp := ID[P];
+        if ID[I] < tmp then
+          repeat
+            inc(I)
+          until ID[I] >= 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 < R then
+    repeat
+      I := L;
+      J := R;
+      P := (L + R) shr 1;
+      repeat
+        tmp := ID[P];
+        if ID[I] < tmp then
+          repeat
+            inc(I)
+          until ID[I] >= 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 < R then
+    repeat
+      I := L;
+      J := R;
+      P := (L + R) shr 1;
+      repeat
+      {$ifdef CPU64}
+        tmp := ID^[P];
+        if ID[I] < tmp then
+          repeat
+            inc(I)
+          until ID[I] >= tmp;
+        if ID[J] > tmp then
+          repeat
+            dec(J)
+          until ID[J] <= tmp;
+      {$else}
+        while ID[I] < ID[P] do
+          inc(I);
+        while ID[J] > ID[P] do
+          dec(J);
+      {$endif CPU64}
+        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 L < R then
+    repeat
+      I := L;
+      J := R;
+      P := (L + R) shr 1;
+      repeat
+      {$ifdef CPUX86} // circumvent QWord comparison slowness (and bug)
+        while CompareQWord(ID[I], ID[P]) < 0 do
+          inc(I);
+        while CompareQWord(ID[J], ID[P]) > 0 do
+          dec(J);
+      {$else}
+        tmp := ID[P];
+        if ID[I] < tmp then
+          repeat
+            inc(I)
+          until ID[I] >= tmp;
+        if ID[J] > tmp then
+          repeat
+            dec(J)
+          until ID[J] <= tmp;
+      {$endif CPUX86}
+        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 QuickSortDouble(ID: PDoubleArray; L, R: PtrInt);
+var
+  I, J, P: PtrInt;
+  tmp: double;
+begin
+  if L < R then
+    repeat
+      I := L;
+      J := R;
+      P := (L + R) shr 1;
+      repeat
+        tmp := ID[P];
+        while ID[I] < tmp do
+          inc(I);
+        while ID[J] > tmp do
+          dec(J);
+        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
+          QuickSortDouble(ID, L, J);
+        L := I;
+      end
+      else
+      begin
+        if I < R then
+          QuickSortDouble(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 < R then
+    repeat
+      I := L;
+      J := R;
+      P := (L + R) shr 1;
+      repeat
+      {$ifdef CPU64}
+        tmp := ID^[P];
+        if ID[I] < tmp then
+          repeat
+            inc(I)
+          until ID[I] >= tmp;
+        if ID[J] > tmp then
+          repeat
+            dec(J)
+          until ID[J] <= tmp;
+      {$else}
+        while ID[I] < ID[P] do
+          inc(I);
+        while ID[J] > ID[P] do
+          dec(J);
+      {$endif CPU64}
+        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;
+
+function FastFindIntegerSorted(const Values: TIntegerDynArray; Value: integer): PtrInt;
+begin
+  result := FastFindIntegerSorted(pointer(Values), Length(Values) - 1, Value);
+end;
+
+{$ifndef CPUX64} // x86_64 has fast branchless asm for those functions
+
+function FastFindWordSorted(P: PWordArray; R: PtrInt; Value: Word): PtrInt;
+var
+  L, RR: 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;
+      RR := result + 1; // compile as 2 branchless cmovc/cmovnc on FPC
+      dec(result);
+      if cmp < 0 then
+        L := RR
+      else
+        R := result;
+    until L > R;
+  result := -1
+end;
+
+function FastFindIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt;
+var
+  L, RR: PtrInt;
+  cmp: integer;
+begin
+  L := 0;
+  if 0 <= R then
+    repeat
+      result := (L + R) shr 1;
+      cmp := CompareInteger(P^[result], Value);
+      if cmp = 0 then
+        exit;
+      RR := result + 1; // compile as 2 branchless cmovc/cmovnc on FPC
+      dec(result);
+      if cmp < 0 then
+        L := RR
+      else
+        R := result;
+    until L > R;
+  result := -1
+end;
+
+function FastFindInt64Sorted(P: PInt64Array; R: PtrInt; const Value: Int64): PtrInt;
+var
+  L, RR: PtrInt;
+  cmp: integer;
+begin
+  L := 0;
+  if 0 <= R then
+    repeat
+      result := (L + R) shr 1;
+      cmp := CompareInt64(P^[result], Value);
+      if cmp = 0 then
+        exit;
+      RR := result + 1; // compile as 2 branchless cmovc/cmovnc on FPC
+      dec(result);
+      if cmp < 0 then
+        L := RR
+      else
+        R := result;
+    until L > R;
+  result := -1
+end;
+
+{$endif CPUX64}
+
+function FastFindQWordSorted(P: PQWordArray; R: PtrInt; const Value: QWord): PtrInt;
+var
+  L, RR: PtrInt;
+  cmp: integer;
+begin
+  L := 0;
+  if 0 <= R then
+    repeat
+      result := (L + R) shr 1;
+      cmp := CompareQWord(P^[result], Value);
+      if cmp = 0 then
+        exit;
+      RR := result + 1; // compile as 2 branchless cmovc/cmovnc on FPC
+      dec(result);
+      if cmp < 0 then
+        L := RR
+      else
+        R := result;
+    until L > R;
+  result := -1
+end;
+
+function FastLocateIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt;
+var
+  L, RR: PtrInt;
+  cmp: integer;
+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;
+      RR := result + 1; // compile as 2 branchless cmovl/cmovge on FPC
+      dec(result);
+      if cmp < 0 then
+        L := RR
+      else
+        R := result;
+    until L > R;
+    while (result >= 0) and
+          (P^[result] >= Value) do
+      dec(result);
+    inc(result); // return the index where to insert
+  end;
+end;
+
+function FastSearchIntegerSorted(P: PIntegerArray; R: PtrInt; Value: integer): PtrInt;
+var
+  L, RR: PtrInt;
+  cmp: integer;
+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
+        exit; // return exact matching index
+      RR := result + 1; // compile as 2 branchless cmovl/cmovge on FPC
+      dec(result);
+      if cmp < 0 then
+        L := RR
+      else
+        R := result;
+    until L > R;
+    while (result >= 0) and
+          (P^[result] >= Value) do
+      dec(result);
+    inc(result); // return the index where to insert
+  end;
+end;
+
+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);
+    inc(result); // return the index where to insert
+  end;
+end;
+
+function AddSortedInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
+  Value: integer; CoValues: PIntegerDynArray): PtrInt;
+begin
+  result := FastLocateIntegerSorted(pointer(Values), ValuesCount - 1, Value);
+  if result >= 0 then // if Value exists -> fails and return -(foundindex+1)
+    result := InsertInteger(Values, ValuesCount, Value, result, CoValues);
+end;
+
+function AddSortedInteger(var Values: TIntegerDynArray; Value: integer;
+  CoValues: PIntegerDynArray): PtrInt;
+var
+  ValuesCount: integer;
+begin
+  ValuesCount := Length(Values);
+  result := FastLocateIntegerSorted(pointer(Values), ValuesCount - 1, Value);
+  if result < 0 then
+    exit; // Value exists -> fails and return -(foundindex+1)
+  SetLength(Values, ValuesCount + 1); // manual size increase
+  result := InsertInteger(Values, ValuesCount, Value, result, CoValues);
+end;
+
+function InsertInteger(var Values: TIntegerDynArray; var ValuesCount: integer;
+  Value: integer; Index: PtrInt; CoValues: PIntegerDynArray): 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) < PtrUInt(n) then
+  begin
+    n := (n - result) * SizeOf(integer);
+    MoveFast(Values[result], Values[result + 1], n);
+    if CoValues <> nil then
+      MoveFast(CoValues^[result], CoValues^[result + 1], n);
+  end
+  else
+    result := n;
+  Values[result] := Value;
+  inc(ValuesCount);
+end;
+
+function TIntegerDynArrayFrom(const Values: array of integer): TIntegerDynArray;
+var
+  i: PtrInt;
+begin
+  Finalize(result);
+  SetLength(result, Length(Values));
+  for i := 0 to high(Values) do
+    result[i] := Values[i];
+end;
+
+function TIntegerDynArrayFrom64(const Values: TInt64DynArray;
+  raiseExceptionOnOverflow: boolean): TIntegerDynArray;
+var
+  i: PtrInt;
+const
+  MinInt = -MaxInt - 1;
+begin
+  Finalize(result);
+  SetLength(result, Length(Values));
+  for i := 0 to Length(Values) - 1 do
+    if Values[i] > MaxInt then
+      if raiseExceptionOnOverflow then
+        raise Exception.CreateFmt('TIntegerDynArrayFrom64: Values[%d]=%d>%d',
+          [i, Values[i], MaxInt])
+      else
+        result[i] := MaxInt
+    else if Values[i] < MinInt then
+      if raiseExceptionOnOverflow then
+        raise Exception.CreateFmt('TIntegerDynArrayFrom64: Values[%d]=%d<%d',
+          [i, Values[i], MinInt])
+      else
+        result[i] := MinInt
+    else
+      result[i] := Values[i];
+end;
+
+function TInt64DynArrayFrom(const Values: TIntegerDynArray): TInt64DynArray;
+var
+  i: PtrInt;
+begin
+  Finalize(result);
+  SetLength(result, Length(Values));
+  for i := 0 to Length(Values) - 1 do
+    result[i] := Values[i];
+end;
+
+function TQWordDynArrayFrom(const Values: TCardinalDynArray): TQWordDynArray;
+var
+  i: PtrInt;
+begin
+  Finalize(result);
+  SetLength(result, Length(Values));
+  for i := 0 to Length(Values) - 1 do
+    result[i] := Values[i];
+end;
+
+function FromI32(const Values: array of integer): TIntegerDynArray;
+var
+  i: PtrInt;
+begin
+  Finalize(result);
+  SetLength(result, Length(Values));
+  for i := 0 to high(Values) do
+    result[i] := Values[i];
+end;
+
+function FromU32(const Values: array of cardinal): TCardinalDynArray;
+var
+  i: PtrInt;
+begin
+  Finalize(result);
+  SetLength(result, Length(Values));
+  for i := 0 to high(Values) do
+    result[i] := Values[i];
+end;
+
+function FromI64(const Values: array of Int64): TInt64DynArray;
+var
+  i: PtrInt;
+begin
+  Finalize(result);
+  SetLength(result, Length(Values));
+  for i := 0 to high(Values) do
+    result[i] := Values[i];
+end;
+
+function FromU64(const Values: array of QWord): TQWordDynArray;
+var
+  i: PtrInt;
+begin
+  Finalize(result);
+  SetLength(result, Length(Values));
+  for i := 0 to high(Values) do
+    result[i] := Values[i];
+end;
+
+function gcd(a, b: PtrUInt): PtrUInt;
+begin
+  result := 0;
+  if a <> 0 then
+    while b <> 0 do
+    begin
+      result := b;
+      b := a mod b;
+      a := result;
+    end;
+end;
+
+
+{ TSortedWordArray }
+
+function TSortedWordArray.Add(aValue: Word): PtrInt;
+begin
+  result := Count; // optimistic check of perfectly increasing aValue
+  if (result > 0) and
+     (aValue <= Values[result - 1]) then
+    result := FastLocateWordSorted(pointer(Values), result - 1, aValue);
+  if result < 0 then // aValue already exists in Values[] -> fails
+    exit;
+  if Count = Length(Values) then
+    SetLength(Values, NextGrow(Count));
+  if result < Count then
+    MoveFast(Values[result], Values[result + 1], (Count - result) * SizeOf(word))
+  else
+    result := Count;
+  Values[result] := aValue;
+  inc(Count);
+end;
+
+function TSortedWordArray.IndexOf(aValue: Word): PtrInt;
+begin
+  result := FastFindWordSorted(pointer(Values), Count - 1, aValue);
+end;
+
+procedure TSortedWordArray.SetArray(out aValues: TWordDynArray);
+begin
+  if Count = 0 then
+    exit;
+  DynArrayFakeLength(Values, Count); // no realloc needed
+  aValues := Values;
+end;
+
+
+{ TSortedIntegerArray }
+
+function TSortedIntegerArray.Add(aValue: integer): PtrInt;
+begin
+  result := Count; // optimistic check of perfectly increasing aValue
+  if (result > 0) and
+     (aValue <= Values[result - 1]) then
+    result := FastLocateIntegerSorted(pointer(Values), result - 1, aValue);
+  if result < 0 then // aValue already exists in Values[] -> fails
+    exit;
+  if Count = Length(Values) then
+    SetLength(Values, NextGrow(Count));
+  if result < Count then
+    MoveFast(Values[result], Values[result + 1], (Count - result) * SizeOf(integer))
+  else
+    result := Count;
+  Values[result] := aValue;
+  inc(Count);
+end;
+
+function TSortedIntegerArray.IndexOf(aValue: integer): PtrInt;
+begin
+  result := FastFindIntegerSorted(pointer(Values), Count - 1, aValue);
+end;
+
+procedure TSortedIntegerArray.SetArray(out aValues: TIntegerDynArray);
+begin
+  if Count = 0 then
+    exit;
+  DynArrayFakeLength(Values, Count); // no realloc needed
+  aValues := Values;
+end;
+
+
+{ ************ ObjArray PtrArray InterfaceArray Wrapper Functions }
+
+{ PtrArr* wrapper functions }
+
+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 PtrArrayAdd(var aPtrArray; aItem: pointer; var aPtrArrayCount: integer): PtrInt;
+var
+  a: TPointerDynArray absolute aPtrArray;
+begin
+  result := aPtrArrayCount;
+  if result = length(a) then
+    SetLength(a, NextGrow(result));
+  a[result] := aItem;
+  inc(aPtrArrayCount);
+end;
+
+function PtrArrayAddOnce(var aPtrArray; aItem: pointer): PtrInt;
+var
+  a: TPointerDynArray absolute aPtrArray;
+  n: PtrInt;
+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 PtrArrayAddOnce(var aPtrArray; aItem: pointer;
+  var aPtrArrayCount: integer): PtrInt;
+begin
+  result := PtrUIntScanIndex(pointer(aPtrArray), aPtrArrayCount, PtrUInt(aItem));
+  if result < 0 then
+    result := PtrArrayAdd(aPtrArray, aItem, aPtrArrayCount);
+end;
+
+function PtrArrayInsert(var aPtrArray; aItem: pointer; aIndex: PtrInt;
+  var aPtrArrayCount: integer): PtrInt;
+var
+  a: TPointerDynArray absolute aPtrArray;
+  n: PtrInt;
+begin
+  n := aPtrArrayCount;
+  if length(a) = n then
+    SetLength(a, NextGrow(n));
+  if PtrUInt(aIndex) < PtrUInt(n) then
+    MoveFast(a[aIndex], a[aIndex + 1], (n - aIndex) * SizeOf(pointer))
+  else
+    aIndex := n;
+  a[aIndex] := aItem;
+  inc(aPtrArrayCount);
+  result := aIndex;
+end;
+
+procedure PtrArrayDelete(var aPtrArray; aIndex: PtrInt; aCount: PInteger);
+var
+  a: TPointerDynArray absolute aPtrArray;
+  n: PtrInt;
+begin
+  if aCount = nil then
+    n := length(a)
+  else
+    n := aCount^;
+  if PtrUInt(aIndex) >= PtrUInt(n) then
+    exit; // out of range
+  dec(n);
+  if n > aIndex then
+    MoveFast(a[aIndex + 1], a[aIndex], (n - aIndex) * SizeOf(pointer));
+  a[n] := nil; // better safe than sorry
+  if aCount = nil then
+    if n and 255 <> 0 then
+      DynArrayFakeLength(a, n) // call ReallocMem() once every 256 deletes
+    else
+      SetLength(a, n) // finalize if n = 0
+  else
+  begin
+    aCount^ := n;
+    if n = 0 then
+      Finalize(a);
+  end;
+end;
+
+function PtrArrayDelete(var aPtrArray; aItem: pointer; aCount: PInteger): PtrInt;
+var
+  a: TPointerDynArray absolute aPtrArray;
+  n: PtrInt;
+begin
+  if aCount = nil then
+    n := length(a)
+  else
+    n := aCount^;
+  result := PtrUIntScanIndex(pointer(a), n, PtrUInt(aItem));
+  if result < 0 then
+    exit;
+  dec(n);
+  if n > result then
+    MoveFast(a[result + 1], a[result], (n - result) * SizeOf(pointer));
+  a[n] := nil; // better safe than sorry
+  if aCount = nil then
+    SetLength(a, n)
+  else
+  begin
+    aCount^ := n;
+    if n = 0 then
+      Finalize(a);
+  end;
+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;
+begin
+  result := PtrArrayAdd(aObjArray, aItem);
+end;
+
+function ObjArrayAddCount(var aObjArray; aItem: TObject; var aObjArrayCount: integer): PtrInt;
+begin
+  result := PtrArrayAdd(aObjArray, aItem, aObjArrayCount);
+end;
+
+function ObjArrayAddFrom(var aDestObjArray; const aSourceObjArray): PtrInt;
+var
+  n: PtrInt;
+  s: TObjectDynArray absolute aSourceObjArray;
+  d: TObjectDynArray absolute aDestObjArray;
+begin
+  result := length(d);
+  n := length(s);
+  SetLength(d, result + n);
+  MoveFast(s[0], d[result], n * SizeOf(pointer));
+  inc(result, n);
+end;
+
+function ObjArrayAppend(var aDestObjArray, aSourceObjArray): PtrInt;
+begin
+  result := ObjArrayAddFrom(aDestObjArray, aSourceObjArray);
+  TObjectDynArray(aSourceObjArray) := nil; // aSourceObjArray[] changed ownership
+end;
+
+function ObjArrayAddOnce(var aObjArray; aItem: TObject): PtrInt;
+begin
+  result := PtrArrayAddOnce(aObjArray, aItem);
+end;
+
+function ObjArrayAddOnce(var aObjArray; aItem: TObject;
+  var aObjArrayCount: integer): PtrInt;
+begin
+  result := PtrArrayAddOnce(aObjArray, aItem, aObjArrayCount);
+end;
+
+function ObjArrayAddOnceFrom(var aDestObjArray; const aSourceObjArray): PtrInt;
+var
+  n, i: PtrInt;
+  s: TObjectDynArray absolute aSourceObjArray;
+  d: TObjectDynArray absolute aDestObjArray;
+begin
+  result := length(d);
+  n := length(s);
+  if n = 0 then
+    exit;
+  SetLength(d, result + n);
+  for i := 0 to n - 1 do
+    if not PtrUIntScanExists(pointer(d), result, PtrUInt(s[i])) then
+    begin
+      d[result] := s[i];
+      inc(result);
+    end;
+  DynArrayFakeLength(d, result);
+end;
+
+procedure ObjArraySetLength(var aObjArray; aLength: integer);
+begin
+  SetLength(TObjectDynArray(aObjArray), aLength);
+end;
+
+function ObjArrayFind(const aObjArray; aItem: TObject): PtrInt;
+begin
+  result := PtrUIntScanIndex(
+    pointer(aObjArray), length(TObjectDynArray(aObjArray)), PtrUInt(aItem));
+end;
+
+function ObjArrayFind(const aObjArray; aCount: integer; aItem: TObject): PtrInt;
+begin
+  result := PtrUIntScanIndex(pointer(aObjArray), aCount, PtrUInt(aItem));
+end;
+
+function ObjArrayNotNilCount(const aObjArray): integer;
+var
+  i: PtrInt;
+  a: TObjectDynArray absolute aObjArray;
+begin
+  result := 0;
+  for i := 0 to length(a) - 1 do
+    inc(result, ord(a[i] <> nil));
+end;
+
+procedure ObjArrayDelete(var aObjArray; aItemIndex: PtrInt;
+  aContinueOnException: boolean; aCount: PInteger);
+var
+  n: PtrInt;
+  a: TObjectDynArray absolute aObjArray;
+begin
+  if aCount = nil then
+    n := length(a)
+  else
+    n := aCount^;
+  if cardinal(aItemIndex) >= cardinal(n) then
+    exit; // out of range
+  if aContinueOnException then
+    try
+      a[aItemIndex].Free;
+    except
+    end
+  else
+    a[aItemIndex].Free;
+  dec(n);
+  if n > aItemIndex then
+    MoveFast(a[aItemIndex + 1], a[aItemIndex], (n - aItemIndex) * SizeOf(TObject));
+  if aCount = nil then
+    if n = 0 then
+      Finalize(a)
+    else
+      DynArrayFakeLength(a, n)
+  else
+    aCount^ := n;
+end;
+
+function ObjArrayDelete(var aObjArray; aItem: TObject): PtrInt;
+begin
+  result := PtrUIntScanIndex(pointer(aObjArray), length(TObjectDynArray(aObjArray)), PtrUInt(aItem));
+  if result >= 0 then
+    ObjArrayDelete(aObjArray, result);
+end;
+
+function ObjArrayDelete(var aObjArray; aCount: integer; aItem: TObject): PtrInt; overload;
+begin
+  result := PtrUIntScanIndex(pointer(aObjArray), aCount, PtrUInt(aItem));
+  if result >= 0 then
+    ObjArrayDelete(aObjArray, result, false, @aCount);
+end;
+
+procedure RawObjectsClear(o: PObject; n: integer);
+var
+  obj: TObject;
+begin
+  if n > 0 then
+    repeat
+      obj := o^;
+      if obj <> nil then
+      begin
+        // inlined FreeAndNil(o^)
+        o^ := nil;
+        obj.Destroy;
+      end;
+      inc(o);
+      dec(n);
+    until n = 0;
+end;
+
+procedure FreeAndNilSafe(var aObj);
+begin
+  if TObject(aObj) = nil then
+    exit;
+  try // slower but paranoidically safe
+    TObject(aObj).Destroy;
+  except
+  end;
+  TObject(aObj) := nil; // we could do it AFTER destroy
+end;
+
+procedure InterfaceNilSafe(var aInterface);
+begin
+  if IInterface(aInterface) <> nil then
+    try // slower but paranoidically safe
+      IInterface(aInterface) := nil;
+    except
+      pointer(aInterface) := nil; // force variable to nil
+    end;
+end;
+
+procedure InterfacesNilSafe(const aInterfaces: array of pointer);
+var
+  i: PtrInt;
+begin
+  for i := 0 to high(aInterfaces) do
+    InterfaceNilSafe(aInterfaces[i]^);
+end;
+
+procedure ObjArrayClear(var aObjArray);
+var
+  a: TObjectDynArray absolute aObjArray;
+begin
+  if a = nil then
+    exit;
+  // release all owned TObject instances
+  RawObjectsClear(pointer(aObjArray), PDALen(PAnsiChar(a) - _DALEN)^ + _DAOFF);
+  // release the dynamic array itself
+  a := nil;
+end;
+
+procedure ObjArrayClear(var aObjArray; aCount: integer);
+var
+  a: TObjectDynArray absolute aObjArray;
+  n: integer;
+begin
+  n := length(a);
+  if n = 0 then
+    exit;
+  if n < aCount then
+    aCount := n;
+  RawObjectsClear(pointer(aObjArray), aCount);
+  a := nil;
+end;
+
+procedure ObjArrayClear(var aObjArray; aContinueOnException: boolean; aCount: PInteger);
+var
+  n, i: PtrInt;
+  a: TObjectDynArray absolute aObjArray;
+begin
+  if aCount = nil then
+    n := length(a)
+  else
+  begin
+    n := aCount^;
+    aCount^ := 0;
+  end;
+  if n = 0 then
+    exit;
+  if aContinueOnException then
+    for i := n - 1 downto 0 do
+      try
+        a[i].Free;
+      except
+      end
+  else
+    RawObjectsClear(pointer(a), n);
+  a := nil; // finalize the dynamic array itself
+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;
+
+
+{ wrapper functions to array of interface types }
+
+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;
+
+function InterfaceArrayAddCount(var aInterfaceArray; var aCount: integer;
+  const aItem: IUnknown): PtrInt;
+var
+  a: TInterfaceDynArray absolute aInterfaceArray;
+begin
+  result := aCount;
+  if result = length(a) then
+    SetLength(a, NextGrow(result));
+  a[result] := aItem;
+  inc(aCount);
+end;
+
+procedure InterfaceArrayAddOnce(var aInterfaceArray; const aItem: IUnknown);
+var
+  a: TInterfaceDynArray absolute aInterfaceArray;
+  n: PtrInt;
+begin
+  if PtrUIntScanExists(pointer(aInterfaceArray),
+      length(TInterfaceDynArray(aInterfaceArray)), PtrUInt(aItem)) then
+    exit;
+  n := length(a);
+  SetLength(a, n + 1);
+  a[n] := aItem;
+end;
+
+function InterfaceArrayFind(const aInterfaceArray; const aItem: IUnknown): PtrInt;
+begin
+  result := PtrUIntScanIndex(pointer(aInterfaceArray), length(TInterfaceDynArray(aInterfaceArray)), PtrUInt(aItem));
+end;
+
+procedure InterfaceArrayDelete(var aInterfaceArray; aItemIndex: PtrInt);
+var
+  n: PtrInt;
+  a: TInterfaceDynArray absolute aInterfaceArray;
+begin
+  n := length(a);
+  if PtrUInt(aItemIndex) >= PtrUInt(n) then
+    exit; // out of range
+  a[aItemIndex] := nil;
+  dec(n);
+  if n > aItemIndex then
+    MoveFast(a[aItemIndex + 1], a[aItemIndex], (n - aItemIndex) * SizeOf(IInterface));
+  TPointerDynArray(aInterfaceArray)[n] := nil; // avoid GPF in SetLength()
+  if n = 0 then
+    Finalize(a)
+  else
+    DynArrayFakeLength(a, n);
+end;
+
+function InterfaceArrayDelete(var aInterfaceArray; const aItem: IUnknown): PtrInt;
+begin
+  result := InterfaceArrayFind(aInterfaceArray, aItem);
+  if result >= 0 then
+    InterfaceArrayDelete(aInterfaceArray, result);
+end;
+
+
+
+{ ************ low-level types mapping binary structures }
+
+function IsZero(const dig: THash128): boolean;
+var
+  a: TPtrIntArray absolute dig;
+begin
+  result := a[0] or a[1] {$ifdef CPU32} or a[2] or a[3]{$endif}  = 0;
+end;
+
+function IsEqual(const A, B: THash128): boolean;
+var
+  a_: TPtrIntArray absolute A;
+  b_: TPtrIntArray absolute B;
+begin
+  // uses anti-forensic time constant "xor/or" pattern
+  result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) {$ifdef CPU32} or
+             (a_[2] xor b_[2]) or (a_[3] xor b_[3]) {$endif} ) = 0;
+end;
+
+procedure FillZero(out dig: THash128);
+var
+  d: TInt64Array absolute dig;
+begin
+  d[0] := 0;
+  d[1] := 0;
+end;
+
+{$ifdef CPU64}
+
+function Hash128Index(P: PHash128Rec; Count: integer; h: PHash128Rec): integer;
+var
+  _0, _1: PtrInt; // is likely to use CPU registers
+begin
+  if P <> nil then
+  begin
+    _0 := h^.Lo;
+    _1 := h^.Hi;
+    for result := 0 to Count - 1 do
+      if (P^.Lo = _0) and
+         (P^.Hi = _1) then
+        exit
+      else
+        inc(P);
+  end;
+  result := -1; // not found
+end;
+
+function Hash256Index(P: PHash256Rec; Count: integer; h: PHash256Rec): integer;
+var
+  _0, _1: PtrInt;
+begin
+  if P <> nil then
+  begin
+    _0 := h^.d0;
+    _1 := h^.d1;
+    for result := 0 to Count - 1 do
+      if (P^.d0 = _0) and
+         (P^.d1 = _1) and
+         (P^.d2 = h^.d2) and
+         (P^.d3 = h^.d3) then
+        exit
+      else
+        inc(P);
+  end;
+  result := -1; // not found
+end;
+
+{$else}
+
+function Hash128Index(P: PHash128Rec; Count: integer; h: PHash128Rec): integer;
+begin
+  if P <> nil then
+    for result := 0 to Count - 1 do
+      if (P^.i0 = h^.i0) and
+         (P^.i1 = h^.i1) and
+         (P^.i2 = h^.i2) and
+         (P^.i3 = h^.i3) then
+        exit
+      else
+        inc(P);
+  result := -1; // not found
+end;
+
+function Hash256Index(P: PHash256Rec; Count: integer; h: PHash256Rec): integer;
+begin
+  if P <> nil then
+    for result := 0 to Count - 1 do
+      if (P^.i0 = h^.i0) and
+         (P^.i1 = h^.i1) and
+         (P^.i2 = h^.i2) and
+         (P^.i3 = h^.i3) and
+         (P^.i4 = h^.i4) and
+         (P^.i5 = h^.i5) and
+         (P^.i6 = h^.i6) and
+         (P^.i7 = h^.i7) then
+        exit
+      else
+        inc(P);
+  result := -1; // not found
+end;
+
+{$endif CPU64}
+
+function AddHash128(var Arr: THash128DynArray; const V: THash128;
+  var Count: integer): PtrInt;
+begin
+  result := Count;
+  if result = length(Arr) then
+    SetLength(Arr, NextGrow(result));
+  Arr[result] := V;
+  inc(Count);
+end;
+
+function IsZero(const dig: THash160): boolean;
+var
+  a: TIntegerArray absolute dig;
+begin
+  result := a[0] or a[1] or a[2] or a[3] or a[4] = 0;
+end;
+
+function IsEqual(const A, B: THash160): boolean;
+var
+  a_: TIntegerArray absolute A;
+  b_: TIntegerArray absolute B;
+begin
+  // uses anti-forensic time constant "xor/or" pattern
+  result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or
+             (a_[3] xor b_[3]) or (a_[4] xor b_[4])) = 0;
+end;
+
+procedure FillZero(out dig: THash160);
+begin
+  PInt64Array(@dig)^[0] := 0;
+  PInt64Array(@dig)^[1] := 0;
+  PIntegerArray(@dig)^[4] := 0;
+end;
+
+function IsZero(const dig: THash256): boolean;
+var
+  a: TPtrIntArray absolute dig;
+begin
+  result := a[0] or a[1] or a[2] or a[3] {$ifdef CPU32} or
+            a[4] or a[5] or a[6] or a[7] {$endif} = 0;
+end;
+
+function IsEqual(const A, B: THash256): boolean;
+var
+  a_: TPtrIntArray absolute A;
+  b_: TPtrIntArray absolute B;
+begin
+  // uses anti-forensic time constant "xor/or" pattern
+  result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or
+    (a_[3] xor b_[3]) {$ifdef CPU32}  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);
+var
+  d: TInt64Array absolute dig;
+begin
+  d[0] := 0;
+  d[1] := 0;
+  d[2] := 0;
+  d[3] := 0;
+end;
+
+function IsZero(const dig: THash384): boolean;
+var
+  a: TPtrIntArray absolute dig;
+begin
+  result := a[0] or a[1] or a[2] or a[3] or a[4] or a[5] {$ifdef CPU32} or
+    a[6] or a[7] or a[8] or a[9] or a[10] or a[11] {$endif}  = 0;
+end;
+
+function IsEqual(const A, B: THash384): boolean;
+var
+  a_: TPtrIntArray absolute A;
+  b_: TPtrIntArray absolute B;
+begin
+  // uses anti-forensic time constant "xor/or" pattern
+  result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or
+    (a_[3] xor b_[3]) or (a_[4] xor b_[4]) or (a_[5] xor b_[5]) {$ifdef CPU32} or
+    (a_[6] xor b_[6]) or (a_[7] xor b_[7]) or (a_[8] xor b_[8]) or
+    (a_[9] xor b_[9]) or (a_[10] xor b_[10]) or (a_[11] xor b_[11]) {$endif}) = 0;
+end;
+
+procedure FillZero(out dig: THash384);
+var
+  d: TInt64Array absolute dig;
+begin
+  d[0] := 0;
+  d[1] := 0;
+  d[2] := 0;
+  d[3] := 0;
+  d[4] := 0;
+  d[5] := 0;
+end;
+
+function IsZero(const dig: THash512): boolean;
+var
+  a: TPtrIntArray absolute dig;
+begin
+  result := a[0] or a[1] or a[2] or a[3] or a[4] or a[5] or a[6] or a[7] {$ifdef CPU32}
+    or a[8] or a[9] or a[10] or a[11] or a[12] or a[13] or a[14] or a[15] {$endif}  = 0;
+end;
+
+function IsEqual(const A, B: THash512): boolean;
+var
+  a_: TPtrIntArray absolute A;
+  b_: TPtrIntArray absolute B;
+begin
+  // uses anti-forensic time constant "xor/or" pattern
+  result := ((a_[0] xor b_[0]) or (a_[1] xor b_[1]) or (a_[2] xor b_[2]) or
+             (a_[3] xor b_[3]) or (a_[4] xor b_[4]) or (a_[5] xor b_[5]) or
+             (a_[6] xor b_[6]) or (a_[7] xor b_[7]) {$ifdef CPU32} or
+             (a_[8] xor b_[8]) or (a_[9] xor b_[9]) or (a_[10] xor b_[10]) or
+             (a_[11] xor b_[11]) or (a_[12] xor b_[12]) or (a_[13] xor b_[13]) or
+             (a_[14] xor b_[14]) or (a_[15] xor b_[15]) {$endif}) = 0;
+end;
+
+procedure FillZero(out dig: THash512);
+var
+  d: TInt64Array absolute dig;
+begin
+  d[0] := 0;
+  d[1] := 0;
+  d[2] := 0;
+  d[3] := 0;
+  d[4] := 0;
+  d[5] := 0;
+  d[6] := 0;
+  d[7] := 0;
+end;
+
+function IsEqual(const A, B; count: PtrInt): boolean;
+var
+  perbyte: boolean; // ensure no optimization takes place
+begin
+  result := true;
+  while count > 0 do
+  begin
+    dec(count);
+    perbyte := PByteArray(@A)[count] = PByteArray(@B)[count];
+    result := result and perbyte;
+  end;
+end;
+
+{$ifdef ISDELPHI} // intrinsic in FPC
+{$ifdef CPUINTEL}
+procedure ReadBarrier;
+asm
+        {$ifdef CPUX86}
+        lock add dword ptr [esp], 0
+        {$else}
+        .noframe
+        lfence // lfence requires an SSE CPU, which is OK on x86-64
+        {$endif CPUX86}
+end;
+{$else}
+procedure ReadBarrier;
+begin
+  MemoryBarrier; // modern Delphi intrinsic
+end;
+{$endif CPUINTEL}
+{$endif ISDELPHI}
+
+procedure Rcu32(var src, dst);
+begin
+  repeat
+    integer(dst) := integer(src);
+    ReadBarrier;
+  until integer(dst) = integer(src);
+end;
+
+procedure Rcu64(var src, dst);
+begin
+  repeat
+    Int64(dst) := Int64(src);
+    ReadBarrier;
+  until Int64(dst) = Int64(src);
+end;
+
+procedure RcuPtr(var src, dst);
+begin
+  repeat
+    PtrInt(dst) := PtrInt(src);
+    ReadBarrier;
+  until PtrInt(dst) = PtrInt(src);
+end;
+
+procedure Rcu128(var src, dst);
+var
+  s: THash128Rec absolute src;
+  d: THash128Rec absolute dst;
+begin
+  repeat
+    d := s;
+    ReadBarrier;
+  until (d.L = s.L) and
+        (d.H = s.H);
+end;
+
+procedure Rcu(var src, dst; len: integer);
+begin
+  if len > 0 then
+    repeat
+      MoveByOne(@src, @dst, len); // per-byte inlined copy
+      ReadBarrier;
+    until CompareMemSmall(@src, @dst, len);
+end;
+
+
+{ ************ low-level functions manipulating bits }
+
+// naive code gives the best performance - bts [Bits] has an overhead
+// we tried with PPtrIntArray but PIntegerArray seems to generate better code
+
+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 := byte(aIndex) in TBits64(Bits);
+end;
+
+procedure SetBit64(var Bits: Int64; aIndex: PtrInt);
+begin
+  include(PBits64(@Bits)^, aIndex);
+end;
+
+procedure UnSetBit64(var Bits: Int64; aIndex: PtrInt);
+begin
+  exclude(PBits64(@Bits)^, aIndex);
+end;
+
+function GetBitsCount(const Bits; Count: PtrInt): PtrInt;
+var
+  P: PPtrInt;
+  popcnt: function(value: PtrInt): PtrInt; // fast redirection within loop
+begin
+  P := @Bits;
+  result := 0;
+  popcnt := @GetBitsCountPtrInt;
+  if Count >= POINTERBITS then
+    repeat
+      dec(Count, POINTERBITS);
+      inc(result, popcnt(P^)); // use SSE4.2 if available
+      inc(P);
+    until Count < POINTERBITS;
+  if Count > 0 then
+    inc(result, popcnt(P^ and ((PtrInt(1) shl Count) - 1)));
+end;
+
+function GetAllBits(Bits, BitCount: cardinal): boolean;
+begin
+  if (BitCount >= low(ALLBITS_CARDINAL)) and
+     (BitCount <= high(ALLBITS_CARDINAL)) then
+  begin
+    BitCount := ALLBITS_CARDINAL[BitCount];
+    result := (Bits and BitCount) = BitCount;
+  end
+  else
+    result := false;
+end;
+
+function BitsToBytes(bits: byte): byte;
+begin
+  result := (bits + 7) shr 3;
+end;
+
+
+{ ************ Faster alternative to RTL standard functions }
+
+{$ifndef CPUX86} // those functions have their own PIC-compatible x86 asm version
+
+function StrLenSafe(S: pointer): PtrInt;
+begin
+  result := PtrUInt(S);
+  if S <> nil then
+    repeat
+      if PAnsiChar(result)[0] <> #0 then
+        if PAnsiChar(result)[1] <> #0 then
+          if PAnsiChar(result)[2] <> #0 then
+            if PAnsiChar(result)[3] <> #0 then
+            begin
+              inc(result, 4);
+              continue;
+            end
+            else
+            begin
+              dec(result, PtrUInt(S) - 3);
+              exit;
+            end
+          else
+          begin
+            dec(result, PtrUInt(S) - 2);
+            exit;
+          end
+        else
+          dec(PtrUInt(S));
+      dec(result, PtrUInt(S));
+      exit;
+    until false;
+end;
+
+function StrComp(Str1, Str2: pointer): PtrInt;
+var
+  c: byte;
+begin
+  result := 0;
+  if Str1 <> nil then
+    if Str2 <> nil then
+    begin
+      dec(PtrUInt(Str1), PtrUInt(Str2));
+      if Str1 = nil then
+        exit; // Str1=Str2
+      repeat
+        c := PByteArray(Str1)[PtrUInt(Str2)];
+        if c <> PByte(Str2)^ then
+          break
+        else if c = 0 then
+          exit // Str1 = Str2
+        else
+          inc(PByte(Str2));
+      until false;
+      result := PByteArray(Str1)[PtrUInt(Str2)] - PByte(Str2)^;
+      exit;
+    end
+    else
+      inc(result) // Str2=''
+  else if Str2 <> nil then
+    dec(result);  // Str1=''
+end;
+
+// from A. Sharahov's PosEx_Sha_Pas_2() - refactored for cross-platform/compiler
+function PosExPas(pSub, p: PUtf8Char; Offset: PtrUInt): PtrInt;
+var
+  len, lenSub: PtrInt;
+  ch: AnsiChar;
+  pStart, pStop: PUtf8Char;
+label
+  s2, s6, tt, t0, t1, t2, t3, t4, s0, s1, fnd, quit;
+begin
+  result := 0;
+  if (p = nil) or
+     (pSub = nil) or
+     (PtrInt(Offset) <= 0) then
+    goto quit;
+  len := PStrLen(p - _STRLEN)^;
+  lenSub := PStrLen(pSub - _STRLEN)^ - 1;
+  if (len < lenSub + PtrInt(Offset)) or
+     (lenSub < 0) then
+    goto quit;
+  pStop := p + len;
+  inc(p, lenSub);
+  inc(pSub, lenSub);
+  pStart := p;
+  p := @p[Offset + 3];
+  ch := pSub[0];
+  lenSub := -lenSub;
+  if p < pStop then
+    goto s6;
+  dec(p, 4);
+  goto s2;
+s6: // check 6 chars per loop iteration
+  if ch = p[-4] then
+    goto t4;
+  if ch = p[-3] then
+    goto t3;
+  if ch = p[-2] then
+    goto t2;
+  if ch = p[-1] then
+    goto t1;
+s2:if ch = p[0] then
+    goto t0;
+s1:if ch = p[1] then
+    goto tt;
+s0:inc(p, 6);
+  if p < pStop then
+    goto s6;
+  dec(p, 4);
+  if p >= pStop then
+    goto quit;
+  goto s2;
+t4:dec(p, 2);
+t2:dec(p, 2);
+  goto t0;
+t3:dec(p, 2);
+t1:dec(p, 2);
+tt:len := lenSub;
+  if lenSub <> 0 then
+    repeat
+      if (pSub[len] <> p[len + 1]) or
+         (pSub[len + 1] <> p[len + 2]) then
+        goto s0;
+      inc(len, 2);
+    until len >= 0;
+  inc(p, 2);
+  if p <= pStop then
+    goto fnd;
+  goto quit;
+t0:len := lenSub;
+  if lenSub <> 0 then
+    repeat
+      if (pSub[len] <> p[len]) or
+         (pSub[len + 1] <> p[len + 1]) then
+        goto s1;
+      inc(len, 2);
+    until len >= 0;
+  inc(p);
+fnd:
+  result := p - pStart;
+quit:
+end;
+
+function PosEx(const SubStr, S: RawUtf8; Offset: PtrUInt): PtrInt;
+begin
+  result := PosExPas(pointer(SubStr), pointer(S), Offset); // inlined call
+end;
+
+{$endif CPUX86}
+
+function StrCompW(Str1, Str2: PWideChar): PtrInt;
+var
+  c: word;
+begin
+  result := 0;
+  if Str1 <> Str2 then
+    if Str1 <> nil then
+      if Str2 <> nil then
+      begin
+        repeat
+          c := PWord(Str1)^;
+          if c <> PWord(Str2)^ then
+            break
+          else if c = 0 then
+            exit; // Str1 = Str2
+          inc(Str1);
+          inc(Str2);
+        until false;
+        result := PWord(Str1)^ - PWord(Str2)^;
+      end
+      else
+        inc(result) // Str2=''
+    else
+      dec(result);  // Str1=''
+end;
+
+function PosExChar(Chr: AnsiChar; const Str: RawUtf8): PtrInt;
+begin
+  if Str <> '' then
+    result := ByteScanIndex(pointer(Str), PStrLen(PtrUInt(Str) - _STRLEN)^, byte(Chr)) + 1
+  else
+    result := 0;
+end;
+
+function PosChar(Str: PUtf8Char; StrLen: PtrInt; Chr: AnsiChar): PUtf8Char;
+begin
+  if StrLen <> 0 then
+  begin
+    StrLen := ByteScanIndex(pointer(Str), StrLen, byte(Chr));
+    if StrLen >= 0 then
+      result := Str + StrLen
+    else
+      result := nil;
+  end
+  else
+    result := nil;
+end;
+
+{$ifdef UNICODE}
+
+function PosExString(const SubStr, S: string; Offset: PtrUInt): PtrInt;
+begin
+  result := PosExStringPas(pointer(SubStr), pointer(S), Offset);
+end;
+
+function PosExStringPas(pSub, p: PChar; Offset: PtrUInt): PtrInt;
+var
+  len, lenSub: PtrInt;
+  ch: char;
+  pStart, pStop: PChar;
+label
+  Loop2, Loop6, TestT, Test0, Test1, Test2, Test3, Test4,
+  AfterTestT, AfterTest0, Ret, Exit;
+begin
+  result := 0;
+  if (p = nil) or
+     (pSub = nil) or
+     (PtrInt(Offset) <= 0) then
+    goto Exit;
+  len := PStrLen(PtrUInt(p) - _STRLEN)^;
+  lenSub := PStrLen(PtrUInt(pSub) - _STRLEN)^ - 1;
+  if (len < lenSub + PtrInt(Offset)) or
+     (lenSub < 0) then
+    goto Exit;
+  pStop := p + len;
+  inc(p, lenSub);
+  inc(pSub, lenSub);
+  pStart := p;
+  inc(p, Offset + 3);
+  ch := pSub[0];
+  lenSub := -lenSub;
+  if p < pStop then
+    goto Loop6;
+  dec(p, 4);
+  goto Loop2;
+Loop6: // check 6 chars per loop iteration
+  if ch = p[-4] then
+    goto Test4;
+  if ch = p[-3] then
+    goto Test3;
+  if ch = p[-2] then
+    goto Test2;
+  if ch = p[-1] then
+    goto Test1;
+Loop2:
+  if ch = p[0] then
+    goto Test0;
+AfterTest0:
+  if ch = p[1] then
+    goto TestT;
+AfterTestT:
+  inc(p, 6);
+  if p < pStop then
+    goto Loop6;
+  dec(p, 4);
+  if p >= 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;
+
+{$else}
+
+function PosExString(const SubStr, S: string; Offset: PtrUInt): PtrInt;
+begin
+  {$ifdef CPUX86}
+  result := PosEx(SubStr, S, Offset); // call x86 asm
+  {$else}
+  result := PosExPas(pointer(SubStr), pointer(S), Offset);
+  {$endif CPUX86}
+end;
+
+{$endif UNICODE}
+
+function TrimU(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
+    FastAssignNew(result) // void string
+  else if (i = 1) and
+          (S[L] > ' ') then
+    result := S // nothing to trim: reference counted copy
+  else
+  begin
+    while S[L] <= ' ' do
+      dec(L);
+    dec(i);
+    FastSetString(result, @PByteArray(S)[i], L - i); // trim and allocate
+  end;
+end;
+
+procedure TrimSelf(var S: RawUtf8);
+var
+  i, L: PtrInt;
+begin
+  if S = '' then
+    exit;
+  L := PStrLen(PAnsiChar(pointer(S)) - _STRLEN)^;
+  i := 1;
+  while (i <= L) and
+        (S[i] <= ' ') do
+    inc(i);
+  if i > L then
+    FastAssignNew(S) // void string
+  else if (i = 1) and
+          (S[L] > ' ') then
+    exit // nothing to trim
+  else
+  begin
+    // trim the UTF-8 string
+    while S[L] <= ' ' do
+      dec(L);
+    dec(i);
+    dec(L, i);
+    if (L <> 0) and
+       (PStrCnt(PAnsiChar(pointer(S)) - _STRCNT)^ = 1) then
+    begin
+      if i <> 0 then
+        MoveFast(PByteArray(S)[i], pointer(S)^, L); // trim left: move in place
+      FakeLength(S, L); // after move, to properly set ending #0
+    end
+    else
+      FastSetString(S, @PByteArray(S)[i], L); // allocate
+  end;
+end;
+
+{$ifndef PUREMORMOT2}
+function Trim(const S: RawUtf8): RawUtf8;
+begin
+  result := TrimU(S);
+end;
+{$endif PUREMORMOT2}
+
+procedure TrimCopy(const S: RawUtf8; start, count: PtrInt;
+  var result: RawUtf8); // faster alternative to TrimU(copy())
+var
+  L: PtrInt;
+begin
+  if count > 0 then
+  begin
+    if start <= 0 then
+      start := 1;
+    L := Length(S);
+    while (start <= L) and
+          (S[start] <= ' ') do
+    begin
+      inc(start);
+      dec(count);
+    end;
+    dec(start);
+    dec(L,start);
+    if count < L then
+      L := count;
+    while L > 0 do
+      if S[start + L] <= ' ' then
+        dec(L)
+      else
+        break;
+    if L > 0 then
+    begin
+      FastSetString(result, @PByteArray(S)[start], L);
+      exit;
+    end;
+  end;
+  result := '';
+end;
+
+function Split(const Str, SepStr: RawUtf8; StartPos: PtrInt): RawUtf8;
+var
+  len, i: PtrInt;
+begin
+  len := length(Str);
+  if len = 0 then
+  begin
+    result := '';
+    exit;
+  end;
+  if StartPos > len then
+    StartPos := len
+  else if StartPos <= 0 then
+    StartPos := 1;
+  if (length(SepStr) = 1) and
+     (StartPos <= 1) then
+    i := PosExChar(SepStr[1], Str) // may use SSE2 on i386/x86_64
+  else
+    i := PosEx(SepStr, Str, StartPos);
+  if i > 0 then
+    FastSetString(result, @PByteArray(Str)[StartPos - 1], i - StartPos)
+  else if StartPos = 1 then
+    result := Str
+  else
+    FastSetString(result, @PByteArray(Str)[StartPos - 1], len - StartPos + 1);
+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 GotoNextControlChar(source: PUtf8Char): PUtf8Char;
+label
+  _1, _2, _3; // ugly but faster
+begin
+  result := source;
+  repeat
+    if result[0] < #13 then
+      exit
+    else if result[1] < #13 then
+      goto _1
+    else if result[2] < #13 then
+      goto _2
+    else if result[3] < #13 then
+      goto _3
+    else
+    begin
+      inc(result, 4);
+      continue;
+    end;
+_3: inc(result);
+_2: inc(result);
+_1: inc(result);
+    exit;
+  until false;
+end;
+
+function GotoNextLine(source: PUtf8Char): PUtf8Char;
+label
+  _0, _1, _2, _3; // ugly but faster
+begin
+  repeat
+    if source[0] < #13 then
+      goto _0
+    else if source[1] < #13 then
+      goto _1
+    else if source[2] < #13 then
+      goto _2
+    else if source[3] < #13 then
+      goto _3
+    else
+    begin
+      inc(source, 4);
+      continue;
+    end;
+_3: inc(source);
+_2: inc(source);
+_1: inc(source);
+_0: if source[0] = #13 then
+    begin
+      if source[1] = #10 then
+      begin
+        result := source + 2; // most common case is text ending with #13#10
+        exit;
+      end;
+    end
+    else if source[0] = #0 then
+    begin
+      result := nil; // premature ending
+      exit;
+    end
+    else if source[0] <> #10 then
+    begin
+      inc(source);
+      continue; // e.g. #9
+    end;
+    result := source + 1;
+    exit;
+  until false;
+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
+        // 7-bit chars are always OK, whatever codepage/charset is used
+        inc(PC)
+      else
+        exit;
+  result := true;
+end;
+
+function IsAnsiCompatible(PC: PAnsiChar; Len: PtrUInt): boolean;
+begin
+  if PC <> nil then
+  begin
+    result := false;
+    Len := PtrUInt(@PC[Len - 4]);
+    if Len >= PtrUInt(PC) then
+      repeat
+        if PCardinal(PC)^ and $80808080 <> 0 then
+          exit;
+        inc(PC, 4);
+      until Len < PtrUInt(PC);
+    inc(Len, 4);
+    if Len > PtrUInt(PC) then
+      repeat
+        if PC^ > #127 then
+          exit;
+        inc(PC);
+      until Len <= PtrUInt(PC);
+  end;
+  result := true;
+end;
+
+function IsAnsiCompatible(const Text: RawByteString): boolean;
+begin
+  result := IsAnsiCompatible(PAnsiChar(pointer(Text)), Length(Text));
+end;
+
+function IsAnsiCompatibleW(PW: PWideChar): boolean;
+begin
+  result := false;
+  if PW <> nil then
+    while true do
+      if ord(PW^) = 0 then
+        break
+      else if ord(PW^) <= 127 then
+        inc(PW)
+      else // 7-bit chars are always OK, whatever codepage/charset is used
+        exit;
+  result := true;
+end;
+
+function IsAnsiCompatibleW(PW: PWideChar; Len: PtrInt): boolean;
+begin
+  result := false;
+  if (PW <> nil) and
+     (Len > 0) then
+    repeat
+      if ord(PW^) > 127 then
+        exit;
+      inc(PW);
+      dec(Len);
+    until Len = 0;
+  result := true;
+end;
+
+procedure StrCntAdd(var refcnt: TStrCnt; increment: TStrCnt);
+begin
+  {$ifdef STRCNT32}
+  LockedAdd32(cardinal(refcnt), increment);
+  {$else}
+  LockedAdd(PtrUInt(refcnt), increment);
+  {$endif STRCNT32}
+end;
+
+procedure DACntAdd(var refcnt: TDACnt; increment: TDACnt);
+begin
+  {$ifdef DACNT32}
+  LockedAdd32(cardinal(refcnt), increment);
+  {$else}
+  LockedAdd(PtrUInt(refcnt), increment);
+  {$endif DACNT32}
+end;
+
+procedure FillZero(var dest; count: PtrInt);
+begin
+  FillCharFast(dest, count, 0);
+end;
+
+procedure MoveAndZero(Source, Dest: Pointer; Count: PtrUInt);
+begin
+  if Count = 0 then
+    exit;
+  MoveFast(Source^, Dest^, Count);
+  FillCharFast(Source^, Count, 0);
+end;
+
+procedure FillZeroSmall(P: pointer; Length: PtrInt);
+begin
+  inc(PtrUInt(P), PtrUInt(Length));
+  Length := -Length;
+  repeat
+    PByteArray(P)[Length] := 0;
+    inc(Length);
+  until Length = 0;
+end;
+
+threadvar // do not publish for compilation within Delphi packages
+  _Lecuyer: TLecuyer; // uses only 16 bytes per thread
+
+function Lecuyer: PLecuyer;
+begin
+  result := @_Lecuyer;
+end;
+
+{$ifdef OSDARWIN} // FPC CreateGuid calls /dev/urandom which is not advised
+function mach_absolute_time: Int64;   cdecl external 'c';
+function mach_continuous_time: Int64; cdecl external 'c';
+
+procedure CreateGuid(var guid: TGuid); // sysutils version is slow
+begin
+  PInt64Array(@guid)^[0] := mach_absolute_time;  // monotonic time (in ns)
+  PInt64Array(@guid)^[1] := mach_continuous_time;
+  crc128c(@guid, SizeOf(guid), THash128(guid)); // good enough diffusion
+end;
+{$endif OSDARWIN}
+
+var
+  // cascaded 128-bit random to avoid replay attacks - shared by all threads
+  _EntropyGlobal: THash128Rec;
+
+procedure XorEntropy(var e: THash512Rec);
+var
+  lec: PLecuyer;
+  guid: THash128Rec;
+begin
+  // note: we don't use RTL Random() here because it is not thread-safe
+  if _EntropyGlobal.L = 0 then
+    sysutils.CreateGuid(_EntropyGlobal.guid); // slow but rich initial value
+  e.r[0].L := e.r[0].L xor _EntropyGlobal.L;
+  e.r[0].H := e.r[0].H xor _EntropyGlobal.H;
+  lec := @_Lecuyer; // lec^.rs#=0 at thread startup, but won't hurt
+  e.r[1].c0 := e.r[1].c0 xor lec^.RawNext; // perfect forward security
+  e.r[1].c1 := e.r[1].c1 xor lec^.RawNext; // but don't expose rs1,rs2,rs3
+  e.r[1].c2 := e.r[1].c2 xor lec^.RawNext;
+  // any threadvar is thread-specific, so PtrUInt(lec) identifies this thread
+  {$ifdef CPUINTELARM}
+  e.r[1].c3 := e.r[1].c3 xor crc32c(PtrUInt(lec), @CpuFeatures, SizeOf(CpuFeatures));
+  {$else}
+  e.r[1].c3 := e.r[1].c3 xor PtrUInt(lec);
+  {$endif CPUINTELARM}
+  // Windows CoCreateGuid, Linux /proc/sys/kernel/random/uuid, FreeBSD syscall,
+  // then fallback to /dev/urandom or RTL mtwist_u32rand
+  CreateGuid(guid.guid); // not from sysutils: redefined above for OSDARWIN
+  e.r[2].L := e.r[2].L xor guid.L;
+  e.r[2].H := e.r[2].H xor guid.H;
+  // no mormot.core.os yet, so we can't use QueryPerformanceMicroSeconds()
+  unaligned(PDouble(@e.r[3].Lo)^) := Now * 2123923447; // cross-platform time
+  {$ifdef CPUINTEL} // use low-level Intel/AMD opcodes
+  e.r[3].Lo := e.r[3].Lo xor Rdtsc;
+  RdRand32(@e.r[0].c, length(e.r[0].c));
+  e.r[3].Hi := e.r[3].Hi xor Rdtsc; // has slightly changed in-between
+  {$else}
+  {$ifdef OSDARWIN} // fallback to known OS API on Mac M1/M2
+  e.r[3].Lo := e.r[3].Lo xor mach_absolute_time; // as defined above
+  e.r[3].Hi := e.r[3].Hi xor mach_continuous_time;
+  {$endif OSDARWIN}
+  e.r[3].Hi := e.r[3].Hi xor GetTickCount64; // always defined in FPC RTL
+  {$endif CPUINTEL}
+  crc128c(@e, SizeOf(e), _EntropyGlobal.b); // simple diffusion to move forward
+end;
+
+procedure MoveSwap(dst, src: PByte; n: PtrInt);
+begin
+  if n <= 0 then
+    exit;
+  inc(dst, n);
+  repeat
+    dec(dst);
+    dst^ := src^;
+    inc(src);
+    dec(n);
+  until n = 0;
+end;
+
+procedure TLecuyer.Seed(entropy: PByteArray; entropylen: PtrInt);
+var
+  e: THash512Rec;
+  h: THash128Rec;
+  i, j: PtrInt;
+begin
+  if entropy <> nil then
+    for i := 0 to entropylen - 1 do
+    begin
+      j := i and (SizeOf(e) - 1); // insert into the 64 bytes of e.b[]
+      e.b[j] := {%H-}e.b[j] xor entropy^[i];
+    end;
+  repeat
+    XorEntropy(e); // 512-bit from RdRand32 + Rdtsc + Now + CreateGuid
+    DefaultHasher128(@h, @e, SizeOf(e)); // may be AesNiHash128
+    rs1 := rs1 xor h.c0;
+    rs2 := rs2 xor h.c1;
+    rs3 := rs3 xor h.c2;
+  until (rs1 > 1) and
+        (rs2 > 7) and
+        (rs3 > 15);
+  seedcount := h.c3 shr 24; // may seed slightly before 2^32 of output data
+  for i := 1 to h.i3 and 7 do
+    RawNext; // warm up
+end;
+
+procedure TLecuyer.SeedGenerator(fixedseed: QWord);
+begin
+  SeedGenerator(@fixedseed, SizeOf(fixedseed));
+end;
+
+procedure TLecuyer.SeedGenerator(fixedseed: pointer; fixedseedbytes: integer);
+begin
+  rs1 := crc32c(0,   fixedseed, fixedseedbytes);
+  rs2 := crc32c(rs1, fixedseed, fixedseedbytes);
+  rs3 := crc32c(rs2, fixedseed, fixedseedbytes);
+  if rs1 < 2 then
+    rs1 := 2;
+  if rs2 < 8 then
+    rs2 := 8;
+  if rs3 < 16 then
+    rs3 := 16;
+  seedcount := 1; // will reseet after 16 GB, i.e. 2^32 of output data
+end;
+
+function TLecuyer.RawNext: cardinal;
+begin // not inlined for better code generation
+  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: cardinal;
+begin
+  if seedcount = 0 then
+    Seed // seed at startup, and after 2^32 of output data = 16 GB
+  else
+    inc(seedcount);
+  result := RawNext;
+end;
+
+function TLecuyer.Next(max: cardinal): cardinal;
+begin
+  result := (QWord(Next) * max) shr 32;
+end;
+
+function TLecuyer.NextQWord: QWord;
+begin
+  PQWordRec(@result)^.L := Next;
+  PQWordRec(@result)^.H := RawNext; // no need to check the Seed twice
+end;
+
+function TLecuyer.NextDouble: double;
+const
+  COEFF32: double = 1.0 / (Int64(1) shl 32);
+begin
+  result := Next * COEFF32; // 32-bit resolution is enough for our purpose
+end;
+
+procedure TLecuyer.Fill(dest: pointer; bytes: integer);
+var
+  c: cardinal;
+begin
+  if bytes <= 0 then
+    exit;
+  c := seedcount;
+  inc(seedcount, cardinal(bytes) shr 2);
+  if (c = 0) or           // first use = seed at startup
+     (c > seedcount) then // check for 32-bit overflow, i.e. after 16 GB
+    Seed;
+  repeat
+    if bytes < 4 then
+      break;
+    PCardinal(dest)^ := PCardinal(dest)^ xor RawNext; // inlining won't change
+    inc(PCardinal(dest));
+    dec(bytes, 4);
+    if bytes = 0 then
+      exit;
+  until false;
+  c := RawNext;
+  repeat
+    PByte(dest)^ := PByte(dest)^ xor c;
+    inc(PByte(dest));
+    c := c shr 8;
+    dec(bytes);
+  until bytes = 0;
+end;
+
+procedure FillAnsiStringFromRandom(dest: PByteArray; size: PtrUInt);
+var
+  len: PtrUInt;
+begin
+  dec(size);
+  len := dest[0];  // first random byte will make length
+  if size = 31 then
+    size := len and 31 // optimized for FillShort31()
+  else if size = 255 then
+    size := ToByte(len)
+  else
+    size := len mod size;
+  dest[0] := size;
+  if size <> 0 then
+    repeat
+      dest[size] := (cardinal(dest[size]) and 63) + 32;
+      dec(size);
+    until size = 0;
+end;
+
+procedure TLecuyer.FillShort(var dest: ShortString; size: PtrUInt);
+begin
+  if size = 0 then
+  begin
+    dest[0] := #0;
+    exit;
+  end;
+  if size > 255 then
+    size := 256
+  else
+    inc(size);
+  Fill(@dest, size);
+  FillAnsiStringFromRandom(@dest, size);
+end;
+
+procedure TLecuyer.FillShort31(var dest: TShort31);
+begin
+  Fill(@dest, 32);
+  FillAnsiStringFromRandom(@dest, 32);
+end;
+
+procedure Random32Seed(entropy: pointer; entropylen: PtrInt);
+begin
+  _Lecuyer.Seed(entropy, entropylen);
+end;
+
+function Random32: cardinal;
+begin
+  result := _Lecuyer.Next;
+end;
+
+function Random31: integer;
+begin
+  result := _Lecuyer.Next shr 1;
+end;
+
+function Random32(max: cardinal): cardinal;
+begin
+  result := (QWord(_Lecuyer.Next) * max) shr 32;
+end;
+
+function Random64: QWord;
+begin
+  result := _Lecuyer.NextQWord;
+end;
+
+function RandomDouble: double;
+begin
+  result := _Lecuyer.NextDouble;
+end;
+
+procedure RandomBytes(Dest: PByte; Count: integer);
+begin
+  if Count > 0 then
+    _Lecuyer.Fill(pointer(Dest), Count);
+end;
+
+procedure RandomShort31(var dest: TShort31);
+begin
+  _Lecuyer.FillShort31(dest);
+end;
+
+procedure LecuyerEncrypt(key: Qword; var data: RawByteString);
+var
+  gen: TLecuyer;
+begin
+  if data = '' then
+    exit;
+  {$ifdef FPC}
+  UniqueString(data); // @data[1] won't call UniqueString() under FPC :(
+  {$endif FPC}
+  gen.SeedGenerator(key);
+  gen.Fill(@data[1], length(data));
+  FillZero(THash128(gen)); // to avoid forensic leak
+end;
+
+{$ifndef PUREMORMOT2}
+procedure FillRandom(Dest: PCardinal; CardinalCount: integer);
+begin
+  if CardinalCount > 0 then
+    _Lecuyer.Fill(pointer(Dest), CardinalCount shl 2);
+end;
+{$endif PUREMORMOT2}
+
+
+{ MultiEvent* functions }
+
+function MultiEventFind(const EventList; const Event: TMethod): PtrInt;
+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: PtrInt;
+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) < cardinal(max) then
+  begin
+    dec(max);
+    MoveFast(Events[Index + 1], Events[Index], (max - Index) * SizeOf(Events[Index]));
+    SetLength(Events, max);
+  end;
+end;
+
+procedure MultiEventMerge(var DestList; const ToBeAddedList);
+var
+  Dest: TMethodDynArray absolute DestList;
+  New: TMethodDynArray absolute ToBeAddedList;
+  d, n: PtrInt;
+begin
+  d := length(Dest);
+  n := length(New);
+  if n = 0 then
+    exit;
+  SetLength(Dest, d + n);
+  MoveFast(New[0], Dest[d], n * SizeOf(TMethod));
+end;
+
+function EventEquals(const eventA, eventB): boolean;
+var
+  A: TMethod absolute eventA;
+  B: TMethod absolute eventB;
+begin
+  result := (A.Code = B.Code) and
+            (A.Data = B.Data);
+end;
+
+
+type
+  // 16KB/32KB hash table used by SynLZ - as used by the asm .inc files
+  TOffsets = array[0..4095] of PAnsiChar;
+
+{$ifdef CPUINTEL}
+
+// optimized asm for x86 and x86_64 is located in include files
+
+{$ifndef HASNOSSE2}
+
+function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal;
+begin
+  Count := IntegerScanIndex(P, Count, Value); // SSE2 asm on Intel/AMD
+  if Count >= 0 then
+    result := @P[Count]
+  else
+    result := nil;
+end;
+
+function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean;
+begin
+  result := IntegerScanIndex(P, Count, Value) >= 0; // SSE2 asm on Intel/AMD
+end;
+
+{$endif HASNOSSE2}
+
+function HasHWAes: boolean;
+begin
+  result := cfAESNI in CpuFeatures;
+end;
+
+procedure RdRand32(buffer: PCardinal; n: integer);
+begin
+  if (n > 0) and
+     (cfRAND in CpuFeatures) then
+    repeat
+      buffer^ := buffer^ xor RdRand32;
+      inc(buffer);
+      dec(n);
+    until n = 0;
+end;
+
+type
+  TIntelRegisters = record
+    eax, ebx, ecx, edx: cardinal;
+  end;
+
+{$ifdef CPUX64}
+  {$include mormot.core.base.asmx64.inc}
+{$endif CPUX64}
+
+{$ifdef CPUX86}
+  {$include mormot.core.base.asmx86.inc}
+{$endif CPUX86}
+
+procedure TestCpuFeatures;
+var
+  regs: TIntelRegisters;
+  c: cardinal;
+begin
+  // retrieve CPUID raw flags
+  FillChar(regs, SizeOf(regs), 0); // no FillCharFast here
+  GetCpuid({eax=}1, {ecx=}0, regs);
+  PIntegerArray(@CpuFeatures)^[0] := regs.edx;
+  PIntegerArray(@CpuFeatures)^[1] := regs.ecx;
+  GetCpuid(7, 0, regs);
+  PIntegerArray(@CpuFeatures)^[2] := regs.ebx;
+  PIntegerArray(@CpuFeatures)^[3] := regs.ecx;
+  PIntegerArray(@CpuFeatures)^[4] := regs.edx;
+  if regs.eax in [1..9] then // returned the maximum ecx value for eax=7 in eax
+  begin
+    GetCpuid(7, 1, regs);
+    PIntegerArray(@CpuFeatures)^[5] := regs.eax; // just ignore regs.ebx
+    PIntegerArray(@CpuFeatures)^[6] := regs.edx;
+    if cfAVX10 in CpuFeatures then
+    begin
+      GetCpuid($24, 0, regs);
+      CpuAvx10.MaxSubLeaf := regs.eax;
+      CpuAvx10.Version := ToByte(regs.ebx);
+      PByte(@CpuAvx10.Vector)^ := (regs.ebx shr 16) and 7;
+    end;
+  end;
+  // validate accuracy of most used HW opcodes
+  {$ifdef DISABLE_SSE42}
+  // force fallback on Darwin x64 (as reported by alf) - clang asm bug?
+  CpuFeatures := CpuFeatures -
+    [cfSSE3, cfSSE42, cfPOPCNT, cfAESNI, cfCLMUL, cfAVX, cfAVX2, cfFMA];
+  {$else}
+  if not (cfOSXS in CpuFeatures) or
+     not IsXmmYmmOSEnabled then
+    // AVX is available on the CPU, but not supported at OS context switch
+    CpuFeatures := CpuFeatures - [cfAVX, cfAVX2, cfFMA];
+  {$endif DISABLE_SSE42}
+  if cfRAND in CpuFeatures then
+    try
+      c := RdRand32;
+      if RdRand32 = c then // most probably a RDRAND bug, e.g. on AMD Rizen 3000
+        exclude(CpuFeatures, cfRAND);
+    except // may trigger an illegal instruction exception on some Ivy Bridge
+      exclude(CpuFeatures, cfRAND);
+    end;
+  if cfSSE42 in CpuFeatures then
+    try
+      if crc32cby4sse42(0, 1) <> 3712330424 then
+        exclude(CpuFeatures, cfSSE42);
+    except // disable now on illegal instruction or incorrect result
+      exclude(CpuFeatures, cfSSE42);
+    end;
+  if cfPOPCNT in CpuFeatures then
+    try
+      if GetBitsCountSse42(7) = 3 then
+        GetBitsCountPtrInt := @GetBitsCountSse42;
+    except // clearly invalid opcode
+      exclude(CpuFeatures, cfPOPCNT);
+    end;
+  {$ifdef ASMX64}
+  // note: cfERMS has no cpuid within some VMs -> ignore and assume present
+  if cfAVX in CpuFeatures then
+  begin
+    include(X64CpuFeatures, cpuAVX);
+    if cfAVX2 in CpuFeatures then
+      include(X64CpuFeatures, cpuAVX2);
+    if CpuFeatures * CPUAVX2HASWELL = CPUAVX2HASWELL then
+      include(X64CpuFeatures, cpuHaswell);
+  end;
+  {$endif ASMX64}
+  // redirect some CPU-aware functions
+  {$ifdef ASMX86} 
+  {$ifndef HASNOSSE2}
+  {$ifdef WITH_ERMS}
+  if not (cfSSE2 in CpuFeatures) then
+  begin
+    ERMSB_MIN_SIZE_FWD := 0; // FillCharFast fallbacks to rep stosb on older CPU
+    {$ifndef FPC_X86}
+    ERMSB_MIN_SIZE_BWD := 0; // in both directions to bypass the SSE2 code
+    {$endif FPC_X86}
+  end
+    // but MoveFast/SynLz are likely to abort -> recompile with HASNOSSE2 conditional
+    // note: mormot.core.os.pas InitializeSpecificUnit will notify it on console
+  else if cfERMS in CpuFeatures then
+    ERMSB_MIN_SIZE_FWD := 4096; // "on 32-bit strings have to be at least 4KB"
+    // backward rep movsd has no ERMS optimization so degrades performance
+  {$endif WITH_ERMS}
+  {$endif HASNOSSE2}
+  if cfSSE2 in CpuFeatures then
+    StrLen := @StrLenSSE2;
+  {$endif ASMX86}
+  if cfSSE42 in CpuFeatures then // for both i386 and x86_64
+  begin
+    crc32c          := @crc32csse42;
+    crc32cby4       := @crc32cby4sse42;
+    crcblock        := @crcblocksse42;
+    crcblocks       := @crcblockssse42;
+    DefaultHasher   := @crc32csse42;
+    InterningHasher := @crc32csse42;
+  end;
+end;
+
+{$else not CPUINTEL}
+
+// fallback to pure pascal version for non-Intel CPUs
+
+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;
+
+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}
+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;
+{$endif FPC}
+
+function xxHash32(crc: cardinal; P: PAnsiChar; len: cardinal): 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); // inlined xxHash32Mixup()
+  result := result * PRIME32_2;
+  result := result xor (result shr 13);
+  result := result * PRIME32_3;
+  result := result xor (result shr 16);
+end;
+
+function SortDynArrayInteger(const A, B): integer;
+begin
+  result := ord(integer(A) > integer(B)) - ord(integer(A) < integer(B));
+end;
+
+function SortDynArrayCardinal(const A, B): integer;
+begin
+  result := ord(cardinal(A) > cardinal(B)) - ord(cardinal(A) < cardinal(B));
+end;
+
+function SortDynArrayInt64(const A, B): integer;
+begin
+  result := ord(Int64(A) > Int64(B)) - ord(Int64(A) < Int64(B));
+end;
+
+function SortDynArrayQWord(const A, B): integer;
+begin
+  result := ord(QWord(A) > QWord(B)) - ord(QWord(A) < QWord(B));
+end;
+
+function SortDynArrayPointer(const A, B): integer;
+begin
+  result := ord(PtrUInt(A) > PtrUInt(B)) - ord(PtrUInt(A) < PtrUInt(B));
+end;
+
+function SortDynArrayDouble(const A, B): integer;
+begin
+  result := ord(double(A) > double(B)) - ord(double(A) < double(B));
+end;
+
+function SortDynArraySingle(const A, B): integer;
+begin
+  result := ord(single(A) > single(B)) - ord(single(A) < single(B));
+end;
+
+function SortDynArrayAnsiString(const A, B): integer;
+begin
+  result := StrComp(pointer(A), pointer(B));
+end;
+
+function SortDynArrayRawByteString(const A, B): integer;
+var
+  p1, p2: PByteArray;
+  l1, l2: PtrInt; // FPC will use very 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
+        result := p1[0] - p2[0]; // compare first char for quicksort
+        if result <> 0 then
+          exit;
+        l1 := PStrLen(PtrUInt(p1) - _STRLEN)^;
+        l2 := PStrLen(PtrUInt(p2) - _STRLEN)^;
+        result := l1;
+        if l1 > l2 then
+          l1 := l2;
+        dec(result, l2);
+        p1 := @p1[l1];
+        p2 := @p2[l1];
+        dec(l1); // we already compared the first char
+        if l1 = 0 then
+          exit;
+        l1 := -l1;
+        repeat
+          if p1[l1] <> p2[l1] then
+            break;
+          inc(l1);
+          if l1 = 0 then
+            exit;
+        until false;
+        result := p1[l1] - p2[l1];
+      end
+      else
+        result := 1  // p2=''
+    else
+      result := -1   // p1=''
+  else
+    result := 0;     // p1=p2
+end;
+
+{  FPC x86_64 Linux:
+  1000000 pas in 4.67ms i.e. 213,949,507/s, aver. 0us, 1.5 GB/s
+  1000000 asm in 4.14ms i.e. 241,196,333/s, aver. 0us, 1.8 GB/s
+  1000000 sse4.2 in 2.36ms i.e. 423,011,844/s, aver. 0us, 3.1 GB/s
+  1000000 FPC in 21.32ms i.e. 46,886,721/s, aver. 0us, 357.7 MB/s
+   FPC i386 Windows:
+  1000000 pas in 3.40ms i.e. 293,944,738/s, aver. 0us, 1 GB/s
+  1000000 asm in 3.18ms i.e. 313,971,742/s, aver. 0us, 1.1 GB/s
+  1000000 sse4.2 in 2.74ms i.e. 364,166,059/s, aver. 0us, 1.3 GB/s
+  1000000 FPC in 8.18ms i.e. 122,204,570/s, aver. 0us, 466.1 MB/s
+ notes:
+ 1. AVX2 faster than popcnt on big buffers - https://arxiv.org/pdf/1611.07612.pdf
+ 2. our pascal/asm versions below use the efficient Wilkes-Wheeler-Gill algorithm
+    whereas FPC RTL's popcnt() is much slower }
+
+function GetBitsCountPas(value: PtrInt): PtrInt;
+begin
+  // generic branchless Wilkes-Wheeler-Gill pure pascal version
+  result := value;
+  {$ifdef CPU64}
+  result := result - ((result shr 1) and $5555555555555555);
+  result := (result and $3333333333333333) + ((result shr 2) and $3333333333333333);
+  result := (result + (result shr 4)) and $0f0f0f0f0f0f0f0f;
+  inc(result, result shr 8); // avoid slow multiplication on ARM
+  inc(result, result shr 16);
+  inc(result, result shr 32);
+  result := result and $7f;
+  {$else}
+  result := result - ((result shr 1) and $55555555);
+  result := (result and $33333333) + ((result shr 2) and $33333333);
+  result := (result + (result shr 4)) and $0f0f0f0f;
+  inc(result, result shr 8);
+  inc(result, result shr 16);
+  result := result and $3f;
+  {$endif CPU64}
+end;
+
+procedure mul64x64(constref left, right: QWord; out product: THash128Rec);
+var
+  l: TQWordRec absolute left;
+  r: TQWordRec absolute right;
+  t1, t2: TQWordRec;
+begin
+  // CPU-neutral implementation
+  t1.V := QWord(l.L) * r.L;
+  product.c0 := t1.L;
+  t2.V := QWord(l.H) * r.L + t1.H;
+  t1.V := QWord(l.L) * r.H + t2.L;
+  product.H := QWord(l.H) * r.H + t2.H + t1.H;
+  product.c1 := t1.V;
+end;
+
+function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
+begin
+  result := SynLZcompress1pas(src, size, dst);
+end;
+
+function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
+begin
+  result := SynLZdecompress1pas(src, size, dst);
+end;
+
+function StrCntDecFree(var refcnt: TStrCnt): boolean;
+begin
+  // fallback to RTL asm e.g. for ARM
+  {$ifdef STRCNT32}
+  result := InterLockedDecrement(refcnt) <= 0;
+  {$else}
+  result := InterLockedDecrement64(refcnt) <= 0;
+  {$endif STRCNT32}
+end; // we don't check for ismultithread global
+
+function DACntDecFree(var refcnt: TDACnt): boolean;
+begin
+  // fallback to RTL asm e.g. for ARM
+  {$ifdef DACNT32}
+  result := InterLockedDecrement(refcnt) <= 0;
+  {$else}
+  result := InterLockedDecrement64(refcnt) <= 0;
+  {$endif DACNT32}
+end;
+
+procedure LockedInc32(int32: PInteger);
+begin
+  InterlockedIncrement(int32^);
+end;
+
+procedure LockedDec32(int32: PInteger);
+begin
+  InterlockedDecrement(int32^);
+end;
+
+procedure LockedInc64(int64: PInt64);
+begin
+  {$ifdef FPC_64}
+  InterlockedIncrement64(int64^); // we can use the existing 64-bit RTL function
+  {$else}
+  with PInt64Rec(int64)^ do
+    if InterlockedIncrement(Lo) = 0 then
+      InterlockedIncrement(Hi); // collission is highly unprobable
+  {$endif FPC_64}
+end;
+
+function LockedExc(var Target: PtrUInt; NewValue, Comperand: PtrUInt): boolean;
+begin
+  result := InterlockedCompareExchange(
+    pointer(Target), pointer(NewValue), pointer(Comperand)) = pointer(Comperand);
+end;
+
+procedure LockedAdd(var Target: PtrUInt; Increment: PtrUInt);
+begin
+  InterlockedExchangeAdd(pointer(Target), pointer(Increment));
+end;
+
+procedure LockedAdd32(var Target: cardinal; Increment: cardinal);
+begin
+  InterlockedExchangeAdd(Target, Increment);
+end;
+
+procedure LockedDec(var Target: PtrUInt; Decrement: PtrUInt);
+begin
+  InterlockedExchangeAdd(pointer(Target), pointer(-PtrInt(Decrement)));
+end;
+
+procedure bswap64array(a,b: PQWordArray; n: PtrInt);
+var
+  i: PtrInt;
+begin
+  for i := 0 to n - 1 do
+    b^[i] := {$ifdef FPC}SwapEndian{$else}bswap64{$endif}(a^[i]);
+end;
+
+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;
+
+function ByteScanIndex(P: PByteArray; Count: PtrInt; Value: byte): PtrInt;
+begin
+  result := IndexByte(P^, Count, Value); // use FPC RTL
+end;
+
+function WordScanIndex(P: PWordArray; Count: PtrInt; Value: word): PtrInt;
+begin
+  result := IndexWord(P^, Count, Value); // use FPC RTL
+end;
+
+function IntegerScan(P: PCardinalArray; Count: PtrInt; Value: cardinal): PCardinal;
+begin
+  result := nil;
+  if P = nil then
+    exit;
+  Count := PtrUInt(@P[Count - 4]); // per-four loop is faster than FPC RTL
+  repeat
+    if PtrUInt(P) > PtrUInt(Count) then
+      break;
+    if P^[0] <> Value then
+      if P^[1] <> Value then
+        if P^[2] <> Value then
+          if P^[3] <> Value then
+          begin
+            P := @P[4];
+            continue;
+          end
+          else
+            result := @P[3]
+        else
+          result := @P[2]
+      else
+        result := @P[1]
+    else
+      result := pointer(P);
+    exit;
+  until false;
+  inc(Count, 4 * SizeOf(Value));
+  result := pointer(P);
+  repeat
+    if PtrUInt(result) >= PtrUInt(Count) then
+      break;
+    if result^ = Value then
+      exit;
+    inc(result);
+  until false;
+  result := nil;
+end;
+
+function IntegerScanExists(P: PCardinalArray; Count: PtrInt; Value: cardinal): boolean;
+begin
+  if P <> nil then
+  begin
+    result := true;
+    Count := PtrInt(@P[Count - 4]);
+    repeat
+      if PtrUInt(P) > PtrUInt(Count) then
+        break;
+      if (P^[0] = Value) or
+         (P^[1] = Value) or
+         (P^[2] = Value) or
+         (P^[3] = Value) then
+        exit;
+      P := @P[4];
+    until false;
+    inc(Count, 4 * SizeOf(Value));
+    repeat
+      if PtrUInt(P) >= PtrUInt(Count) then
+        break;
+      if P^[0] = Value then
+        exit;
+      P := @P[1];
+    until false;
+  end;
+  result := false;
+end;
+
+function IntegerScanIndex(P: PCardinalArray; Count: PtrInt; Value: cardinal): PtrInt;
+begin
+  result := PtrUInt(IntegerScan(P, Count, Value));
+  if result = 0 then
+    dec(result)
+  else
+  begin
+    dec(result, PtrUInt(P));
+    result := result shr 2;
+  end;
+end;
+
+{$ifdef CPUARM3264} // ARM-specific code
+
+{$ifdef OSLINUXANDROID} // read CpuFeatures from Linux envp
+
+const
+  AT_HWCAP  = 16;
+  AT_HWCAP2 = 26;
+
+procedure TestCpuFeatures;
+var
+  p: PPChar;
+  caps: TArmHwCaps;
+begin
+  // C library function getauxval() is not always available -> use system.envp
+  caps := [];
+  try
+    p := system.envp;
+    while p^ <> nil do
+      inc(p);
+    inc(p); // auxv is located after the last textual environment variable
+    repeat
+      if PtrUInt(p[0]) = AT_HWCAP then // 32-bit or 64-bit entries = PtrUInt
+        PCardinalArray(@caps)[0] := PtrUInt(p[1])
+      else if PtrUInt(p[0]) = AT_HWCAP2 then
+        PCardinalArray(@caps)[1] := PtrUInt(p[1]);
+      p := @p[2];
+    until p[0] = nil;
+  except
+    // may happen on some untested Operating System
+    caps := []; // is likely to be invalid
+  end;
+  CpuFeatures := caps;
+end;
+
+{$else}
+
+procedure TestCpuFeatures;
+begin
+  // perhaps system.envp would work somewhat, but the HWCAP items don't match
+end;
+
+{$endif OSLINUXANDROID}
+
+function HasHWAes: boolean;
+begin
+  result := ahcAES in CpuFeatures;
+end;
+
+{$else}  // non Intel nor ARM CPUs
+
+procedure TestCpuFeatures;
+begin
+end;
+
+function HasHWAes: boolean;
+begin
+  result := false;
+end;
+
+{$endif CPUARM3264}
+
+{$endif CPUINTEL}
+
+{$ifndef ASMINTEL}
+
+// fallback to pure pascal version for ARM or Intel PIC
+function crc32fasttab(crc: cardinal; buf: PAnsiChar; len: cardinal;
+  tab: PCrc32tab): cardinal; inline;
+begin
+  // on ARM, we use slicing-by-4 to avoid polluting smaller L1 cache
+  result := not crc;
+  if (buf <> nil) and
+     (len > 0) then
+  begin
+    repeat
+      if PtrUInt(buf) and 3 = 0 then // align to 4 bytes boundary
+        break;
+      result := tab[0, ToByte(result xor ord(buf^))] xor (result shr 8);
+      dec(len);
+      inc(buf);
+    until len = 0;
+    if len >= 4 then
+      repeat
+        result := result xor PCardinal(buf)^;
+        inc(buf, 4);
+        dec(len, 4);
+        result := tab[3, ToByte(result)] xor tab[2, ToByte(result shr 8)] xor
+           tab[1, ToByte(result shr 16)] xor tab[0, ToByte(result shr 24)];
+      until len < 4;
+    while len > 0 do
+    begin
+      result := tab[0, ToByte(result xor ord(buf^))] xor (result shr 8);
+      dec(len);
+      inc(buf);
+    end;
+  end;
+  result := not result;
+end;
+
+function StrInt32(P: PAnsiChar; val: PtrInt): PAnsiChar;
+begin
+  if val < 0 then
+  begin
+    result := StrUInt32(P, PtrUInt(-val)) - 1;
+    result^ := '-';
+  end
+  else
+    result := StrUInt32(P, val);
+end;
+
+function StrUInt32(P: PAnsiChar; val: PtrUInt): PAnsiChar;
+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; // FPC will use fast reciprocal
+    dec(val, c100 * 100);
+    PWord(P)^ := tab[val];
+    val := c100;
+    if c100 = 0 then
+      break;
+  until false;
+  result := P;
+end;
+
+{$endif ASMINTEL}
+
+
+{ ************ Buffers (e.g. Hashing and SynLZ compression) Raw Functions }
+
+{$ifndef CPUX64} // there is fast branchless SSE2 assembly on x86-64
+
+function BufferLineLength(Text, TextEnd: PUtf8Char): PtrInt;
+var
+  c: byte;
+begin
+  result := PtrUInt(Text) - 1;
+  repeat
+    inc(result);
+    if PtrUInt(result) < PtrUInt(TextEnd) then
+    begin
+      c := PByte(result)^;
+      if (c > 13) or
+         ((c <> 10) and
+          (c <> 13)) then
+        continue;
+    end;
+    break;
+  until false;
+  dec(result, PtrInt(Text)); // returns length
+end;
+
+function PosChar(Str: PUtf8Char; Chr: AnsiChar): PUtf8Char;
+var
+  c: AnsiChar;
+begin
+  result := nil;
+  if Str = nil then
+    exit;
+  repeat
+    c := Str^;
+    if c = #0 then
+      exit
+    else if c = Chr then
+      break;
+    inc(Str);
+  until false;
+  result := Str;
+end;
+
+function MemCmp(P1, P2: PByteArray; L: PtrInt): integer;
+begin
+  // caller ensured that P1<>nil, P2<>nil and L>0 -> aggressively inlined asm
+  result := 0;
+  if L <= 0 then
+    exit;
+  inc(PtrUInt(P1), PtrUInt(L));
+  inc(PtrUInt(P2), PtrUInt(L));
+  L := -L;
+  repeat
+    if P1[L] <> P2[L] then
+      break;
+    inc(L);
+    if L <> 0 then
+      continue;
+    exit;
+  until false;
+  result := P1[L] - P2[L];
+end;
+
+{$endif CPUX64}
+
+function SynLZcompressdestlen(in_len: integer): integer;
+begin
+  // get maximum possible (worse) compressed size for out_p
+  result := in_len + in_len shr 3 + 16;
+end;
+
+function SynLZdecompressdestlen(in_p: PAnsiChar): integer;
+begin
+  // get uncompressed size from lz-compressed buffer (to reserve memory, e.g.)
+  result := PWord(in_p)^;
+  if result and $8000 <> 0 then
+    result := (result and $7fff) or (integer(PWord(in_p + 2)^) shl 15);
+end;
+
+function SynLZcompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
+var
+  dst_beg,          // initial dst value
+  src_end,          // real last byte available in src
+  src_endmatch,     // last byte to try for hashing
+  o: PAnsiChar;
+  CWbit: byte;
+  CWpoint: PCardinal;
+  v, h, cached, t, tmax: PtrUInt;
+  offset: TOffsets;
+  cache: array[0..4095] of cardinal; // 16KB+16KB=32KB on stack (48KB for cpu64)
+begin
+  dst_beg := dst;
+  // 1. store in_len
+  if size >= $8000 then
+  begin
+    // size in 32KB..2GB -> stored as integer
+    PWord(dst)^ := $8000 or (size and $7fff);
+    PWord(dst + 2)^ := size shr 15;
+    inc(dst, 4);
+  end
+  else
+  begin
+    PWord(dst)^ := size; // size<32768 -> stored as word
+    if size = 0 then
+    begin
+      result := 2;
+      exit;
+    end;
+    inc(dst, 2);
+  end;
+  // 2. compress
+  src_end := src + size;
+  src_endmatch := src_end - (6 + 5);
+  CWbit := 0;
+  CWpoint := pointer(dst);
+  PCardinal(dst)^ := 0;
+  inc(dst, SizeOf(CWpoint^));
+  FillCharFast(offset, SizeOf(offset), 0); // fast 16KB reset to 0
+  // 1. main loop to search using hash[]
+  if src <= src_endmatch then
+    repeat
+      v := PCardinal(src)^;
+      h := ((v shr 12) xor v) and 4095;
+      o := offset[h];
+      offset[h] := src;
+      cached := v xor {%H-}cache[h]; // o=nil if cache[h] is uninitialized
+      cache[h] := v;
+      if (cached and $00ffffff = 0) and
+         (o <> nil) and
+         (src - o > 2) then
+      begin
+        CWpoint^ := CWpoint^ or (cardinal(1) shl CWbit);
+        inc(src, 2);
+        inc(o, 2);
+        t := 1;
+        tmax := src_end - src - 1;
+        if tmax >= (255 + 16) then
+          tmax := (255 + 16);
+        while (o[t] = src[t]) and
+              (t < tmax) do
+          inc(t);
+        inc(src, t);
+        h := h shl 4;
+        // here we have always t>0
+        if t <= 15 then
+        begin
+          // mark 2 to 17 bytes -> size=1..15
+          PWord(dst)^ := integer(t or h);
+          inc(dst, 2);
+        end
+        else
+        begin
+          // mark 18 to (255+16) bytes -> size=0, next byte=t
+          dec(t, 16);
+          PWord(dst)^ := h; // size=0
+          dst[2] := ansichar(t);
+          inc(dst, 3);
+        end;
+      end
+      else
+      begin
+        dst^ := src^;
+        inc(src);
+        inc(dst);
+      end;
+      if CWbit < 31 then
+      begin
+        inc(CWbit);
+        if src <= src_endmatch then
+          continue
+        else
+          break;
+      end
+      else
+      begin
+        CWpoint := pointer(dst);
+        PCardinal(dst)^ := 0;
+        inc(dst, SizeOf(CWpoint^));
+        CWbit := 0;
+        if src <= src_endmatch then
+          continue
+        else
+          break;
+      end;
+    until false;
+  // 2. store remaining bytes
+  if src < src_end then
+    repeat
+      dst^ := src^;
+      inc(src);
+      inc(dst);
+      if CWbit < 31 then
+      begin
+        inc(CWbit);
+        if src < src_end then
+          continue
+        else
+          break;
+      end
+      else
+      begin
+        PCardinal(dst)^ := 0;
+        inc(dst, 4);
+        CWbit := 0;
+        if src < src_end then
+          continue
+        else
+          break;
+      end;
+    until false;
+  result := dst - dst_beg;
+end;
+
+// better code generation with sub-functions for raw decoding
+procedure SynLZdecompress1passub(src, src_end, dst: PAnsiChar; var offset: TOffsets);
+var
+  last_hashed: PAnsiChar; // initial src and dst value
+  {$ifdef CPU64}
+  o: PAnsiChar;
+  {$endif CPU64}
+  CW, CWbit: cardinal;
+  v, t, h: PtrUInt;
+label
+  nextCW;
+begin
+  last_hashed := dst - 1;
+nextCW:
+  CW := PCardinal(src)^;
+  inc(src, 4);
+  CWbit := 1;
+  if src < src_end then
+    repeat
+      if CW and CWbit = 0 then
+      begin
+        dst^ := src^;
+        inc(src);
+        inc(dst);
+        if src >= src_end then
+          break;
+        if last_hashed < dst - 3 then
+        begin
+          inc(last_hashed);
+          v := PCardinal(last_hashed)^;
+          offset[((v shr 12) xor v) and 4095] := last_hashed;
+        end;
+        CWbit := CWbit shl 1;
+        if CWbit <> 0 then
+          continue
+        else
+          goto nextCW;
+      end
+      else
+      begin
+        h := PWord(src)^;
+        inc(src, 2);
+        t := (h and 15) + 2;
+        if t = 2 then
+        begin
+          t := ord(src^) + (16 + 2);
+          inc(src);
+        end;
+        h := h shr 4;
+        {$ifdef CPU64}
+        o := offset[h];
+        if PtrUInt(dst - o) < t then // overlap -> move byte-by-byte
+          MoveByOne(o, dst, t)
+        else if t <= 8 then
+          PInt64(dst)^ := PInt64(o)^ // much faster in practice
+        else
+          MoveFast(o^, dst^, t);     // safe since src_endmatch := src_end-(6+5)
+        {$else}
+        if PtrUInt(dst - offset[h]) < t then
+          MoveByOne(offset[h], dst, t)
+        else if t > 8 then
+          MoveFast(offset[h]^, dst^, t)
+        else
+          PInt64(dst)^ := PInt64(offset[h])^;
+        {$endif CPU64}
+        if src >= src_end then
+          break;
+        if last_hashed < dst then
+          repeat // decompressed bytes should update the hash table
+            inc(last_hashed);
+            v := PCardinal(last_hashed)^;
+            offset[((v shr 12) xor v) and 4095] := last_hashed;
+          until last_hashed >= dst;
+        inc(dst, t);
+        last_hashed := dst - 1;
+        CWbit := CWbit shl 1;
+        if CWbit <> 0 then
+          continue
+        else
+          goto nextCW;
+      end;
+    until false;
+end;
+
+function SynLZdecompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer;
+var
+  offset: TOffsets;
+  src_end: PAnsiChar;
+begin
+  src_end := src + size;
+  result := PWord(src)^;
+  if result = 0 then
+    exit;
+  inc(src, 2);
+  if result and $8000 <> 0 then
+  begin
+    result := (result and $7fff) or (integer(PWord(src)^) shl 15);
+    inc(src, 2);
+  end;
+  SynLZdecompress1passub(src, src_end, dst, offset);
+end;
+
+procedure SynLZdecompress1partialsub(src, dst, src_end, dst_end: PAnsiChar;
+  var offset: TOffsets);
+var
+  last_hashed: PAnsiChar; // initial src and dst value
+  CWbit, CW: integer;
+  v, t, h: PtrUInt;
+  {$ifdef CPU64}
+  o: PAnsiChar;
+  {$endif CPU64}
+label
+  nextCW;
+begin
+  last_hashed := dst - 1;
+nextCW:
+  CW := PCardinal(src)^;
+  inc(src, 4);
+  CWbit := 1;
+  if src < src_end then
+    repeat
+      if CW and CWbit = 0 then
+      begin
+        dst^ := src^;
+        inc(src);
+        inc(dst);
+        if (src >= src_end) or
+           (dst >= dst_end) then
+          break;
+        if last_hashed < dst - 3 then
+        begin
+          inc(last_hashed);
+          v := PCardinal(last_hashed)^;
+          offset[((v shr 12) xor v) and 4095] := last_hashed;
+        end;
+        CWbit := CWbit shl 1;
+        if CWbit <> 0 then
+          continue
+        else
+          goto nextCW;
+      end
+      else
+      begin
+        h := PWord(src)^;
+        inc(src, 2);
+        t := (h and 15) + 2;
+        h := h shr 4;
+        if t = 2 then
+        begin
+          t := ord(src^) + (16 + 2);
+          inc(src);
+        end;
+        if dst + t >= dst_end then
+        begin
+          // avoid buffer overflow by all means
+          MoveByOne(offset[h], dst, dst_end - dst);
+          break;
+        end;
+        {$ifdef CPU64}
+        o := offset[h];
+        if (t <= 8) or
+           (PtrUInt(dst - o) < t) then
+          MoveByOne(o, dst, t)
+        else
+          MoveFast(o^, dst^, t);
+        {$else}
+        if (t <= 8) or
+           (PtrUInt(dst - offset[h]) < t) then
+          MoveByOne(offset[h], dst, t)
+        else
+          MoveFast(offset[h]^, dst^, t);
+        {$endif CPU64}
+        if src >= src_end then
+          break;
+        if last_hashed < dst then
+          repeat
+            inc(last_hashed);
+            v := PCardinal(last_hashed)^;
+            offset[((v shr 12) xor v) and 4095] := last_hashed;
+          until last_hashed >= dst;
+        inc(dst, t);
+        last_hashed := dst - 1;
+        CWbit := CWbit shl 1;
+        if CWbit <> 0 then
+          continue
+        else
+          goto nextCW;
+      end;
+    until false;
+end;
+
+function SynLZdecompress1partial(src: PAnsiChar; size: integer; dst: PAnsiChar;
+  maxDst: integer): integer;
+var
+  offset: TOffsets;
+  src_end: PAnsiChar;
+begin
+  src_end := src + size;
+  result := PWord(src)^;
+  if result = 0 then
+    exit;
+  inc(src, 2);
+  if result and $8000 <> 0 then
+  begin
+    result := (result and $7fff) or (integer(PWord(src)^) shl 15);
+    inc(src, 2);
+  end;
+  if maxDst < result then
+    result := maxDst;
+  if result > 0 then
+    SynLZdecompress1partialsub(src, dst, src_end, dst + result, offset);
+end;
+
+function CompressSynLZ(var Data: RawByteString; Compress: boolean): RawUtf8;
+var
+  DataLen, len: integer;
+  P: PAnsiChar;
+  tmp: TSynTempBuffer;
+begin
+  DataLen := length(Data);
+  if DataLen <> 0 then // '' is compressed and uncompressed to ''
+    if Compress then
+    begin
+      len := SynLZcompressdestlen(DataLen) + 8;
+      P := tmp.Init(len);
+      PCardinal(P)^ := Hash32(pointer(Data), DataLen);
+      len := SynLZcompress1(pointer(Data), DataLen, P + 8);
+      PCardinal(P + 4)^ := Hash32(pointer(P + 8), len);
+      FastSetRawByteString(Data, P, len + 8);
+      {%H-}tmp.Done;
+    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);
+      tmp.Init(len);
+      if (len = 0) or
+         ((SynLZDecompress1(P + 8, DataLen - 8, tmp.buf) = len) and
+          (Hash32(tmp.buf, len) = PCardinal(P)^)) then
+        FastSetRawByteString(Data, tmp.buf, len);
+      {%H-}tmp.Done;
+    end;
+  result := 'synlz';
+end;
+
+function CompressSynLZGetHash32(const Data: RawByteString): cardinal;
+var
+  DataLen: integer;
+  P: PAnsiChar;
+begin
+  DataLen := length(Data);
+  P := pointer(Data);
+  if (DataLen <= 8) or
+     (Hash32(pointer(P + 8), DataLen - 8) <> PCardinal(P + 4)^) then
+    result := 0
+  else
+    result := PCardinal(P)^;
+end;
+
+const
+  RLE_CW = $5a; // any byte would do - this one is nothing special but for me
+
+function RleEncode(dst: PByteArray; v, n: PtrUInt): PByteArray;
+  {$ifdef HASINLINE} inline; {$endif}
+begin
+  if (n > 3) or
+     (v = RLE_CW) then // encode as dst[0]=RLE_CW dst[1]=count dst[2]=value
+  begin
+    v := v shl 16;
+    inc(v, RLE_CW);
+    while n > 255 do
+    begin
+      PCardinal(dst)^ := v + 255 shl 8;
+      dst := @dst[3];
+      dec(n, 255);
+    end;
+    inc(v, n shl 8);
+    result := @dst[3];
+  end
+  else
+  begin
+    inc(v, (v shl 8) + (v shl 16)); // append the value n (=1,2,3) times
+    result := @dst[n]; // seems faster with branchless move
+  end;
+  PCardinal(dst)^ := v;
+end;
+
+function RleCompress(src, dst: PByteArray; srcsize, dstsize: PtrUInt): PtrInt;
+var
+  dststart: PAnsiChar;
+  c, b, n: PtrUInt;
+begin
+  dststart := PAnsiChar(dst);
+  if srcsize <> 0 then
+  begin
+    dstsize := PtrUInt(@dst[dstsize - 3]); // pointer(dstsize) = dstmax
+    b := src[0];
+    n := 0;
+    repeat
+      c := src[0];
+      inc(PByte(src));
+      if c = b then
+      begin
+        inc(n);
+        dec(srcsize);
+        if (srcsize = 0) or
+           (PtrUInt(dst) >= PtrUInt(dstsize)) then
+          break;
+      end
+      else // dedicated if n = 1 then .. branch was slower
+      begin
+        dst := RleEncode(dst, b, n);
+        n := 1;
+        b := c;
+        dec(srcsize);
+        if (srcsize = 0) or
+           (PtrUInt(dst) >= PtrUInt(dstsize)) then
+          break;
+      end;
+    until false;
+    dst := RleEncode(dst, b, n);
+    if PtrUInt(dst) >= PtrUInt(dstsize) then
+    begin
+      result := -1;
+      exit;
+    end;
+  end;
+  result := PAnsiChar(dst) - dststart;
+end;
+
+{$ifdef CPUINTEL}
+  {$ifndef HASNOSSE2}
+    {$define INLINEDSEARCH} // leverage ByteScanIndex() SSE2 asm
+  {$endif HASNOSSE2}
+{$endif CPUINTEL}
+{.$define INLINEDFILL} // actually slower
+
+function RleUnCompress(src, dst: PByteArray; size: PtrUInt): PtrUInt;
+var
+  dststart: PAnsiChar;
+  {$ifdef INLINEDFILL}
+  c: PtrInt;
+  {$endif INLINEDFILL}
+  v: PtrUInt;
+begin
+  dststart := PAnsiChar(dst);
+  if size > 0 then
+    repeat
+      {$ifdef INLINEDSEARCH}
+      if src[0] <> RLE_CW then
+      begin
+        v := ByteScanIndex(src, size, RLE_CW);
+        if PtrInt(v) < 0 then
+          v := size;
+        MoveFast(src^, dst^, v);
+        inc(PByte(src), v);
+        inc(PByte(dst), v);
+        dec(size, v);
+        if size = 0 then
+          break;
+      end;
+      {$else}
+      v := src[0];
+      if v <> RLE_CW then
+      begin
+        dst[0] := v;
+        inc(PByte(dst));
+        inc(PByte(src));
+        dec(size);
+        if size = 0 then
+          break;
+      end
+      else
+      {$endif INLINEDSEARCH}
+      begin // here src[0]=RLE_CW src[1]=count src[2]=value
+        {$ifdef INLINEDFILL}
+        c := src[1];
+        v := src[2];
+        inc(PByte(dst), c);
+        c := -c;
+        repeat
+          dst[c] := v;
+          inc(c);
+        until c = 0;
+        {$else}
+        v := src[1];
+        FillCharFast(dst^, v, src[2]);
+        inc(PByte(dst), v);
+        {$endif INLINEDFILL}
+        inc(PByte(src), 3);
+        dec(size, 3);
+        if PtrInt(size) <= 0 then
+          break;
+      end
+    until false;
+  result := PAnsiChar(dst) - dststart;
+end;
+
+function RleUnCompressPartial(src, dst: PByteArray; size, max: PtrUInt): PtrUInt;
+var
+  dststart: PAnsiChar;
+  v, m: PtrUInt;
+begin
+  dststart := PAnsiChar(dst);
+  inc(max, PtrUInt(dst));
+  while (size > 0) and
+        (PtrUInt(dst) < max) do
+  begin
+    v := src[0];
+    if v = RLE_CW then
+    begin
+      v := src[1];
+      m := max - PtrUInt(dst);
+      if v > m then
+        v := m; // compile as cmov on FPC
+      FillCharFast(dst^, v, src[2]);
+      inc(PByte(dst), v);
+      inc(PByte(src), 3);
+      dec(size, 3);
+    end
+    else
+    begin
+      dst[0] := v;
+      inc(PByte(dst));
+      inc(PByte(src));
+      dec(size);
+    end;
+  end;
+  result := PAnsiChar(dst) - dststart;
+end;
+
+
+{ TSynTempBuffer }
+
+procedure TSynTempBuffer.Init(Source: pointer; SourceLen: PtrInt);
+begin
+  len := SourceLen;
+  if SourceLen <= 0 then
+    buf := nil
+  else
+  begin
+    if SourceLen <= SizeOf(tmp) - 16 then // max internal tmp is 4080 bytes
+      buf := @tmp
+    else
+      GetMem(buf, SourceLen + 16); // +16 for trailing #0 and for PInteger() parsing
+    if Source <> nil then
+    begin
+      MoveFast(Source^, buf^, len);
+      PPtrInt(PAnsiChar(buf) + len)^ := 0; // init last 4/8 bytes (for valgrid)
+    end;
+  end;
+end;
+
+function TSynTempBuffer.InitOnStack: pointer;
+begin
+  buf := @tmp;
+  len := SizeOf(tmp);
+  result := @tmp;
+end;
+
+procedure TSynTempBuffer.Init(const Source: RawByteString);
+begin
+  Init(pointer(Source), length(Source));
+end;
+
+function TSynTempBuffer.Init(Source: PUtf8Char): PUtf8Char;
+begin
+  Init(Source, StrLen(Source));
+  result := buf;
+end;
+
+function TSynTempBuffer.Init(SourceLen: PtrInt): pointer;
+begin
+  len := SourceLen;
+  if SourceLen <= 0 then
+    buf := nil
+  else
+  begin
+    if SourceLen <= SizeOf(tmp) - 16 then // max internal tmp is 4080 bytes
+      buf := @tmp
+    else
+      GetMem(buf, SourceLen + 16); // +16 for trailing #0 and buffer overflow
+    PPtrInt(PAnsiChar(buf) + SourceLen)^ := 0; // init last 4/8 bytes
+  end;
+  result := buf;
+end;
+
+function TSynTempBuffer.Init: integer;
+begin
+  buf := @tmp;
+  result := SizeOf(tmp) - 16; // set to maximum safe size, which is 4080 bytes
+  len := result;
+end;
+
+function TSynTempBuffer.InitRandom(RandomLen: integer): pointer;
+begin
+  Init(RandomLen);
+  RandomBytes(buf, RandomLen);
+  result := buf;
+end;
+
+function TSynTempBuffer.InitIncreasing(Count, Start: PtrInt): PIntegerArray;
+begin
+  Init((Count - Start) * 4);
+  FillIncreasing(buf, Start, Count);
+  result := buf;
+end;
+
+function TSynTempBuffer.InitZero(ZeroLen: PtrInt): pointer;
+begin
+  if ZeroLen = 0 then
+    ZeroLen := SizeOf(tmp) - 16;
+  Init(ZeroLen);
+  FillCharFast(buf^, ZeroLen, 0);
+  result := buf;
+end;
+
+function TSynTempBuffer.BufEnd: pointer;
+begin
+  result := PAnsiChar(buf) + len;
+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;
+
+
+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;
+
+function IsZero(P: pointer; Length: integer): boolean;
+var
+   n: integer;
+begin
+  result := false;
+  n := Length shr 4;
+  if n <> 0 then
+    repeat // 16 bytes (4 DWORD) by loop - aligned read
+      {$ifdef CPU64}
+      if (PInt64(P)^ <> 0) or
+         (PInt64Array(P)^[1] <> 0) then
+      {$else}
+      if (PCardinal(P)^ <> 0) or
+         (PCardinalArray(P)^[1] <> 0) or
+         (PCardinalArray(P)^[2] <> 0) or
+         (PCardinalArray(P)^[3] <> 0) then
+      {$endif CPU64}
+          exit
+        else
+          inc(PByte(P), 16);
+      dec(n);
+    until n = 0;
+  n := (Length shr 2) and 3;
+  if n <> 0 then
+    repeat // 4 bytes (1 DWORD) by loop
+      if PCardinal(P)^ <> 0 then
+        exit
+      else
+        inc(PByte(P), 4);
+        dec(n);
+    until n = 0;
+  n := Length and 3;
+  if n <> 0 then
+    repeat // remaining content
+      if PByte(P)^ <> 0 then
+        exit
+      else
+        inc(PByte(P));
+      dec(n);
+    until n = 0;
+  result := true;
+end;
+
+function IsZeroSmall(P: pointer; Length: PtrInt): boolean;
+begin
+  result := false;
+  inc(PtrUInt(P), PtrUInt(Length));
+  Length := -Length;
+  repeat
+    if PByteArray(P)[Length] <> 0 then
+      exit;
+    inc(Length);
+  until Length = 0;
+  result := true;
+end;
+
+function crc32cfast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
+begin
+  result := crc32fasttab(crc, buf, len, @crc32ctab);
+end;
+
+function crc32fast(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
+begin
+  result := crc32fasttab(crc, buf, len, @crc32tab);
+end;
+
+function crc32cBy4fast(crc, value: cardinal): cardinal;
+var
+  tab: PCrc32tab;
+begin
+  tab := @crc32ctab;
+  result := crc xor value;
+  result := tab[3, ToByte(result)]        xor tab[2, ToByte(result shr 8)] xor
+            tab[1, ToByte(result shr 16)] xor tab[0, ToByte(result shr 24)];
+end;
+
+{$ifdef HASINLINE}
+
+function crc32cinlined(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
+var
+  tab: PCrc32tab;
+begin
+  result := not crc;
+  tab := @crc32ctab;
+  if len > 0 then
+    repeat
+      result := tab[0, ToByte(result xor ord(buf^))] xor (result shr 8);
+      inc(buf);
+      dec(len);
+    until len = 0;
+  result := not result;
+end;
+
+{$else}
+
+function crc32cinlined(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal;
+begin
+  result := crc32c(crc, buf, len);
+end;
+
+{$endif HASINLINE}
+
+function crc64c(buf: PAnsiChar; len: cardinal): Int64;
+var
+  lo: PtrInt;
+begin
+  lo := crc32c(0, buf, len);
+  result := Int64(lo) or (Int64(crc32c(lo, buf, len)) shl 32);
+end;
+
+function crc32cTwice(seed: QWord; buf: PAnsiChar; len: cardinal): QWord;
+begin
+  PQWordRec(@result)^.L := crc32c(PQWordRec(@seed)^.L, buf, len);
+  PQWordRec(@result)^.H := crc32c(PQWordRec(@seed)^.H, buf, len);
+end;
+
+function crc63c(buf: PAnsiChar; len: cardinal): Int64;
+var
+  lo: PtrInt;
+begin
+  lo := crc32c(0, buf, len);
+  result := Int64(lo) or (Int64(crc32c(lo, buf, len) and $7fffffff) shl 32);
+end;
+
+procedure crc128c(buf: PAnsiChar; len: cardinal; out crc: THash128);
+var
+  h: THash128Rec absolute crc;
+  h1, h2: cardinal;
+begin
+  // see https://goo.gl/Pls5wi
+  h1 := crc32c(0, buf, len);
+  h2 := crc32c(h1, buf, len);
+  h.i0 := h1;
+  inc(h1, h2);
+  h.i1 := h1;
+  inc(h1, h2);
+  h.i2 := h1;
+  inc(h1, h2);
+  h.i3 := h1;
+end;
+
+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;
+
+procedure crc32c128(hash: PHash128; buf: PAnsiChar; len: cardinal);
+var
+  blocks: cardinal;
+begin
+  blocks := len shr 4;
+  if blocks <> 0 then
+  begin
+    crcblocks(pointer(hash), pointer(buf), blocks);
+    blocks := blocks shl 4;
+    inc(buf, blocks);
+    dec(len, blocks);
+  end;
+  if len <> 0 then
+    with PHash128Rec(hash)^ do
+    begin
+      c0 := crc32c(c0, buf, len);
+      c1 := crc32c(c1, buf, len);
+      c2 := crc32c(c2, buf, len);
+      c3 := crc32c(c3, buf, len);
+    end;
+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 DefaultHash(const s: RawByteString): cardinal;
+begin
+  result := DefaultHasher(0, pointer(s), length(s));
+end;
+
+function DefaultHash(const b: TBytes): cardinal;
+begin
+  result := DefaultHasher(0, pointer(b), length(b));
+end;
+
+function crc32cHash(const s: RawByteString): cardinal;
+begin
+  result := crc32c(0, pointer(s), length(s));
+end;
+
+function crc32cHash(const b: TBytes): cardinal;
+begin
+  result := crc32c(0, pointer(b), length(b));
+end;
+
+function Hash128To64(const b: THash128): QWord;
+begin
+  result := THash128Rec(b).L xor (THash128Rec(b).H * QWord(2685821657736338717));
+end;
+
+function xxHash32Mixup(crc: cardinal): cardinal;
+begin
+  result := crc;
+  result := result xor (result shr 15);
+  result := result * 2246822519;
+  result := result xor (result shr 13);
+  result := result * 3266489917;
+  result := result xor (result shr 16);
+end;
+
+procedure crcblockone(crc128, data128: PBlock128; tab: PCrc32tab);
+  {$ifdef HASINLINE} inline; {$endif}
+var
+  c: cardinal;
+begin
+  c := crc128^[0] xor data128^[0];
+  crc128^[0] := tab[3, ToByte(c)]        xor tab[2, ToByte(c shr 8)] xor
+                tab[1, ToByte(c shr 16)] xor tab[0, ToByte(c shr 24)];
+  c := crc128^[1] xor data128^[1];
+  crc128^[1] := tab[3, ToByte(c)]        xor tab[2, ToByte(c shr 8)] xor
+                tab[1, ToByte(c shr 16)] xor tab[0, ToByte(c shr 24)];
+  c := crc128^[2] xor data128^[2];
+  crc128^[2] := tab[3, ToByte(c)]        xor tab[2, ToByte(c shr 8)] xor
+                tab[1, ToByte(c shr 16)] xor tab[0, ToByte(c shr 24)];
+  c := crc128^[3] xor data128^[3];
+  crc128^[3] := tab[3, ToByte(c)]        xor tab[2, ToByte(c shr 8)] xor
+                tab[1, ToByte(c shr 16)] xor tab[0, ToByte(c shr 24)];
+end;
+
+{$ifndef ASMX86} // those functions have their tuned x86 asm version
+
+{$ifdef CPUX64}
+function CompareMem(P1, P2: Pointer; Length: PtrInt): boolean;
+begin
+  result := MemCmp(P1, P2, Length) = 0; // use our SSE2 optimized asm
+end;
+{$else}
+function CompareMem(P1, P2: Pointer; Length: PtrInt): boolean;
+label
+  zero;
+begin
+  // this awfull code compiles well under FPC and Delphi on 32-bit and 64-bit
+  Length := PtrInt(@PAnsiChar(P1)[Length - SizeOf(PtrInt) * 2]); // = 2*PtrInt end
+  if Length >= PtrInt(PtrUInt(P1)) then
+  begin
+    if PPtrInt(PtrUInt(P1))^ <> PPtrInt(P2)^ then // compare first PtrInt bytes
+      goto zero;
+    inc(PPtrInt(P1));
+    inc(PPtrInt(P2));
+    dec(PtrInt(P2), PtrInt(PtrUInt(P1)));
+    PtrInt(PtrUInt(P1)) := PtrInt(PtrUInt(P1)) and  - SizeOf(PtrInt); // align
+    inc(PtrInt(P2), PtrInt(PtrUInt(P1)));
+    if Length >= PtrInt(PtrUInt(P1)) then
+      repeat
+        // compare 4 aligned PtrInt per loop
+        if (PPtrInt(PtrUInt(P1))^ <> PPtrInt(P2)^) or
+           (PPtrIntArray(P1)[1] <> PPtrIntArray(P2)[1]) then
+          goto zero;
+        inc(PByte(P1), SizeOf(PtrInt) * 2);
+        inc(PByte(P2), SizeOf(PtrInt) * 2);
+        if Length < PtrInt(PtrUInt(P1)) then
+          break;
+        if (PPtrInt(PtrUInt(P1))^ <> PPtrInt(P2)^) or
+           (PPtrIntArray(P1)[1] <> PPtrIntArray(P2)[1]) then
+          goto zero;
+        inc(PByte(P1), SizeOf(PtrInt) * 2);
+        inc(PByte(P2), SizeOf(PtrInt) * 2);
+      until Length < PtrInt(PtrUInt(P1));
+  end;
+  dec(Length, PtrInt(PtrUInt(P1)) - SizeOf(PtrInt) * 2); // back to real length
+  if Length >= SizeOf(PtrInt) then
+  begin
+    if PPtrInt(PtrUInt(P1))^ <> PPtrInt(P2)^ then
+      goto zero;
+    inc(PPtrInt(P1));
+    inc(PPtrInt(P2));
+    dec(Length, SizeOf(PtrInt));
+  end;
+  {$ifdef CPU64}
+  if Length >= 4 then
+  begin
+    if PCardinal(P1)^ <> PCardinal(P2)^ then
+      goto zero;
+    inc(PCardinal(P1));
+    inc(PCardinal(P2));
+    dec(Length, 4);
+  end;
+  {$endif CPU64}
+  if Length >= 2 then
+  begin
+    if PWord(P1)^ <> PWord(P2)^ then
+      goto zero;
+    inc(PWord(P1));
+    inc(PWord(P2));
+    dec(Length, 2);
+  end;
+  if Length >= 1 then
+    if PByte(P1)^ <> PByte(P2)^ then
+      goto zero;
+  result := true;
+  exit;
+zero:
+  result := false;
+end;
+{$endif CPUX64}
+
+procedure crcblockfast(crc128, data128: PBlock128);
+begin
+  crcblockone(crc128, data128, @crc32ctab);
+end;
+
+function fnv32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
+var
+  i: PtrInt;
+begin
+  if buf <> nil then
+    for i := 0 to len - 1 do
+      crc := (crc xor ord(buf[i])) * 16777619;
+  result := crc;
+end;
+
+function kr32(crc: cardinal; buf: PAnsiChar; len: PtrInt): cardinal;
+var
+  i: PtrInt;
+begin
+  if buf <> nil then
+    for i := 0 to len - 1 do
+    begin
+      crc := crc * 31;
+      inc(crc, ord(buf[i]));
+    end;
+  result := crc;
+end;
+
+procedure YearToPChar(Y: PtrUInt; P: PUtf8Char);
+var
+  d100: PtrUInt;
+  tab: PWordArray;
+begin
+  tab := @TwoDigitLookupW;
+  d100 := Y div 100; // FPC will use fast reciprocal
+  PWordArray(P)[0] := tab[d100];
+  PWordArray(P)[1] := tab[Y - (d100 * 100)];
+end;
+
+{$endif ASMX86}
+
+function CompareBuf(const P1: RawByteString; P2: Pointer; P2Len: PtrInt): integer;
+begin
+  result := ComparePtrInt(length(P1), P2Len);
+  if result = 0 then
+    result := MemCmp(pointer(P1), P2, P2Len);
+end;
+
+function CompareBuf(const P1, P2: RawByteString): integer;
+begin
+  result := SortDynArrayRawByteString(P1, P2);
+end;
+
+function EqualBuf(const P1, P2: RawByteString): boolean;
+begin
+  result := SortDynArrayRawByteString(P1, P2) = 0;
+end;
+
+procedure crcblocksfast(crc128, data128: PBlock128; count: integer);
+var
+  tab: PCrc32tab; // good enough or PIC or ARM
+begin
+  if count <= 0 then
+    exit;
+  tab := @crc32ctab;
+  repeat
+    crcblockone(crc128, data128, tab); // properly inlined
+    inc(data128);
+    dec(count);
+  until count = 0;
+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 AbsA < AbsB then
+      DoublePrec := AbsA * Res
+    else
+      DoublePrec := AbsB * Res;
+    if DoublePrec < Res then
+      DoublePrec := Res;
+  end;
+  if A < B then
+    result := (B - A) <= DoublePrec
+  else
+    result := (A - B) <= DoublePrec;
+end;
+
+function SameValueFloat(const A, B: TSynExtended; DoublePrec: TSynExtended): boolean;
+var
+  AbsA, AbsB, Res: TSynExtended;
+begin
+  if DoublePrec = 0 then
+  begin
+    // Max(Min(Abs(A),Abs(B))*1E-12,1E-12)
+    AbsA := Abs(A);
+    AbsB := Abs(B);
+    Res := 1E-12; // also for TSynExtended (FPC uses 1E-4!)
+    if AbsA < AbsB then
+      DoublePrec := AbsA * Res
+    else
+      DoublePrec := AbsB * Res;
+    if DoublePrec < Res then
+      DoublePrec := Res;
+  end;
+  if A < B then
+    result := (B - A) <= DoublePrec
+  else
+    result := (A - B) <= DoublePrec;
+end;
+
+function CompareFloat(const A, B: double): integer;
+begin
+  result := ord(A > B) - ord(A < B);
+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;
+
+
+{ ************ Efficient Variant Values Conversion }
+
+procedure SetVariantNull(var Value: variant);
+begin
+  VarClearAndSetType(Value, varNull);
+end;
+
+procedure ClearVariantForString(var Value: variant);
+var
+  v: cardinal;
+begin
+  v := TVarData(Value).VType;
+  if v = varString then
+    FastAssignNew(TVarData(Value).VAny)
+  else
+  begin
+    VarClearAndSetType(Value, varString);
+    TVarData(Value).VAny := nil; // to avoid GPF when assigning the value
+  end;
+end;
+
+procedure RawByteStringToVariant(Data: PByte; DataLen: integer; var Value: variant);
+begin
+  ClearVariantForString(Value);
+  if (Data = nil) or
+     (DataLen <= 0) then
+    PCardinal(@Value)^ := varNull
+  else
+    FastSetRawByteString(RawByteString(TVarData(Value).VAny), Data, DataLen);
+end;
+
+procedure RawByteStringToVariant(const Data: RawByteString; var Value: variant);
+begin
+  ClearVariantForString(Value);
+  if Data = '' then
+    PCardinal(@Value)^ := varNull
+  else
+    RawByteString(TVarData(Value).VAny) := Data;
+end;
+
+procedure VariantToUtf8(const Value: variant; var Dest: RawByteString);
+begin // sub-proc to avoid hidden temp variable in VariantToRawByteString
+  Dest := {$ifdef UNICODE}RawByteString{$else}string{$endif}(Value);
+end;
+
+procedure VariantToRawByteString(const Value: variant; var Dest: RawByteString);
+begin
+  case integer(TVarData(Value).VType) of
+    varEmpty,
+    varNull:
+      Dest := '';
+    varString:
+      Dest := RawByteString(TVarData(Value).VAny);
+    varStringByRef:
+      Dest := PRawByteString(TVarData(Value).VAny)^;
+    varVariantByRef:
+      VariantToRawByteString(PVariant(TVarData(Value).VPointer)^, Dest);
+    else // not from RawByteStringToVariant() -> conversion to string
+      VariantToUtf8(Value, Dest);
+  end;
+end;
+
+function VarDataFromVariant(const Value: variant): PVarData;
+begin
+  result := @Value;
+  repeat
+    if integer(result^.VType) <> varVariantByRef then
+      exit;
+    if result^.VPointer <> nil then
+      result := result^.VPointer
+    else
+    begin
+      result := @result^.VPointer; // so VType will point to 0=varEmpty
+      exit;
+    end;
+  until false;
+end;
+
+function VarDataIsEmptyOrNull(VarData: pointer): boolean;
+begin
+  with VarDataFromVariant(PVariant(VarData)^)^ do
+    result := (cardinal(VType) <= varNull) or
+              (cardinal(VType) = varNull or varByRef);
+end;
+
+function VarIsEmptyOrNull(const V: Variant): boolean;
+begin
+  with VarDataFromVariant(V)^ do
+    result := (cardinal(VType) <= varNull) or
+              (cardinal(VType) = varNull or varByRef);
+end;
+
+function SetVariantUnRefSimpleValue(const Source: variant;
+  var Dest: TVarData): boolean;
+var
+  typ: cardinal;
+begin
+  result := false;
+  typ := TVarData(Source).VType;
+  if typ and varByRef = 0 then
+    exit;
+  typ := typ and not varByRef;
+  case typ of
+    varVariant:
+      if integer(PVarData(TVarData(Source).VPointer)^.VType) in VTYPE_SIMPLE then
+      begin
+        Dest := PVarData(TVarData(Source).VPointer)^;
+        result := true;
+      end;
+    varEmpty..varDate,
+    varBoolean,
+    varShortInt..varWord64:
+      begin
+        PCardinal(@Dest)^ := typ;
+        Dest.VInt64 := PInt64(TVarData(Source).VAny)^;
+        result := true;
+      end;
+  end;
+end;
+
+function SetVarDataUnRefSimpleValue(V: PVarData; var tmp: TVarData): PVarData;
+  {$ifdef HASINLINE}inline;{$endif}
+var
+  typ: cardinal;
+begin
+  typ := V^.VType;
+  if typ and varByRef <> 0 then
+  begin
+    typ := typ and not varByRef;
+    if typ in VTYPE_SIMPLE then
+    begin
+      PCardinal(@tmp)^ := typ;
+      tmp.VInt64 := PInt64(V^.VAny)^;
+      result := @tmp;
+      exit;
+    end
+  end;
+  result := nil;
+end;
+
+function VariantToInteger(const V: Variant; var Value: integer): boolean;
+var
+  vd: PVarData;
+  tmp: TVarData;
+begin
+  result := false;
+  vd := VarDataFromVariant(V);
+  repeat
+    case cardinal(vd^.VType) of
+      varNull,
+      varEmpty:
+        Value := 0;
+      varBoolean:
+        if vd^.VBoolean then
+          Value := 1
+        else
+          Value := 0; // normalize
+      varSmallint:
+        Value := vd^.VSmallInt;
+      varShortInt:
+        Value := vd^.VShortInt;
+      varWord:
+        Value := vd^.VWord;
+      varLongWord,
+      varOleUInt:
+        if vd^.VLongWord <= cardinal(High(integer)) then
+          Value := vd^.VLongWord
+        else
+          exit;
+      varByte:
+        Value := vd^.VByte;
+      varInteger,
+      varOleInt:
+        Value := vd^.VInteger;
+      varWord64:
+        if (vd^.VInt64 >= 0) and
+           (vd^.VInt64 <= High(integer)) then
+          Value := vd^.VInt64
+        else
+          exit;
+      varInt64:
+        if (vd^.VInt64 >= Low(integer)) and
+           (vd^.VInt64 <= High(integer)) then
+          Value := vd^.VInt64
+        else
+          exit;
+      varDouble,
+      varDate,
+      varSingle,
+      varCurrency,
+      varString,
+      varOleStr:
+        exit;
+    else
+      begin
+        vd := SetVarDataUnRefSimpleValue(vd, tmp{%H-});
+        if vd <> nil then
+          continue; // avoid a goto
+        exit;
+      end;
+    end;
+    break;
+  until false;
+  result := true;
+end;
+
+function VariantToDouble(const V: Variant; var Value: double): boolean;
+var
+  vd: PVarData;
+  i64: Int64;
+begin
+  vd := VarDataFromVariant(V);
+  result := true;
+  case cardinal(vd^.VType) of
+    varEmpty,
+    varNull:
+      Value := 0;
+    varDouble,
+    varDate:
+      Value := vd^.VDouble;
+    varSingle:
+      Value := vd^.VSingle;
+    varCurrency:
+      CurrencyToDouble(@vd^.VCurrency, Value);
+    varDouble or varByRef,
+    varDate or varByRef:
+      Value := unaligned(PDouble(vd^.VAny)^);
+    varSingle or varByRef:
+      Value := {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}unaligned{$endif}(
+        PSingle(vd^.VAny)^);
+    varCurrency or varByRef:
+      CurrencyToDouble(vd^.VAny, Value);
+  else
+    if VariantToInt64(PVariant(vd)^, i64) then
+      Value := i64
+    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
+  vd: PVarData;
+  tmp: TVarData;
+begin
+  vd := VarDataFromVariant(V);
+  result := true;
+  case cardinal(vd^.VType) of
+    varDouble,
+    varDate:
+      DoubleToCurrency(vd^.VDouble, Value);
+    varSingle:
+      DoubleToCurrency(vd^.VSingle, Value);
+    varCurrency:
+      Value := PCurrency(@vd^.VCurrency)^;
+    varDouble or varByRef,
+    varDate or varByRef:
+      DoubleToCurrency(PDouble(vd^.VAny)^, Value);
+    varSingle or varByRef:
+      DoubleToCurrency(PSingle(vd^.VAny)^, Value);
+    varCurrency or varByRef:
+      Value := PCurrency(vd^.VAny)^;
+  else
+    if VariantToInt64(PVariant(vd)^, tmp.VInt64) then
+      Int64ToCurrency(tmp.VInt64, Value) // also handle varEmpty,varNull
+    else
+      result := false;
+  end;
+end;
+
+function VariantToBoolean(const V: Variant; var Value: boolean): boolean;
+var
+  vd: PVarData;
+  tmp: TVarData;
+begin
+  vd := VarDataFromVariant(V);
+  repeat
+    case cardinal(vd^.VType) of
+      varEmpty,
+      varNull:
+        begin
+          result := false;
+          exit;
+        end;
+      varBoolean: // 16-bit WordBool to 8-bit boolean
+        if vd^.VBoolean then
+          Value := true // normalize
+        else
+          Value := false;
+      varInteger: // coming e.g. from TGetJsonField
+        Value := vd^.VInteger = 1;
+      varString:
+        Value := GetBoolean(vd^.VAny);
+      varOleStr:
+        Value := WideString(vd^.VAny) = 'true';
+    {$ifdef HASVARUSTRING}
+      varUString:
+        Value := UnicodeString(vd^.VAny) = 'true';
+    {$endif HASVARUSTRING}
+    else
+      begin
+        vd := SetVarDataUnRefSimpleValue(vd, tmp{%H-});
+        if vd <> nil then
+          continue;
+        result := false;
+        exit;
+      end;
+    end;
+    break;
+  until false;
+  result := true;
+end;
+
+function VariantToInt64(const V: Variant; var Value: Int64): boolean;
+var
+  vd: PVarData;
+  tmp: TVarData;
+begin
+  vd := VarDataFromVariant(V);
+  repeat
+    case cardinal(vd^.VType) of
+      varNull,
+      varEmpty:
+        Value := 0;
+      varBoolean:
+        if vd^.VBoolean then
+          Value := 1
+        else
+          Value := 0; // normalize
+      varSmallint:
+        Value := vd^.VSmallInt;
+      varShortInt:
+        Value := vd^.VShortInt;
+      varWord:
+        Value := vd^.VWord;
+      varLongWord,
+      varOleUInt:
+        Value := vd^.VLongWord;
+      varByte:
+        Value := vd^.VByte;
+      varInteger,
+      varOleInt:
+        Value := vd^.VInteger;
+      varWord64:
+        if vd^.VInt64 >= 0 then
+          Value := vd^.VInt64
+        else
+        begin
+          result := false;
+          exit;
+        end;
+      varInt64:
+        Value := vd^.VInt64;
+    else
+      begin
+        vd := SetVarDataUnRefSimpleValue(vd, tmp{%H-});
+        if vd <> nil then
+          continue;
+        result := false;
+        exit;
+      end;
+    end;
+    break;
+  until false;
+  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;
+
+procedure RawUtf8ToVariant(Txt: PUtf8Char; TxtLen: integer; var Value: variant);
+begin
+  ClearVariantForString(Value);
+  FastSetString(RawUtf8(TVarData(Value).VString), Txt, TxtLen);
+end;
+
+procedure RawUtf8ToVariant(const Txt: RawUtf8; var Value: variant);
+begin
+  ClearVariantForString(Value);
+  if Txt = '' then
+    exit;
+  RawUtf8(TVarData(Value).VAny) := Txt;
+  EnsureRawUtf8(RawByteString(TVarData(Value).VAny));
+end;
+
+function RawUtf8ToVariant(const Txt: RawUtf8): variant;
+begin
+  RawUtf8ToVariant(Txt, result{%H-});
+end;
+
+procedure VariantStringToUtf8(const V: Variant; var result: RawUtf8);
+begin
+  with VarDataFromVariant(V)^ do
+    if cardinal(VType) = varString then
+      result := RawUtf8(VString)
+    else
+      result := '';
+end;
+
+function VariantStringToUtf8(const V: Variant): RawUtf8;
+begin
+  VariantStringToUtf8(V, result{%H-});
+end;
+
+procedure _VariantClearSeveral(V: PVariant; n: integer);
+begin
+  if n > 0 then
+    repeat
+      VarClear(V^);
+      inc(V);
+      dec(n);
+    until n = 0;
+end;
+
+function VariantCompSimple(const A, B: variant): integer;
+var
+  a64, b64: Int64;
+  af64, bf64: double;
+begin
+  // directly handle ordinal and floating point values
+  if VariantToInt64(A, a64) and
+     VariantToInt64(B, b64) then
+    result := CompareInt64(a64, b64)
+  else if VariantToDouble(A, af64) and
+          VariantToDouble(B, bf64) then
+    result := CompareFloat(af64, bf64)
+  else
+    // inlined VarCompareValue() for complex/mixed types
+    if A = B then
+      result := 0
+    else if A < B then // both FPC and Delphi RTL require these two comparisons
+      result := -1
+    else
+      result := 1;
+end;
+
+function _SortDynArrayVariantComp(const A, B: TVarData;
+  {%H-}caseInsensitive: boolean): integer;
+// caseInsensitive not supported by the RTL -> include mormot.core.variants
+begin
+  result := VariantCompSimple(PVariant(@A)^, PVariant(@B)^);
+end;
+
+
+{ ************ Sorting/Comparison Functions }
+
+function SortMatch(CompareResult: integer; CompareOperator: TCompareOperator): boolean;
+begin
+  case CompareOperator of
+    coEqualTo:
+      result := CompareResult = 0;
+    coNotEqualTo:
+      result := CompareResult <> 0;
+    coLessThan:
+      result := CompareResult < 0;
+    coLessThanOrEqualTo:
+      result := CompareResult <= 0;
+    coGreaterThan:
+      result := CompareResult > 0;
+  // coGreaterThanOrEqualTo:
+  else
+    result := CompareResult >= 0;
+  end;
+end;
+
+function SortDynArrayVariant(const A, B): integer;
+begin
+  result := SortDynArrayVariantComp(TVarData(A), TVarData(B), {caseins=}false);
+end;
+
+function SortDynArrayVariantI(const A, B): integer;
+begin
+  result := SortDynArrayVariantComp(TVarData(A), TVarData(B), {caseins=}true);
+end;
+
+function SortDynArrayBoolean(const A, B): integer;
+begin
+  if boolean(A) then // normalize (seldom used, anyway)
+    if boolean(B) then
+      result := 0
+    else
+      result := 1
+  else if boolean(B) then
+    result := -1
+  else
+    result := 0;
+end;
+
+function SortDynArrayByte(const A, B): integer;
+begin
+  result := byte(A) - byte(B);
+end;
+
+function SortDynArraySmallint(const A, B): integer;
+begin
+  result := smallint(A) - smallint(B);
+end;
+
+function SortDynArrayShortint(const A, B): integer;
+begin
+  result := shortint(A) - shortint(B);
+end;
+
+function SortDynArrayWord(const A, B): integer;
+begin
+  result := word(A) - word(B);
+end;
+
+function SortDynArrayExtended(const A, B): integer;
+begin
+  result := ord(TSynExtended(A) > TSynExtended(B)) - ord(TSynExtended(A) < TSynExtended(B));
+end;
+
+function SortDynArrayString(const A, B): integer;
+begin
+  {$ifdef UNICODE}
+  result := StrCompW(PWideChar(A), PWideChar(B));
+  {$else}
+  {$ifdef CPUINTEL}
+  result := SortDynArrayAnsiString(A, B); // has its own optimized asm
+  {$else}
+  result := StrComp(PUtf8Char(A), PUtf8Char(B));
+  {$endif CPUINTEL}
+  {$endif UNICODE}
+end;
+
+function SortDynArrayUnicodeString(const A, B): integer;
+begin
+  // works for both tkWString and tkUString
+  result := StrCompW(PWideChar(A), PWideChar(B));
+end;
+
+function CompareHash(A, B: PPointer; Len: integer): integer;
+  {$ifdef HASINLINE}inline;{$endif}
+begin
+  repeat
+    result := ComparePointer(A^, B^); // on FPC inlined is better than explicit
+    if result <> 0 then
+      exit; // trailing register-size memory is seldom equal during sort
+    inc(A);
+    inc(B);
+    dec(Len);
+  until Len = 0;
+end;
+
+function SortDynArray128(const A, B): integer;
+begin
+  {$ifdef CPU64}
+  result := ord(THash128Rec(A).L > THash128Rec(B).L) -
+            ord(THash128Rec(A).L < THash128Rec(B).L);
+  if result = 0 then
+    result := ord(THash128Rec(A).H > THash128Rec(B).H) -
+              ord(THash128Rec(A).H < THash128Rec(B).H);
+  {$else}
+  result := CompareHash(@A, @B, SizeOf(THash128) div SizeOf(pointer));
+  {$endif CPU64}
+end;
+
+function SortDynArray256(const A, B): integer;
+begin
+  result := CompareHash(@A, @B, SizeOf(THash256) div SizeOf(pointer));
+end;
+
+function SortDynArray512(const A, B): integer;
+begin
+  result := CompareHash(@A, @B, SizeOf(THash512) div SizeOf(pointer));
+end;
+
+function SortDynArrayPUtf8Char(const A, B): integer;
+begin
+  result := StrComp(pointer(A), pointer(B));
+end;
+
+function SortDynArrayShortString(const A, B): integer;
+var
+  sa: shortstring absolute A;
+  sb: shortstring absolute B;
+  la, lb: PtrInt;
+begin
+  la := ord(sa[0]);
+  lb := ord(sb[0]);
+  if la < lb then
+    la := lb;
+  result := MemCmp(@sa[1], @sb[1], la);
+  if result = 0 then
+    result := ord(sa[0]) - ord(sb[0]);
+end;
+
+
+{$if not defined(CPUX64ASM) and not defined(CPUX86)} // fallback if no asm
+
+procedure DynArrayHashTableAdjust(P: PIntegerArray; deleted: integer; count: PtrInt);
+begin
+  repeat
+    dec(count, 8);
+    dec(P[0], ord(P[0] > deleted)); // branchless code is 10x faster than if :)
+    dec(P[1], ord(P[1] > deleted));
+    dec(P[2], ord(P[2] > deleted));
+    dec(P[3], ord(P[3] > deleted));
+    dec(P[4], ord(P[4] > deleted));
+    dec(P[5], ord(P[5] > deleted));
+    dec(P[6], ord(P[6] > deleted));
+    dec(P[7], ord(P[7] > deleted));
+    P := @P[8];
+  until count < 8;
+  while count > 0 do
+  begin
+    dec(count);
+    dec(P[count], ord(P[count] > deleted));
+  end;
+end;
+
+procedure DynArrayHashTableAdjust16(P: PWordArray; deleted: cardinal; count: PtrInt);
+begin
+  repeat // branchless code is 10x faster than if :)
+    dec(count, 8);
+    dec(P[0], cardinal(P[0] > deleted));
+    dec(P[1], cardinal(P[1] > deleted));
+    dec(P[2], cardinal(P[2] > deleted));
+    dec(P[3], cardinal(P[3] > deleted));
+    dec(P[4], cardinal(P[4] > deleted));
+    dec(P[5], cardinal(P[5] > deleted));
+    dec(P[6], cardinal(P[6] > deleted));
+    dec(P[7], cardinal(P[7] > deleted));
+    P := @P[8];
+  until count < 8;
+  while count > 0 do
+  begin
+    dec(count);
+    dec(P[count], cardinal(P[count] > deleted));
+  end;
+end;
+
+{$ifend}
+
+procedure ExchgPointer(n1, n2: PPointer);
+var
+  n: pointer;
+begin
+  n := n2^;
+  n2^ := n1^;
+  n1^ := n;
+end;
+
+procedure ExchgPointers(n1, n2: PPointer; count: PtrInt);
+var
+  n: pointer;
+begin
+  repeat
+    n := n2^;
+    n2^ := n1^;
+    n1^ := n;
+    inc(n1);
+    inc(n2);
+    dec(count);
+  until count = 0;
+end;
+
+procedure ExchgVariant(v1, v2: PPtrIntArray);
+var
+  c: PtrInt; // 32-bit: 16 bytes = 4 PtrInt; 64-bit: 24 bytes = 3 PtrInt
+begin
+  c := v2[0];
+  v2[0] := v1[0];
+  v1[0] := c;
+  c := v2[1];
+  v2[1] := v1[1];
+  v1[1] := c;
+  c := v2[2];
+  v2[2] := v1[2];
+  v1[2] := c;
+  {$ifdef CPU32}
+  c := v2[3];
+  v2[3] := v1[3];
+  v1[3] := c;
+  {$endif CPU32}
+end;
+
+procedure Exchg(P1, P2: PAnsiChar; count: PtrInt);
+var
+  i, c: PtrInt;
+  u: AnsiChar;
+begin
+  i := count shr POINTERSHR;
+  if i <> 0 then
+    repeat
+      c := PPtrInt(P1)^;
+      PPtrInt(P1)^ := PPtrInt(P2)^;
+      PPtrInt(P2)^ := c;
+      inc(P1, SizeOf(c));
+      inc(P2, SizeOf(c));
+      dec(i);
+    until i = 0;
+  i := count and POINTERAND;
+  if i <> 0 then
+    repeat
+      dec(i);
+      u := P1[i];
+      P1[i] := P2[i];
+      P2[i] := u;
+    until i = 0;
+end;
+
+
+{ ************ Some Convenient TStream descendants }
+
+{ TStreamWithPosition }
+
+{$ifdef FPC}
+function TStreamWithPosition.GetPosition: Int64;
+begin
+  result := fPosition;
+end;
+{$endif FPC}
+
+function TStreamWithPosition.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
+var
+  size: Int64;
+begin
+  if (Offset <> 0) or
+     (Origin <> soCurrent) then
+  begin
+    size := GetSize;
+    case Origin of
+      soBeginning:
+        result := Offset;
+      soEnd:
+        result := size - Offset;
+    else
+      result := fPosition + Offset; // soCurrent
+    end;
+    if result > size then
+      result := size
+    else if result < 0 then
+      result := 0;
+    fPosition := result;
+  end
+  else
+    // optimize on Delphi when retrieving TStream.Position as Seek(0,soCurrent)
+    result := fPosition;
+end;
+
+function TStreamWithPosition.Seek(Offset: Longint; Origin: Word): Longint;
+begin
+  result := Seek(Offset, TSeekOrigin(Origin)); // call the 64-bit version above
+end;
+
+
+{ TStreamWithPositionAndSize }
+
+function TStreamWithPositionAndSize.GetSize: Int64;
+begin
+  result := fSize;
+end;
+
+
+{ TRawByteStringStream }
+
+constructor TRawByteStringStream.Create(const aString: RawByteString);
+begin
+  fDataString := aString;
+end;
+
+function TRawByteStringStream.Read(var Buffer; Count: Longint): Longint;
+begin
+  if Count <= 0 then
+    result := 0
+  else
+  begin
+    result := Length(fDataString) - fPosition;
+    if result = 0 then
+      exit;
+    if result > Count then
+      result := Count;
+    MoveFast(PByteArray(fDataString)[fPosition], Buffer, result);
+    inc(fPosition, result);
+  end;
+end;
+
+function TRawByteStringStream.GetSize: Int64;
+begin
+  // faster than the TStream inherited method calling Seek() twice
+  result := length(fDataString);
+end;
+
+procedure TRawByteStringStream.SetSize(NewSize: Longint);
+begin
+  SetLength(fDataString, NewSize);
+  if fPosition > NewSize then
+    fPosition := NewSize;
+end;
+
+function TRawByteStringStream.Write(const Buffer; Count: Longint): Longint;
+begin
+  result := Count;
+  if result > 0 then
+    if fDataString = '' then // inlined FastSetString()
+    begin
+      pointer(fDataString) := FastNewString(result, CP_UTF8);
+      MoveFast(Buffer, pointer(fDataString)^, result);
+      fPosition := result;
+    end
+    else
+    begin
+      if fPosition + result > length(fDataString) then
+        SetLength(fDataString, fPosition + result); // resize
+      MoveFast(Buffer, PByteArray(fDataString)[fPosition], result);
+      inc(fPosition, result);
+    end;
+end;
+
+procedure TRawByteStringStream.GetAsText(StartPos, Len: PtrInt; var Text: RawUtf8);
+var
+  L: PtrInt;
+begin
+  if StartPos < 0 then
+    StartPos := 0;
+  L := length(fDataString);
+  if (L = 0) or
+     (StartPos >= L) then
+    FastAssignNew(Text) // nothing to return
+  else if (StartPos = 0) and
+          (Len = L) and
+          (PStrCnt(PAnsiChar(pointer(fDataString)) - _STRCNT)^ = 1) then
+    FastAssignUtf8(Text, fDataString) // fast return the fDataString instance
+  else
+  begin
+    dec(L, StartPos);
+    if Len > L then
+      Len := L; // avoid any buffer overflow
+    FastSetString(Text, @PByteArray(fDataString)[StartPos], Len);
+  end;
+end;
+
+procedure TRawByteStringStream.Clear;
+begin
+  fPosition := 0;
+  fDataString := '';
+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
+  result := RaiseStreamError(self, 'Write');
+end;
+
+
+function {%H-}RaiseStreamError(Caller: TObject; const Context: shortstring): PtrInt;
+begin
+  raise EStreamError.CreateFmt('Unexpected %s.%s', [ClassNameShort(Caller)^, Context]);
+end;
+
+procedure crc32tabInit(polynom: cardinal; var tab: TCrc32tab);
+var
+  i, n: PtrUInt;
+  crc: cardinal;
+begin // 256 bytes of code to generate 2 x 8KB lookup tables
+  i := 0;
+  repeat // unrolled branchless root lookup table generation
+    crc := cardinal(-(i and 1) and polynom) xor (i shr 1);
+    crc := cardinal(-(crc and 1) and polynom) xor (crc shr 1);
+    crc := cardinal(-(crc and 1) and polynom) xor (crc shr 1);
+    crc := cardinal(-(crc and 1) and polynom) xor (crc shr 1);
+    crc := cardinal(-(crc and 1) and polynom) xor (crc shr 1);
+    crc := cardinal(-(crc and 1) and polynom) xor (crc shr 1);
+    crc := cardinal(-(crc and 1) and polynom) xor (crc shr 1);
+    crc := cardinal(-(crc and 1) and polynom) xor (crc shr 1);
+    tab[0, i] := crc;
+    if i = 255 then
+      break;
+    inc(i);
+  until false;
+  i := 0;
+  repeat // expand the root lookup table for by-8 fast computation
+    crc := tab[0, i];
+    for n := 1 to high(tab) do
+    begin
+      crc := (crc shr 8) xor tab[0, ToByte(crc)];
+      tab[n, i] := crc;
+    end;
+    inc(i);
+  until i > 256;
+end;
+
+procedure InitializeUnit;
+begin
+  assert(ord(high(TSynLogLevel)) = 31);
+  // initialize internal constants
+  crc32tabInit(2197175160, crc32ctab); // crc32c() reversed polynom
+  crc32tabInit(3988292384, crc32tab);  // crc32() = zlib's reversed polynom
+  // setup minimalistic global functions - overriden by other core units
+  VariantClearSeveral     := @_VariantClearSeveral;
+  SortDynArrayVariantComp := @_SortDynArrayVariantComp;
+  // initialize CPU-specific asm
+  TestCpuFeatures;
+end;
+
+
+initialization
+  InitializeUnit;
+
+end.
+
diff --git a/lib/dmustache/mormot.core.buffers.pas b/lib/dmustache/mormot.core.buffers.pas
new file mode 100644
index 00000000..e350c695
--- /dev/null
+++ b/lib/dmustache/mormot.core.buffers.pas
@@ -0,0 +1,11414 @@
+/// Framework Core Low-Level Memory Buffer Process
+// - this unit is a part of the Open Source Synopse mORMot framework 2,
+// licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+unit mormot.core.buffers;
+
+{
+  *****************************************************************************
+
+   Low-Level Memory Buffers Processing Functions shared by all framework units
+   - Variable Length Integer Encoding / Decoding
+   - TAlgoCompress Compression/Decompression Classes - with AlgoSynLZ AlgoRleLZ
+   - TFastReader / TBufferWriter Binary Streams
+   - Base64, Base64Uri, Base58 and Baudot Encoding / Decoding
+   - URI-Encoded Text Buffer Process
+   - Basic MIME Content Types Support
+   - Text Memory Buffers and Files
+   - TStreamRedirect and other Hash process
+   - Markup (e.g. HTML or Emoji) process
+   - RawByteString Buffers Aggregation via TRawByteStringGroup
+
+  *****************************************************************************
+}
+
+interface
+
+{$I mormot.defines.inc}
+
+uses
+  classes,
+  sysutils,
+  mormot.core.base,
+  mormot.core.os,
+  mormot.core.unicode,
+  mormot.core.text,
+  mormot.core.rtti;
+
+
+{ ************ Variable Length Integer Encoding / Decoding }
+
+/// convert a cardinal into a 32-bit variable-length integer buffer
+function ToVarUInt32(Value: cardinal; Dest: PByte): PByte;
+
+/// return the number of bytes necessary to store a 32-bit variable-length integer
+// - i.e. the ToVarUInt32() buffer size
+function ToVarUInt32Length(Value: PtrUInt): PtrUInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// return the number of bytes necessary to store some data with a its
+// 32-bit variable-length integer length
+function ToVarUInt32LengthWithData(Value: PtrUInt): PtrUInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert an integer into a 32-bit variable-length integer buffer
+// - store negative values as cardinal two-complement, i.e.
+// 0=0,1=1,2=-1,3=2,4=-2...
+function ToVarInt32(Value: PtrInt; Dest: PByte): PByte;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a 32-bit variable-length integer buffer into a cardinal
+// - fast inlined process for any number < 128
+// - use overloaded FromVarUInt32() or FromVarUInt32Safe() with a SourceMax
+// pointer to avoid any potential buffer overflow
+// - use FromVarUInt32Big() is the content is likely to be >= 128
+function FromVarUInt32(var Source: PByte): cardinal; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// safely convert a 32-bit variable-length integer buffer into a cardinal
+// - slower but safer process checking out of boundaries memory access in Source
+// - SourceMax is expected to be not nil, and to point to the first byte
+// just after the Source memory buffer
+// - returns nil on error, or point to next input data on successful decoding
+function FromVarUInt32Safe(Source, SourceMax: PByte; out Value: cardinal): PByte;
+
+/// convert a 32-bit variable-length integer buffer into a cardinal
+// - will call FromVarUInt32() if SourceMax=nil, or FromVarUInt32Safe() if set
+// - returns false on error, true if Value has been set properly
+function FromVarUInt32(var Source: PByte; SourceMax: PByte;
+  out Value: cardinal): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a 32-bit variable-length integer buffer into a cardinal
+// - this version could be called if number is likely to be > $7f, so if
+// inlining the first byte won't make any benefit
+function FromVarUInt32Big(var Source: PByte): cardinal;
+
+/// convert a 32-bit variable-length integer buffer into a cardinal
+// - used e.g. when inlining FromVarUInt32()
+// - this version must be called if Source^ has already been checked to be > $7f
+// ! result := Source^;
+// ! inc(Source);
+// ! if result>$7f then
+// !   result := (result and $7F) or FromVarUInt32Up128(Source);
+function FromVarUInt32Up128(var Source: PByte): cardinal;
+
+/// convert a 32-bit variable-length integer buffer into a cardinal
+// - this version must be called if Source^ has already been checked to be > $7f
+function FromVarUInt32High(var Source: PByte): cardinal;
+
+/// convert a 32-bit variable-length integer buffer into an integer
+// - decode negative values from cardinal two-complement, i.e.
+// 0=0,1=1,2=-1,3=2,4=-2...
+function FromVarInt32(var Source: PByte): integer;
+
+/// convert a UInt64 into a 64-bit variable-length integer buffer
+function ToVarUInt64(Value: QWord; Dest: PByte): PByte;
+
+/// convert a 64-bit variable-length integer buffer into a UInt64
+function FromVarUInt64(var Source: PByte): QWord; overload;
+
+/// safely convert a 64-bit variable-length integer buffer into a UInt64
+// - slower but safer process checking out of boundaries memory access in Source
+// - SourceMax is expected to be not nil, and to point to the first byte
+// just after the Source memory buffer
+// - returns nil on error, or point to next input data on successful decoding
+function FromVarUInt64Safe(Source, SourceMax: PByte; out Value: QWord): PByte;
+
+/// convert a 64-bit variable-length integer buffer into a UInt64
+// - will call FromVarUInt64() if SourceMax=nil, or FromVarUInt64Safe() if set
+// - returns false on error, true if Value has been set properly
+function FromVarUInt64(var Source: PByte; SourceMax: PByte;
+  out Value: Qword): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a Int64 into a 64-bit variable-length integer buffer
+function ToVarInt64(Value: Int64; Dest: PByte): PByte;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a 64-bit variable-length integer buffer into a Int64
+function FromVarInt64(var Source: PByte): Int64;
+
+/// convert a 64-bit variable-length integer buffer into a Int64
+// - this version won't update the Source pointer
+function FromVarInt64Value(Source: PByte): Int64;
+
+/// jump a value in the 32-bit or 64-bit variable-length integer buffer
+function GotoNextVarInt(Source: PByte): pointer;
+ {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a RawUtf8 into an UTF-8 encoded variable-length buffer
+function ToVarString(const Value: RawUtf8; Dest: PByte): PByte;
+
+/// jump a value in variable-length text buffer
+function GotoNextVarString(Source: PByte): pointer;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// retrieve a variable-length UTF-8 encoded text buffer in a newly allocation RawUtf8
+function FromVarString(var Source: PByte): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// safe retrieve a variable-length UTF-8 encoded text buffer in a newly allocation RawUtf8
+// - supplied SourceMax value will avoid any potential buffer overflow
+function FromVarString(var Source: PByte; SourceMax: PByte): RawUtf8; overload;
+
+/// retrieve a variable-length UTF-8 encoded text buffer in a newly allocation RawUtf8
+procedure FromVarString(var Source: PByte; var Value: RawUtf8); overload;
+
+/// retrieve a variable-length text buffer
+// - this overloaded function will set the supplied code page to the AnsiString
+procedure FromVarString(var Source: PByte; var Value: RawByteString;
+  CodePage: integer); overload;
+
+/// retrieve a variable-length text buffer
+// - this overloaded function will set the supplied code page to the AnsiString
+// and will also check for the SourceMax end of buffer
+// - returns TRUE on success, or FALSE on any buffer overload detection
+function FromVarString(var Source: PByte; SourceMax: PByte;
+  var Value: RawByteString; CodePage: integer): boolean; overload;
+
+/// retrieve a variable-length UTF-8 encoded text buffer in a temporary buffer
+// - caller should call Value.Done after use of the Value.buf memory
+// - this overloaded function would include a trailing #0, so Value.buf could
+// be parsed as a valid PUtf8Char buffer (e.g. containing JSON)
+procedure FromVarString(var Source: PByte; var Value: TSynTempBuffer); overload;
+
+/// retrieve a variable-length UTF-8 encoded text buffer in a temporary buffer
+// - caller should call Value.Done after use of the Value.buf memory
+// - this overloaded function will also check for the SourceMax end of buffer,
+// returning TRUE on success, or FALSE on any buffer overload detection
+function FromVarString(var Source: PByte; SourceMax: PByte;
+  var Value: TSynTempBuffer): boolean; overload;
+
+type
+  /// kind of result returned by FromVarBlob() function
+  TValueResult = record
+    /// start of data value
+    Ptr: PAnsiChar;
+    /// value length (in bytes)
+    Len: PtrInt;
+  end;
+
+/// retrieve pointer and length to a variable-length text/blob buffer
+function FromVarBlob(Data: PByte): TValueResult;
+  {$ifdef HASINLINE}inline;{$endif}
+
+
+
+{ ************ TAlgoCompress Compression/Decompression Classes }
+
+type
+  /// exception raised by TAlgoCompress classes
+  EAlgoCompress = class(ESynException);
+
+  /// define the implementation used by TAlgoCompress.Decompress()
+  TAlgoCompressLoad = (
+    aclNormal,
+    aclSafeSlow,
+    aclNoCrcFast);
+
+  /// abstract low-level parent class for generic compression/decompression algorithms
+  // - will encapsulate the compression algorithm with crc32c hashing
+  // - all Algo* abstract methods should be overriden by inherited classes
+  // - don't inherit from TSynPersistent since we don't need any of it
+  TAlgoCompress = class
+  protected
+    fAlgoID: byte;
+    fAlgoHasForcedFormat: boolean;
+    fAlgoFileExt: TFileName;
+    procedure EnsureAlgoHasNoForcedFormat(const caller: shortstring);
+  public
+    /// computes by default the crc32c() digital signature of the buffer
+    function AlgoHash(Previous: cardinal;
+      Data: pointer; DataLen: integer): cardinal; overload; virtual;
+    /// computes the digital signature of the buffer, or Hash32() if specified
+    function AlgoHash(ForceHash32: boolean;
+      Data: pointer; DataLen: integer): cardinal; overload;
+    /// 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;
+    /// contains a genuine byte identifier for this algorithm
+    // - 0 is reserved for stored, 1 for TAlgoSynLz, 2/3 for TAlgoDeflate/Fast
+    // (in mormot.core.zip.pas), 4/5/6 for TAlgoLizard/Fast/Huffman
+    // (in mormot.lib.lizard.pas), 7/8 for TAlgoRleLZ/TAlgoRle, 9/10 for limited
+    // TAlgoGZ/TAlgoGZFast (in mormot.core.zip.pas)
+    property AlgoID: byte
+      read fAlgoID;
+    /// the usual file extension of this algorithm
+    // - e.g. '.synlz' or '.synz' or '.synliz' for SynLZ, Deflate or Lizard
+    property AlgoFileExt: TFileName
+      read fAlgoFileExt;
+    /// if this algorithm does not supports our custom storage format
+    // - e.g. AlgoGZ set true and only supports plain buffers and files methods
+    // and would raise EAlgoCompress when stream methods are used
+    property AlgoHasForcedFormat: boolean
+      read fAlgoHasForcedFormat;
+  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 EAlgoCompress 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; virtual;
+    /// finalize this algorithm
+    destructor Destroy; 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; virtual;
+    /// 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; virtual;
+    /// 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; virtual;
+    /// 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; virtual;
+    /// 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; virtual;
+    /// compress a Stream content using this compression algorithm
+    // - source Stream may be read and compressed by ChunkBytes = 4MB chunks
+    // - a 32-bit Magic number identifies the compressed content chunks
+    // - WithTrailer would finish the Dest output with a trailer block to locate
+    // the position of the compressed data, to be used e.g. when it is appended
+    // - follow the StreamSynLZ() deprecated function format, if ForceHash32=true
+    // and WithTrailer=true so that Hash32() is used instead of AlgoHash()
+    function StreamCompress(Source, Dest: TStream; Magic: cardinal;
+      ForceHash32: boolean = false; WithTrailer: boolean = true;
+      ChunkBytes: PtrInt = 4 shl 20): Int64; overload;
+    /// compress a Stream content using this compression algorithm into a file
+    // - just a wrapper around the overloaded StreamCompress() method
+    function StreamCompress(Source: TStream; const DestFile: TFileName;
+      Magic: cardinal; ForceHash32: boolean = false;
+      WithTrailer: boolean = true; ChunkBytes: PtrInt = 4 shl 20): Int64; overload;
+    /// uncompress a Stream previously compressed via StreamCompress()
+    // - you should specify a Magic number to be used to identify the compressed
+    // Stream format
+    // - if Source is not positioned at compressed data beginning, a trailer is
+    // searched at the end of the Source stream to get the proper location
+    // - returns true on success, and false on decoding error - but some chunks
+    // may have been decompressed in Dest even if false is returned
+    function StreamUnCompress(Source, Dest: TStream; Magic: cardinal;
+      ForceHash32: boolean = false): boolean; overload;
+    /// uncompress a Stream previously compressed via StreamCompress()
+    // - return nil on decompression error, or a new TMemoryStream instance
+    // - follow the StreamUnSynLZ() deprecated function format, if ForceHash32=true
+    // so that Hash32() is used instead of the AlgoHash() of this instance
+    function StreamUnCompress(Source: TStream; Magic: cardinal;
+      ForceHash32: boolean = false): TMemoryStream; overload;
+    /// uncompress a File previously compressed via StreamCompress() as TStream
+    // - you should specify a Magic number to be used to identify the compressed
+    // Stream format
+    // - follow the StreamUnSynLZ() deprecated function format, if ForceHash32=true
+    // so that Hash32() is used instead of the AlgoHash() of this instance
+    // - if the compressed data is not at Source file beginning, a trailer is
+    // searched at the end of the Source content to get the proper location
+    function StreamUnCompress(const Source: TFileName; Magic: cardinal;
+      ForceHash32: boolean = false): TMemoryStream; overload;
+    /// compute the length of a given StreamCompress() buffer from its trailer
+    // - allows to replace an existing appended content, for instance
+    // - expects StreamCompress(WithTrailer=true) format
+    function StreamComputeLen(P: PAnsiChar; Len: PtrUInt; Magic: cardinal): integer;
+    /// returns TRUE if the supplied file name is a compressed file,
+    // matching the Magic number as supplied to FileCompress() function
+    // - follow the FileIsSynLZ() deprecated function format
+    // - expects the compressed data to be at file beginning (not appended)
+    // - may be overriden to support a standard file layout (e.g. AlgoGZ)
+    class function FileIsCompressed(const Name: TFileName;
+      Magic: cardinal): boolean; virtual;
+    /// compress a file content using this compression algorithm
+    // - source file is split into ChunkBytes blocks (128 MB by default) for
+    // fast in-memory compression of any file size, then compressed and
+    // including checksums of Source/Dest data
+    // - it is not compatible with StreamCompress format, which has no chunking
+    // - you should specify a Magic number to be used to identify the compressed
+    // file format
+    // - follow the FileSynLZ() deprecated function format, if ForceHash32=true
+    // so that Hash32() is used instead of the AlgoHash() of this instance
+    // - may be overriden to support a standard file layout (e.g. AlgoGZ)
+    function FileCompress(const Source, Dest: TFileName; Magic: cardinal;
+      ForceHash32: boolean = false; ChunkBytes: Int64 = 128 shl 20;
+      WithTrailer: boolean = false): boolean; virtual;
+    /// uncompress a file previously compressed via FileCompress()
+    // - you should specify a Magic number to be used to identify the compressed
+    // file format
+    // - follow the FileUnSynLZ() deprecated function format, if ForceHash32=true
+    // so that Hash32() is used instead of the AlgoHash() of this instance
+    // - may be overriden to support a standard file layout (e.g. AlgoGZ)
+    function FileUnCompress(const Source, Dest: TFileName; Magic: cardinal;
+      ForceHash32: boolean = false): boolean; virtual;
+
+    /// 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(aAlgoID: 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'
+    // TAlgoDeflateFast->'deflatefast'
+    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
+    /// set AlgoID = 1 as genuine byte identifier for SynLZ
+    constructor Create; 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 mainly 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;
+
+  /// implement our SynLZ compression with RLE preprocess as a TAlgoCompress class
+  // - SynLZ is very good with JSON or text, but not so efficient when its input
+  // has a lot of padding (e.g. a database file, or unoptimized raw binary)
+  // - this class would make a first pass with RleCompress() before SynLZ
+  // - if RLE has no effect during compression, will fallback to plain SynLZ
+  // with no RLE pass during decompression
+  TAlgoRleLZ = class(TAlgoCompressWithNoDestLen)
+  protected
+    function RawProcess(src, dst: pointer; srcLen, dstLen, dstMax: integer;
+      process: TAlgoCompressWithNoDestLenProcess): integer; override;
+  public
+    /// set AlgoID = 7 as genuine byte identifier for RLE + SynLZ
+    constructor Create; override;
+    /// get maximum possible (worse) compressed size for the supplied length
+    function AlgoCompressDestLen(PlainLen: integer): integer; override;
+  end;
+
+  /// implement RLE compression as a TAlgoCompress class
+  // - if RLE has no effect during compression, will fallback to plain store
+  TAlgoRle = class(TAlgoCompressWithNoDestLen)
+  protected
+    function RawProcess(src, dst: pointer; srcLen, dstLen, dstMax: integer;
+      process: TAlgoCompressWithNoDestLenProcess): integer; override;
+  public
+    /// set AlgoID = 8 as genuine byte identifier for RLE
+    constructor Create; override;
+    /// get maximum possible (worse) compressed size for the supplied length
+    function AlgoCompressDestLen(PlainLen: integer): integer; override;
+  end;
+
+var
+  /// our fast SynLZ compression as a TAlgoCompress class
+  // - please use this global variable methods instead of the deprecated
+  // SynLZCompress/SynLZDecompress wrapper functions
+  AlgoSynLZ: TAlgoCompress;
+
+  /// SynLZ compression with RLE preprocess as a TAlgoCompress class
+  // - SynLZ is not efficient when its input has a lot of identical characters
+  // (e.g. a database content, or a raw binary buffer) - try with this class
+  // which is slower than AlgoSynLZ but may have better ratio on such content
+  AlgoRleLZ: TAlgoCompress;
+
+  /// Run-Length-Encoding (RLE) compression as a TAlgoCompress class
+  // - if RLE has no effect during compression, will fallback to plain store
+  AlgoRle: TAlgoCompress;
+
+var
+  /// define how files are compressed by TSynLog.PerformRotation
+  // - as used within mormot.core.log.pas unit, and defined in this unit to be
+  // available wihout any dependency to it (e.g. in compression units)
+  // - assigned to AlgoSynLZ by default for .synlz which is the fastest for logs
+  // - you may set AlgoGZFast from mormot.core.zip.pas to generate .gz standard
+  // files during TSynLog file rotation (with libdeflate if available)
+  // - you may set AlgoLizardFast or AlgoLizardHuffman as non-standard
+  // alternatives (default AlgoLizard is much slower and less efficient on logs)
+  // - if you set nil, no compression will take place during rotation
+  // - note that compression itself is run in the logging background thread
+  LogCompressAlgo: TAlgoCompress;
+
+  /// internal wrapper function used by TSynLogArchiveEvent handlers to compress
+  // and delete older .log files using our proprietary FileCompress format for
+  // a given algorithm
+  // - as used within mormot.core.log.pas unit, and defined in this unit to be
+  // available wihout any dependency to it (e.g. in compression units)
+  // - called by EventArchiveLizard/EventArchiveSynLZ to implement
+  // .synlz/.synliz archival
+  LogCompressAlgoArchive: function(aAlgo: TAlgoCompress; aMagic: cardinal;
+    const aOldLogFileName, aDestinationPath: TFileName): boolean;
+
+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);
+
+  COMPRESS_STORED = #0;
+  COMPRESS_SYNLZ = 1;
+
+
+/// 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: TLibHandle = 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: TLibHandle = 0);
+
+{$ifndef PUREMORMOT2}
+
+function StreamSynLZComputeLen(P: PAnsiChar;
+  Len, Magic: cardinal): integer; deprecated;
+function StreamSynLZ(Source: TCustomMemoryStream; Dest: TStream;
+  Magic: cardinal): integer; overload; deprecated;
+function StreamSynLZ(Source: TCustomMemoryStream; const DestFile: TFileName;
+  Magic: cardinal): integer; overload; deprecated;
+function FileSynLZ(const Source, Dest: TFileName; Magic: cardinal): boolean; deprecated;
+function FileUnSynLZ(const Source, Dest: TFileName; Magic: cardinal): boolean; deprecated;
+function FileIsSynLZ(const Name: TFileName; Magic: cardinal): boolean; deprecated;
+function StreamUnSynLZ(const Source: TFileName; Magic: cardinal): TMemoryStream; overload; deprecated;
+function StreamUnSynLZ(Source: TStream; Magic: cardinal): TMemoryStream; overload; deprecated;
+function SynLZCompress(const Data: RawByteString; CompressionSizeTrigger: integer = 100;
+  CheckMagicForCompressed: boolean = false): RawByteString; overload;
+procedure SynLZCompress(P: PAnsiChar; PLen: integer; out Result: RawByteString;
+  CompressionSizeTrigger: integer = 100; CheckMagicForCompressed: boolean = false); overload;
+function SynLZCompress(P, Dest: PAnsiChar; PLen, DestLen: integer;
+  CompressionSizeTrigger: integer = 100; CheckMagicForCompressed: boolean = false): integer; overload;
+function SynLZDecompress(const Data: RawByteString): RawByteString; overload;
+procedure SynLZDecompress(P: PAnsiChar; PLen: integer; out Result: RawByteString;
+  SafeDecompression: boolean = false); overload;
+function SynLZCompressToBytes(const Data: RawByteString;
+  CompressionSizeTrigger: integer = 100): TByteDynArray; overload;
+function SynLZCompressToBytes(P: PAnsiChar; PLen: integer;
+  CompressionSizeTrigger: integer = 100): TByteDynArray; overload;
+function SynLZDecompress(const Data: TByteDynArray): RawByteString; overload;
+function SynLZDecompress(const Data: RawByteString; out Len: integer;
+  var tmp: RawByteString): pointer; overload;
+function SynLZDecompress(P: PAnsiChar; PLen: integer; out Len: integer;
+  var tmp: RawByteString): pointer; overload;
+function SynLZDecompressHeader(P: PAnsiChar; PLen: integer): integer;
+function SynLZDecompressBody(P,Body: PAnsiChar; PLen, BodyLen: integer;
+  SafeDecompression: boolean = false): boolean;
+function SynLZDecompressPartial(P, Partial: PAnsiChar; PLen, PartialLen: integer): integer;
+
+{$endif PUREMORMOT2}
+
+
+{ ****************** TFastReader / TBufferWriter Binary Streams }
+
+type
+  /// exception raised during TFastReader decoding
+  EFastReader = class(ESynException);
+
+  /// event signature to customize TFastReader.ErrorOverflow notification
+  TOnFastReaderErrorOverflow = procedure of object;
+
+  /// event signature to customize TFastReader.ErrorData notification
+  TOnFastReaderErrorData = procedure(const fmt: RawUtf8;
+    const args: array of const) of object;
+
+  /// safe decoding of a TBufferWriter content from an in-memory buffer
+  // - raise a EFastReader exception on decoding error (e.g. if a buffer
+  // overflow may occur) or call OnErrorOverflow/OnErrorData event handlers
+  {$ifdef USERECORDWITHMETHODS}
+  TFastReader = record
+  {$else}
+  TFastReader = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// the current position in the memory
+    P: PAnsiChar;
+    /// the last position in the buffer
+    Last: PAnsiChar;
+    /// use this event to customize the ErrorOverflow process
+    OnErrorOverflow: TOnFastReaderErrorOverflow;
+    /// use this event to customize the ErrorData process
+    OnErrorData: TOnFastReaderErrorData;
+    /// when used to unserialize variants, stores options for TDocVariant creation
+    // - contains a PDocVariantOptions reference pointer as defined in the
+    // mormot.core.data unit
+    CustomVariants: pointer;
+    /// some opaque value, e.g. a version number to define the binary layout
+    Tag: PtrInt;
+    /// initialize the reader from a memory block
+    procedure Init(Buffer: pointer; Len: PtrInt); overload;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// initialize the reader from a RawByteString content
+    procedure Init(const Buffer: RawByteString); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// raise a EFastReader with "Reached End of Input" error message
+    procedure ErrorOverflow;
+    /// raise a EFastReader with "Incorrect Data: ...." error message
+    procedure ErrorData(const fmt: RawUtf8; const args: array of const); overload;
+    /// raise a EFastReader with "Incorrect Data: ...." error message
+    procedure ErrorData(const msg: shortstring); overload;
+    /// read the next 32-bit signed value from the buffer
+    function VarInt32: integer;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// read the next 32-bit unsigned value from the buffer
+    function VarUInt32: cardinal;
+    /// try to read the next 32-bit signed value from the buffer
+    // - don't change the current position
+    function PeekVarInt32(out value: PtrInt): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// try to read the next 32-bit unsigned value from the buffer
+    // - don't change the current position
+    function PeekVarUInt32(out value: PtrUInt): boolean;
+    /// read the next 32-bit unsigned value from the buffer
+    // - this version won't call ErrorOverflow, but return false on error
+    // - returns true on read success
+    function VarUInt32Safe(out Value: cardinal): boolean;
+    /// read the next 64-bit signed value from the buffer
+    function VarInt64: Int64;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// read the next 64-bit unsigned value from the buffer
+    function VarUInt64: QWord;
+    /// read the next RawUtf8 value from the buffer
+    function VarUtf8: RawUtf8; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// read the next RawUtf8 value from the buffer
+    procedure VarUtf8(out result: RawUtf8); overload;
+    /// read the next RawUtf8 value from the buffer
+    // - this version won't call ErrorOverflow, but return false on error
+    // - returns true on read success
+    function VarUtf8Safe(out Value: RawUtf8): boolean;
+    /// read the next RawByteString value from the buffer
+    function VarString: RawByteString; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// read the next RawByteString value from the buffer
+    function VarString(CodePage: integer): RawByteString; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// read the next pointer and length value from the buffer
+    procedure VarBlob(out result: TValueResult); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// read the next pointer and length value from the buffer
+    function VarBlob: TValueResult; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// copy the next VarBlob value from the buffer into a TSynTempBuffer
+    procedure VarBlob(out Value: TSynTempBuffer); overload;
+    /// read the next pointer and length value from the buffer
+    // - this version won't call ErrorOverflow, but return false on error
+    // - returns true on read success
+    function VarBlobSafe(out Value: TValueResult): boolean;
+    /// read the next ShortString value from the buffer
+    function VarShortString: ShortString;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// fast ignore the next VarUInt32/VarInt32/VarUInt64/VarInt64 value
+    // - don't raise any exception, so caller could check explicitly for any EOF
+    procedure VarNextInt; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// fast ignore the next count VarUInt32/VarInt32/VarUInt64/VarInt64 values
+    // - don't raise any exception, so caller could check explicitly for any EOF
+    procedure VarNextInt(count: integer); overload;
+    /// read the next byte from the buffer
+    function NextByte: byte;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// read the next byte from the buffer, checking
+    function NextByteSafe(dest: pointer): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// read the next 2 bytes from the buffer as a 16-bit unsigned value
+    function Next2: cardinal;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// read the next 2 bytes from the buffer as a 16-bit big-endian value
+    function Next2BigEndian: cardinal;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// read the next 4 bytes from the buffer as a 32-bit unsigned value
+    function Next4: cardinal;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// read the next 8 bytes from the buffer as a 64-bit unsigned value
+    function Next8: Qword;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// consumes the next byte from the buffer, if matches a given value
+    function NextByteEquals(Value: byte): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// returns the current position, and move ahead the specified bytes
+    function Next(DataLen: PtrInt): pointer;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// returns the current position, and move ahead the specified bytes
+    function NextSafe(out Data: Pointer; DataLen: PtrInt): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// copy data from the current position, and move ahead the specified bytes
+    procedure Copy(Dest: Pointer; DataLen: PtrInt);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// copy data from the current position, and move ahead the specified bytes
+    // - this version won't call ErrorOverflow, but return false on error
+    // - returns true on read success
+    function CopySafe(Dest: Pointer; DataLen: PtrInt): boolean;
+    /// retrieved cardinal values encoded with TBufferWriter.WriteVarUInt32Array
+    // - Values[] will be resized only if it is not long enough, to spare heap
+    // - returns decoded count in Values[], which may not be length(Values)
+    // - wkFakeMarker will return -count and the caller should make the decoding
+    function ReadVarUInt32Array(var Values: TIntegerDynArray): PtrInt;
+    /// retrieved Int64 values encoded with TBufferWriter.WriteVarUInt64DynArray
+    // - Values[] will be resized only if it is not long enough, to spare heap
+    // - returns decoded count in Values[], which may not be length(Values)
+    function ReadVarUInt64Array(var Values: TInt64DynArray): PtrInt;
+    /// retrieved RawUtf8 values encoded with TFileBufferWriter.WriteRawUtf8DynArray
+    // - returns the number of items read into Values[] (may differ from length(Values))
+    function ReadVarRawUtf8DynArray(var Values: TRawUtf8DynArray): PtrInt;
+    /// retrieve some TAlgoCompress buffer, appended via Write()
+    // - BufferOffset could be set to reserve some bytes before the uncompressed buffer
+    function ReadCompressed(Load: TAlgoCompressLoad = aclNormal;
+      BufferOffset: integer = 0): RawByteString;
+    /// returns TRUE if the current position is the end of the input stream
+    function EOF: boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// returns remaining length (difference between Last and P)
+    function RemainingLength: PtrUInt;
+      {$ifdef HASINLINE}inline;{$endif}
+  end;
+
+  /// exception raised during buffer processing
+  EBufferException = class(ESynException);
+
+  /// available kind of integer array storage, corresponding to the data layout
+  // of TBufferWriter
+  // - wkUInt32 will write the content as "plain" 4 bytes binary (this is the
+  // prefered way if the integers can be negative)
+  // - wkVarUInt32 will write the content using our 32-bit variable-length integer
+  // encoding
+  // - wkVarInt32 will write the content using our 32-bit variable-length integer
+  // encoding and the by-two complement (0=0,1=1,2=-1,3=2,4=-2...)
+  // - wkSorted will write an increasing array of integers, handling the special
+  // case of a difference of similar value (e.g. 1) between two values - note
+  // that this encoding is efficient only if the difference is mainly < 253
+  // - wkOffsetU and wkOffsetI will write the difference between two successive
+  // values, with detection of any constant difference (unsigned or signed)
+  // - wkFakeMarker won't be used by WriteVarUInt32Array, but to notify a
+  // custom encoding
+  TBufferWriterKind = (
+    wkUInt32,
+    wkVarUInt32,
+    wkVarInt32,
+    wkSorted,
+    wkOffsetU,
+    wkOffsetI,
+    wkFakeMarker);
+
+  /// this class can be used to speed up writing to a file or a stream
+  // - big speed up if data is written in small blocks
+  // - also handle optimized storage of any integer/Int64/RawUtf8 values
+  // - use TFileBufferReader or TFastReader for decoding of the stored binary
+  TBufferWriter = class
+  protected
+    fPos: PtrInt;
+    fBufLen, fBufLen16: PtrInt;
+    fBuffer: PByteArray;
+    fStream: TStream;
+    fTotalFlushed: Int64;
+    fBufferInternal: pointer;
+    fInternalStream: boolean;
+    fTag: PtrInt;
+    procedure InternalFlush;
+    function GetTotalWritten: Int64;
+      {$ifdef HASINLINE}inline;{$endif}
+    procedure InternalWrite(Data: pointer; DataLen: PtrInt);
+    procedure FlushAndWrite(Data: pointer; DataLen: PtrInt);
+    procedure Setup(aStream: TStream; aBuf: pointer; aLen: integer);
+      {$ifdef HASINLINE}inline;{$endif}
+  public
+    /// initialize the buffer, and specify a file handle to use for writing
+    // - define an internal buffer of the specified size
+    constructor Create(aFile: THandle; BufLen: integer = 65536); overload;
+    /// initialize the buffer, and specify a TStream to use for writing
+    // - define an internal buffer of the specified size
+    constructor Create(aStream: TStream; BufLen: integer = 65536); overload;
+    /// initialize the buffer, and specify a file to use for writing
+    // - define an internal buffer of the specified size
+    // - would replace any existing file by default, unless Append is TRUE
+    constructor Create(const aFileName: TFileName; BufLen: integer = 65536;
+      Append: boolean = false); overload;
+    /// initialize with a specified buffer and an existing TStream instance
+    // - use a specified external buffer (which may be allocated on stack),
+    // to avoid a memory allocation
+    constructor Create(aStream: TStream; aTempBuf: pointer; aTempLen: integer); overload;
+    /// initialize the buffer, using an owned TStream instance
+    // - parameter could be e.g. TMemoryStream or TRawByteStringStream
+    // - use Flush then TMemoryStream(Stream) to retrieve its content, or
+    // FlushTo if TRawByteStringStream was used
+    // - Write() fails over 800MB (_STRMAXSIZE) for a TRawByteStringStream
+    constructor Create(aClass: TStreamClass; BufLen: integer = 4096); overload;
+    /// initialize with a specified buffer and an owned TStream
+    // - use a specified external buffer (which may be allocated on stack),
+    // to avoid a memory allocation
+    // - aClass could be e.g. TMemoryStream or TRawByteStringStream
+    constructor Create(aClass: TStreamClass; aTempBuf: pointer; aTempLen: integer); overload;
+    /// initialize with a stack-allocated 8KB of buffer
+    // - destination stream is an owned TRawByteStringStream - so you can
+    // call FlushTo to retrieve all written data
+    // - Write() fails over 800MB (_STRMAXSIZE) for a TRawByteStringStream
+    // - convenient to reduce heap presure, when writing a few KB of data
+    constructor Create(const aStackBuffer: TTextWriterStackBuffer); overload;
+    /// release internal TStream (after AssignToHandle call)
+    // - warning: an explicit call to Flush is needed to write the data pending
+    // in internal buffer
+    destructor Destroy; override;
+    /// append 1 byte of data at the current position
+    procedure Write1(Data: byte);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append 2 bytes of data at the current position
+    procedure Write2(Data: cardinal);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append 2 bytes of data, encoded as BigEndian,  at the current position
+    procedure Write2BigEndian(Data: cardinal);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append 4 bytes of data at the current position
+    procedure Write4(Data: integer);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append 4 bytes of data, encoded as BigEndian, at the current position
+    procedure Write4BigEndian(Data: integer);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append 8 bytes of data at the current position
+    procedure Write8(Data8Bytes: pointer);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append 8 bytes of 64-bit integer at the current position
+    procedure WriteI64(Data: Int64);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append the same byte a given number of occurrences at the current position
+    procedure WriteN(Data: byte; Count: integer);
+    /// append some content (may be text or binary) prefixed by its encoded length
+    // - will write DataLen as VarUInt32, then the Data content, as expected
+    // by FromVarString/FromVarBlob functions
+    procedure WriteVar(Data: pointer; DataLen: PtrInt); overload;
+    /// append some TTempUtf8 text content prefixed by its encoded length
+    // - will also release any memory stored in Item.TempRawUtf8
+    procedure WriteVar(var Item: TTempUtf8); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append some UTF-8 encoded text at the current position
+    // - will write the string length (as VarUInt32), then the string content
+    // - is just a wrapper around WriteVar()
+    procedure WriteShort(const Text: ShortString);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append some length-prefixed UTF-8 text at the current position
+    // - will write the string length (as VarUInt32), then the string content, as expected
+    // by the FromVarString() function
+    // - is just a wrapper around WriteVar()
+    procedure Write(const Text: RawByteString); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append some data at the current position
+    // - will be inlined as a MoveFast() most of the time
+    procedure Write(Data: pointer; DataLen: PtrInt); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append some content at the current position
+    // - will write the binary data, without any length prefix
+    procedure WriteBinary(const Data: RawByteString);
+    /// append "New[0..Len-1] xor Old[0..Len-1]" bytes
+    // - as used e.g. by ZeroCompressXor/TSynBloomFilterDiff.SaveTo
+    procedure WriteXor(New, Old: PAnsiChar; Len: PtrInt; crc: PCardinal = nil);
+    /// append a cardinal value using 32-bit variable-length integer encoding
+    procedure WriteVarUInt32(Value: PtrUInt);
+    /// append an integer value using 32-bit variable-length integer encoding of
+    // the by-two complement of the given value
+    procedure WriteVarInt32(Value: PtrInt);
+    /// append an integer value using 64-bit variable-length integer encoding of
+    // the by-two complement of the given value
+    procedure WriteVarInt64(Value: Int64);
+    /// append an unsigned integer value using 64-bit variable-length encoding
+    procedure WriteVarUInt64(Value: QWord);
+    /// append cardinal values (NONE must be negative!) using 32-bit
+    // variable-length integer encoding or other specialized algorithm,
+    // depending on the data layout
+    // - could be decoded later on via TFastReader.ReadVarUInt32Array
+    procedure WriteVarUInt32Array(const Values: TIntegerDynArray;
+      ValuesCount: integer; DataLayout: TBufferWriterKind);
+    /// append cardinal values (NONE must be negative!) using 32-bit
+    // variable-length integer encoding or other specialized algorithms,
+    // depending on the data layout
+    // - could be decoded later on via TFastReader.ReadVarUInt32Array
+    procedure WriteVarUInt32Values(Values: PIntegerArray; ValuesCount: integer;
+      DataLayout: TBufferWriterKind);
+    /// append UInt64 values using 64-bit variable length integer encoding
+    // - if Offset is TRUE, then it will store the difference between
+    // two values using 64-bit variable-length integer encoding (in this case,
+    // a fixed-sized record storage is also handled separately)
+    // - could be decoded later on via TFastReader.ReadVarUInt64Array
+    procedure WriteVarUInt64DynArray(const Values: TInt64DynArray;
+      ValuesCount: integer; Offset: boolean);
+    /// append the RawUtf8 dynamic array
+    // - handled the fixed size strings array case in a very efficient way
+    procedure WriteRawUtf8DynArray(const Values: TRawUtf8DynArray; ValuesCount: integer);
+    /// append a RawUtf8 array of values, from its low-level memory pointer
+    // - handled the fixed size strings array case in a very efficient way
+    procedure WriteRawUtf8Array(Values: PPtrUIntArray; ValuesCount: integer);
+    /// append a TStream content
+    // - is StreamSize is left as -1, the Stream.Size is used
+    // - the size of the content is stored in the resulting stream
+    procedure WriteStream(aStream: TCustomMemoryStream; aStreamSize: integer = -1);
+    /// allows to write directly to a memory buffer
+    // - caller should specify the maximum possible number of bytes to be written
+    // - then write the data to the returned pointer, and call DirectWriteFlush
+    // - if len is bigger than the internal buffer, tmp will be used instead
+    function DirectWritePrepare(maxlen: PtrInt; var tmp: RawByteString): PAnsiChar;
+    /// finalize a direct write to a memory buffer
+    // - by specifying the number of bytes written to the buffer
+    procedure DirectWriteFlush(len: PtrInt; const tmp: RawByteString);
+    /// allows to write directly to a memory buffer
+    // - caller should specify the maximum possible number of bytes to be written
+    // - len should be smaller than the internal buffer size (not checked)
+    function DirectWriteReserve(maxlen: PtrInt): PByte;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// flush DirectWriteReserve() content
+    procedure DirectWriteReserved(pos: PByte);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// write any pending data in the internal buffer to the stream
+    // - after a Flush, it's possible to call FileSeek64(aFile,....)
+    // - returns the number of bytes written between two FLush method calls
+    function Flush: Int64;
+    /// write any pending data, then create a RawByteString from the content
+    // - raise an exception if internal Stream is not a TRawByteStringStream
+    function FlushTo: RawByteString;
+    /// write any pending data, then create a TBytes array from the content
+    // - raise an exception if the size exceeds 800MB (_DAMAXSIZE)
+    function FlushToBytes: TBytes;
+    /// write any pending data, then call algo.Compress() on the buffer
+    // - if algo is left to its default nil, will use global AlgoSynLZ
+    // - features direct compression from internal buffer, if stream was not used
+    // - BufferOffset could be set to reserve some bytes before the compressed buffer
+    // - raise an exception if internal Stream is not a TRawByteStringStream
+    function FlushAndCompress(nocompression: boolean = false;
+      algo: TAlgoCompress = nil; BufferOffset: integer = 0): RawByteString;
+    /// 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; virtual;
+    /// the associated writing stream
+    property Stream: TStream
+      read fStream;
+    /// the current position in the internal buffer
+    property BufferPosition: PtrInt
+      read fPos;
+    /// get the byte count written since last Flush
+    property TotalWritten: Int64
+      read GetTotalWritten;
+    /// simple property used to store some integer content
+    property Tag: PtrInt
+      read fTag write fTag;
+  end;
+
+{$ifndef PUREMORMOT2}
+
+  /// deprecated alias to TBufferWriter binary serializer
+  TFileBufferWriter = TBufferWriter;
+  TFileBufferWriterKind = TBufferWriterKind;
+
+const
+  woHideSynPersistentPassword = woHideSensitivePersonalInformation;
+
+{$endif PUREMORMOT2}
+
+
+{ ************ Base64, Base64Uri, Base58 and Baudot Encoding / Decoding }
+
+const
+  /// 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
+  // the TExtractInlineParameters decoder
+  // - used e.g. when transmitting TDynArray.SaveTo() content
+  JSON_BASE64_MAGIC_C = $b0bfef;
+
+  /// 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
+  // the TExtractInlineParameters decoder
+  // - used e.g. when transmitting TDynArray.SaveTo() content
+  JSON_BASE64_MAGIC_S: string[3] = #$ef#$bf#$b0;
+
+  /// '"' + UTF-8 encoded \uFFF0 special code to mark Base64 binary in JSON
+  JSON_BASE64_MAGIC_QUOTE_C = ord('"') + cardinal(JSON_BASE64_MAGIC_C) shl 8;
+
+  /// '"' + UTF-8 encoded \uFFF0 special code to mark Base64 binary in JSON
+  // - defined as a ShortString constant to be used as:
+  // ! AddShorter(JSON_BASE64_MAGIC_QUOTE_S);
+  JSON_BASE64_MAGIC_QUOTE_S: string[4] = '"'#$ef#$bf#$b0;
+
+/// just a wrapper around Base64ToBin() for in-place decode of JSON_BASE64_MAGIC_C
+// '\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_C pattern, decode and set Blob and return TRUE
+function Base64MagicCheckAndDecode(Value: PUtf8Char; var Blob: RawByteString): boolean; overload;
+
+/// decode '\uFFF0base64encodedbinary' or 'base64encodedbinary' into binary
+// - same as Base64MagicCheckAndDecode(), but will detect and ignore the magic
+// and not require it
+function Base64MagicTryAndDecode(Value: PUtf8Char; ValueLen: integer;
+  var Blob: RawByteString): boolean;
+
+/// check and decode '\uFFF0base64encodedbinary' content into binary
+// - this method will check the supplied value to match the expected
+// JSON_BASE64_MAGIC_C 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_C pattern, decode and set Blob and return TRUE
+function Base64MagicCheckAndDecode(Value: PUtf8Char;
+  var Blob: TSynTempBuffer; ValueLen: integer = 0): boolean; overload;
+
+/// fast conversion from binary data into Base64 encoded UTF-8 text
+function BinToBase64(const s: RawByteString): RawUtf8; overload;
+
+/// fast conversion from binary data into Base64 encoded UTF-8 text
+function BinToBase64(Bin: PAnsiChar; BinBytes: integer): RawUtf8; overload;
+
+/// fast conversion from a small binary data into Base64 encoded UTF-8 text
+function BinToBase64Short(const s: RawByteString): ShortString; overload;
+
+/// fast conversion from a small binary data into Base64 encoded UTF-8 text
+function BinToBase64Short(Bin: PAnsiChar; BinBytes: integer): ShortString; overload;
+
+/// fast conversion from binary data into prefixed/suffixed Base64 encoded UTF-8 text
+// - with optional JSON_BASE64_MAGIC_C prefix (UTF-8 encoded \uFFF0 special code)
+// - may use AVX2 optimized asm (10GB/s) on FPC x86_64
+function BinToBase64(const data, Prefix, Suffix: RawByteString; WithMagic: boolean): RawUtf8; overload;
+
+/// fast conversion from binary into prefixed/suffixed Base64 with 64 chars per line
+function BinToBase64Line(sp: PAnsiChar; len: PtrUInt; const Prefix: RawUtf8 = '';
+  const Suffix: RawUtf8 = ''): RawUtf8;
+
+/// fast conversion from binary data into Base64 encoded UTF-8 text
+// with JSON_BASE64_MAGIC_C prefix (UTF-8 encoded \uFFF0 special code)
+function BinToBase64WithMagic(const data: RawByteString): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast conversion from binary data into Base64 encoded UTF-8 text
+// with JSON_BASE64_MAGIC_C prefix (UTF-8 encoded \uFFF0 special code)
+function BinToBase64WithMagic(Data: pointer; DataLen: integer): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast conversion from binary data into Base64 encoded UTF-8 text
+// with JSON_BASE64_MAGIC_C prefix (UTF-8 encoded \uFFF0 special code)
+procedure BinToBase64WithMagic(Data: pointer; DataLen: integer;
+  var Result: RawUtf8); overload;
+
+/// raw function for efficient binary to Base64 encoding of the last bytes
+// - don't use this function, but rather the BinToBase64() overloaded functions
+procedure Base64EncodeTrailing(rp, sp: PAnsiChar; len: cardinal);
+  {$ifdef FPC}inline;{$endif}
+
+/// raw function for efficient binary to Base64 encoding
+// - just a wrapper around Base64EncodeMain() + Base64EncodeTrailing()
+procedure Base64Encode(rp, sp: PAnsiChar; len: cardinal);
+
+/// 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
+  {$ifndef PUREMORMOT2} ; nofullcheck: boolean = true {$endif}): 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
+  {$ifndef PUREMORMOT2} ; nofullcheck: boolean = true {$endif}): 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;
+
+/// 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; out data: TBytes): boolean; overload;
+
+/// conversion from Base64 encoded text into binary data, ignoring spaces
+// - returns '' if s was not a valid Base64-encoded input once spaces are trimmed
+// - consider PemToDer() from mormot.crypt.secure if you need to read PEM content
+function Base64ToBinTrim(const s: RawByteString): RawByteString;
+
+/// raw function for efficient binary to Base64 encoding of the main block
+// - don't use this function, but rather the BinToBase64() overloaded functions
+// - on FPC x86_64, detect and use AVX2 asm for very high throughput (11GB/s)
+var Base64EncodeMain: function(rp, sp: PAnsiChar; len: cardinal): integer;
+
+/// raw function for efficient Base64 to binary decoding of the main block
+// - don't use this function, but rather the Base64ToBin() overloaded functions
+// - on FPC x86_64, detect and use AVX2 asm for very high throughput (9GB/s)
+var Base64DecodeMain: function(sp, rp: PAnsiChar; len: PtrInt): boolean;
+
+/// check if the supplied text is a valid Base64 encoded stream
+function IsBase64(const s: RawByteString): boolean; overload;
+
+/// check if the supplied text is a valid Base64 encoded stream
+function IsBase64(sp: PAnsiChar; len: PtrInt): boolean; overload;
+
+/// retrieve the expected encoded length after Base64 process
+function BinToBase64Length(len: PtrUInt): PtrUInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// retrieve the expected undecoded length of a Base64 encoded buffer
+// - here len is the number of bytes in sp
+function Base64ToBinLength(sp: PAnsiChar; len: PtrInt): PtrInt;
+
+/// retrieve the expected undecoded length of a Base64 encoded buffer
+// - here len is the number of bytes in sp
+// - will check supplied text is a valid Base64 encoded stream
+function Base64ToBinLengthSafe(sp: PAnsiChar; len: PtrInt): PtrInt;
+
+/// direct low-level decoding of a Base64 encoded buffer
+// - here len is the number of 4 chars chunks in sp input
+// - deprecated low-level function: use Base64ToBin/Base64ToBinSafe instead
+function Base64Decode(sp, rp: PAnsiChar; len: PtrInt): boolean;
+
+/// fast conversion from binary data into Base64-like URI-compatible encoded text
+// - in comparison to Base64 standard encoding, will trim any right-sided '='
+// unsignificant characters, and replace '+' or '/' by '_' or '-'
+function BinToBase64uri(const s: RawByteString): RawUtf8; overload;
+
+/// fast conversion from a binary buffer into Base64-like URI-compatible encoded text
+// - in comparison to Base64 standard encoding, will trim any right-sided '='
+// unsignificant characters, and replace '+' or '/' by '_' or '-'
+function BinToBase64uri(Bin: PAnsiChar; BinBytes: integer): RawUtf8; overload;
+
+/// fast conversion from a binary buffer into Base64-like URI-compatible encoded ShortString
+// - in comparison to Base64 standard encoding, will trim any right-sided '='
+// unsignificant characters, and replace '+' or '/' by '_' or '-'
+// - returns '' if BinBytes void or too big for the resulting ShortString
+function BinToBase64uriShort(Bin: PAnsiChar; BinBytes: integer): ShortString;
+
+/// conversion from any Base64 encoded value into URI-compatible encoded text
+// - warning: will modify the supplied base64 string in-place
+// - in comparison to Base64 standard encoding, will trim any right-sided '='
+// unsignificant characters, and replace '+' or '/' by '_' or '-'
+procedure Base64ToUri(var base64: RawUtf8);
+
+/// low-level conversion from a binary buffer into Base64-like URI-compatible encoded text
+// - you should rather use the overloaded BinToBase64uri() functions
+procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal);
+
+/// retrieve the expected encoded length after Base64-URI process
+// - in comparison to Base64 standard encoding, will trim any right-sided '='
+// unsignificant characters, and replace '+' or '/' by '_' or '-'
+function BinToBase64uriLength(len: PtrUInt): PtrUInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// retrieve the expected undecoded length of a Base64-URI encoded buffer
+// - here len is the number of bytes in sp
+// - in comparison to Base64 standard encoding, will trim any right-sided '='
+// unsignificant characters, and replace '+' or '/' by '_' or '-'
+function Base64uriToBinLength(len: PtrInt): PtrInt;
+
+/// fast conversion from Base64-URI encoded text into binary data
+// - in comparison to Base64 standard encoding, will trim any right-sided '='
+// unsignificant characters, and replace '+' or '/' by '_' or '-'
+function Base64uriToBin(sp: PAnsiChar; len: PtrInt): RawByteString; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast conversion from Base64-URI encoded text into binary data
+// - in comparison to Base64 standard encoding, will trim any right-sided '='
+// unsignificant characters, and replace '+' or '/' by '_' or '-'
+function Base64uriToBin(sp: PAnsiChar; len: PtrInt;
+  var bin: RawByteString): boolean; 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;
+
+/// conversion from a binary buffer into Base58 encoded text as TSynTempBuffer
+// - Bitcoin' Base58 was defined as alphanumeric chars without misleading 0O I1
+// - Base58 is much slower than Base64, performing in O(n^2) instead of O(n),
+// and should not be used on big buffers
+// - returns the number of encoded chars encoded into Dest.buf
+// - caller should call Dest.Done once it is finished with the output text
+function BinToBase58(Bin: PAnsiChar; BinLen: integer;
+  var Dest: TSynTempBuffer): integer; overload;
+
+/// conversion from a binary buffer into Base58 encoded text as RawUtf8
+// - Bitcoin' Base58 was defined as alphanumeric chars without misleading 0O I1
+// - Base58 is much slower than Base64, performing in O(n^2) instead of O(n),
+// and should not be used on big buffers
+function BinToBase58(Bin: PAnsiChar; BinLen: integer): RawUtf8; overload;
+
+/// conversion from a binary buffer into Base58 encoded text as RawUtf8
+// - Bitcoin' Base58 was defined as alphanumeric chars without misleading 0O I1
+// - Base58 is much slower than Base64, performing in O(n^2) instead of O(n),
+// and should not be used on big buffers
+function BinToBase58(const Bin: RawByteString): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// conversion from Base58 encoded text into a binary buffer
+// - Bitcoin' Base58 was defined as alphanumeric chars without misleading 0O I1
+// - Base58 is much slower than Base64, performing in O(n^2) instead of O(n),
+// and should not be used on big buffers
+// - returns the number of decoded chars encoded into Dest.buf
+// - caller should call Dest.Done once it is finished with the output binary
+function Base58ToBin(B58: PAnsiChar; B58Len: integer;
+  var Dest: TSynTempBuffer): integer; overload;
+
+/// conversion from Base58 encoded text into a binary string
+// - Bitcoin' Base58 was defined as alphanumeric chars without misleading 0O I1
+// - Base58 is much slower than Base64, and should not be used on big buffers
+// - returns '' if input was not valid Base58 encoded
+function Base58ToBin(B58: PAnsiChar; B58Len: integer): RawByteString; overload;
+
+/// conversion from Base58 encoded text into a binary string
+// - Bitcoin' Base58 was defined as alphanumeric chars without misleading 0O I1
+// - Base58 is much slower than Base64, and should not be used on big buffers
+// - returns '' if input was not valid Base58 encoded
+function Base58ToBin(const base58: RawUtf8): RawByteString; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// compute the length resulting of Base32 encoding of a binary buffer
+// - RFC4648 Base32 is defined as upper alphanumeric without misleading 0O 1I 8B
+function BinToBase32Length(BinLen: cardinal): cardinal;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// conversion from a binary buffer into Base32 encoded text  buffer
+// - default b32enc is RFC4648 upper alphanumeric without misleading 0O 1I 8B
+procedure BinToBase32(Bin: PByteArray; Dest: PAnsiChar; BinLen: PtrInt;
+  b32enc: PAnsiChar); overload;
+
+/// conversion from a binary buffer into Base32 encoded text as RawUtf8
+// - RFC4648 Base32 is defined as upper alphanumeric without misleading 0O 1I 8B
+function BinToBase32(Bin: PAnsiChar; BinLen: PtrInt): RawUtf8; overload;
+
+/// conversion from a binary buffer into Base32 encoded text as RawUtf8
+// - RFC4648 Base32 is defined as upper alphanumeric without misleading 0O 1I 8B
+function BinToBase32(const Bin: RawByteString): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// conversion from Base32 encoded text into a binary string
+// - RFC4648 Base32 is defined as upper alphanumeric without misleading 0O 1I 8B
+// - returns '' if input was not valid Base32 encoded
+function Base32ToBin(B32: PAnsiChar; B32Len: integer): RawByteString; overload;
+
+/// conversion from Base32 encoded text into a binary string
+// - RFC4648 Base32 is defined as upper alphanumeric without misleading 0O 1I 8B
+// - returns '' if input was not valid Base32 encoded
+function Base32ToBin(const base32: RawUtf8): RawByteString; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fill a RawBlob from TEXT-encoded blob data
+// - blob data can be encoded as SQLite3 BLOB literals (X'53514C697465' e.g.) or
+// or Base64 encoded content ('\uFFF0base64encodedbinary') or plain TEXT
+function BlobToRawBlob(P: PUtf8Char; Len: integer = 0): RawBlob; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fill a RawBlob from TEXT-encoded blob data
+// - blob data can be encoded as SQLite3 BLOB literals (X'53514C697465' e.g.) or
+// or Base64 encoded content ('\uFFF0base64encodedbinary') or plain TEXT
+procedure BlobToRawBlob(P: PUtf8Char; var result: RawBlob; Len: integer = 0); overload;
+
+/// fill a RawBlob from TEXT-encoded blob data
+// - blob data can be encoded as SQLite3 BLOB literals (X'53514C697465' e.g.) or
+// or Base64 encoded content ('\uFFF0base64encodedbinary') or plain TEXT
+function BlobToRawBlob(const Blob: RawByteString): RawBlob; overload;
+
+/// create a TBytes from TEXT-encoded blob data
+// - blob data can be encoded as SQLite3 BLOB literals (X'53514C697465' e.g.) or
+// or Base64 encoded content ('\uFFF0base64encodedbinary') or plain TEXT
+function BlobToBytes(P: PUtf8Char): TBytes;
+
+/// create a memory stream from TEXT-encoded blob data
+// - blob data can be encoded as SQLite3 BLOB literals (X'53514C697465' e.g.) or
+// or Base64 encoded content ('\uFFF0base64encodedbinary') or plain TEXT
+// - the caller must free the stream instance after use
+function BlobToStream(P: PUtf8Char): TStream;
+
+/// creates a TEXT-encoded version of blob data from a RawBlob
+// - TEXT will be encoded as SQLite3 BLOB literals (X'53514C697465' e.g.)
+function RawBlobToBlob(const RawBlob: RawBlob): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// creates a TEXT-encoded version of blob data from a memory data
+// - same as RawBlob, but with direct memory access via a pointer/byte size pair
+// - TEXT will be encoded as SQLite3 BLOB literals (X'53514C697465' e.g.)
+function RawBlobToBlob(RawBlob: pointer; RawBlobLength: integer): RawUtf8; overload;
+
+/// convert a Base64-encoded content into binary hexadecimal ready for SQL
+// - returns e.g. X'53514C697465'
+procedure Base64MagicToBlob(Base64: PUtf8Char; var result: RawUtf8);
+
+/// return true if the TEXT is encoded as SQLite3 BLOB literals (X'53514C697465' e.g.)
+function isBlobHex(P: PUtf8Char): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+
+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 into memory
+// - following RFC 1867
+// - decoded sections are appended to MultiPart[] existing array
+function MultiPartFormDataDecode(const MimeType, Body: RawUtf8;
+  var MultiPart: TMultiPartDynArray): boolean;
+
+/// used e.g. by MultiPartFormDataEncode and THttpMultiPartStream.Add
+function MultiPartFormDataNewBound(var boundaries: TRawUtf8DynArray): RawUtf8;
+
+/// 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
+// - Rfc2388NestedFiles will force the deprecated nested "multipart/mixed" format
+// - consider THttpMultiPartStream from mormot.net.client for huge file content
+function MultiPartFormDataEncode(const MultiPart: TMultiPartDynArray;
+  var MultiPartContentType, MultiPartContent: RawUtf8;
+  Rfc2388NestedFiles: boolean = false): 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
+// - consider THttpMultiPartStream from mormot.net.client for huge file content
+function MultiPartFormDataAddFile(const FileName: TFileName;
+  var MultiPart: TMultiPartDynArray; const Name: RawUtf8 = '';
+  const ForcedContentType: 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
+// - consider THttpMultiPartStream from mormot.net.client for huge file content
+function MultiPartFormDataAddField(const FieldName, FieldValue: RawUtf8;
+  var MultiPart: TMultiPartDynArray; const ForcedContentType: RawUtf8 = ''): boolean;
+
+
+/// convert some ASCII-7 text into binary, using Emile Baudot code
+// - as used in telegraphs, covering #10 #13 #32 a-z 0-9 - ' , ! : ( + ) $ ? @ . / ;
+// charset, following a custom static-huffman-like encoding with 5-bit masks
+// - any upper case char will be converted into lowercase during encoding
+// - other characters (e.g. UTF-8 accents, or controls chars) will be ignored
+// - resulting binary will consume 5 (or 10) bits per character
+// - reverse of the BaudotToAscii() function
+// - the "baud" symbol rate measurement comes from Emile's name ;)
+function AsciiToBaudot(P: PAnsiChar; len: PtrInt): RawByteString; overload;
+
+/// convert some ASCII-7 text into binary, using Emile Baudot code
+// - as used in telegraphs, covering #10 #13 #32 a-z 0-9 - ' , ! : ( + ) $ ? @ . / ;
+// charset, following a custom static-huffman-like encoding with 5-bit masks
+// - any upper case char will be converted into lowercase during encoding
+// - other characters (e.g. UTF-8 accents, or controls chars) will be ignored
+// - resulting binary will consume 5 (or 10) bits per character
+// - reverse of the BaudotToAscii() function
+// - the "baud" symbol rate measurement comes from Emile's name ;)
+function AsciiToBaudot(const Text: RawUtf8): RawByteString; overload;
+
+/// convert some Baudot code binary, into ASCII-7 text
+// - reverse of the AsciiToBaudot() function
+// - any uppercase character would be decoded as lowercase - and some characters
+// may have disapeared outside of a-z 0-9 - ' , ! : ( + ) $ ? @ . / ; range
+// - the "baud" symbol rate measurement comes from Emile's name ;)
+function BaudotToAscii(Baudot: PByteArray; len: PtrInt): RawUtf8; overload;
+
+/// convert some Baudot code binary, into ASCII-7 text
+// - reverse of the AsciiToBaudot() function
+// - any uppercase character would be decoded as lowercase - and some characters
+// may have disapeared outside of a-z 0-9 - ' , ! : ( + ) $ ? @ . / ; range
+// - the "baud" symbol rate measurement comes from Emile's name ;)
+function BaudotToAscii(const Baudot: RawByteString): RawUtf8; overload;
+
+
+
+{ ***************** URI-Encoded Text Buffer Process }
+
+/// encode a string as URI parameter encoding, i.e. ' ' as '+'
+function UrlEncode(const svar: RawUtf8): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// encode a string as URI parameter encoding, i.e. ' ' as '+'
+function UrlEncode(Text: PUtf8Char): RawUtf8; overload;
+
+/// encode a string as URI network name encoding, i.e. ' ' as %20
+// - only parameters - i.e. after '?' - should replace spaces by '+'
+function UrlEncodeName(const svar: RawUtf8): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// encode a string as URI network name encoding, i.e. ' ' as %20
+// - only parameters - i.e. after '?' - should replace spaces by '+'
+function UrlEncodeName(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 with ObjectToJson()
+function UrlEncode(const NameValuePairs: array of const;
+  TrimLeadingQuestionMark: boolean = false): RawUtf8; overload;
+
+/// decode a UrlEncode() URI encoded parameter into its original value
+function UrlDecode(U: PUtf8Char): RawUtf8; overload;
+
+/// decode a UrlEncode() URI encoded parameter into its original value
+function UrlDecode(const s: RawUtf8): RawUtf8; overload;
+
+/// decode a UrlEncodeName() URI encoded network name into its original value
+// - only parameters - i.e. after '?' - should replace spaces by '+'
+function UrlDecodeName(U: PUtf8Char): RawUtf8; overload;
+
+/// decode a UrlEncodeName() URI encoded network name into its original value
+// - only parameters - i.e. after '?' - should replace spaces by '+'
+function UrlDecodeName(const s: RawUtf8): RawUtf8; overload;
+
+/// decode a UrlEncode/UrlEncodeName() URI encoded string into its original value
+// - name=false for parameters (after ?), to replace spaces by '+'
+procedure UrlDecodeVar(U: PUtf8Char; L: PtrInt; var result: RawUtf8; name: boolean);
+
+/// 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='*'
+// - Upper should be already uppercased, and end with a '=' character
+// - 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
+// - Upper should be already uppercased, and end with a '=' character
+// - 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
+// - Upper should be already uppercased, and end with a '=' character
+// - 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
+// - Upper should be already uppercased, and end with a '=' character
+// - 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
+// - Upper should be already uppercased, and end with a '=' character
+// - 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
+// - Upper should be already uppercased, and end with a '=' character
+// - 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;
+
+
+{ *********** Basic MIME Content Types Support }
+
+type
+  /// some of the best-known mime types
+  // - subset of the whole IANA list which can be quite huge (>1500 items)
+  TMimeType = (
+    mtUnknown,
+    mtPng,
+    mtGif,
+    mtTiff,
+    mtJpg,
+    mtBmp,
+    mtDoc,
+    mtPpt,
+    mtXls,
+    mtHtml,
+    mtCss,
+    mtJS,
+    mtXIcon,
+    mtFont,
+    mtText,
+    mtSvg,
+    mtXml,
+    mtWebp,
+    mtManifest,
+    mtJson,
+    mtOgg,
+    mtMp4,
+    mtMp2,
+    mtMpeg,
+    mtH264,
+    mtWma,
+    mtWmv,
+    mtAvi,
+    mtGzip,
+    mtWebm,
+    mtRar,
+    mt7z,
+    mtZip,
+    mtBz2,
+    mtPdf,
+    mtSQlite3,
+    mtXcomp);
+  PMimeType = ^TMimeType;
+
+const
+  /// the known mime types text representation
+  MIME_TYPE: array[TMimeType] of RawUtf8 = (
+    '',                              // mtUnknown
+    'image/png',                     // mtPng
+    'image/gif',                     // mtGif
+    'image/tiff',                    // mtTiff
+    JPEG_CONTENT_TYPE,               // mtJpg
+    'image/bmp',                     // mtBmp
+    'application/msword',            // mtDoc
+    'application/vnd.ms-powerpoint', // mtPpt
+    'application/vnd.ms-excel',      // mtXls
+    HTML_CONTENT_TYPE,               // mtHtml
+    'text/css',                      // mtCss
+    'text/javascript',               // mtJS RFC 9239
+    'image/x-icon',                  // mtXIcon
+    'font/woff',                     // mtFont RFC 8081
+    TEXT_CONTENT_TYPE,               // mtText
+    'image/svg+xml',                 // mtSvg
+    XML_CONTENT_TYPE,                // mtXml
+    'image/webp',                    // mtWebp
+    'text/cache-manifest',           // mtManifest
+    JSON_CONTENT_TYPE,               // mtJson
+    'video/ogg',                     // mtOgg RFC 5334
+    'video/mp4',                     // mtMp4 RFC 4337 6381
+    'video/mp2',                     // mtMp2
+    'audio/mpeg',                    // mtMpeg RFC 3003
+    'video/H264',                    // mtH264  RFC 6184
+    'audio/x-ms-wma',                // mtWma
+    'video/x-ms-wmv',                // mtWmv
+    'video/x-msvideo',               // mtAvi
+    'application/gzip',              // mtGzip
+    'video/webm',                    // mtWebm
+    'application/x-rar-compressed',  // mtRar
+    'application/x-7z-compressed',   // mt7z
+    'application/zip',               // mtZip
+    'application/bzip2',             // mtBz2
+    'application/pdf',               // mtPdf
+    'application/x-sqlite3',         // mtSQlite3
+    'application/x-compress');       // mtXcomp
+
+/// retrieve the MIME content type from its file name
+function GetMimeContentTypeFromExt(const FileName: TFileName;
+  FileExt: PRawUtf8 = nil): TMimeType;
+
+/// retrieve the MIME content type from its file extension text (without '.')
+function GetMimeTypeFromExt(const Ext: RawUtf8): TMimeType;
+
+/// retrieve the MIME content type from a supplied binary buffer
+function GetMimeContentTypeFromMemory(Content: Pointer; Len: PtrInt): TMimeType;
+
+/// retrieve the MIME content type from a supplied binary buffer
+// - inspect the first bytes, to guess from standard known headers
+// - return the MIME type, ready to be appended to a 'Content-Type: ' HTTP header
+// - returns DefaultContentType if the binary buffer has an unknown layout
+function GetMimeContentTypeFromBuffer(Content: Pointer; Len: PtrInt;
+  const DefaultContentType: RawUtf8; Mime: PMimeType = nil): RawUtf8;
+
+/// retrieve the MIME content type from its file name or a supplied binary buffer
+// - will first check for known file extensions, then inspect the binary content
+// - return the MIME type, ready to be appended to a 'Content-Type: ' HTTP header
+// - default is DefaultContentType or 'application/octet-stream' (BINARY_CONTENT_TYPE)
+// or 'application/fileextension' if FileName was specified
+// - see @http://en.wikipedia.org/wiki/Internet_media_type for most common values
+function GetMimeContentType(Content: Pointer; Len: PtrInt; const FileName: TFileName = '';
+  const DefaultContentType: RawUtf8 = BINARY_CONTENT_TYPE; Mime: PMimeType = nil): 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 = ''; Mime: PMimeType = nil): RawUtf8;
+
+const
+  /// the "magic" number used to identify .log.synlz compressed files, as
+  // created by EventArchiveSynLZ / EventArchiveLizard callbacks
+  LOG_MAGIC = $ABA51051;
+
+/// retrieve if some content is compressed, from a supplied binary buffer
+// - returns TRUE, if the header in binary buffer "may" be compressed (this
+// method can trigger false positives), e.g. begin with most common already
+// compressed zip/gz/gif/png/jpeg/avi/mp3/mp4 markers (aka "magic numbers")
+function IsContentCompressed(Content: Pointer; Len: PtrInt): boolean;
+
+/// 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 + Bits variable with its dimensions - but there may be false
+// positive recognition, and no waranty that the memory buffer is a valid JPEG
+// - returns FALSE if the buffer does not have any expected SOI/SOF markers
+function GetJpegSize(jpeg: PAnsiChar; len: PtrInt;
+  out Height, Width, Bits: integer): boolean; overload;
+
+
+{ ************* Text Memory Buffers and Files }
+
+type
+  {$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)'') and (Text[length(Text)]<>Ch) then Text := Text + ch;
+procedure AppendCharOnceToRawUtf8(var Text: RawUtf8; Ch: AnsiChar);
+
+/// fast add some characters to a RawUtf8 string
+// - faster than Text := Text+RawUtf8(Buffers[0])+RawUtf8(Buffers[0])+...
+// - will handle up to 64 Buffers[] - raise an ESynException on too many Buffers
+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 some characters from ane buffer into another buffer
+// - warning: the Buffer should contain enough space to store the Text, otherwise
+// you may encounter buffer overflows and random memory errors
+function AppendBufferToBuffer(Buffer: PUtf8Char; Text: pointer; Len: PtrInt): PUtf8Char;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// 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: PtrUInt): PUtf8Char;
+
+/// fast add text conversion of 0-999 integer value into a given buffer
+// - warning: it won't check that Value is in 0-999 range
+// - up to 4 bytes may be written to the buffer (including trailing #0)
+function Append999ToBuffer(Buffer: PUtf8Char; Value: PtrUInt): PUtf8Char;
+  {$ifdef HASINLINE}inline;{$endif}
+
+const
+  /// can be used to append to most English nouns to form a plural
+  // - as used by 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;
+
+/// low-level 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 dmax overflow
+// - ensure the destination buffer contains at least dmax bytes, which is
+// always the case when using LogEscape() and its local TLogEscape variable
+function EscapeBuffer(s: PAnsiChar; slen: integer;
+  d: PAnsiChar; dmax: integer): PAnsiChar;
+
+type
+  /// 512 bytes buffer to be allocated on stack when using LogEscape()
+  TLogEscape = array[0..511] of AnsiChar;
+
+/// fill TLogEscape stack buffer with the (hexadecimal) chars of the input binary
+// - up to 512 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;
+
+
+/// 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;
+
+/// generate some pascal source code holding some data binary as constant
+function BinToSource(const ConstName, Comment: RawUtf8; const Data: RawByteString;
+  PerLine: integer = 16; const Suffix: RawUtf8 = ''): RawUtf8; overload;
+
+/// generate some 'xx:xx:xx:xx' output buffer with left and right margins
+// - used e.g. by ParsedToText() to output X509 public key content in PeerInfo
+function BinToHumanHex(Data: PByte; Len: integer; PerLine: integer = 16;
+  LeftTab: integer = 0; SepChar: AnsiChar = ':'): RawUtf8; overload;
+
+/// generate some 'xx:xx:xx:xx' output buffer with left and right margins
+procedure BinToHumanHex(W: TTextWriter; Data: PByte; Len: integer;
+  PerLine: integer = 16; LeftTab: integer = 0; SepChar: AnsiChar = ':'); overload;
+
+
+{ *************************** TStreamRedirect and other Hash process }
+
+/// compute the 32-bit default hash of a file content
+// - you can specify your own hashing function if DefaultHasher is not what you expect
+function HashFile(const FileName: TFileName; Hasher: THasher = nil): cardinal; overload;
+
+/// compare two files by content, reading them by blocks
+function SameFileContent(const One, Another: TFileName): boolean;
+
+type
+  /// prototype of a file hashing function, returning its hexadecimal hash
+  // - match HashFileCrc32c() below, HashFileCrc32() in mormot.core.zip,
+  // and HashFileMd5/HashFileSha* in mormot.crypt.secure functions signature
+  THashFile = function(const FileName: TFileName): RawUtf8;
+
+  TStreamRedirect = class;
+
+  /// TStreamHasher.Write optional progression callback
+  // - see Sender properties like Context/Size/PerSecond and ExpectedSize
+  // (which may be 0 if the download size is unknown)
+  // - see e.g. TStreamRedirect.ProgressStreamToConsole
+  TOnStreamProgress = procedure(Sender: TStreamRedirect) of object;
+
+  /// optional callback as used e.g. by THttpClientSocketWGet.OnStreamCreate
+  TOnStreamCreate = function(const FileName: string; Mode: cardinal): TStream of object;
+
+  PProgressInfo = ^TProgressInfo;
+
+  /// callback definition to notify some TProgressInfo process
+  // - see e.g. TStreamRedirect.ProgressInfoToConsole
+  TOnInfoProgress = procedure(Sender: TObject; Info: PProgressInfo) of object;
+
+  /// information about the progression of a process, e.g. for TStreamRedirect
+  // - can also compute user-level text information from raw numbers
+  {$ifdef USERECORDWITHMETHODS}
+  TProgressInfo = record
+  {$else}
+  TProgressInfo = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    StartTix, ReportTix: Int64;
+    ExpectedWrittenSize: Int64;
+    ConsoleLen: integer;
+    LastProgress: RawUtf8;
+  public
+    /// optional process context, e.g. a download URI, used for logging/progress
+    Context: RawUtf8;
+    /// number of bytes for the processed size
+    CurrentSize: Int64;
+    /// number of bytes for the final processed size
+    // - may equal 0 if not known
+    ExpectedSize: Int64;
+    /// how many bytes have processed yet
+    ProcessedSize: Int64;
+    /// percentage of CurrentSize versus ExpectedSize
+    // - equals 0 if ExpectedSize is 0
+    Percent: integer;
+    /// number of milliseconds elasped since process beginning
+    Elapsed: Int64;
+    /// number of milliseconds remaining for full process, as estimated
+    // - equals 0 if ExpectedSize is 0
+    // - is just an estimation based on the average PerSecond speed
+    Remaining: Int64;
+    /// number of bytes processed per second
+    PerSecond: PtrInt;
+    /// number of milliseconds between each DoReport notification
+    // - default is 1000, i.e. to notify OnLog/OnProgress every second
+    ReportDelay: Int64;
+    /// can be assigned from TSynLog.DoLog class method for low-level logging
+    // - at least at process startup and finish, and every second (ReportDelay)
+    OnLog: TSynLogProc;
+    /// can be assigned to a TOnInfoProgress callback for high-level logging
+    // - at least at process startup and finish, and every second (ReportDelay)
+    OnProgress: TOnInfoProgress;
+    /// initialize the information, especially start the timing
+    procedure Init;
+    /// called during process to setup ExpectedSize/ExpectedWrittenSize fields
+    procedure SetExpectedSize(SizeExpected, Position: Int64);
+    /// retrieve the current status as simple text
+    function GetProgress: RawUtf8;
+    /// initialize the information for a new process
+    // - once expected size and ident are set, caller should call DoAfter()
+    procedure DoStart(Sender: TObject; SizeExpected: Int64; const Ident: string);
+    /// can be called
+    procedure DoAfter(Sender: TObject; ChunkSize: Int64);
+    /// update the computed fields according to the curent state
+    // - will be updated only every ReportDelay ms (default 1000 = every second)
+    // - return false and compute nothing if ReportDelay has not been reached
+    // - optionally call OnLog and OnProgress callbacks
+    function DoReport(Sender: TObject; ReComputeElapsed: boolean): boolean;
+  end;
+
+  /// exception raised during TStreamRedirect processing
+  EStreamRedirect = class(ESynException);
+
+  /// an abstract pipeline stream able to redirect and hash read/written content
+  // - can be used either Read() or Write() calls during its livetime
+  // - hashing is performed on the fly during the Read/Write process
+  // - it features also a callback to mark its progress
+  // - can sleep during Read/Write to reach a LimitPerSecond average bandwidth
+  TStreamRedirect = class(TStreamWithPosition)
+  protected
+    fRedirected: TStream;
+    fInfo: TProgressInfo;
+    fLastTix, fTimeOut: Int64;
+    fLimitPerSecond: PtrInt;
+    fOnStreamProgress: TOnStreamProgress;
+    fTerminated: boolean;
+    fMode: (mUnknown, mRead, mWrite);
+    function GetSize: Int64; override;
+    procedure SetSize(NewSize: Longint); override;
+    procedure SetSize(const NewSize: Int64); override;
+    function GetProgress: RawUtf8;
+    procedure DoReport(ReComputeElapsed: boolean);
+    procedure DoHash(data: pointer; len: integer); virtual; // do nothing
+    procedure SetExpectedSize(Value: Int64);
+    procedure ReadWriteHash(const Buffer; Count: integer); virtual;
+    procedure ReadWriteReport(const Caller: ShortString); virtual;
+  public
+    /// initialize the internal structure, and start the timing
+    // - before calling Read/Write, you should set the Redirected property or
+    // specify aRedirected here - which will be owned by this instance
+    // - if aRead is true, ExpectedSize is set from aRedirected.Size
+    constructor Create(aRedirected: TStream; aRead: boolean = false); reintroduce; virtual;
+    /// release the associated Redirected stream
+    destructor Destroy; override;
+    /// can be used as TOnStreamProgress callback writing into the console
+    class procedure ProgressStreamToConsole(Sender: TStreamRedirect);
+    /// can be used as TOnInfoProgress callback writing into the console
+    class procedure ProgressInfoToConsole(Sender: TObject; Info: PProgressInfo);
+    /// notify a TOnStreamProgress callback that a process ended
+    // - create a fake TStreamRedirect and call Ended with the supplied info
+    class procedure NotifyEnded(
+      const OnStream: TOnStreamProgress; const OnInfo: TOnInfoProgress;
+      const Fmt: RawUtf8; const Args: array of const; Size, StartedMs: Int64);
+    /// update the hash and redirect the data to the associated TStream
+    // - also trigger OnProgress at least every second
+    // - will raise an error if Write() (or Append) have been called before
+    function Read(var Buffer; Count: Longint): Longint; override;
+    /// update the hash and redirect the data to the associated TStream
+    // - also trigger OnProgress at least every second
+    // - will raise an error if Read() has been called before
+    function Write(const Buffer; Count: Longint): Longint; override;
+    /// update the hash of the existing Redirected stream content
+    // - ready to Write() some new data after the existing
+    procedure Append;
+    /// notify end of process
+    // - should be called explicitly when all Read()/Write() has been done
+    procedure Ended;
+    /// could be set from another thread to abort the streaming process
+    // - will raise an exception at the next Read()/Write() call
+    procedure Terminate;
+    /// return the current state of the hash as lower hexadecimal
+    // - by default, will return '' meaning that no hashing algorithm was set
+    function GetHash: RawUtf8; virtual;
+    /// current algorithm name as file/url extension, e.g. '.md5' or '.sha256'
+    // - by default, will return '' meaning that no hashing algorithm was set
+    class function GetHashFileExt: RawUtf8; virtual;
+    /// current algorithm name, from GetHashFileExt, e.g. 'md5' or 'sha256'
+    class function GetHashName: RawUtf8;
+    /// apply the internal hash algorithm to the supplied file content
+    // - could be used ahead of time to validate a cached file
+    class function HashFile(const FileName: TFileName;
+      const OnProgress: TOnStreamProgress = nil): RawUtf8;
+    /// specify a TStream to which any Read()/Write() will be redirected
+    // - this TStream instance will be owned by the TStreamRedirect
+    property Redirected: TStream
+      read fRedirected write fRedirected;
+    /// you can specify a number of bytes for the final Redirected size
+    // - will be used for the callback progress - could be left to 0 for Write()
+    // if size is unknown
+    property ExpectedSize: Int64
+      read fInfo.ExpectedSize write SetExpectedSize;
+    /// how many bytes have passed through Read() or Write()
+    // - may not equal Size or Position after an Append - e.g. on resumed
+    // download from partial file
+    property ProcessedSize: Int64
+      read fInfo.ProcessedSize;
+    /// percentage of Size versus ExpectedSize
+    // - equals 0 if ExpectedSize is 0
+    property Percent: integer
+      read fInfo.Percent;
+    /// number of milliseconds elasped since beginning, as set by Read/Write
+    property Elapsed: Int64
+      read fInfo.Elapsed;
+    /// number of milliseconds remaining for full process, as set by Read/Write
+    // - equals 0 if ExpectedSize is 0
+    // - is just an estimation based on the average PerSecond speed
+    property Remaining: Int64
+      read fInfo.Remaining;
+    /// number of bytes processed per second, since initialization of this instance
+    property PerSecond: PtrInt
+      read fInfo.PerSecond;
+    /// can limit the Read/Write bytes-per-second bandwidth used, if not 0
+    // - sleep so that PerSecond will keep close to this LimitPerSecond value
+    property LimitPerSecond: PtrInt
+      read fLimitPerSecond write fLimitPerSecond;
+    /// Read/Write will raise an exception if not finished after TimeOut milliseconds
+    property TimeOut: Int64
+      read fTimeOut write fTimeOut;
+    /// optional process context, e.g. a download URI, used for logging/progress
+    property Context: RawUtf8
+      read fInfo.Context write fInfo.Context;
+    /// number of milliseconds between each notification
+    // - default is 1000, i.e. notify OnLog/OnProgress/OnInfoProgress every second
+    property ReportDelay: Int64
+      read fInfo.ReportDelay write fInfo.ReportDelay;
+    /// can be assigned from TSynLog.DoLog class method for low-level logging
+    property OnLog: TSynLogProc
+      read fInfo.OnLog write fInfo.OnLog;
+    /// optional TOnStreamProgress callback triggered during Read/Write
+    // - at least at process startup and finish, and every second / ReportDelay
+    property OnProgress: TOnStreamProgress
+      read fOnStreamProgress write fOnStreamProgress;
+    /// optional TOnInfoProgress callback triggered during Read/Write
+    // - at least at process startup and finish, and every second / ReportDelay
+    property OnInfoProgress: TOnInfoProgress
+      read fInfo.OnProgress write fInfo.OnProgress;
+  published
+    /// the current progression as text, as returned by ProgressStreamToConsole
+    property Progress: RawUtf8
+      read GetProgress;
+  end;
+
+  /// meta-class of TStreamRedirect hierarchy
+  TStreamRedirectClass = class of TStreamRedirect;
+
+  /// TStreamRedirect with 32-bit THasher checksum
+  TStreamRedirectHasher = class(TStreamRedirect)
+  protected
+    fHash: cardinal;
+  public
+    function GetHash: RawUtf8; override;
+  end;
+
+  /// TStreamRedirect with crc32c 32-bit checksum
+  TStreamRedirectCrc32c = class(TStreamRedirectHasher)
+  protected
+    procedure DoHash(data: pointer; len: integer); override;
+  public
+    class function GetHashFileExt: RawUtf8; override;
+  end;
+
+  /// a fake TStream, which will just count the number of bytes written
+  TFakeWriterStream = class(TStream)
+  protected
+    fWritten: Int64;
+    {$ifdef FPC}
+    function GetPosition: Int64; override;
+    {$endif FPC}
+  public
+    function Read(var Buffer; Count: Longint): Longint; override;
+    function Write(const Buffer; Count: Longint): Longint; override;
+    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
+    function Seek(Offset: Longint; Origin: Word): Longint; override;
+  end;
+
+  TNestedStream = record
+    Stream: TStream;
+    Start, Stop: Int64;
+  end;
+
+  /// TStream allowing to read from some nested TStream instances
+  TNestedStreamReader = class(TStreamWithPositionAndSize)
+  protected
+    fNested: array of TNestedStream;
+    fContentRead: ^TNestedStream;
+  public
+    /// overriden method to call Flush on rewind, i.e. if position is set to 0
+    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
+    /// finalize the nested TStream instance
+    destructor Destroy; override;
+    /// append a nested TStream instance
+    // - you could use a TFileStreamEx here for efficient chunked reading
+    function NewStream(Stream: TStream): TStream;
+    /// get the last TRawByteStringStream, or append a new one if needed
+    function ForText: TRawByteStringStream;
+    /// append some text or content to an internal TRawByteStringStream
+    // - is the easy way to append some text or data to the internal buffers
+    procedure Append(const Content: RawByteString);
+    /// you should call this method before any Read() call
+    // - is also called when you execute Seek(0, soBeginning)
+    procedure Flush; virtual;
+    /// will read up to Count bytes from the internal nested TStream
+    function Read(var Buffer; Count: Longint): Longint; override;
+    /// this TStream is read-only: calling this method will raise an exception
+    function Write(const Buffer; Count: Longint): Longint; override;
+  end;
+
+  /// TStream with an internal memory buffer
+  // - can be beneficial e.g. reading from a file by small chunks
+  TBufferedStreamReader = class(TStreamWithPositionAndSize)
+  protected
+    fBuffer: RawByteString;
+    fSource: TStream;
+    fBufferPos: PAnsiChar;
+    fBufferLeft: integer;
+    fOwnStream: TStream;
+  public
+    /// initialize the source TStream and the internal buffer
+    // - will also rewind the aSource position to its beginning, and retrieve
+    // its size
+    constructor Create(aSource: TStream;
+      aBufSize: integer = 65536); reintroduce; overload;
+    /// initialize a source file and the internal buffer
+    constructor Create(const aSourceFileName: TFileName;
+      aBufSize: integer = 65536); reintroduce; overload;
+    /// finalize this instance and its buffer
+    destructor Destroy; override;
+    /// overriden method to flush buffer on rewind
+    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
+    /// will read up to Count bytes from the internal buffer or source TStream
+    function Read(var Buffer; Count: Longint): Longint; override;
+    /// this TStream is read-only: calling this method will raise an exception
+    function Write(const Buffer; Count: Longint): Longint; override;
+  end;
+
+
+/// compute the crc32c checksum of a given file
+// - this function maps the THashFile signature
+function HashFileCrc32c(const FileName: TFileName): RawUtf8;
+
+/// retrieve the memory buffer of a TCustomMemoryStream/TRawByteStringStream
+// - returns nil if the instance is not of those classes
+function GetStreamBuffer(S: TStream): pointer;
+
+/// check if class is a TCustomMemoryStream/TRawByteStringStream
+function IsStreamBuffer(S: TStream): boolean;
+
+
+{ ************* Markup (e.g. HTML or Emoji) process }
+
+type
+  /// tune AddHtmlEscapeWiki/AddHtmlEscapeMarkdown wrapper functions process
+  // - heHtmlEscape will escape any HTML special chars, e.g. & into &
+  // - heEmojiToUtf8 will convert any Emoji text into UTF-8 Unicode character,
+  // recognizing e.g. :joy: or :) in the text
+  TTextWriterHtmlEscape = set of (
+    heHtmlEscape,
+    heEmojiToUtf8);
+
+/// convert some wiki-like text into proper HTML
+// - convert all #13#10 into 
...
, *..* into .., +..+ into
+// .., `..` into .., and http://... as
+// 
+// - escape any HTML special chars, and Emoji tags as specified with esc
+procedure AddHtmlEscapeWiki(W: TTextWriter; P: PUtf8Char;
+  esc: TTextWriterHtmlEscape = [heHtmlEscape, heEmojiToUtf8]);
+
+/// convert minimal Markdown text into proper HTML
+// - see https://enterprise.github.com/downloads/en/markdown-cheatsheet.pdf
+// - convert all #13#10 into 
...
, *..* into .., **..** into
+// .., `...` into ..., backslash espaces \\
+// \* \_ and so on, [title](http://...) and detect plain http:// as
+// 
+// - create unordered lists from trailing * + - chars, blockquotes from
+// trailing > char, and code line from 4 initial spaces
+// - as with default Markdown, won't escape HTML special chars (i.e. you can
+// write plain HTML in the supplied text) unless esc is set otherwise
+// - only inline-style links and images are supported yet (not reference-style);
+// tables aren't supported either
+procedure AddHtmlEscapeMarkdown(W: TTextWriter; P: PUtf8Char;
+  esc: TTextWriterHtmlEscape = [heEmojiToUtf8]);
+
+/// escape some wiki-marked text into HTML
+// - just a wrapper around AddHtmlEscapeWiki() process
+function HtmlEscapeWiki(const wiki: RawUtf8;
+  esc: TTextWriterHtmlEscape = [heHtmlEscape, heEmojiToUtf8]): RawUtf8;
+
+/// escape some Markdown-marked text into HTML
+// - just a wrapper around AddHtmlEscapeMarkdown() process
+function HtmlEscapeMarkdown(const md: RawUtf8;
+  esc: TTextWriterHtmlEscape = [heEmojiToUtf8]): RawUtf8;
+
+type
+  /// map the first Unicode page of Emojis, from U+1F600 to U+1F64F
+  // - naming comes from github/Markdown :identifiers:
+  TEmoji = (
+    eNone,
+    eGrinning,
+    eGrin,
+    eJoy,
+    eSmiley,
+    eSmile,
+    eSweat_smile,
+    eLaughing,
+    eInnocent,
+    eSmiling_imp,
+    eWink,
+    eBlush,
+    eYum,
+    eRelieved,
+    eHeart_eyes,
+    eSunglasses,
+    eSmirk,
+    eNeutral_face,
+    eExpressionless,
+    eUnamused,
+    eSweat,
+    ePensive,
+    eConfused,
+    eConfounded,
+    eKissing,
+    eKissing_heart,
+    eKissing_smiling_eyes,
+    eKissing_closed_eyes,
+    eStuck_out_tongue,
+    eStuck_out_tongue_winking_eye,
+    eStuck_out_tongue_closed_eyes,
+    eDisappointed,
+    eWorried,
+    eAngry,
+    ePout,
+    eCry,
+    ePersevere,
+    eTriumph,
+    eDisappointed_relieved,
+    eFrowning,
+    eAnguished,
+    eFearful,
+    eWeary,
+    eSleepy,
+    eTired_face,
+    eGrimacing,
+    eSob,
+    eOpen_mouth,
+    eHushed,
+    eCold_sweat,
+    eScream,
+    eAstonished,
+    eFlushed,
+    eSleeping,
+    eDizzy_face,
+    eNo_mouth,
+    eMask,
+    eSmile_cat,
+    eJoy_cat,
+    eSmiley_cat,
+    eHeart_eyes_cat,
+    eSmirk_cat,
+    eKissing_cat,
+    ePouting_cat,
+    eCrying_cat_face,
+    eScream_cat,
+    eSlightly_frowning_face,
+    eSlightly_smiling_face,
+    eUpside_down_face,
+    eRoll_eyes,
+    eNo_good,
+    oOk_woman,
+    eBow,
+    eSee_no_evil,
+    eHear_no_evil,
+    eSpeak_no_evil,
+    eRaising_hand,
+    eRaised_hands,
+    eFrowning_woman,
+    ePerson_with_pouting_face,
+    ePray);
+
+var
+  /// github/Markdown compatible text of Emojis
+  // - e.g. 'grinning' or 'person_with_pouting_face'
+  EMOJI_TEXT: array[TEmoji] of RawUtf8;
+
+  /// github/Markdown compatible tag of Emojis, including trailing and ending :
+  // - e.g. ':grinning:' or ':person_with_pouting_face:'
+  EMOJI_TAG: array[TEmoji] of RawUtf8;
+
+  /// the Unicode character matching a given Emoji, after UTF-8 encoding
+  EMOJI_UTF8: array[TEmoji] of RawUtf8;
+
+  /// low-level access to TEmoji RTTI - used when inlining EmojiFromText()
+  EMOJI_RTTI: PShortString;
+
+  /// to recognize simple :) :( :| :/ :D :o :p :s characters as smilleys
+  EMOJI_AFTERDOTS: array['('..'|'] of TEmoji;
+
+/// recognize github/Markdown compatible text of Emojis
+// - for instance 'sunglasses' text buffer will return eSunglasses
+// - returns eNone if no case-insensitive match was found
+function EmojiFromText(P: PUtf8Char; len: PtrInt): TEmoji;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// low-level parser of github/Markdown compatible text of Emojis
+// - supplied P^ should point to ':'
+// - will append the recognized UTF-8 Emoji if P contains e.g. :joy: or :)
+// - will append ':' if no Emoji text is recognized, and return eNone
+// - will try both EMOJI_AFTERDOTS[] and EMOJI_RTTI[] reference set
+// - if W is nil, won't append anything, but just return the recognized TEmoji
+function EmojiParseDots(var P: PUtf8Char; W: TTextWriter = nil): TEmoji;
+
+/// low-level conversion of UTF-8 Emoji sequences into github/Markdown :identifiers:
+procedure EmojiToDots(P: PUtf8Char; W: TTextWriter); overload;
+
+/// conversion of UTF-8 Emoji sequences into github/Markdown :identifiers:
+function EmojiToDots(const text: RawUtf8): RawUtf8; overload;
+
+/// low-level conversion of github/Markdown :identifiers: into UTF-8 Emoji sequences
+procedure EmojiFromDots(P: PUtf8Char; W: TTextWriter); overload;
+
+/// conversion of github/Markdown :identifiers: into UTF-8 Emoji sequences
+function EmojiFromDots(const text: RawUtf8): RawUtf8; overload;
+
+
+{ ************ RawByteString Buffers Aggregation via TRawByteStringGroup }
+
+type
+  /// item as stored in a TRawByteStringGroup instance
+  TRawByteStringGroupValue = record
+    Position: integer;
+    Value: RawByteString;
+  end;
+
+  PRawByteStringGroupValue = ^TRawByteStringGroupValue;
+
+  /// items as stored in a TRawByteStringGroup instance
+  TRawByteStringGroupValueDynArray = array of TRawByteStringGroupValue;
+
+  /// store several RawByteString content with optional concatenation
+  {$ifdef USERECORDWITHMETHODS}
+  TRawByteStringGroup = record
+  {$else}
+  TRawByteStringGroup = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// actual list storing the data
+    Values: TRawByteStringGroupValueDynArray;
+    /// how many items are currently stored in Values[]
+    Count: integer;
+    /// the current size of data stored in Values[]
+    Position: integer;
+    /// naive but efficient cache for Find()
+    LastFind: integer;
+    /// add a new item to Values[]
+    procedure Add(const aItem: RawByteString); overload;
+    /// add a new item to Values[]
+    procedure Add(aItem: pointer; aItemLen: integer); overload;
+    /// add another TRawByteStringGroup to Values[]
+    procedure Add(const aAnother: TRawByteStringGroup); overload;
+    /// low-level method to abort the latest Add() call
+    // - warning: will work only once, if an Add() has actually been just called:
+    // otherwise, the behavior is unexpected, and may wrongly truncate data
+    procedure RemoveLastAdd;
+    /// compare two TRawByteStringGroup instance stored text
+    function Equals(const aAnother: TRawByteStringGroup): boolean;
+    /// clear any stored information
+    procedure Clear;
+    /// append stored information into another RawByteString, and clear content
+    procedure AppendTextAndClear(var aDest: RawByteString);
+    // compact the Values[] array into a single item
+    // - is also used by AsText to compute a single RawByteString
+    procedure Compact;
+    /// return all content as a single RawByteString
+    // - will also compact the Values[] array into a single item (which is returned)
+    function AsText: RawByteString;
+    /// return all content as a single TByteDynArray
+    function AsBytes: TByteDynArray;
+    /// save all content into a TJsonWriter instance
+    procedure Write(W: TTextWriter; Escape: TTextWriterKind = twJsonEscape); overload;
+    /// save all content into a TBufferWriter instance
+    procedure WriteBinary(W: TBufferWriter); overload;
+    /// save all content as a string into a TBufferWriter instance
+    // - storing the length as WriteVarUInt32() prefix
+    procedure WriteString(W: TBufferWriter);
+    /// add another TRawByteStringGroup previously serialized via WriteString()
+    procedure AddFromReader(var aReader: TFastReader);
+    /// returns a pointer to Values[] containing a given position
+    // - returns nil if not found
+    function Find(aPosition: integer): PRawByteStringGroupValue; overload;
+    /// returns a pointer to Values[].Value containing a given position and length
+    // - returns nil if not found
+    function Find(aPosition, aLength: integer): pointer; overload;
+    /// returns the text at a given position in Values[]
+    // - text should be in a single Values[] entry
+    procedure FindAsText(aPosition, aLength: integer; out aText: RawByteString); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// returns the text at a given position in Values[]
+    // - text should be in a single Values[] entry
+    function FindAsText(aPosition, aLength: integer): RawByteString; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// returns the text at a given position in Values[] via RawUtf8ToVariant()
+    // - text should be in a single Values[] entry
+    // - explicitly returns null if the supplied text was not found
+    procedure FindAsVariant(aPosition, aLength: integer; out aDest: variant);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append the text at a given position in Values[], JSON escaped by default
+    // - text should be in a single Values[] entry
+    procedure FindWrite(aPosition, aLength: integer; W: TTextWriter;
+      Escape: TTextWriterKind = twJsonEscape; TrailingCharsToIgnore: integer = 0);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append the blob at a given position in Values[], Base64 encoded
+    // - text should be in a single Values[] entry
+    procedure FindWriteBase64(aPosition, aLength: integer; W: TTextWriter;
+      withMagic: boolean);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// copy the text at a given position in Values[]
+    // - text should be in a single Values[] entry
+    procedure FindMove(aPosition, aLength: integer; aDest: pointer);
+      {$ifdef HASINLINE}inline;{$endif}
+  end;
+
+  /// pointer reference to a TRawByteStringGroup
+  PRawByteStringGroup = ^TRawByteStringGroup;
+
+  /// thread-safe reusable set of constant RawByteString instances
+  // - use internally its own TLockedList O(1) efficient structure
+  // - warning: any call to New() should manually be followed by one Release()
+  TRawByteStringCached = class
+  protected
+    fLength: integer;
+    fOne: TLockedList;
+  public
+    /// initialize the internal cache for a given length
+    constructor Create(aLength: integer);
+    /// return a new RawByteString of a given length, with refcount = -2
+    // - may be allocated or returned from its internal cache
+    procedure New(var aDest: RawByteString;
+      aCodePage: integer = CP_RAWBYTESTRING); overload;
+    /// return a new RawUtf8 of a given length, with refcount = -2
+    procedure New(var aDest: RawUtf8); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// return a new RawUtf8 of a given length into a pointer, with refcount = -2
+    procedure NewUtf8(var aDest: pointer);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// put back a RawByteString acquired from New() into the internal cache
+    procedure Release(var aDest: RawByteString); overload;
+    /// put back a RawUtf8 acquired from New() into the internal cache
+    procedure Release(var aDest: RawUtf8); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// put back a RawByteString acquired from NewUtf8() into the internal cache
+    procedure Release(var aDest: pointer); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// release the RawByteString instances in the cache bin
+    // - keep any existing New() instances intact
+    // - returns how many memory has been released to the heap
+    function Clean: PtrInt;
+    /// release all cached instances
+    destructor Destroy; override;
+    /// how many New() calls are currently active
+    property Count: integer
+      read fOne.Count;
+    /// the length() of RawByteString returned by New()
+    property Length: integer
+      read fLength;
+  end;
+
+  /// store one RawByteString content with an associated length
+  // - to be used e.g. as a convenient reusable memory buffer
+  {$ifdef USERECORDWITHMETHODS}
+  TRawByteStringBuffer = record
+  {$else}
+  TRawByteStringBuffer = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    fBuffer: RawUtf8; /// actual storage, with length(fBuffer) as Capacity
+    fLen: PtrInt;
+    procedure RawAppend(P: pointer; PLen: PtrInt);
+      {$ifdef HASINLINE}inline;{$endif}
+    procedure RawRealloc(needed: PtrInt);
+  public
+    /// set Len to 0, but doesn't clear/free the Buffer itself
+    procedure Reset;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// release/free the internal Buffer storage
+    procedure Clear;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// a convenient wrapper to pointer(fBuffer) for direct Buffer/Len use
+    function Buffer: pointer;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// how many bytes are currently allocated in the Buffer
+    function Capacity: PtrInt;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// add some UTF-8 buffer content to the Buffer, resizing it if needed
+    procedure Append(P: pointer; PLen: PtrInt); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// add some UTF-8 string content to the Buffer, resizing it if needed
+    procedure Append(const Text: RawUtf8); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// add some number as text content to the Buffer, resizing it if needed
+    procedure Append(Value: QWord); overload;
+    /// add some UTF-8 shortstring content to the Buffer, resizing it if needed
+    procedure AppendShort(const Text: ShortString);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// add some UTF-8 string(s) content to the Buffer, resizing it if needed
+    procedure Append(const Text: array of RawUtf8); overload;
+    /// just after Append/AppendShort, append a #13#10 end of line
+    procedure AppendCRLF;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// just after Append/AppendShort, append one single character
+    procedure Append(Ch: AnsiChar); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// add some UTF-8 buffer content to the Buffer, without resizing it
+    function TryAppend(P: pointer; PLen: PtrInt): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// ensure the internal Buffer has at least MaxSize bytes
+    // - also reset the internal Len to 0
+    procedure Reserve(MaxSize: PtrInt); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// use a specified string buffer as start
+    procedure Reserve(const WorkingBuffer: RawByteString); overload;
+    /// similar to delete(fBuffer, 1, FirstBytes)
+    procedure Remove(FirstBytes: PtrInt);
+    /// move up to Count bytes from the internal Buffer into another place
+    // - returns how many bytes were available to be copied into Dest^
+    // - then remove the copied bytes from the internal Buffer/Len storage
+    function Extract(Dest: pointer; Count: PtrInt): PtrInt;
+    /// move up to Count bytes from the internal Buffer into another place
+    // - returns how many bytes were available to be copied into Dest^
+    // - don't move any byte, but just update the given Pos index
+    function ExtractAt(var Dest: PAnsiChar; var Count: PtrInt;
+      var Pos: PtrInt): PtrInt;
+    /// similar to insert(P/PLen, fBuffer, Position + 1)
+    // - could optionally include a #13#10 pattern between the two
+    procedure Insert(P: pointer; PLen: PtrInt; Position: PtrInt = 0;
+      CRLF: boolean = false);
+    /// retrieve the current Buffer/Len content as RawUtf8 text
+    // - with some optional overhead for faster reallocmem at concatenation
+    // - won't force Len to 0: caller should call Reset if done with it
+    // - UseMainBuffer=true will return a copy of fBuffer into Text
+    procedure AsText(out Text: RawUtf8; Overhead: PtrInt = 0;
+      UseMainBuffer: boolean = false);
+    /// how many bytes are currently used in the Buffer
+    property Len: PtrInt
+      read fLen write fLen;
+  end;
+
+  /// pointer reference to a TRawByteStringBuffer
+  PRawByteStringBuffer = ^TRawByteStringBuffer;
+
+
+implementation
+
+
+{ ************ Variable Length Integer Encoding / Decoding }
+
+function ToVarInt32(Value: PtrInt; Dest: PByte): PByte;
+begin
+  // 0=0,1=1,2=-1,3=2,4=-2...
+  if Value < 0 then
+    // -1->2, -2->4..
+    Value := (-Value) shl 1
+  else if Value > 0 then
+    // 1->1, 2->3..
+    Value := (Value shl 1) - 1;
+    // 0->0
+  result := ToVarUInt32(Value, Dest);
+end;
+
+function ToVarUInt32(Value: cardinal; Dest: PByte): PByte;
+label
+  _1, _2, _3; // ugly but fast
+begin
+  if Value > $7f then
+  begin
+    if Value < $80 shl 7 then
+      goto _1
+    else if Value < $80 shl 14 then
+      goto _2
+    else if Value < $80 shl 21 then
+      goto _3;
+    Dest^ := (Value and $7F) or $80;
+    Value := Value shr 7;
+    inc(Dest);
+_3: Dest^ := (Value and $7F) or $80;
+    Value := Value shr 7;
+    inc(Dest);
+_2: Dest^ := (Value and $7F) or $80;
+    Value := Value shr 7;
+    inc(Dest);
+_1: Dest^ := (Value and $7F) or $80;
+    Value := Value shr 7;
+    inc(Dest);
+  end;
+  Dest^ := Value;
+  inc(Dest);
+  result := Dest;
+end;
+
+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;
+
+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;
+var
+  c: cardinal;
+  p: PByte;
+begin
+  p := Source;
+  result := p^;
+  inc(p);
+  if result > $7f then
+  begin
+    // Values between 128 and 16256
+    c := p^;
+    c := c shl 7;
+    result := result and $7F or c;
+    inc(p);
+    if c > $7f shl 7 then
+    begin
+      // Values between 16257 and 2080768
+      c := p^;
+      c := c shl 14;
+      inc(p);
+      result := result and $3FFF or c;
+      if c > $7f shl 14 then
+      begin
+        // Values between 2080769 and 266338304
+        c := p^;
+        c := c shl 21;
+        inc(p);
+        result := result and $1FFFFF or c;
+        if c > $7f shl 21 then
+        begin
+          // Values above 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
+  // Values above 127
+  p := Source;
+  result := p^ shl 7;
+  inc(p);
+  if result > $7f shl 7 then
+  begin
+    // Values above 16256
+    c := p^;
+    c := c shl 14;
+    inc(p);
+    result := result and $3FFF or c;
+    if c > $7f shl 14 then
+    begin
+      // Values above 2080768
+      c := p^;
+      c := c shl 21;
+      inc(p);
+      result := result and $1FFFFF or c;
+      if c > $7f shl 21 then
+      begin
+        // Values above 266338304
+        c := p^;
+        c := c shl 28;
+        inc(p);
+        result := result and $FFFFFFF or c;
+      end;
+    end;
+  end;
+  Source := p;
+end;
+
+function FromVarUInt32(var Source: PByte; SourceMax: PByte;
+  out Value: cardinal): boolean;
+begin
+  if SourceMax = nil then
+  begin
+    Value := FromVarUInt32(Source);
+    result := true;
+  end
+  else
+  begin
+    Source := FromVarUInt32Safe(Source, SourceMax, Value);
+    result := Source <> nil;
+  end;
+end;
+
+function FromVarUInt32Safe(Source, SourceMax: PByte; out Value: cardinal): PByte;
+var
+  c: cardinal;
+begin
+  result := nil; // error
+  if PAnsiChar(Source) >= PAnsiChar(SourceMax) then
+    exit;
+  c := Source^;
+  inc(Source);
+  Value := c;
+  if c > $7f then
+  begin
+    // Values between 128 and 16256
+    if PAnsiChar(Source) >= PAnsiChar(SourceMax) then
+      exit;
+    c := Source^;
+    c := c shl 7;
+    Value := Value and $7F or c;
+    inc(Source);
+    if c > $7f shl 7 then
+    begin
+      // Values between 16257 and 2080768
+      if PAnsiChar(Source) >= PAnsiChar(SourceMax) then
+        exit;
+      c := Source^;
+      c := c shl 14;
+      inc(Source);
+      Value := Value and $3FFF or c;
+      if c > $7f shl 14 then
+      begin
+        // Values between 2080769 and 266338304
+        if PAnsiChar(Source) >= PAnsiChar(SourceMax) then
+          exit;
+        c := Source^;
+        c := c shl 21;
+        inc(Source);
+        Value := Value and $1FFFFF or c;
+        if c > $7f shl 21 then
+        begin
+          // Values above 266338304
+          if PAnsiChar(Source) >= PAnsiChar(SourceMax) then
+            exit;
+          c := Source^;
+          c := c shl 28;
+          inc(Source);
+          Value := Value and $FFFFFFF or c;
+        end;
+      end;
+    end;
+  end;
+  result := Source; // safely decoded
+end;
+
+function FromVarInt32(var Source: PByte): integer;
+var
+  c: cardinal;
+  p: PByte;
+begin
+  // fast stand-alone function with no FromVarUInt32 call
+  p := Source;
+  result := p^;
+  inc(p);
+  if result > $7f then
+  begin
+    c := p^;
+    c := c shl 7;
+    result := result and $7F or integer(c);
+    inc(p);
+    if c > $7f shl 7 then
+    begin
+      c := p^;
+      c := c shl 14;
+      inc(p);
+      result := result and $3FFF or integer(c);
+      if c > $7f shl 14 then
+      begin
+        c := p^;
+        c := c shl 21;
+        inc(p);
+        result := result and $1FFFFF or integer(c);
+        if c > $7f shl 21 then
+        begin
+          c := p^;
+          c := c shl 28;
+          inc(p);
+          result := result and $FFFFFFF or integer(c);
+        end;
+      end;
+    end;
+  end;
+  Source := p;
+  // 0=0,1=1,2=-1,3=2,4=-2...
+  if result and 1 <> 0 then
+    // 1->1, 3->2..
+    result := result shr 1 + 1
+  else
+    // 0->0, 2->-1, 4->-2..
+    result := -(result shr 1);
+end;
+
+function FromVarUInt32High(var Source: PByte): cardinal;
+var
+  c: cardinal;
+begin
+  result := Source^;
+  inc(Source);
+  c := Source^ shl 7;
+  inc(Source);
+  result := result and $7F or c;
+  if c <= $7f shl 7 then
+    exit;
+  c := Source^ shl 14;
+  inc(Source);
+  result := result and $3FFF or c;
+  if c <= $7f shl 14 then
+    exit;
+  c := Source^ shl 21;
+  inc(Source);
+  result := result and $1FFFFF or c;
+  if c <= $7f shl 21 then
+    exit;
+  c := Source^ shl 28;
+  inc(Source);
+  result := result and $FFFFFFF or c;
+end;
+
+function ToVarInt64(Value: Int64; Dest: PByte): PByte;
+begin
+  // 0=0,1=1,2=-1,3=2,4=-2...
+{$ifdef CPU32}
+  if Value <= 0 then
+    // 0->0, -1->2, -2->4..
+    result := ToVarUInt64((-Value) shl 1, Dest)
+  else
+     // 1->1, 2->3..
+    result := ToVarUInt64((Value shl 1) - 1, Dest);
+{$else}
+  if Value <= 0 then
+    // 0->0, -1->2, -2->4..
+    Value := (-Value) shl 1
+  else
+    // 1->1, 2->3..
+    Value := (Value shl 1) - 1;
+  result := ToVarUInt64(Value, Dest);
+{$endif CPU32}
+end;
+
+function ToVarUInt64(Value: QWord; Dest: PByte): PByte;
+var
+  c: cardinal;
+label
+  _1, _2, _4; // ugly but fast
+begin
+  repeat
+    c := Value;
+    {$ifdef CPU32}
+    if PCardinalArray(@Value)^[1] = 0 then
+    {$else}
+    if Value shr 32 = 0 then
+    {$endif CPU32}
+      begin
+        if c > $7f then
+        begin
+          if c < $80 shl 7 then
+            goto _1
+          else if c < $80 shl 14 then
+            goto _2
+          else if c >= $80 shl 21 then
+            goto _4;
+          Dest^ := (c and $7F) or $80;
+          c := c shr 7;
+          inc(Dest);
+_2:       Dest^ := (c and $7F) or $80;
+          c := c shr 7;
+          inc(Dest);
+_1:       Dest^ := (c and $7F) or $80;
+          c := c shr 7;
+          inc(Dest);
+        end;
+        Dest^ := c;
+        inc(Dest);
+        result := Dest;
+        exit;
+      end;
+_4: PCardinal(Dest)^ := (c and $7F) or (((c shr 7) and $7F) shl 8) or
+      (((c shr 14) and $7F) shl 16) or (((c shr 21) and $7F) shl 24) or $80808080;
+    inc(Dest, 4);
+    Value := Value shr 28;
+  until false;
+end;
+
+function FromVarUInt64(var Source: PByte): QWord;
+var
+  c, n: PtrUInt;
+  p: PByte;
+begin
+  p := Source;
+  {$ifdef CPU64}
+  result := p^;
+  if result > $7f then
+  begin
+    result := result and $7F;
+  {$else}
+  if p^ > $7f then
+  begin
+    result := PtrUInt(p^) and $7F;
+  {$endif CPU64}
+    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
+  {$ifdef CPU32}
+  else
+    result := p^
+  {$endif CPU32};
+  inc(p);
+  Source := p;
+end;
+
+function FromVarUInt64Safe(Source, SourceMax: PByte; out Value: QWord): PByte;
+var
+  c, n: PtrUInt;
+begin
+  result := nil; // error
+  if PAnsiChar(Source) >= PAnsiChar(SourceMax) then
+    exit;
+  c := Source^;
+  inc(Source);
+  if c > $7f then
+  begin
+    Value := c and $7F;
+    n := 7;
+    repeat
+      if PAnsiChar(Source) >= PAnsiChar(SourceMax) then
+        exit;
+      c := Source^;
+      inc(Source);
+      if c <= $7f then
+        break;
+      c := c and $7f;
+      Value := Value or (QWord(c) shl n);
+      inc(n, 7);
+    until false;
+    Value := Value or (QWord(c) shl n);
+  end
+  else
+    Value := c;
+  result := Source; // safely decoded
+end;
+
+function FromVarUInt64(var Source: PByte; SourceMax: PByte; out Value: QWord): boolean;
+begin
+  if SourceMax = nil then
+  begin
+    Value := FromVarUInt64(Source);
+    result := true;
+  end
+  else
+  begin
+    Source := FromVarUInt64Safe(Source, SourceMax, Value);
+    result := Source <> nil;
+  end;
+end;
+
+function FromVarInt64(var Source: PByte): Int64;
+var
+  c, n: PtrUInt;
+begin
+  // 0=0,1=1,2=-1,3=2,4=-2...
+{$ifdef CPU64}
+  result := Source^;
+  if result > $7f then
+  begin
+    result := result and $7F;
+    n := 0;
+    inc(Source);
+    repeat
+      c := Source^;
+      inc(n, 7);
+      if c <= $7f then
+        break;
+      result := result or (Int64(c and $7f) shl n);
+      inc(Source);
+    until false;
+    result := result or (Int64(c) shl n);
+  end;
+  if result and 1 <> 0 then
+    // 1->1, 3->2..
+    result := result shr 1 + 1
+  else
+    // 0->0, 2->-1, 4->-2..
+    result := -(result shr 1);
+{$else}
+  c := Source^;
+  if c > $7f then
+  begin
+    result := c and $7F;
+    n := 0;
+    inc(Source);
+    repeat
+      c := Source^;
+      inc(n, 7);
+      if c <= $7f then
+        break;
+      result := result or (Int64(c and $7f) shl n);
+      inc(Source);
+    until false;
+    result := result or (Int64(c) shl n);
+    if PCardinal(@result)^ and 1 <> 0 then
+      // 1->1, 3->2..
+      result := result shr 1 + 1
+    else
+      // 0->0, 2->-1, 4->-2..
+      result := -(result shr 1);
+  end
+  else
+  begin
+    if c = 0 then
+      result := 0
+    else if c and 1 = 0 then
+      // 0->0, 2->-1, 4->-2..
+      result := -Int64(c shr 1)
+    else
+      // 1->1, 3->2..
+      result := (c shr 1) + 1;
+  end;
+{$endif CPU64}
+  inc(Source);
+end;
+
+function FromVarInt64Value(Source: PByte): Int64;
+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);
+    {$ifdef CPU64}
+    if result and 1 <> 0 then
+    {$else}
+    if PCardinal(@result)^ and 1 <> 0 then
+    {$endif CPU64}
+      // 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;
+
+function GotoNextVarInt(Source: PByte): pointer;
+begin
+  if Source <> nil then
+  begin
+    if Source^ > $7f then
+      repeat
+        inc(Source)
+      until Source^ <= $7f;
+    inc(Source);
+  end;
+  result := Source;
+end;
+
+
+function ToVarString(const Value: RawUtf8; Dest: PByte): PByte;
+var
+  Len: integer;
+begin
+  Len := Length(Value);
+  Dest := ToVarUInt32(Len, Dest);
+  if Len > 0 then
+  begin
+    MoveFast(pointer(Value)^, Dest^, Len);
+    result := pointer(PAnsiChar(Dest) + Len);
+  end
+  else
+    result := Dest;
+end;
+
+function GotoNextVarString(Source: PByte): pointer;
+begin
+  result := Pointer(PtrUInt(Source) + FromVarUInt32(Source));
+end;
+
+function FromVarString(var Source: PByte): RawUtf8;
+begin
+  FromVarString(Source, result{%H-});
+end;
+
+procedure FromVarString(var Source: PByte; var Value: RawUtf8);
+var
+  len: PtrUInt;
+begin
+  len := FromVarUInt32(Source);
+  FastSetString(Value, Source, len);
+  inc(Source, len);
+end;
+
+function FromVarString(var Source: PByte; SourceMax: PByte): RawUtf8;
+var
+  len: cardinal;
+begin
+  Source := FromVarUInt32Safe(Source, SourceMax, len);
+  if (Source = nil) or
+      (PAnsiChar(Source) + len > PAnsiChar(SourceMax)) then
+    len := 0;
+  FastSetString(result{%H-}, Source, len);
+  inc(Source, len);
+end;
+
+procedure FromVarString(var Source: PByte; var Value: TSynTempBuffer);
+var
+  len: integer;
+begin
+  len := FromVarUInt32(Source);
+  Value.Init(Source, len);
+  PByteArray(Value.buf)[len] := 0; // include trailing #0
+  inc(Source, len);
+end;
+
+function FromVarString(var Source: PByte; SourceMax: PByte;
+  var Value: TSynTempBuffer): boolean;
+var
+  len: cardinal;
+begin
+  if SourceMax = nil then
+    len := FromVarUInt32(Source)
+  else
+  begin
+    Source := FromVarUInt32Safe(Source, SourceMax, len);
+    if (Source = nil) or
+       (PAnsiChar(Source) + len > PAnsiChar(SourceMax)) then
+    begin
+      result := false;
+      exit;
+    end;
+  end;
+  Value.Init(Source, len);
+  PByteArray(Value.buf)[len] := 0; // include trailing #0
+  inc(Source, len);
+  result := true;
+end;
+
+procedure FromVarString(var Source: PByte; var Value: RawByteString;
+  CodePage: integer);
+var
+  Len: PtrUInt;
+begin
+  Len := FromVarUInt32(Source);
+  FastSetStringCP(Value, Source, Len, CodePage);
+  inc(Source, Len);
+end;
+
+function FromVarString(var Source: PByte; SourceMax: PByte;
+  var Value: RawByteString; CodePage: integer): boolean;
+var
+  len: cardinal;
+begin
+  if SourceMax = nil then
+    len := FromVarUInt32(Source)
+  else
+  begin
+    Source := FromVarUInt32Safe(Source, SourceMax, len);
+    if (Source = nil) or
+       (PAnsiChar(Source) + len > PAnsiChar(SourceMax)) then
+    begin
+      result := false;
+      exit;
+    end;
+  end;
+  FastSetStringCP(Value, Source, len, CodePage);
+  inc(Source, len);
+  result := true;
+end;
+
+function FromVarBlob(Data: PByte): TValueResult;
+begin
+  result.Len := FromVarUInt32(Data);
+  result.Ptr := pointer(Data);
+end;
+
+
+{ ****************** TFastReader / TBufferWriter Binary Streams }
+
+{ TFastReader }
+
+procedure TFastReader.Init(Buffer: pointer; Len: PtrInt);
+begin
+  P := Buffer;
+  Last := PAnsiChar(Buffer) + Len;
+  OnErrorOverflow := nil;
+  OnErrorData := nil;
+  CustomVariants := nil;
+end;
+
+procedure TFastReader.Init(const Buffer: RawByteString);
+begin
+  Init(pointer(Buffer), length(Buffer));
+end;
+
+procedure TFastReader.ErrorOverflow;
+begin
+  if Assigned(OnErrorOverflow) then
+    OnErrorOverflow
+  else
+    raise EFastReader.Create('Reached End of Input');
+end;
+
+procedure TFastReader.ErrorData(const fmt: RawUtf8; const args: array of const);
+begin
+  if Assigned(OnErrorData) then
+    OnErrorData(fmt, args)
+  else
+    raise EFastReader.CreateUtf8('Incorrect Data: ' + fmt, args);
+end;
+
+procedure TFastReader.ErrorData(const msg: shortstring);
+begin
+  ErrorData('%', [msg]);
+end;
+
+function TFastReader.EOF: boolean;
+begin
+  result := P >= Last;
+end;
+
+function TFastReader.RemainingLength: PtrUInt;
+begin
+  result := PtrUInt(Last) - PtrUInt(P);
+end;
+
+function TFastReader.NextByte: byte;
+begin
+  if P >= Last then
+    ErrorOverflow;
+  result := ord(P^);
+  inc(P);
+end;
+
+function TFastReader.NextByteSafe(dest: pointer): boolean;
+begin
+  if P >= Last then
+    result := false
+  else
+  begin
+    PAnsiChar(dest)^ := P^;
+    inc(P);
+    result := true;
+  end;
+end;
+
+function TFastReader.Next2: cardinal;
+begin
+  if P + 1 >= Last then
+    ErrorOverflow;
+  result := PWord(P)^;
+  inc(P, 2);
+end;
+
+function TFastReader.Next2BigEndian: cardinal;
+begin
+  if P + 1 >= Last then
+    ErrorOverflow;
+  result := swap(PWord(P)^);
+  inc(P, 2);
+end;
+
+function TFastReader.Next4: cardinal;
+begin
+  if P + 3 >= Last then
+    ErrorOverflow;
+  result := PCardinal(P)^;
+  inc(P, 4);
+end;
+
+function TFastReader.Next8: Qword;
+begin
+  if P + 7 >= Last then
+    ErrorOverflow;
+  result := PQWord(P)^;
+  inc(P, 8);
+end;
+
+function TFastReader.NextByteEquals(Value: byte): boolean;
+begin
+  if P >= Last then
+    ErrorOverflow;
+  if ord(P^) = Value then
+  begin
+    inc(P);
+    result := true;
+  end
+  else
+    result := false;
+end;
+
+function TFastReader.Next(DataLen: PtrInt): pointer;
+begin
+  if P + DataLen > Last then
+    ErrorOverflow;
+  result := P;
+  inc(P, DataLen);
+end;
+
+function TFastReader.NextSafe(out Data: Pointer; DataLen: PtrInt): boolean;
+begin
+  if P + DataLen > Last then
+    result := false
+  else
+  begin
+    Data := P;
+    inc(P, DataLen);
+    result := true;
+  end;
+end;
+
+procedure TFastReader.Copy(Dest: Pointer; DataLen: PtrInt);
+begin
+  if P + DataLen > Last then
+    ErrorOverflow;
+  MoveFast(P^, Dest^, DataLen);
+  inc(P, DataLen);
+end;
+
+function TFastReader.CopySafe(Dest: Pointer; DataLen: PtrInt): boolean;
+begin
+  if P + DataLen > Last then
+    result := false
+  else
+  begin
+    MoveFast(P^, Dest^, DataLen);
+    inc(P, DataLen);
+    result := true;
+  end;
+end;
+
+function TFastReader.VarInt32: integer;
+begin
+  result := VarUInt32;
+  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 TFastReader.VarInt64: Int64;
+begin
+  result := VarUInt64;
+  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;
+
+{$ifdef CPUX86} // not enough CPU registers
+
+function TFastReader.VarUInt32: cardinal;
+var
+  c: cardinal;
+label
+  e;
+begin
+  if P >= Last then
+    goto e;
+  result := ord(P^);
+  inc(P);
+  if result <= $7f then
+    exit;
+  if P >= Last then
+    goto e;
+  c := ord(P^) shl 7;
+  inc(P);
+  result := result and $7F or c;
+  if c <= $7f shl 7 then
+    exit; // Values between 128 and 16256
+  if P >= Last then
+    goto e;
+  c := ord(P^) shl 14;
+  inc(P);
+  result := result and $3FFF or c;
+  if c <= $7f shl 14 then
+    exit; // Values between 16257 and 2080768
+  if P >= Last then
+    goto e;
+  c := ord(P^) shl 21;
+  inc(P);
+  result := result and $1FFFFF or c;
+  if c <= $7f shl 21 then
+    exit; // Values between 2080769 and 266338304
+  if P >= Last then
+e:begin
+    {$ifdef ISDELPHI}
+    result := 0; // avoid paranoid compiler hint
+    {$endif ISDELPHI}
+    ErrorOverflow;
+  end;
+  c := ord(P^) shl 28;
+  inc(P);
+  result := result {%H-}and $FFFFFFF or c;
+end;
+
+procedure TFastReader.VarNextInt;
+begin
+  repeat
+    if P >= Last then
+      break;  // reached end of input
+    if P^ <= #$7f then
+      break; // reached end of VarUInt32/VarUInt64
+    inc(P);
+  until false;
+  inc(P);
+end;
+
+procedure TFastReader.VarNextInt(count: integer);
+begin
+  if count = 0 then
+    exit;
+  repeat
+    if P >= Last then
+      break;  // reached end of input
+    if P^ > #$7f then
+    begin
+      inc(P);
+      continue; // didn't reach end of VarUInt32/VarUInt64
+    end;
+    inc(P);
+    dec(count);
+    if count = 0 then
+      break;
+  until false;
+end;
+
+{$else not CPUX86} // on x86_64 and ARM, use registers for P/Last values
+
+function TFastReader.VarUInt32: cardinal;
+var
+  c: cardinal;
+  s, l: PByte;
+label
+  e, f;
+begin
+  s := pointer(P);
+  l := pointer(Last);
+  if PAnsiChar(s) >= PAnsiChar(l) then
+    goto e;
+  result := s^;
+  inc(s);
+  if result <= $7f then
+    goto f;
+  if PAnsiChar(s) >= PAnsiChar(l) then
+    goto e;
+  c := s^ shl 7;
+  inc(s);
+  result := result and $7F or c;
+  if c <= $7f shl 7 then
+    goto f; // Values between 128 and 16256
+  if PAnsiChar(s) >= PAnsiChar(l) then
+    goto e;
+  c := s^ shl 14;
+  inc(s);
+  result := result and $3FFF or c;
+  if c <= $7f shl 14 then
+    goto f; // Values between 16257 and 2080768
+  if PAnsiChar(s) >= PAnsiChar(l) then
+    goto e;
+  c := s^ shl 21;
+  inc(s);
+  result := result and $1FFFFF or c;
+  if c <= $7f shl 21 then
+    goto f; // Values between 2080769 and 266338304
+  if PAnsiChar(s) >= PAnsiChar(l) then
+e:begin
+    {$ifdef ISDELPHI}
+    result := 0; // avoid hint
+    {$endif ISDELPHI}
+    ErrorOverflow;
+  end;
+  c := s^ shl 28;
+  inc(s);
+  result := result {%H-}and $FFFFFFF or c;
+f:P := pointer(s);
+end;
+
+procedure TFastReader.VarNextInt;
+var
+  s, l: PAnsiChar;
+begin
+  s := P;
+  l := Last;
+  repeat
+    if s >= l then
+      break;  // reached end of input
+    if s^ <= #$7f then
+      break; // reached end of VarUInt32/VarUInt64
+    inc(s);
+  until false;
+  P := s + 1;
+end;
+
+procedure TFastReader.VarNextInt(count: integer);
+var
+  s, l: PAnsiChar;
+begin
+  if count = 0 then
+    exit;
+  s := P;
+  l := Last;
+  repeat
+    if s >= l then
+      break;  // reached end of input
+    if s^ > #$7f then
+    begin
+      inc(s);
+      continue; // didn't reach end of VarUInt32/VarUInt64
+    end;
+    inc(s);
+    dec(count);
+    if count = 0 then
+      break;
+  until false;
+  P := s;
+end;
+
+{$endif CPUX86}
+
+function TFastReader.PeekVarInt32(out value: PtrInt): boolean;
+begin
+  result := PeekVarUInt32(PtrUInt(value));
+  if result then
+    if value and 1 <> 0 then
+      // 1->1, 3->2..
+      value := value shr 1 + 1
+    else      // 0->0, 2->-1, 4->-2..
+      value := -(value shr 1);
+end;
+
+function TFastReader.PeekVarUInt32(out value: PtrUInt): boolean;
+var
+  s: PAnsiChar;
+begin
+  result := false;
+  s := P;
+  repeat
+    if s >= Last then
+      exit  // reached end of input -> returns false
+    else if s^ <= #$7f then
+      break; // reached end of VarUInt32
+    inc(s);
+  until false;
+  s := P;
+  value := VarUInt32; // fast value decode
+  P := s; // rewind
+  result := true;
+end;
+
+function TFastReader.VarUInt32Safe(out Value: cardinal): boolean;
+var
+  c, n, v: cardinal;
+begin
+  result := false;
+  if P >= Last then
+    exit;
+  v := ord(P^);
+  inc(P);
+  if v > $7f then
+  begin
+    n := 0;
+    v := v and $7F;
+    repeat
+      if P >= Last then
+        exit;
+      c := ord(P^);
+      inc(P);
+      inc(n, 7);
+      if c <= $7f then
+        break;
+      v := v or ((c and $7f) shl n);
+    until false;
+    v := v or (c shl n);
+  end;
+  Value := v;
+  result := true; // success
+end;
+
+function TFastReader.VarUInt64: QWord;
+label
+  e;
+var
+  c, n: PtrUInt;
+begin
+  if P >= Last then
+e:  ErrorOverflow;
+  c := ord(P^);
+  inc(P);
+  if c > $7f then
+  begin
+    result := c and $7F;
+    n := 0;
+    repeat
+      if P >= Last then
+        goto e;
+      c := ord(P^);
+      inc(P);
+      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
+  else
+    result := c;
+end;
+
+procedure TFastReader.VarBlob(out result: TValueResult);
+var
+  len: PtrUInt;
+begin
+  len := VarUInt32;
+  if P + len > Last then
+    ErrorOverflow;
+  result.Ptr := P;
+  result.Len := len;
+  inc(P, len);
+end;
+
+function TFastReader.VarBlobSafe(out Value: TValueResult): boolean;
+var
+  len: PtrUInt;
+begin
+  len := VarUInt32;
+  if P + len > Last then
+  begin
+    result := false;
+    exit;
+  end;
+  Value.Ptr := P;
+  Value.Len := len;
+  inc(P, len);
+  result := true;
+end;
+
+procedure TFastReader.VarBlob(out Value: TSynTempBuffer);
+var
+  len: PtrUInt;
+begin
+  len := VarUInt32;
+  if P + len > Last then
+    ErrorOverflow;
+  Value.Init(P, len);
+  inc(P, len);
+end;
+
+function TFastReader.VarBlob: TValueResult;
+var
+  len: PtrUInt;
+label
+  e;
+{%H-}begin
+  if P >= Last then
+    goto e;
+  len := ord(P^);
+  if len < $80 then
+    inc(P)
+  else
+    len := VarUInt32;
+  result.Ptr := P;
+  result.Len := len;
+  if P + len <= Last then
+    inc(P, len)
+  else
+e:  ErrorOverflow;
+end;
+
+function TFastReader.VarString: RawByteString;
+begin
+  with VarBlob do
+    FastSetRawByteString(result{%H-}, Ptr, Len);
+end;
+
+function TFastReader.VarString(CodePage: integer): RawByteString;
+begin
+  with VarBlob do
+    FastSetStringCP(result{%H-}, Ptr, Len, CodePage)
+end;
+
+procedure TFastReader.VarUtf8(out result: RawUtf8);
+var
+  len: PtrUInt;
+label
+  e;
+begin
+  if P >= Last then
+    goto e;
+  len := ord(P^);
+  if len < $80 then
+    inc(P)
+  else
+    len := VarUInt32;
+  if P + len <= Last then
+  begin
+    FastSetString(result, P, len);
+    inc(P, len);
+  end
+  else
+e:  ErrorOverflow;
+end;
+
+function TFastReader.VarUtf8: RawUtf8;
+begin
+  VarUtf8(result);
+end;
+
+function TFastReader.VarShortString: ShortString;
+var
+  len: cardinal;
+  s: PAnsiChar;
+label
+  e, r;
+{%H-}begin
+  s := P;
+  if s >= Last then
+    goto e;
+  len := ord(s^);
+  if len <= $7f then
+  begin
+    inc(s);
+r:  P := s;
+    inc(s, len);
+    if s >= Last then
+      goto e;
+    result[0] := AnsiChar(len);
+    MoveFast(P^, result[1], len);
+    P := s;
+    exit;
+  end;
+  len := (len and $7F) or (ord(s^) shl 7); // 2nd byte of VarUInt32 decoding
+  inc(s);
+  if len <= 255 then
+    goto r;
+e:ErrorOverflow;
+end;
+
+function TFastReader.VarUtf8Safe(out Value: RawUtf8): boolean;
+var
+  len: cardinal;
+begin
+  if VarUInt32Safe(len) then
+    if len = 0 then
+      result := true
+    else if P + len <= Last then
+    begin
+      FastSetString(Value, P, len);
+      inc(P, len);
+      result := true;
+    end
+    else
+      result := false
+  else
+    result := false;
+end;
+
+function CleverReadInteger(p, e: 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) < PtrUInt(e) then
+    repeat
+      case p^ of
+        #0:
+          begin
+            // B:0 W:difference with previous
+            inc(i, PWord(p + 1)^);
+            inc(p, 3);
+            V^ := i;
+            inc(V);
+            if PtrUInt(p) < PtrUInt(e) then
+              continue
+            else
+              break;
+          end;
+        #254:
+          begin
+            // B:254 W:byOne
+            for n := 1 to PWord(p + 1)^ do
+            begin
+              inc(i);
+              V^ := i;
+              inc(V);
+            end;
+            inc(p, 3);
+            if PtrUInt(p) < PtrUInt(e) then
+              continue
+            else
+              break;
+          end;
+        #255:
+          begin
+            // B:255 B:byOne
+            for n := 1 to PByte(p + 1)^ do
+            begin
+              inc(i);
+              V^ := i;
+              inc(V);
+            end;
+            inc(p, 2);
+            if PtrUInt(p) < PtrUInt(e) then
+              continue
+            else
+              break;
+          end
+      else
+        begin
+          // B:1..253 = difference with previous
+          inc(i, ord(p^));
+          inc(p);
+          V^ := i;
+          inc(V);
+          if PtrUInt(p) < PtrUInt(e) then
+            continue
+          else
+            break;
+        end;
+      end; // case p^ of
+    until false;
+  result := (PtrUInt(V) - result) shr 2; // returns count of stored integers
+end;
+
+function TFastReader.ReadVarUInt32Array(var Values: TIntegerDynArray): PtrInt;
+var
+  i: PtrInt;
+  k: TBufferWriterKind;
+  pi: PInteger;
+  n, diff: integer;
+  chunk, chunkend: PtrUInt;
+begin
+  result := VarUInt32;
+  if result = 0 then
+    exit;
+  if result > length(Values) then // only set length is not big enough
+    SetLength(Values, result);
+  k := TBufferWriterKind(NextByte);
+  pi := pointer(Values);
+  n := result;
+  case k of
+    wkUInt32:
+      begin
+        Copy(pointer(Values), n * 4);
+        exit;
+      end;
+    wkOffsetU,
+    wkOffsetI:
+      begin
+        pi^ := VarUInt32;
+        dec(n);
+        if n = 0 then
+          exit;
+        diff := VarUInt32;
+        if diff <> 0 then
+        begin
+          // all items have a fixed offset
+          for i := 0 to n - 1 do
+            PIntegerArray(pi)[i + 1] := PIntegerArray(pi)[i] + diff;
+          exit;
+        end
+      end;
+    wkFakeMarker:
+      begin
+        // caller should make the decoding: notify by returning the count as <0
+        result := -result;
+        exit;
+      end;
+  end;
+  repeat
+    // chunked format: Isize+values
+    chunkend := Next4;
+    chunk := PtrUInt(Next(chunkend));
+    inc(chunkend, chunk);
+    case k of
+      wkVarInt32:
+        repeat
+          pi^ := FromVarInt32(PByte(chunk));
+          inc(pi);
+          dec(n);
+        until (n = 0) or
+              (chunk >= chunkend);
+      wkVarUInt32:
+        repeat
+          pi^ := FromVarUInt32Big(PByte(chunk));
+          inc(pi);
+          dec(n);
+        until (n = 0) or
+              (chunk >= chunkend);
+      wkSorted:
+        begin
+          diff := CleverReadInteger(pointer(chunk), pointer(chunkend), pi);
+          dec(n, diff);
+          inc(pi, diff);
+        end;
+      wkOffsetU:
+        repeat
+          PIntegerArray(pi)[1] := pi^ + integer(FromVarUInt32(PByte(chunk)));
+          inc(pi);
+          dec(n);
+        until (n = 0) or
+              (chunk >= chunkend);
+      wkOffsetI:
+        repeat
+          PIntegerArray(pi)[1] := pi^ + FromVarInt32(PByte(chunk));
+          inc(pi);
+          dec(n);
+        until (n = 0) or
+              (chunk >= chunkend);
+    else
+      ErrorData('ReadVarUInt32Array got kind=%', [ord(k)]);
+    end;
+  until n = 0;
+end;
+
+type
+  TBufferWriterKind64 = (
+    wkVarUInt64, wkOffset64);
+
+function TFastReader.ReadVarUInt64Array(var Values: TInt64DynArray): PtrInt;
+var
+  i, n: PtrInt;
+  k: TBufferWriterKind64;
+  pi: PQWord;
+  diff: QWord;
+  chunk, chunkend: PtrUInt;
+begin
+  result := VarUInt32;
+  if result = 0 then
+    exit;
+  if result > length(Values) then // only set length is not big enough
+    SetLength(Values, result);
+  k := TBufferWriterKind64(NextByte);
+  pi := pointer(Values);
+  n := result;
+  if k = wkOffset64 then
+  begin
+    pi^ := VarUInt64;
+    dec(n);
+    diff := VarUInt32;
+    if diff <> 0 then
+    begin
+      // all items have a fixed offset
+      for i := 0 to n - 1 do
+        PQwordArray(pi)[i + 1] := PQwordArray(pi)[i] + diff;
+      exit;
+    end
+  end;
+  repeat
+    // chunked format: Isize+values
+    chunkend := Next4;
+    chunk := PtrUInt(Next(chunkend));
+    inc(chunkend, chunk);
+    case k of
+      wkVarUInt64:
+        repeat
+          pi^ := FromVarUInt64(PByte(chunk));
+          inc(pi);
+          dec(n);
+        until (n = 0) or
+              (chunk >= chunkend);
+      wkOffset64:
+        repeat
+          PQwordArray(pi)[1] := pi^ + FromVarUInt64(PByte(chunk));
+          inc(pi);
+          dec(n);
+        until (n = 0) or
+              (chunk >= chunkend);
+      else
+        ErrorData('ReadVarUInt64Array got kind=%', [ord(k)]);
+    end;
+  until n = 0;
+end;
+
+function TFastReader.ReadVarRawUtf8DynArray(var Values: TRawUtf8DynArray): PtrInt;
+var
+  count, len: integer;
+  fixedsize, chunk, chunkend: PtrUInt;
+  PI: PRawUtf8;
+begin
+  result := VarUInt32;
+  if result = 0 then
+    exit;
+  count := result;
+  if count > length(Values) then // change Values[] length only if not big enough
+    SetLength(Values, count);
+  PI := pointer(Values);
+  fixedsize := VarUInt32;
+  repeat
+    // chunked format: Isize+values
+    chunkend := Next4;
+    chunk := PtrUInt(Next(chunkend));
+    inc(chunkend, chunk);
+    if fixedsize = 0 then
+      // variable size strings
+      while (count > 0) and
+            (chunk < chunkend) do
+      begin
+        len := FromVarUInt32(PByte(chunk));
+        if len > 0 then
+        begin
+          FastSetString(PI^, pointer(chunk), len);
+          inc(chunk, len);
+        end
+        else if PI^<>'' then
+          PI^ := '';
+        dec(count);
+        inc(PI);
+      end
+    else
+      // fixed size strings
+      while (count > 0) and
+            (chunk < chunkend) do
+      begin
+        FastSetString(PI^, pointer(chunk), fixedsize);
+        inc(chunk, fixedsize);
+        dec(count);
+        inc(PI);
+      end;
+  until count <= 0;
+  if PI <> @Values[result] then
+    ErrorOverflow; // paranoid check
+end;
+
+function TFastReader.ReadCompressed(Load: TAlgoCompressLoad;
+  BufferOffset: integer): RawByteString;
+var
+  comp: PAnsiChar;
+  complen: PtrUInt;
+begin
+  complen := VarUInt32;
+  comp := Next(complen);
+  TAlgoCompress.Algo(comp, complen).Decompress(
+    comp, complen, result, Load, BufferOffset);
+end;
+
+
+{ TBufferWriter }
+
+constructor TBufferWriter.Create(aFile: THandle; BufLen: integer);
+begin
+  Create(THandleStream.Create(aFile), BufLen);
+  fInternalStream := true;
+end;
+
+constructor TBufferWriter.Create(const aFileName: TFileName;
+  BufLen: integer; Append: boolean);
+var
+  s: TStream;
+begin
+  if Append and
+     FileExists(aFileName) then
+  begin
+    s := TFileStreamEx.Create(aFileName, fmOpenWrite);
+    s.Seek(0, soEnd);
+  end
+  else
+    s := TFileStreamEx.Create(aFileName, fmCreate);
+  Create(s, BufLen);
+  fInternalStream := true;
+end;
+
+procedure TBufferWriter.Setup(aStream: TStream; aBuf: pointer; aLen: integer);
+begin
+  fBufLen := aLen;
+  fBufLen16 := aLen - 16;
+  fBuffer := aBuf;
+  fStream := aStream;
+end;
+
+constructor TBufferWriter.Create(aStream: TStream; BufLen: integer);
+begin
+  if BufLen > 1 shl 22 then
+    BufLen := 1 shl 22 // 4 MB sounds right enough
+  else if BufLen < 128 then
+    raise EBufferException.CreateUtf8('%.Create(BufLen=%)', [self, BufLen]);
+  GetMem(fBufferInternal, BufLen);
+  Setup(aStream, fBufferInternal, BufLen);
+end;
+
+constructor TBufferWriter.Create(aStream: TStream;
+  aTempBuf: pointer; aTempLen: integer);
+begin
+  Setup(aStream, aTempBuf, aTempLen);
+end;
+
+constructor TBufferWriter.Create(aClass: TStreamClass; BufLen: integer);
+begin
+  Create(aClass.Create, BufLen);
+  fInternalStream := true;
+end;
+
+constructor TBufferWriter.Create(aClass: TStreamClass;
+  aTempBuf: pointer; aTempLen: integer);
+begin
+  Setup(aClass.Create, aTempBuf, aTempLen);
+  fInternalStream := true;
+end;
+
+constructor TBufferWriter.Create(const aStackBuffer: TTextWriterStackBuffer);
+begin
+  Setup(TRawByteStringStream.Create, @aStackBuffer, SizeOf(aStackBuffer));
+  fInternalStream := true;
+end;
+
+destructor TBufferWriter.Destroy;
+begin
+  if fInternalStream then
+    fStream.Free;
+  if fBufferInternal <> nil then
+    FreeMem(fBufferInternal);
+  inherited;
+end;
+
+procedure TBufferWriter.InternalFlush;
+begin
+  if fPos > 0 then
+  begin
+    InternalWrite(fBuffer, fPos);
+    fPos := 0;
+  end;
+end;
+
+procedure TBufferWriter.InternalWrite(Data: pointer; DataLen: PtrInt);
+begin
+  inc(fTotalFlushed, DataLen);
+  if fStream.InheritsFrom(TRawByteStringStream) and
+     (fTotalFlushed > _STRMAXSIZE) then
+    // Delphi strings have a 32-bit length so you should change your algorithm
+    raise EBufferException.CreateUtf8('%.Write: % overflow (%)',
+      [self, fStream, KBNoSpace(fTotalFlushed)]);
+  fStream.WriteBuffer(Data^, DataLen);
+end;
+
+function TBufferWriter.GetTotalWritten: Int64;
+begin
+  result := fTotalFlushed + fPos;
+end;
+
+function TBufferWriter.Flush: Int64;
+begin
+  if fPos > 0 then
+    InternalFlush;
+  result := GetTotalWritten;
+  fTotalFlushed := 0;
+end;
+
+procedure TBufferWriter.CancelAll;
+begin
+  fTotalFlushed := 0;
+  fPos := 0;
+  if fStream.ClassType = TRawByteStringStream then
+    TRawByteStringStream(fStream).Size := 0
+  else
+    fStream.Seek(0, soBeginning);
+end;
+
+procedure TBufferWriter.FlushAndWrite(Data: pointer; DataLen: PtrInt);
+begin
+  if DataLen < 0 then
+    exit;
+  if fPos > 0 then
+    InternalFlush;
+  if DataLen > fBufLen then
+    InternalWrite(Data, DataLen)
+  else
+  begin
+    MoveFast(Data^, fBuffer^[fPos], DataLen);
+    inc(fPos, DataLen);
+  end;
+end;
+
+procedure TBufferWriter.Write(Data: pointer; DataLen: PtrInt);
+var
+  p: PtrUInt;
+begin
+  p := fPos;
+  if p + PtrUInt(DataLen) <= PtrUInt(fBufLen) then
+  begin
+    MoveFast(Data^, fBuffer^[p], DataLen);
+    inc(fPos, DataLen);
+  end
+  else
+    FlushAndWrite(Data, DataLen); // will also handle DataLen<0
+end;
+
+procedure TBufferWriter.WriteN(Data: byte; Count: integer);
+var
+  len: integer;
+begin
+  while Count > 0 do
+  begin
+    if Count > fBufLen then
+      len := fBufLen
+    else
+      len := Count;
+    if fPos + len > fBufLen then
+      InternalFlush;
+    FillCharFast(fBuffer^[fPos], len, Data);
+    inc(fPos, len);
+    dec(Count, len);
+  end;
+end;
+
+procedure TBufferWriter.Write1(Data: byte);
+begin
+  if fPos > fBufLen16 then
+    InternalFlush;
+  fBuffer^[fPos] := Data;
+  inc(fPos);
+end;
+
+procedure TBufferWriter.Write2(Data: cardinal);
+begin
+  if fPos > fBufLen16 then
+    InternalFlush;
+  PWord(@fBuffer^[fPos])^ := Data;
+  inc(fPos, SizeOf(Word));
+end;
+
+procedure TBufferWriter.Write2BigEndian(Data: cardinal);
+begin
+  Write2(swap(word(Data)));
+end;
+
+procedure TBufferWriter.Write4(Data: integer);
+begin
+  if fPos > fBufLen16 then
+    InternalFlush;
+  PInteger(@fBuffer^[fPos])^ := Data;
+  inc(fPos, SizeOf(integer));
+end;
+
+procedure TBufferWriter.Write4BigEndian(Data: integer);
+begin
+  Write4(bswap32(Data));
+end;
+
+procedure TBufferWriter.Write8(Data8Bytes: pointer);
+begin
+  if fPos > fBufLen16 then
+    InternalFlush;
+  PInt64(@fBuffer^[fPos])^ := PInt64(Data8Bytes)^;
+  inc(fPos, SizeOf(Int64));
+end;
+
+procedure TBufferWriter.WriteI64(Data: Int64);
+begin
+  if fPos > fBufLen16 then
+    InternalFlush;
+  PInt64(@fBuffer^[fPos])^ := Data;
+  inc(fPos, SizeOf(Data));
+end;
+
+procedure TBufferWriter.WriteVar(Data: pointer; DataLen: PtrInt);
+label
+  wr;
+begin
+  if fPos + DataLen <= fBufLen16 then // could fit in buffer (most common case)
+  begin
+    if DataLen < $80 then // e.g. small strings
+    begin
+      fBuffer^[fPos] := DataLen;
+      inc(fPos);
+      if DataLen = 0 then
+        exit;
+wr:   MoveFast(Data^, fBuffer^[fPos], DataLen);
+      inc(fPos, DataLen);
+      exit;
+    end;
+    fPos := PtrUInt(ToVarUInt32(DataLen, @fBuffer^[fPos])) - PtrUInt(fBuffer);
+    goto wr;
+  end;
+  // Data wouldn't fit in memory buffer -> write as two explicit calls
+  WriteVarUInt32(DataLen);
+  Write(Data, DataLen);
+end;
+
+procedure TBufferWriter.WriteVar(var Item: TTempUtf8);
+begin
+  WriteVar(Item.Text, Item.Len);
+  if Item.TempRawUtf8 <> nil then
+    {$ifdef FPC}
+    FastAssignNew(Item.TempRawUtf8);
+    {$else}
+    RawUtf8(Item.TempRawUtf8) := '';
+    {$endif FPC}
+end;
+
+procedure TBufferWriter.Write(const Text: RawByteString);
+begin
+  WriteVar(pointer(Text), length(Text));
+end;
+
+procedure TBufferWriter.WriteShort(const Text: ShortString);
+begin
+  WriteVar(@Text[1], ord(Text[0]));
+end;
+
+procedure TBufferWriter.WriteBinary(const Data: RawByteString);
+begin
+  Write(pointer(Data), Length(Data));
+end;
+
+function TBufferWriter.DirectWritePrepare(maxlen: PtrInt;
+  var tmp: RawByteString): PAnsiChar;
+begin
+  if (maxlen <= fBufLen) and
+     (fPos + maxlen > fBufLen) then
+    InternalFlush;
+  if fPos + maxlen > fBufLen then
+  begin
+    if maxlen > length(tmp) then
+      FastNewRawByteString(tmp, maxlen); // don't reallocate buffer (reuse)
+    result := pointer(tmp);
+  end
+  else
+    result := @fBuffer^[fPos]; // write directly into the buffer
+end;
+
+procedure TBufferWriter.DirectWriteFlush(len: PtrInt; const tmp: RawByteString);
+begin
+  if tmp = '' then
+    inc(fPos, len)
+  else
+    Write(pointer(tmp), len);
+end;
+
+function TBufferWriter.DirectWriteReserve(maxlen: PtrInt): PByte;
+begin
+  if fPos + maxlen > fBufLen then
+    InternalFlush;
+  result := @fBuffer^[fPos]; // write directly into the buffer
+end;
+
+procedure TBufferWriter.DirectWriteReserved(pos: PByte);
+begin
+  fPos := PAnsiChar(pos) - pointer(fBuffer);
+end;
+
+procedure TBufferWriter.WriteXor(New, Old: PAnsiChar; Len: PtrInt;
+  crc: PCardinal);
+var
+  L: integer;
+  Dest: PAnsiChar;
+begin
+  if (New = nil) or
+     (Old = nil) then
+    exit;
+  while Len > 0 do
+  begin
+    Dest := pointer(fBuffer);
+    if fPos + Len > fBufLen then
+      InternalFlush
+    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 TBufferWriter.WriteRawUtf8DynArray(const Values: TRawUtf8DynArray;
+  ValuesCount: integer);
+begin
+  WriteRawUtf8Array(pointer(Values), ValuesCount);
+end;
+
+procedure TBufferWriter.WriteRawUtf8Array(Values: PPtrUIntArray;
+  ValuesCount: integer);
+var
+  n: integer;
+  i: PtrInt;
+  fixedsize, len: PtrUInt;
+  P, PEnd: PByte;
+  PBeg: PAnsiChar;
+begin
+  WriteVarUInt32(ValuesCount);
+  if ValuesCount = 0 then
+    exit;
+  fixedsize := Values^[0];
+  if fixedsize <> 0 then
+  begin
+    fixedsize := {%H-}PStrLen(fixedsize - _STRLEN)^;
+    for i := 1 to ValuesCount - 1 do
+      if (Values^[i] = 0) or
+         ({%H-}PStrLen(Values^[i] - _STRLEN)^ <> TStrLen(fixedsize)) then
+      begin
+        fixedsize := 0;
+        break;
+      end;
+  end;
+  WriteVarUInt32(fixedsize);
+  repeat
+    P := @fBuffer^[fPos];
+    PEnd := @fBuffer^[fBufLen16];
+    if PtrUInt(P) < PtrUInt(PEnd) then
+    begin
+      n := ValuesCount;
+      PBeg := PAnsiChar(P); // leave space for chunk size
+      inc(P, 4);
+      if fixedsize = 0 then
+        for i := 0 to ValuesCount - 1 do
+          if Values^[i] = 0 then
+          begin
+            P^ := 0; // store length=0
+            inc(P);
+            if PtrUInt(P) >= PtrUInt(PEnd) then
+            begin
+              n := i + 1;
+              break; // avoid buffer overflow
+            end;
+          end
+          else
+          begin
+            len := {%H-}PStrLen(Values^[i] - _STRLEN)^;
+            if PtrUInt(PEnd) - PtrUInt(P) <= len then
+            begin
+              n := i;
+              break; // avoid buffer overflow
+            end;
+            P := ToVarUInt32(len, P);
+            MoveFast(pointer(Values^[i])^, P^, len); // here len>0
+            inc(P, len);
+          end
+      else // fixedsize<>0:
+        for i := 0 to ValuesCount - 1 do
+        begin
+          if PtrUInt(PEnd) - PtrUInt(P) <= fixedsize then
+          begin
+            n := i;
+            break; // avoid buffer overflow
+          end;
+          MoveFast(pointer(Values^[i])^, P^, fixedsize);
+          inc(P, fixedsize);
+        end;
+      len := PAnsiChar(P) - PBeg; // format: Isize+varUInt32s*strings
+      PInteger(PBeg)^ := len - 4;
+      inc(fPos, len);
+      inc(PByte(Values), n * SizeOf(PtrInt));
+      dec(ValuesCount, n);
+      if ValuesCount = 0 then
+        break;
+    end;
+    InternalFlush;
+  until false;
+end;
+
+procedure TBufferWriter.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 TBufferWriter.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 TBufferWriter.WriteVarUInt32(Value: PtrUInt);
+begin
+  if fPos > fBufLen16 then
+    InternalFlush;
+  fPos := PtrUInt(ToVarUInt32(Value, @fBuffer^[fPos])) - PtrUInt(fBuffer);
+end;
+
+procedure TBufferWriter.WriteVarInt64(Value: Int64);
+begin
+  if fPos > fBufLen16 then
+    InternalFlush;
+  fPos := PtrUInt(ToVarInt64(Value, @fBuffer^[fPos])) - PtrUInt(fBuffer);
+end;
+
+procedure TBufferWriter.WriteVarUInt64(Value: QWord);
+begin
+  if fPos > fBufLen16 then
+    InternalFlush;
+  fPos := PtrUInt(ToVarUInt64(Value, @fBuffer^[fPos])) - PtrUInt(fBuffer);
+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 (V < VEnd) and
+           (pCount > 0) then
+          continue
+        else
+          break;
+      end
+      else
+      begin
+        dec(pCount);
+        V^ := AnsiChar(d);
+        inc(V); // B:1..253 = difference with previous
+        if (V < VEnd) and
+           (pCount > 0) then
+          continue
+        else
+          break;
+      end;
+      if V >= VEnd then
+        break; // avoid GPF
+    until false;
+  dec(StoredCount, pCount);
+  result := V;
+end;
+
+procedure TBufferWriter.WriteVarUInt32Array(const Values: TIntegerDynArray;
+  ValuesCount: integer; DataLayout: TBufferWriterKind);
+begin
+  WriteVarUInt32Values(pointer(Values), ValuesCount, DataLayout);
+end;
+
+procedure TBufferWriter.WriteVarUInt32Values(Values: PIntegerArray;
+  ValuesCount: integer; DataLayout: TBufferWriterKind);
+var
+  diff, v, vp, n: integer;
+  i: PtrInt;
+  P: PByte;
+  PBeg, PEnd: PAnsiChar;
+begin
+  WriteVarUInt32(ValuesCount);
+  if ValuesCount = 0 then
+    exit;
+  fBuffer^[fPos] := ord(DataLayout);
+  inc(fPos);
+  vp := Values^[0];
+  if DataLayout in [wkOffsetU, wkOffsetI] then
+  begin
+    fPos := PtrUInt(ToVarUInt32(vp, @fBuffer^[fPos])) - PtrUInt(fBuffer);
+    diff := Values^[1] - vp;
+    inc(PInteger(Values));
+    dec(ValuesCount);
+    if ValuesCount = 0 then
+      exit;
+    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);
+    if diff <> 0 then
+      exit; // same offset for all items (fixed sized records) -> quit now
+  end;
+  repeat
+    P := @fBuffer^[fPos];
+    PEnd := @fBuffer^[fBufLen16];
+    if PtrUInt(P) < PtrUInt(PEnd) then
+    begin
+      case DataLayout of
+        wkUInt32:
+          // format: uncompressed array of cardinals
+          begin
+            n := (fBufLen - fPos) shr 2;
+            if ValuesCount < n then
+              n := ValuesCount;
+            MoveFast(Values^, P^, n * 4);
+            inc(P, n * 4);
+          end;
+        wkVarInt32,
+        wkVarUInt32,
+        wkOffsetU,
+        wkOffsetI:
+          begin
+            // format: Isize + varUInt32s
+            PBeg := PAnsiChar(P); // leave space for chunk size
+            inc(P, 4);
+            n := ValuesCount;
+            for i := 0 to ValuesCount - 1 do
+            begin
+              v := Values^[i];
+              case DataLayout of
+                wkVarInt32:
+                  P := ToVarInt32(v, P);
+                wkVarUInt32:
+                  P := ToVarUInt32(v, P);
+                wkOffsetU:
+                  P := ToVarUInt32(v - vp, P);
+                wkOffsetI:
+                  P := ToVarInt32(v - vp, P);
+              end;
+              vp := v;
+              if PtrUInt(P) >= PtrUInt(PEnd) then
+              begin
+                n := i + 1;
+                break; // avoid buffer overflow
+              end;
+            end;
+            PInteger(PBeg)^ := PAnsiChar(P) - PBeg - 4;
+          end;
+        wkSorted:
+          begin
+            // format: Isize + cleverStorage
+            PBeg := PAnsiChar(P) + 4; // leave space for chunk size
+            P := PByte(CleverStoreInteger(pointer(Values), PBeg, PEnd, ValuesCount, n));
+            if P = nil then
+              raise EBufferException.CreateUtf8(
+                '%.WriteVarUInt32Array: data not sorted', [self]);
+            PInteger(PBeg - 4)^ := PAnsiChar(P) - PBeg;
+          end;
+      end;
+      inc(PByte(Values), n * 4);
+      fPos := PtrUInt(P) - PtrUInt(fBuffer);
+      dec(ValuesCount, n);
+      if ValuesCount = 0 then
+        break;
+    end;
+    InternalFlush;
+  until false;
+end;
+
+procedure TBufferWriter.WriteVarUInt64DynArray(const Values: TInt64DynArray;
+  ValuesCount: integer; Offset: boolean);
+var
+  n: integer;
+  i: PtrInt;
+  diff: Int64;
+  P, PEnd: PByte;
+  PI: PInt64Array;
+  PBeg: PAnsiChar;
+begin
+  WriteVarUInt32(ValuesCount);
+  if ValuesCount = 0 then
+    exit;
+  PI := pointer(Values);
+  if Offset then
+  begin
+    fBuffer^[fPos] := ord(wkOffset64);
+    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
+      exit;
+    if (diff > 0) and
+       (diff < MaxInt) then
+    begin
+      for i := 1 to ValuesCount - 1 do
+        if PI^[i] - PI^[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);
+    if diff <> 0 then
+      exit; // same offset for all items (fixed sized records) -> quit now
+  end
+  else
+  begin
+    fBuffer^[fPos] := ord(wkVarUInt64);
+    inc(fPos);
+  end;
+  repeat
+    P := @fBuffer^[fPos];
+    PEnd := @fBuffer^[fBufLen16];
+    if PtrUInt(P) < PtrUInt(PEnd) then
+    begin
+      PBeg := PAnsiChar(P); // leave space for chunk size
+      inc(P, 4);
+      n := ValuesCount;
+      for i := 0 to ValuesCount - 1 do
+      begin
+        if Offset then
+          P := ToVarUInt64(PI^[i] - PI^[i - 1], P) // store diffs
+        else
+          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);
+      dec(ValuesCount, n);
+      if ValuesCount = 0 then
+        break;
+    end;
+    InternalFlush;
+  until false;
+end;
+
+function TBufferWriter.FlushTo: RawByteString;
+begin
+  InternalFlush;
+  result := (fStream as TRawByteStringStream).DataString;
+end;
+
+function TBufferWriter.FlushToBytes: TBytes;
+var
+  siz: Int64;
+begin
+  result := nil;
+  siz := GetTotalWritten;
+  if siz > _DAMAXSIZE then
+    raise EBufferException.CreateUtf8('%.FlushToBytes: overflow (%)', [KB(siz)]);
+  SetLength(result, siz);
+  if fStream.Position = 0 then
+    // direct assignment from internal buffer
+    MoveFast(fBuffer[0], pointer(result)^, fPos)
+  else
+  begin
+    // from temporary allocation in TRawByteStringStream.DataString
+    Flush;
+    MoveFast(pointer((fStream as TRawByteStringStream).DataString)^,
+      pointer(result)^, TotalWritten);
+  end;
+end;
+
+function TBufferWriter.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
+    // from temporary allocation in TRawByteStringStream.DataString
+    result := algo.Compress(FlushTo, trig, false, BufferOffset);
+end;
+
+
+
+{ ************ TAlgoCompress Compression/Decompression Classes }
+
+{ TAlgoCompress }
+
+var
+  // don't use TObjectList before mormot.core.json registered TRttiJson
+  SynCompressAlgos: array of TAlgoCompress;
+
+constructor TAlgoCompress.Create;
+var
+  existing: TAlgoCompress;
+begin
+  existing := Algo(fAlgoID);
+  if existing <> nil then
+    raise EAlgoCompress.CreateUtf8('%.Create: AlgoID=% already registered by %',
+      [self, fAlgoID, existing]);
+  ObjArrayAdd(SynCompressAlgos, self);
+  RegisterGlobalShutdownRelease(self);
+end;
+
+destructor TAlgoCompress.Destroy;
+begin
+  if LogCompressAlgo = self then
+    LogCompressAlgo := nil; // avoid GPF at shutdown
+  inherited Destroy;
+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(aAlgoID: byte): TAlgoCompress;
+var
+  n: integer;
+  ptr: ^TAlgoCompress;
+begin
+  if aAlgoID <= COMPRESS_SYNLZ then // COMPRESS_STORED is handled as SynLZ
+    result := AlgoSynLZ
+  else
+  begin
+    ptr := pointer(SynCompressAlgos);
+    if ptr <> nil then
+    begin
+      n := PDALen(PAnsiChar(ptr) - _DALEN)^ + ( _DAOFF - 1 ); // - 1 for List[0]
+      if n > 0 then
+        repeat
+          inc(ptr); // ignore List[0] = AlgoSynLZ
+          result := ptr^;
+          if result.fAlgoID = aAlgoID then
+            exit;
+          dec(n);
+        until n = 0;
+    end;
+    result := nil;
+  end;
+end;
+
+class function TAlgoCompress.UncompressedSize(const Comp: RawByteString): integer;
+begin
+  result := Algo(Comp).DecompressHeader(pointer(Comp), length(Comp));
+end;
+
+function TAlgoCompress.AlgoName: TShort16;
+var
+  s: PShortString;
+  i: integer;
+begin
+  if self = nil then
+    result := 'none'
+  else
+  begin
+    s := ClassNameShort(self);
+    if IdemPChar(@s^[1], 'TALGO') then
+    begin
+      result[0] := AnsiChar(ord(s^[0]) - 5);
+      inc(PByte(s), 5);
+    end
+    else
+      result[0] := s^[0];
+    if result[0] > #16 then
+      result[0] := #16;
+    for i := 1 to ord(result[0]) do
+      result[i] := NormToLower[s^[i]];
+  end;
+end;
+
+procedure TAlgoCompress.EnsureAlgoHasNoForcedFormat(const caller: shortstring);
+begin
+  if fAlgoHasForcedFormat then
+    raise EAlgoCompress.CreateUtf8('%.% is unsupported', [self, caller]);
+end;
+
+function TAlgoCompress.AlgoHash(Previous: cardinal;
+  Data: pointer; DataLen: integer): cardinal;
+begin
+  result := crc32c(Previous, Data, DataLen);
+end;
+
+function TAlgoCompress.AlgoHash(ForceHash32: boolean;
+  Data: pointer; DataLen: integer): cardinal;
+begin
+  if ForceHash32 then
+    result := Hash32(Data, DataLen)
+  else
+    result := AlgoHash(0, 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 (PlainLen = 0) or
+     (Plain = nil) then
+  begin
+    result := '';
+    exit;
+  end;
+  EnsureAlgoHasNoForcedFormat('Compress');
+  crc := AlgoHash(0, Plain, PlainLen);
+  if (PlainLen < CompressionSizeTrigger) or
+     (CheckMagicForCompressed and
+      IsContentCompressed(Plain, PlainLen)) then
+  begin
+    FastNewRawByteString(result, PlainLen + BufferOffset + 9);
+    R := pointer(result);
+    inc(R, BufferOffset);
+    PCardinal(R)^ := crc;
+    R[4] := COMPRESS_STORED;
+    PCardinal(R + 5)^ := crc;
+    MoveFast(Plain^, R[9], PlainLen);
+  end
+  else
+  begin
+    len := CompressDestLen(PlainLen) + BufferOffset;
+    if len > SizeOf(tmp) then
+    begin
+      FastNewRawByteString(result, len);
+      R := pointer(result);
+    end
+    else
+      R := @tmp;
+    inc(R, BufferOffset);
+    PCardinal(R)^ := crc;
+    len := AlgoCompress(Plain, PlainLen, R + 9);
+    if len >= PlainLen then
+    begin
+      // store if compression was not worth it
+      R[4] := COMPRESS_STORED;
+      PCardinal(R + 5)^ := crc;
+      MoveFast(Plain^, R[9], PlainLen);
+      len := PlainLen;
+    end
+    else
+    begin
+      R[4] := AnsiChar(AlgoID);
+      PCardinal(R + 5)^ := AlgoHash(0, R + 9, len);
+    end;
+    inc(len, BufferOffset + 9);
+    if R = @tmp[BufferOffset] then
+      FastSetRawByteString(result, @tmp, len)
+    else
+      FakeLength(result, len);
+  end;
+end;
+
+function TAlgoCompress.Compress(Plain, Comp: PAnsiChar; PlainLen, CompLen: integer;
+  CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): integer;
+var
+  len: integer;
+begin
+  result := 0;
+  if (PlainLen = 0) or
+     (CompLen < PlainLen + 9) then
+    exit;
+  EnsureAlgoHasNoForcedFormat('Compress');
+  PCardinal(Comp)^ := AlgoHash(0, Plain, PlainLen);
+  if (PlainLen >= CompressionSizeTrigger) and
+     not (CheckMagicForCompressed and
+          IsContentCompressed(Plain, PlainLen)) then
+  begin
+    len := CompressDestLen(PlainLen);
+    if CompLen < len then
+      exit;
+    len := AlgoCompress(Plain, PlainLen, Comp + 9);
+    if len < PlainLen then
+    begin
+      Comp[4] := AnsiChar(AlgoID);
+      PCardinal(Comp + 5)^ := AlgoHash(0, Comp + 9, len);
+      result := len + 9;
+      exit;
+    end;
+  end;
+  Comp[4] := COMPRESS_STORED;
+  PCardinal(Comp + 5)^ := PCardinal(Comp)^;
+  MoveFast(Plain^, Comp[9], PlainLen);
+  result := PlainLen + 9;
+end;
+
+function TAlgoCompress.CompressDestLen(PlainLen: integer): integer;
+begin
+  if self = nil then
+    result := 0
+  else
+    result := AlgoCompressDestLen(PlainLen) + 9;
+end;
+
+function TAlgoCompress.CompressToBytes(Plain: PAnsiChar; PlainLen: integer;
+  CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): TByteDynArray;
+var
+  len: integer;
+  R: PAnsiChar;
+  crc: cardinal;
+begin
+  Finalize(result);
+  if (self = nil) or
+     (PlainLen = 0) then
+    exit;
+  EnsureAlgoHasNoForcedFormat('CompressToBytes');
+  crc := AlgoHash(0, Plain, PlainLen);
+  if PlainLen < CompressionSizeTrigger then
+  begin
+    SetLength(result, PlainLen + 9);
+    R := pointer(result);
+    PCardinal(R)^ := crc;
+    R[4] := COMPRESS_STORED;
+    PCardinal(R + 5)^ := crc;
+    MoveFast(Plain^, R[9], PlainLen);
+  end
+  else
+  begin
+    SetLength(result, CompressDestLen(PlainLen));
+    R := pointer(result);
+    PCardinal(R)^ := crc;
+    len := AlgoCompress(Plain, PlainLen, R + 9);
+    if len >= PlainLen then
+    begin
+      // store if compression not worth it
+      R[4] := COMPRESS_STORED;
+      PCardinal(R + 5)^ := crc;
+      MoveFast(Plain^, R[9], PlainLen);
+      len := PlainLen;
+    end
+    else
+    begin
+      R[4] := AnsiChar(AlgoID);
+      PCardinal(R + 5)^ := AlgoHash(0, R + 9, len);
+    end;
+    SetLength(result, len + 9);
+  end;
+end;
+
+function TAlgoCompress.CompressToBytes(const Plain: RawByteString;
+  CompressionSizeTrigger: integer; CheckMagicForCompressed: boolean): TByteDynArray;
+begin
+  result := CompressToBytes(pointer(Plain), Length(Plain),
+    CompressionSizeTrigger, CheckMagicForCompressed);
+end;
+
+function TAlgoCompress.Decompress(const Comp: TByteDynArray): RawByteString;
+begin
+  Decompress(pointer(Comp), length(Comp), result);
+end;
+
+procedure TAlgoCompress.Decompress(Comp: PAnsiChar; CompLen: integer;
+  out result: RawByteString; Load: TAlgoCompressLoad; BufferOffset: integer);
+var
+  len: integer;
+  dec: PAnsiChar;
+begin
+  len := DecompressHeader(Comp, CompLen, Load);
+  if len = 0 then
+    exit;
+  FastSetString(RawUtf8(result), len + BufferOffset); // CP_UTF8 for FPC RTL bug
+  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
+  FastSetString(RawUtf8(Dest), len); // assume CP_UTF8 for FPC RTL bug
+  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;
+  if self = nil then
+    exit;
+  EnsureAlgoHasNoForcedFormat('Decompress');
+  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
+      FastSetString(RawUtf8(tmp), PlainLen); // assume CP_UTF8 for FPC RTL bug
+    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
+     (PartialLenMax < PartialLen) then
+    exit;
+  EnsureAlgoHasNoForcedFormat('DecompressPartial');
+  if Comp[4] = COMPRESS_STORED then
+    if PCardinal(Comp)^ = PCardinal(Comp + 5)^ then
+      BodyLen := CompLen - 9
+    else
+      exit
+  else if Comp[4] = AnsiChar(AlgoID) then
+    BodyLen := AlgoDecompressDestLen(Comp + 9)
+  else
+    exit;
+  if PartialLen > BodyLen then
+    PartialLen := BodyLen;
+  if Comp[4] = COMPRESS_STORED then
+    MoveFast(Comp[9], Partial[0], PartialLen)
+  else if AlgoDecompressPartial(Comp + 9, CompLen - 9,
+           Partial, PartialLen, PartialLenMax) < PartialLen then
+    exit;
+  result := PartialLen;
+end;
+
+type
+  // disk header of TAlgoCompress chunk
+  TAlgoCompressHead = packed record
+    Magic: cardinal;
+    CompressedSize: integer;
+    CompressedHash: cardinal;
+    UnCompressedSize: integer;
+    UncompressedHash: cardinal;
+  end;
+  PAlgoCompressHead = ^TAlgoCompressHead;
+
+  TAlgoCompressTrailer = packed record
+    HeaderRelativeOffset: cardinal;
+    Magic: cardinal;
+  end;
+  PAlgoCompressTrailer = ^TAlgoCompressTrailer;
+
+function TAlgoCompress.StreamCompress(Source, Dest: TStream; Magic: cardinal;
+  ForceHash32, WithTrailer: boolean; ChunkBytes: PtrInt): Int64;
+var
+  count: Int64;
+  S, D: pointer;
+  head: TAlgoCompressHead;
+  trail: TAlgoCompressTrailer;
+  tmps, tmpd: RawByteString;
+begin
+  result := 0;
+  if (self = nil) or
+     (Dest = nil) or
+     (Source = nil) then
+    exit;
+  EnsureAlgoHasNoForcedFormat('StreamCompress');
+  count := Source.Size;
+  if count = 0 then
+    exit;
+  S := GetStreamBuffer(Source);
+  head.Magic := Magic;
+  repeat
+    // compress Source into Dest with proper chunking
+    if count > ChunkBytes then
+      head.UnCompressedSize := ChunkBytes
+    else
+      head.UnCompressedSize := count;
+    if S = nil then
+    begin
+      FastNewRawByteString(tmps, head.UnCompressedSize);
+      S := pointer(tmps); // here S is a temporary buffer
+    end;
+    if {%H-}tmpd = '' then
+      FastNewRawByteString(tmpd, AlgoCompressDestLen(head.UnCompressedSize));
+    dec(count, head.UnCompressedSize); // supports premature end of input
+    if S = pointer(tmps) then
+      head.UnCompressedSize := Source.Read(S^, head.UnCompressedSize);
+    if head.UnCompressedSize <= 0 then
+      exit; // read error
+    head.UncompressedHash := AlgoHash(ForceHash32, S, head.UnCompressedSize);
+    D := pointer(tmpd);
+    head.CompressedSize := AlgoCompress(S, head.UnCompressedSize, D);
+    if head.CompressedSize >= head.UnCompressedSize then
+    begin
+      D := S; // compression is not worth it -> store
+      head.CompressedSize := head.UnCompressedSize;
+      head.CompressedHash := head.UncompressedHash;
+    end
+    else
+      head.CompressedHash := AlgoHash(ForceHash32, D, head.CompressedSize);
+    Dest.WriteBuffer(head, SizeOf(head));
+    Dest.WriteBuffer(D^, head.CompressedSize);
+    if S <> pointer(tmps) then
+      inc(PByte(S), head.UnCompressedSize); // move ahead to next chunk
+    inc(result, SizeOf(head) + head.CompressedSize);
+  until count = 0;
+  if not WithTrailer then
+    exit;
+  inc(result, SizeOf(trail));
+  trail.Magic := Magic;
+  trail.HeaderRelativeOffset := result;        // Int64 into cardinal
+  if trail.HeaderRelativeOffset <> result then // max 4GB compressed size
+    RaiseStreamError(self, 'StreamCompress trail overflow');
+  Dest.WriteBuffer(trail, SizeOf(trail));
+end;
+
+function TAlgoCompress.StreamCompress(Source: TStream;
+  const DestFile: TFileName; Magic: cardinal; ForceHash32, WithTrailer: boolean;
+  ChunkBytes: PtrInt): Int64;
+var
+  F: TStream;
+begin
+  F := TFileStreamEx.Create(DestFile, fmCreate);
+  try
+    result := StreamCompress(Source, F, Magic, ForceHash32, WithTrailer, ChunkBytes);
+  finally
+    F.Free;
+  end;
+end;
+
+function TAlgoCompress.StreamUnCompress(Source: TStream; Magic: cardinal;
+  ForceHash32: boolean): TMemoryStream;
+begin
+  result := TMemoryStream.Create;
+  if not StreamUncompress(Source, result, Magic, ForceHash32) then
+    FreeAndNil(result);
+end;
+
+function TAlgoCompress.StreamUnCompress(Source, Dest: TStream; Magic: cardinal;
+  ForceHash32: boolean): boolean;
+var
+  S, D: PAnsiChar;
+  sourcePosition, resultSize, sourceSize: Int64;
+  Head: TAlgoCompressHead;
+  offs, rd: cardinal;
+  Trailer: TAlgoCompressTrailer absolute Head;
+  tmps, tmpd: RawByteString;
+  stored: boolean;
+
+  function MagicSeek: boolean;
+  // Source not positioned as expected -> try from the TAlgoCompressTrailer end
+  var
+    t: PAlgoCompressTrailer;
+    tmplen: PtrInt;
+    tmp: array[word] of byte;
+    Trailer: TAlgoCompressTrailer absolute tmp;
+  begin
+    result := false;
+    Source.Position := sourceSize - SizeOf(Trailer);
+    if (Source.Read(Trailer, SizeOf(Trailer)) <> SizeOf(Trailer)) or
+       (Trailer.Magic <> Magic) then
+    begin
+      // may have been appended before a digital signature -> try last 64KB
+      tmplen := SizeOf(tmp);
+      if sourcesize < tmplen then
+        tmplen := sourcesize;
+      Source.Position := sourceSize - tmplen;
+      if Source.Read(tmp, tmplen) <> tmplen then
+        exit;
+      dec(tmplen, SizeOf(TAlgoCompressTrailer));
+      t := @tmp[tmplen];
+      repeat
+        dec(PByte(t)); // search backward
+        if PtrUInt(t) < PtrUInt(@tmp) then
+          exit;
+      until t^.Magic = Magic;
+      dec(sourceSize, PtrUInt(@tmp[tmplen]) - PtrUInt(t));    // adjust
+      sourcePosition := sourceSize - t^.HeaderRelativeOffset; // found
+    end
+    else
+      sourcePosition := sourceSize - Trailer.HeaderRelativeOffset;
+    Source.Position := sourcePosition;
+    if (Source.Read(Head, SizeOf(Head)) <> SizeOf(Head)) or
+       (Head.Magic <> Magic) then
+      exit;
+    result := true;
+  end;
+
+begin
+  result := false;
+  if (self = nil) or
+     (Source = nil) then
+    exit;
+  EnsureAlgoHasNoForcedFormat('StreamUnCompress');
+  sourceSize := Source.Size;
+  sourcePosition := Source.Position;
+  if Source.Read(Head, SizeOf(Head)) <> SizeOf(Head) then
+    exit;
+  if (Head.Magic <> Magic) and
+     not MagicSeek then
+    exit;
+  offs := 0;
+  resultSize := 0;
+  repeat
+    // read next chunk from Source
+    inc(sourcePosition, SizeOf(Head));
+    S := GetStreamBuffer(Source);
+    if S <> nil then
+    begin
+      if sourcePosition + Head.CompressedSize > sourceSize then
+        break;
+      inc(S, sourcePosition);
+      Source.Seek(Head.CompressedSize, soCurrent);
+    end
+    else
+    begin
+      if Head.CompressedSize > length({%H-}tmps) then
+        FastNewRawByteString(tmps, Head.CompressedSize);
+      S := pointer(tmps);
+      if Source.Read(S^, Head.CompressedSize) <> Head.CompressedSize then
+        break;
+    end;
+    inc(sourcePosition, Head.CompressedSize);
+    // decompress chunk into Dest
+    stored := (Head.CompressedSize = Head.UnCompressedSize) and
+              (Head.CompressedHash = Head.UncompressedHash);
+    if not stored then
+      if AlgoDecompressDestLen(S) <> Head.UnCompressedSize then
+        break;
+    if AlgoHash(ForceHash32, S, Head.CompressedSize) <> Head.CompressedHash then
+      break;
+    if IsStreamBuffer(Dest) then
+    begin
+      Dest.Size := resultSize + Head.UnCompressedSize;    // resize output
+      D := PAnsiChar(GetStreamBuffer(Dest)) + resultSize; // in-place decompress
+      inc(resultSize, Head.UnCompressedSize);
+    end
+    else
+    begin
+      if Head.UnCompressedSize > length({%H-}tmpd) then
+        FastNewRawByteString(tmpd, Head.UnCompressedSize);
+      D := pointer(tmpd);
+    end;
+    if stored then
+      MoveFast(S^, D^, Head.CompressedSize)
+    else if (AlgoDecompress(S, Head.CompressedSize, D) <> Head.UnCompressedSize) or
+       (AlgoHash(ForceHash32, D, Head.UnCompressedSize) <> Head.UncompressedHash) then
+      break; // invalid decompression
+    if D = pointer({%H-}tmpd) then
+      Dest.WriteBuffer(D^, Head.UnCompressedSize);
+    result := true; // if we reached here, we uncompressed a block
+    // try if we have some other pending chunk(s)
+    if (sourceSize <> 0) and
+       (sourcePosition = sourceSize) then
+      break; // end of source with no trailer or next block
+    inc(offs, Head.CompressedSize + SizeOf(Head));
+    rd := Source.Read(Trailer, SizeOf(Trailer));
+    if rd <> SizeOf(Trailer) then
+    begin
+      if rd <> 0 then
+        Source.Position := sourcePosition; // rewind source
+      break; // valid uncompressed data with no more chunk
+    end;
+    if (Trailer.Magic = Magic) and
+       (Trailer.HeaderRelativeOffset = offs + SizeOf(Trailer)) then
+      break; // we reached the end trailer
+    if (Source.Read(PByteArray(@Head)[SizeOf(Trailer)],
+         SizeOf(Head) - SizeOf(Trailer)) <> SizeOf(Head) - SizeOf(Trailer)) or
+       (Head.Magic <> Magic) then
+    begin
+      Source.Position := sourcePosition; // rewind source
+      break; // valid uncompressed data with no more chunk
+    end;
+    result := false; // any decompression error on next chunk should be notified
+  until false;
+end;
+
+function TAlgoCompress.StreamUnCompress(const Source: TFileName;
+  Magic: cardinal; ForceHash32: boolean): TMemoryStream;
+var
+  S: TStream;
+begin
+  try
+    S := FileStreamSequentialRead(Source);
+    try
+      result := StreamUnCompress(S, Magic, ForceHash32);
+    finally
+      S.Free;
+    end;
+  except
+    on E: Exception do
+      result := nil;
+  end;
+end;
+
+function TAlgoCompress.StreamComputeLen(P: PAnsiChar; Len: PtrUInt;
+  Magic: cardinal): integer;
+var
+  trailer: PAlgoCompressTrailer;
+begin
+  if (P = nil) or
+     (Len <= SizeOf(TAlgoCompressTrailer)) then
+    result := 0
+  else
+  begin
+    if fAlgoHasForcedFormat then
+      EnsureAlgoHasNoForcedFormat('StreamComputeLen');
+    trailer := PAlgoCompressTrailer(P + Len - SizeOf(TAlgoCompressTrailer));
+    if (Magic = trailer^.Magic) and
+       (trailer^.HeaderRelativeOffset < Len) and
+       (PAlgoCompressHead(P + Len - trailer^.HeaderRelativeOffset)^.Magic = Magic) then
+      // trim existing content
+      result := Len - trailer^.HeaderRelativeOffset
+    else
+      result := Len;
+  end;
+end;
+
+class function TAlgoCompress.FileIsCompressed(const Name: TFileName;
+  Magic: cardinal): boolean;
+var
+  f: THandle;
+  l: integer;
+  h: TAlgoCompressHead;
+begin
+  result := false;
+  f := FileOpen(Name, fmOpenReadShared);
+  if not ValidHandle(f) then
+    exit;
+  l := FileRead(f, h, SizeOf(h));
+  FileClose(f);
+  result := (l = SizeOf(h)) and
+            (h.Magic = Magic); // only check the magic of first chunk header
+end;
+
+function TAlgoCompress.FileCompress(const Source, Dest: TFileName; Magic: cardinal;
+  ForceHash32: boolean; ChunkBytes: Int64; WithTrailer: boolean): boolean;
+var
+  S, D: THandleStream;
+begin
+  EnsureAlgoHasNoForcedFormat('FileCompres'); // should be overriden
+  result := false;
+  if (ChunkBytes > 0) and
+     FileExists(Source) then
+  try
+    S := FileStreamSequentialRead(Source);
+    try
+      DeleteFile(Dest);
+      D := TFileStreamEx.Create(Dest, fmCreate);
+      try
+        StreamCompress(S, D, Magic, ForceHash32, WithTrailer, ChunkBytes);
+      finally
+        D.Free;
+      end;
+      result := FileSetDateFrom(Dest, S.Handle);
+    finally
+      S.Free;
+    end;
+  except
+    on Exception do
+      result := false;
+  end;
+end;
+
+function TAlgoCompress.FileUnCompress(const Source, Dest: TFileName;
+  Magic: cardinal; ForceHash32: boolean): boolean;
+var
+  S, D: THandleStream;
+begin
+  EnsureAlgoHasNoForcedFormat('FileUnCompress'); // should be overriden
+  result := false;
+  if FileExists(Source) then
+  try
+    S := FileStreamSequentialRead(Source);
+    try
+      DeleteFile(Dest);
+      D := TFileStreamEx.Create(Dest, fmCreate);
+      try
+        if not StreamUnCompress(S, D, Magic, ForceHash32) then
+          exit;
+      finally
+        D.Free;
+      end;
+      result := FileSetDateFrom(Dest, S.Handle);
+    finally
+      S.Free;
+    end;
+  except
+    on Exception do
+      result := false;
+  end;
+end;
+
+function TAlgoCompress.DecompressHeader(Comp: PAnsiChar; CompLen: integer;
+  Load: TAlgoCompressLoad): integer;
+begin
+  result := 0;
+  if (CompLen <= 9) or
+     (Comp = nil) then
+    exit;
+  EnsureAlgoHasNoForcedFormat('Decompress');
+  if ((Load <> 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 PlainLen <= 0 then
+    exit;
+  if Comp[4] = COMPRESS_STORED then
+    MoveFast(Comp[9], Plain[0], PlainLen)
+  else if Comp[4] = AnsiChar(AlgoID) then
+    case Load of
+      aclNormal:
+        if (AlgoDecompress(Comp + 9, CompLen - 9, Plain) <> PlainLen) or
+           (AlgoHash(0, Plain, PlainLen) <> PCardinal(Comp)^) then
+          exit;
+      aclSafeSlow:
+        if (AlgoDecompressPartial(Comp + 9, CompLen - 9,
+            Plain, PlainLen, PlainLen) <> PlainLen) or
+           (AlgoHash(0, Plain, PlainLen) <> PCardinal(Comp)^) then
+          exit;
+      aclNoCrcFast:
+        if AlgoDecompress(Comp + 9, CompLen - 9, Plain) <> PlainLen then
+          exit;
+    end;
+  result := true;
+end;
+
+
+
+{ TAlgoSynLZ }
+
+constructor TAlgoSynLZ.Create;
+begin
+  fAlgoID := COMPRESS_SYNLZ; // =1
+  fAlgoFileExt := '.synlz';
+  inherited Create;
+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;
+
+
+{ TAlgoCompressWithNoDestLen }
+
+function TAlgoCompressWithNoDestLen.AlgoCompress(Plain: pointer; PlainLen: integer;
+  Comp: pointer): integer;
+begin
+  Comp := ToVarUInt32(PlainLen, Comp); // e.g. 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;
+
+
+{ TAlgoRleLZ }
+
+function TAlgoRleLZ.RawProcess(src, dst: pointer; srcLen, dstLen, dstMax: integer;
+  process: TAlgoCompressWithNoDestLenProcess): integer;
+var
+  tmp: TSynTempBuffer;
+  rle: integer;
+begin
+  case process of
+    doCompress:
+      begin
+        tmp.Init(srcLen - srcLen shr 3); // try to reduce at least by 1/8
+        rle := RleCompress(src, tmp.buf, srcLen, tmp.Len);
+        if rle < 0 then
+          // RLE was not worth it (no 1/8 reduction) -> apply only SynLZ
+          PByte(dst)^ := 0
+        else
+        begin
+          // the RLE first pass did reduce the size
+          PByte(dst)^ := 1;
+          src := tmp.buf;
+          srcLen := rle;
+        end;
+        inc(PByte(dst));
+        result := SynLZcompress1(src, srcLen, dst) + 1;
+        tmp.Done;
+      end;
+    doUnCompress:
+      begin
+        rle := PByte(src)^;
+        inc(PByte(src));
+        dec(srcLen);
+        if rle <> 0 then
+        begin
+          // process SynLZ with final RLE pass
+          tmp.Init(SynLZdecompressdestlen(src));
+          rle := SynLZdecompress1(src, srcLen, tmp.buf);
+          result := RleUnCompress(tmp.buf, dst, rle);
+          tmp.Done;
+        end
+        else
+          // only SynLZ was used
+          result := SynLZdecompress1(src, srcLen, dst);
+      end;
+    doUncompressPartial:
+      begin
+        rle := PByte(src)^;
+        inc(PByte(src));
+        dec(srcLen);
+        if rle <> 0 then
+        begin
+          // process full SynLZ with partial RLE pass (not optimal, but works)
+          tmp.Init(SynLZdecompressdestlen(src));
+          rle := SynLZdecompress1(src, srcLen, tmp.buf);
+          result := RleUnCompressPartial(tmp.buf, dst, rle, dstLen);
+          tmp.Done;
+        end
+        else
+          // only SynLZ was used
+          result := SynLZDecompress1Partial(src, srcLen, dst, dstLen);
+      end;
+  else
+    result := 0;
+  end;
+end;
+
+constructor TAlgoRleLZ.Create;
+begin
+  fAlgoID := 7;
+  fAlgoFileExt := '.synrlz';
+  inherited Create;
+end;
+
+function TAlgoRleLZ.AlgoCompressDestLen(PlainLen: integer): integer;
+begin
+  result := SynLZcompressdestlen(PlainLen);
+end;
+
+
+{ TAlgoRle }
+
+function TAlgoRle.RawProcess(src, dst: pointer; srcLen, dstLen, dstMax: integer;
+  process: TAlgoCompressWithNoDestLenProcess): integer;
+begin
+  case process of
+    doCompress:
+      begin
+        // try to reduce at least by 1/8
+        result := RleCompress(src, dst, srcLen, srcLen - srcLen shr 3);
+        if result < 0 then
+          // RLE was not worth it -> caller would fallback to plain store
+          result := dstLen; // to indicate no compression
+      end;
+    doUnCompress:
+      result := RleUnCompress(src, dst, srcLen);
+    doUncompressPartial:
+      result := RleUnCompressPartial(src, dst, srcLen, dstLen);
+  else
+    result := 0;
+  end;
+end;
+
+constructor TAlgoRle.Create;
+begin
+  fAlgoID := 8;
+  fAlgoFileExt := '.synrle';
+  inherited Create;
+end;
+
+function TAlgoRle.AlgoCompressDestLen(PlainLen: integer): integer;
+begin
+  result := PlainLen + 16;
+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]));
+  FastNewRawByteString(result{%H-}, L);
+  P := pointer(result);
+  for i := 0 to high(Values) do
+  begin
+    L := length(Values[i]);
+    MoveFast(pointer(Values[i])^, P^, L);
+    inc(P, L);
+  end;
+end;
+
+procedure RawByteStringToBytes(const buf: RawByteString; out bytes: TBytes);
+var
+  L: integer;
+begin
+  L := Length(buf);
+  if L <> 0 then
+  begin
+    SetLength(bytes, L);
+    MoveFast(pointer(buf)^, pointer(bytes)^, L);
+  end;
+end;
+
+procedure BytesToRawByteString(const bytes: TBytes; out buf: RawByteString);
+begin
+  FastSetRawByteString(buf, pointer(bytes), Length(bytes));
+end;
+
+procedure ResourceToRawByteString(const ResName: string; ResType: PChar;
+  out buf: RawByteString; Instance: TLibHandle);
+var
+  res: TExecutableResource;
+begin
+  if res.Open(ResName, ResType, Instance) then
+  begin
+    FastSetRawByteString(buf, res.Buffer, res.Size);
+    res.Close;
+  end;
+end;
+
+procedure ResourceSynLZToRawByteString(const ResName: string;
+  out buf: RawByteString; Instance: TLibHandle);
+var
+  res: TExecutableResource;
+begin
+  if res.Open(ResName, PChar(10), Instance) then
+  begin
+    AlgoSynLZ.Decompress(res.Buffer, res.Size, buf);
+    res.Close;
+  end;
+end;
+
+{$ifndef PUREMORMOT2}
+
+function StreamSynLZComputeLen(P: PAnsiChar; Len, Magic: cardinal): integer;
+begin
+  result := AlgoSynLZ.StreamComputeLen(P, Len, Magic);
+end;
+
+function StreamSynLZ(Source: TCustomMemoryStream; Dest: TStream; Magic: cardinal): integer;
+begin
+  result := AlgoSynLZ.StreamCompress(Source, Dest, Magic, {hash32=}true);
+end;
+
+function StreamSynLZ(Source: TCustomMemoryStream; const DestFile: TFileName;
+  Magic: cardinal): integer;
+begin
+  result := AlgoSynLZ.StreamCompress(Source, DestFile, Magic, {hash32=}true);
+end;
+
+function FileSynLZ(const Source, Dest: TFileName; Magic: cardinal): boolean;
+begin
+  result := AlgoSynLZ.FileCompress(Source, Dest, Magic, {hash32=}true);
+end;
+
+function FileUnSynLZ(const Source, Dest: TFileName; Magic: cardinal): boolean;
+begin
+  result := AlgoSynLZ.FileUnCompress(Source, Dest, Magic, {hash32=}true);
+end;
+
+function FileIsSynLZ(const Name: TFileName; Magic: cardinal): boolean;
+begin
+  result := AlgoSynLZ.FileIsCompressed(Name, Magic);
+end;
+
+function StreamUnSynLZ(const Source: TFileName; Magic: cardinal): TMemoryStream;
+begin
+  result := AlgoSynLZ.StreamUnCompress(Source, Magic, {hash32=}true);
+end;
+
+function StreamUnSynLZ(Source: TStream; Magic: cardinal): TMemoryStream;
+begin
+  result := AlgoSynLZ.StreamUnCompress(Source, Magic, {hash32=}true);
+end;
+
+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;
+
+procedure AppendBufferToRawByteString(
+  var Content: RawByteString; const Buffer; BufferLen: PtrInt);
+begin
+  Append(Content, @Buffer, BufferLen);
+end;
+
+procedure AppendBufferToRawByteString(var Content: RawByteString; const Buffer: RawByteString);
+begin
+  Append(Content, Buffer);
+end;
+
+procedure AppendToRawUtf8(var Text: RawUtf8; const After: RawByteString);
+begin
+  Append(Text, After);
+end;
+
+procedure AppendBufferToRawUtf8(var Text: RawUtf8; Buffer: PUtf8Char; BufferLen: PtrInt);
+begin
+  Append(Text, Buffer, BufferLen);
+end;
+
+procedure AppendCharToRawUtf8(var Text: RawUtf8; Ch: AnsiChar);
+begin
+  Append(Text, @Ch, 1);
+end;
+
+procedure AppendToRawUtf8(var Text: RawUtf8; const After1, After2: RawByteString);
+begin
+  Append(Text, After1, After2);
+end;
+
+{$endif PUREMORMOT2}
+
+
+{ ************ Base64, Base64Uri, Base58 and Baudot Encoding / Decoding }
+
+type
+  TBase64Enc = array[0..63] of AnsiChar;
+  PBase64Enc = ^TBase64Enc;
+  TBase64Dec = array[AnsiChar] of shortint;
+  PBase64Dec = ^TBase64Dec;
+
+const
+  b64enc: TBase64Enc =
+    'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
+  b64Urienc: TBase64Enc =
+    'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_';
+
+var
+  /// a conversion table from Base64 text into binary data
+  // - used by Base64ToBin/IsBase64 functions
+  // - has -1 (255) for invalid char, -2 (254) for '=', 0..63 for valid char
+  ConvertBase64ToBin, ConvertBase64UriToBin: TBase64Dec;
+
+
+{ --------- Base64 encoding/decoding }
+
+function Base64AnyDecode(const decode: TBase64Dec; sp, rp: PAnsiChar; len: PtrInt): boolean;
+var
+  c, ch: PtrInt;
+begin // FPC emits suboptimal asm but Base64DecodeMainAvx2() will run on server
+  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 Base64DecodeMainPas(sp, rp: PAnsiChar; len: PtrInt): boolean;
+begin
+  result := Base64AnyDecode(ConvertBase64ToBin, sp, rp, len);
+end;
+
+function Base64Decode(sp, rp: PAnsiChar; len: PtrInt): boolean;
+  {$ifdef FPC} inline;{$endif}
+var
+  tab: PBase64Dec; // use local register
+begin
+  tab := @ConvertBase64ToBin;
+  len := len shl 2; // len was the number of 4 chars chunks in sp
+  if (len > 0) and
+     (tab[sp[len - 2]] >= 0) then
+    if tab[sp[len - 1]] >= 0 then
+      // no trim
+    else
+      dec(len)
+  else
+    dec(len, 2); // Base64AnyDecode() algorithm ignores the trailing '='
+  {$ifdef ASMX64AVXNOCONST}
+  result := Base64DecodeMain(sp, rp, len); // may be Base64DecodeMainAvx2
+  {$else}
+  result := Base64AnyDecode(tab^, sp, rp, len);
+  {$endif ASMX64AVXNOCONST}
+end;
+
+procedure Base64EncodeLoop(rp, sp: PAnsiChar; len: cardinal; enc: PBase64Enc);
+  {$ifdef HASINLINE} inline; {$endif}
+var
+  c: cardinal;
+begin // this loop is faster than mORMot 1 manual x86 asm, even on Delphi 7
+  repeat
+    c := (ord(sp[0]) shl 16) or (ord(sp[1]) shl 8) or ord(sp[2]);
+    rp[0] := enc[(c shr 18) and $3f];
+    rp[1] := enc[(c shr 12) and $3f];
+    rp[2] := enc[(c shr 6) and $3f];
+    rp[3] := enc[c and $3f];
+    inc(rp, 4);
+    inc(sp, 3);
+    dec(len, 3)
+  until len = 0;
+end;
+
+{$ifdef ASMX64AVXNOCONST} // AVX2 ASM not available on Delphi < 11
+function Base64EncodeMainAvx2(rp, sp: PAnsiChar; len: cardinal): integer;
+var
+  blen: PtrUInt;
+begin
+  result := len div 3;
+  if result = 0 then
+    exit;
+  blen := result * 3;
+  Base64EncodeAvx2(sp, blen, rp); // handle >=32 bytes of data using AVX2
+  Base64EncodeLoop(rp, sp, blen, @b64enc); // good inlining code generation
+end;
+
+function Base64DecodeMainAvx2(sp, rp: PAnsiChar; len: PtrInt): boolean;
+begin
+  Base64DecodeAvx2(sp, len, rp);
+  // on error, AVX2 code let sp point to the faulty input so result=false
+  result := Base64AnyDecode(ConvertBase64ToBin, sp, rp, len);
+end;
+{$endif ASMX64AVXNOCONST}
+
+function Base64EncodeMainPas(rp, sp: PAnsiChar; len: cardinal): integer;
+var
+  enc: PBase64Enc; // use local register
+begin
+  enc := @b64enc;
+  result := len div 3;
+  if result <> 0 then
+    Base64EncodeLoop(rp, sp, result * 3, enc);
+end;
+
+procedure Base64EncodeTrailing(rp, sp: PAnsiChar; len: cardinal);
+var
+  c: cardinal;
+  enc: PBase64Enc; // use local register
+begin
+  enc := @b64enc;
+  case len of
+    1:
+      begin
+        c := ord(sp[0]) shl 4;
+        rp[0] := enc[(c shr 6) and $3f];
+        rp[1] := enc[c and $3f];
+        PWord(rp + 2)^ := ord('=') + ord('=') shl 8;
+      end;
+    2:
+      begin
+        c := (ord(sp[0]) shl 10) or (ord(sp[1]) shl 2);
+        rp[0] := enc[(c shr 12) and $3f];
+        rp[1] := enc[(c shr 6) and $3f];
+        rp[2] := enc[c and $3f];
+        rp[3] := '=';
+      end;
+  end;
+end;
+
+procedure Base64Encode(rp, sp: PAnsiChar; len: cardinal);
+var
+  main: cardinal;
+begin
+  main := Base64EncodeMain(rp, sp, len); // may use AVX2 on FPC x86_64
+  Base64EncodeTrailing(rp + main * 4, sp + main * 3, len - main * 3);
+end;
+
+function BinToBase64Length(len: PtrUInt): PtrUInt;
+begin
+  result := ((len + 2) div 3) * 4;
+end;
+
+function BinToBase64(const s: RawByteString): RawUtf8;
+var
+  len: integer;
+begin
+  result := '';
+  len := length(s);
+  if len = 0 then
+    exit;
+  FastSetString(result, BinToBase64Length(len));
+  Base64Encode(pointer(result), pointer(s), len);
+end;
+
+function BinToBase64Short(Bin: PAnsiChar; BinBytes: integer): ShortString;
+var
+  destlen: integer;
+begin
+  result := '';
+  if BinBytes = 0 then
+    exit;
+  destlen := BinToBase64Length(BinBytes);
+  if destlen > 255 then
+    exit; // avoid buffer overflow
+  result[0] := AnsiChar(destlen);
+  Base64Encode(@result[1], Bin, BinBytes);
+end;
+
+function BinToBase64Line(sp: PAnsiChar; len: PtrUInt; const Prefix, Suffix: RawUtf8): RawUtf8;
+const
+  PERLINE = (64 * 3) div 4; // = 48 bytes for 64 chars per line
+var
+  p: PAnsiChar;
+  outlen, last: PtrUInt;
+begin
+  outlen := BinToBase64Length(len);
+  inc(outlen, 2 * (outlen shr 6) + 2); // one CRLF per line
+  FastSetString(result{%H-}, PtrInt(outlen) + length(Prefix) + length(Suffix));
+  p := pointer(result);
+  if Prefix <> '' then
+  begin
+    MoveFast(pointer(Prefix)^, p^, PStrLen(PAnsiChar(pointer(Prefix)) - _STRLEN)^);
+    inc(p, PStrLen(PAnsiChar(pointer(Prefix)) - _STRLEN)^);
+  end;
+  while len >= PERLINE do
+  begin
+    Base64EncodeLoop(p, sp, PERLINE, @b64enc); // better inlining than AVX2 here
+    inc(sp, PERLINE);
+    PWord(p + 64)^ := $0a0d; // CR + LF on all systems for safety
+    inc(p, 66);
+    dec(len, PERLINE);
+  end;
+  if len > 0 then
+  begin
+    last := len div 3;
+    if last <> 0 then
+      Base64EncodeLoop(p, sp, last * 3, @b64enc);
+    inc(p, last * 4);
+    last := last * 3;
+    inc(sp, last);
+    dec(len, last);
+    if len <> 0 then
+    begin
+      Base64EncodeTrailing(p, sp, len); // 1/2 bytes as 4 chars with trailing =
+      inc(p, 4);
+    end;
+    PWord(p)^ := $0a0d;
+    inc(p, 2);
+  end;
+  if Suffix <> '' then
+  begin
+    MoveFast(pointer(Suffix)^, p^, PStrLen(PAnsiChar(pointer(Suffix)) - _STRLEN)^);
+    inc(p, PStrLen(PAnsiChar(pointer(Suffix)) - _STRLEN)^);
+  end;
+  FakeLength(result, pointer(p));
+end;
+
+function BinToBase64Short(const s: RawByteString): ShortString;
+begin
+  result := BinToBase64Short(pointer(s), length(s));
+end;
+
+function BinToBase64(Bin: PAnsiChar; BinBytes: integer): RawUtf8;
+begin
+  result := '';
+  if BinBytes = 0 then
+    exit;
+  FastSetString(result, BinToBase64Length(BinBytes));
+  Base64Encode(pointer(result), Bin, BinBytes);
+end;
+
+function BinToBase64(const data, Prefix, Suffix: RawByteString; WithMagic: boolean): RawUtf8;
+var
+  lendata, lenprefix, lensuffix, len: integer;
+  res: PByteArray absolute result;
+begin
+  result := '';
+  lendata := length(data);
+  lenprefix := length(Prefix);
+  lensuffix := length(Suffix);
+  if lendata + lenprefix + lensuffix = 0 then
+    exit;
+  len := ((lendata + 2) div 3) * 4 + lenprefix + lensuffix;
+  if WithMagic then
+    inc(len, 3);
+  FastSetString(result, len);
+  if lenprefix > 0 then
+    MoveFast(pointer(Prefix)^, res^, lenprefix);
+  if WithMagic then
+  begin
+    PInteger(@res[lenprefix])^ := JSON_BASE64_MAGIC_C;
+    inc(lenprefix, 3);
+  end;
+  Base64Encode(@res[lenprefix], pointer(data), lendata);
+  if lensuffix > 0 then
+    MoveFast(pointer(Suffix)^, res[len - lensuffix], lensuffix);
+end;
+
+function BinToBase64WithMagic(const data: RawByteString): RawUtf8;
+begin
+  BinToBase64WithMagic(pointer(data), length(data), result{%H-});
+end;
+
+function BinToBase64WithMagic(Data: pointer; DataLen: integer): RawUtf8;
+begin
+  BinToBase64WithMagic(Data, DataLen, result{%H-});
+end;
+
+procedure BinToBase64WithMagic(Data: pointer; DataLen: integer;
+  var Result: RawUtf8);
+begin
+  Result := '';
+  if DataLen <= 0 then
+    exit;
+  FastSetString(Result, ((DataLen + 2) div 3) * 4 + 3);
+  PInteger(pointer(Result))^ := JSON_BASE64_MAGIC_C;
+  Base64Encode(PAnsiChar(pointer(Result)) + 3, Data, DataLen);
+end;
+
+function IsBase64Internal(sp: PAnsiChar; len: PtrInt; dec: PBase64Dec): boolean;
+var
+  i: PtrInt;
+begin
+  result := false;
+  if (len = 0) or
+     (len and 3 <> 0) then
+    exit;
+  for i := 0 to len - 5 do
+    if dec[sp[i]] < 0 then
+      exit;
+  inc(sp, len - 4);
+  if (dec[sp[0]] = -1) or
+     (dec[sp[1]] = -1) or
+     (dec[sp[2]] = -1) or
+     (dec[sp[3]] = -1) then
+    exit;
+  result := true; // layout seems correct
+end;
+
+function IsBase64(sp: PAnsiChar; len: PtrInt): boolean;
+begin
+  result := IsBase64Internal(sp, len, @ConvertBase64ToBin);
+end;
+
+function IsBase64(const s: RawByteString): boolean;
+begin
+  result := IsBase64Internal(pointer(s), length(s), @ConvertBase64ToBin);
+end;
+
+function Base64Length(sp: PAnsiChar; len: PtrInt; dec: PBase64Dec): PtrInt;
+  {$ifdef HASINLINE} inline; {$endif}
+begin
+  result := 0;
+  if (len = 0) or
+     (len and 3 <> 0) then
+    exit;
+  if dec[sp[len - 2]] >= 0 then
+    if dec[sp[len - 1]] >= 0 then
+      result := 0
+    else
+      result := 1
+  else
+    result := 2;
+  result := (len shr 2) * 3 - result;
+end;
+
+function Base64ToBinLengthSafe(sp: PAnsiChar; len: PtrInt): PtrInt;
+var
+  dec: PBase64Dec;
+begin
+  dec := @ConvertBase64ToBin;
+  if IsBase64Internal(sp, len, dec) then
+    result := Base64Length(sp, len, dec)
+  else
+    result := 0;
+end;
+
+function Base64ToBinLength(sp: PAnsiChar; len: PtrInt): PtrInt;
+begin
+  result := Base64Length(sp, len, @ConvertBase64ToBin);
+end;
+
+function Base64ToBin(const s: RawByteString): RawByteString;
+begin
+  Base64ToBinSafe(pointer(s), length(s), result{%H-});
+end;
+
+function Base64ToBin(sp: PAnsiChar; len: PtrInt): RawByteString;
+begin
+  Base64ToBinSafe(sp, len, result{%H-});
+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
+  if s = '' then
+    result := ''
+  else
+    Base64ToBinSafe(pointer(s), length(s), result);
+end;
+
+function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt): RawByteString;
+begin
+  Base64ToBinSafe(sp, len, result{%H-});
+end;
+
+function Base64LengthAdjust(sp: PAnsiChar; var len: PtrInt): PtrInt;
+  {$ifdef HASINLINE} inline; {$endif}
+var
+  tab: PBase64Dec;
+begin
+  result := len; // for better code generation
+  if (result = 0) or
+     (result and 3 <> 0) then
+  begin
+    result := 0;
+    exit;
+  end;
+  tab := @ConvertBase64ToBin;
+  if tab[sp[result - 2]] >= 0 then
+    if tab[sp[result - 1]] >= 0 then
+      result := 0
+    else
+      result := 1
+  else
+    result := 2;
+  sp := pointer(result);
+  result := (len shr 2) * 3 - result;
+  dec(len, PtrInt(sp)); // adjust for Base64AnyDecode() algorithm
+end;
+
+function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt; var data: RawByteString): boolean;
+var
+  resultLen: PtrInt;
+begin
+  result := false;
+  resultLen := Base64LengthAdjust(sp, len);
+  if resultLen <> 0 then
+  begin
+    FastNewRawByteString(data, resultLen);
+    result := Base64DecodeMain(sp, pointer(data), len); // may use AVX2
+  end;
+  if not result then
+    data := '';
+end;
+
+function Base64ToBinSafe(sp: PAnsiChar; len: PtrInt; out data: TBytes): boolean;
+var
+  resultLen: PtrInt;
+begin
+  result := false;
+  resultLen := Base64LengthAdjust(sp, len);
+  if resultLen = 0 then
+    exit;
+  SetLength(data, resultLen);
+  result := Base64DecodeMain(sp, pointer(data), len); // may use AVX2
+  if not result then
+    data := nil;
+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); // may use AVX2
+end;
+
+function Base64ToBin(base64, bin: PAnsiChar; base64len, binlen: PtrInt
+  {$ifndef PUREMORMOT2} ; nofullcheck: boolean {$endif}): boolean;
+begin
+  // nofullcheck is just ignored and deprecated
+  result := (bin <> nil) and
+            (Base64ToBinLength(base64, base64len) = binlen) and
+            Base64Decode(base64, bin, base64len shr 2); // may use AVX2
+end;
+
+function Base64ToBinTrim(const s: RawByteString): RawByteString;
+begin
+  result := Base64ToBin(TrimControlChars(s));
+end;
+
+function Base64ToBin(const base64: RawByteString; bin: PAnsiChar; binlen: PtrInt
+  {$ifndef PUREMORMOT2} ; nofullcheck: boolean {$endif}): boolean;
+begin
+  result := Base64ToBin(pointer(base64), bin, length(base64), binlen);
+end;
+
+
+{ --------- Base64 URI encoding/decoding }
+
+procedure Base64uriEncode(rp, sp: PAnsiChar; len: cardinal);
+var
+  main, c: cardinal;
+  enc: PBase64Enc; // faster especially on x86_64 and PIC
+begin
+  enc := @b64Urienc;
+  main := len div 3;
+  if main <> 0 then
+  begin
+    dec(len, main * 3); // fast modulo
+    repeat // inlined Base64EncodeLoop()
+      c := (ord(sp[0]) shl 16) or (ord(sp[1]) shl 8) or ord(sp[2]);
+      rp[0] := enc[(c shr 18) and $3f];
+      rp[1] := enc[(c shr 12) and $3f];
+      rp[2] := enc[(c shr 6) and $3f];
+      rp[3] := enc[c and $3f];
+      inc(rp, 4);
+      inc(sp, 3);
+      dec(main)
+    until main = 0;
+  end;
+  case len of
+    1:
+      begin
+        c := ord(sp[0]) shl 4;
+        rp[0] := enc[(c shr 6) and $3f];
+        rp[1] := enc[c and $3f];
+      end;
+    2:
+      begin
+        c := (ord(sp[0]) shl 10) or (ord(sp[1]) shl 2);
+        rp[0] := enc[(c shr 12) and $3f];
+        rp[1] := enc[(c shr 6) and $3f];
+        rp[2] := enc[c and $3f];
+      end;
+  end;
+end;
+
+function BinToBase64uriLength(len: PtrUInt): PtrUInt;
+begin
+  result := (len div 3) * 4;
+  case len - (result shr 2) * 3 of // fast len mod 3
+    1:
+      inc(result, 2);
+    2:
+      inc(result, 3);
+  end;
+end;
+
+function BinToBase64uri(const s: RawByteString): RawUtf8;
+var
+  len: integer;
+begin
+  result := '';
+  len := length(s);
+  if len = 0 then
+    exit;
+  FastSetString(result, BinToBase64uriLength(len));
+  Base64uriEncode(pointer(result), pointer(s), len);
+end;
+
+function BinToBase64uri(Bin: PAnsiChar; BinBytes: integer): RawUtf8;
+begin
+  result := '';
+  if BinBytes <= 0 then
+    exit;
+  FastSetString(result, 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{%H-});
+end;
+
+function Base64uriToBin(const s: RawByteString): RawByteString;
+begin
+  Base64uriToBin(pointer(s), length(s), result{%H-});
+end;
+
+function Base64uriToBin(sp: PAnsiChar; len: PtrInt; var bin: RawByteString): boolean;
+var
+  resultLen: PtrInt;
+begin
+  result := false;
+  resultLen := Base64uriToBinLength(len);
+  if resultLen <> 0 then
+  begin
+    FastNewRawByteString(bin, resultLen);
+    result := Base64AnyDecode(ConvertBase64UriToBin, sp, pointer(bin), len);
+  end;
+  if not result then
+    bin := '';
+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
+            FakeLength(base64, P - pointer(base64));
+            break;
+          end;
+      end;
+      inc(P);
+    until false;
+end;
+
+procedure Base64MagicDecode(var ParamValue: RawUtf8);
+var
+  tmp: RawUtf8;
+begin
+  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
+  if (Value = nil) or
+     (Value[0] = #0) or
+     (Value[1] = #0) or
+     (Value[2] = #0) or
+     (PCardinal(Value)^ and $ffffff <> JSON_BASE64_MAGIC_C) 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;
+  ValueLen: integer): boolean;
+begin
+  if (Value = nil) or
+     (Value[0] = #0) or
+     (Value[1] = #0) or
+     (Value[2] = #0) or
+     (PCardinal(Value)^ and $ffffff <> JSON_BASE64_MAGIC_C) then
+    result := false
+  else
+  begin
+    if ValueLen = 0 then
+      ValueLen := StrLen(Value);
+    dec(ValueLen, 3);
+    if ValueLen > 0 then
+      result := Base64ToBin(PAnsiChar(Value) + 3, ValueLen, Blob)
+    else
+      result := false;
+  end;
+end;
+
+function Base64MagicTryAndDecode(Value: PUtf8Char; ValueLen: integer;
+  var Blob: RawByteString): boolean;
+begin
+  if (ValueLen >= 4) and
+     (PCardinal(Value)^ and $ffffff = JSON_BASE64_MAGIC_C) then
+  begin
+    inc(Value, 3); // just ignore the magic trailer
+    dec(ValueLen, 3);
+  end;
+  result := Base64ToBinSafe(PAnsiChar(Value), ValueLen, Blob);
+end;
+
+function Base64MagicCheckAndDecode(Value: PUtf8Char; ValueLen: integer;
+  var Blob: RawByteString): boolean;
+begin
+  if (ValueLen < 4) or
+     (PCardinal(Value)^ and $ffffff <> JSON_BASE64_MAGIC_C) then
+    result := false
+  else
+    result := Base64ToBinSafe(PAnsiChar(Value) + 3, ValueLen - 3, Blob);
+end;
+
+
+{ --------- Base58 encoding/decoding }
+
+type
+  TBase58Enc = array[0..57] of AnsiChar;
+  PBase58Enc = ^TBase58Enc;
+  TBase58Dec = array[AnsiChar] of shortint;
+  PBase58Dec = ^TBase58Dec;
+
+const
+  b58enc: TBase58Enc =
+    '123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz';
+var
+  /// a conversion table from Base58 text into binary data
+  ConvertBase58ToBin: TBase58Dec;
+
+function BinToBase58(Bin: PAnsiChar; BinLen: integer; var Dest: TSynTempBuffer): integer;
+var
+  P, PEnd, P2: PByte;
+  len, c, carry, i: cardinal;
+begin
+  result := 0;
+  if (Bin = nil) or
+     (BinLen <= 0) then
+  begin
+    Dest.buf := nil;
+    exit;
+  end;
+  while Bin^ = #0 do
+  begin
+    inc(result); // any leading zero is stored as '1' -> result = num of zeros
+    inc(Bin);
+    dec(BinLen);
+    if BinLen = 0 then
+      break;
+  end;
+  P := Dest.InitZero(result + integer(cardinal(BinLen * 138) div 100));
+  PEnd := @PByteArray(P)[Dest.len];
+  if result <> 0 then
+  begin
+    FillcharFast(P^, result, ord('1'));
+    inc(P, result);
+  end;
+  if BinLen = 0 then
+    exit;
+  len := 0;
+  repeat
+    // this loop is O(n2) by definition so BinLen should remain small
+    i := 0;
+    P2 := PEnd;
+    carry := PByte(Bin)^;
+    while (PtrUInt(P2) >= PtrUInt(P)) and
+          ((carry <> 0) or
+           (i < len)) do
+    begin
+      inc(carry, cardinal(P2^) shl 8);
+      c := carry div 58;   // FPC will use fast reciprocal mul by 0x8d3dcb09
+      dec(carry, c * 58);
+      P2^ := carry;        // P2^ := carry mod 58
+      carry := c;
+      dec(P2);
+      inc(i);
+    end;
+    len := i;
+    inc(Bin);
+    dec(BinLen);
+  until BinLen = 0;
+  inc(PEnd);
+  P2 := P;
+  while (P2 <> PEnd) and
+        (P2^ = 0) do
+    inc(P2);
+  inc(result, PtrUInt(PEnd) - PtrUInt(P2));
+  while P2 <> PEnd do
+  begin
+    P^ := ord(b58enc[P2^]);
+    inc(P);
+    inc(P2);
+  end;
+end;
+
+function BinToBase58(Bin: PAnsiChar; BinLen: integer): RawUtf8;
+var
+  temp: TSynTempBuffer;
+  len: integer;
+begin
+  len := BinToBase58(Bin, BinLen, temp);
+  FastSetString(result{%H-}, temp.buf, len);
+  temp.Done;
+end;
+
+function BinToBase58(const Bin: RawByteString): RawUtf8;
+begin
+  result := BinToBase58(pointer(Bin), length(Bin));
+end;
+
+function Base58ToBin(B58: PAnsiChar; B58Len: integer;
+  var Dest: TSynTempBuffer): integer;
+var
+  P: PByteArray;
+  PEnd, P2: PByte;
+  zeros, carry: integer;
+begin
+  result := 0; // means void or error
+  if (B58 = nil) or
+     (B58Len <= 0) then
+  begin
+    Dest.buf := nil;
+    exit;
+  end;
+  zeros := 0;
+  while B58^ = '1' do
+  begin
+    inc(zeros);
+    inc(B58);
+    dec(B58Len);
+    if B58Len = 0 then
+      break;
+  end;
+  P := Dest.InitZero(zeros + integer(cardinal(B58Len * 733) div 1000));
+  PEnd := @P[Dest.len];
+  if B58Len = 0 then
+  begin
+    result := zeros;
+    exit;
+  end;
+  repeat
+    // this loop is O(n2) by definition so B58Len should remain small
+    carry := ConvertBase58ToBin[B58^];
+    inc(B58);
+    if carry < 0 then
+      exit; // invalid input
+    P2 := PEnd;
+    while PtrUInt(P2) >= PtrUInt(P) do
+    begin
+      inc(carry, 58 * P2^);
+      P2^ := carry;
+      carry := carry shr 8;
+      dec(P2);
+    end;
+    dec(B58Len);
+  until B58Len = 0;
+  P2 := pointer(P);
+  while (P2 <> PEnd) and
+        (P2^ = 0) do
+    inc(P2);
+  result := PtrUInt(PEnd) - PtrUInt(P2) + 1;
+  if result + zeros <> Dest.len + 1 then
+    MoveFast(P[PtrUInt(P2) - PtrUInt(P)], P[zeros], result);
+  inc(result, zeros);
+end;
+
+function Base58ToBin(B58: PAnsiChar; B58Len: integer): RawByteString;
+var
+  temp: TSynTempBuffer;
+  len: integer;
+begin
+  len := Base58ToBin(B58, B58Len, temp);
+  FastSetRawByteString(result{%H-}, temp.buf, len);
+  temp.Done;
+end;
+
+function Base58ToBin(const base58: RawUtf8): RawByteString;
+begin
+  result := Base58ToBin(pointer(base58), length(base58));
+end;
+
+function BinToBase32Length(BinLen: cardinal): cardinal;
+begin
+  if integer(BinLen) <= 0 then
+    result := 0
+  else
+    result := ((BinLen div 5) + cardinal(ord((BinLen mod 5) <> 0))) shl 3;
+end;
+
+procedure BinToBase32(Bin: PByteArray; Dest: PAnsiChar; BinLen: PtrInt; b32enc: PAnsiChar);
+const
+  b32pad: array[0..4] of byte = (8, 6, 4, 3, 1);
+var
+  c, d: PtrInt; // optimized for x86_64 and ARM/AARCH64
+begin
+  while BinLen >= 5 do // handle whole blocks of 5 input bytes as 8 text chars
+  begin
+    c := Bin[0];
+    d := Bin[1];
+    Dest[0] := b32enc[(c and $f8) shr 3];
+    Dest[1] := b32enc[((d and $c0) shr 6) or ((c and $07) shl 2)];
+    Dest[2] := b32enc[(d and $3e) shr 1];
+    c := Bin[2];
+    Dest[3] := b32enc[((c and $f0) shr 4) or ((d and $01) shl 4)];
+    d := Bin[3];
+    Dest[4] := b32enc[((d and $80) shr 7) or ((c and $0f) shl 1)];
+    Dest[5] := b32enc[(d and $7c) shr 2];
+    c := Bin[4];
+    Dest[6] := b32enc[((c and $e0) shr 5) or ((d and $03) shl 3)];
+    Dest[7] := b32enc[c and $1f];
+    dec(BinLen, 5);
+    if BinLen = 0 then
+      exit;
+    Bin := @Bin[5];
+    inc(Dest, 8);
+  end;
+  repeat // remaining 1..4 bytes in a "repeat until true" block to avoid goto
+    c := Bin[0];
+    Dest[0] := b32enc[(c and $f8) shr 3];
+    c := (c and $07) shl 2;
+    if BinLen < 2 then
+    begin
+      Dest[1] := b32enc[c];
+      break;
+    end;
+    d := Bin[1];
+    Dest[1] := b32enc[((d and $c0) shr 6) or c];
+    Dest[2] := b32enc[(d and $3e) shr 1];
+    c := (d and $01) shl 4;
+    if BinLen < 3 then
+    begin
+      Dest[3] := b32enc[c];
+      break;
+    end;
+    d := Bin[2];
+    Dest[3] := b32enc[((d and $f0) shr 4) or c];
+    c := (d and $0f) shl 1;
+    if BinLen < 4 then
+    begin
+      Dest[4] := b32enc[c];
+      break;
+    end;
+    d := Bin[3];
+    Dest[4] := b32enc[((d and $80) shr 7) or c];
+    Dest[5] := b32enc[(d and $7c) shr 2];
+    Dest[6] := b32enc[(d and $03) shl 3];
+  until true;
+  BinLen := b32pad[BinLen];
+  inc(Dest, 7 - BinLen);
+  repeat
+    Dest[BinLen] := '='; // padding
+    dec(BinLen);
+  until BinLen = 0;
+end;
+
+const
+  b32enc: array[0..31] of AnsiChar = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ234567';
+var
+  ConvertBase32ToBin: TBase64Dec;
+
+function BinToBase32(Bin: PAnsiChar; BinLen: PtrInt): RawUtf8;
+begin
+  FastSetString(result, BinToBase32Length(BinLen));
+  if result <> '' then
+    BinToBase32(pointer(Bin), pointer(result), BinLen, @b32enc);
+end;
+
+function BinToBase32(const Bin: RawByteString): RawUtf8;
+begin
+  result := BinToBase32(pointer(Bin), length(Bin));
+end;
+
+function Base32Decode(decode: PBase64Dec; sp: PAnsiChar; rp: PByteArray;
+  len: PtrInt): pointer;
+var
+  c, d, e: integer;
+begin
+  result := nil;
+  while len > 8 do  // handle whole blocks of 8 input text chars into 5 bytes
+  begin
+    c := decode[sp[0]];
+    d := decode[sp[1]];
+    if (c < 0) or
+       (d < 0) then
+      exit;
+    rp[0] := ((c and $1f) shl 3) or ((d and $1c) shr 2);
+    c := decode[sp[2]];
+    e := decode[sp[3]];
+    if (c < 0) or
+       (e < 0) then
+      exit;
+    rp[1] := ((d and $03) shl 6) or ((c and $1f) shl 1) or ((e and $10) shr 4);
+    c := decode[sp[4]];
+    if c < 0 then
+      exit;
+    rp[2] := ((e and $0f) shl 4) or ((c and $1e) shr 1);
+    d := decode[sp[5]];
+    e := decode[sp[6]];
+    if (d < 0) or
+       (e < 0) then
+      exit;
+    rp[3] := ((c and $01) shl 7) or ((d and $1f) shl 2) or ((e and $18) shr 3);
+    c := decode[sp[7]];
+    if c < 0 then
+      exit;
+    rp[4] := ((e and $07) shl 5) or (c and $1f);
+    rp := @rp[5];
+    dec(len, 8);
+    inc(sp, 8);
+  end;
+  c := decode[sp[0]]; // decode trailing text chars into 1..4 bytes
+  d := decode[sp[1]];
+  if (c < 0) or
+     (d < 0) then
+    exit;
+  rp[0] := ((c and $1f) shl 3) or ((d and $1c) shr 2);
+  rp := @rp[1];
+  repeat
+    if sp[2] = '=' then
+      break;
+    c := decode[sp[2]];
+    e := decode[sp[3]];
+    if (c < 0) or
+       (e < 0) then
+      exit;
+    rp[0] := ((d and $03) shl 6) or ((c and $1f) shl 1) or ((e and $10) shr 4);
+    rp := @rp[1];
+    if sp[4] = '=' then
+      break;
+    c := decode[sp[4]];
+    if c < 0 then
+      exit;
+    rp[0] := ((e and $0f) shl 4) or ((c and $1e) shr 1);
+    rp := @rp[1];
+    if sp[5] = '=' then
+      break;
+    d := decode[sp[5]];
+    e := decode[sp[6]];
+    if (d < 0) or
+       (e < 0) then
+      exit;
+    rp[0] := ((c and $01) shl 7) or ((d and $1f) shl 2) or ((e and $18) shr 3);
+    rp := @rp[1];
+    if sp[7] = '=' then
+      break;
+    c := decode[sp[7]];
+    if c < 0 then
+      exit;
+    rp[0] := ((e and $07) shl 5) or (c and $1f);
+    rp := @rp[1];
+  until true;
+  result := rp;
+end;
+
+function Base32ToBin(B32: PAnsiChar; B32Len: integer): RawByteString;
+var
+  p: PAnsiChar;
+begin
+  if (B32Len > 0) and
+     ((B32Len and 7) = 0) then
+  begin
+    FastNewRawByteString(result, (B32Len shr 3) * 5);
+    p := Base32Decode(@ConvertBase32ToBin, B32, pointer(result), B32Len);
+    if p <> nil then
+    begin
+      FakeLength(result, p - pointer(result));
+      exit;
+    end;
+  end;
+  result := '';
+end;
+
+function Base32ToBin(const base32: RawUtf8): RawByteString;
+begin
+  result := Base32ToBin(pointer(base32), length(base32));
+end;
+
+function BlobToRawBlob(P: PUtf8Char; Len: integer): RawBlob;
+begin
+  BlobToRawBlob(P, result{%H-}, Len);
+end;
+
+procedure BlobToRawBlob(P: PUtf8Char; var result: RawBlob; Len: integer);
+var
+  LenHex: integer;
+begin
+  result := '';
+  if Len = 0 then
+    Len := StrLen(P);
+  if Len = 0 then
+    exit;
+  if Len >= 3 then
+    if (P[0] in ['x', 'X']) and
+       (P[1] = '''') and
+       (P[Len - 1] = '''') then
+    begin
+      // BLOB literals are string literals containing hexadecimal data and
+      // preceded by a single "x" or "X" character. For example: X'53514C697465'
+      LenHex := (Len - 3) shr 1;
+      pointer(result) := FastNewString(LenHex, CP_RAWBYTESTRING);
+      if mormot.core.text.HexToBin(@P[2], pointer(result), LenHex) then
+        exit; // valid hexa data
+    end
+    else if (PInteger(P)^ and $00ffffff = JSON_BASE64_MAGIC_C) and
+       Base64ToBinSafe(@P[3], Len - 3, RawByteString(result)) then
+      exit; // safe decode Base64 content ('\uFFF0base64encodedbinary')
+  // TEXT format
+  FastSetStringCP(result, P, Len, CP_RAWBYTESTRING);
+end;
+
+function BlobToRawBlob(const Blob: RawByteString): RawBlob;
+var
+  Len, LenHex: integer;
+  P: PUtf8Char;
+begin
+  result := '';
+  if Blob = '' then
+    exit;
+  Len := length(Blob);
+  P := pointer(Blob);
+  if Len >= 3 then
+    if (P[0] in ['x', 'X']) and
+       (P[1] = '''') and
+       (P[Len - 1] = '''') then
+    begin
+      // BLOB literals are string literals containing hexadecimal data and
+      // preceded by a single "x" or "X" character. For example: X'53514C697465'
+      LenHex := (Len - 3) shr 1;
+      pointer(result) := FastNewString(LenHex, CP_RAWBYTESTRING);
+      if mormot.core.text.HexToBin(@P[2], pointer(result), LenHex) then
+        exit; // valid hexa data
+    end
+    else if (PInteger(P)^ and $00ffffff = JSON_BASE64_MAGIC_C) and
+        Base64ToBinSafe(@P[3], Len - 3, RawByteString(result)) then
+      exit; // safe decode Base64 content ('\uFFF0base64encodedbinary')
+  // TEXT format
+  result := Blob;
+end;
+
+function BlobToStream(P: PUtf8Char): TStream;
+begin
+  result := TRawByteStringStream.Create(BlobToRawBlob(P));
+end;
+
+function BlobToBytes(P: PUtf8Char): TBytes;
+var
+  Len, LenResult: integer;
+begin
+  result := nil;
+  Len := StrLen(P);
+  if Len = 0 then
+    exit;
+  if Len >= 3 then
+    if (P[0] in ['x', 'X']) and
+       (P[1] = '''') and
+       (P[Len - 1] = '''') then
+    begin
+      // BLOB literals format
+      LenResult := (Len - 3) shr 1;
+      SetLength(result, LenResult);
+      if mormot.core.text.HexToBin(@P[2], pointer(result), LenResult) then
+        exit; // valid hexa data
+    end
+    else if (PInteger(P)^ and $00ffffff = JSON_BASE64_MAGIC_C) and
+            Base64ToBinSafe(@P[3], Len - 3, result) then
+       exit; // safe decode Base64 content ('\uFFF0base64encodedbinary')
+  // TEXT format
+  SetLength(result, Len);
+  MoveFast(P^, pointer(result)^, Len);
+end;
+
+function RawBlobToBlob(const RawBlob: RawBlob): RawUtf8;
+// BLOB literals are string literals containing hexadecimal data and
+//  preceded by a single "x" or "X" character. For example: X'53514C697465'
+begin
+  result := RawBlobToBlob(pointer(RawBlob), length(RawBlob));
+end;
+
+function RawBlobToBlob(RawBlob: pointer; RawBlobLength: integer): RawUtf8;
+// BLOB literals are string literals containing hexadecimal data and
+//  preceded by a single "x" or "X" character. For example: X'53514C697465'
+var
+  P: PAnsiChar;
+begin
+  result := '';
+  if RawBlobLength <> 0 then
+  begin
+    pointer(result) := FastNewString(RawBlobLength * 2 + 3, CP_UTF8);
+    P := pointer(result);
+    P[0] := 'X';
+    P[1] := '''';
+    BinToHex(RawBlob, P + 2, RawBlobLength);
+    P[RawBlobLength * 2 + 2] := '''';
+  end;
+end;
+
+function isBlobHex(P: PUtf8Char): boolean;
+// BLOB literals are string literals containing hexadecimal data and
+// preceded by a single "x" or "X" character. For example: X'53514C697465'
+var
+  Len: integer;
+begin
+  if P = nil then
+  begin
+    result := false;
+    exit;
+  end;
+  while (P^ <= ' ') and
+        (P^ <> #0) do
+    inc(P);
+  if (P[0] in ['x', 'X']) and
+     (P[1] = '''') then
+  begin
+    Len := (StrLen(P) - 3) shr 1;
+    result := (P[Len - 1] = '''') and
+              mormot.core.text.HexToBin(@P[2], nil, Len);
+    exit;
+  end
+  else
+  begin
+    result := false;
+    exit;
+  end;
+end;
+
+procedure Base64MagicToBlob(Base64: PUtf8Char; var result: RawUtf8);
+begin
+  // do not escape the result: returns e.g. X'53514C697465'
+  result := RawBlobToBlob(Base64ToBin(PAnsiChar(Base64), StrLen(Base64)));
+end;
+
+
+
+{ --------- MultiPart encoding/decoding }
+
+function MultiPartFormDataDecode(const MimeType, Body: RawUtf8;
+  var MultiPart: TMultiPartDynArray): boolean;
+var
+  boundary, endBoundary: RawUtf8;
+  i, j, n: integer;
+  P: PUtf8Char;
+  part: TMultiPart;
+
+  function GetBoundary(const line: RawUtf8): boolean;
+  var
+    i: integer;
+  begin
+    result := false;
+    i := PosEx('boundary=', line);
+    if i = 0 then
+      exit;
+    TrimCopy(line, i + 9, 200, boundary);
+    if (boundary <> '') and
+       (boundary[1] = '"') then
+      TrimChars(boundary, 1, 1); // "boundary" -> boundary
+    Make(['--', boundary, '--'#13#10], endBoundary);
+    boundary := Make(['--', boundary, #13#10]);
+    result := true;
+  end;
+
+begin
+  result := false;
+  if not GetBoundary(MimeType) then
+    exit;
+  i := PosEx(boundary{%H-}, Body);
+  if i <> 0 then
+    repeat
+      inc(i, length(boundary));
+      if i = length(Body) then
+        exit; // reached the (premature) end
+      P := PUtf8Char(Pointer(Body)) + i - 1;
+      Finalize(part);
+      // decode section header
+      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 if IdemPChar(P, 'FILE; ') then
+          begin
+            inc(P, 6);
+            IdemPCharAndGetNextItem(P, 'NAME="', part.Name, '"');
+            if P^ = ';' then
+              P := GotoNextNotSpace(P + 1);
+            IdemPCharAndGetNextItem(P, 'FILENAME="', part.FileName, '"');
+          end;
+        end
+        else if IdemPCharAndGetNextItem(P, 'CONTENT-TYPE: ', part.ContentType) then
+        begin
+          if IdemPChar(pointer(part.ContentType), 'MULTIPART/MIXED') then
+            if GetBoundary(part.ContentType) then
+              part.ContentType := 'files'
+            else
+              exit;
+        end
+        else
+          IdemPCharAndGetNextItem(P, 'CONTENT-TRANSFER-ENCODING: ', part.Encoding);
+        P := GotoNextLine(P);
+        if P = nil then
+          exit;
+      until PWord(P)^ = 13 + 10 shl 8;
+      // decode section content
+      i := P - PUtf8Char(Pointer(Body)) + 3; // i = just after header
+      j := PosEx(boundary, Body, i);
+      if j = 0 then
+      begin
+        j := PosEx(endBoundary{%H-}, Body, i); // try last boundary
+        if j = 0 then
+          exit;
+        result := true; // content seems well formatted enough
+      end;
+      if part.ContentType <> 'files' then
+      begin
+        part.Content := copy(Body, i, j - i - 2); // -2 to ignore trailing #13#10
+        if (part.ContentType = '') or
+           (PosEx('-8', part.ContentType) > 0) then
+        begin
+          if IdemPChar(pointer(part.ContentType), JSON_CONTENT_TYPE_UPPER) then
+            part.ContentType := JSON_CONTENT_TYPE
+          else
+            part.ContentType := TEXT_CONTENT_TYPE;
+          FakeCodePage(part.Content, CP_UTF8); // ensure value is UTF-8
+        end;
+        if PropNameEquals(part.Encoding, 'base64') then
+          part.Content := Base64ToBin(part.Content);
+        // note: "quoted-printable" not yet handled here
+        n := length(MultiPart);
+        SetLength(MultiPart, n + 1);
+        MultiPart[n] := part;
+      end;
+      i := j;
+    until result;
+end;
+
+function MultiPartFormDataNewBound(var boundaries: TRawUtf8DynArray): RawUtf8;
+var
+  random: array[0..2] of cardinal;
+begin
+  RandomBytes(@random, SizeOf(random));
+  result := BinToBase64uri(@random, SizeOf(random));
+  AddRawUtf8(boundaries, result);
+end;
+
+function MultiPartFormDataEncode(const MultiPart: TMultiPartDynArray;
+  var MultiPartContentType, MultiPartContent: RawUtf8;
+  Rfc2388NestedFiles: boolean): boolean;
+var
+  len, filescount, i: integer;
+  boundaries: TRawUtf8DynArray;
+  bound: RawUtf8;
+  W: TTextWriter;
+  temp: TTextWriterStackBuffer;
+begin
+  result := false;
+  len := length(MultiPart);
+  if len = 0 then
+    exit;
+  filescount := 0;
+  W := TTextWriter.CreateOwnedStream(temp);
+  try
+    // header - see https://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
+    bound := MultiPartFormDataNewBound(boundaries);
+    MultiPartContentType :=
+      'Content-Type: multipart/form-data; boundary=' + bound;
+    for i := 0 to len - 1 do
+      with MultiPart[i] do
+      begin
+        if FileName = '' then
+          // simple name/value form section
+          W.Add('--%'#13#10'Content-Disposition: form-data; name="%"'#13#10 +
+            'Content-Type: %'#13#10#13#10'%'#13#10,
+            [bound, Name, ContentType, Content])
+        else
+        begin
+          // if this is the first file, create the RFC 2388 nested "files"
+          if Rfc2388NestedFiles and
+             (filescount = 0) then
+          begin
+            W.Add('--%'#13#10, [bound]);
+            bound := MultiPartFormDataNewBound(boundaries);
+            W.Add('Content-Disposition: form-data; name="files"'#13#10 +
+              'Content-Type: multipart/mixed; boundary=%'#13#10#13#10, [bound]);
+            W.Add('--%'#13#10'Content-Disposition: file; filename="%"'#13#10 +
+              'Content-Type: %'#13#10, [bound, FileName, ContentType]);
+          end
+          else
+            // see https://tools.ietf.org/html/rfc7578#appendix-A
+            W.Add('--%'#13#10 +
+              'Content-Disposition: form-data; name="%"; filename="%"'#13#10 +
+              'Content-Type: %'#13#10,
+              [bound, Name, FileName, ContentType]);
+          if Encoding <> '' then
+            W.Add('Content-Transfer-Encoding: %'#13#10, [Encoding]);
+          W.AddCR;
+          W.AddString(MultiPart[i].Content);
+          W.AddCR;
+          inc(filescount);
+        end;
+      end;
+    // footer multipart
+    for i := length(boundaries) - 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;
+  const ForcedContentType: 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));
+  if ForcedContentType <> '' then
+    part.ContentType := ForcedContentType
+  else
+    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; const ForcedContentType: RawUtf8): boolean;
+var
+  part: TMultiPart;
+  newlen: integer;
+begin
+  result := false;
+  if FieldName = '' then
+    exit;
+  newlen := length(MultiPart) + 1;
+  part.Name := FieldName;
+  if ForcedContentType <> '' then
+    part.ContentType := ForcedContentType
+  else
+    part.ContentType := GetMimeContentTypeFromBuffer(
+      pointer(FieldValue), length(FieldValue), TEXT_CONTENT_TYPE);
+  part.Content := FieldValue;
+  SetLength(MultiPart, newlen);
+  MultiPart[newlen - 1] := part;
+  result := true;
+end;
+
+
+{ --------- Baudot encoding/decoding }
+
+const
+  // see https://en.wikipedia.org/wiki/Baudot_code
+  Baudot2Char: array[0..63] of AnsiChar =
+   #0'e'#10'a siu'#13'drjnfcktzlwhypqobg'#254'mxv'#255+
+   #0'3'#10'- ''87'#13#0'4'#0',!:(5+)2$6019?@'#254'./;'#255;
+var
+  Char2Baudot: array[AnsiChar] of byte;
+
+function AsciiToBaudot(const Text: RawUtf8): RawByteString;
+begin
+  result := AsciiToBaudot(pointer(Text), length(Text));
+end;
+
+function AsciiToBaudot(P: PAnsiChar; len: PtrInt): RawByteString;
+var
+  i: PtrInt;
+  c, d, bits: integer;
+  shift: boolean;
+  dest: PByte;
+  tmp: TSynTempBuffer;
+begin
+  result := '';
+  if (P = nil) or
+     (len = 0) then
+    exit;
+  shift := false;
+  dest := tmp.Init((len * 10) shr 3);
+  d := 0;
+  bits := 0;
+  for i := 0 to len - 1 do
+  begin
+    c := Char2Baudot[P[i]];
+    if c > 32 then
+    begin
+      if not shift then
+      begin
+        d := (d shl 5) or 27;
+        inc(bits, 5);
+        shift := true;
+      end;
+      d := (d shl 5) or (c - 32);
+      inc(bits, 5);
+    end
+    else if c > 0 then
+    begin
+      if shift and
+         (P[i] >= ' ') then
+      begin
+        d := (d shl 5) or 31;
+        inc(bits, 5);
+        shift := false;
+      end;
+      d := (d shl 5) or c;
+      inc(bits, 5);
+    end;
+    while bits >= 8 do
+    begin
+      dec(bits, 8);
+      dest^ := d shr bits;
+      inc(dest);
+    end;
+  end;
+  if bits > 0 then
+  begin
+    dest^ := d shl (8 - bits);
+    inc(dest);
+  end;
+  FastSetRawByteString(result, tmp.buf, PAnsiChar(dest) - PAnsiChar(tmp.buf));
+  tmp.Done;
+end;
+
+function BaudotToAscii(const Baudot: RawByteString): RawUtf8;
+begin
+  result := BaudotToAscii(pointer(Baudot), length(Baudot));
+end;
+
+function BaudotToAscii(Baudot: PByteArray; len: PtrInt): RawUtf8;
+var
+  i: PtrInt;
+  c, b, bits, shift: integer;
+  tmp: TSynTempBuffer;
+  dest: PAnsiChar;
+begin
+  result := '';
+  if (Baudot = nil) or
+     (len <= 0) then
+    exit;
+  dest := tmp.Init((len shl 3) div 5);
+  try
+    shift := 0;
+    b := 0;
+    bits := 0;
+    for i := 0 to len - 1 do
+    begin
+      b := (b shl 8) or Baudot[i];
+      inc(bits, 8);
+      while bits >= 5 do
+      begin
+        dec(bits, 5);
+        c := (b shr bits) and 31;
+        case c of
+          27:
+            if shift <> 0 then
+              exit
+            else
+              shift := 32;
+          31:
+            if shift <> 0 then
+              shift := 0
+            else
+              exit;
+        else
+          begin
+            c := ord(Baudot2Char[c + shift]);
+            if c = 0 then
+              if Baudot[i + 1] = 0 then // allow triming of last 5 bits
+                break
+              else
+                exit;
+            dest^ := AnsiChar(c);
+            inc(dest);
+          end;
+        end;
+      end;
+    end;
+  finally
+    tmp.Done(dest, result);
+  end;
+end;
+
+
+
+{ ***************** URI-Encoded Text Buffer Process }
+
+function UrlEncode(const svar: RawUtf8): RawUtf8;
+begin
+  result := UrlEncode(pointer(svar));
+end;
+
+function UrlEncodeName(const svar: RawUtf8): RawUtf8;
+begin
+  result := UrlEncodeName(pointer(svar));
+end;
+
+// two sub-functions for better code generation of UrlEncode()
+
+procedure _UrlEncode_Write(s, p: PByte; tab: PTextByteSet; space2plus: cardinal);
+var
+  c: cardinal;
+  hex: PByteToWord;
+begin
+  hex := @TwoDigitsHexWB;
+  repeat
+    c := s^;
+    inc(s);
+    if tcUriUnreserved in tab[c] then
+    begin
+      // was ['_', '-', '.', '~', '0'..'9', 'a'..'z', 'A'..'Z']
+      p^ := c;
+      inc(p);
+    end
+    else if c = 0 then
+      exit
+    else if c = space2plus then // space2plus=32 for parameter, =48 for URI
+    begin
+      p^ := ord('+');
+      inc(p);
+    end
+    else
+    begin
+      p^ := ord('%');
+      inc(p);
+      PWord(p)^ := hex[c];
+      inc(p, 2);
+    end;
+  until false;
+end;
+
+function _UrlEncode_ComputeLen(s: PByte; tab: PTextByteSet; space2plus: cardinal): PtrInt;
+var
+  c: cardinal;
+begin
+  result := 0;
+  repeat
+    c := s^;
+    inc(s);
+    if (tcUriUnreserved in tab[c]) or
+       (c = space2plus) then // =32 for parameter, =48 for URI
+    begin
+      inc(result);
+      continue;
+    end;
+    if c = 0 then
+      exit;
+    inc(result, 3);
+  until false;
+end;
+
+function UrlEncode(Text: PUtf8Char): RawUtf8;
+begin
+  result := '';
+  if Text = nil then
+    exit;
+  FastSetString(result, _UrlEncode_ComputeLen(pointer(Text), @TEXT_CHARS, 32));
+  _UrlEncode_Write(pointer(Text), pointer(result), @TEXT_BYTES, 32);
+end;
+
+function UrlEncodeName(Text: PUtf8Char): RawUtf8;
+begin
+  result := '';
+  if Text = nil then
+    exit;
+  FastSetString(result, _UrlEncode_ComputeLen(pointer(Text), @TEXT_CHARS, 48));
+  _UrlEncode_Write(pointer(Text), pointer(result), @TEXT_BYTES, 48);
+end;
+
+function UrlEncode(const NameValuePairs: array of const;
+  TrimLeadingQuestionMark: boolean): RawUtf8;
+// (['select','*','where','ID=12','offset',23,'object',aObject]);
+var
+  a, n: PtrInt;
+  name, value: RawUtf8;
+  p: PVarRec;
+begin
+  result := '';
+  n := high(NameValuePairs);
+  if (n > 0) and
+     (n and 1 = 1) then
+  begin
+    for a := 0 to n shr 1 do
+    begin
+      VarRecToUtf8(NameValuePairs[a * 2], name);
+      if not IsUrlValid(pointer(name)) then
+        continue; // just skip invalid names
+      p := @NameValuePairs[a * 2 + 1];
+      if p^.VType = vtObject then
+        value := ObjectToJson(p^.VObject, [])
+      else
+        VarRecToUtf8(p^, value);
+      result := result + '&' + name + '=' + UrlEncode(value);
+    end;
+    if TrimLeadingQuestionMark then
+      delete(result, 1, 1)
+    else
+      result[1] := '?';
+  end;
+end;
+
+function IsUrlValid(P: PUtf8Char): boolean;
+var
+  tab: PTextCharSet;
+begin
+  result := false;
+  if P = nil then
+    exit;
+  tab := @TEXT_CHARS;
+  repeat
+    if tcUriUnreserved in tab[P^] then
+      inc(P) // was  ['_', '-', '.', '~', '0'..'9', 'a'..'z', 'A'..'Z']
+    else
+      exit;
+  until P^ = #0;
+  result := true;
+end;
+
+function AreUrlValid(const Url: array of RawUtf8): boolean;
+var
+  i: integer;
+begin
+  result := false;
+  for i := 0 to high(Url) do
+    if not IsUrlValid(pointer(Url[i])) then
+      exit;
+  result := true;
+end;
+
+function IncludeTrailingUriDelimiter(const URI: RawByteString): RawByteString;
+begin
+  if (URI <> '') and
+     (Uri[length(URI)] <> '/') then
+    result := URI + '/'
+  else
+    result := URI;
+end;
+
+procedure UrlDecodeVar(U: PUtf8Char; L: PtrInt; var result: RawUtf8; name: boolean);
+var
+  P: PUtf8Char;
+  tmp: TSynTempBuffer;
+begin
+  if L = 0 then
+  begin
+    result := '';
+    exit;
+  end;
+  P := tmp.Init(L);
+  repeat
+    case U^ of
+      #0:
+        break; // reached end of URI
+      '%':
+        if not HexToChar(PAnsiChar(U + 1), P) then
+          P^ := U^ // browsers may not follow the RFC (e.g. encode % as % !)
+        else
+          inc(U, 2);
+      '+':
+        if name then
+          P^ := '+'
+        else
+          P^ := ' ';
+    else
+      P^ := U^;
+    end;
+    inc(U);
+    inc(P);
+  until false;
+  tmp.Done(P, result);
+end;
+
+function UrlDecode(U: PUtf8Char): RawUtf8;
+begin
+  UrlDecodeVar(U, StrLen(U), result, {name=}false);
+end;
+
+function UrlDecode(const s: RawUtf8): RawUtf8;
+begin
+  UrlDecodeVar(pointer(s), length(s), result, {name=}false);
+end;
+
+function UrlDecodeName(U: PUtf8Char): RawUtf8;
+begin
+  UrlDecodeVar(U, StrLen(U), result, {name=}true);
+end;
+
+function UrlDecodeName(const s: RawUtf8): RawUtf8;
+begin
+  UrlDecodeVar(pointer(s), length(s), result, {name=}true);
+end;
+
+function UrlDecodeNextValue(U: PUtf8Char; out Value: RawUtf8): PUtf8Char;
+var
+  Beg, V: PUtf8Char;
+  len: PtrInt;
+  {$ifndef CPUX86NOTPIC}
+  tab: PByteArray; // faster on PIC, ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  if U <> nil then
+  begin
+    // compute resulting length of value
+    {$ifndef CPUX86NOTPIC}
+    tab := @ConvertHexToBin;
+    {$endif CPUX86NOTPIC}
+    Beg := U;
+    len := 0;
+    while (U^ <> #0) and
+          (U^ <> '&') do
+    begin
+      if (U^ = '%') and
+         HexToCharValid(pointer(U + 1) {$ifndef CPUX86NOTPIC}, tab{$endif}) then
+        inc(U, 3)
+      else
+        inc(U);
+      inc(len);
+    end;
+    // decode value content
+    if len <> 0 then
+    begin
+      FastSetString(Value, len);
+      V := pointer(Value);
+      U := Beg;
+      repeat
+        if (U^ = '%') and
+           HexToChar(pointer(U + 1), V {$ifndef CPUX86NOTPIC}, tab{$endif}) then
+        begin
+          inc(V);
+          inc(U, 3);
+        end
+        else
+        begin
+          if U^ = '+' then
+            V^ := ' '
+          else
+            V^ := U^;
+          inc(V);
+          inc(U);
+        end;
+        dec(len);
+      until len = 0;
+    end;
+  end;
+  result := U;
+end;
+
+function UrlDecodeNextName(U: PUtf8Char; out Name: RawUtf8): PUtf8Char;
+var
+  Beg, V: PUtf8Char;
+  len: PtrInt;
+  {$ifndef CPUX86NOTPIC}
+  tab: PByteArray; // faster on PIC, ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  result := nil;
+  if U = nil then
+    exit;
+  // compute resulting length of name
+  {$ifndef CPUX86NOTPIC}
+  tab := @ConvertHexToBin;
+  {$endif CPUX86NOTPIC}
+  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 ending = according to the RFC
+        end
+        else if HexToCharValid(pointer(U + 1) {$ifndef CPUX86NOTPIC}, tab{$endif}) then
+          inc(U, 3)
+        else
+          inc(U);
+    else
+      inc(U);
+    end;
+    inc(len);
+  until false;
+  if len = 0 then
+    exit;
+  // decode name content
+  FastSetString(Name, len);
+  V := pointer(Name);
+  U := Beg;
+  repeat
+    if (U^ = '%') and
+       HexToChar(pointer(U + 1), V {$ifndef CPUX86NOTPIC}, tab{$endif}) then
+    begin
+      inc(V);
+      inc(U, 3);
+    end
+    else
+    begin
+      if U^ = '+' then
+        V^ := ' '
+      else
+        V^ := U^;
+      inc(V);
+      inc(U);
+    end;
+    dec(len);
+  until len = 0;
+end;
+
+function UrlDecodeNextNameValue(U: PUtf8Char; var Name, Value: RawUtf8): PUtf8Char;
+begin
+  result := nil;
+  if U = nil then
+    exit;
+  U := UrlDecodeNextName(U, Name);
+  if U = nil then
+    exit;
+  U := UrlDecodeNextValue(U, Value);
+  if U^ = #0 then
+    result := U
+  else
+    result := U + 1; // jump '&' to let decode the next name=value pair
+end;
+
+procedure UrlDecodeEnd(Next: PPUtf8Char; U: PUtf8Char); {$ifdef HASINLINE} inline; {$endif}
+var
+  c: AnsiChar;
+begin
+  if Next = nil then
+    exit;
+  repeat
+    c := U^;
+    inc(U);
+    if c <> #0 then
+      if c = '&' then
+        break // jump '&'
+      else
+        continue;
+    U := nil; // return nil when end of URI is reached
+    break;
+  until false;
+  Next^ := U;
+end;
+
+function UrlDecodeValue(U: PUtf8Char; const Upper: RawUtf8;
+  var Value: RawUtf8; Next: PPUtf8Char): boolean;
+begin
+  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;
+  UrlDecodeEnd(Next, U);
+end;
+
+function UrlDecodeInteger(U: PUtf8Char; const Upper: RawUtf8;
+  var Value: integer; Next: PPUtf8Char): boolean;
+var
+  v, sign: PtrInt;
+begin
+  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
+      sign := -1;
+      inc(U);
+    end
+    else
+      sign := 1;
+    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 * sign;
+      result := true;
+    end;
+  end;
+  UrlDecodeEnd(Next, U);
+end;
+
+function UrlDecodeCardinal(U: PUtf8Char; const Upper: RawUtf8;
+  var Value: cardinal; Next: PPUtf8Char): boolean;
+var
+  v: PtrInt;
+begin
+  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;
+  UrlDecodeEnd(Next, U);
+end;
+
+function UrlDecodeInt64(U: PUtf8Char; const Upper: RawUtf8;
+  var Value: Int64; Next: PPUtf8Char): boolean;
+var
+  v, sign: Int64;
+begin
+  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
+      sign := 1;
+      inc(U);
+    end
+    else
+      sign := -1;
+    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 * sign;
+      result := true;
+    end;
+  end;
+  UrlDecodeEnd(Next, U);
+end;
+
+function UrlDecodeExtended(U: PUtf8Char; const Upper: RawUtf8;
+  var Value: TSynExtended; Next: PPUtf8Char): boolean;
+var
+  tmp: RawUtf8;
+  err: integer;
+begin
+  result := UrlDecodeValue(U, Upper, tmp, Next);
+  if result then
+  begin
+    Value := GetExtended(pointer(tmp), err);
+    if err <> 0 then
+      result := false;
+  end;
+end;
+
+function UrlDecodeDouble(U: PUtf8Char; const Upper: RawUtf8;
+  var Value: double; Next: PPUtf8Char): boolean;
+var
+  tmp: RawUtf8;
+  err: integer;
+begin
+  result := UrlDecodeValue(U, Upper, tmp, Next);
+  if result then
+  begin
+    Value := GetExtended(pointer(tmp), err);
+    if err <> 0 then
+      result := false;
+  end;
+end;
+
+function UrlDecodeNeedParameters(U, CsvNames: PUtf8Char): boolean;
+var
+  tmp: array[byte] of AnsiChar;
+  L: integer;
+  Beg: PUtf8Char;
+// UrlDecodeNeedParameters('price=20.45&where=LastName%3D','price,where') will
+// return TRUE
+begin
+  result := (CsvNames = nil);
+  if result or
+     (U = nil) then
+    exit; // no parameter to check -> success; 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;
+
+
+{ *********** Basic MIME Content Types Support }
+
+const
+  MIME_MAGIC: array[0..17] of cardinal = (
+     $04034b50 + 1, $46445025 + 1, $21726152 + 1, $afbc7a37 + 1,
+     $694c5153 + 1, $75b22630 + 1, $9ac6cdd7 + 1, $474e5089 + 1,
+     $38464947 + 1, $46464f77 + 1, $a3df451a + 1, $002a4949 + 1,
+     $2a004d4d + 1, $2b004d4d + 1, $46464952 + 1, $e011cfd0 + 1,
+     $5367674f + 1, $1c000000 + 1);
+  MIME_MAGIC_TYPE: array[0..high(MIME_MAGIC)] of TMimeType = (
+     mtZip, mtPdf, mtRar, mt7z, mtSQlite3, mtWma, mtWmv, mtPng, mtGif, mtFont,
+     mtWebm, mtTiff, mtTiff, mtTiff, mtWebp{=riff}, mtDoc, mtOgg, mtMp4);
+
+function GetMimeContentTypeFromMemory(Content: Pointer; Len: PtrInt): TMimeType;
+var
+  i: PtrInt;
+begin
+  result := mtUnknown;
+  // see http://www.garykessler.net/library/file_sigs.html for magic numbers
+  if (Content <> nil) and
+     (Len > 4) then
+  begin
+    i := IntegerScanIndex(@MIME_MAGIC, length(MIME_MAGIC), PCardinal(Content)^ + 1);
+    // + 1 to avoid finding it in the exe - may use SSE2
+    if i >= 0 then
+      result := MIME_MAGIC_TYPE[i];
+    case result of // identify some partial matches
+      mtUnknown:
+        case PCardinal(Content)^ and $00ffffff of
+          $685a42:
+            result := mtBz2;  // 42 5A 68
+          $088b1f:
+            result := mtGzip; // 1F 8B 08
+          $492049:
+            result := mtTiff; // 49 20 49
+          $ffd8ff:
+            result := mtJpg;  // FF D8 FF DB/E0/E1/E2/E3/E8
+        else
+          case PWord(Content)^ of
+            $4D42:
+              result := mtBmp; // 42 4D
+          end;
+        end;
+      mtWebp:
+        if Len > 16 then // RIFF
+          case PCardinalArray(Content)^[2] of
+            $50424557:
+              result := mtWebp;
+            $20495641:
+              if PCardinalArray(Content)^[3] = $5453494c then
+                result := mtAvi; // Windows Audio Video Interleave file
+          else
+            result := mtUnknown;
+          end
+        else
+          result := mtUnknown;
+      mtDoc: // Microsoft Office applications D0 CF 11 E0=DOCFILE
+        if Len > 600 then
+          case PWordArray(Content)^[256] of // at offset 512
+            $a5ec:
+              result := mtDoc; // EC A5 C1 00
+            $fffd: // FD FF FF
+              case PByteArray(Content)^[516] of
+                $0E, $1c, $43:
+                  result := mtPpt;
+                $10, $1f, $20, $22, $23, $28, $29:
+                  result := mtXls;
+                else
+                  result := mtUnknown;
+              end
+            else
+              result := mtUnknown;
+          end
+        else
+          result := mtUnknown;
+      mtOgg:
+        if (Len < 14) or
+           (PCardinalArray(Content)^[1] <> $00000200) or
+           (PCardinalArray(Content)^[2] <> $00000000) or
+           (PWordArray(Content)^[6] <> $0000) then
+            result := mtUnknown;
+      mtMp4:
+        if (Len < 12) or
+           (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
+              $35706733: // 3gp5: MPEG-4 video files
+                ;
+            else
+              result := mtUnknown
+            end
+       else
+         result := mtUnknown;
+    end;
+  end;
+end;
+
+function GetMimeContentTypeFromBuffer(Content: Pointer; Len: PtrInt;
+  const DefaultContentType: RawUtf8; Mime: PMimeType): RawUtf8;
+var
+  m: TMimeType;
+begin
+  m := GetMimeContentTypeFromMemory(Content, Len);
+  if Mime <> nil then
+    Mime^ := m;
+  if m = mtUnknown then
+    result := DefaultContentType
+  else
+    result := MIME_TYPE[m];
+end;
+
+const
+  MIME_EXT: array[0..46] of PUtf8Char = ( // for IdemPPChar() start check
+    'PNG',  'GIF',  'TIF',  'JP',  'BMP', 'DOC',  'HTM',  'CSS',
+    'JSON', 'ICO',  'WOF', 'TXT', 'SVG',  'ATOM', 'RDF', 'RSS',
+    'WEBP', 'APPC', 'MANI', 'XML', 'JS',  'MJS',  'WOFF', 'OGG',
+    'OGV',  'MP4',  'M2V',  'M2P', 'MP3', 'H264', 'TEXT', 'LOG',
+    'GZ',  'WEBM', 'MKV',  'RAR',  '7Z',  'BZ2', 'WMA',  'WMV',
+    'AVI', 'PPT',  'XLS',  'PDF',  'SQLITE', 'DB3', nil);
+  MIME_EXT_TYPE: array[0 .. high(MIME_EXT) - 1] of TMimeType = (
+    mtPng,  mtGif,  mtTiff,  mtJpg,  mtBmp,  mtDoc,  mtHtml, mtCss,
+    mtJson, mtXIcon, mtFont, mtText, mtSvg,  mtXml,  mtXml,  mtXml,
+    mtWebp, mtManifest, mtManifest,  mtXml,  mtJS,   mtJS,   mtFont, mtOgg,
+    mtOgg,  mtMp4,  mtMp2,   mtMp2,  mtMpeg, mtH264, mtText, mtText,
+    mtGzip, mtWebm, mtWebm,  mtRar,  mt7z,   mtBz2,  mtWma,  mtWmv,
+    mtAvi,  mtPpt,  mtXls,  mtPdf,   mtSQlite3, mtSQlite3);
+
+function GetMimeTypeFromExt(const Ext: RawUtf8): TMimeType;
+var
+  i: PtrInt;
+begin
+  result := mtUnknown;
+  case length(Ext) of
+    0: ;
+    1: // IdemPPChar() requires 2 chars len minimum
+      case ext[1] of
+        'x', 'X':
+          result := mtXcomp;
+      end;
+  else
+    begin
+      i := IdemPPChar(pointer(Ext), @MIME_EXT);
+      if i >= 0 then
+        result := MIME_EXT_TYPE[i]
+    end;
+  end;
+end;
+
+function GetMimeContentTypeFromExt(const FileName: TFileName; FileExt: PRawUtf8): TMimeType;
+var
+  ext: RawUtf8;
+begin
+  StringToUtf8(ExtractExt(FileName, {withoutdot=}true), ext);
+  result := GetMimeTypeFromExt(ext);
+  if FileExt <> nil then
+    FileExt^ := {%H-}ext;
+end;
+
+function GetMimeContentType(Content: Pointer; Len: PtrInt; const FileName: TFileName;
+  const DefaultContentType: RawUtf8; Mime: PMimeType): RawUtf8;
+var
+  ext: RawUtf8;
+  m: TMimeType;
+begin
+  if FileName <> '' then
+  begin
+    // file extension is more precise -> check first
+    m := GetMimeContentTypeFromExt(FileName, @ext);
+    if m <> mtUnknown then
+    begin
+      result := MIME_TYPE[m];
+      if Mime <> nil then
+        Mime^ := m;
+      exit;
+    end;
+    // fallback to content check
+    if (ext <> '') and
+       (ext[1] in ['a'..'z']) then
+      // e.g. 'application/zip' or 'application/pdf'
+      result := 'application/' + LowerCase(ext)
+    else
+      result := DefaultContentType;
+  end
+  else
+    result := DefaultContentType;
+  result := GetMimeContentTypeFromBuffer(Content, Len, result, Mime);
+end;
+
+function GetMimeContentTypeHeader(const Content: RawByteString;
+  const FileName: TFileName; Mime: PMimeType): RawUtf8;
+begin
+  result := HEADER_CONTENT_TYPE + GetMimeContentType(
+      Pointer(Content), length(Content), FileName, BINARY_CONTENT_TYPE, Mime);
+end;
+
+const
+  MIME_COMPRESSED: array[0..38] of cardinal = ( // may use SSE2
+    $04034b50, // 'application/zip' = 50 4B 03 04
+    $474e5089, // 'image/png' = 89 50 4E 47 0D 0A 1A 0A
+    $e0ffd8ff, $e1ffd8ff, // 'image/jpeg' FF D8 FF E0/E1
+    $002a4949, $2a004d4d, $2b004d4d, // 'image/tiff'
+    $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
+    $4d5a4cff, // LZMA = FF 4C 5A 4D 41 00
+    $72613c21, // .ar/.deb package file = '!' (assuming compressed)
+    $75b22630, // 'audio/x-ms-wma' = 30 26 B2 75 8E 66
+    $766f6f6d, // mov = 6D 6F 6F 76 [....moov]
+    $89a8275f, // jar = 5F 27 A8 89
+    $9ac6cdd7, // 'video/x-ms-wmv' = D7 CD C6 9A 00 00
+    $a5a5a5a5, // mORMot 1 .mab file
+    $a5a5a55a, // .mab file = MAGIC_MAB in mormot.core.log.pas
+    $a5aba5a5, // .data = TRESTSTORAGEINMEMORY_MAGIC in mormot.orm.server.pas
+    LOG_MAGIC, // .log.synlz/.log.synliz compression = $aba51051
+    $aba5a5ab, $aba5a5ab + 1, $aba5a5ab + 2, $aba5a5ab + 3, $aba5a5ab + 4,
+    $aba5a5ab + 5, $aba5a5ab + 6, $aba5a5ab + 7, // .dbsynlz = SQLITE3_MAGIC
+    $afbc7a37, // 'application/x-7z-compressed' = 37 7A BC AF 27 1C
+    $b7010000, $ba010000, // mpeg = 00 00 01 Bx
+    $cececece, // jceks = CE CE CE CE
+    $dbeeabed, // .rpm package file
+    $e011cfd0); // msi = D0 CF 11 E0 A1 B1 1A E1
+
+function IsContentCompressed(Content: Pointer; Len: PtrInt): boolean;
+begin
+  // see http://www.garykessler.net/library/file_sigs.html
+  result := false;
+  if (Content <> nil) and
+     (Len > 8) then
+    if IntegerScanExists(@MIME_COMPRESSED, length(MIME_COMPRESSED), PCardinal(Content)^) then
+      result := true
+    else
+      case PCardinal(Content)^ and $00ffffff of // 24-bit magic
+        $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 // ignore variable 4 byte offset
+          $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;
+
+function GetJpegSize(jpeg: PAnsiChar; len: PtrInt;
+  out Height, Width, Bits: 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 - 8;
+  inc(jpeg, 2);
+  while jpeg < je do
+  begin
+    if jpeg^ <> #$ff then
+      exit;
+    inc(jpeg);
+    case ord(jpeg^) of
+      $c0..$c3, $c5..$c7, $c9..$cb, $cd..$cf: // SOF
+        begin
+          Height := swap(PWord(jpeg + 4)^);
+          Width  := swap(PWord(jpeg + 6)^);
+          Bits   := PByte(jpeg + 8)^ * 8;
+          result := (Height > 0) and
+                    (Height < 20000) and
+                    (Width > 0) and
+                    (Width < 20000);
+          exit;
+        end;
+      $d0..$d8, $01: // RST, SOI
+        inc(jpeg);
+      $d9: // EOI
+        break;
+      $ff: // padding
+        ;
+    else
+      inc(jpeg, swap(PWord(jpeg + 1)^) + 1);
+    end;
+  end;
+end;
+
+
+{ ************* Text Memory Buffers and Files }
+
+{ 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: PtrInt;
+  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: TStream;
+begin
+  FS := TFileStreamEx.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 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 TMemoryMapText.LineSizeSmallerThan(aIndex, aMinimalCount: integer): boolean;
+begin
+  result := GetLineSizeSmallerThan(fLines[aIndex], fMapEnd, aMinimalCount);
+end;
+
+procedure TMemoryMapText.ProcessOneLine(LineBeg, LineEnd: PUtf8Char);
+begin
+  if fCount = fLinesMax then
+  begin
+    fLinesMax := NextGrow(fLinesMax);
+    ReallocMem(fLines, fLinesMax * SizeOf(pointer));
+  end;
+  fLines[fCount] := LineBeg;
+  inc(fCount);
+end;
+
+procedure ParseLines(P, PEnd: PUtf8Char; Map: TMemoryMapText);
+var
+  PBeg: PUtf8Char;
+begin
+  // generated asm is much better with a local proc
+  if P < PEnd then
+  repeat
+    PBeg := P;
+    {$ifdef CPUX64}
+    inc(P, BufferLineLength(P, PEnd)); // use branchless SSE2 on x86_64
+    {$else}
+    while (P < PEnd) and
+          (P^ <> #13) and
+          (P^ <> #10) do
+      inc(P);
+    {$endif CPUX64}
+    Map.ProcessOneLine(PBeg, P);
+    if P + 1 < PEnd then
+      if PWord(P)^ = 13 + 10 shl 8 then
+      begin
+        inc(P, 2); // ignore #13#10
+        if P < PEnd then
+          continue;
+      end
+      else
+      begin
+        inc(P);    // ignore #13 or #10
+        if P < PEnd then
+          continue;
+      end;
+    break;
+  until false;
+end;
+
+procedure TMemoryMapText.LoadFromMap(AverageLineLength: integer = 32);
+var
+  P: PUtf8Char;
+begin
+  if fMap.Buffer = nil then
+    exit;
+  fLinesMax := fMap.FileSize div AverageLineLength + 8;
+  GetMem(fLines, fLinesMax * SizeOf(pointer));
+  P := pointer(fMap.Buffer);
+  fMapEnd := P + fMap.Size;
+  if (PWord(P)^ = $BBEF) and
+     (P[2] = #$BF) then
+    inc(P, 3); // ignore UTF-8 BOM
+  ParseLines(P, fMapEnd, self);
+  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;
+
+procedure AppendCharOnceToRawUtf8(var Text: RawUtf8; Ch: AnsiChar);
+var
+  L: PtrInt;
+begin
+  L := length(Text);
+  if (L <> 0) and
+     (Text[L] = Ch) then
+    exit;
+  SetLength(Text, L + 1);
+  PByteArray(Text)[L] := ord(Ch);
+end;
+
+procedure AppendBuffersToRawUtf8(var Text: RawUtf8; const Buffers: array of PUtf8Char);
+var
+  i, len, TextLen: PtrInt;
+  lens: array[0..63] of integer;
+  P: PUtf8Char;
+begin
+  if high(Buffers) > high(lens) then
+    raise EBufferException.Create('Too many params in AppendBuffersToRawUtf8()');
+  len := 0;
+  for i := 0 to high(Buffers) do
+  begin
+    lens[i] := StrLen(Buffers[i]);
+    inc(len, lens[i]);
+  end;
+  TextLen := Length(Text);
+  SetLength(Text, TextLen + len);
+  P := pointer(Text);
+  inc(P, TextLen);
+  for i := 0 to high(Buffers) do
+    if Buffers[i] <> nil then
+    begin
+      MoveFast(Buffers[i]^, P^, {%H-}lens[i]);
+      inc(P, lens[i]);
+    end;
+end;
+
+function AppendRawUtf8ToBuffer(Buffer: PUtf8Char; const Text: RawUtf8): PUtf8Char;
+var
+  L: PtrInt;
+begin
+  L := length(Text);
+  if L <> 0 then
+  begin
+    MoveFast(Pointer(Text)^, Buffer^, L);
+    inc(Buffer, L);
+  end;
+  result := Buffer;
+end;
+
+function Append999ToBuffer(Buffer: PUtf8Char; Value: PtrUInt): PUtf8Char;
+var
+  L: PtrInt;
+  P: PAnsiChar;
+begin
+  P := pointer(SmallUInt32Utf8[Value]);
+  L := PStrLen(P - _STRLEN)^;
+  MoveByOne(P, Buffer, L);
+  result := Buffer + L;
+end;
+
+function AppendBufferToBuffer(Buffer: PUtf8Char; Text: pointer; Len: PtrInt): PUtf8Char;
+begin
+  MoveFast(Text^, Buffer^, Len);
+  result := Buffer + Len;
+end;
+
+function AppendUInt32ToBuffer(Buffer: PUtf8Char; Value: PtrUInt): PUtf8Char;
+var
+  L: PtrInt;
+  P: PAnsiChar;
+  tmp: array[0..23] of AnsiChar;
+begin
+  {$ifndef ASMINTEL} // our StrUInt32 asm has less CPU cache pollution
+  if Value <= high(SmallUInt32Utf8) then
+  begin
+    P := pointer(SmallUInt32Utf8[Value]);
+    L := PStrLen(P - _STRLEN)^;
+    MoveByOne(P, Buffer, L);
+  end
+  else
+  {$endif ASMINTEL}
+  begin
+    P := StrUInt32(@tmp[23], Value);
+    L := @tmp[23] - P;
+    MoveFast(P^, Buffer^, L);
+  end;
+  result := Buffer + L;
+end;
+
+function Plural(const itemname: ShortString; itemcount: cardinal): ShortString;
+var
+  len, L: PtrInt;
+begin
+  len := (AppendUInt32ToBuffer(@result[1], itemcount) - PUtf8Char(@result[1])) + 1;
+  result[len] := ' ';
+  L := ord(itemname[0]);
+  if (L > 0) and
+     (L <= 240) then
+  begin
+    // avoid buffer overflow
+    MoveFast(itemname[1], result[len + 1], L);
+    inc(len, L);
+    if itemcount > 1 then
+    begin
+      inc(len);
+      result[len] := 's';
+    end;
+  end;
+  result[0] := AnsiChar(len);
+end;
+
+function EscapeBuffer(s: PAnsiChar; slen: integer;
+  d: PAnsiChar; dmax: integer): PAnsiChar;
+var
+  c: AnsiChar;
+  tab: PWordArray;
+begin
+  if (slen > 0) and
+     (dmax > 7) then
+  begin
+    tab := @TwoDigitsHexWBLower;
+    repeat
+      c := s^;
+      inc(s);
+      if (c >= ' ') and
+         (c <= #126) then
+      begin
+        d^ := c;
+        inc(d);
+        dec(dmax);
+      end
+      else
+      begin
+        d^ := '$';
+        inc(d);
+        PWord(d)^ := tab[ord(c)];
+        inc(d, 2);
+        dec(dmax, 3);
+      end;
+      if dmax <= 7 then // mark truncated
+      begin
+        PCardinal(d)^ := ord('.') + ord('.') shl 8 + ord('.') shl 16;
+        inc(d, 3);
+        break;
+      end;
+      dec(slen);
+    until slen = 0;
+  end;
+  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, sourcelen, @temp[1], SizeOf(temp) - 1);
+  end
+  else
+    temp[0] := #0;
+  result := @temp;
+end;
+
+function LogEscapeFull(const source: RawByteString): RawUtf8;
+begin
+  result := LogEscapeFull(pointer(source), length(source));
+end;
+
+function LogEscapeFull(source: PAnsiChar; sourcelen: integer): RawUtf8;
+begin
+  FastSetString(result{%H-}, sourcelen * 3); // worse case
+  if sourcelen <> 0 then
+    FakeLength(result, pointer(EscapeBuffer(
+      pointer(result), sourcelen, pointer(result), sourcelen * 3)));
+end;
+
+function EscapeToShort(source: PAnsiChar; sourcelen: integer): ShortString;
+begin
+  result[0] := AnsiChar(
+    EscapeBuffer(source, sourcelen, @result[1], 255) - @result[1]);
+end;
+
+function EscapeToShort(const source: RawByteString): ShortString;
+begin
+  result[0] := AnsiChar(
+    EscapeBuffer(pointer(source), length(source), @result[1], 255) - @result[1]);
+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;
+
+function BinToSource(const ConstName, Comment: RawUtf8;
+  const Data: RawByteString; PerLine: integer; const Suffix: RawUtf8): RawUtf8;
+begin
+  result := BinToSource(ConstName, Comment, pointer(Data), length(Data), PerLine, Suffix);
+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.AddShorter('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.AddShorter(#13#10'   ');
+    for i := 1 to line do
+    begin
+      Dest.Add(' ', '$');
+      Dest.AddByteToHexLower(P^);
+      inc(P);
+      Dest.AddComma;
+    end;
+    dec(Len,line);
+  until Len = 0;
+  Dest.CancelLastComma;
+  Dest.Add(');'#13#10'  %_LEN = SizeOf(%);'#13#10, [ConstName, ConstName]);
+end;
+
+function BinToHumanHex(Data: PByte; Len, PerLine, LeftTab: integer;
+  SepChar: AnsiChar): RawUtf8;
+var
+  w: TTextWriter;
+  temp: TTextWriterStackBuffer;
+begin
+  w := TTextWriter.CreateOwnedStream(temp);
+  try
+    BinToHumanHex(w, Data, Len, PerLine, LeftTab, SepChar);
+    w.SetText(result);
+  finally
+    w.Free;
+  end;
+end;
+
+procedure BinToHumanHex(W: TTextWriter; Data: PByte;
+  Len, PerLine, LeftTab: integer; SepChar: AnsiChar);
+var
+  n: integer;
+begin
+  if Data <> nil then
+    while Len > 0 do
+    begin
+      W.AddChars(' ', LeftTab);
+      n := PerLine;
+      repeat
+        W.AddByteToHexLower(Data^);
+        inc(Data);
+        W.Add(SepChar);
+        dec(Len);
+        if Len = 0 then
+          break;
+        dec(n);
+      until n = 0;
+      W.CancelLastChar;
+      W.AddCR;
+    end;
+end;
+
+
+{ *************************** TStreamRedirect and other Hash process }
+
+{ TProgressInfo }
+
+procedure TProgressInfo.Init;
+begin
+  Finalize(Context);
+  FillCharFast(self, SizeOf(self), 0); // warning: would overlap custom options
+  StartTix := GetTickCount64;
+  ReportDelay := 1000; // DoReport() will notify every second
+end;
+
+procedure TProgressInfo.DoStart(
+  Sender: TObject; SizeExpected: Int64; const Ident: string);
+begin
+  CurrentSize := 0; // no Init because would overlap customized options
+  ProcessedSize := 0;
+  ExpectedSize := SizeExpected;
+  ExpectedWrittenSize := SizeExpected;
+  StringToUtf8(Ident, Context);
+  StartTix := GetTickCount64;
+  ReportTix := 0;
+  Elapsed := 0;
+  DoReport(Sender, {computeelapsed=}false);
+end;
+
+procedure TProgressInfo.DoAfter(Sender: TObject; ChunkSize: Int64);
+begin
+  inc(CurrentSize, ChunkSize);
+  inc(ProcessedSize, ChunkSize);
+  DoReport(Sender, {computeelapsed=}true);
+end;
+
+procedure TProgressInfo.SetExpectedSize(SizeExpected, Position: Int64);
+begin
+  ExpectedSize := SizeExpected;
+  ExpectedWrittenSize := SizeExpected - Position;
+end;
+
+function TProgressInfo.DoReport(Sender: TObject; ReComputeElapsed: boolean): boolean;
+begin
+  if ReComputeElapsed then
+    Elapsed := GetTickCount64 - StartTix; // may have changed in-between
+  if (CurrentSize <> ExpectedSize) and
+     (Elapsed < ReportTix) then
+  begin
+    result := false; // nothing to report yet
+    exit;
+  end;
+  LastProgress := '';
+  ReportTix := Elapsed + ReportDelay; // notify once per second or when finished
+  if ExpectedSize = 0 then
+    Percent := 0
+  else if CurrentSize >= ExpectedSize then
+  begin
+    Percent := 100;
+    Remaining := 0;
+  end
+  else
+  begin
+    if (Elapsed <> 0) and
+       (ProcessedSize <> 0) then
+      Remaining :=
+        (Elapsed * (ExpectedWrittenSize - ProcessedSize)) div ProcessedSize;
+    Percent := (CurrentSize * 100) div ExpectedSize;
+  end;
+  if Elapsed = 0 then
+    PerSecond := 0
+  else
+    PerSecond := (ProcessedSize * 1000) div Elapsed;
+  if Assigned(OnLog) then
+    OnLog(sllTrace, '%', [GetProgress], Sender);
+  if Assigned(OnProgress) then
+    OnProgress(Sender, @self);
+  result := true;
+end;
+
+function TProgressInfo.GetProgress: RawUtf8;
+var
+  ctx, remain: ShortString;
+  persec, expect, curr: TShort16;
+begin
+  result := LastProgress;
+  if result <> '' then
+    exit;
+  Ansi7StringToShortString(Context, ctx);
+  if ctx[0] > #30 then
+  begin
+    ctx[0] := #33; // truncate to keep information on a single line
+    PCardinal(@ctx[30])^ := ord('.') + ord('.') shl 8 + ord('.') shl 16;
+  end;
+  persec := '';
+  if PerSecond <> 0 then
+    FormatShort16(' %/s', [KBNoSpace(PerSecond)], persec);
+  KB(CurrentSize, curr, {nospace=}true);
+  if ExpectedSize = 0 then
+    // size may not be known (e.g. server-side chunking)
+    FormatUtf8('% % read% ...', [ctx, curr, persec], result)
+  else
+  begin
+    KB(ExpectedSize, expect, {nospace=}true);
+    if CurrentSize < ExpectedSize then
+    begin
+      // we can state the current progression ratio
+      remain := '';
+      if Remaining > 0 then
+        FormatShort(' remaining:%', [MilliSecToString(Remaining)], remain);
+      FormatUtf8('% %% %/%%%',
+        [ctx, Percent, '%', curr, expect, persec, remain], result)
+    end
+    else
+      // process is finished
+      if (Elapsed = 0) or
+         (PerSecond = 0) then
+        FormatUtf8('% % done' + CRLF, [Context, expect], result)
+      else
+        FormatUtf8('% % done in % (% )' + CRLF,
+          [Context, expect, MilliSecToString(Elapsed), persec], result);
+  end;
+  LastProgress := result;
+end;
+
+
+{ TStreamRedirect }
+
+constructor TStreamRedirect.Create(aRedirected: TStream; aRead: boolean);
+begin
+  fInfo.Init;
+  fRedirected := aRedirected;
+  if aRead and
+     Assigned(aRedirected) then
+    SetExpectedSize(aRedirected.Size); // needed e.g. to upload a file
+end;
+
+destructor TStreamRedirect.Destroy;
+begin
+  fRedirected.Free;
+  inherited Destroy;
+end;
+
+function TStreamRedirect.GetProgress: RawUtf8;
+begin
+  if (self = nil) or
+     fTerminated then
+    result := ''
+  else
+    result := fInfo.GetProgress;
+end;
+
+function TStreamRedirect.GetSize: Int64;
+begin
+  if (fMode <> mWrite) and
+     (fInfo.ExpectedSize <> 0) then
+    result := fInfo.ExpectedSize
+  else
+    result := fInfo.CurrentSize;
+end;
+
+procedure TStreamRedirect.SetSize(NewSize: Longint);
+begin
+  raise EStreamRedirect.CreateUtf8('%.Size is read/only', [self]);
+end;
+
+procedure TStreamRedirect.SetSize(const NewSize: Int64);
+begin
+  raise EStreamRedirect.CreateUtf8('%.Size is read/only', [self]);
+end;
+
+class procedure TStreamRedirect.ProgressStreamToConsole(Sender: TStreamRedirect);
+begin
+  if (Sender <> nil) and
+     Sender.InheritsFrom(TStreamRedirect) then
+    ProgressInfoToConsole(Sender, @Sender.fInfo);
+end;
+
+{$I-}
+class procedure TStreamRedirect.ProgressInfoToConsole(
+  Sender: TObject; Info: PProgressInfo);
+var
+  eraseline: ShortString;
+  msg: RawUtf8;
+begin
+  eraseline[0] := AnsiChar(Info.ConsoleLen + 2);
+  eraseline[1] := #13;
+  FillCharFast(eraseline[2], ord(eraseline[0]) - 2, 32);
+  eraseline[ord(eraseline[0])] := #13;
+  system.write(eraseline);
+  msg := Info.GetProgress;
+  if length(msg) > 250 then
+    FakeLength(msg, 250); // paranoid overflow check
+  Info.ConsoleLen := length(msg); // to properly erase previous line
+  system.write(msg);
+  ioresult;
+end;
+
+class procedure TStreamRedirect.NotifyEnded(
+  const OnStream: TOnStreamProgress; const OnInfo: TOnInfoProgress;
+  const Fmt: RawUtf8; const Args: array of const; Size, StartedMs: Int64);
+var
+  tmp: TStreamRedirect;
+  stop: Int64;
+begin
+  if not Assigned(OnStream) and
+     not Assigned(OnInfo) then
+    exit;
+  QueryPerformanceMicroSeconds(stop);
+  tmp := TStreamRedirect.Create(nil);
+  try
+    tmp.OnProgress := OnStream;
+    tmp.OnInfoProgress := OnInfo;
+    FormatUtf8(Fmt, Args, tmp.fInfo.Context);
+    tmp.fInfo.ProcessedSize := Size;
+    tmp.fInfo.CurrentSize := Size;
+    if StartedMs <> 0 then
+    begin
+      tmp.fInfo.Elapsed := stop - StartedMs;
+      dec(tmp.fInfo.StartTix, tmp.fInfo.Elapsed shr 10); // fake time
+    end;
+    tmp.Ended;
+  finally
+    tmp.Free;
+  end;
+end;
+
+{$I+}
+
+procedure TStreamRedirect.DoReport(ReComputeElapsed: boolean);
+begin
+  if fInfo.DoReport(self, ReComputeElapsed) then
+    // DoReport did notify OnLog + OnInfoProgress
+    if Assigned(fOnStreamProgress) then
+      fOnStreamProgress(self);
+end;
+
+procedure TStreamRedirect.DoHash(data: pointer; len: integer);
+begin // no associated hasher on this parent class
+end;
+
+procedure TStreamRedirect.SetExpectedSize(Value: Int64);
+begin
+  fInfo.SetExpectedSize(Value, fPosition);
+end;
+
+function TStreamRedirect.GetHash: RawUtf8;
+begin
+  result := ''; // no associated hasher on this parent class
+end;
+
+class function TStreamRedirect.GetHashFileExt: RawUtf8;
+begin
+  result := ''; // no associated hasher on this parent class
+end;
+
+class function TStreamRedirect.GetHashName: RawUtf8;
+begin
+  result := copy(GetHashFileExt, 2, 10);
+end;
+
+class function TStreamRedirect.HashFile(const FileName: TFileName;
+  const OnProgress: TOnStreamProgress): RawUtf8;
+var
+  hasher: TStreamRedirect;
+  f: THandle;
+begin
+  result := '';
+  if GetHashFileExt = '' then
+    exit; // no hash function defined
+  f := FileOpenSequentialRead(FileName);
+  if not ValidHandle(f) then
+    exit;
+  hasher := Create(TFileStreamFromHandle.Create(f));
+  try
+    if Assigned(OnProgress) then
+    begin
+      hasher.fInfo.ExpectedSize := FileSize(f);
+      hasher.OnProgress := OnProgress;
+    end;
+    hasher.Append;
+    result := hasher.GetHash;
+  finally
+    hasher.Free; // includes FileClose(f)
+  end;
+end;
+
+procedure TStreamRedirect.Append;
+var
+  buf: RawByteString;
+  read: PtrInt;
+begin
+  if fRedirected = nil then
+    raise EStreamRedirect.CreateUtf8('%.Append(%): Redirected=nil',
+      [self, fInfo.Context]);
+  if fMode = mRead then
+    raise EStreamRedirect.CreateUtf8('%.Append(%) after Read()',
+      [self, fInfo.Context]);
+  fMode := mWrite;
+  if GetHashFileExt = '' then // DoHash() does nothing
+  begin
+    // no hash involved: just move to the end of partial content
+    fInfo.CurrentSize := fRedirected.Seek(0, soEnd);
+    fPosition := fInfo.CurrentSize;
+  end
+  else
+  begin
+    // compute the hash of the existing partial content
+    FastNewRawByteString(buf, 1 shl 20); // 1MB temporary buffer
+    repeat
+      read := fRedirected.Read(pointer(buf)^, length(buf));
+      if read <= 0 then
+        break;
+      DoHash(pointer(buf), read);
+      inc(fInfo.CurrentSize, read);
+      inc(fPosition, read);
+      if Assigned(fOnStreamProgress) or
+         Assigned(fInfo.OnProgress) or
+         Assigned(fInfo.OnLog) then
+        if (fInfo.ExpectedSize <> 0) and
+           (fInfo.CurrentSize <> read) then
+          DoReport(true);
+    until false;
+  end;
+end;
+
+procedure TStreamRedirect.Ended;
+begin
+  if fInfo.CurrentSize = fInfo.ExpectedSize then
+    exit; // nothing to report
+  fInfo.ExpectedSize := fInfo.CurrentSize; // reached 100%
+  if Assigned(fOnStreamProgress) or
+     Assigned(fInfo.OnProgress) or
+     Assigned(fInfo.OnLog) then
+    DoReport(true); // notify finished
+end;
+
+procedure TStreamRedirect.Terminate;
+begin
+  fTerminated := true;
+end;
+
+procedure TStreamRedirect.ReadWriteHash(const Buffer; Count: integer);
+begin
+  DoHash(@Buffer, Count);
+  inc(fInfo.CurrentSize, Count);
+  inc(fInfo.ProcessedSize, Count);
+  inc(fPosition, Count);
+end;
+
+procedure TStreamRedirect.ReadWriteReport(const Caller: ShortString);
+var
+  tix, tosleep, endsleep: Int64;
+begin
+  tix := GetTickCount64;
+  fInfo.Elapsed := tix - fInfo.StartTix;
+  if (fLimitPerSecond <> 0) or
+     (fTimeOut <> 0) then
+  begin
+    if tix shr 7 <> fLastTix shr 7 then // checking every 128 ms is good enough
+    begin
+      fLastTix := tix;
+      if fInfo.Elapsed > 0 then
+      begin
+        if (fTimeOut <> 0) and
+           (fInfo.Elapsed > fTimeOut) then
+          raise EStreamRedirect.CreateUtf8('%.%(%) timeout after %',
+            [self, Caller, fInfo.Context, MilliSecToString(fInfo.Elapsed)]);
+        if fLimitPerSecond > 0 then
+        begin
+          // adjust bandwidth limit every 128 ms by adding some sleep() steps
+          tosleep := ((fInfo.ProcessedSize * 1000) div fLimitPerSecond) - fInfo.Elapsed;
+          if tosleep > 10 then // on Windows, typical resolution is 16ms
+          begin
+            if tosleep > 300 then
+            begin
+              endsleep := tix + tosleep;
+              repeat
+                SleepHiRes(300); // show progress on very low bandwidth
+                if Assigned(fOnStreamProgress) or
+                   Assigned(fInfo.OnProgress) or
+                   Assigned(fInfo.OnLog) then
+                  DoReport({ReComputeElapsed=}true);
+                tosleep := endsleep - GetTickCount64;
+              until tosleep < 300;
+            end;
+            if tosleep > 10 then
+              SleepHiRes(tosleep);
+          end;
+        end;
+      end;
+    end;
+  end;
+  if Assigned(fOnStreamProgress) or
+     Assigned(fInfo.OnProgress) or
+     Assigned(fInfo.OnLog) then
+    DoReport(false);
+  if fTerminated then
+    raise EStreamRedirect.CreateUtf8('%.%(%) Terminated',
+      [self, Caller, fInfo.Context]);
+end;
+
+function TStreamRedirect.Read(var Buffer; Count: Longint): Longint;
+begin
+  if fMode = mWrite then
+    raise EStreamRedirect.CreateUtf8('%.Read(%) in Write() mode',
+      [self, fInfo.Context]);
+  fMode := mRead;
+  if fRedirected = nil then
+    raise EStreamRedirect.CreateUtf8('%.Read(%) with Redirected=nil',
+      [self, fInfo.Context]);
+  result := fRedirected.Read(Buffer, Count);
+  ReadWriteHash(Buffer, result);
+  ReadWriteReport('Read');
+end;
+
+function TStreamRedirect.Write(const Buffer; Count: Longint): Longint;
+begin
+  if fMode = mRead then
+    raise EStreamRedirect.CreateUtf8('%.Write(%) in Read() mode',
+      [self, fInfo.Context]);
+  fMode := mWrite;
+  ReadWriteHash(Buffer, Count);
+  result := Count;
+  if fRedirected = nil then
+    exit; // we may just want the hash
+  fRedirected.WriteBuffer(Buffer, Count);
+  ReadWriteReport('Write');
+end;
+
+
+{ TStreamRedirectHasher }
+
+function TStreamRedirectHasher.GetHash: RawUtf8;
+begin
+  result := CardinalToHexLower(fHash);
+end;
+
+
+{ TStreamRedirectCrc32c }
+
+procedure TStreamRedirectCrc32c.DoHash(data: pointer; len: integer);
+begin
+  fHash := crc32c(fHash, data, len);
+end;
+
+class function TStreamRedirectCrc32c.GetHashFileExt: RawUtf8;
+begin
+  result := '.crc32c';
+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
+  inc(fWritten, Count);
+  result := Count;
+end;
+
+{$ifdef FPC}
+function TFakeWriterStream.GetPosition: Int64;
+begin
+  result := fWritten;
+end;
+{$endif FPC}
+
+function TFakeWriterStream.Seek(Offset: Longint; Origin: Word): Longint;
+begin
+  result := Seek(Offset, TSeekOrigin(Origin));
+end;
+
+function TFakeWriterStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
+begin
+  case Origin of
+    soBeginning:
+      result := Offset;
+    soEnd:
+      result := fWritten - Offset;
+    else
+      result := fWritten + Offset;
+  end;
+  if result > fWritten then
+    result := fWritten
+  else if result < 0 then
+    result := 0
+  else if result < fWritten then
+    fWritten := result;
+end;
+
+
+{ TNestedStreamReader }
+
+destructor TNestedStreamReader.Destroy;
+var
+  i: PtrInt;
+begin
+  inherited Destroy;
+  for i := 0 to length(fNested) - 1 do
+    fNested[i].Stream.Free;
+end;
+
+function TNestedStreamReader.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
+begin
+  if (Offset = 0) and
+     (Origin = soBeginning) then
+    Flush; // allow to read the file again, and set nested stream sizes
+  result := inherited Seek(Offset, Origin);
+end;
+
+function TNestedStreamReader.NewStream(Stream: TStream): TStream;
+var
+  n: PtrInt;
+begin
+  n := length(fNested);
+  SetLength(fNested, n + 1);
+  fNested[n].Stream := Stream;
+  result := Stream; // allow simple fluent calls
+end;
+
+function TNestedStreamReader.ForText: TRawByteStringStream;
+var
+  n: PtrInt;
+begin
+  n := length(fNested);
+  if n <> 0 then
+  begin
+    result := pointer(fNested[n - 1].Stream);
+    if PClass(result)^ = TRawByteStringStream then
+      exit;
+  end;
+  result := TRawByteStringStream.Create;
+  NewStream(result);
+end;
+
+procedure TNestedStreamReader.Append(const Content: RawByteString);
+begin
+  with ForText do
+    DataString := DataString + Content; // the fast and easy way
+end;
+
+procedure TNestedStreamReader.Flush;
+var
+  i, n: PtrInt;
+begin
+  fContentRead := pointer(fNested);
+  fSize := 0;
+  n := length(fNested);
+  for i := 0 to n - 1 do
+    with fNested[i] do
+    begin
+      Stream.Seek(0, soBeginning);
+      Start := fSize;
+      inc(fSize, Stream.Size); // to allow proper Seek() + Read()
+      Stop := fSize;
+    end;
+end;
+
+function TNestedStreamReader.Read(var Buffer; Count: Longint): Longint;
+var
+  s, m: ^TNestedStream;
+  P: PByte;
+  rd: PtrInt;
+begin
+  result := 0;
+  s := pointer(fContentRead);
+  if s = nil then
+    exit; // Flush was not called
+  P := @Buffer;
+  m := @fNested[length(fNested)];
+  while (Count > 0) and
+        (fPosition < fSize) do
+  begin
+    if (PtrUInt(s) >= PtrUInt(m)) or
+       (fPosition >= s^.Stop) or
+       (fPosition < s^.Start) then
+    begin
+      inc(s); // optimize forward reading (most common case)
+      if (PtrUInt(s) >= PtrUInt(m)) or
+         (fPosition >= s^.Stop) or
+         (fPosition < s^.Start) then
+      begin
+        // handle random Seek() call - brute force is enough (seldom used)
+        s := pointer(fNested);
+        repeat
+          if fPosition >= s^.Start then
+            break;
+          inc(s);
+        until PtrUInt(s) >= PtrUInt(m);
+        if PtrUInt(s) >= PtrUInt(m) then
+          break; // paranoid (we know fPosition < fSize)
+      end;
+    end;
+    rd := s^.Stream.Read(P^, Count);
+    if rd <= 0 then
+    begin
+      // read from next section(s) until we got Count bytes
+      inc(s);
+      if PtrUInt(s) >= PtrUInt(m) then
+        break;
+      continue;
+    end;
+    dec(Count, rd);
+    inc(P, rd);
+    inc(fPosition, rd);
+    inc(result, rd);
+  end;
+  fContentRead := pointer(s);
+end;
+
+function TNestedStreamReader.Write(const Buffer; Count: Longint): Longint;
+begin
+  result := RaiseStreamError(self, 'Write');
+end;
+
+
+{ TBufferedStreamReader }
+
+constructor TBufferedStreamReader.Create(aSource: TStream; aBufSize: integer);
+begin
+  FastNewRawByteString(fBuffer, aBufSize);
+  fSource := aSource;
+  fSize := fSource.Size; // get it once
+  fSource.Seek(0, soBeginning);
+end;
+
+constructor TBufferedStreamReader.Create(const aSourceFileName: TFileName;
+  aBufSize: integer);
+begin
+  Create(TFileStreamEx.Create(aSourceFileName, fmOpenReadShared));
+  fOwnStream := fSource;
+end;
+
+destructor TBufferedStreamReader.Destroy;
+begin
+  inherited Destroy;
+  fOwnStream.Free;
+end;
+
+function TBufferedStreamReader.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
+var
+  prev: Int64;
+begin
+  prev := fPosition;
+  result := inherited Seek(Offset, Origin);
+  if prev <> result then
+  begin
+    fSource.Seek(result, soBeginning);
+    fBufferLeft := 0; // deprecate buffer content
+  end;
+end;
+
+function TBufferedStreamReader.Read(var Buffer; Count: Longint): Longint;
+var
+  dest: PAnsiChar;
+  avail: integer;
+begin
+  result := 0;
+  if Count <= 0 then
+    exit;
+  if fPosition + Count > fSize then
+    Count := fSize - fPosition;
+  dest := @Buffer;
+  while Count <> 0 do
+  begin
+    avail := fBufferLeft;
+    if avail > Count then
+      avail := Count;
+    if avail <> 0 then
+    begin
+      MoveFast(fBufferPos^, dest^, avail);
+      inc(fBufferPos, avail);
+      dec(fBufferLeft, avail);
+      inc(result, avail);
+      dec(Count, avail);
+      if Count = 0 then
+        break;
+      inc(dest, avail);
+    end;
+    if Count > length(fBuffer) then
+    begin // big requests would read directly from stream
+      inc(result, fSource.Read(dest^, Count));
+      break;
+    end;
+    fBufferPos := pointer(fBuffer); // fill buffer and retry
+    fBufferLeft := fSource.Read(fBufferPos^, length(fBuffer));
+    if fBufferLeft <= 0 then
+      break;
+  end;
+  inc(fPosition, result);
+end;
+
+function TBufferedStreamReader.Write(const Buffer; Count: Longint): Longint;
+begin
+  result := RaiseStreamError(self, 'Write');
+end;
+
+
+
+function HashFile(const FileName: TFileName; Hasher: THasher): cardinal;
+var
+  buf: array[word] of cardinal; // 256KB of buffer
+  read: integer;
+  f: THandle;
+begin
+  if not Assigned(Hasher) then
+    Hasher := DefaultHasher;
+  result := 0;
+  f := FileOpenSequentialRead(FileName);
+  if ValidHandle(f) then
+  begin
+    repeat
+      read := FileRead(f, buf, SizeOf(buf));
+      if read <= 0 then
+        break;
+      result := Hasher(result, @buf, read);
+    until false;
+    FileClose(f);
+  end;
+end;
+
+function SameFileContent(const One, Another: TFileName): boolean;
+var
+  b1, b2: array[word] of word; // 2 * 128KB of buffers
+  r1, r2: integer;
+  f1, f2: THandle;
+begin
+  f1 := FileOpenSequentialRead(One);
+  f2 := FileOpenSequentialRead(Another);
+  result := false;
+  if ValidHandle(f1) and
+     ValidHandle(f2) and
+     (FileSize(f1) = FileSize(f2)) then
+    repeat
+      r1 := FileRead(f1, b1, SizeOf(b1));
+      r2 := FileRead(f2, b2, SizeOf(b2));
+      if (r1 <= 0) or (r2 <= 0) then
+      begin
+        result := (r1 <= 0) = (r2 <= 0);
+        break;
+      end;
+    until (r1 <> r2) or
+          not CompareMem(@b1, @b2, r1);
+  if ValidHandle(f2) then
+    FileClose(f2);
+  if ValidHandle(f1) then
+    FileClose(f1);
+end;
+
+
+function HashFileCrc32c(const FileName: TFileName): RawUtf8;
+begin
+  result := CardinalToHexLower(HashFile(FileName, crc32c));
+end;
+
+function GetStreamBuffer(S: TStream): pointer;
+begin
+  if S.InheritsFrom(TRawByteStringStream) then
+    result := pointer(TRawByteStringStream(S).DataString)
+  else if S.InheritsFrom(TCustomMemoryStream) then
+    result := TCustomMemoryStream(S).Memory
+  else
+    result := nil;
+end;
+
+function IsStreamBuffer(S: TStream): boolean;
+begin
+  result := S.InheritsFrom(TRawByteStringStream) or
+            S.InheritsFrom(TCustomMemoryStream);
+end;
+
+
+{ ************* Markup (e.g. HTML or Emoji) process }
+
+{ internal TTextWriterEscape class }
+
+type
+  TTextWriterEscapeStyle = (
+    tweBold,
+    tweItalic,
+    tweCode);
+
+  TTextWriterEscapeLineStyle = (
+    twlNone,
+    twlParagraph,
+    twlOrderedList,
+    twlUnorderedList,
+    twlBlockquote,
+    twlCode4,
+    twlCode3);
+
+  {$ifdef USERECORDWITHMETHODS}
+  TTextWriterEscape = record
+  {$else}
+  TTextWriterEscape = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    P, B, P2, B2: PUtf8Char;
+    W: TTextWriter;
+    st: set of TTextWriterEscapeStyle;
+    fmt: TTextWriterHtmlFormat;
+    esc: TTextWriterHtmlEscape;
+    lst: TTextWriterEscapeLineStyle;
+    procedure Start(dest: TTextWriter; src: PUtf8Char; escape: TTextWriterHtmlEscape);
+    function ProcessText(const stopchars: TSynByteSet): AnsiChar;
+    procedure ProcessHRef;
+    function ProcessLink: boolean;
+    procedure ProcessEmoji;
+      {$ifdef HASINLINE}inline;{$endif}
+    procedure Toggle(style: TTextWriterEscapeStyle);
+    procedure SetLine(style: TTextWriterEscapeLineStyle);
+    procedure EndOfParagraph;
+    procedure NewMarkdownLine;
+    procedure AddHtmlEscapeWiki(dest: TTextWriter; src: PUtf8Char;
+      escape: TTextWriterHtmlEscape);
+    procedure AddHtmlEscapeMarkdown(dest: TTextWriter; src: PUtf8Char;
+      escape: TTextWriterHtmlEscape);
+  end;
+
+procedure TTextWriterEscape.Start(dest: TTextWriter; src: PUtf8Char;
+  escape: TTextWriterHtmlEscape);
+begin
+  P := src;
+  W := dest;
+  st := [];
+  if heHtmlEscape in escape then
+    fmt := hfOutsideAttributes
+  else
+    fmt := hfNone;
+  esc := escape;
+  lst := twlNone;
+end;
+
+function IsHttpOrHttps(P: PUtf8Char): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+begin
+  result := (PCardinal(P)^ =
+             ord('h') + ord('t') shl 8 + ord('t') shl 16 + ord('p') shl 24) and
+            ((PCardinal(P + 4)^ and $ffffff =
+             ord(':') + ord('/') shl 8 + ord('/') shl 16) or
+             (PCardinal(P + 4)^ =
+             ord('s') + ord(':') shl 8 + ord('/') shl 16 + ord('/') shl 24));
+end;
+
+function TTextWriterEscape.ProcessText(const stopchars: TSynByteSet): AnsiChar;
+begin
+  if P = nil then
+  begin
+    result := #0;
+    exit;
+  end;
+  B := P;
+  while not (ord(P^) in stopchars) and
+        not IsHttpOrHttps(P) do
+    inc(P);
+  W.AddHtmlEscape(B, P - B, fmt);
+  result := P^;
+end;
+
+procedure TTextWriterEscape.ProcessHRef;
+begin
+  B := P;
+  while P^ > ' ' do
+    inc(P);
+  W.AddShort('');
+  W.AddHtmlEscape(B, P - B);
+  W.AddShorter('');
+end;
+
+function TTextWriterEscape.ProcessLink: boolean;
+begin
+  inc(P);
+  B2 := P;
+  while not (P^ in [#0, ']']) do
+    inc(P);
+  P2 := P;
+  if PWord(P)^ = ord(']') + ord('(') shl 8 then
+  begin
+    inc(P, 2);
+    B := P;
+    while not (P^ in [#0, ')']) do
+      inc(P);
+    if P^ = ')' then
+    begin
+      // [GitHub](https://github.com)
+      result := true;
+      exit;
+    end;
+  end;
+  P := B2; // rollback
+  result := false;
+end;
+
+procedure TTextWriterEscape.ProcessEmoji;
+begin
+  if heEmojiToUtf8 in esc then
+    EmojiParseDots(P, W)
+  else
+  begin
+    W.Add(':');
+    inc(P);
+  end;
+end;
+
+procedure TTextWriterEscape.Toggle(style: TTextWriterEscapeStyle);
+const
+  HTML: array[tweBold..tweCode] of string[7] = (
+    'strong>', 'em>', 'code>');
+begin
+  W.Add('<');
+  if style in st then
+  begin
+    W.Add('/');
+    exclude(st, style);
+  end
+  else
+    include(st, style);
+  W.AddShorter(HTML[style]);
+end;
+
+procedure TTextWriterEscape.EndOfParagraph;
+begin
+  if tweBold in st then
+    Toggle(tweBold);
+  if tweItalic in st then
+    Toggle(tweItalic);
+  if P <> nil then
+    if PWord(P)^ = $0a0d then
+      inc(P, 2)
+    else
+      inc(P);
+end;
+
+procedure TTextWriterEscape.SetLine(style: TTextWriterEscapeLineStyle);
+const
+  HTML: array[twlParagraph..twlCode3] of string[5] = (
+    'p>', 'li>', 'li>', 'p>', 'code>', 'code>');
+  HTML2: array[twlOrderedList..twlCode3] of string[11] = (
+    'ol>', 'ul>', 'blockquote>', 'pre>', 'pre>');
+begin
+  if lst >= low(HTML) then
+  begin
+    if (lst < twlCode4) or
+       (lst <> style) then
+    begin
+      W.Add('<', '/');
+      W.AddShorter(HTML[lst]);
+    end;
+    if (lst >= low(HTML2)) and
+       (lst <> style) then
+    begin
+      W.Add('<', '/');
+      W.AddShort(HTML2[lst]);
+    end;
+  end;
+  if style >= low(HTML) then
+  begin
+    if (style >= low(HTML2)) and
+       (lst <> style) then
+    begin
+      W.Add('<');
+      W.AddShort(HTML2[style]);
+    end;
+    if (style < twlCode4) or
+       (lst <> style) then
+    begin
+      W.Add('<');
+      W.AddShorter(HTML[style]);
+    end;
+  end;
+  lst := style;
+end;
+
+procedure TTextWriterEscape.NewMarkdownLine;
+label
+  none;
+var
+  c: cardinal;
+begin
+  if P = nil then
+    exit;
+  c := PCardinal(P)^;
+  if c and $ffffff = ord('`') + ord('`') shl 8 + ord('`') shl 16 then
+  begin
+    inc(P, 3);
+    if lst = twlCode3 then
+    begin
+      lst := twlCode4; // to close
+ NewMarkdownLine; + exit; + end; + SetLine(twlCode3); + end; + if lst = twlCode3 then + exit; // no prefix process within ``` code blocks + if c = $20202020 then + begin + SetLine(twlCode4); + inc(P, 4); + exit; + end; + P := GotoNextNotSpaceSameLine(P); // don't implement nested levels yet + case P^ of + '*', + '+', + '-': + if P[1] = ' ' then + SetLine(twlUnorderedList) + else + goto none; + '1'..'9': + begin + // first should be 1. then any ##. number to continue + B := P; + repeat + inc(P) + until not (P^ in ['0'..'9']); + if (P^ = '.') and + ((lst = twlOrderedList) or + (PWord(B)^ = ord('1') + ord('.') shl 8)) then + SetLine(twlOrderedList) + else + begin + P := B; +none: if lst = twlParagraph then + begin + c := PWord(P)^; // detect blank line to separate paragraphs + if c = $0a0d then + inc(P, 2) + else if c and $ff = $0a then + inc(P) + else + begin + W.AddOnce(' '); + exit; + end; + end; + SetLine(twlParagraph); + exit; + end; + end; + '>': + if P[1] = ' ' then + SetLine(twlBlockquote) + else + goto none; + else + goto none; + end; + P := GotoNextNotSpaceSameLine(P + 1); +end; + +procedure TTextWriterEscape.AddHtmlEscapeWiki(dest: TTextWriter; + src: PUtf8Char; escape: TTextWriterHtmlEscape); +begin + Start(dest, src, escape); + SetLine(twlParagraph); + repeat + case ProcessText([0, 10, 13, + ord('*'), ord('+'), ord('`'), ord('\'), ord(':')]) of + #0: + break; + #10, + #13: + begin + EndOfParagraph; + SetLine(twlParagraph); + continue; + end; + '\': + if P[1] in ['\', '`', '*', '+'] then + begin + inc(P); + W.Add(P^); + end + else + W.Add('\'); + '*': + Toggle(tweItalic); + '+': + Toggle(tweBold); + '`': + Toggle(tweCode); + 'h': + begin + ProcessHRef; + continue; + end; + ':': + begin + ProcessEmoji; + continue; + end; + end; + inc(P); + until false; + EndOfParagraph; + SetLine(twlNone); +end; + +procedure TTextWriterEscape.AddHtmlEscapeMarkdown(dest: TTextWriter; + src: PUtf8Char; escape: TTextWriterHtmlEscape); +begin + Start(dest, src, escape); + NewMarkDownLine; + repeat + if lst >= twlCode4 then // no Markdown tags within code blocks + if ProcessText([0, 10, 13]) = #0 then + break + else + begin + if PWord(P)^ = $0a0d then + inc(P, 2) + else + inc(P); + W.AddCR; // keep LF within 
+        NewMarkdownLine;
+        continue;
+      end
+    else
+      case ProcessText([0, 10, 13, ord('*'), ord('_'), ord('`'),
+                        ord('\'), ord('['), ord('!'), ord(':')]) of
+        #0:
+          break;
+        #10,
+        #13:
+          begin
+            EndOfParagraph;
+            NewMarkdownLine;
+            continue;
+          end;
+        '\':
+          if P[1] in ['\', '`', '*', '_', '[', ']', '{', '}',
+                      '(', ')', '#', '+', '-', '.', '!'] then
+          begin
+            // backslash escape
+            inc(P);
+            W.Add(P^);
+          end
+          else
+            W.Add('\');
+        '*',
+        '_':
+          if P[1] = P[0] then
+          begin
+            // **This text will be bold** or __This text will be bold__
+            inc(P);
+            Toggle(tweBold);
+          end
+          else
+            // *This text will be italic* or _This text will be italic_
+            Toggle(tweItalic);
+        '`':
+          // `This text will be code`
+          Toggle(tweCode);
+        '[':
+          if ProcessLink then
+          begin
+            // [GitHub](https://github.com)
+            W.AddShort('')
+            else
+              W.Add('"', '>');
+            W.AddHtmlEscape(B2, P2 - B2, fmt);
+            W.AddShorter(''); // no continune -> need inc(P) over ending )
+          end
+          else
+            // not a true link -> just append
+            W.Add('[');
+        '!':
+          begin
+            if P[1] = '[' then
+            begin
+              inc(P);
+              if ProcessLink then
+              begin
+                W.AddShort('');
+                W.AddHtmlEscape(B2, P2 - B2, hfWithinAttributes);
+                W.AddShorter('');
+                inc(P);
+                continue;
+              end;
+              dec(P);
+            end;
+            W.Add('!'); // not a true image
+          end;
+        'h':
+          begin
+            ProcessHRef;
+            continue;
+          end;
+        ':':
+          begin
+            ProcessEmoji;
+            continue;
+          end;
+      end;
+    inc(P);
+  until false;
+  EndOfParagraph;
+  SetLine(twlNone);
+end;
+
+function HtmlEscapeWiki(const wiki: RawUtf8; esc: TTextWriterHtmlEscape): RawUtf8;
+var
+  temp: TTextWriterStackBuffer;
+  W: TTextWriter;
+begin
+  W := TTextWriter.CreateOwnedStream(temp);
+  try
+    AddHtmlEscapeWiki(W, pointer(wiki), esc);
+    W.SetText(result);
+  finally
+    W.Free;
+  end;
+end;
+
+function HtmlEscapeMarkdown(const md: RawUtf8; esc: TTextWriterHtmlEscape): RawUtf8;
+var
+  temp: TTextWriterStackBuffer;
+  W: TTextWriter;
+begin
+  W := TTextWriter.CreateOwnedStream(temp);
+  try
+    AddHtmlEscapeMarkdown(W, pointer(md), esc);
+    W.SetText(result);
+  finally
+    W.Free;
+  end;
+end;
+
+procedure AddHtmlEscapeWiki(W: TTextWriter; P: PUtf8Char; esc: TTextWriterHtmlEscape);
+var
+  doesc: TTextWriterEscape;
+begin
+  doesc.AddHtmlEscapeWiki(W, P, esc);
+end;
+
+procedure AddHtmlEscapeMarkdown(W: TTextWriter; P: PUtf8Char; esc: TTextWriterHtmlEscape);
+var
+  doesc: TTextWriterEscape;
+begin
+  doesc.AddHtmlEscapeMarkdown(W, P, esc);
+end;
+
+function EmojiFromText(P: PUtf8Char; len: PtrInt): TEmoji;
+begin
+  // RTTI has shortstrings in adjacent L1 cache lines -> faster than EMOJI_TEXT[]
+  result := TEmoji(FindShortStringListTrimLowerCase(
+                     EMOJI_RTTI, ord(high(TEmoji)) - 1, P, len) + 1);
+  // note: we may enhance performance by using FastFindPUtf8CharSorted()
+end;
+
+function EmojiParseDots(var P: PUtf8Char; W: TTextWriter): TEmoji;
+var
+  c: PUtf8Char;
+begin
+  result := eNone;
+  inc(P); // ignore trailing ':'
+  c := P;
+  if c[-2] <= ' ' then
+  begin
+    if (c[1] <= ' ') and
+       (c^ in ['('..'|']) then
+      result := EMOJI_AFTERDOTS[c^]; // e.g. :)
+    if result = eNone then
+    begin
+      while c^ in ['a'..'z', 'A'..'Z', '_'] do
+        inc(c);
+      if (c^ = ':') and
+         (c[1] <= ' ') then // try e.g. :joy_cat:
+        result := EmojiFromText(P, c - P);
+    end;
+    if result <> eNone then
+    begin
+      P := c + 1; // continue parsing after the Emoji text
+      if W <> nil then
+        W.AddShort(pointer(EMOJI_UTF8[result]), 4);
+      exit;
+    end;
+  end;
+  if W <> nil then
+    W.Add(':');
+end;
+
+procedure EmojiToDots(P: PUtf8Char; W: TTextWriter);
+var
+  B: PUtf8Char;
+  c: cardinal;
+begin
+  if (P <> nil) and
+     (W <> nil) then
+    repeat
+      B := P;
+      while (P^ <> #0) and
+            (PWord(P)^ <> $9ff0) do
+        inc(P);
+      W.AddNoJsonEscape(B, P - B);
+      if P^ = #0 then
+        break;
+      B := P;
+      c := NextUtf8Ucs4(P) - $1f5ff;
+      if c <= cardinal(high(TEmoji)) then
+        W.AddNoJsonEscapeUtf8(EMOJI_TAG[TEmoji(c)])
+      else
+        W.AddNoJsonEscape(B, P - B);
+    until P^ = #0;
+end;
+
+function EmojiToDots(const text: RawUtf8): RawUtf8;
+var
+  W: TTextWriter;
+  tmp: TTextWriterStackBuffer;
+begin
+  if PosExChar(#$f0, text) = 0 then
+  begin
+    result := text; // no UTF-8 smiley for sure
+    exit;
+  end;
+  W := TTextWriter.CreateOwnedStream(tmp);
+  try
+    EmojiToDots(pointer(text), W);
+    W.SetText(result);
+  finally
+    W.Free;
+  end;
+end;
+
+procedure EmojiFromDots(P: PUtf8Char; W: TTextWriter);
+var
+  B: PUtf8Char;
+begin
+  if (P <> nil) and
+     (W <> nil) then
+    repeat
+      B := P;
+      while not (P^ in [#0, ':']) do
+        inc(P);
+      W.AddNoJsonEscape(B, P - B);
+      if P^ = #0 then
+        break;
+      EmojiParseDots(P, W);
+    until P^ = #0;
+end;
+
+function EmojiFromDots(const text: RawUtf8): RawUtf8;
+var
+  W: TTextWriter;
+  tmp: TTextWriterStackBuffer;
+begin
+  W := TTextWriter.CreateOwnedStream(tmp);
+  try
+    EmojiFromDots(pointer(text), W);
+    W.SetText(result);
+  finally
+    W.Free;
+  end;
+end;
+
+
+{ ************ RawByteString Buffers Aggregation via TRawByteStringGroup }
+
+{ TRawByteStringGroup }
+
+procedure TRawByteStringGroup.Add(const aItem: RawByteString);
+begin
+  if Values = nil then
+    Clear; // ensure all fields are initialized, even if on stack
+  if Count = Length(Values) then
+    SetLength(Values, NextGrow(Count));
+  with Values[Count] do
+  begin
+    Position := self.Position;
+    Value := aItem;
+  end;
+  LastFind := Count;
+  inc(Count);
+  inc(Position, Length(aItem));
+end;
+
+procedure TRawByteStringGroup.Add(aItem: pointer; aItemLen: integer);
+var
+  tmp: RawByteString;
+begin
+  FastSetRawByteString(tmp, aItem, aItemLen);
+  Add(tmp);
+end;
+
+procedure TRawByteStringGroup.Add(const aAnother: TRawByteStringGroup);
+var
+  i: integer;
+  s, d: PRawByteStringGroupValue;
+begin
+  if aAnother.Values = nil then
+    exit;
+  if Values = nil then
+    Clear; // ensure all fields are initialized, even if on stack
+  if Count + aAnother.Count > Length(Values) then
+    SetLength(Values, Count + aAnother.Count);
+  s := pointer(aAnother.Values);
+  d := @Values[Count];
+  for i := 1 to aAnother.Count do
+  begin
+    d^.Position := Position;
+    d^.Value := s^.Value;
+    inc(Position, length(s^.Value));
+    inc(s);
+    inc(d);
+  end;
+  inc(Count, aAnother.Count);
+  LastFind := Count - 1;
+end;
+
+procedure TRawByteStringGroup.RemoveLastAdd;
+begin
+  if Count > 0 then
+  begin
+    dec(Count);
+    dec(Position, Length(Values[Count].Value));
+    Values[Count].Value := ''; // release memory
+    LastFind := Count - 1;
+  end;
+end;
+
+function TRawByteStringGroup.Equals(const aAnother: TRawByteStringGroup): boolean;
+begin
+  if ((Values = nil) and
+      (aAnother.Values <> nil)) or
+     ((Values <> nil) and
+      (aAnother.Values = nil)) or
+     (Position <> aAnother.Position) then
+    result := false
+  else if (Count <> 1) or
+          (aAnother.Count <> 1) or
+          (Values[0].Value <> aAnother.Values[0].Value) then
+    result := AsText = aAnother.AsText
+  else
+    result := true;
+end;
+
+procedure TRawByteStringGroup.Clear;
+begin
+  Values := nil;
+  Position := 0;
+  Count := 0;
+  LastFind := 0;
+end;
+
+procedure TRawByteStringGroup.AppendTextAndClear(var aDest: RawByteString);
+var
+  d, i: integer;
+  v: PRawByteStringGroupValue;
+begin
+  d := length(aDest);
+  SetLength(aDest, d + Position);
+  v := pointer(Values);
+  for i := 1 to Count do
+  begin
+    MoveFast(pointer(v^.Value)^, PByteArray(aDest)[d + v^.Position], length(v^.Value));
+    inc(v);
+  end;
+  Clear;
+end;
+
+function TRawByteStringGroup.AsText: RawByteString;
+begin
+  if Values = nil then
+    result := ''
+  else
+  begin
+    if Count > 1 then
+      Compact;
+    result := Values[0].Value;
+  end;
+end;
+
+procedure TRawByteStringGroup.Compact;
+var
+  i: integer;
+  v: PRawByteStringGroupValue;
+  tmp: RawUtf8;
+begin
+  if (Values <> nil) and
+     (Count > 1) then
+  begin
+    FastSetString(tmp, Position); // assume CP_UTF8 for FPC RTL bug
+    v := pointer(Values);
+    for i := 1 to Count do
+    begin
+      MoveFast(pointer(v^.Value)^, PByteArray(tmp)[v^.Position], length(v^.Value));
+      {$ifdef FPC}
+      FastAssignNew(v^.Value);
+      {$else}
+      v^.Value := '';
+      {$endif FPC}
+      inc(v);
+    end;
+    Values[0].Value := tmp; // use result for absolute compaction ;)
+    if Count > 128 then
+      SetLength(Values, 128);
+    Count := 1;
+    LastFind := 0;
+  end;
+end;
+
+function TRawByteStringGroup.AsBytes: TByteDynArray;
+var
+  i: integer;
+begin
+  result := nil;
+  if Values = nil then
+    exit;
+  SetLength(result, Position);
+  for i := 0 to Count - 1 do
+    with Values[i] do
+      MoveFast(pointer(Value)^, PByteArray(result)[Position], length(Value));
+end;
+
+procedure TRawByteStringGroup.Write(W: TTextWriter; Escape: TTextWriterKind);
+var
+  i: integer;
+begin
+  if Values <> nil then
+    for i := 0 to Count - 1 do
+      with Values[i] do
+        W.Add(PUtf8Char(pointer(Value)), length(Value), Escape);
+end;
+
+procedure TRawByteStringGroup.WriteBinary(W: TBufferWriter);
+var
+  i: integer;
+begin
+  if Values <> nil then
+    for i := 0 to Count - 1 do
+      W.WriteBinary(Values[i].Value);
+end;
+
+procedure TRawByteStringGroup.WriteString(W: TBufferWriter);
+begin
+  if Values = nil then
+  begin
+    W.Write1(0);
+    exit;
+  end;
+  W.WriteVarUInt32(Position);
+  WriteBinary(W);
+end;
+
+procedure TRawByteStringGroup.AddFromReader(var aReader: TFastReader);
+var
+  complexsize: integer;
+begin
+  complexsize := aReader.VarUInt32;
+  if complexsize > 0 then
+    // directly create a RawByteString from aReader buffer
+    Add(aReader.Next(complexsize), complexsize);
+end;
+
+function TRawByteStringGroup.Find(aPosition: integer): PRawByteStringGroupValue;
+var
+  i: integer;
+begin
+  result := nil;
+  if (pointer(Values) = nil) or
+     (cardinal(aPosition) >= cardinal(Position)) then
+    exit;
+  result := @Values[LastFind]; // this cache is very efficient in practice
+  if (aPosition >= result^.Position) and
+     (aPosition < result^.Position + length(result^.Value)) then
+    exit;
+  result := @Values[1]; // seldom O(n) brute force search (in CPU L1 cache)
+  for i := 0 to Count - 2 do
+    if result^.Position > aPosition then
+    begin
+      dec(result);
+      LastFind := i;
+      exit;
+    end
+    else
+      inc(result);
+  dec(result);
+  LastFind := Count - 1;
+end;
+
+function TRawByteStringGroup.Find(aPosition, aLength: integer): pointer;
+var
+  P: PRawByteStringGroupValue;
+  i: integer;
+label
+  found;
+begin
+  result := nil;
+  if (pointer(Values) = nil) or
+     (cardinal(aPosition) >= cardinal(Position)) then
+    exit;
+  P := @Values[LastFind]; // this cache is very efficient in practice
+  i := aPosition - P^.Position;
+  if (i >= 0) and
+     (i + aLength < length(P^.Value)) then
+  begin
+    result := @PByteArray(P^.Value)[i];
+    exit;
+  end;
+  P := @Values[1]; // seldom O(n) brute force search (in CPU L1 cache)
+  for i := 0 to Count - 2 do
+    if P^.Position > aPosition then
+    begin
+      LastFind := i;
+found:  dec(P);
+      dec(aPosition, P^.Position);
+      if aLength - aPosition <= length(P^.Value) then
+        result := @PByteArray(P^.Value)[aPosition];
+      exit;
+    end
+    else
+      inc(P);
+  LastFind := Count - 1;
+  goto found;
+end;
+
+procedure TRawByteStringGroup.FindAsText(aPosition, aLength: integer;
+  out aText: RawByteString);
+var
+  P: PRawByteStringGroupValue;
+begin
+  P := Find(aPosition);
+  if P = nil then
+    exit;
+  dec(aPosition, P^.Position);
+  if (aPosition = 0) and
+     (length(P^.Value) = aLength) then
+    aText := P^.Value
+  else
+  // direct return if not yet compacted
+  if aLength - aPosition <= length(P^.Value) then
+    FastSetRawByteString(aText, @PByteArray(P^.Value)[aPosition], aLength);
+end;
+
+function TRawByteStringGroup.FindAsText(aPosition, aLength: integer): RawByteString;
+{%H-}begin
+  {%H-}FindAsText(aPosition, aLength, result);
+end;
+
+procedure TRawByteStringGroup.FindAsVariant(aPosition, aLength: integer;
+  out aDest: variant);
+var
+  tmp: RawByteString;
+begin
+  FindAsText(aPosition, aLength, tmp);
+  if {%H-}tmp <> '' then
+    RawUtf8ToVariant(tmp, aDest);
+end;
+
+procedure TRawByteStringGroup.FindWrite(aPosition, aLength: integer;
+  W: TTextWriter; Escape: TTextWriterKind; TrailingCharsToIgnore: integer);
+var
+  P: pointer;
+begin
+  P := Find(aPosition, aLength);
+  if P <> nil then
+    W.Add(PUtf8Char(P) + TrailingCharsToIgnore, aLength - TrailingCharsToIgnore, Escape);
+end;
+
+procedure TRawByteStringGroup.FindWriteBase64(aPosition, aLength: integer;
+  W: TTextWriter; withMagic: boolean);
+var
+  P: pointer;
+begin
+  P := Find(aPosition, aLength);
+  if P <> nil then
+    W.WrBase64(P, aLength, withMagic);
+end;
+
+procedure TRawByteStringGroup.FindMove(aPosition, aLength: integer;
+  aDest: pointer);
+var
+  P: pointer;
+begin
+  P := Find(aPosition, aLength);
+  if P <> nil then
+    MoveFast(P^, aDest^, aLength);
+end;
+
+
+{ TRawByteStringCached }
+
+type
+  TRawByteStringCacheOne = record
+    header: TLockedListOne;
+    strrec: TStrRec;
+  end;
+  PRawByteStringCacheOne = ^TRawByteStringCacheOne;
+
+constructor TRawByteStringCached.Create(aLength: integer);
+begin
+  fLength := aLength;
+  fOne.Init(aLength + (SizeOf(TRawByteStringCacheOne) + 1));
+end;
+
+procedure TRawByteStringCached.New(var aDest: RawByteString; aCodePage: integer);
+var
+  one: PRawByteStringCacheOne;
+begin
+  one := fOne.New;
+  {$ifdef HASCODEPAGE}
+  one^.strrec.codePage := aCodePage;
+  one^.strrec.elemSize := 1;
+  {$endif HASCODEPAGE}
+  one^.strrec.refCnt := -2;
+  one^.strrec.length := fLength;
+  inc(one);
+  FastAssignNew(aDest, one);
+end;
+
+procedure TRawByteStringCached.New(var aDest: RawUtf8);
+begin
+  New(RawByteString(aDest), CP_UTF8);
+end;
+
+procedure TRawByteStringCached.NewUtf8(var aDest: pointer);
+begin
+  New(PRawByteString(@aDest)^, CP_UTF8);
+end;
+
+procedure TRawByteStringCached.Release(var aDest: RawByteString);
+var
+  one: PRawByteStringCacheOne;
+begin
+  if self <> nil then
+  begin
+    one := pointer(aDest);
+    dec(one);
+    if (one^.strrec.refCnt = -2) and
+       (one^.strrec.length = TStrLen(fLength)) and
+       fOne.Free(one) then
+    begin
+      pointer(aDest) := nil;
+      exit;
+    end;
+  end;
+  FastAssignNew(aDest) // this was a regular RawByteString
+end;
+
+procedure TRawByteStringCached.Release(var aDest: RawUtf8);
+begin
+  Release(RawByteString(aDest));
+end;
+
+procedure TRawByteStringCached.Release(var aDest: pointer);
+begin
+  Release(PRawByteString(@aDest)^);
+end;
+
+function TRawByteStringCached.Clean: PtrInt;
+begin
+  result := fOne.EmptyBin * fOne.Size;
+end;
+
+destructor TRawByteStringCached.Destroy;
+begin
+  fOne.Done;
+  inherited Destroy;
+end;
+
+
+{ TRawByteStringBuffer }
+
+procedure TRawByteStringBuffer.Reset;
+begin
+  fLen := 0;
+end;
+
+procedure TRawByteStringBuffer.Clear;
+begin
+  fLen := 0;
+  FastAssignNew(fBuffer);
+end;
+
+function TRawByteStringBuffer.Buffer: pointer;
+begin
+  result := pointer(fBuffer);
+end;
+
+function TRawByteStringBuffer.Capacity: PtrInt;
+begin
+  result := length(fBuffer);
+end;
+
+procedure TRawByteStringBuffer.RawRealloc(needed: PtrInt);
+begin
+  if fLen = 0 then // buffer from scratch (fBuffer may be '' or not)
+  begin
+    inc(needed, 128); // small overhead at first
+    FastSetString(fBuffer, needed); // no realloc
+  end
+  else
+  begin
+    inc(needed, needed shr 3 + 2048); // generous overhead on resize
+    SetLength(fBuffer, needed); // realloc = move existing data
+  end;
+end;
+
+procedure TRawByteStringBuffer.RawAppend(P: pointer; PLen: PtrInt);
+var
+  needed: PtrInt;
+begin
+  needed := fLen + PLen + 2;
+  if needed > length(fBuffer) then
+    RawRealloc(needed);
+  MoveFast(P^, PByteArray(fBuffer)[fLen], PLen);
+  inc(fLen, PLen);
+end;
+
+procedure TRawByteStringBuffer.Append(P: pointer; PLen: PtrInt);
+begin
+  if PLen > 0 then
+    RawAppend(P, PLen);
+end;
+
+procedure TRawByteStringBuffer.Append(const Text: RawUtf8);
+var
+  P: PAnsiChar;
+begin
+  P := pointer(Text);
+  if P <> nil then
+    RawAppend(P, PStrLen(P - _STRLEN)^);
+end;
+
+procedure TRawByteStringBuffer.Append(Value: QWord);
+var
+  tmp: array[0..23] of AnsiChar;
+  P: PAnsiChar;
+begin
+  {$ifndef ASMINTEL} // our StrUInt64 asm has less CPU cache pollution
+  if Value <= high(SmallUInt32Utf8) then
+    Append(SmallUInt32Utf8[Value])
+  else
+  {$endif ASMINTEL}
+  begin
+    P := StrUInt64(@tmp[23], Value);
+    RawAppend(P, @tmp[23] - P);
+  end;
+end;
+
+procedure TRawByteStringBuffer.AppendCRLF;
+begin
+  PWord(@PByteArray(fBuffer)[fLen])^ := $0a0d;
+  inc(fLen, 2);
+end;
+
+procedure TRawByteStringBuffer.Append(Ch: AnsiChar);
+begin
+  PByteArray(fBuffer)[fLen] := ord(Ch);
+  inc(fLen);
+end;
+
+procedure TRawByteStringBuffer.AppendShort(const Text: ShortString);
+begin
+  RawAppend(@Text[1], ord(Text[0]));
+end;
+
+procedure TRawByteStringBuffer.Append(const Text: array of RawUtf8);
+var
+  i: PtrInt;
+begin
+  for i := 0 to high(Text) do
+    Append(Text[i]);
+end;
+
+function TRawByteStringBuffer.TryAppend(P: pointer; PLen: PtrInt): boolean;
+begin
+  if fLen + PLen <= length(fBuffer) then
+  begin
+    MoveFast(P^, PByteArray(fBuffer)[fLen], PLen);
+    inc(fLen, PLen);
+    result := true;
+  end
+  else
+    result := false;
+end;
+
+procedure TRawByteStringBuffer.Reserve(MaxSize: PtrInt);
+begin
+  fLen := 0;
+  if MaxSize > length(fBuffer) then
+    RawRealloc(MaxSize);
+end;
+
+procedure TRawByteStringBuffer.Reserve(const WorkingBuffer: RawByteString);
+begin
+  fLen := 0;
+  if pointer(fBuffer) <> pointer(WorkingBuffer) then
+    fBuffer := WorkingBuffer;
+end;
+
+procedure TRawByteStringBuffer.Remove(FirstBytes: PtrInt);
+begin
+  if FirstBytes > 0 then
+    if FirstBytes >= fLen then
+      fLen := 0
+    else
+    begin
+      dec(fLen, FirstBytes);
+      MoveFast(PByteArray(fBuffer)[FirstBytes], pointer(fBuffer)^, fLen);
+    end;
+end;
+
+function TRawByteStringBuffer.Extract(Dest: pointer; Count: PtrInt): PtrInt;
+begin
+  result := fLen;
+  if Count < result then
+    result := Count;
+  if result <= 0 then
+    exit;
+  MoveFast(pointer(fBuffer)^, Dest^, result);
+  dec(fLen, result);
+  if fLen <> 0 then // keep trailing bytes for next call
+    MoveFast(PByteArray(fBuffer)[result], pointer(fBuffer)^, fLen);
+end;
+
+function TRawByteStringBuffer.ExtractAt(
+  var Dest: PAnsiChar; var Count: PtrInt; var Pos: PtrInt): PtrInt;
+begin
+  result := fLen - Pos;
+  if (result = 0) or
+     (Count = 0) then
+    exit;
+  if result > Count then
+    result := Count;
+  MoveFast(PByteArray(fBuffer)[Pos], Dest^, result);
+  inc(Pos, result);
+  if Pos = fLen then
+  begin
+    Reset; // all pending content has been read
+    Pos := 0;
+  end;
+  inc(Dest, result);
+  dec(Count, result);
+end;
+
+procedure TRawByteStringBuffer.Insert(P: pointer; PLen: PtrInt;
+  Position: PtrInt; CRLF: boolean);
+begin
+  inc(PLen, 2 * ord(CRLF));
+  if PLen + fLen > length(fBuffer) then
+    RawRealloc(PLen + fLen); // need more space
+  MoveFast(pointer(fBuffer)^, PByteArray(fBuffer)[PLen], fLen);
+  dec(PLen, 2 * ord(CRLF));
+  MoveFast(P^, pointer(fBuffer)^, PLen);
+  if CRLF then
+    PWord(@PByteArray(fBuffer)[PLen])^ := $0a0d;
+end;
+
+procedure TRawByteStringBuffer.AsText(out Text: RawUtf8; Overhead: PtrInt;
+  UseMainBuffer: boolean);
+begin
+  if (Len = 0) or
+     (fBuffer = '') or
+     (OverHead < 0) then
+    exit;
+  if UseMainBuffer and
+     (PStrCnt(PAnsiChar(pointer(fBuffer)) - _STRCNT)^ = 1) and
+     (Len + Overhead <= length(fBuffer)) then
+  begin
+    pointer(Text) := pointer(fBuffer); // fast pointer move for refcount=1
+    pointer(fBuffer) := nil;
+  end
+  else
+  begin
+    pointer(Text) := FastNewString(Len + Overhead, CP_UTF8);
+    MoveFast(pointer(fBuffer)^, pointer(Text)^, Len);
+    if OverHead = 0 then
+      exit;
+  end;
+  // keep OverHead allocated, but SetLength(Len) and put #0 at right position
+  FakeLength(Text, Len);
+end;
+
+
+procedure InitializeUnit;
+var
+  i: PtrInt;
+  e: TEmoji;
+begin
+  // initialize Base64/Base64Uri/Base58/Base32/Baudot encoding/decoding tables
+  FillcharFast(ConvertBase64ToBin, SizeOf(ConvertBase64ToBin), 255); // -1 = invalid
+  FillcharFast(ConvertBase64uriToBin, SizeOf(ConvertBase64uriToBin), 255);
+  FillcharFast(ConvertBase58ToBin, SizeOf(ConvertBase58ToBin), 255);
+  FillcharFast(ConvertBase32ToBin, SizeOf(ConvertBase32ToBin), 255);
+  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 := 0 to high(b58enc) do
+    ConvertBase58ToBin[b58enc[i]] := i;
+  for i := 0 to high(b32enc) do
+    ConvertBase32ToBin[b32enc[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
+  // HTML/Emoji Efficient Parsing
+  Assert(ord(high(TEmoji)) = $4f + 1);
+  EMOJI_RTTI := GetEnumName(TypeInfo(TEmoji), 1); // ignore eNone=0
+  GetEnumTrimmedNames(TypeInfo(TEmoji), @EMOJI_TEXT);
+  EMOJI_TEXT[eNone] := '';
+  for e := succ(low(e)) to high(e) do
+  begin
+    LowerCaseSelf(EMOJI_TEXT[e]);
+    EMOJI_TAG[e] := ':' + EMOJI_TEXT[e] + ':';
+    SetLength(EMOJI_UTF8[e], 4); // order matches U+1F600 to U+1F64F codepoints
+    Ucs4ToUtf8(ord(e) + $1f5ff, pointer(EMOJI_UTF8[e]));
+  end;
+  EMOJI_AFTERDOTS[')'] := eSmiley;
+  EMOJI_AFTERDOTS['('] := eFrowning;
+  EMOJI_AFTERDOTS['|'] := eExpressionless;
+  EMOJI_AFTERDOTS['/'] := eConfused;
+  EMOJI_AFTERDOTS['D'] := eLaughing;
+  EMOJI_AFTERDOTS['o'] := eOpen_mouth;
+  EMOJI_AFTERDOTS['O'] := eOpen_mouth;
+  EMOJI_AFTERDOTS['p'] := eYum;
+  EMOJI_AFTERDOTS['P'] := eYum;
+  EMOJI_AFTERDOTS['s'] := eScream;
+  EMOJI_AFTERDOTS['S'] := eScream;
+  // setup internal lists and function wrappers
+  AlgoSynLZ := TAlgoSynLZ.Create;
+  AlgoRleLZ := TAlgoRleLZ.Create;
+  AlgoRle := TAlgoRle.Create;
+  Base64EncodeMain := @Base64EncodeMainPas;
+  Base64DecodeMain := @Base64DecodeMainPas;
+  {$ifdef ASMX64AVXNOCONST} // focus on x86_64 server performance
+  if cfAVX2 in CpuFeatures then
+  begin // our AVX2 asm code is almost 10x faster than the pascal version
+    Base64EncodeMain := @Base64EncodeMainAvx2; // 11.5 GB/s vs 1.3 GB/s
+    Base64DecodeMain := @Base64DecodeMainAvx2; //  8.7 GB/s vs 0.9 GB/s
+  end;
+  {$endif ASMX64AVXNOCONST}
+end;
+
+
+initialization
+  InitializeUnit;
+
+
+end.
diff --git a/lib/dmustache/mormot.core.data.pas b/lib/dmustache/mormot.core.data.pas
new file mode 100644
index 00000000..32e8e36b
--- /dev/null
+++ b/lib/dmustache/mormot.core.data.pas
@@ -0,0 +1,11523 @@
+/// Framework Core Low-Level Data Processing Functions
+// - this unit is a part of the Open Source Synopse mORMot framework 2,
+// licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+unit mormot.core.data;
+
+{
+  *****************************************************************************
+
+   Low-Level Data Processing Functions shared by all framework units
+    - RTL TPersistent / TInterfacedObject with Custom Constructor
+    - TSynPersistent* TSyn*List TSynLocker classes
+    - TSynPersistentStore with proper Binary Serialization
+    - INI Files and In-memory Access
+    - Efficient RTTI Values Binary Serialization and Comparison
+    - TDynArray and TDynArrayHashed Wrappers
+    - Integer Arrays Extended Process
+    - RawUtf8 String Values Interning and TRawUtf8List
+    - Abstract Radix Tree Classes
+
+  *****************************************************************************
+}
+
+interface
+
+{$I mormot.defines.inc}
+
+uses
+  classes,
+  contnrs,
+  types,
+  sysutils,
+  {$ifdef ISDELPHI}
+  typinfo,  // circumvent Delphi inlining issues
+  {$endif ISDELPHI}
+  mormot.core.base,
+  mormot.core.os,
+  mormot.core.rtti,
+  mormot.core.datetime,
+  mormot.core.unicode,
+  mormot.core.text,
+  mormot.core.buffers;
+
+
+{ ************ RTL TPersistent / TInterfacedObject with Custom Constructor }
+
+type
+    /// 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 TRestServer.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) - warning: use with extreme caution!
+    procedure RefCountUpdate(Release: boolean); virtual;
+  end;
+  {$M-}
+
+
+  /// 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 by default
+    function VirtualQueryInterface(IID: PGuid; out Obj): TIntQry; virtual;
+    // always return 1 for a "non allocated" instance (0 triggers release)
+    function VirtualAddRef: integer;  virtual; abstract;
+    function VirtualRelease: integer; virtual; abstract;
+    function QueryInterface({$ifdef FPC_HAS_CONSTREF}constref{$else}const{$endif}
+      IID: TGuid; out Obj): TIntQry; {$ifdef OSWINDOWS}stdcall{$else}cdecl{$endif};
+    function _AddRef: TIntCnt;       {$ifdef OSWINDOWS}stdcall{$else}cdecl{$endif};
+    function _Release: TIntCnt;      {$ifdef OSWINDOWS}stdcall{$else}cdecl{$endif};
+  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;
+    /// the associated reference count
+    property RefCount: integer
+      read fRefCount write fRefCount;
+  end;
+
+  /// any TCollection used between client and server shall inherit from this class
+  // - you should override the GetClass virtual method to provide the
+  // expected collection item class to be used on server side
+  // - another possibility is to register a TCollection/TCollectionItem pair
+  // via a call to Rtti.RegisterCollection()
+  TInterfacedCollection = class(TCollection)
+  public
+    /// you shall override this abstract method
+    class function GetClass: TCollectionItemClass; virtual; abstract;
+    /// this constructor will call GetClass to initialize the collection
+    constructor Create; reintroduce; virtual;
+  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;
+
+  /// class-reference type (metaclass) of a TInterfacedCollection kind
+  TInterfacedCollectionClass = class of TInterfacedCollection;
+
+
+  /// interface for TAutoFree to register another TObject instance
+  // to an existing IAutoFree local variable
+  // - WARNING: both FPC and Delphi 10.4+ don't keep the IAutoFree instance
+  // up to the end-of-method -> you should not use TAutoFree for new projects :(
+  IAutoFree = interface
+    procedure Another(var objVar; obj: TObject);
+    /// do-nothing method to circumvent the Delphi 10.4 IAutoFree early release
+    procedure ForMethod;
+  end;
+
+  /// simple reference-counted storage for local objects
+  // - WARNING: both FPC and Delphi 10.4+ don't keep the IAutoFree instance
+  // up to the end-of-method -> you should not use TAutoFree for new projects :(
+  // - 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;
+    // do-nothing method to circumvent the Delphi 10.4 IAutoFree early release
+    procedure ForMethod;
+  public
+    /// initialize the TAutoFree class for one local variable
+    // - do not call this constructor, but class function One() instead
+    constructor Create(var localVariable; obj: TObject); reintroduce; overload;
+    /// initialize the TAutoFree class for several local variables
+    // - do not call this constructor, but class function Several() instead
+    constructor Create(const varObjPairs: array of pointer); reintroduce; overload;
+    /// protect one local TObject variable instance life time
+    // - for instance, instead of writing:
+    // !var
+    // !  myVar: TMyClass;
+    // !begin
+    // !  myVar := TMyClass.Create;
+    // !  try
+    // !    ... use myVar
+    // !  finally
+    // !    myVar.Free;
+    // !  end;
+    // !end;
+    // - you may write:
+    // !var
+    // !  myVar: TMyClass;
+    // !begin
+    // !  TAutoFree.One(myVar,TMyClass.Create);
+    // !  ... use myVar
+    // !end; // here myVar will be released
+    // - warning: under FPC, you should assign the result of this method to a local
+    // IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602
+    // - Delphi 10.4 also did change it and release the IAutoFree before the
+    // end of the current method, so we inlined a void method call trying to
+    // circumvent this problem - https://quality.embarcadero.com/browse/RSP-30050
+    // - for both Delphi 10.4+ and FPC, you may use with TAutoFree.One() do
+    class function One(var localVariable; obj: TObject): IAutoFree;
+      {$ifdef ISDELPHI104} inline; {$endif}
+    /// protect several local TObject variable instances life time
+    // - specified as localVariable/objectInstance pairs
+    // - you may write:
+    // !var
+    // !  var1, var2: TMyClass;
+    // !begin
+    // !  TAutoFree.Several([
+    // !    @var1,TMyClass.Create,
+    // !    @var2,TMyClass.Create]);
+    // !  ... use var1 and var2
+    // !end; // here var1 and var2 will be released
+    // - warning: under FPC, you should assign the result of this method to a local
+    // IAutoFree variable - see bug http://bugs.freepascal.org/view.php?id=26602
+    // - Delphi 10.4 also did change it and release the IAutoFree before the
+    // end of the current method, and an "array of pointer" cannot be inlined
+    // by the Delphi compiler, so you should explicitly call ForMethod:
+    // !  TAutoFree.Several([
+    // !    @var1,TMyClass.Create,
+    // !    @var2,TMyClass.Create]).ForMethod;
+    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 TOrm
+    destructor Destroy; override;
+  end;
+
+
+  /// 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.core.interface.pas
+  // TInjectableObject as IAutoLocker so that this class may be automatically
+  // injected
+  // - 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;
+
+
+
+{ ************ TSynPersistent* TSyn*List TSynLocker classes }
+
+type
+  /// 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 UI)
+  // - this class has a virtual constructor, so is a preferred alternative
+  // to both TPersistent and TPersistentWithCustomCreate classes
+  // - features some protected methods to customize its JSON serialization
+  // - 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(TObjectWithCustomCreate)
+  protected
+    // this default implementation will call AssignError()
+    procedure AssignTo(Dest: TSynPersistent); virtual;
+    procedure AssignError(Source: TSynPersistent);
+  public
+    /// 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;
+  end;
+
+  /// used to determine the exact class type of a TSynPersistent
+  TSynPersistentClass = class of TSynPersistent;
+
+
+  {$ifdef HASITERATORS}
+  /// abstract pointer Enumerator
+  TPointerEnumerator = record
+  private
+    Curr, After: PPointer;
+    function GetCurrent: pointer; inline;
+  public
+    procedure Init(Values: PPointerArray; Count: PtrUInt); inline;
+    function MoveNext: Boolean; inline;
+    function GetEnumerator: TPointerEnumerator; inline;
+    /// returns the current pointer value
+    property Current: pointer
+      read GetCurrent;
+  end;
+  {$endif HASITERATORS}
+
+  {$M+}
+  /// simple and efficient TList, without any notification
+  // - regular TList has an internal notification mechanism which slows down
+  // basic process, and can't be easily inherited
+  // - stateless methods (like Add/Clear/Exists/Remove) are defined as virtual
+  // since can be overriden e.g. by TSynObjectListLocked to add a TSynLocker
+  TSynList = class(TObject)
+  protected
+    fCount: integer;
+    fList: TPointerDynArray;
+    function Get(index: integer): pointer;
+      {$ifdef HASINLINE}inline;{$endif}
+  public
+    /// virtual constructor called at instance creation
+    constructor Create; virtual;
+    /// add one item to the list
+    function Add(item: pointer): PtrInt; virtual;
+    /// insert one item to the list at a given position
+    function Insert(item: pointer; index: PtrInt): PtrInt;
+    /// delete all items of the list
+    procedure Clear; virtual;
+    /// delete one item from the list
+    procedure Delete(index: integer; dontfree: boolean = false); virtual;
+    /// fast retrieve one item in the list
+    function IndexOf(item: pointer): PtrInt; virtual;
+    /// fast check if one item exists in the list
+    function Exists(item: pointer): boolean; virtual;
+    /// fast delete one item in the list
+    function Remove(item: pointer): PtrInt; virtual;
+    {$ifdef HASITERATORS}
+    /// an enumerator able to compile "for .. in list do" statements
+    function GetEnumerator: TPointerEnumerator;
+    {$endif HASITERATORS}
+    /// how many items are stored in this TList instance
+    property Count: integer
+      read fCount;
+    /// low-level access to the items stored in this TList instance
+    property List: TPointerDynArray
+      read fList;
+    /// low-level array-like access to the items stored in this TList instance
+    // - warning: if index is out of range, will return nil and won't raise
+    // any exception
+    property Items[index: integer]: pointer
+      read Get; default;
+  end;
+  {$M-}
+  PSynList = ^TSynList;
+
+  /// simple and efficient TObjectList, without any notification
+  TSynObjectList = class(TSynList)
+  protected
+    fOwnObjects: boolean;
+    fItemClass: TClass;
+  public
+    /// initialize the object list
+    // - can optionally specify an item class for efficient JSON serialization
+    constructor Create(aOwnObjects: boolean = true;
+      aItemClass: TClass = nil); reintroduce; virtual;
+    /// delete one object from the list
+    // - will also Free the item if OwnObjects was set, and dontfree is false
+    procedure Delete(index: integer; dontfree: boolean = false); override;
+    /// delete all objects of the list
+    procedure Clear; override;
+    /// delete all objects of the list in reverse order
+    // - for some kind of processes, owned objects should be removed from the
+    // last added to the first
+    // - will use slower but safer FreeAndNilSafe() instead of plain Free
+    procedure ClearFromLast; virtual;
+    /// finalize the store items
+    destructor Destroy; override;
+    /// create a new ItemClass instance, Add() it and return it
+    function NewItem: pointer;
+    /// optional class of the stored items
+    // - used e.g. by _JL_TSynObjectList() when unserializing from JSON
+    property ItemClass: TClass
+      read fItemClass write fItemClass;
+    /// flag set if this list will Free its items on Delete/Clear/Destroy
+    property OwnObjects: boolean
+      read fOwnObjects write fOwnObjects;
+  end;
+  PSynObjectList = ^TSynObjectList;
+
+  /// meta-class of TSynObjectList type
+  TSynObjectListClass = class of TSynObjectList;
+
+  /// 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,
+  // and is cross-compiler whereas TMonitor is Delphi-specific and buggy (at
+  // least before XE5)
+  // - if you don't need TSynPersistent overhead, consider plain TSynLocked class
+  TSynPersistentLock = class(TSynPersistent)
+  protected
+    // TSynLocker would increase inherited fields offset -> managed PSynLocker
+    fSafe: PSynLocker;
+    // will lock/unlock the instance during JSON serialization of its properties
+    function RttiBeforeWriteObject(W: TTextWriter;
+      var Options: TTextWriterWriteObjectOptions): boolean; override;
+    procedure RttiAfterWriteObject(W: TTextWriter;
+      Options: TTextWriterWriteObjectOptions); override;
+    // set the rcfHookWrite flag to call RttiBeforeWriteObject
+    class procedure RttiCustomSetParser(Rtti: TRttiCustom); override;
+  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;
+    /// could be used as a short-cut to Safe.Lock
+    procedure Lock;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// could be used as a short-cut to Safe.UnLock
+    procedure Unlock;
+      {$ifdef HASINLINE}inline;{$endif}
+  end;
+
+  /// adding light non-upgradable multiple Read / exclusive Write locking
+  // methods to a TSynPersistent with virtual constructor
+  TSynPersistentRWLightLock = class(TSynPersistent)
+  protected
+    fSafe: TRWLightLock;
+  public
+    /// access to the associated non-upgradable TRWLightLock instance
+    // - call Safe methods to protect multi-thread access on this storage
+    property Safe: TRWLightLock
+      read fSafe;
+  end;
+
+  /// adding light upgradable multiple Read / exclusive Write locking methods
+  // to a TSynPersistent with virtual constructor
+  TSynPersistentRWLock = class(TSynPersistent)
+  protected
+    fSafe: TRWLock;
+  public
+    /// access to the associated upgradable TRWLock instance
+    // - call Safe methods to protect multi-thread access on this storage
+    property Safe: TRWLock
+      read fSafe;
+  end;
+
+  {$ifndef PUREMORMOT2}
+
+  /// used for backward compatibility only with existing code
+  TSynPersistentLocked = class(TSynPersistentLock);
+
+  {$endif PUREMORMOT2}
+
+  /// 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;
+
+  /// adding light locking methods to a TInterfacedObject with virtual constructor
+  TInterfacedObjectRWLocked = class(TInterfacedObjectWithCustomCreate)
+  protected
+    fSafe: TRWLock;
+  public
+    /// access to the multiple Read / exclusive Write locking methods of this instance
+    property Safe: TRWLock
+      read fSafe;
+  end;
+
+  /// add TRWLightLock non-upgradable methods to a TSynObjectList
+  // - this class expands the regular TSynObjectList to include a TRWLightLock
+  // - you need to call the Safe locking methods by hand to protect the
+  // execution of all methods, since even Add/Clear/ClearFromLast/Remove/Exists
+  // have not been overriden because TRWLighLock.WriteLock is not reentrant
+  TSynObjectListLightLocked = class(TSynObjectList)
+  protected
+    fSafe: TRWLightLock;
+  public
+    /// the light single Read / exclusive Write LightLock associated to this list
+    // - could be used to protect shared resources within the internal process,
+    // for index-oriented methods like Delete/Items/Count...
+    // - use Safe LightLock methods with a try ... finally bLightLock
+    property Safe: TRWLightLock
+      read fSafe;
+  end;
+
+  /// add TRWLock upgradable methods to a TSynObjectList
+  // - this class expands the regular TSynObjectList to include a TRWLock
+  // - you need to call the Safe locking methods by hand to protect the
+  // execution of index-oriented methods (like Delete/Items/Count...): the
+  // list content may change in the background, so using indexes is thread-safe
+  // - on the other hand, Add/Clear/ClearFromLast/Remove stateless methods have
+  // been overriden in this class to call Safe lock methods, and therefore are
+  // thread-safe and protected to any background change
+  TSynObjectListLocked = class(TSynObjectList)
+  protected
+    fSafe: TRWLock;
+  public
+    /// add one item to the list using Safe.WriteLock
+    function Add(item: pointer): PtrInt; override;
+    /// delete all items of the list using Safe.WriteLock
+    procedure Clear; override;
+    /// delete all items of the list in reverse order, using Safe.WriteLock
+    procedure ClearFromLast; override;
+    /// fast delete one item in the list, using Safe.WriteLock
+    function Remove(item: pointer): PtrInt; override;
+    /// check an item using Safe.ReadOnlyLock
+    function Exists(item: pointer): boolean; override;
+    /// the light single Read / exclusive Write lock associated to this list
+    // - could be used to protect shared resources within the internal process,
+    // for index-oriented methods like Delete/Items/Count...
+    // - use Safe lock methods within a try ... finally block
+    property Safe: TRWLock
+      read fSafe;
+  end;
+
+  /// event used by TSynObjectListSorted to compare its instances
+  TOnObjectCompare = function(A, B: TObject): integer;
+
+  /// an ordered thread-safe TSynObjectList
+  // - items will be stored in order, for O(log(n)) fast search
+  TSynObjectListSorted = class(TSynObjectListLocked)
+  protected
+    fCompare: TOnObjectCompare;
+    // returns TRUE and the index of existing Item, or FALSE and the index
+    // where the Item is to be inserted so that the array remains sorted
+    function Locate(item: pointer; out index: PtrInt): boolean;
+  public
+    /// initialize the object list to be sorted with the supplied function
+    constructor Create(const aCompare: TOnObjectCompare;
+      aOwnsObjects: boolean = true); reintroduce;
+    /// add in-order one item to the list using Safe.WriteLock
+    // - returns the sorted index when item was inserted
+    // - returns < 0 if item was found, as -(existingindex + 1)
+    function Add(item: pointer): PtrInt; override;
+    /// fast retrieve one item in the list using O(log(n)) binary search
+    // - this overriden version won't search for the item pointer itself,
+    // but will use the Compare() function until it is 0
+    function IndexOf(item: pointer): PtrInt; override;
+    /// fast retrieve one item in the list using O(log(n)) binary search
+    // - supplied item should have enough information for fCompare to work
+    function Find(item: TObject): TObject;
+    /// how two stored objects are stored
+    property Compare: TOnObjectCompare
+      read fCompare write fCompare;
+  end;
+
+
+{ ************ TSynPersistentStore with proper Binary Serialization }
+
+type
+  /// abstract high-level handling of (SynLZ-)compressed persisted storage
+  // - LoadFromReader/SaveToWriter abstract methods should be overriden
+  // with proper binary persistence implementation
+  TSynPersistentStore = class(TSynPersistentRWLock)
+  protected
+    fName: RawUtf8;
+    fReader: TFastReader;
+    fReaderTemp: PRawByteString;
+    fLoadFromLastUncompressed, fSaveToLastUncompressed: integer;
+    fLoadFromLastAlgo: TAlgoCompress;
+    /// low-level virtual methods implementing the persistence reading
+    procedure LoadFromReader; virtual;
+    procedure SaveToWriter(aWriter: TBufferWriter); virtual;
+  public
+    /// initialize a void storage with the supplied name
+    constructor Create(const aName: RawUtf8); reintroduce; overload; virtual;
+    /// initialize a storage from a SaveTo persisted buffer
+    // - raise a EFastReader exception on decoding error
+    constructor CreateFrom(const aBuffer: RawByteString;
+      aLoad: TAlgoCompressLoad = aclNormal);
+    /// initialize a storage from a SaveTo persisted buffer
+    // - raise a EFastReader exception on decoding error
+    constructor CreateFromBuffer(aBuffer: pointer; aBufferLen: integer;
+      aLoad: TAlgoCompressLoad = aclNormal);
+    /// initialize a storage from a SaveTo persisted buffer
+    // - raise a EFastReader exception on decoding error
+    constructor CreateFromFile(const aFileName: TFileName;
+      aLoad: TAlgoCompressLoad = aclNormal);
+    /// fill the storage from a SaveTo persisted buffer
+    // - actually call the LoadFromReader() virtual method for persistence
+    // - raise a EFastReader exception on decoding error
+    procedure LoadFrom(const aBuffer: RawByteString;
+      aLoad: TAlgoCompressLoad = aclNormal); overload;
+    /// initialize the storage from a SaveTo persisted buffer
+    // - actually call the LoadFromReader() virtual method for persistence
+    // - raise a EFastReader exception on decoding error
+    procedure LoadFrom(aBuffer: pointer; aBufferLen: integer;
+      aLoad: TAlgoCompressLoad = aclNormal); overload; virtual;
+    /// initialize the storage from a SaveToFile content
+    // - actually call the LoadFromReader() virtual method for persistence
+    // - returns false if the file is not found, true if the file was loaded
+    // without any problem, or raise a EFastReader exception on decoding error
+    function LoadFromFile(const aFileName: TFileName;
+      aLoad: TAlgoCompressLoad = aclNormal): boolean;
+    /// persist the content as a SynLZ-compressed binary blob
+    // - to be retrieved later on via LoadFrom method
+    // - actually call the SaveToWriter() protected virtual method for persistence
+    // - you can specify ForcedAlgo if you want to override the default AlgoSynLZ
+    // - BufferOffset could be set to reserve some bytes before the compressed buffer
+    procedure SaveTo(out aBuffer: RawByteString; nocompression: boolean = false;
+      BufLen: integer = 65536; ForcedAlgo: TAlgoCompress = nil;
+      BufferOffset: integer = 0); overload; virtual;
+    /// persist the content as a SynLZ-compressed binary blob
+    // - just an overloaded wrapper
+    function SaveTo(nocompression: boolean = false; BufLen: integer = 65536;
+      ForcedAlgo: TAlgoCompress = nil; BufferOffset: integer = 0): RawByteString; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// persist the content as a SynLZ-compressed binary file
+    // - to be retrieved later on via LoadFromFile method
+    // - returns the number of bytes of the resulting file
+    // - actually call the SaveTo method for persistence
+    function SaveToFile(const aFileName: TFileName; nocompression: boolean = false;
+      BufLen: integer = 65536; ForcedAlgo: TAlgoCompress = nil): PtrUInt;
+    /// one optional text associated with this storage
+    // - you can define this field as published to serialize its value in log/JSON
+    property Name: RawUtf8
+      read fName;
+    /// after a LoadFrom(), contains the uncompressed data size read
+    property LoadFromLastUncompressed: integer
+      read fLoadFromLastUncompressed;
+    /// after a SaveTo(), contains the uncompressed data size written
+    property SaveToLastUncompressed: integer
+      read fSaveToLastUncompressed;
+  end;
+
+
+
+{ ********** Efficient RTTI Values Binary Serialization and Comparison }
+
+type
+  /// possible options for a TDocVariant JSON/BSON document storage
+  // - defined in this unit to avoid circular reference with mormot.core.variants
+  // - 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)
+  // - the parser will try to guess the array or object size by pre-fetching
+  // some content: you can set dvoJsonParseDoNotGuessCount if your input has
+  // a lot of nested documents, and manual resize is preferred - this option
+  // will be forced by InitJson if a huge nest of objects is detected
+  // - 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
+  // - see JSON_[TDocVariantModel] and all JSON_* constants as useful sets
+  TDocVariantOption = (
+    dvoIsArray,
+    dvoIsObject,
+    dvoNameCaseSensitive,
+    dvoCheckForDuplicatedNames,
+    dvoReturnNullForUnknownProperty,
+    dvoValueCopiedByReference,
+    dvoJsonParseDoNotTryCustomVariants,
+    dvoJsonParseDoNotGuessCount,
+    dvoJsonObjectParseWithinString,
+    dvoSerializeAsExtendedJson,
+    dvoAllowDoubleValue,
+    dvoInternNames,
+    dvoInternValues);
+
+  /// set of options for a TDocVariant storage
+  // - defined in this unit to avoid circular reference with mormot.core.variants
+  // - see JSON_[TDocVariantModel] and all JSON_* constants (e.g. JSON_FAST or
+  // JSON_FAST_FLOAT) as potential values
+  // - 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
+  // - defined in this unit to avoid circular reference with mormot.core.variants
+  // - use e.g. @JSON_[mFast], @JSON_[mDefault], or any other TDocVariantModel
+  PDocVariantOptions = ^TDocVariantOptions;
+
+  /// a boolean array of TDocVariant storage options
+  TDocVariantOptionsBool = array[boolean] of TDocVariantOptions;
+  PDocVariantOptionsBool = ^TDocVariantOptionsBool;
+
+
+type
+  /// internal function handler for binary persistence of any RTTI type value
+  // - i.e. the kind of functions called via RTTI_BINARYSAVE[] lookup table
+  // - work with managed and unmanaged types
+  // - persist Data^ into Dest, returning the size in Data^ as bytes
+  TRttiBinarySave = function(Data: pointer; Dest: TBufferWriter;
+    Info: PRttiInfo): PtrInt;
+
+  /// the type of RTTI_BINARYSAVE[] efficient lookup table
+  TRttiBinarySaves = array[TRttiKind] of TRttiBinarySave;
+  PRttiBinarySaves = ^TRttiBinarySaves;
+
+  /// internal function handler for binary persistence of any RTTI type value
+  // - i.e. the kind of functions called via RTTI_BINARYLOAD[] lookup table
+  // - work with managed and unmanaged types
+  // - fill Data^ from Source, returning the size in Data^ as bytes
+  TRttiBinaryLoad = function(Data: pointer; var Source: TFastReader;
+    Info: PRttiInfo): PtrInt;
+
+  /// the type of RTTI_BINARYLOAD[] efficient lookup table
+  TRttiBinaryLoads = array[TRttiKind] of TRttiBinaryLoad;
+  PRttiBinaryLoads = ^TRttiBinaryLoads;
+
+  /// internal function handler for fast comparison of any RTTI type value
+  // - i.e. the kind of functions called via RTTI_COMPARE[] lookup table
+  // - work with managed and unmanaged types
+  // - returns the size in Data1/Data2^ as bytes, and the result in Compared
+  TRttiCompare = function(Data1, Data2: pointer; Info: PRttiInfo;
+    out Compared: integer): PtrInt;
+
+  /// the type of RTTI_COMPARE[] efficient lookup table
+  TRttiCompares = array[TRttiKind] of TRttiCompare;
+  PRttiCompares = ^TRttiCompares;
+
+  TRttiComparers = array[{CaseInSensitive=}boolean] of TRttiCompares;
+
+var
+  /// lookup table for binary persistence of any RTTI type value
+  // - for efficient persistence into binary of managed and unmanaged types
+  RTTI_BINARYSAVE: TRttiBinarySaves;
+
+  /// lookup table for binary persistence of any RTTI type value
+  // - for efficient retrieval from binary of managed and unmanaged types
+  RTTI_BINARYLOAD: TRttiBinaryLoads;
+
+  /// lookup table for comparison of any RTTI type value
+  // - for efficient search or sorting of managed and unmanaged types
+  // - RTTI_COMPARE[false] for case-sensitive comparison
+  // - RTTI_COMPARE[true] for case-insensitive comparison
+  RTTI_COMPARE: TRttiComparers;
+
+  /// lookup table for comparison of ordinal RTTI type values
+  // - slightly faster alternative to RTTI_COMPARE[rkOrdinalTypes]
+  RTTI_ORD_COMPARE: array[TRttiOrd] of TRttiCompare;
+
+  /// lookup table for comparison of floating-point RTTI type values
+  // - slightly faster alternative to RTTI_COMPARE[rkFloat]
+  RTTI_FLOAT_COMPARE: array[TRttiFloat] of TRttiCompare;
+
+/// raw binary serialization of a dynamic array
+// - as called e.g. by TDynArray.SaveTo, using ExternalCount optional parameter
+// - RTTI_BINARYSAVE[rkDynArray] is a wrapper to this function, with ExternalCount=nil
+procedure DynArraySave(Data: PAnsiChar; ExternalCount: PInteger;
+  Dest: TBufferWriter; Info: PRttiInfo); overload;
+
+/// 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
+// - is a wrapper around BinarySave(rkDynArray)
+function DynArraySave(var Value; TypeInfo: PRttiInfo): RawByteString; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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
+// - is a wrapper around BinaryLoad(rkDynArray)
+function DynArrayLoad(var Value; Source: PAnsiChar; TypeInfo: PRttiInfo;
+  {$ifdef PUREMORMOT2} // SourceMax is manadatory for safety
+  TryCustomVariants: PDocVariantOptions; SourceMax: PAnsiChar): PAnsiChar;
+  {$else}
+  TryCustomVariants: PDocVariantOptions = nil; SourceMax: PAnsiChar = nil): PAnsiChar;
+  {$endif PUREMORMOT2}
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// low-level binary unserialization as saved by DynArraySave/TDynArray.Save
+// - as used by DynArrayLoad() and TDynArrayLoadFrom
+// - returns the stored length() of the dynamic array, and Source points to
+// the stored binary data itself
+function DynArrayLoadHeader(var Source: TFastReader;
+  ArrayInfo, ItemInfo: PRttiInfo): integer;
+
+/// raw comparison of two dynamic arrays
+// - as called e.g. by TDynArray.Equals, using ExternalCountA/B optional parameter
+// - RTTI_COMPARE[true/false,rkDynArray] are wrappers to this, with ExternalCount=nil
+// - if Info=TypeInfo(TObjectDynArray) then will compare any T*ObjArray
+function DynArrayCompare(A, B: PAnsiChar; ExternalCountA, ExternalCountB: PInteger;
+  Info: PRttiInfo; CaseInSensitive: boolean): integer; overload;
+
+/// wrapper around TDynArray.Add
+// - warning: the Item type is not checked at runtime, so should be as expected
+// - not very fast, but could be useful for simple code
+function DynArrayAdd(TypeInfo: PRttiInfo; var DynArray; const Item): integer; overload;
+
+/// wrapper around TDynArray.Delete
+// - not very fast, but could be useful for simple code
+function DynArrayDelete(TypeInfo: PRttiInfo; var DynArray; Index: PtrInt): boolean; overload;
+
+/// compare two dynamic arrays by calling TDynArray.Equals
+// - if Info=TypeInfo(TObjectDynArray) then will compare any T*ObjArray
+function DynArrayEquals(TypeInfo: PRttiInfo; var Array1, Array2;
+  Array1Count: PInteger = nil; Array2Count: PInteger = nil;
+  CaseInsensitive: boolean = false): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+{$ifdef FPCGENERICS}
+/// wrapper around TDynArray.Add
+// - warning: the Item type is not checked at runtime, so should be as expected
+// - not very fast, but could be useful for simple code
+function DynArrayAdd(var DynArray: TArray; const Item): integer; overload;
+
+/// wrapper around TDynArray.Delete
+// - not very fast, but could be useful for simple code
+function DynArrayDelete(var DynArray: TArray; Index: PtrInt): boolean; overload;
+
+/// compare two dynamic arrays values
+function DynArrayCompare(var Array1, Array2: TArray;
+  CaseInSensitive: boolean = false): integer; overload;
+{$endif FPCGENERICS}
+
+// some low-level comparison methods used by mormot.core.json
+function _BC_SQWord(A, B: PInt64; Info: PRttiInfo; out Compared: integer): PtrInt;
+function _BC_UQWord(A, B: PQWord; Info: PRttiInfo; out Compared: integer): PtrInt;
+function _BC_ObjArray(A, B: pointer; Info: PRttiInfo; out Compared: integer): PtrInt;
+function _BCI_ObjArray(A, B: pointer; Info: PRttiInfo; out Compared: integer): PtrInt;
+
+/// check equality of two values by content, using RTTI
+// - optionally returns the known in-memory PSize of the value
+function BinaryEquals(A, B: pointer; Info: PRttiInfo; PSize: PInteger;
+  Kinds: TRttiKinds; CaseInSensitive: boolean): boolean;
+
+/// comparison of two values by content, using RTTI
+function BinaryCompare(A, B: pointer; Info: PRttiInfo;
+  CaseInSensitive: boolean): integer; overload;
+
+/// comparison of two arrays of values by content, using RTTI
+function BinaryCompare(A, B: pointer; Info: PRttiInfo; Count: PtrInt;
+  CaseInSensitive: boolean): integer; overload;
+
+/// comparison of two TObject published properties, using RTTI
+function ObjectCompare(A, B: TObject; CaseInSensitive: boolean): integer; overload;
+
+/// comparison of published properties of several TObject instances, using RTTI
+function ObjectCompare(A, B: PObject; Count: PtrInt;
+  CaseInsensitive: boolean = false): integer; overload;
+
+/// case-sensitive comparison of two TObject published properties, using RTTI
+function ObjectEquals(A, B: TObject): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// case-insensitive comparison of two TObject published properties, using RTTI
+function ObjectEqualsI(A, B: TObject): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+{$ifndef PUREMORMOT2}
+
+/// how many bytes a BinarySave() may return
+// - deprecated function - use overloaded BinarySave() functions instead
+function BinarySaveLength(Data: pointer; Info: PRttiInfo; Len: PInteger;
+  Kinds: TRttiKinds): integer; deprecated;
+
+/// binary persistence of any value using RTTI, into a memory buffer
+// - deprecated function - use overloaded BinarySave() functions instead
+function BinarySave(Data: pointer; Dest: PAnsiChar; Info: PRttiInfo;
+  out Len: integer; Kinds: TRttiKinds): PAnsiChar; overload; deprecated;
+
+{$endif PUREMORMOT2}
+
+/// binary persistence of any value using RTTI, into a RawByteString buffer
+function BinarySave(Data: pointer; Info: PRttiInfo; Kinds: TRttiKinds;
+  WithCrc: boolean = false): RawByteString; overload;
+
+/// binary persistence of any value using RTTI, into a TBytes buffer
+function BinarySaveBytes(Data: pointer; Info: PRttiInfo; Kinds: TRttiKinds): TBytes;
+
+/// binary persistence of any value using RTTI, into a TBufferWriter stream
+procedure BinarySave(Data: pointer; Info: PRttiInfo; Dest: TBufferWriter); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// binary persistence of any value using RTTI, into a TSynTempBuffer buffer
+procedure BinarySave(Data: pointer; var Dest: TSynTempBuffer;
+  Info: PRttiInfo; Kinds: TRttiKinds; WithCrc: boolean = false); overload;
+
+/// binary persistence of any value using RTTI, into a Base64-encoded text
+// - contains a trailing crc32c hash before the actual data
+function BinarySaveBase64(Data: pointer; Info: PRttiInfo; UriCompatible: boolean;
+  Kinds: TRttiKinds; WithCrc: boolean = true): RawUtf8;
+
+/// unserialize any value from BinarySave() memory buffer, using RTTI
+function BinaryLoad(Data: pointer; Source: PAnsiChar; Info: PRttiInfo;
+  Len: PInteger; SourceMax: PAnsiChar; Kinds: TRttiKinds;
+  TryCustomVariants: PDocVariantOptions = nil): PAnsiChar; overload;
+
+/// unserialize any value from BinarySave() RawByteString, using RTTI
+function BinaryLoad(Data: pointer; const Source: RawByteString; Info: PRttiInfo;
+  Kinds: TRttiKinds; TryCustomVariants: PDocVariantOptions = nil): boolean; overload;
+
+/// unserialize any value from BinarySaveBase64() encoding, using RTTI
+// - optionally contains a trailing crc32c hash before the actual data
+function BinaryLoadBase64(Source: PAnsiChar; Len: PtrInt; Data: pointer;
+  Info: PRttiInfo; UriCompatible: boolean; Kinds: TRttiKinds;
+  WithCrc: boolean = true; TryCustomVariants: PDocVariantOptions = nil): boolean;
+
+
+/// 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)
+// - is a wrapper around BinaryEquals(rkRecordTypes)
+function RecordEquals(const RecA, RecB; TypeInfo: PRttiInfo;
+  PRecSize: PInteger = nil; CaseInSensitive: boolean = false): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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 RTL 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
+// - is a wrapper around BinarySave(rkRecordTypes)
+function RecordSave(const Rec; TypeInfo: PRttiInfo): RawByteString; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// save a record content into a TBytes dynamic array
+// - could be used as an alternative to RawByteString's RecordSave()
+// - is a wrapper around BinarySaveBytes(rkRecordTypes)
+function RecordSaveBytes(const Rec; TypeInfo: PRttiInfo): TBytes;
+  {$ifdef HASINLINE}inline;{$endif}
+
+{$ifndef PUREMORMOT2}
+
+/// compute the number of bytes needed to save a record content
+// using the RecordSave() function
+// - deprecated function - use overloaded BinarySave() functions instead
+function RecordSaveLength(const Rec; TypeInfo: PRttiInfo;
+  Len: PInteger = nil): integer; deprecated;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// save a record content into a destination memory buffer
+// - Dest must be at least RecordSaveLength() bytes long
+// - deprecated function - use overloaded BinarySave() functions instead
+function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: PRttiInfo;
+  out Len: integer): PAnsiChar; overload; deprecated;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// save a record content into a destination memory buffer
+// - Dest must be at least RecordSaveLength() bytes long
+// - deprecated function - use overloaded BinarySave() functions instead
+function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: PRttiInfo): PAnsiChar;
+  overload; deprecated; {$ifdef HASINLINE}inline;{$endif}
+
+{$endif PUREMORMOT2}
+
+/// save a record content into a destination memory buffer
+// - caller should make Dest.Done once finished with Dest.buf/Dest.len buffer
+// - is a wrapper around BinarySave(rkRecordTypes)
+procedure RecordSave(const Rec; var Dest: TSynTempBuffer; TypeInfo: PRttiInfo); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// save a record content into a Base64 encoded UTF-8 text content
+// - will use RecordSave() format, with a left-sided binary CRC
+// - is a wrapper around BinarySaveBase64(rkRecordTypes)
+function RecordSaveBase64(const Rec; TypeInfo: PRttiInfo;
+  UriCompatible: boolean = false): RawUtf8;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fill a record content from a memory buffer as saved by RecordSave()
+// - return nil if the Source buffer is incorrect
+// - in case of success, return the memory buffer pointer just after the
+// read content, and set the Rec size, in bytes, into Len reference variable
+// - will use a proprietary binary format, with some variable-length encoding
+// of the string length - note that if you change the type definition, any
+// previously-serialized content will fail, maybe triggering unexpected GPF: you
+// may use TypeInfoToHash() if you share this binary data accross executables
+// - you should provide in SourceMax the first byte after the Source memory
+// buffer, which will be used to avoid any unexpected buffer overflow - clearly
+// mandatory when decoding the content from any external process (e.g. a
+// maybe-forged client) - with no performance penalty
+// - is a wrapper around BinaryLoad(rkRecordTypes)
+function RecordLoad(var Rec; Source: PAnsiChar; TypeInfo: PRttiInfo;
+  {$ifdef PUREMORMOT2} // SourceMax is manadatory for safety
+  Len: PInteger; SourceMax: PAnsiChar;
+  {$else}              // mORMot 1 compatibility mode
+  Len: PInteger = nil; SourceMax: PAnsiChar = nil;
+  {$endif PUREMORMOT2}
+  TryCustomVariants: PDocVariantOptions = nil): PAnsiChar; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fill a record content from a memory buffer as saved by RecordSave()
+// - will use the Source length to detect and avoid any buffer overlow
+// - returns false if the Source buffer was incorrect, true on success
+// - is a wrapper around BinaryLoad(rkRecordTypes)
+function RecordLoad(var Rec; const Source: RawByteString;
+  TypeInfo: PRttiInfo; TryCustomVariants: PDocVariantOptions = nil): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// read a record content from a Base64 encoded content
+// - expects RecordSaveBase64() format, with a left-sided binary CRC32C
+// - is a wrapper around BinaryLoadBase64(rkRecordTypes)
+function RecordLoadBase64(Source: PAnsiChar; Len: PtrInt; var Rec; TypeInfo: PRttiInfo;
+  UriCompatible: boolean = false; TryCustomVariants: PDocVariantOptions = nil): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// crc32c-based hash of a variant value
+// - complex string types will make up to 255 uppercase characters conversion
+// if CaseInsensitive is true
+// - you can specify your own hashing function if crc32c is not what you expect
+function VariantHash(const value: variant; CaseInsensitive: boolean;
+  Hasher: THasher = nil): cardinal;
+
+
+{ ************ TDynArray and TDynArrayHashed Wrappers }
+
+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
+  TOnDynArraySortCompare = function(const A, B): integer of object;
+
+  /// defined here as forward definition of the TRawUtf8Interning final class
+  TRawUtf8InterningAbstract = class(TSynPersistent);
+
+const
+  /// redirect to the proper SortDynArrayAnsiString/SortDynArrayAnsiStringI
+  SORT_LSTRING: array[{caseins=}boolean] of TDynArraySortCompare = (
+    {$ifdef CPUINTEL}
+    SortDynArrayAnsiString,
+    {$else}
+    SortDynArrayRawByteString,
+    {$endif CPUINTEL}
+    SortDynArrayAnsiStringI);
+
+{$ifndef PUREMORMOT2}
+
+type
+  /// internal enumeration used to specify some standard arrays
+  // - mORMot 1.18 did have two serialization engines - we unified it
+  // - defined only for backward compatible code; use TRttiParserType instead
+  TDynArrayKind = TRttiParserType;
+  TDynArrayKinds = TRttiParserTypes;
+
+const
+  /// deprecated TDynArrayKind enumerate mapping
+  // - defined only for backward compatible code; use TRttiParserType instead
+  djNone = ptNone;
+  djboolean = ptboolean;
+  djByte = ptByte;
+  djWord = ptWord;
+  djInteger = ptInteger;
+  djCardinal = ptCardinal;
+  djSingle = ptSingle;
+  djInt64 = ptInt64;
+  djQWord = ptQWord;
+  djDouble = ptDouble;
+  djCurrency = ptCurrency;
+  djTimeLog = ptTimeLog;
+  djDateTime = ptDateTime;
+  djDateTimeMS = ptDateTimeMS;
+  djRawUtf8 = ptRawUtf8;
+  djRawJson = ptRawJson;
+  djWinAnsi = ptWinAnsi;
+  djString = ptString;
+  djRawByteString = ptRawByteString;
+  djWideString = ptWideString;
+  djSynUnicode = ptSynUnicode;
+  djHash128 = ptHash128;
+  djHash256 = ptHash256;
+  djHash512 = ptHash512;
+  djVariant = ptVariant;
+  djCustom = ptCustom;
+  djPointer = ptPtrInt;
+  djObject = ptPtrInt;
+  djUnmanagedTypes = ptUnmanagedTypes;
+  djStringTypes = ptStringTypes;
+
+{$endif PUREMORMOT2}
+
+type
+  /// the kind of exceptions raised during TDynArray/TDynArrayHashed process
+  EDynArray = class(ESynException);
+
+  /// a pointer to a TDynArray Wrapper instance
+  PDynArray = ^TDynArray;
+
+  /// 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 Item" is not checked at compile time nor runtime:
+  // you must ensure that Item matchs the element type of the dynamic array;
+  // all Item*() methods will use pointers for safety
+  // - can use external Count storage to make Add() and Delete() much faster
+  // (avoid most reallocation of the memory buffer)
+  // - Note that TDynArray is just a wrapper around an existing dynamic array:
+  // methods can modify the content of the associated variable but the TDynArray
+  // doesn't contain any data by itself. It is therefore aimed to initialize
+  // a TDynArray wrapper on need, to access any existing dynamic array.
+  // - is defined as an object or as a record, due to a bug
+  // in Delphi 2009/2010 compiler (at least): this structure is not initialized
+  // if defined as an object on the stack, but will be as a record :(
+  {$ifdef UNDIRECTDYNARRAY}
+  TDynArray = record
+  {$else}
+  TDynArray = object
+  {$endif UNDIRECTDYNARRAY}
+  private
+    fValue: PPointer;
+    fInfo: TRttiCustom;
+    fCountP: PInteger;
+    fCompare: TDynArraySortCompare;
+    fSorted, fNoFinalize: boolean;
+    function GetCount: PtrInt;
+      {$ifdef HASINLINE}inline;{$endif}
+    procedure SetCount(aCount: PtrInt);
+    function GetCapacity: PtrInt;
+      {$ifdef HASINLINE}inline;{$endif}
+    procedure SetCapacity(aCapacity: PtrInt);
+    procedure SetCompare(const aCompare: TDynArraySortCompare);
+      {$ifdef HASINLINE}inline;{$endif}
+    function FindIndex(const Item; aIndex: PIntegerDynArray;
+      aCompare: TDynArraySortCompare): PtrInt;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// faster than RTL + handle T*ObjArray + ensure unique
+    procedure InternalSetLength(OldLength, NewLength: PtrUInt);
+  public
+    /// initialize the wrapper with a one-dimension dynamic array
+    // - the dynamic array must have been defined with its own type
+    // (e.g. TIntegerDynArray = array of integer)
+    // - if aCountPointer is set, it will be used instead of length() to store
+    // the dynamic array items count - it will be much faster when adding
+    // items 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 - to bypass this
+    // behavior and keep an existing Count, call UseExternalCount() after Init()
+    // - 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: PRttiInfo; var aValue; aCountPointer: PInteger = nil);
+    /// initialize the wrapper with a one-dimension dynamic array
+    // - also set the Compare() function from a supplied TRttiParserType
+    // - aKind=ptNone will guess the type from Info.ArrayRtti/ArrayFirstField
+    // - will raise an exception if there is not enough RTTI available
+    // - no RTTI check is made over the corresponding array layout: you shall
+    // ensure that the aKind parameter matches at least the first field of
+    // the dynamic array item definition
+    // - aCaseInsensitive will be used for ptStringTypes
+    function InitSpecific(aTypeInfo: PRttiInfo; var aValue; aKind: TRttiParserType;
+      aCountPointer: PInteger = nil; aCaseInsensitive: boolean = false): TRttiParserType;
+    /// set a specific TRttiParserType for this dynamic array
+    // - could be called after InitRtti() to set the Compare() function
+    // - as used by InitSpecific() after InitRtti(Rtti.RegisterType(aTypeInfo))
+    function SetParserType(aKind: TRttiParserType; aCaseInsensitive: boolean): TRttiParserType;
+    /// initialize the wrapper with a one-dimension dynamic array
+    // - low-level method, as called by Init() and InitSpecific()
+    // - can be called directly for a very fast TDynArray initialization
+    // - warning: caller should check that aInfo.Kind=rkDynArray
+    procedure InitRtti(aInfo: TRttiCustom; var aValue; aCountPointer: PInteger); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// initialize the wrapper with a one-dimension dynamic array
+    // - low-level method, as called by Init() and InitSpecific()
+    // - can be called directly for a very fast TDynArray initialization
+    // - warning: caller should check that aInfo.Kind=rkDynArray
+    procedure InitRtti(aInfo: TRttiCustom; var aValue); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// fast initialize a wrapper for an existing dynamic array of the same type
+    // - is slightly faster than
+    // ! InitRtti(aAnother.Info, aValue, nil);
+    procedure InitFrom(aAnother: PDynArray; var aValue);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// 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(aCountPointer: PInteger);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// initialize the wrapper to point to no dynamic array
+    // - it won't clear the wrapped array, just reset the fValue internal pointer
+    // - in practice, will disable the other methods
+    procedure Void;
+    /// check if the wrapper points to a dynamic array
+    // - i.e. if Void has been called before
+    function IsVoid: boolean;
+    /// add an element to the dynamic array
+    // - warning: Item 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 Item): PtrInt;
+    /// add an element to the dynamic array, returning its index
+    // - note: if you use this method to add a new item with a reference to the
+    // dynamic array, be aware that the following trigger a GPF on FPC:
+    // !    with Values[DynArray.New] do // otherwise Values is nil -> GPF
+    // !    begin
+    // !      Field1 := 1;
+    // !      ...
+    // - so you should either use a local variable:
+    // !    i := DynArray.New;
+    // !    with Values[i] do // otherwise Values is nil -> GPF
+    // !    begin
+    // - or even better, don't use the dubious "with Values[...] do" but NewPtr
+    function New: PtrInt;
+    /// add an element to the dynamic array, returning its pointer
+    // - a slightly faster alternative to ItemPtr(New)
+    function NewPtr: pointer;
+    /// add an element to the dynamic array at the position specified by Index
+    // - warning: Item 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 Item);
+    /// get and remove the last element stored in the dynamic array
+    // - Add + Pop/Peek will implement a LIFO (Last-In-First-Out) stack
+    // - warning: Dest 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, but just get its value
+    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: Dest 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;
+    /// get and remove the first element stored in the dynamic array
+    // - Add + PopHead/PeekHead will implement a FIFO (First-In-First-Out) stack
+    // - removing from head will move all items so TSynQueue is faster
+    // - warning: Dest must be of the same exact type than the dynamic array
+    // - returns true if the item was successfully copied and removed
+    // - use PeekHead() if you don't want to remove the item, but get its value
+    // - first slot will be deleted and all content moved, so may take some time
+    function PopHead(var Dest): boolean;
+    /// get the first element stored in the dynamic array
+    // - Add + PopHead/PeekHead will implement a FIFO (First-In-First-Out) stack
+    // - warning: Dest must be of the same exact type than the dynamic array
+    // - returns true if the item was successfully copied and removed
+    // - use PopHead() if you also want to remove the item
+    function PeekHead(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 occurred when calling Clear, false otherwise
+    // - you should better not call this method, which will catch and ignore
+    // all exceptions - but it may somewhat make sense in a destructor
+    // - this method will recognize T*ObjArray types and free all instances
+    function ClearSafe: boolean;
+    /// delete one item inside the dynamic array
+    // - the deleted element is finalized if necessary
+    // - this method will recognize T*ObjArray types and free all instances
+    function Delete(aIndex: PtrInt): boolean;
+    /// search for an element inside the dynamic array using RTTI
+    // - return the index found (0..Count-1), or -1 if Item was not found
+    // - will search for all properties content of Item: 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 fields) can be filled as random, and
+    // there is no way with standard RTTI to identify randomness from values
+    // - warning: Item 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 Item; CaseInSensitive: boolean = true): PtrInt;
+    /// search for an element inside the dynamic array using the Compare function
+    // - this method will use the Compare property function, or the supplied
+    // aCompare for the search; if none of them are set, it will fallback to
+    // IndexOf() to perform a default case-sensitive RTTI search
+    // - return the index found (0..Count-1), or -1 if Item 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: Item 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 Item; aCompare: TDynArraySortCompare = nil): PtrInt; overload;
+    /// search for an element value inside the dynamic array, from an external
+    // aIndex[] lookup table - e.g. created by CreateOrderedIndex()
+    // - return the index found (0..Count-1), or -1 if Item was not found
+    // - if an indexed lookup is supplied, it must already be sorted:
+    // this function will then use fast O(log(n)) binary search over aCompare
+    // - if the indexed lookup is not correct (e.g. aIndex=nil), iterate O(n)
+    // using aCompare - it won't fallback to IndexOf() RTTI search
+    // - warning: the lookup aIndex[] should be synchronized if array content
+    // is modified (in case of addition or deletion)
+    function Find(const Item; 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,
+    // and fallback to case-sensitive RTTI search if none is defined
+    // - if Item content matches, all Item 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 Item 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: Item 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 Item; 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,
+    // and fallback to case-sensitive RTTI search if none is defined
+    // - if Item 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 Item 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: Item 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 Item; 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,
+    // and fallback to case-sensitive RTTI search if none is defined
+    // - if Item 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 Item 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: Item 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 Item; 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,
+    // and fallback to case-sensitive RTTI search if none is defined
+    // - if no Item 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 Item was not found and
+    // the supplied element has been successfully 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: Item 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 Item; aIndex: PIntegerDynArray = nil;
+      aCompare: TDynArraySortCompare = nil): integer;
+    /// sort the dynamic array items, using the Compare property function
+    // - it will change the dynamic array content, and exchange all items
+    // in order to be sorted in increasing order according to Compare function
+    procedure Sort(aCompare: TDynArraySortCompare = nil); overload;
+    /// sort some dynamic array items, 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 items
+    // in order to be sorted in increasing order according to Compare function
+    procedure SortRange(aStart, aStop: integer;
+      aCompare: TDynArraySortCompare = nil);
+    /// will check all items against aCompare
+    function IsSorted(aCompare: TDynArraySortCompare = nil): boolean;
+    /// will check all items against aCompare, calling Sort() if needed
+    // - faster than plain Sort() if the array is likely to be already sorted
+    procedure EnsureSorted(aCompare: TDynArraySortCompare = nil);
+    /// sort the dynamic array items, using a Compare method (not function)
+    // - it will change the dynamic array content, and exchange all items
+    // 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: TOnDynArraySortCompare;
+      aReverse: boolean = false); overload;
+    /// search the items 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
+    // - warning: FirstIndex/LastIndex parameters should be integer, not PtrInt
+    function FindAllSorted(const Item;
+      out FirstIndex, LastIndex: integer): boolean; overload;
+    /// search the item pointers which match a given value in a sorted dynamic array
+    // - this method will use the Compare property function for the search
+    // - return nil and FindCount = 0 if no matching item was found
+    // - return the a pointer to the first matching item, and FindCount >=1
+    // - warning: FindCount out parameter should be integer, not PtrInt
+    function FindAllSorted(const Item; out FindCount: integer): pointer; overload;
+    /// 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 Item, or FALSE and the index
+    // where the Item 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: Item 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.)
+    // - warning: Index out parameter should be integer, not PtrInt
+    function FastLocateSorted(const Item; 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: PtrInt; const Item);
+    /// 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 Item and wasAdded^=false
+    // - returns the sorted index of the inserted Item and wasAdded^=true
+    // - if the array is not sorted, returns -1 and wasAdded^=false
+    // - is just a wrapper around FastLocateSorted+FastAddSorted
+    function FastLocateOrAddSorted(const Item; 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: PtrInt);
+    /// will reverse all array items, in place
+    procedure Reverse;
+    /// will call FillZero() on all items, mainly binaries and strings
+    // - could be used on a dynamic array to avoid memory forensic after release
+    procedure FillZero;
+    /// sort the dynamic array items 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 items than the main dynamic array,
+    // its content will be recreated
+    procedure CreateOrderedIndex(var aIndex: TIntegerDynArray;
+      aCompare: TDynArraySortCompare); overload;
+    /// sort the dynamic array items 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 using our binary serialization
+    // - 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
+    // - this method will raise an ESynException for T*ObjArray types
+    // - use TDynArray.LoadFrom to decode the saved buffer
+    // - warning: legacy Hash32 checksum will be stored as 0, so may be refused
+    // by mORMot TDynArray.LoadFrom before 1.18.5966
+    procedure SaveTo(W: TBufferWriter); overload;
+    /// 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 to decode the saved buffer
+    // - warning: legacy Hash32 checksum will be stored as 0, so may be refused
+    // by mORMot TDynArray.LoadFrom before 1.18.5966
+    function SaveTo: RawByteString; overload;
+    /// unserialize dynamic array content from binary written by TDynArray.SaveTo
+    // - return nil if the Source buffer is incorrect: invalid type, wrong
+    // checksum, or SourceMax overflow
+    // - return a non nil pointer just after the Source content on success
+    // - this method will raise an ESynException for T*ObjArray types
+    function LoadFrom(Source: PAnsiChar;
+      {$ifdef PUREMORMOT2} // SourceMax is manadatory for safety
+      SourceMax: PAnsiChar): PAnsiChar;
+      {$else}             // mORMot 1 compatibility mode
+      SourceMax: PAnsiChar = nil): PAnsiChar;
+      {$endif PUREMORMOT2}
+    /// unserialize dynamic array content from binary written by TDynArray.SaveTo
+    procedure LoadFromReader(var Read: TFastReader);
+    /// unserialize the dynamic array content from a TDynArray.SaveTo binary string
+    // - same as LoadFrom, and will check for any buffer overflow since we
+    // know the actual end of input buffer
+    // - will read mORMot 1.18 binary content, but will ignore the Hash32
+    // stored checksum which is not needed any more
+    function LoadFromBinary(const Buffer: RawByteString): boolean;
+    /// serialize the dynamic array content as JSON
+    function SaveToJson(EnumSetsAsText: boolean = false;
+      reformat: TTextWriterJsonFormat = jsonCompact): RawUtf8; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// serialize the dynamic array content as JSON
+    procedure SaveToJson(out result: RawUtf8; EnumSetsAsText: boolean = false;
+      reformat: TTextWriterJsonFormat = jsonCompact); overload;
+    /// serialize the dynamic array content as JSON
+    // - is just a wrapper around TTextWriter.AddTypedJson()
+    // - this method will therefore recognize T*ObjArray types
+    procedure SaveToJson(out result: RawUtf8; Options: TTextWriterOptions;
+      ObjectOptions: TTextWriterWriteObjectOptions = [];
+      reformat: TTextWriterJsonFormat = jsonCompact); overload;
+    /// serialize the dynamic array content as JSON
+    // - is just a wrapper around TTextDateWTTextWriterriter.AddTypedJson()
+    // - this method will therefore recognize T*ObjArray types
+    procedure SaveToJson(W: TTextWriter;
+      ObjectOptions: TTextWriterWriteObjectOptions = []); 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
+    // Rtti.RegisterFromText/TRttiJson.RegisterCustomSerializer format
+    // - or any other kind of array as Base64 encoded binary stream precessed
+    // via JSON_BASE64_MAGIC_C (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
+    // - set e.g. @JSON_[mFast] as CustomVariantOptions parameter to handle
+    // complex JSON object or arrays as TDocVariant into variant fields
+    // - can use an associated TRawUtf8Interning instance for RawUtf8 values
+    // - warning: the content of P^ will be modified during parsing: make a
+    // local copy if it will be needed later (using e.g. the overloaded method)
+    function LoadFromJson(P: PUtf8Char; EndOfObject: PUtf8Char = nil;
+      CustomVariantOptions: PDocVariantOptions = nil; Tolerant: boolean = false;
+      Interning: TRawUtf8InterningAbstract = nil): PUtf8Char; overload;
+    /// load the dynamic array content from an UTF-8 encoded JSON buffer
+    // - this method will make a private copy of the JSON for in-place parsing
+    // - returns false in case of invalid input buffer, true on success
+    function LoadFromJson(const Json: RawUtf8;
+      CustomVariantOptions: PDocVariantOptions = nil; Tolerant: boolean = false;
+      Interning: TRawUtf8InterningAbstract = nil): boolean; overload;
+    ///  select a sub-section (slice) of a dynamic array content
+    procedure Slice(var Dest; Limit: cardinal; Offset: cardinal = 0);
+    /// assign the current dynamic array content into a variable
+    // - by default (Offset=Limit=0), the whole array is set with no memory
+    // (re)allocation, just finalize the Dest slot, then make Inc(RefCnt) and
+    // force the internal length/Capacity to equal Count
+    // - Offset/Limit could be used to create a new dynamic array with some part
+    // of the existing content (Offset<0 meaning from the end):
+    // ! SliceAsDynArray(DA);         // items 0..Count-1 (assign with refcount)
+    // ! SliceAsDynArray(DA, 10);     // items 10..Count-1
+    // ! SliceAsDynArray(DA, 0, 10);  // first 0..9 items
+    // ! SliceAsDynArray(DA, 10, 20); // items 10..29 - truncated if Count < 20
+    // ! SliceAsDynArray(DA, -10);    // last Count-10..Count-1 items
+    procedure SliceAsDynArray(Dest: PPointer; Offset: integer = 0;
+      Limit: integer = 0);
+    /// add items 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;
+    /// add items 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(aSource: PDynArray; aStartIndex: integer = 0;
+      aCount: integer = -1);
+    /// compare the content of the two arrays, returning TRUE if both match
+    // - use any supplied Compare property (unless ignorecompare=true), or
+    // following the RTTI element description on all array items
+    // - T*ObjArray kind of arrays will properly compare their properties
+    function Equals(B: PDynArray; IgnoreCompare: boolean = false;
+      CaseSensitive: boolean = true): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// compare the content of the two arrays
+    // - use any supplied Compare property (unless ignorecompare=true), or
+    // following the RTTI element description on all array items
+    // - T*ObjArray kind of arrays will properly compare their properties
+    function Compares(B: PDynArray; IgnoreCompare: boolean = false;
+      CaseSensitive: boolean = true): integer;
+    /// 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(Source: PDynArray; 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; MaxItem: 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);
+    /// 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 this (slightly)
+    // slower and more error prone method (such pointer access lacks of strong
+    // typing abilities), which is designed for TDynArray abstract/internal use
+    function ItemPtr(index: PtrInt): pointer;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// just a convenient wrapper of Info.Cache.ItemSize
+    function ItemSize: PtrUInt;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// will copy one element content from its index into another variable
+    // - do nothing and return false if index is out of range or Dest is nil
+    function ItemCopyAt(index: PtrInt; Dest: pointer): boolean;
+      {$ifdef FPC}inline;{$endif}
+    /// will move one element content from its index into another variable
+    // - will erase the internal item after copy
+    // - do nothing and return false if index is out of range or Dest is nil
+    function ItemMoveTo(index: PtrInt; Dest: pointer): boolean;
+    /// will copy one variable content into an indexed element
+    // - do nothing if index is out of range
+    // - ClearBeforeCopy will call ItemClear() before the copy, which may be safer
+    // if the source item is a copy of Values[index] with some dynamic arrays
+    procedure ItemCopyFrom(Source: pointer; index: PtrInt;
+      ClearBeforeCopy: boolean = false);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// compare the content of two items, returning TRUE if both values equal
+    // - use the Compare() property function (if set) or using Info.Cache.ItemInfo
+    // if available - and fallbacks to binary comparison
+    function ItemEquals(A, B: pointer; CaseInSensitive: boolean = false): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// compare the content of two items, returning -1, 0 or +1s
+    // - use the Compare() property function (if set) or using Info.Cache.ItemInfo
+    // if available - and fallbacks to binary comparison
+    function ItemCompare(A, B: pointer; CaseInSensitive: boolean = false): integer;
+    /// will reset the element content
+    // - i.e. release any managed type memory, and fill Item with zeros
+    procedure ItemClear(Item: pointer);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// will fill the element with some random content
+    // - this method is thread-safe using Rtti.DoLock/DoUnLock
+    procedure ItemRandom(Item: pointer);
+    /// will copy one element content
+    procedure ItemCopy(Source, Dest: pointer);
+      {$ifdef HASINLINE}{$ifndef ISDELPHI2009}inline;{$endif}{$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 ItemCopyFirstField(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 ItemLoad method later to retrieve its content
+    // - warning: Item must be of the same exact type than the dynamic array,
+    // and must be a reference to a variable (you can't write ItemSave(i+10) e.g.)
+    function ItemSave(Item: pointer): RawByteString;
+    /// load an array element as saved by the ItemSave method into Item variable
+    // - warning: Item must be of the same exact type than the dynamic array
+    procedure ItemLoad(Source, SourceMax: PAnsiChar; Item: pointer);
+    /// load an array element as saved by the ItemSave method
+    // - this overloaded method will retrieve the element as a memory buffer,
+    // which should be cleared by ItemLoadMemClear() before release
+    function ItemLoadMem(Source, SourceMax: PAnsiChar): RawByteString;
+    /// search for an array element as saved by the ItemSave method
+    // - same as ItemLoad() + Find()/IndexOf() + ItemLoadClear()
+    // - will call Find() method if Compare property is set
+    // - will call generic IndexOf() method if no Compare property is set
+    function ItemLoadFind(Source, SourceMax: PAnsiChar): integer;
+    /// finalize a temporary buffer used to store an element via ItemLoadMem()
+    // - will release any managed type referenced inside the RawByteString,
+    // then void the variable
+    // - is just a wrapper around ItemClear(pointer(ItemTemp)) + ItemTemp := ''
+    procedure ItemLoadMemClear(var ItemTemp: RawByteString);
+
+    /// retrieve or set the number of items of the dynamic array
+    // - same as length(DynArray) or SetLength(DynArray)
+    // - this property will recognize T*ObjArray types, so will free any stored
+    // instance if the array is sized down
+    property Count: PtrInt
+      read GetCount write SetCount;
+    /// the internal buffer capacity
+    // - if no external Count pointer was set with Init, is the same as Count
+    // - if an external Count pointer is set, you can set a value to this
+    // property before a massive use of the Add() method e.g.
+    // - if no external Count pointer is set, set a value to this property
+    // will affect the Count value, i.e. Add() will append after this count
+    // - this property will recognize T*ObjArray types, so will free any stored
+    // instance if the array is sized down
+    property Capacity: PtrInt
+      read GetCapacity write SetCapacity;
+    /// the compare function to be used for Sort and Find methods
+    // - by default, no comparison function is set
+    // - common functions exist for base types: e.g. SortDynArrayByte, SortDynArrayBoolean,
+    // SortDynArrayWord, SortDynArrayInteger, SortDynArrayCardinal, SortDynArraySingle,
+    // SortDynArrayInt64, SortDynArrayDouble, SortDynArrayAnsiString,
+    // SortDynArrayAnsiStringI, SortDynArrayString, SortDynArrayStringI,
+    // SortDynArrayUnicodeString, SortDynArrayUnicodeStringI
+    property Compare: TDynArraySortCompare
+      read fCompare write SetCompare;
+    /// must be TRUE if the array is currently in sorted order according to
+    // the compare function
+    // - Add/Delete/Insert/Load* methods will reset this property to false
+    // - Sort method will set this property to true
+    // - you MUST set this property to false if you modify the dynamic array
+    // content in your code, so that Find() won't try to wrongly use binary
+    // search in an unsorted array, and miss its purpose
+    property Sorted: boolean
+      read fSorted write fSorted;
+    /// can be set to TRUE to avoid any item finalization
+    // -  e.g. with T*ObjArray - handle with care to avoid memory leaks
+    property NoFinalize: boolean
+      read fNoFinalize write fNoFinalize;
+
+    /// low-level direct access to the storage variable
+    property Value: PPointer
+      read fValue;
+    /// low-level extended RTTI access
+    // - use e.g. Info.ArrayRtti to access the item RTTI, or Info.Cache.ItemInfo
+    // to get the managed item TypeInfo()
+    property Info: TRttiCustom
+      read fInfo;
+    /// low-level direct access to the external count (if defined at Init)
+    // - use UseExternalCount() after Init to avoid resetting the count to 0
+    property CountExternal: PInteger
+      read fCountP;
+  end;
+
+  /// just a wrapper record to join a TDynArray, its Count and a TRWLightLock
+  TDynArrayLocked = record
+    /// lightweight multiple Reads / exclusive Write non-upgradable lock
+    Safe: TRWLightLock;
+    /// the wrapper to a dynamic array
+    DynArray: TDynArray;
+    /// will store the length of the TDynArray
+    Count: integer;
+  end;
+
+
+{.$define DYNARRAYHASHCOLLISIONCOUNT} // to be defined also in test.core.base
+
+{$ifndef CPU32DELPHI} // Delphi Win32 compiler doesn't like Lemire algorithm
+
+  {$define DYNARRAYHASH_LEMIRE}
+  // use the Lemire 64-bit multiplication for faster hash reduction
+  // see https://lemire.me/blog/2016/06/27/a-fast-alternative-to-the-modulo-reduction
+  // - generate more collisions with crc32c, but is always faster -> enabled
+
+{$endif CPU32DELPHI}
+
+// use Power-Of-Two sizes for smallest HashTables[], to reduce the hash with AND
+// - and Delphi Win32 is not efficient at 64-bit multiplication, anyway
+{$define DYNARRAYHASH_PO2}
+
+// use 16-bit Hash table when indexes fit in a word (array Capacity < 65535)
+// - to reduce memory consumption and slightly enhance CPU cache efficiency
+// - e.g. arrays of size 1..127 use only 256*2=512 bytes for their hash table
+{$define DYNARRAYHASH_16BIT}
+
+{$ifdef DYNARRAYHASH_PO2}
+const
+  /// defined for inlining bitwise division in TDynArrayHasher.HashTableIndex
+  // - HashTableSize<=HASH_PO2 is expected to be a power of two (fast binary op);
+  // limit is set to 262,144 hash table slots (=1MB), for Capacity=131,072 items
+  // - above this limit, a set of increasing primes is used; using a prime as
+  // hashtable modulo enhances its distribution, especially for a weak hash function
+  // - 64-bit CPU and FPC can efficiently compute a prime reduction using Lemire
+  // algorithm, but power of two sizes still have a better practical performance
+  // for lower (and most common) content until it consumes too much memory
+  HASH_PO2 = 1 shl 18;
+{$endif DYNARRAYHASH_PO2}
+
+
+
+type
+  /// function prototype to be used for hashing of a dynamic array element
+  // - this function must use the supplied hasher on the Item data
+  TDynArrayHashOne = function(const Item; Hasher: THasher): cardinal;
+
+  /// event handler to be used for hashing of a dynamic array element
+  // - can be set as an alternative to TDynArrayHashOne
+  TOnDynArrayHashOne = function(const Item): cardinal of object;
+
+  TDynArrayHasherState = set of (
+    hasHasher
+    {$ifdef DYNARRAYHASH_16BIT} , hash16bit {$endif} );
+
+  /// implements O(1) lookup to any dynamic array content
+  // - this won't handle the storage process (like add/update), just efficiently
+  // maintain a hash table over an existing dynamic array: several TDynArrayHasher
+  // could be applied to a single TDynArray wrapper
+  // - TDynArrayHashed will use a TDynArrayHasher on its own storage
+  {$ifdef USERECORDWITHMETHODS}
+  TDynArrayHasher = record
+  {$else}
+  TDynArrayHasher = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    fDynArray: PDynArray;
+    fHashItem: TDynArrayHashOne;       // function
+    fEventHash: TOnDynArrayHashOne;    // function of object
+    fHashTableStore: TIntegerDynArray; // store 0 for void entry, or Index+1
+    fHashTableSize: integer;
+    fState: TDynArrayHasherState;
+    fCompare: TDynArraySortCompare;        // function
+    fEventCompare: TOnDynArraySortCompare; // function of object
+    fHasher: THasher;
+    function HashTableIndex(aHashCode: PtrUInt): PtrUInt;
+      {$ifdef HASINLINE}inline;{$endif}
+    function HashTableIndexToIndex(aHashTableIndex: PtrInt): PtrInt;
+      {$ifdef HASINLINE}inline;{$endif}
+    procedure HashAdd(aHashCode: cardinal; var result: PtrInt);
+    procedure HashDelete(aArrayIndex, aHashTableIndex: PtrInt; aHashCode: cardinal);
+    procedure RaiseFatalCollision(const caller: shortstring; aHashCode: cardinal);
+    procedure HashTableInit(aHasher: THasher);
+    procedure SetEventCompare(const Value: TOnDynArraySortCompare);
+    procedure SetEventHash(const Value: TOnDynArrayHashOne);
+  public
+    {$ifdef DYNARRAYHASHCOLLISIONCOUNT}
+    /// low-level access to an hash collisions counter for all instance live
+    CountCollisions: cardinal;
+    /// low-level access to an hash collisions counter for the last HashTable[]
+    CountCollisionsCurrent: cardinal;
+    /// low-level access to the size of the internal HashTable[]
+    HashTableSize: integer;
+    {$endif DYNARRAYHASHCOLLISIONCOUNT}
+    /// initialize the hash table for a given dynamic array storage
+    // - you can call this method several times, e.g. if aCaseInsensitive changed
+    procedure Init(aDynArray: PDynArray; aHashItem: TDynArrayHashOne;
+      const aEventHash: TOnDynArrayHashOne; aHasher: THasher; aCompare: TDynArraySortCompare;
+      const aEventCompare: TOnDynArraySortCompare; aCaseInsensitive: boolean);
+    /// initialize a known hash table for a given dynamic array storage
+    // - you can call this method several times, e.g. if aCaseInsensitive changed
+    procedure InitSpecific(aDynArray: PDynArray; aKind: TRttiParserType;
+      aCaseInsensitive: boolean; aHasher: THasher);
+    /// search for an element value inside the dynamic array without hashing
+    function Scan(Item: pointer): PtrInt;
+    /// search for an element value inside the dynamic array with hashing
+    function Find(Item: pointer): PtrInt; overload;
+    /// search for a hashed element value inside the dynamic array with hashing
+    function Find(Item: pointer; aHashCode: cardinal): PtrInt; overload;
+    /// search for a hash position inside the dynamic array with hashing
+    function Find(aHashCode: cardinal; aForAdd: boolean): PtrInt; overload;
+    /// returns position in array, or next void index in HashTable[] as -(index+1)
+    function FindOrNew(aHashCode: cardinal; Item: pointer; aHashTableIndex: PPtrInt): PtrInt;
+    /// returns position in array, or -1 if not found with a custom comparer
+    function FindOrNewComp(aHashCode: cardinal; Item: pointer;
+      Comp: TDynArraySortCompare = nil): PtrInt;
+    /// search an hashed element value for adding, updating the internal hash table
+    // - trigger hashing if Count reaches CountTrigger
+    function FindBeforeAdd(Item: pointer; out wasAdded: boolean;
+      aHashCode: cardinal): PtrInt;
+    /// search and delete an element value, updating the internal hash table
+    function FindBeforeDelete(Item: pointer): PtrInt;
+    /// full computation of the internal hash table
+    // - to be called after items have been manually updated - e.g. after Clear
+    // - can return the number of duplicated values found (likely to be 0)
+    procedure ForceReHash(duplicates: PInteger = nil);
+    {$ifndef PUREMORMOT2}
+    function ReHash(forced: boolean = false): integer;
+    {$endif PUREMORMOT2}
+    /// compute the hash of a given item
+    function HashOne(Item: pointer): cardinal;
+      {$ifdef FPC_OR_DELPHIXE4}inline;{$endif}
+      { not inlined to circumvent Delphi 2007=C1632, 2010=C1872, XE3=C2130 }
+    /// compare one given item from its index with a value
+    // - using either EventCompare() or Compare() functions
+    function Equals(Item: pointer; ndx: PtrInt): boolean;
+       {$ifdef FPC_OR_DELPHIXE4}inline;{$endif}
+    /// retrieve the low-level hash of a given item
+    function GetHashFromIndex(aIndex: PtrInt): cardinal;
+    /// associated item comparison - may differ from DynArray^.Compare
+    property Compare: TDynArraySortCompare
+      read fCompare;
+    /// custom method-based comparison function
+    // - should be set just after Init, when no item has been stored
+    property EventCompare: TOnDynArraySortCompare
+      read fEventCompare write SetEventCompare;
+    /// custom method-based hashing function
+    // - should be set just after Init, when no item has been stored
+    property EventHash: TOnDynArrayHashOne
+      read fEventHash write SetEventHash;
+    /// associated item hasher
+    property Hasher: THasher
+      read fHasher;
+  end;
+
+  /// pointer to a TDynArrayHasher instance
+  PDynArrayHasher = ^TDynArrayHasher;
+
+type
+  /// used to access any dynamic arrray items 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 re-hashing for FindHashedForAdding+FindHashedAndUpdate)
+  // - consider using TSynDictionary from mormot.core.json for a thread-safe
+  // stand-alone storage of key/value pairs
+  {$ifdef UNDIRECTDYNARRAY}
+  TDynArrayHashed = record
+  // pseudo inheritance for most used methods
+  private
+    function GetCount: PtrInt; inline;
+    procedure SetCount(aCount: PtrInt); inline;
+    procedure SetCapacity(aCapacity: PtrInt); inline;
+    function GetCapacity: PtrInt; inline;
+  public
+    InternalDynArray: TDynArray;
+    function Value: PPointer; inline;
+    function ItemSize: PtrUInt; inline;
+    function Info: TRttiCustom; inline;
+    procedure Clear; inline;
+    procedure ItemCopy(Source, Dest: pointer); inline;
+    function ItemPtr(index: PtrInt): pointer; inline;
+    function ItemCopyAt(index: PtrInt; Dest: pointer): boolean; inline;
+    function Add(const Item): PtrInt; inline;
+    procedure Delete(aIndex: PtrInt); inline;
+    function SaveTo: RawByteString; overload; inline;
+    procedure SaveTo(W: TBufferWriter); overload; inline;
+    procedure Sort(aCompare: TDynArraySortCompare = nil); inline;
+    function SaveToJson(EnumSetsAsText: boolean = false;
+      reformat: TTextWriterJsonFormat = jsonCompact): RawUtf8; overload; inline;
+    procedure SaveToJson(out result: RawUtf8; EnumSetsAsText: boolean = false;
+      reformat: TTextWriterJsonFormat = jsonCompact); overload; inline;
+    procedure SaveToJson(W: TTextWriter); overload; inline;
+    function LoadFromJson(P: PUtf8Char; aEndOfObject: PUtf8Char = nil;
+      CustomVariantOptions: PDocVariantOptions = nil): PUtf8Char; inline;
+    function LoadFrom(Source: PAnsiChar; SourceMax: PAnsiChar
+      {$ifndef PUREMORMOT2} = nil{$endif}): PAnsiChar; inline;
+    function LoadFromBinary(const Buffer: RawByteString): boolean; inline;
+    procedure CreateOrderedIndex(var aIndex: TIntegerDynArray;
+      aCompare: TDynArraySortCompare);
+    property Count: PtrInt read GetCount write SetCount;
+    property Capacity: PtrInt read GetCapacity write SetCapacity;
+  private
+  {$else UNDIRECTDYNARRAY}
+  TDynArrayHashed = object(TDynArray)
+  protected
+  {$endif UNDIRECTDYNARRAY}
+    fHash: TDynArrayHasher;
+    function GetHashFromIndex(aIndex: PtrInt): cardinal;
+      {$ifdef HASINLINE}inline;{$endif}
+    procedure SetEventCompare(const cmp: TOnDynArraySortCompare);
+    procedure SetEventHash(const hsh: TOnDynArrayHashOne);
+  public
+    /// initialize the wrapper with a one-dimension dynamic array
+    // - this version accepts some hash-dedicated parameters: aHashItem to
+    // set how to hash each element, aCompare to handle hash collision
+    // - if no aHashItem 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: PRttiInfo; var aValue; aHashItem: TDynArrayHashOne = nil;
+      aCompare: TDynArraySortCompare = nil; aHasher: THasher = nil;
+      aCountPointer: PInteger = nil; aCaseInsensitive: boolean = false);
+    /// initialize the wrapper with a one-dimension dynamic array from our RTTI
+    procedure InitRtti(aRtti: TRttiCustom; var aValue; aHashItem: 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 TRttiParserType 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: PRttiInfo; var aValue; aKind: TRttiParserType;
+      aCountPointer: PInteger = nil; aCaseInsensitive: boolean = false;
+      aHasher: THasher = nil);
+    /// will recompute all hash from the current items of the dynamic array
+    // - can be called on purpose, when modifications have been performed on
+    // the dynamic array content (e.g. in case of element deletion or update,
+    // or after calling LoadFrom/Clear method) - this is not necessary after
+    // FindHashedForAdding / FindHashedAndUpdate / FindHashedAndDelete methods
+    // - returns the number of duplicated items found - which should be 0
+    procedure ForceReHash;
+      {$ifdef HASINLINE} inline; {$endif}
+    {$ifndef PUREMORMOT2}
+    function ReHash(forced: boolean = false): integer;
+    {$endif PUREMORMOT2}
+    /// search for an element value inside the dynamic array using hashing
+    // - Item should be of the type expected by both the hash function and
+    // Equals/Compare methods: e.g. if the searched/hashed field in a record is
+    // a string as first field, you can safely use a string variable as Item
+    // - Item must refer to a variable: e.g. you can't write FindHashed(i+10)
+    // - will call fHashItem(Item,fHasher) to compute the needed hash
+    // - returns -1 if not found, or the index in the dynamic array if found
+    function FindHashed(const Item): PtrInt;
+      {$ifdef FPC} inline; {$endif}
+    /// search for an element value inside the dynamic array using its hash
+    // - returns -1 if not found, or the index in the dynamic array if found
+    // - aHashCode parameter constains an already hashed value of the item,
+    // to be used e.g. after a call to HashFind()
+    function FindFromHash(const Item; aHashCode: cardinal): PtrInt;
+    /// search for an element value inside the dynamic array using hashing, and
+    // fill ItemToFill with the found content
+    // - return the index found (0..Count-1), or -1 if Item was not found
+    // - ItemToFill should be of the type expected by the dynamic array, since
+    // all its fields will be set on match
+    function FindHashedAndFill(var ItemToFill): PtrInt;
+    /// search for an element value inside the dynamic array using hashing, and
+    // add a void entry to the array if was not found (unless noAddEntry is set)
+    // - this method will use hashing for fast retrieval
+    // - Item should be of the type expected by both the hash function and
+    // Equals/Compare methods: e.g. if the searched/hashed field in a record is
+    // a string as first field, you can safely use a string variable as Item
+    // - 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, Item is used only for searching,
+    // not copied to the newly created entry in the array  - check
+    // FindHashedAndUpdate() for a method actually copying Item fields
+    function FindHashedForAdding(const Item; out wasAdded: boolean;
+      noAddEntry: boolean = false): PtrInt; overload;
+    /// search for an element value inside the dynamic array using hashing, and
+    // add a void entry to the array if was not found (unless noAddEntry is set)
+    // - overloaded method accepting an already hashed value of the item, to be
+    // used e.g. after a call to HashFind()
+    function FindHashedForAdding(const Item; out wasAdded: boolean;
+      aHashCode: cardinal; noAddEntry: boolean = false): PtrInt; overload;
+    /// ensure a given element name is unique, then add it to the array
+    // - expected element layout is to have a RawUtf8 field at first position
+    // - the aName is searched (using hashing) to be unique, and if not the case,
+    // an ESynException.CreateUtf8() is raised with the supplied arguments
+    // - use internally FindHashedForAdding method
+    // - this version will set the field content with the unique value
+    // - returns a pointer to the newly added element (to set other fields)
+    function AddUniqueName(const aName: RawUtf8; const ExceptionMsg: RawUtf8;
+      const ExceptionArgs: array of const;
+      aNewIndex: PPtrInt = nil): pointer; overload;
+    /// ensure a given element name is unique, then add it to the array
+    // - just a wrapper to AddUniqueName(aName,'',[],aNewIndex)
+    function AddUniqueName(const aName: RawUtf8;
+      aNewIndex: PPtrInt = nil): pointer; overload;
+    /// search for a given element name, make it unique, and add it to the array
+    // - expected element layout is to have a RawUtf8 field at first position
+    // - the aName is searched (using hashing) to be unique, and if not the case,
+    // some suffix is added to make it unique, counting from _1 to _999
+    // - use internally FindHashedForAdding method
+    // - this version will set the field content with the unique value
+    // - returns a pointer to the newly added element (to set other fields)
+    function AddAndMakeUniqueName(aName: RawUtf8): pointer;
+    /// search for an element value inside the dynamic array using hashing, then
+    // update any matching item, or add the item if none matched
+    // - by design, hashed field shouldn't have been modified by this update,
+    // otherwise the method won't be able to find and update the old hash: in
+    // this case, you should first call FindHashedAndDelete(OldItem) then
+    // FindHashedForAdding(NewItem) to properly handle the internal hash table
+    // - if AddIfNotExisting is FALSE, returns the index found (0..Count-1),
+    // or -1 if Item 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 Item value was not matching -
+    // add won't rehash all content - for even faster process (avoid rehash),
+    // please set the Capacity property
+    // - Item should be of the type expected by the dynamic array, since its
+    // content will be copied into the dynamic array, and it must refer to a
+    // variable: e.g. you can't write FindHashedAndUpdate(i+10)
+    function FindHashedAndUpdate(const Item; AddIfNotExisting: boolean): PtrInt;
+    /// 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 Item was not found
+    // - can optionally copy the deleted item to FillDeleted^ before erased
+    // - Item should be of the type expected by both the hash function and
+    // Equals/Compare methods, and must refer to a variable: e.g. you can't
+    // write FindHashedAndDelete(i+10)
+    // - it won't call slow ForceReHash but refresh the hash table as needed
+    function FindHashedAndDelete(const Item; FillDeleted: pointer = nil;
+      noDeleteEntry: boolean = false): PtrInt;
+    /// search for an element value inside the dynamic array without hashing
+    // - is preferred to Find(), since EventCompare would be used if defined
+    // - Item should be of the type expected by both the hash function and
+    // Equals/Compare methods, and must refer to a variable: e.g. you can't
+    // write Scan(i+10)
+    // - returns -1 if not found, or the index in the dynamic array if found
+    function Scan(const Item): PtrInt;
+    /// 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
+    // - should be set just after Init, when not item has been stored
+    property EventCompare: TOnDynArraySortCompare
+      read fHash.fEventCompare write SetEventCompare;
+    /// custom hash function used for hashing of a dynamic array element
+    property HashItem: TDynArrayHashOne
+      read fHash.fHashItem;
+    /// alternative event-oriented Hash function
+    // - this object-oriented callback will be used instead of HashItem()
+    // on each dynamic array entries - HashItem will still be used on
+    // const Item values, since they may be just a sub part of the stored entry
+    // - should be set just after Init, when not item has been stored
+    property EventHash: TOnDynArrayHashOne
+      read fHash.fEventHash write SetEventHash;
+    /// access to the internal hash table
+    // - you can call e.g. Hasher.Clear to invalidate the whole hash table
+    property Hasher: TDynArrayHasher
+      read fHash;
+  end;
+
+
+/// 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;
+// ! (...)
+// ! bin := DynArray(TypeInfo(TIntegerDynArray), IntArray).SaveTo;
+function DynArray(aTypeInfo: PRttiInfo; var aValue;
+  aCountPointer: PInteger = nil): TDynArray;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// get the hash function corresponding to a given standard array type
+// - as used e.g. internally by TDynArrayHasher.Init
+function DynArrayHashOne(Kind: TRttiParserType;
+  CaseInsensitive: boolean = false): TDynArrayHashOne;
+
+/// sort any dynamic array, generating 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 finshed
+procedure DynArraySortIndexed(Values: pointer; ItemSize, Count: integer;
+  out Indexes: TSynTempBuffer; Compare: TDynArraySortCompare); overload;
+
+/// sort any dynamic array, via a supplied array of indexes
+// - this function expects Indexes[] to be already allocated and filled
+procedure DynArraySortIndexed(Values: pointer; ItemSize, Count: integer;
+  Indexes: PCardinalArray; Compare: TDynArraySortCompare); overload;
+
+/// get the comparison function corresponding to a given standard array type
+// - as used e.g. internally by TDynArray
+function DynArraySortOne(Kind: TRttiParserType; CaseInsensitive: boolean): TDynArraySortCompare;
+
+/// sort any TObjArray with a given comparison function
+procedure ObjArraySort(var aValue; Compare: TDynArraySortCompare;
+  CountPointer: PInteger = nil);
+
+
+{ *************** Integer Arrays Extended Process }
+
+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);
+
+/// 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: PtrInt): PtrInt; 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);
+
+/// 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: PtrInt): PtrInt; overload;
+
+/// low-level function called by DeduplicateInt64()
+// - warning: caller should ensure that last>0
+function DeduplicateInt64Sorted(val: PInt64Array; last: PtrInt): PtrInt;
+
+/// create a new 64-bit integer dynamic array with the values from another one
+procedure CopyInt64(const Source: TInt64DynArray; out Dest: TInt64DynArray);
+
+/// find the maximum 32-bit integer in Values[]
+function MaxInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt;
+  MaxStart: integer = -1): integer;
+
+/// sum all 32-bit integers in Values[]
+function SumInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt): integer;
+
+/// fill already allocated Reversed[] so that Reversed[Values[i]]=i
+procedure Reverse(const Values: TIntegerDynArray; ValuesCount: PtrInt;
+  Reversed: PIntegerArray);
+
+/// copy some Int64 values into an unsigned integer array
+procedure Int64ToUInt32(Values64: PInt64Array; Values32: PCardinalArray; Count: PtrInt);
+
+type
+  /// 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 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
+// - see also function MedianQuickSelectInteger() for PIntegerArray values
+// - returns the index of the median Value
+function MedianQuickSelect(const OnCompare: TOnValueGreater; n: integer;
+  var TempBuffer: TSynTempBuffer): integer;
+
+/// 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;
+
+
+/// fast search of a binary value position in a fixed-size array
+// - Count is the number of entries in P^[]
+// - return index of P^[index]=V^, comparing VSize bytes
+// - return -1 if Value was not found
+function AnyScanIndex(P, V: pointer; Count, VSize: PtrInt): PtrInt;
+
+/// fast search of a binary value position in a fixed-size array
+// - Count is the number of entries in P^[]
+function AnyScanExists(P, V: pointer; Count, VSize: PtrInt): boolean;
+  {$ifdef HASINLINE} inline; {$endif}
+
+
+{ ************ INI Files and In-memory Access }
+
+/// 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;
+  const DefaultValue: 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 internally fast FindIniEntry() function above
+function FindIniEntryFile(const FileName: TFileName;
+  const Section, Name: RawUtf8; const DefaultValue: 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 internally 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;
+  const DefaultValue: RawUtf8 = ''): 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 an array of upper values with left side matching,
+// and ending with nil - as expected by IdemPPChar(), i.e. with at least 2 chars
+function ExistsIniNameValue(P: PUtf8Char; const UpperName: RawUtf8;
+  UpperValues: PPAnsiChar): 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; const UpperName: RawUtf8): PtrInt;
+
+/// 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;
+
+/// fill a class Instance properties from an .ini content
+// - the class property fields are searched in the supplied main SectionName
+// - nested objects and multi-line text values are searched in their own section,
+// named from their section level and property (e.g. [mainprop.nested1.nested2])
+// - returns true if at least one property has been identified
+function IniToObject(const Ini: RawUtf8; Instance: TObject;
+  const SectionName: RawUtf8 = 'Main'; DocVariantOptions: PDocVariantOptions = nil;
+  Level: integer = 0): boolean;
+
+/// serialize a class Instance properties into an .ini content
+// - the class property fields are written in the supplied main SectionName
+// - nested objects and multi-line text values are written in their own section,
+// named from their section level and property (e.g. [mainprop.nested1.nested2])
+function ObjectToIni(const Instance: TObject; const SectionName: RawUtf8 = 'Main';
+  Options: TTextWriterWriteObjectOptions =
+    [woEnumSetsAsText, woRawBlobAsBase64, woHumanReadableEnumSetAsComment];
+    Level: integer = 0): RawUtf8;
+
+/// 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;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// search if the WebSocketUpgrade() header is present
+// - consider checking the hsrConnectionUpgrade flag instead
+function IsWebSocketUpgrade(headers: PUtf8Char): boolean;
+
+
+{ ************ RawUtf8 String Values Interning and TRawUtf8List }
+
+type
+  /// store a TRawUtf8DynArray with its efficient hash table
+  {$ifdef USERECORDWITHMETHODS}
+  TRawUtf8Hashed = record
+  {$else}
+  TRawUtf8Hashed = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    Count: integer;
+    Value: TRawUtf8DynArray;
+    Values: TDynArrayHashed;
+    /// initialize the RawUtf8 dynamic array and hasher
+    procedure Init;
+  end;
+
+  /// used to store one list of hashed RawUtf8 in TRawUtf8Interning pool
+  // - Delphi "object" is buggy on stack -> also defined as record with methods
+  // - each slot has its own TRWLightLock for efficient concurrent reads
+  {$ifdef USERECORDWITHMETHODS}
+  TRawUtf8InterningSlot = record
+  {$else}
+  TRawUtf8InterningSlot = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    fSafe: TRWLightLock;
+    fHash: TRawUtf8Hashed;
+  public
+    /// initialize the RawUtf8 slot (and its Safe mutex)
+    procedure Init;
+    /// returns the interned RawUtf8 value
+    procedure Unique(var aResult: RawUtf8; const aText: RawUtf8;
+      aTextHash: cardinal);
+    /// returns the interned RawUtf8 value
+    // - only allocates new aResult string if needed
+    procedure UniqueFromBuffer(var aResult: RawUtf8;
+      aText: PUtf8Char; aTextLen: PtrInt; aTextHash: cardinal);
+    /// ensure the supplied RawUtf8 value is interned
+    procedure UniqueText(var aText: RawUtf8; aTextHash: cardinal);
+    /// return the interned value, if any
+    function Existing(const aText: RawUtf8; aTextHash: cardinal): pointer;
+    /// delete all stored RawUtf8 values
+    procedure Clear;
+    /// reclaim any unique RawUtf8 values
+    // - any string with an usage count <= aMaxRefCount will be removed
+    function Clean(aMaxRefCount: TStrCnt): integer;
+    /// how many items are currently stored in Value[]
+    property Count: integer
+      read fHash.Count;
+  end;
+  PRawUtf8InterningSlot = ^TRawUtf8InterningSlot;
+
+  /// 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(TRawUtf8InterningAbstract)
+  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
+    // (1, 2, 4, 8, 16, 32, 64, 128, 256, 512)
+    constructor Create(aHashTables: integer = 4); reintroduce;
+    /// 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;
+    /// check if a RawUtf8 value is already stored within this class
+    // - if not existing, returns nil and don't add it to the pool
+    // - if existing, returns pointer(fValue[i]) of the unique stored RawUtf8
+    // - use e.g. for very fast per-pointer lookup of interned property names
+    function Existing(const aText: RawUtf8): pointer;
+    /// return a RawUtf8 variable stored within this class from a text buffer
+    // - if aText occurs for the first time, add it to the internal string pool
+    // - if aText does exist in the internal string pool, return the shared
+    // instance (with its reference counter increased), to reduce memory usage
+    function Unique(aText: PUtf8Char; aTextLen: PtrInt): RawUtf8; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// 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
+    // - this method won't allocate any memory if aText is already interned
+    procedure Unique(var aResult: RawUtf8; aText: PUtf8Char; aTextLen: PtrInt); overload;
+    /// 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);
+    /// return a variant containing a RawUtf8 stored within this class
+    // - similar to RawUtf8ToVariant(), but with string interning
+    // - see also UniqueVariant() from mormot.core.variants if you want to
+    // intern only non-numerical values
+    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 RTL string, which will
+    // be converted into a variant containing a RawUtf8 varString instance
+    procedure UniqueVariantString(var aResult: variant; const aText: string);
+    /// 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}
+    /// 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: TStrCnt = 1): integer;
+    /// how many items are currently stored in this instance
+    function Count: integer;
+  end;
+
+  /// possible values used by TRawUtf8List.Flags
+  TRawUtf8ListFlags = set of (
+    fObjectsOwned,
+    fCaseSensitive,
+    fNoDuplicate,
+    fOnChangeTrigerred,
+    fThreadSafe);
+
+  /// thread-safe TStringList-class optimized for our native UTF-8 string type
+  // - can optionally store associated some TObject instances
+  // - high-level methods of this class are thread-safe
+  // - if fNoDuplicate flag is defined, an internal hash table will be
+  // maintained to perform IndexOf() lookups in O(1) linear way
+  // - not thread-safe by default, unless fThreadSafe is set to use the TRWLock
+  TRawUtf8List = class(TSynPersistentRWLock)
+  protected
+    fCount: PtrInt;
+    fValue: TRawUtf8DynArray;
+    fValues: TDynArrayHashed;
+    fObjects: TObjectDynArray;
+    fFlags: TRawUtf8ListFlags;
+    fNameValueSep: AnsiChar;
+    fOnChange, fOnChangeBackupForBeginUpdate: TNotifyEvent;
+    fOnChangeLevel: integer;
+    function GetCount: PtrInt;
+      {$ifdef HASINLINE}inline;{$endif}
+    procedure SetCapacity(const capa: PtrInt);
+    function GetCapacity: PtrInt;
+    function Get(Index: PtrInt): RawUtf8;
+      {$ifdef HASINLINE}inline;{$endif}
+    procedure Put(Index: PtrInt; const Value: RawUtf8);
+    function GetS(Index: PtrInt): string;
+    procedure PutS(Index: PtrInt; const Value: string);
+    function GetObject(Index: PtrInt): pointer;
+      {$ifdef HASINLINE}inline;{$endif}
+    procedure PutObject(Index: PtrInt; Value: pointer);
+    function GetName(Index: PtrInt): RawUtf8;
+    function GetValue(const Name: RawUtf8): RawUtf8;
+    procedure SetValue(const Name, Value: RawUtf8);
+    function GetTextCRLF: RawUtf8;
+    procedure SetTextCRLF(const Value: RawUtf8);
+    procedure SetTextPtr(P, PEnd: PUtf8Char; const Delimiter: RawUtf8);
+    function GetTextPtr: PPUtf8CharArray;
+      {$ifdef HASINLINE}inline;{$endif}
+    function GetNoDuplicate: boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    function GetObjectPtr: PPointerArray;
+      {$ifdef HASINLINE}inline;{$endif}
+    function GetCaseSensitive: boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    procedure SetCaseSensitive(Value: boolean); virtual;
+    procedure Changed; virtual;
+    procedure InternalDelete(Index: PtrInt);
+    procedure OnChangeHidden(Sender: TObject);
+    {$ifndef PUREMORMOT2}
+    procedure SetDefaultFlags; virtual;
+    {$endif PUREMORMOT2}
+  public
+    /// initialize the RawUtf8/Objects storage with [fCaseSensitive] flags
+    constructor Create; overload; override;
+    /// initialize the RawUtf8/Objects storage with extended flags
+    // - by default, any associated Objects[] are just weak references;
+    // you may supply fOwnObjects flag to force object instance management
+    // - if you want the stored text items to be unique, set fNoDuplicate
+    // and then an internal hash table will be maintained for fast IndexOf()
+    // - you can set fCaseSensitive to let the UTF-8 lookup be case-sensitive
+    // - not thread-safe by default, unless fThreadSafe is set to use a R/W lock
+    // - is defined as CreateEx instead of overload Create to avoid weird Delphi
+    // compilation issues, especially within packages
+    constructor CreateEx(aFlags: TRawUtf8ListFlags);
+    {$ifndef PUREMORMOT2}
+    /// backward compatiliby overloaded constructor
+    // - please rather use the overloaded CreateEx(TRawUtf8ListFlags)
+    // - for instance, Create(true) is CreateEx([fObjectsOwned, fCaseSensitive]);
+    constructor Create(aOwnObjects: boolean; aNoDuplicate: boolean = false;
+      aCaseSensitive: boolean = true); reintroduce; overload;
+    {$endif PUREMORMOT2}
+    /// finalize the internal objects stored
+    // - if instance was created with fOwnObjects flag
+    destructor Destroy; override;
+    /// get a stored Object item by its associated UTF-8 text
+    // - returns nil and raise no exception if aText doesn't exist
+    // - thread-safe method, unless returned TObject is deleted in the background
+    function GetObjectFrom(const aText: RawUtf8): pointer;
+    /// store a new RawUtf8 item
+    // - without the fNoDuplicate flag, it will always add the supplied value
+    // - if fNoDuplicate was set and aText already exists (using the internal
+    // hash table), it will return -1 unless aRaiseExceptionIfExisting is forced
+    // - thread-safe method
+    function Add(const aText: RawUtf8;
+      aRaiseExceptionIfExisting: boolean = false): PtrInt;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// store a new RawUtf8 item, and its associated TObject
+    // - without the fNoDuplicate flag, it will always add the supplied value
+    // - if fNoDuplicate was set and aText already exists (using the internal hash
+    // table), it will return -1 unless aRaiseExceptionIfExisting is forced;
+    // optionally freeing the supplied aObject if aFreeAndReturnExistingObject
+    // is set, in which pointer the existing Objects[] is copied (see
+    // AddObjectUnique as a convenient wrapper around this behavior);
+    // if aFreeAndReturnExistingObject is nil, and aReplaceExistingObject is
+    // true, the existing object is freed and replaced by aObject
+    // - thread-safe method
+    function AddObject(const aText: RawUtf8; aObject: TObject;
+      aRaiseExceptionIfExisting: boolean = false;
+      aFreeAndReturnExistingObject: PPointer = nil;
+      aReplaceExistingObject: boolean = false): PtrInt;
+    /// try to store a new RawUtf8 item and its associated TObject
+    // - fNoDuplicate should have been specified in the list flags
+    // - if aText doesn't exist, will add the values
+    // - if aText exist, will call aObjectToAddOrFree.Free and set the value
+    // already stored in Objects[] into aObjectToAddOrFree - allowing dual
+    // commit thread-safe update of the list, e.g. after a previous unsuccessful
+    // call to GetObjectFrom(aText)
+    // - thread-safe method, using an internal Hash Table to speedup IndexOf()
+    // - in fact, this method is just a wrapper around
+    // ! AddObject(aText,aObjectToAddOrFree^,false,@aObjectToAddOrFree);
+    procedure AddObjectUnique(const aText: RawUtf8; aObjectToAddOrFree: PPointer);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// force the storage of a RawUtf8 item, and its associated TObject
+    // - without the fNoDuplicate flag, it will always add the supplied value
+    // - if fNoDuplicate was set and aText already exists (using the internal hash
+    // table), it will free any existing Objects[] and put aObject in its place
+    // - thread-safe method, using an internal Hash Table to speedup IndexOf()
+    function AddOrReplaceObject(const aText: RawUtf8; aObject: TObject): PtrInt;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append a specified list to the current content
+    // - thread-safe method
+    procedure AddRawUtf8List(List: TRawUtf8List);
+    /// delete a stored RawUtf8 item, and its associated TObject
+    // - raise no exception in case of out of range supplied index
+    // - this method is not thread-safe: use Safe.Lock/UnLock if needed
+    procedure Delete(Index: PtrInt); overload;
+    /// delete a stored RawUtf8 item, and its associated TObject
+    // - will search for the value using IndexOf(aText), and returns its index
+    // - returns -1 if no entry was found and deleted
+    // - thread-safe method, using the internal Hash Table if fNoDuplicate is set
+    function Delete(const aText: RawUtf8): PtrInt; overload;
+    /// delete a stored RawUtf8 item, and its associated TObject, from
+    // a given Name when stored as 'Name=Value' pairs
+    // - raise no exception in case of out of range supplied index
+    // - thread-safe method, but not using the internal Hash Table
+    // - consider using TSynNameValue if you expect efficient name/value process
+    function DeleteFromName(const Name: RawUtf8): PtrInt; virtual;
+    /// find the index of a given Name when stored as 'Name=Value' pairs
+    // - search on Name is case-insensitive with 'Name=Value' pairs
+    // - this method is not thread-safe, and won't use the internal Hash Table
+    // - consider using TSynNameValue if you expect efficient name/value process
+    function IndexOfName(const Name: RawUtf8): PtrInt;
+    /// access to the Value of a given 'Name=Value' pair at a given position
+    // - this method is not thread-safe
+    // - consider using TSynNameValue if you expect efficient name/value process
+    function GetValueAt(Index: PtrInt): RawUtf8;
+    /// compare a Value with some RawUtf8 text
+    // - this method is not thread-safe
+    function EqualValueAt(Index: PtrInt; const aText: RawUtf8): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// retrieve Value from an existing Name=Value, then optinally delete the entry
+    // - if Name is found, will fill Value with the stored content and return true
+    // - if Name is not found, Value is not modified, and false is returned
+    // - thread-safe method, but not using the internal Hash Table
+    // - consider using TSynNameValue if you expect efficient name/value process
+    function UpdateValue(const Name: RawUtf8; var Value: RawUtf8;
+      ThenDelete: boolean): boolean;
+    /// retrieve and delete the first RawUtf8 item in the list
+    // - could be used as a FIFO, calling Add() as a "push" method
+    // - thread-safe method
+    function PopFirst(out aText: RawUtf8; aObject: PObject = nil): boolean;
+    /// retrieve and delete the last RawUtf8 item in the list
+    // - could be used as a FILO, calling Add() as a "push" method
+    // - thread-safe method
+    function PopLast(out aText: RawUtf8; aObject: PObject = nil): boolean;
+    /// erase all stored RawUtf8 items
+    // - and corresponding objects (if aOwnObjects was true at constructor)
+    // - thread-safe method, also clearing the internal Hash Table
+    procedure Clear; virtual;
+    /// find a RawUtf8 item in the stored Strings[] list
+    // - this search is case sensitive if fCaseSensitive flag was set (which
+    // is the default)
+    // - this method is not thread-safe since the internal list may change
+    // and the returned index may not be accurate any more
+    // - see also Exists() and GetObjectFrom() method
+    // - uses the internal Hash Table if fNoDuplicate was set
+    function IndexOf(const aText: RawUtf8): PtrInt;
+    /// find a RawUtf8 item in the stored Strings[] list
+    // - search is case sensitive if fCaseSensitive flag was set (default)
+    // - this method is thread-safe
+    // - uses the internal Hash Table if fNoDuplicate was set
+    function Exists(const aText: RawUtf8): boolean;
+    /// find a TObject item index in the stored Objects[] list
+    // - this method is not thread-safe since the internal list may change
+    // and the returned index may not be accurate any more
+    // - aObject lookup won't use the internal Hash Table
+    function IndexOfObject(aObject: TObject): PtrInt;
+    /// search for any RawUtf8 item containing some text
+    // - uses PosEx() on the stored lines
+    // - this method is not thread-safe since the internal list may change
+    // and the returned index may not be accurate any more
+    // - by design, aText lookup can't use the internal Hash Table
+    function Contains(const aText: RawUtf8; aFirstIndex: integer = 0): PtrInt;
+    /// retrieve the all lines, separated by the supplied delimiter
+    // - this method is thread-safe
+    function GetText(const Delimiter: RawUtf8 = #13#10): RawUtf8;
+    /// the OnChange event will be raised only when EndUpdate will be called
+    // - this method will also call Safe.Lock for thread-safety
+    procedure BeginUpdate;
+    /// call the OnChange event if changes occurred
+    // - this method will also call Safe.UnLock for thread-safety
+    procedure EndUpdate;
+    /// set low-level text and objects from existing arrays
+    procedure SetFrom(const aText: TRawUtf8DynArray; const aObject: TObjectDynArray);
+    /// set all lines, separated by the supplied delimiter
+    // - this method is thread-safe
+    procedure SetText(const aText: RawUtf8; const Delimiter: RawUtf8 = #13#10);
+    /// set all lines from a text file
+    // - will assume text file with no BOM is already UTF-8 encoded
+    // - this method is thread-safe
+    procedure LoadFromFile(const FileName: TFileName);
+    /// write all lines into the supplied stream
+    // - this method is thread-safe
+    procedure SaveToStream(Dest: TStream; const Delimiter: RawUtf8 = #13#10);
+    /// write all lines into a new UTF-8 file
+    // - this method is thread-safe
+    procedure SaveToFile(const FileName: TFileName; const Delimiter: RawUtf8 = #13#10);
+    /// return the count of stored RawUtf8
+    // - reading this property is not thread-safe, since size may change
+    property Count: PtrInt
+      read GetCount;
+    /// set or retrieve the current memory capacity of the RawUtf8 list
+    // - reading this property is not thread-safe, since size may change
+    property Capacity: PtrInt
+      read GetCapacity write SetCapacity;
+    /// set if IndexOf() shall be case sensitive or not
+    // - default is TRUE
+    // - matches fCaseSensitive in Flags
+    property CaseSensitive: boolean
+      read GetCaseSensitive write SetCaseSensitive;
+    /// set if the list doesn't allow duplicated UTF-8 text
+    // - if true, an internal hash table is maintained for faster IndexOf()
+    // - matches fNoDuplicate in Flags
+    property NoDuplicate: boolean
+      read GetNoDuplicate;
+    /// access to the low-level flags of this list
+    property Flags: TRawUtf8ListFlags
+      read fFlags write fFlags;
+    /// get or set a RawUtf8 item
+    // - returns '' and raise no exception in case of out of range supplied index
+    // - if you want to use it with the UI, use Utf8ToString() function
+    // - reading this property is not thread-safe, since content may change
+    property Strings[Index: PtrInt]: RawUtf8
+      read Get write Put; default;
+    /// get or set an item as RTL string, ready to be used with the UI
+    // - returns '' and raise no exception in case of out of range supplied index
+    // - wrap Strings[] with Utf8ToString/StringToUtf8 functions
+    // - reading this property is not thread-safe, since content may change
+    property Str[Index: PtrInt]: string
+      read GetS write PutS;
+    /// get or set a Object item
+    // - returns nil and raise no exception in case of out of range supplied index
+    // - reading this property is not thread-safe, since content may change
+    property Objects[Index: PtrInt]: pointer
+      read GetObject write PutObject;
+    /// retrieve the corresponding Name when stored as 'Name=Value' pairs
+    // - reading this property is not thread-safe, since content may change
+    // - consider TSynNameValue if you expect more efficient name/value process
+    property Names[Index: PtrInt]: RawUtf8
+      read GetName;
+    /// access to the corresponding 'Name=Value' pairs
+    // - search on Name is case-insensitive with 'Name=Value' pairs
+    // - reading this property is thread-safe, but won't use the hash table
+    // - consider TSynNameValue if you expect more efficient name/value process
+    property Values[const Name: RawUtf8]: RawUtf8
+      read GetValue write SetValue;
+    /// the char separator between 'Name=Value' pairs
+    // - equals '=' by default
+    // - consider TSynNameValue if you expect more efficient name/value process
+    property NameValueSep: AnsiChar
+      read fNameValueSep write fNameValueSep;
+    /// set or retrieve all items as text lines
+    // - lines are separated by #13#10 (CRLF) by default; use GetText and
+    // SetText methods if you want to use another line delimiter (even a comma)
+    // - this property is thread-safe
+    property Text: RawUtf8
+      read GetTextCRLF write SetTextCRLF;
+    /// Event triggered when an entry is modified
+    property OnChange: TNotifyEvent
+      read fOnChange write fOnChange;
+    /// direct access to the memory of the TRawUtf8DynArray items
+    // - reading this property is not thread-safe, since content may change
+    property TextPtr: PPUtf8CharArray
+      read GetTextPtr;
+    /// direct access to the memory of the TObjectDynArray items
+    // - reading this property is not thread-safe, since content may change
+    property ObjectPtr: PPointerArray
+      read GetObjectPtr;
+    /// direct access to the TRawUtf8DynArray instance
+    // - reading this property is not thread-safe, since content may change
+    property ValuePtr: TRawUtf8DynArray
+      read fValue;
+    /// direct access to the TRawUtf8DynArray items dynamic array wrapper
+    // - using this property is not thread-safe, since content may change
+    property ValuesArray: TDynArrayHashed
+      read fValues;
+  end;
+
+  PRawUtf8List = ^TRawUtf8List;
+
+{$ifndef PUREMORMOT2}
+
+  // some declarations used for backward compatibility only
+  TRawUtf8ListLocked = class(TRawUtf8List)
+    protected procedure SetDefaultFlags; override; end;
+  TRawUtf8ListHashed = class(TRawUtf8List)
+    protected procedure SetDefaultFlags; override; end;
+  TRawUtf8ListHashedLocked = class(TRawUtf8ListHashed)
+    protected procedure SetDefaultFlags; override; end;
+  // deprecated TRawUtf8MethodList should be replaced by a TSynDictionary
+
+{$endif PUREMORMOT2}
+
+/// 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);
+
+var
+  /// low-level JSON unserialization function
+  // - defined in this unit to avoid circular reference with mormot.core.json,
+  // but to publish the TDynArray.LoadFromJson overloaded methods
+  // - this unit will just set a wrapper raising an ERttiException
+  // - link mormot.core.json.pas to have a working implementation
+  // - rather call LoadJson() from mormot.core.json than this low-level function
+  GetDataFromJson: procedure(Data: pointer; var Json: PUtf8Char;
+    EndOfObject: PUtf8Char; Rtti: TRttiCustom;
+    CustomVariantOptions: PDocVariantOptions; Tolerant: boolean;
+    Interning: TRawUtf8InterningAbstract);
+
+
+{ ************ Abstract Radix Tree Classes }
+
+type
+  TRadixTree = class;
+
+  /// refine the TRadixTreeNode content
+  // - rtfParam is  node, i.e. a TRadixTreeNodeParams with Names <> nil
+  // - rtfParamInteger is for a rtfParam which value should be only an integer,
+  // either from rtoIntegerParams global flag, or individually as 
+  // - rtfParamPath is for a rtfParam which value should be the whole path,
+  // until the end of the URI or the beginning of the parameters (i.e. at '?'),
+  // set individually as  parameter - * being synonymous to 
+  TRadixTreeNodeFlags = set of (
+    rtfParam,
+    rtfParamInteger,
+    rtfParamPath);
+
+  /// implement an abstract Radix Tree node
+  TRadixTreeNode = class
+  protected
+    function ComputeDepth: integer;
+    procedure SortChildren;
+  public
+    /// the main Tree holding this node
+    Owner: TRadixTree;
+    /// the characters to be compared at this level
+    Chars: RawUtf8;
+    /// how many branches are within this node - used to sort by priority
+    Depth: integer;
+    /// describe the content of this node
+    Flags: TRadixTreeNodeFlags;
+    /// the nested nodes
+    Child: array of TRadixTreeNode;
+    /// the whole text up to this level
+    FullText: RawUtf8;
+    /// initialize this node instance
+    constructor Create(aOwner: TRadixTree); reintroduce;
+    /// instantiate a new node with the same class and properties
+    function Split(const Text: RawUtf8): TRadixTreeNode; virtual;
+    /// finalize this Radix Tree node
+    destructor Destroy; override;
+    /// search for the node corresponding to a given text
+    function Find(P: PUtf8Char): TRadixTreeNode;
+    /// internal debugging/testing method
+    procedure ToText(var Result: RawUtf8; Level: integer);
+  end;
+
+  /// our TRadixTree works on dynamic/custom types of node classes
+  TRadixTreeNodeClass = class of TRadixTreeNode;
+
+  /// allow to customize TRadixTree process
+  // - e.g. if static text matching should be case-insensitive (but  are
+  // always case-sensitive, because they are user-specific runtime variables)
+  // - if  values should be only plain integers, never alphabetical text -
+  // you may also specify int:xxx for a single parameter, e.g. as 
+  TRadixTreeOptions = set of (
+    rtoCaseInsensitiveUri,
+    rtoIntegerParams);
+
+  /// implement an abstract Radix Tree over UTF-8 case-insensitive text
+  // - as such, this class is not very useful if you just need to lookup for
+  // a text value: a TDynArrayHasher/TDictionary is faster and uses less RAM
+  // - but, once extended e.g. as TUriTree, it can very efficiently parse
+  // some text with variants parts (e.g. parameters)
+  TRadixTree = class
+  protected
+    fRoot: TRadixTreeNode;
+    fDefaultNodeClass: TRadixTreeNodeClass;
+    fOptions: TRadixTreeOptions;
+    fNormTable: PNormTable; // for efficient rtoCaseInsensitiveUri
+  public
+    /// initialize the Radix Tree
+    constructor Create(aNodeClass: TRadixTreeNodeClass;
+      aOptions: TRadixTreeOptions = []); reintroduce;
+    /// finalize this Radix Tree
+    destructor Destroy; override;
+    /// define how TRadixTreeNode.Lookup() will process this node
+    // - as set with this class constructor
+    property Options: TRadixTreeOptions
+      read fOptions;
+    /// finalize this Radix Tree node
+    procedure Clear;
+    /// low-level insertion of a given Text entry as a given child
+    // - may return an existing node instance, if Text was already inserted
+    function Insert(Text: RawUtf8; Node: TRadixTreeNode = nil;
+      NodeClass: TRadixTreeNodeClass = nil): TRadixTreeNode;
+    /// to be called after Insert() to consolidate the internal tree state
+    // - nodes will be sorted by search priority, i.e. the longest depths first
+    // - as called e.g. by TUriTree.Setup()
+    procedure AfterInsert;
+    /// search for the node corresponding to a given text
+    // - more than 6 million lookups per second, with 1000 items stored
+    function Find(const Text: RawUtf8): TRadixTreeNode;
+    /// internal debugging/testing method
+    function ToText: RawUtf8;
+    /// low-level access to the root node of the Radix Tree
+    property Root: TRadixTreeNode
+      read fRoot;
+  end;
+
+  /// implement an abstract Radix Tree static or  node
+  TRadixTreeNodeParams = class(TRadixTreeNode)
+  protected
+    /// is called for each  as Pos/Len pair
+    // - called eventually with Pos^='?' and Len=-1 for the inlined parameters
+    // - should return true on success, false to abort
+    function LookupParam(Ctxt: TObject; Pos: PUtf8Char; Len: integer): boolean;
+      virtual; abstract;
+  public
+    /// all the   names, in order, up to this parameter
+    // - equals nil for static nodes
+    // - is referenced as pointer into THttpServerRequestAbstract.fRouteName
+    Names: TRawUtf8DynArray;
+    /// overriden to support the additional Names fields
+    function Split(const Text: RawUtf8): TRadixTreeNode; override;
+    /// main search method, recognizing static or  patterns
+    function Lookup(P: PUtf8Char; Ctxt: TObject): TRadixTreeNodeParams;
+  end;
+
+  /// implement an abstract Radix Tree with static or  nodes
+  TRadixTreeParams = class(TRadixTree)
+  public
+    /// low-level registration of a new URI path, with  support
+    // - returns the node matching the given URI
+    // - called e.g. from TUriRouter.Rewrite/Run methods
+    // - will recognize  alphanumerical and  integer parameters
+    function Setup(const aFromUri: RawUtf8; out aNames: TRawUtf8DynArray): TRadixTreeNodeParams;
+  end;
+
+  ERadixTree = class(ESynException);
+
+
+implementation
+
+
+{ ************ RTL TPersistent / TInterfacedObject with Custom Constructor }
+
+{ TPersistentWithCustomCreate }
+
+constructor TPersistentWithCustomCreate.Create;
+begin
+  // nothing to do by default - overridden constructor may add custom code
+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;
+
+
+{ TInterfacedCollection }
+
+constructor TInterfacedCollection.Create;
+begin
+  inherited Create(GetClass);
+end;
+
+
+{ TSynInterfacedObject }
+
+constructor TSynInterfacedObject.Create;
+begin
+  // do-nothing virtual constructor
+end;
+
+function TSynInterfacedObject._AddRef: TIntCnt;
+begin
+  result := VirtualAddRef;
+end;
+
+function TSynInterfacedObject._Release: TIntCnt;
+begin
+  result := VirtualRelease;
+end;
+
+function TSynInterfacedObject.QueryInterface(
+  {$ifdef FPC_HAS_CONSTREF}constref{$else}const{$endif} IID: TGuid;
+  out Obj): TIntQry;
+begin
+  result := VirtualQueryInterface(@IID, Obj);
+end;
+
+function TSynInterfacedObject.VirtualQueryInterface(IID: PGuid; out Obj): TIntQry;
+begin
+  result := E_NOINTERFACE;
+end;
+
+
+{ TAutoFree }
+
+constructor TAutoFree.Create(var localVariable; obj: TObject);
+begin
+  fObject := obj;
+  TObject(localVariable) := obj;
+end;
+
+constructor TAutoFree.Create(const varObjPairs: array of pointer);
+var
+  n, i: PtrInt;
+begin
+  n := length(varObjPairs);
+  if (n = 0) or
+     (n and 1 = 1) then
+    exit;
+  n := n shr 1;
+  if n = 0 then
+    exit;
+  if n = 1 then
+  begin
+    fObject := varObjPairs[1];
+    PPointer(varObjPairs[0])^ := fObject;
+    exit;
+  end;
+  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.ForMethod;
+begin
+  // do-nothing method to circumvent the Delphi 10.4 IAutoFree early release
+end;
+
+class function TAutoFree.One(var localVariable; obj: TObject): IAutoFree;
+begin
+  result := Create(localVariable,obj);
+  {$ifdef ISDELPHI104}
+  result.ForMethod;
+  {$endif ISDELPHI104}
+end;
+
+class function TAutoFree.Several(const varObjPairs: array of pointer): IAutoFree;
+begin
+  result := Create(varObjPairs);
+  // inlining is not possible on Delphi -> Delphi 10.4 caller should run ForMethod :(
+end;
+
+procedure TAutoFree.Another(var localVariable; obj: TObject);
+var
+  n: PtrInt;
+begin
+  n := length(fObjectList);
+  SetLength(fObjectList, n + 1);
+  fObjectList[n] := obj;
+  TObject(localVariable) := obj;
+end;
+
+destructor TAutoFree.Destroy;
+var
+  i: PtrInt;
+begin
+  if fObjectList <> nil then
+    for i := length(fObjectList) - 1 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 Destroy;
+end;
+
+function TAutoLocker.ProtectMethod: IUnknown;
+begin
+  result := TAutoLock.Create(@fSafe);
+end;
+
+procedure TAutoLocker.Enter;
+begin
+  fSafe.Lock;
+end;
+
+procedure TAutoLocker.Leave;
+begin
+  fSafe.UnLock;
+end;
+
+function TAutoLocker.Safe: PSynLocker;
+begin
+  result := @fSafe;
+end;
+
+
+{ ************ TSynPersistent* / TSyn*List / TSynLocker classes }
+
+{ TSynPersistent }
+
+procedure TSynPersistent.AssignError(Source: TSynPersistent);
+begin
+  raise EConvertError.CreateFmt('Cannot assign a %s to a %s',
+    [ClassNameShort(Source)^, ClassNameShort(self)^]);
+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 HASITERATORS}
+
+{ TPointerEnumerator }
+
+procedure TPointerEnumerator.Init(Values: PPointerArray; Count: PtrUInt);
+begin
+  if Count = 0 then
+  begin
+    Curr := nil;
+    After := nil;
+  end
+  else
+  begin
+    Curr := pointer(Values);
+    After := @Values[Count];
+    dec(Curr);
+  end;
+end;
+
+function TPointerEnumerator.MoveNext: Boolean;
+begin
+  inc(Curr);
+  result := PtrUInt(Curr) < PtrUInt(After);
+end;
+
+function TPointerEnumerator.GetCurrent: pointer;
+begin
+  result := Curr^;
+end;
+
+function TPointerEnumerator.GetEnumerator: TPointerEnumerator;
+begin
+  result := self;
+end;
+
+{$endif HASITERATORS}
+
+{ TSynList }
+
+constructor TSynList.Create;
+begin
+  // nothing to do
+end;
+
+function TSynList.Add(item: pointer): PtrInt;
+begin
+  // inlined result := ObjArrayAddCount(fList, item, fCount);
+  result := fCount;
+  if result = length(fList) then
+    SetLength(fList, NextGrow(result));
+  fList[result] := item;
+  inc(fCount);
+end;
+
+function TSynList.Insert(item: pointer; index: PtrInt): PtrInt;
+begin
+  result := PtrArrayInsert(fList, item, index, fCount);
+end;
+
+procedure TSynList.Clear;
+begin
+  fList := nil;
+  fCount := 0;
+end;
+
+procedure TSynList.Delete(index: integer; dontfree: boolean);
+begin
+  PtrArrayDelete(fList, index, @fCount);
+  if (fCount > 64) and
+     (length(fList) > fCount * 2) then
+    SetLength(fList, fCount); // reduce capacity when half list is void
+end;
+
+function TSynList.Exists(item: pointer): boolean;
+begin
+  result := IndexOf(item) >= 0;
+end;
+
+function TSynList.Get(index: integer): pointer;
+begin
+  if cardinal(index) < cardinal(fCount) then
+    result := fList[index]
+  else
+    result := nil;
+end;
+
+function TSynList.IndexOf(item: pointer): PtrInt;
+begin
+  result := PtrUIntScanIndex(pointer(fList), fCount, PtrUInt(item));
+end;
+
+function TSynList.Remove(item: pointer): PtrInt;
+begin
+  result := IndexOf(item);
+  if result >= 0 then
+    Delete(result);
+end;
+
+{$ifdef HASITERATORS}
+
+function TSynList.GetEnumerator: TPointerEnumerator;
+begin
+  result.Init(pointer(fList), fCount);
+end;
+
+{$endif HASITERATORS}
+
+
+{ TSynObjectList }
+
+constructor TSynObjectList.Create(aOwnObjects: boolean; aItemClass: TClass);
+begin
+  fOwnObjects := aOwnObjects;
+  fItemClass := aItemClass;
+  inherited Create;
+end;
+
+procedure TSynObjectList.Delete(index: integer; dontfree: boolean);
+begin
+  if cardinal(index) >= cardinal(fCount) then
+    exit;
+  if fOwnObjects and
+     not dontfree then
+    TObject(fList[index]).Free;
+  inherited Delete(index);
+end;
+
+procedure TSynObjectList.Clear;
+begin
+  if fOwnObjects then
+    RawObjectsClear(pointer(fList), fCount);
+  inherited Clear;
+end;
+
+procedure TSynObjectList.ClearFromLast;
+var
+  i: PtrInt;
+begin
+  if fOwnObjects then
+    for i := fCount - 1 downto 0 do // call Free in reverse order
+      FreeAndNilSafe(fList[i]);     // safer
+  inherited Clear;
+end;
+
+destructor TSynObjectList.Destroy;
+begin
+  Clear;
+  inherited Destroy;
+end;
+
+function TSynObjectList.NewItem: pointer;
+begin
+  result := nil;
+  if fItemClass = nil then
+    exit;
+  result := Rtti.RegisterClass(fItemClass).ClassNewInstance;
+  Add(result);
+end;
+
+
+{ TSynPersistentLock }
+
+constructor TSynPersistentLock.Create;
+begin
+  inherited Create; // may have been overriden
+  fSafe := NewSynLocker;
+end;
+
+destructor TSynPersistentLock.Destroy;
+begin
+  inherited Destroy;
+  fSafe^.DoneAndFreeMem;
+end;
+
+procedure TSynPersistentLock.Lock;
+begin
+  if self <> nil then
+    fSafe^.Lock;
+end;
+
+procedure TSynPersistentLock.Unlock;
+begin
+  if self <> nil then
+    fSafe^.UnLock;
+end;
+
+class procedure TSynPersistentLock.RttiCustomSetParser(Rtti: TRttiCustom);
+begin
+  // let's call our overriden RttiBeforeWriteObject and RttiAfterWriteObject
+  Rtti.Flags := Rtti.Flags + [rcfHookWrite];
+end;
+
+function TSynPersistentLock.RttiBeforeWriteObject(W: TTextWriter;
+  var Options: TTextWriterWriteObjectOptions): boolean;
+begin
+  if woPersistentLock in Options then
+    fSafe.Lock;
+  result := false; // continue with default JSON serialization
+end;
+
+procedure TSynPersistentLock.RttiAfterWriteObject(W: TTextWriter;
+  Options: TTextWriterWriteObjectOptions);
+begin
+  if woPersistentLock in Options then
+    fSafe.UnLock;
+end;
+
+{ TInterfacedObjectLocked }
+
+constructor TInterfacedObjectLocked.Create;
+begin
+  inherited Create;
+  fSafe := NewSynLocker;
+end;
+
+destructor TInterfacedObjectLocked.Destroy;
+begin
+  inherited Destroy;
+  fSafe^.DoneAndFreeMem;
+end;
+
+
+{ TSynObjectListLocked }
+
+function TSynObjectListLocked.Add(item: pointer): PtrInt;
+begin
+  Safe.WriteLock;
+  try
+    result := inherited Add(item);
+  finally
+    Safe.WriteUnLock;
+  end;
+end;
+
+function TSynObjectListLocked.Remove(item: pointer): PtrInt;
+begin
+  Safe.WriteLock;
+  try
+    result := inherited Remove(item);
+  finally
+    Safe.WriteUnLock;
+  end;
+end;
+
+function TSynObjectListLocked.Exists(item: pointer): boolean;
+begin
+  Safe.ReadOnlyLock;
+  try
+    result := inherited Exists(item);
+  finally
+    Safe.ReadOnlyUnLock;
+  end;
+end;
+
+procedure TSynObjectListLocked.Clear;
+begin
+  Safe.WriteLock;
+  try
+    inherited Clear;
+  finally
+    Safe.WriteUnLock;
+  end;
+end;
+
+procedure TSynObjectListLocked.ClearFromLast;
+begin
+  Safe.WriteLock;
+  try
+    inherited ClearFromLast;
+  finally
+    Safe.WriteUnLock;
+  end;
+end;
+
+
+{ TSynObjectListSorted }
+
+constructor TSynObjectListSorted.Create(const aCompare: TOnObjectCompare;
+  aOwnsObjects: boolean);
+begin
+  inherited Create(aOwnsObjects);
+  fCompare := aCompare;
+end;
+
+function TSynObjectListSorted.Locate(item: pointer; out index: PtrInt): boolean;
+var
+  n, l, i: PtrInt;
+  cmp: integer;
+begin // see TDynArray.FastLocateSorted below
+  result := false;
+  n := fCount;
+  if n = 0 then // a void array is always sorted
+    index := 0
+  else
+  begin
+    dec(n);
+    cmp := fCompare(fList[n], item);
+    if cmp <= 0 then
+    begin
+      // greater than last sorted item (may be a common case)
+      if cmp = 0 then
+        // returns true + index of existing item
+        result := true
+      else
+        // returns false + insert after last position
+        inc(n);
+      index := n;
+      exit;
+    end;
+    l := 0;
+    repeat
+      // O(log(n)) binary search of the sorted position
+      i := (l + n) shr 1;
+      cmp := fCompare(fList[i], item);
+      if cmp = 0 then
+      begin
+        // returns true + index of existing item
+        index := i;
+        result := true;
+        exit;
+      end
+      else if cmp < 0 then
+        l := i + 1
+      else
+        n := i - 1;
+    until l > n;
+    // item not found: returns false + the index where to insert
+    index := l;
+  end;
+end;
+
+function TSynObjectListSorted.Add(item: pointer): PtrInt;
+begin
+  Safe.WriteLock;
+  try
+    if Locate(item, result) then // O(log(n)) binary search
+      result := -(result + 1)
+    else
+      Insert(item, result);
+  finally
+    Safe.WriteUnLock;
+  end;
+end;
+
+function TSynObjectListSorted.IndexOf(item: pointer): PtrInt;
+begin
+  if not Locate(item, result) then // O(log(n)) binary search
+    result := -1;
+end;
+
+function TSynObjectListSorted.Find(item: TObject): TObject;
+var
+  i: PtrInt;
+begin
+  if Locate(item, i) then
+    result := fList[i]
+  else
+    result := nil;
+end;
+
+
+{ ************ TSynPersistentStore with proper Binary Serialization }
+
+{ TSynPersistentStore }
+
+constructor TSynPersistentStore.Create(const aName: RawUtf8);
+begin
+  inherited Create; // may have been overriden
+  fName := aName;
+end;
+
+constructor TSynPersistentStore.CreateFrom(const aBuffer: RawByteString;
+  aLoad: TAlgoCompressLoad);
+begin
+  CreateFromBuffer(pointer(aBuffer), length(aBuffer), aLoad);
+end;
+
+constructor TSynPersistentStore.CreateFromBuffer(
+  aBuffer: pointer; aBufferLen: integer; aLoad: TAlgoCompressLoad);
+begin
+  inherited Create; // may have been overriden
+  LoadFrom(aBuffer, aBufferLen, aLoad);
+end;
+
+constructor TSynPersistentStore.CreateFromFile(const aFileName: TFileName;
+  aLoad: TAlgoCompressLoad);
+begin
+  inherited Create; // may have been overriden
+  LoadFromFile(aFileName, aLoad);
+end;
+
+procedure TSynPersistentStore.LoadFromReader;
+begin
+  fReader.VarUtf8(fName);
+end;
+
+procedure TSynPersistentStore.SaveToWriter(aWriter: TBufferWriter);
+begin
+  aWriter.Write(fName);
+end;
+
+procedure TSynPersistentStore.LoadFrom(const aBuffer: RawByteString;
+  aLoad: TAlgoCompressLoad);
+begin
+  if aBuffer <> '' then
+    LoadFrom(pointer(aBuffer), length(aBuffer), aLoad);
+end;
+
+procedure TSynPersistentStore.LoadFrom(aBuffer: pointer; aBufferLen: integer;
+  aLoad: TAlgoCompressLoad);
+var
+  localtemp: RawByteString;
+  p: pointer;
+  temp: PRawByteString;
+begin
+  if (aBuffer = nil) or
+     (aBufferLen <= 0) then
+    exit; // nothing to load
+  fLoadFromLastAlgo := TAlgoCompress.Algo(aBuffer, aBufferLen);
+  if fLoadFromLastAlgo = nil then
+    fReader.ErrorData('%.LoadFrom unknown TAlgoCompress AlgoID=%',
+      [self, PByteArray(aBuffer)[4]]);
+  temp := fReaderTemp;
+  if temp = nil then
+    temp := @localtemp;
+  p := fLoadFromLastAlgo.Decompress(aBuffer, aBufferLen,
+    fLoadFromLastUncompressed, temp^, aLoad);
+  if p = nil then
+    fReader.ErrorData('%.LoadFrom %.Decompress failed',
+      [self, fLoadFromLastAlgo]);
+  fReader.Init(p, fLoadFromLastUncompressed);
+  LoadFromReader;
+end;
+
+function TSynPersistentStore.LoadFromFile(const aFileName: TFileName;
+  aLoad: TAlgoCompressLoad): boolean;
+var
+  temp: RawByteString;
+begin
+  temp := StringFromFile(aFileName);
+  result := temp <> '';
+  if result then
+    LoadFrom(temp, aLoad);
+end;
+
+procedure TSynPersistentStore.SaveTo(out aBuffer: RawByteString;
+  nocompression: boolean; BufLen: integer; ForcedAlgo: TAlgoCompress;
+  BufferOffset: integer);
+var
+  writer: TBufferWriter;
+  temp: array[word] of byte;
+begin
+  if BufLen <= SizeOf(temp) then
+    writer := TBufferWriter.Create(TRawByteStringStream, @temp, SizeOf(temp))
+  else
+    writer := TBufferWriter.Create(TRawByteStringStream, BufLen);
+  try
+    SaveToWriter(writer);
+    fSaveToLastUncompressed := writer.TotalWritten;
+    aBuffer := writer.FlushAndCompress(nocompression, ForcedAlgo, BufferOffset);
+  finally
+    writer.Free;
+  end;
+end;
+
+function TSynPersistentStore.SaveTo(nocompression: boolean; BufLen: integer;
+  ForcedAlgo: TAlgoCompress; BufferOffset: integer): RawByteString;
+begin
+  SaveTo(result, nocompression, BufLen, ForcedAlgo, BufferOffset);
+end;
+
+function TSynPersistentStore.SaveToFile(const aFileName: TFileName;
+  nocompression: boolean; BufLen: integer; ForcedAlgo: TAlgoCompress): PtrUInt;
+var
+  temp: RawByteString;
+begin
+  SaveTo(temp, nocompression, BufLen, ForcedAlgo);
+  if FileFromString(temp, aFileName) then
+    result := length(temp)
+  else
+    result := 0;
+end;
+
+
+
+
+{ ************ INI Files and In-memory Access }
+
+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 FindSectionFirstLine(var source: PUtf8Char; search: PAnsiChar): boolean;
+var
+  table: PNormTable;
+  charset: PTextCharSet;
+begin
+  result := false;
+  if (source = nil) or
+     (search = nil) then
+    exit;
+  table := @NormToUpperAnsi7;
+  charset := @TEXT_CHARS;
+  repeat
+    if source^ = '[' then
+    begin
+      inc(source);
+      result := IdemPChar2(table, source, search);
+    end;
+    while tcNot01013 in charset[source^] do
+      inc(source);
+    while tc1013 in charset[source^] do
+      inc(source);
+    if result then
+      exit; // found
+  until source^ = #0;
+  source := nil;
+end;
+
+function FindSectionFirstLineW(var source: PWideChar; search: PUtf8Char): boolean;
+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;
+
+function FindIniNameValue(P: PUtf8Char; UpperName: PAnsiChar;
+  const DefaultValue: RawUtf8): RawUtf8;
+var
+  u, PBeg: PUtf8Char;
+  by4: cardinal;
+  {$ifdef CPUX86NOTPIC}
+  table: TNormTable absolute NormToUpperAnsi7;
+  {$else}
+  table: PNormTable;
+  {$endif CPUX86NOTPIC}
+begin
+  // expect UpperName as 'NAME='
+  if (P <> nil) and
+     (P^ <> '[') and
+     (UpperName <> nil) then
+  begin
+    {$ifndef CPUX86NOTPIC}
+    table := @NormToUpperAnsi7;
+    {$endif CPUX86NOTPIC}
+    PBeg := nil;
+    u := P;
+    repeat
+      while u^ = ' ' do
+        inc(u); // trim left ' '
+      if u^ = #0 then
+        break;
+      if table[u^] = UpperName[0] then
+        PBeg := u;
+      repeat
+        by4 := PCardinal(u)^;
+        if ToByte(by4) > 13 then
+          if ToByte(by4 shr 8) > 13 then
+            if ToByte(by4 shr 16) > 13 then
+              if ToByte(by4 shr 24) > 13 then
+              begin
+                inc(u, 4);
+                continue;
+              end
+              else
+                inc(u, 3)
+            else
+              inc(u, 2)
+          else
+            inc(u);
+        if u^ in [#0, #10, #13] then
+          break;
+        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 := DefaultValue;
+end;
+
+function ExistsIniName(P: PUtf8Char; UpperName: PAnsiChar): boolean;
+var
+  table: PNormTable;
+begin
+  result := false;
+  if (P <> nil) and
+     (P^ <> '[') then
+  begin
+    table := @NormToUpperAnsi7;
+    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;
+end;
+
+function ExistsIniNameValue(P: PUtf8Char; const UpperName: RawUtf8;
+  UpperValues: PPAnsiChar): boolean;
+var
+  table: PNormTable;
+begin
+  if (UpperValues <> nil) and
+     (UpperValues^ <> nil) and
+     (UpperName <> '') then
+  begin
+    result := true;
+    table := @NormToUpperAnsi7;
+    while (P <> nil) and
+          (P^ <> '[') do
+    begin
+      if P^ = ' ' then
+        repeat
+          inc(P)
+        until P^ <> ' '; // trim left ' '
+      if IdemPChar2(table, P, pointer(UpperName)) then
+      begin
+        inc(P, length(UpperName));
+        if IdemPPChar(P, UpperValues) >= 0 then
+          exit; // found one value
+        break;
+      end;
+      P := GotoNextLine(P);
+    end;
+  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{%H-}, SectionName))^ := ord(']');
+  if FindSectionFirstLine(P, UpperSection) then
+    result := GetSectionContent(P)
+  else
+    result := '';
+end;
+
+function DeleteSection(var Content: RawUtf8; const SectionName: RawUtf8;
+  EraseSectionHeader: boolean): boolean;
+var
+  P: PUtf8Char;
+  UpperSection: array[byte] of AnsiChar;
+begin
+  result := false; // no modification
+  P := pointer(Content);
+  PWord(UpperCopy255(UpperSection{%H-}, SectionName))^ := ord(']');
+  if FindSectionFirstLine(P, UpperSection) then
+    result := DeleteSection(P, Content, EraseSectionHeader);
+end;
+
+function DeleteSection(SectionFirstLine: PUtf8Char; var Content: RawUtf8;
+  EraseSectionHeader: boolean): boolean;
+var
+  PEnd: PUtf8Char;
+  IndexBegin: PtrInt;
+begin
+  result := false;
+  PEnd := SectionFirstLine;
+  if EraseSectionHeader then // erase [Section] header line
+    while (PtrUInt(SectionFirstLine) > PtrUInt(Content)) and
+          (SectionFirstLine^ <> '[') do
+      dec(SectionFirstLine);
+  while (PEnd <> nil) and
+        (PEnd^ <> '[') do
+    PEnd := GotoNextLine(PEnd);
+  IndexBegin := SectionFirstLine - pointer(Content);
+  if IndexBegin = 0 then
+    exit; // no modification
+  if PEnd = nil then
+    SetLength(Content, IndexBegin)
+  else
+    delete(Content, IndexBegin + 1, PEnd - SectionFirstLine);
+  result := true; // Content was modified
+end;
+
+procedure ReplaceSection(SectionFirstLine: PUtf8Char; var Content: RawUtf8;
+  const NewSectionContent: RawUtf8);
+var
+  PEnd: PUtf8Char;
+  IndexBegin: PtrInt;
+begin
+  if SectionFirstLine = nil then
+    exit;
+  // delete existing [Section] content
+  PEnd := SectionFirstLine;
+  while (PEnd <> nil) and
+        (PEnd^ <> '[') do
+    PEnd := GotoNextLine(PEnd);
+  IndexBegin := SectionFirstLine - pointer(Content);
+  if PEnd = nil then
+    SetLength(Content, IndexBegin)
+  else
+    delete(Content, IndexBegin + 1, PEnd - SectionFirstLine);
+  // insert section content
+  insert(NewSectionContent, Content, IndexBegin + 1);
+end;
+
+procedure ReplaceSection(var Content: RawUtf8; const SectionName, NewSectionContent: RawUtf8);
+var
+  UpperSection: array[byte] of AnsiChar;
+  P: PUtf8Char;
+begin
+  P := pointer(Content);
+  PWord(UpperCopy255(UpperSection{%H-}, SectionName))^ := ord(']');
+  if FindSectionFirstLine(P, UpperSection) then
+    ReplaceSection(P, Content, NewSectionContent)
+  else
+    Content := Content + '[' + SectionName + ']'#13#10 + NewSectionContent;
+end;
+
+function FindIniNameValueInteger(P: PUtf8Char; const UpperName: RawUtf8): PtrInt;
+var
+  table: PNormTable;
+begin
+  result := 0;
+  if (P = nil) or
+     (UpperName = '') then
+    exit;
+  table := @NormToUpperAnsi7;
+  repeat
+    if IdemPChar2(table, P, pointer(UpperName)) then
+      break;
+    P := GotoNextLine(P);
+    if P = nil then
+      exit;
+  until false;
+  result := GetInteger(P + length(UpperName));
+end;
+
+function FindIniEntry(const Content, Section, Name, DefaultValue: RawUtf8): RawUtf8;
+var
+  P: PUtf8Char;
+  UpperSection, UpperName: array[byte] of AnsiChar;
+begin
+  result := DefaultValue;
+  P := pointer(Content);
+  if P = nil then
+    exit;
+  // fast UpperName := UpperCase(Name)+'='
+  PWord(UpperCopy255(UpperName{%H-}, Name))^ := ord('=');
+  if Section = '' then
+    // find the Name= entry before any [Section]
+    result := FindIniNameValue(P, UpperName, DefaultValue)
+  else
+  begin
+    // find the Name= entry in the specified [Section]
+    PWord(UpperCopy255(UpperSection{%H-}, Section))^ := ord(']');
+    if FindSectionFirstLine(P, UpperSection) then
+      result := FindIniNameValue(P, UpperName, DefaultValue);
+  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, DefaultValue: RawUtf8): RawUtf8;
+var
+  Content: RawUtf8;
+begin
+  Content := StringFromFile(FileName);
+  if Content = '' then
+    result := DefaultValue
+  else
+    result := FindIniEntry(Content, Section, Name, DefaultValue);
+end;
+
+function UpdateIniNameValueInternal(var Content: RawUtf8;
+  const NewValue, NewValueCRLF: RawUtf8;
+  var P: PUtf8Char; UpperName: PAnsiChar; UpperNameLength: integer): boolean;
+var
+  PBeg: PUtf8Char;
+  i: integer;
+begin
+  if UpperName <> nil then
+    while (P <> nil) and
+          (P^ <> '[') do
+    begin
+      while P^ = ' ' do
+        inc(P);   // trim left ' '
+      PBeg := P;
+      P := GotoNextLine(P);
+      if IdemPChar2(@NormToUpperAnsi7, 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;
+    AppendLine(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;
+begin
+  UpperNameLength := length(Name);
+  PWord(UpperCopy255Buf(
+    UpperName{%H-}, pointer(Name), UpperNameLength))^ := ord('=');
+  inc(UpperNameLength);
+  V := Value + CRLF;
+  P := pointer(Content);
+  // 1. find Section, and try update within it
+  if Section = '' then
+    SectionFound := true // find the Name= entry before any [Section]
+  else
+  begin
+    PWord(UpperCopy255(UpperSection{%H-}, Section))^ := ord(']');
+    SectionFound := FindSectionFirstLine(P, UpperSection);
+  end;
+  if SectionFound and
+     UpdateIniNameValueInternal(
+       Content, Value, V, P, @UpperName, UpperNameLength) then
+      exit;
+  // 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 IsHtmlContentTypeTextual(Headers: PUtf8Char): boolean;
+begin
+  result := ExistsIniNameValue(Headers, HEADER_CONTENT_TYPE_UPPER, @CONTENT_TYPE_TEXTUAL);
+end;
+
+const
+  WS_UPGRADE: array[0..2] of PAnsiChar = (
+    'UPGRADE',
+    'KEEP-ALIVE, UPGRADE',
+    nil);
+
+function IsWebSocketUpgrade(headers: PUtf8Char): boolean;
+begin
+  result := ExistsIniNameValue(pointer(headers), 'CONNECTION: ', @WS_UPGRADE);
+end;
+
+function IniToObject(const Ini: RawUtf8; Instance: TObject;
+  const SectionName: RawUtf8; DocVariantOptions: PDocVariantOptions;
+  Level: integer): boolean;
+var
+  r: TRttiCustom;
+  i: integer;
+  p: PRttiCustomProp;
+  section, nested, json: PUtf8Char;
+  name: PAnsiChar;
+  n, v: RawUtf8;
+  up: array[byte] of AnsiChar;
+begin
+  result := false; // true when at least one property has been read
+  if (Ini = '') or
+     (Instance = nil) then
+    exit;
+  PWord(UpperCopy255(up{%H-}, SectionName))^ := ord(']');
+  section := pointer(Ini);
+  if not FindSectionFirstLine(section, @up) then
+    exit; // section not found
+  r := Rtti.RegisterClass(Instance);
+  p := pointer(r.Props.List);
+  for i := 1 to r.Props.Count do
+  begin
+    if p^.Prop <> nil then
+      if p^.Value.Kind = rkClass then
+      begin
+        // recursive load from another per-property section
+        if Level = 0 then
+          n := p^.Name
+        else
+          n := SectionName + '.' + p^.Name;
+        if IniToObject(Ini, p^.Prop^.GetObjProp(Instance), n,
+              DocVariantOptions, Level + 1) then
+          result := true;
+      end
+      else
+      begin
+        PWord(UpperCopy255(up{%H-}, p^.Name))^ := ord('=');
+        v := FindIniNameValue(section, @up, #0);
+        if p^.Value.Parser in ptMultiLineStringTypes then
+        begin
+          if v = #0 then // may be stored in a multi-line section body
+          begin
+            name := @up;
+            if Level <> 0 then
+            begin
+              name := UpperCopy255(name, SectionName);
+              name^ := '.';
+              inc(name);
+            end;
+            PWord(UpperCopy255(name, p^.Name))^ := ord(']');
+            nested := pointer(Ini);
+            if FindSectionFirstLine(nested, @up) then
+            begin
+              // multi-line text value has been stored in its own section
+              v := GetSectionContent(nested);
+              if p^.Prop^.SetValueText(Instance, v) then
+                result := true;
+            end;
+          end
+          else if p^.Prop^.SetValueText(Instance, v) then // single line text
+            result := true;
+        end
+        else if v <> #0 then
+          if (p^.OffsetSet <= 0) or // has a setter?
+             (rcfBoolean in p^.Value.Cache.Flags) or // simple value?
+             (p^.Value.Kind in (rkGetIntegerPropTypes + [rkEnumeration, rkFloat])) then
+          begin
+            if p^.Prop^.SetValueText(Instance, v) then // RTTI conversion
+              result := true;
+          end
+          else // e.g. rkVariant, rkSet, rkDynArray
+          begin
+            json := pointer(v); // convert complex values from JSON
+            GetDataFromJson(@PByteArray(Instance)[p^.OffsetSet], json,
+              nil, p^.Value, DocVariantOptions, true, nil);
+            if json <> nil then
+              result := true;
+          end;
+      end;
+    inc(p);
+  end;
+end;
+
+function TrimAndIsMultiLine(var U: RawUtf8): boolean;
+var
+  L: PtrInt;
+  P: PUtf8Char absolute U;
+begin
+  result := false;
+  L := length(U);
+  if L = 0 then
+    exit;
+  while P[L - 1] in [#13, #10] do
+  begin
+    dec(L);
+    if L = 0 then
+    begin
+      U := ''; // no meaningful text
+      exit;
+    end;
+  end;
+  if L <> length(U) then
+    SetLength(U, L); // trim right
+  if BufferLineLength(P, P + L) = L then // may use x86_64 SSE2 asm
+    exit; // no line feed
+  result := true; // there are line feeds within this text
+  U := TrimChar(U, [#13]); // normalize #13#10 into #10 as ObjectToIni()
+end;
+
+function ObjectToIni(const Instance: TObject; const SectionName: RawUtf8;
+  Options: TTextWriterWriteObjectOptions; Level: integer): RawUtf8;
+var
+  W: TTextWriter;
+  tmp: TTextWriterStackBuffer;
+  nested: TRawUtf8DynArray;
+  i, nestedcount: integer;
+  r: TRttiCustom;
+  p: PRttiCustomProp;
+  n, s: RawUtf8;
+begin
+  result := '';
+  if Instance = nil then
+    exit;
+  nestedcount := 0;
+  W := DefaultJsonWriter.CreateOwnedStream(tmp);
+  try
+    W.CustomOptions := W.CustomOptions + [twoTrimLeftEnumSets];
+    W.Add('[%]'#10, [SectionName]);
+    r := Rtti.RegisterClass(Instance);
+    p := pointer(r.Props.List);
+    for i := 1 to r.Props.Count do
+    begin
+      if p^.Prop <> nil then
+        if p^.Value.Kind = rkClass then
+        begin
+          if Level = 0 then
+            n := p^.Name
+          else
+            n := SectionName + '.' + p^.Name;
+          s := ObjectToIni(p^.Prop^.GetObjProp(Instance), n, Options, Level + 1);
+          if s <> '' then
+            AddRawUtf8(nested, nestedcount, s);
+        end
+        else if p^.Value.Kind = rkEnumeration then
+        begin
+          if woHumanReadableEnumSetAsComment in Options then
+          begin
+            p^.Value.Cache.EnumInfo^.GetEnumNameAll(
+              s, '; values=', {quoted=}false, #10, {uncamelcase=}true);
+            W.AddString(s);
+          end;
+          // AddValueJson() would have written "quotes"
+          W.AddString(p^.Name);
+          W.Add('=');
+          W.AddTrimLeftLowerCase(p^.Value.Cache.EnumInfo^.GetEnumNameOrd(
+            p^.Prop^.GetOrdProp(Instance)));
+          W.Add(#10);
+        end
+        else if p^.Value.Parser in ptMultiLineStringTypes then
+        begin
+          p^.Prop^.GetAsString(Instance, s);
+          if TrimAndIsMultiLine(s) then
+          begin
+            // store multi-line text values in their own section
+            if Level = 0 then
+              FormatUtf8('[%]'#10'%'#10#10, [p^.Name, s], n)
+            else
+              FormatUtf8('[%.%]'#10'%'#10#10, [SectionName, p^.Name, s], n);
+            AddRawUtf8(nested, nestedcount, n);
+          end
+          else
+          begin
+            W.AddString(p^.Name);
+            W.Add('=');
+            W.AddString(s); // single line text
+            W.Add(#10);
+          end;
+        end
+        else
+        begin
+          W.AddString(p^.Name);
+          W.Add('=');
+          p^.AddValueJson(W, Instance, // simple and complex types
+            Options - [woHumanReadableEnumSetAsComment], twOnSameLine);
+          W.Add(#10);
+        end;
+      inc(p);
+    end;
+    W.Add(#10);
+    for i := 0 to nestedcount - 1 do
+      W.AddString(nested[i]);
+    W.SetText(result);
+  finally
+    W.Free;
+  end;
+end;
+
+
+{ ************ RawUtf8 String Values Interning and TRawUtf8List }
+
+{ TRawUtf8Hashed }
+
+procedure TRawUtf8Hashed.Init;
+begin
+  Values.InitSpecific(TypeInfo(TRawUtf8DynArray), Value, ptRawUtf8,
+    @Count, false, InterningHasher);
+end;
+
+
+{ TRawUtf8InterningSlot }
+
+procedure TRawUtf8InterningSlot.Init;
+begin
+  fHash.Init;
+end;
+
+procedure TRawUtf8InterningSlot.Unique(var aResult: RawUtf8;
+  const aText: RawUtf8; aTextHash: cardinal);
+var
+  i: PtrInt;
+  added: boolean;
+begin
+  fSafe.ReadLock; // a TRWLightLock is faster here than an upgradable TRWLock
+  i := fHash.Values.Hasher.FindOrNewComp(aTextHash, @aText);
+  if i >= 0 then
+  begin
+    aResult := fHash.Value[i]; // return unified string instance
+    fSafe.ReadUnLock;
+    exit;
+  end;
+  fSafe.ReadUnLock;
+  fSafe.WriteLock; // need to be added within the write lock
+  i := fHash.Values.FindHashedForAdding(aText, added, aTextHash);
+  if added then
+  begin
+    fHash.Value[i] := aText; // copy new value to the pool
+    aResult := aText;
+  end
+  else
+    aResult := fHash.Value[i]; // was added in a background thread
+  fSafe.WriteUnLock;
+end;
+
+procedure TRawUtf8InterningSlot.UniqueFromBuffer(var aResult: RawUtf8;
+  aText: PUtf8Char; aTextLen: PtrInt; aTextHash: cardinal);
+var
+  c: AnsiChar;
+  added: boolean;
+  i: PtrInt;
+  bak: TDynArraySortCompare;
+begin
+  if not fSafe.TryReadLock then
+  begin
+    FastSetString(aResult, aText, aTextLen); // avoid waiting on contention
+    exit;
+  end;
+  c := aText[aTextLen];
+  aText[aTextLen] := #0; // input buffer may not be #0 terminated
+  i := fHash.Values.Hasher.FindOrNewComp(aTextHash, @aText, @SortDynArrayPUtf8Char);
+  if i >= 0 then
+  begin
+    aResult := fHash.Value[i]; // return unified string instance
+    fSafe.ReadUnLock;
+    aText[aTextLen] := c;
+    exit;
+  end;
+  fSafe.ReadUnLock;
+  fSafe.WriteLock; // need to be added
+  bak := fHash.Values.Hasher.Compare; // (RawUtf8,RawUtf8) -> (RawUtf8,PUtf8Char)
+  PDynArrayHasher(@fHash.Values.Hasher)^.fCompare := @SortDynArrayPUtf8Char;
+  i := fHash.Values.FindHashedForAdding(aText, added, aTextHash);
+  PDynArrayHasher(@fHash.Values.Hasher)^.fCompare := bak;
+  if added then
+    FastSetString(fHash.Value[i], aText, aTextLen); // new value to the pool
+  aResult := fHash.Value[i];
+  fSafe.WriteUnLock;
+  aText[aTextLen] := c;
+end;
+
+procedure TRawUtf8InterningSlot.UniqueText(var aText: RawUtf8; aTextHash: cardinal);
+var
+  i: PtrInt;
+  added: boolean;
+begin
+  fSafe.ReadLock;
+  i := fHash.Values.Hasher.FindOrNewComp(aTextHash, @aText);
+  if i >= 0 then
+  begin
+    aText := fHash.Value[i]; // return unified string instance
+    fSafe.ReadUnLock;
+    exit;
+  end;
+  fSafe.ReadUnLock;
+  fSafe.WriteLock; // need to be added
+  i := fHash.Values.FindHashedForAdding(aText, added, aTextHash);
+  if added then
+    fHash.Value[i] := aText  // copy new value to the pool
+  else
+    aText := fHash.Value[i]; // was added in a background thread
+  fSafe.WriteUnLock;
+end;
+
+function TRawUtf8InterningSlot.Existing(const aText: RawUtf8; aTextHash: cardinal): pointer;
+var
+  i: PtrInt;
+begin
+  result := nil;
+  fSafe.ReadLock;
+  i := fHash.Values.Hasher.FindOrNewComp(aTextHash, @aText);
+  if i >= 0 then
+    result := pointer(fHash.Value[i]); // return a pointer to unified string instance
+  fSafe.ReadUnLock;
+end;
+
+procedure TRawUtf8InterningSlot.Clear;
+begin
+  fSafe.WriteLock;
+  try
+    fHash.Values.SetCount(0); // Values.Clear
+    fHash.Values.Hasher.ForceReHash;
+  finally
+    fSafe.WriteUnLock;
+  end;
+end;
+
+function TRawUtf8InterningSlot.Clean(aMaxRefCount: TStrCnt): integer;
+var
+  i: integer;
+  s, d: PPtrUInt; // points to RawUtf8 values
+begin
+  result := 0;
+  if fHash.Count = 0 then
+    exit;
+  fSafe.WriteLock;
+  try
+    if fHash.Count = 0 then
+      exit;
+    s := pointer(fHash.Value);
+    d := s;
+    for i := 1 to fHash.Count do
+    begin
+      if PStrCnt(PAnsiChar(s^) - _STRCNT)^ <= aMaxRefCount then
+      begin
+        {$ifdef FPC}
+        FastAssignNew(PRawUtf8(s)^);
+        {$else}
+        PRawUtf8(s)^ := '';
+        {$endif FPC}
+        inc(result);
+      end
+      else
+      begin
+        if s <> d then
+        begin
+          d^ := s^; // bypass COW assignments
+          s^ := 0;  // avoid GPF
+        end;
+        inc(d);
+      end;
+      inc(s);
+    end;
+    if result > 0 then
+    begin
+      fHash.Values.SetCount((PtrUInt(d) - PtrUInt(fHash.Value)) div SizeOf(d^));
+      fHash.Values.ForceReHash;
+    end;
+  finally
+    fSafe.WriteUnLock;
+  end;
+end;
+
+
+{ TRawUtf8Interning }
+
+constructor TRawUtf8Interning.Create(aHashTables: integer);
+var
+  p: integer;
+  i: PtrInt;
+begin
+  inherited Create; // may have been overriden
+  for p := 0 to 9 do
+    if aHashTables = 1 shl p then
+    begin
+      SetLength(fPool, aHashTables);
+      fPoolLast := aHashTables - 1;
+      for i := 0 to fPoolLast do
+        fPool[i].Init;
+      exit;
+    end;
+  raise ESynException.CreateUtf8('%.Create(%) not allowed: ' +
+    'should be a power of 2 <= 512', [self, aHashTables]);
+end;
+
+procedure TRawUtf8Interning.Clear;
+var
+  i: PtrInt;
+begin
+  if self <> nil then
+    for i := 0 to fPoolLast do
+      fPool[i].Clear;
+end;
+
+function TRawUtf8Interning.Clean(aMaxRefCount: TStrCnt): integer;
+var
+  i: PtrInt;
+begin
+  result := 0;
+  if self <> nil then
+    for i := 0 to fPoolLast do
+      inc(result, fPool[i].Clean(aMaxRefCount));
+end;
+
+function TRawUtf8Interning.Count: integer;
+var
+  i: PtrInt;
+begin
+  result := 0;
+  if self <> nil then
+    for i := 0 to fPoolLast do
+      inc(result, fPool[i].Count);
+end;
+
+procedure TRawUtf8Interning.Unique(var aResult: RawUtf8; const aText: RawUtf8);
+var
+  hash: cardinal;
+begin
+  if aText = '' then
+    aResult := ''
+  else if self = nil then
+    aResult := aText
+  else
+  begin
+    // inlined fPool[].Values.HashElement
+    hash := InterningHasher(0, pointer(aText), length(aText));
+    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
+    // inlined fPool[].Values.HashElement
+    hash := InterningHasher(0, pointer(aText), length(aText));
+    fPool[hash and fPoolLast].UniqueText(aText, hash);
+  end;
+end;
+
+function TRawUtf8Interning.Unique(const aText: RawUtf8): RawUtf8;
+var
+  hash: cardinal;
+begin
+  if aText = '' then
+    FastAssignNew(result)
+  else if self = nil then
+    result := aText
+  else
+  begin
+    // inlined fPool[].Values.HashElement
+    hash := InterningHasher(0, pointer(aText), length(aText));
+    fPool[hash and fPoolLast].Unique(result, aText, hash);
+  end;
+end;
+
+function TRawUtf8Interning.Existing(const aText: RawUtf8): pointer;
+var
+  hash: cardinal;
+begin
+  result := nil;
+  if self = nil then
+    exit;
+  hash := InterningHasher(0, pointer(aText), length(aText));
+  result := fPool[hash and fPoolLast].Existing(aText, hash);
+end;
+
+function TRawUtf8Interning.Unique(aText: PUtf8Char; aTextLen: PtrInt): RawUtf8;
+begin
+  Unique(result, aText, aTextLen);
+end;
+
+procedure TRawUtf8Interning.Unique(var aResult: RawUtf8;
+  aText: PUtf8Char; aTextLen: PtrInt);
+var
+  hash: cardinal;
+begin
+  if (aText = nil) or
+     (aTextLen <= 0) then
+    FastAssignNew(aResult)
+  else if self = nil then
+    FastSetString(aResult, aText, aTextLen)
+  else
+  begin
+    // inlined fPool[].Values.HashElement
+    hash := InterningHasher(0, pointer(aText), aTextLen);
+    fPool[hash and fPoolLast].UniqueFromBuffer(aResult, aText, aTextLen, hash);
+  end;
+end;
+
+procedure TRawUtf8Interning.UniqueVariant(
+  var aResult: variant; const aText: RawUtf8);
+begin
+  ClearVariantForString(aResult);
+  Unique(RawUtf8(TVarData(aResult).VAny), aText);
+end;
+
+procedure TRawUtf8Interning.UniqueVariantString(var aResult: variant;
+  const aText: string);
+var
+  tmp: RawUtf8;
+begin
+  StringToUtf8(aText, tmp);
+  UniqueVariant(aResult, tmp);
+end;
+
+procedure TRawUtf8Interning.UniqueVariant(var aResult: variant);
+var
+  vd: TVarData absolute aResult;
+  vt: cardinal;
+begin
+  vt := vd.VType;
+  if vt = varString then
+    UniqueText(RawUtf8(vd.VString))
+  else if vt = varVariantByRef then
+    UniqueVariant(PVariant(vd.VPointer)^)
+  else if vt = varStringByRef then
+    UniqueText(PRawUtf8(vd.VPointer)^);
+end;
+
+
+{ TRawUtf8List }
+
+{$ifdef PUREMORMOT2}
+constructor TRawUtf8List.Create;
+begin
+  CreateEx([fCaseSensitive]);
+end;
+{$else}
+constructor TRawUtf8List.Create;
+begin
+  SetDefaultFlags;
+  CreateEx(fFlags + [fCaseSensitive]);
+end;
+
+constructor TRawUtf8List.Create(aOwnObjects, aNoDuplicate, aCaseSensitive: boolean);
+begin
+  SetDefaultFlags;
+  if aOwnObjects then
+    include(fFlags, fObjectsOwned);
+  if aNoDuplicate then
+    include(fFlags, fNoDuplicate);
+  if aCaseSensitive then
+    include(fFlags, fCaseSensitive);
+  CreateEx(fFlags);
+end;
+
+procedure TRawUtf8List.SetDefaultFlags;
+begin
+end;
+procedure TRawUtf8ListLocked.SetDefaultFlags;
+begin
+  fFlags := [fThreadSafe];
+end;
+procedure TRawUtf8ListHashed.SetDefaultFlags;
+begin
+  fFlags := [fNoDuplicate];
+end;
+procedure TRawUtf8ListHashedLocked.SetDefaultFlags;
+begin
+  fFlags := [fNoDuplicate, fThreadSafe];
+end;
+{$endif PUREMORMOT2}
+
+constructor TRawUtf8List.CreateEx(aFlags: TRawUtf8ListFlags);
+begin
+  inherited Create; // may have been overriden
+  fNameValueSep := '=';
+  fFlags := aFlags;
+  fValues.InitSpecific(TypeInfo(TRawUtf8DynArray), fValue, ptRawUtf8, @fCount,
+    not (fCaseSensitive in aFlags));
+end;
+
+destructor TRawUtf8List.Destroy;
+begin
+  SetCapacity(0);
+  inherited Destroy;
+end;
+
+procedure TRawUtf8List.SetCaseSensitive(Value: boolean);
+begin
+  if (self = nil) or
+     (fCaseSensitive in fFlags = Value) then
+    exit;
+  if fThreadSafe in fFlags then
+    fSafe.WriteLock;
+  try
+    if Value then
+      include(fFlags, fCaseSensitive)
+    else
+      exclude(fFlags, fCaseSensitive);
+    fValues.Hasher.InitSpecific(@fValues, ptRawUtf8, not Value, nil);
+    Changed;
+  finally
+    if fThreadSafe in fFlags then
+      fSafe.WriteUnLock;
+  end;
+end;
+
+procedure TRawUtf8List.SetCapacity(const capa: PtrInt);
+begin
+  if self <> nil then
+  begin
+    if fThreadSafe in fFlags then
+      fSafe.WriteLock;
+    try
+      if capa <= 0 then
+      begin
+        // clear
+        if fObjects <> nil then
+        begin
+          if fObjectsOwned in fFlags then
+            RawObjectsClear(pointer(fObjects), fCount);
+          fObjects := nil;
+        end;
+        fValues.Clear;
+        if fNoDuplicate in fFlags then
+          fValues.ForceReHash;
+        Changed;
+      end
+      else
+      begin
+        // resize
+        if capa < fCount then
+        begin
+          // resize down
+          if fObjects <> nil then
+          begin
+            if fObjectsOwned in fFlags then
+              RawObjectsClear(@fObjects[capa], fCount - capa - 1);
+            SetLength(fObjects, capa);
+          end;
+          fValues.Count := capa;
+          if fNoDuplicate in fFlags then
+            fValues.ForceReHash;
+          Changed;
+        end;
+        if capa > length(fValue) then
+        begin
+          // resize up
+          SetLength(fValue, capa);
+          if fObjects <> nil then
+            SetLength(fObjects, capa);
+        end;
+      end;
+    finally
+      if fThreadSafe in fFlags then
+        fSafe.WriteUnLock;
+    end;
+  end;
+end;
+
+function TRawUtf8List.Add(const aText: RawUtf8; aRaiseExceptionIfExisting: boolean): PtrInt;
+begin
+  result := AddObject(aText, nil, aRaiseExceptionIfExisting);
+end;
+
+function TRawUtf8List.AddObject(const aText: RawUtf8; aObject: TObject;
+  aRaiseExceptionIfExisting: boolean; aFreeAndReturnExistingObject: PPointer;
+  aReplaceExistingObject: boolean): PtrInt;
+var
+  added: boolean;
+  obj: TObject;
+begin
+  result := -1;
+  if self = nil then
+    exit;
+  if fThreadSafe in fFlags then
+    fSafe.WriteLock;
+  try
+    if fNoDuplicate in fFlags then
+    begin
+      result := fValues.FindHashedForAdding(aText, added, {noadd=}true);
+      if not added then
+      begin
+        obj := GetObject(result);
+        if (obj = aObject) and
+           (obj <> nil) then
+          exit; // found identical aText/aObject -> behave as if added
+        if aFreeAndReturnExistingObject <> nil then
+        begin
+          aObject.Free;
+          aFreeAndReturnExistingObject^ := obj;
+        end;
+        if aRaiseExceptionIfExisting then
+          raise ESynException.CreateUtf8('%.Add duplicate [%]', [self, aText]);
+        if aReplaceExistingObject then
+        begin
+          if obj = nil then
+            raise ESynException.CreateUtf8(
+              '%.AddOrReplaceObject with no object at [%]', [self, aText]);
+          if fObjectsOwned in fFlags then
+            FreeAndNil(fObjects[result]);
+          fObjects[result] := aObject;
+        end
+        else
+          result := -1;
+        exit;
+      end;
+    end;
+    result := fValues.Add(aText);
+    if (fObjects <> nil) or
+       (aObject <> nil) then
+    begin
+      if result >= length(fObjects) then
+        SetLength(fObjects, length(fValue)); // same capacity
+      if aObject <> nil then
+        fObjects[result] := aObject;
+    end;
+    if Assigned(fOnChange) then
+      Changed;
+  finally
+    if fThreadSafe in fFlags then
+      fSafe.WriteUnLock;
+  end;
+end;
+
+function TRawUtf8List.AddOrReplaceObject(const aText: RawUtf8; aObject: TObject): PtrInt;
+begin
+  result := AddObject(aText, aObject, {raiseexisting=}false, nil, {replace=}true);
+end;
+
+procedure TRawUtf8List.AddObjectUnique(const aText: RawUtf8;
+  aObjectToAddOrFree: PPointer);
+begin
+  if fNoDuplicate in fFlags then
+    AddObject(aText, aObjectToAddOrFree^, {raiseexc=}false,
+      {freeandreturnexisting=}aObjectToAddOrFree);
+end;
+
+procedure TRawUtf8List.AddRawUtf8List(List: TRawUtf8List);
+var
+  i: PtrInt;
+begin
+  if List <> nil then
+  begin
+    BeginUpdate; // includes Safe.Lock
+    try
+      for i := 0 to List.fCount - 1 do
+        AddObject(List.fValue[i], List.GetObject(i));
+    finally
+      EndUpdate;
+    end;
+  end;
+end;
+
+procedure TRawUtf8List.BeginUpdate;
+begin
+  if InterLockedIncrement(fOnChangeLevel) > 1 then
+    exit;
+  if fThreadSafe in fFlags then
+    fSafe.WriteLock;
+  fOnChangeBackupForBeginUpdate := fOnChange;
+  fOnChange := OnChangeHidden;
+  exclude(fFlags, fOnChangeTrigerred);
+end;
+
+procedure TRawUtf8List.EndUpdate;
+begin
+  if (fOnChangeLevel <= 0) or
+     (InterLockedDecrement(fOnChangeLevel) > 0) then
+    exit; // allows nested BeginUpdate..EndUpdate calls
+  fOnChange := fOnChangeBackupForBeginUpdate;
+  if (fOnChangeTrigerred in fFlags) and
+     Assigned(fOnChange) then
+    Changed;
+  exclude(fFlags, fOnChangeTrigerred);
+  if fThreadSafe in fFlags then
+    fSafe.WriteUnLock;
+end;
+
+procedure TRawUtf8List.Changed;
+begin
+  if Assigned(fOnChange) then
+  try
+    fOnChange(self);
+  except // ignore any exception in user code (may not trigger fSafe.UnLock)
+  end;
+end;
+
+procedure TRawUtf8List.Clear;
+begin
+  SetCapacity(0); // will also call Changed
+end;
+
+procedure TRawUtf8List.InternalDelete(Index: PtrInt);
+begin
+  // caller ensured Index is correct
+  fValues.Delete(Index); // includes dec(fCount)
+  if PtrUInt(Index) < PtrUInt(length(fObjects)) then
+  begin
+    if fObjectsOwned in fFlags then
+      fObjects[Index].Free;
+    if fCount > Index then
+      MoveFast(fObjects[Index + 1], fObjects[Index],
+        (fCount - Index) * SizeOf(pointer));
+    fObjects[fCount] := nil;
+  end;
+  if Assigned(fOnChange) then
+    Changed;
+end;
+
+procedure TRawUtf8List.Delete(Index: PtrInt);
+begin
+  if (self <> nil) and
+     (PtrUInt(Index) < PtrUInt(fCount)) then
+    if fNoDuplicate in fFlags then // force update the hash table
+      Delete(fValue[Index])
+    else
+      InternalDelete(Index);
+end;
+
+function TRawUtf8List.Delete(const aText: RawUtf8): PtrInt;
+begin
+  if fThreadSafe in fFlags then
+    fSafe.WriteLock;
+  try
+    if fNoDuplicate in fFlags then
+      result := fValues.FindHashedAndDelete(aText, nil, {nodelete=}true)
+    else
+      result := FindRawUtf8(pointer(fValue), aText, fCount, fCaseSensitive in fFlags);
+    if result >= 0 then
+      InternalDelete(result);
+  finally
+    if fThreadSafe in fFlags then
+      fSafe.WriteUnLock;
+  end;
+end;
+
+function TRawUtf8List.DeleteFromName(const Name: RawUtf8): PtrInt;
+begin
+  result := -1;
+  if fThreadSafe in fFlags then
+    fSafe.ReadWriteLock;
+  try
+    result := IndexOfName(Name);
+    if result >= 0 then
+    begin
+      if fThreadSafe in fFlags then
+        fSafe.WriteLock;
+      Delete(result);
+    end;
+  finally
+    if fThreadSafe in fFlags then
+    begin
+      if result >= 0 then
+        fSafe.WriteUnlock;
+      fSafe.ReadWriteUnLock;
+    end;
+  end;
+end;
+
+function TRawUtf8List.Exists(const aText: RawUtf8): boolean;
+begin
+  if self <> nil then
+    if fThreadSafe in fFlags then
+    begin
+      fSafe.ReadOnlyLock;
+      try
+        result := IndexOf(aText) >= 0;
+      finally
+        fSafe.ReadOnlyUnLock;
+      end;
+    end
+    else
+      result := IndexOf(aText) >= 0
+  else
+    result := false;
+end;
+
+function TRawUtf8List.IndexOf(const aText: RawUtf8): PtrInt;
+begin
+  if self <> nil then
+  begin
+    if fNoDuplicate in fFlags then
+      result := fValues.FindHashed(aText)
+    else
+      result := FindRawUtf8(
+        pointer(fValue), aText, fCount, fCaseSensitive in fFlags);
+  end
+  else
+    result := -1;
+end;
+
+function TRawUtf8List.Get(Index: PtrInt): RawUtf8;
+begin
+  if (self = nil) or
+     (PtrUInt(Index) >= PtrUInt(fCount)) then
+    result := ''
+  else
+    result := fValue[Index];
+end;
+
+function TRawUtf8List.GetS(Index: PtrInt): string;
+begin
+  if (self = nil) or
+     (PtrUInt(Index) >= PtrUInt(fCount)) then
+    result := ''
+  else
+    Utf8ToStringVar(fValue[Index], result);
+end;
+
+function TRawUtf8List.GetCapacity: PtrInt;
+begin
+  if self = nil then
+    result := 0
+  else
+    result := length(fValue);
+end;
+
+function TRawUtf8List.GetCount: PtrInt;
+begin
+  if self = nil then
+    result := 0
+  else
+    result := fCount;
+end;
+
+function TRawUtf8List.GetTextPtr: PPUtf8CharArray;
+begin
+  result := pointer(self);
+  if self <> nil then
+    result := pointer(fValue);
+end;
+
+function TRawUtf8List.GetObjectPtr: PPointerArray;
+begin
+  result := pointer(self);
+  if self <> nil then
+    result := pointer(fObjects);
+end;
+
+function TRawUtf8List.GetName(Index: PtrInt): RawUtf8;
+begin
+  result := Get(Index);
+  if result = '' then
+    exit;
+  Index := PosExChar(NameValueSep, result);
+  if Index = 0 then
+    result := ''
+  else
+    SetLength(result, Index - 1);
+end;
+
+function TRawUtf8List.GetObject(Index: PtrInt): pointer;
+begin
+  if (self <> nil) and
+     (fObjects <> nil) and
+     (PtrUInt(Index) < PtrUInt(fCount)) then
+    result := fObjects[Index]
+  else
+    result := nil;
+end;
+
+function TRawUtf8List.GetObjectFrom(const aText: RawUtf8): pointer;
+var
+  ndx: PtrUInt;
+begin
+  result := nil;
+  if (self <> nil) and
+     (fObjects <> nil) then
+  begin
+    if fThreadSafe in fFlags then
+      fSafe.ReadOnlyLock;
+    try
+      ndx := IndexOf(aText);
+      if ndx < PtrUInt(fCount) then
+        result := fObjects[ndx];
+    finally
+      if fThreadSafe in fFlags then
+        fSafe.ReadOnlyUnLock;
+    end;
+  end;
+end;
+
+function TRawUtf8List.GetText(const Delimiter: RawUtf8): RawUtf8;
+var
+  DelimLen, i, Len: PtrInt;
+  P: PUtf8Char;
+begin
+  result := '';
+  if (self = nil) or
+     (fCount = 0) then
+    exit;
+  if fThreadSafe in fFlags then
+    fSafe.ReadOnlyLock;
+  try
+    DelimLen := length(Delimiter);
+    Len := DelimLen * (fCount - 1);
+    for i := 0 to fCount - 1 do
+      inc(Len, length(fValue[i]));
+    FastSetString(result, Len);
+    P := pointer(result);
+    i := 0;
+    repeat
+      Len := length(fValue[i]);
+      if Len > 0 then
+      begin
+        MoveFast(pointer(fValue[i])^, P^, Len);
+        inc(P, Len);
+      end;
+      inc(i);
+      if i >= fCount then
+        Break;
+      if DelimLen > 0 then
+      begin
+        MoveByOne(pointer(Delimiter), P, DelimLen);
+        inc(P, DelimLen);
+      end;
+    until false;
+  finally
+    if fThreadSafe in fFlags then
+      fSafe.ReadOnlyUnLock;
+  end;
+end;
+
+procedure TRawUtf8List.SaveToStream(Dest: TStream; const Delimiter: RawUtf8);
+var
+  W: TTextWriter;
+  i: PtrInt;
+  temp: TTextWriterStackBuffer;
+begin
+  if (self = nil) or
+     (fCount = 0) then
+    exit;
+  if fThreadSafe in fFlags then
+    fSafe.ReadOnlyLock;
+  try
+    W := TTextWriter.Create(Dest, @temp, SizeOf(temp));
+    try
+      i := 0;
+      repeat
+        W.AddString(fValue[i]);
+        inc(i);
+        if i >= fCount then
+          Break;
+        W.AddString(Delimiter);
+      until false;
+      W.FlushFinal;
+    finally
+      W.Free;
+    end;
+  finally
+    if fThreadSafe in fFlags then
+      fSafe.ReadOnlyUnLock;
+  end;
+end;
+
+procedure TRawUtf8List.SaveToFile(
+  const FileName: TFileName; const Delimiter: RawUtf8);
+var
+  FS: TStream;
+begin
+  FS := TFileStreamEx.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
+  if fThreadSafe in fFlags then
+    fSafe.ReadOnlyLock;
+  try
+    result := GetValueAt(IndexOfName(Name));
+  finally
+    if fThreadSafe in fFlags then
+      fSafe.ReadOnlyUnLock;
+  end;
+end;
+
+function TRawUtf8List.GetValueAt(Index: PtrInt): RawUtf8;
+begin
+  result := Get(Index);
+  if result = '' then
+    exit;
+  Index := PosExChar(NameValueSep, result);
+  if Index = 0 then
+    result := ''
+  else
+    TrimChars(result, Index, 0);
+end;
+
+function TRawUtf8List.EqualValueAt(Index: PtrInt; const aText: RawUtf8): boolean;
+begin
+  result := (self <>nil) and
+            (PtrUInt(Index) < PtrUInt(fCount)) and
+            (fValue[Index] = aText);
+end;
+
+function TRawUtf8List.IndexOfName(const Name: RawUtf8): PtrInt;
+var
+  UpperName: array[byte] of AnsiChar;
+  table: PNormTable;
+begin
+  if self <> nil then
+  begin
+    PWord(UpperCopy255(UpperName{%H-}, Name))^ := ord(NameValueSep);
+    table := @NormToUpperAnsi7;
+    for result := 0 to fCount - 1 do
+      if IdemPChar(Pointer(fValue[result]), UpperName, table) then
+        exit;
+  end;
+  result := -1;
+end;
+
+function TRawUtf8List.IndexOfObject(aObject: TObject): PtrInt;
+begin
+  if (self <> nil) and
+     (fObjects <> nil) then
+  begin
+    if fThreadSafe in fFlags then
+      fSafe.ReadOnlyLock;
+    try
+      result := PtrUIntScanIndex(pointer(fObjects), fCount, PtrUInt(aObject));
+    finally
+      if fThreadSafe in fFlags then
+        fSafe.ReadOnlyUnLock;
+    end
+  end
+  else
+    result := -1;
+end;
+
+function TRawUtf8List.Contains(const aText: RawUtf8; aFirstIndex: integer): PtrInt;
+var
+  i: PtrInt; // use a temp variable to make oldest Delphi happy :(
+begin
+  result := -1;
+  if self = nil then
+    exit;
+  if fThreadSafe in fFlags then
+    fSafe.ReadOnlyLock;
+  try
+    for i := aFirstIndex to fCount - 1 do
+      if PosEx(aText, fValue[i]) > 0 then
+      begin
+        result := i;
+        exit;
+      end;
+  finally
+    if fThreadSafe in fFlags then
+      fSafe.ReadOnlyUnLock;
+  end;
+end;
+
+procedure TRawUtf8List.OnChangeHidden(Sender: TObject);
+begin
+  if self <> nil then
+    include(fFlags, fOnChangeTrigerred);
+end;
+
+procedure TRawUtf8List.Put(Index: PtrInt; const Value: RawUtf8);
+begin
+  if (self <> nil) and
+     (PtrUInt(Index) < PtrUInt(fCount)) then
+  begin
+    fValue[Index] := Value;
+    if Assigned(fOnChange) then
+      Changed;
+  end;
+end;
+
+procedure TRawUtf8List.PutS(Index: PtrInt; const Value: string);
+begin
+  Put(Index, StringToUtf8(Value));
+end;
+
+procedure TRawUtf8List.PutObject(Index: PtrInt; Value: pointer);
+begin
+  if (self <> nil) and
+     (PtrUInt(Index) < PtrUInt(fCount)) then
+  begin
+    if fObjects = nil then
+      SetLength(fObjects, Length(fValue));
+    fObjects[Index] := Value;
+    if Assigned(fOnChange) then
+      Changed;
+  end;
+end;
+
+procedure TRawUtf8List.SetText(const aText: RawUtf8; const Delimiter: RawUtf8);
+begin
+  SetTextPtr(pointer(aText), PUtf8Char(pointer(aText)) + length(aText), Delimiter);
+end;
+
+procedure TRawUtf8List.LoadFromFile(const FileName: TFileName);
+begin
+  SetText(RawUtf8FromFile(FileName), #13#10); // RawUtf8FromFile() detects BOM
+end;
+
+procedure TRawUtf8List.SetTextPtr(P, PEnd: PUtf8Char; const Delimiter: RawUtf8);
+var
+  DelimLen: PtrInt;
+  DelimFirst: AnsiChar;
+  PBeg, DelimNext: PUtf8Char;
+  Line: RawUtf8;
+begin
+  DelimLen := length(Delimiter);
+  BeginUpdate; // also makes fSafe.Lock
+  try
+    Clear;
+    if (P <> nil) and
+       (DelimLen > 0) and
+       (P < PEnd) then
+    begin
+      DelimFirst := Delimiter[1];
+      DelimNext := PUtf8Char(pointer(Delimiter)) + 1;
+      repeat
+        PBeg := P;
+        while P < PEnd do
+        begin
+          if (P^ = DelimFirst) and
+             CompareMemSmall(P + 1, DelimNext, DelimLen - 1) then
+            break;
+          inc(P);
+        end;
+        FastSetString(Line, PBeg, P - PBeg);
+        AddObject(Line, nil);
+        if P >= PEnd then
+          break;
+        inc(P, DelimLen);
+      until P >= PEnd;
+    end;
+  finally
+    EndUpdate;
+  end;
+end;
+
+procedure TRawUtf8List.SetTextCRLF(const Value: RawUtf8);
+begin
+  SetText(Value, #13#10);
+end;
+
+procedure TRawUtf8List.SetFrom(const aText: TRawUtf8DynArray;
+  const aObject: TObjectDynArray);
+var
+  n: integer;
+begin
+  BeginUpdate; // also makes fSafe.Lock
+  try
+    Clear;
+    n := length(aText);
+    if n = 0 then
+      exit;
+    SetCapacity(n);
+    fCount := n;
+    fValue := aText;
+    fObjects := aObject;
+    if fNoDuplicate in fFlags then
+      fValues.ForceReHash;
+  finally
+    EndUpdate;
+  end;
+end;
+
+procedure TRawUtf8List.SetValue(const Name, Value: RawUtf8);
+var
+  i: PtrInt;
+  txt: RawUtf8;
+begin
+  txt := Name + RawUtf8(NameValueSep) + Value;
+  if fThreadSafe in fFlags then
+    fSafe.WriteLock;
+  try
+    i := IndexOfName(Name);
+    if i < 0 then
+      AddObject(txt, nil)
+    else if fValue[i] <> txt then
+    begin
+      fValue[i] := txt;
+      if fNoDuplicate in fFlags then
+        fValues.Hasher.ForceReHash; // invalidate internal hash table
+      Changed;
+    end;
+  finally
+    if fThreadSafe in fFlags then
+      fSafe.WriteUnLock;
+  end;
+end;
+
+function TRawUtf8List.GetCaseSensitive: boolean;
+begin
+  result := (self <> nil) and
+            (fCaseSensitive in fFlags);
+end;
+
+function TRawUtf8List.GetNoDuplicate: boolean;
+begin
+  result := (self <> nil) and
+            (fNoDuplicate in fFlags);
+end;
+
+function TRawUtf8List.UpdateValue(const Name: RawUtf8; var Value: RawUtf8;
+  ThenDelete: boolean): boolean;
+var
+  i: PtrInt;
+begin
+  result := false;
+  if fThreadSafe in fFlags then
+    fSafe.WriteLock;
+  try
+    i := IndexOfName(Name);
+    if i >= 0 then
+    begin
+      Value := GetValueAt(i); // copy value
+      if ThenDelete then
+        Delete(i); // optionally delete
+      result := true;
+    end;
+  finally
+    if fThreadSafe in fFlags then
+      fSafe.WriteUnLock;
+  end;
+end;
+
+function TRawUtf8List.PopFirst(out aText: RawUtf8; aObject: PObject): boolean;
+begin
+  result := false;
+  if fCount = 0 then
+    exit;
+  if fThreadSafe in fFlags then
+    fSafe.WriteLock;
+  try
+    if fCount > 0 then
+    begin
+      aText := fValue[0];
+      if aObject <> nil then
+        if fObjects <> nil then
+          aObject^ := fObjects[0]
+        else
+          aObject^ := nil;
+      Delete(0);
+      result := true;
+    end;
+  finally
+    if fThreadSafe in fFlags then
+      fSafe.WriteUnLock;
+  end;
+end;
+
+function TRawUtf8List.PopLast(out aText: RawUtf8; aObject: PObject): boolean;
+var
+  last: PtrInt;
+begin
+  result := false;
+  if fCount = 0 then
+    exit;
+  if fThreadSafe in fFlags then
+    fSafe.WriteLock;
+  try
+    last := fCount - 1;
+    if last >= 0 then
+    begin
+      aText := fValue[last];
+      if aObject <> nil then
+        if fObjects <> nil then
+          aObject^ := fObjects[last]
+        else
+          aObject^ := nil;
+      Delete(last);
+      result := true;
+    end;
+  finally
+    if fThreadSafe in fFlags then
+      fSafe.WriteUnLock;
+  end;
+end;
+
+
+{ ********** Efficient RTTI Values Binary Serialization and Comparison }
+
+// per-type efficient binary serialization
+
+function _BS_Ord(Data: pointer; Dest: TBufferWriter; Info: PRttiInfo): PtrInt;
+begin
+  result := ORDTYPE_SIZE[Info^.RttiOrd];
+  Dest.Write(Data, result);
+end;
+
+function _BL_Ord(Data: pointer; var Source: TFastReader; Info: PRttiInfo): PtrInt;
+begin
+  result := ORDTYPE_SIZE[Info^.RttiOrd];
+  Source.Copy(Data, result);
+end;
+
+function _BS_Float(Data: pointer; Dest: TBufferWriter; Info: PRttiInfo): PtrInt;
+begin
+  result := FLOATTYPE_SIZE[Info^.RttiFloat];
+  Dest.Write(Data, result);
+end;
+
+function _BL_Float(Data: pointer; var Source: TFastReader; Info: PRttiInfo): PtrInt;
+begin
+  result := FLOATTYPE_SIZE[Info^.RttiFloat];
+  Source.Copy(Data, result);
+end;
+
+function _BS_64(Data: PInt64; Dest: TBufferWriter; Info: PRttiInfo): PtrInt;
+begin
+  {$ifdef CPU32}
+  Dest.Write8(Data);
+  {$else}
+  Dest.WriteI64(Data^);
+  {$endif CPU32}
+  result := 8;
+end;
+
+function _BL_64(Data: PQWord; var Source: TFastReader; Info: PRttiInfo): PtrInt;
+begin
+  Data^ := Source.Next8;
+  result := 8;
+end;
+
+function _BS_String(Data: PRawByteString; Dest: TBufferWriter; Info: PRttiInfo): PtrInt;
+begin
+  Dest.WriteVar(pointer(Data^), length(Data^));
+  result := SizeOf(pointer);
+end;
+
+function _BL_LString(Data: PRawByteString; var Source: TFastReader; Info: PRttiInfo): PtrInt;
+begin
+  with Source.VarBlob do
+    {$ifdef HASCODEPAGE}
+    FastSetStringCP(Data^, Ptr, Len, Info^.AnsiStringCodePageStored);
+    {$else}
+    SetString(Data^, Ptr, Len);
+    {$endif HASCODEPAGE}
+  result := SizeOf(pointer);
+end;
+
+{$ifdef HASVARUSTRING}
+
+function _BS_UString(Data: PUnicodeString; Dest: TBufferWriter; Info: PRttiInfo): PtrInt;
+begin
+  Dest.WriteVar(pointer(Data^), length(Data^) * 2);
+  result := SizeOf(pointer);
+end;
+
+function _BL_UString(Data: PUnicodeString; var Source: TFastReader; Info: PRttiInfo): PtrInt;
+begin
+  with Source.VarBlob do
+    SetString(Data^, PWideChar(Ptr), Len shr 1); // length in bytes was stored
+  result := SizeOf(pointer);
+end;
+
+{$endif HASVARUSTRING}
+
+function _BS_WString(Data: PWideString; Dest: TBufferWriter; Info: PRttiInfo): PtrInt;
+begin
+  Dest.WriteVar(pointer(Data^), length(Data^) * 2);
+  result := SizeOf(pointer);
+end;
+
+function _BL_WString(Data: PWideString; var Source: TFastReader; Info: PRttiInfo): PtrInt;
+begin
+  with Source.VarBlob do
+    SetString(Data^, PWideChar(Ptr), Len shr 1); // length in bytes was stored
+  result := SizeOf(pointer);
+end;
+
+// efficient branchless comparison of every TRttiOrd/TRttiFloat raw value
+
+function _BC_SByte(A, B: PShortInt; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := ord(A^ > B^) - ord(A^ < B^);
+  result := 1;
+end;
+
+function _BC_UByte(A, B: PByte; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := ord(A^ > B^) - ord(A^ < B^);
+  result := 1;
+end;
+
+function _BC_SWord(A, B: PSmallInt; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := ord(A^ > B^) - ord(A^ < B^);
+  result := 2;
+end;
+
+function _BC_UWord(A, B: PWord; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := ord(A^ > B^) - ord(A^ < B^);
+  result := 2;
+end;
+
+function _BC_SLong(A, B: PInteger; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := ord(A^ > B^) - ord(A^ < B^);
+  result := 4;
+end;
+
+function _BC_ULong(A, B: PCardinal; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := ord(A^ > B^) - ord(A^ < B^);
+  result := 4;
+end;
+
+function _BC_SQWord(A, B: PInt64; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := ord(A^ > B^) - ord(A^ < B^);
+  result := 8;
+end;
+
+function _BC_UQWord(A, B: PQWord; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := ord(A^ > B^) - ord(A^ < B^);
+  result := 8;
+end;
+
+function _BC_Ord(A, B: pointer; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  result := RTTI_ORD_COMPARE[Info^.RttiOrd](A, B, Info, Compared);
+end;
+
+function _BC_Single(A, B: PSingle; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := ord(A^ > B^) - ord(A^ < B^);
+  result := SizeOf(single);
+end;
+
+function _BC_Double(A, B: PDouble; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := ord(A^ > B^) - ord(A^ < B^);
+  result := SizeOf(double);
+end;
+
+function _BC_Extended(A, B: PExtended; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := ord(A^ > B^) - ord(A^ < B^);
+  result := SizeOf(extended);
+end;
+
+function _BC_Float(A, B: pointer; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  result := RTTI_FLOAT_COMPARE[Info^.RttiFloat](A, B, Info, Compared);
+end;
+
+function _BC_64(A, B: pointer; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  if Info^.IsQWord then
+    Compared := ord(PQWord(A)^ > PQWord(B)^) - ord(PQWord(A)^ < PQWord(B)^)
+  else
+    Compared := ord(PInt64(A)^ > PInt64(B)^) - ord(PInt64(A)^ < PInt64(B)^);
+  result := 8;
+end;
+
+function _BC_LString(A, B: PRawByteString; Info: PRttiInfo;
+  out Compared: integer): PtrInt;
+begin
+  // StrComp() would fail for RawByteString
+  {$ifdef CPUINTEL}
+  compared := SortDynArrayAnsiString(A^, B^); // optimized asm using length()
+  {$else}
+  compared := SortDynArrayRawByteString(A^, B^);
+  {$endif CPUINTEL}
+  result := SizeOf(pointer);
+end;
+
+function _BC_WString(A, B: PPWideChar; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  compared := StrCompW(A^, B^);
+  result := SizeOf(pointer);
+end;
+
+function _BCI_LString(A, B: PPUtf8Char; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  compared := StrIComp(A^, B^);
+  result := SizeOf(pointer);
+end;
+
+function _BCI_WString(A, B: PPWideChar; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  compared := AnsiICompW(A^, B^);
+  result := SizeOf(pointer);
+end;
+
+function DelphiType(Info: PRttiInfo): integer;
+  {$ifdef HASINLINE} inline; {$endif}
+begin
+  // compatible with legacy TDynArray.SaveTo() format
+  if Info = nil then
+    result := 0
+  else
+    {$ifdef FPC}
+    result := ord(FPCTODELPHI[Info^.Kind]);
+    {$else}
+    result := ord(Info^.Kind);
+    {$endif FPC}
+end;
+
+procedure DynArraySave(Data: PAnsiChar; ExternalCount: PInteger;
+  Dest: TBufferWriter; Info: PRttiInfo);
+var
+  n, itemsize: PtrInt;
+  sav: TRttiBinarySave;
+label
+  raw;
+begin
+  Info := Info^.DynArrayItemType(itemsize);
+  Dest.Write1(0); // warning: store itemsize=0 (mORMot 1 ignores it anyway)
+  Dest.Write1(DelphiType(Info));
+  Data := PPointer(Data)^; // de-reference pointer to array data
+  if Data = nil then
+    Dest.Write1(0) // store dynamic array count of 0
+  else
+  begin
+    if ExternalCount <> nil then
+      n := ExternalCount^ // e.g. from TDynArray with external count
+    else
+      n := PDALen(Data - _DALEN)^ + _DAOFF;
+    Dest.WriteVarUInt32(n);
+    Dest.Write4(0); // warning: we don't store any Hash32 checksum any more
+    if Info = nil then
+raw:  Dest.Write(Data, itemsize * n)
+    else
+    begin
+      sav := RTTI_BINARYSAVE[Info^.Kind];
+      if Assigned(sav) then // paranoid check
+        repeat
+          inc(Data, sav(Data, Dest, Info));
+          dec(n);
+        until n = 0
+      else
+        goto raw;
+    end;
+  end;
+end;
+
+function _BS_DynArray(Data: PAnsiChar; Dest: TBufferWriter; Info: PRttiInfo): PtrInt;
+begin
+  DynArraySave(Data, nil, Dest, Info);
+  result := SizeOf(pointer);
+end;
+
+function DynArrayLoad(var Value; Source: PAnsiChar; TypeInfo: PRttiInfo;
+  TryCustomVariants: PDocVariantOptions; SourceMax: PAnsiChar): PAnsiChar;
+begin
+  {$ifndef PUREMORMOT2}
+  if SourceMax = nil then
+    // mORMot 1 unsafe backward compatible: assume fake 100MB Source input
+    SourceMax := Source + 100 shl 20;
+  {$endif PUREMORMOT2}
+  result := BinaryLoad(
+    @Value, source, TypeInfo, nil, SourceMax, [rkDynArray], TryCustomVariants);
+end;
+
+function DynArraySave(var Value; TypeInfo: PRttiInfo): RawByteString;
+begin
+  result := BinarySave(@Value, TypeInfo, [rkDynArray]);
+end;
+
+function DynArrayLoadHeader(var Source: TFastReader;
+  ArrayInfo, ItemInfo: PRttiInfo): integer;
+begin
+  Source.VarNextInt; // ignore stored itemsize (0 stored now)
+  if Source.NextByte <> DelphiType(ItemInfo) then
+    Source.ErrorData('RTTI_BINARYLOAD[rkDynArray] failed for %', [ArrayInfo.RawName]);
+  result := Source.VarUInt32;
+  if result <> 0 then
+    Source.Next4; // ignore deprecated Hash32 checksum (0 stored now)
+end;
+
+function _BL_DynArray(Data: PAnsiChar; var Source: TFastReader; Info: PRttiInfo): PtrInt;
+var
+  n, itemsize: PtrInt;
+  iteminfo: PRttiInfo;
+  load: TRttiBinaryLoad;
+label
+  raw;
+begin
+  iteminfo := Info^.DynArrayItemType(itemsize); // nil for unmanaged items
+  n := DynArrayLoadHeader(Source, Info, iteminfo);
+  if PPointer(Data)^ <> nil then
+    FastDynArrayClear(pointer(Data), iteminfo);
+  if n > 0 then
+  begin
+    DynArrayNew(pointer(Data), n, itemsize); // allocate zeroed  memory
+    Data := PPointer(Data)^; // point to first item
+    if iteminfo = nil then
+raw:  Source.Copy(Data, itemsize * n)
+    else
+    begin
+      load := RTTI_BINARYLOAD[iteminfo^.Kind];
+      if Assigned(load) then
+        repeat
+          inc(Data, load(Data, Source, iteminfo));
+          dec(n);
+        until n = 0
+      else
+        goto raw;
+    end;
+  end;
+  result := SizeOf(pointer);
+end;
+
+function DynArrayCompare(A, B: PAnsiChar; ExternalCountA, ExternalCountB: PInteger;
+  Info: PRttiInfo; CaseInSensitive: boolean): integer;
+var
+  n1, n2, n: PtrInt;
+begin
+  A := PPointer(A)^;
+  B := PPointer(B)^;
+  if A = B then
+  begin
+    result := 0;
+    exit;
+  end
+  else if A = nil then
+  begin
+    result := -1;
+    exit;
+  end
+  else if B = nil then
+  begin
+    result := 1;
+    exit;
+  end;
+  if ExternalCountA <> nil then
+    n1 := ExternalCountA^ // e.g. from TDynArray with external count
+  else
+    n1 := PDALen(A - _DALEN)^ + _DAOFF;
+  if ExternalCountB <> nil then
+    n2 := ExternalCountB^
+  else
+    n2 := PDALen(B - _DALEN)^ + _DAOFF;
+  n := n1;
+  if n > n2 then
+    n := n2;
+  if Info = TypeInfo(TObjectDynArray) then
+    result := ObjectCompare(PObject(A), PObject(B), n, CaseInSensitive)
+  else
+    result := BinaryCompare(A, B, Info^.DynArrayItemType, n, CaseInSensitive);
+  if result = 0 then
+    result := n1 - n2;
+end;
+
+function DynArrayAdd(TypeInfo: PRttiInfo; var DynArray; const Item): integer;
+var
+  da: TDynArray;
+begin
+  da.Init(TypeInfo, DynArray);
+  result := da.Add(Item);
+end;
+
+function DynArrayDelete(TypeInfo: PRttiInfo; var DynArray; Index: PtrInt): boolean;
+var
+  da: TDynArray;
+begin
+  da.Init(TypeInfo, DynArray);
+  result := da.Delete(Index);
+end;
+
+function DynArrayEquals(TypeInfo: PRttiInfo; var Array1, Array2;
+  Array1Count, Array2Count: PInteger; CaseInsensitive: boolean): boolean;
+begin
+  result := DynArrayCompare(@Array1, @Array2, Array1Count, Array2Count,
+    TypeInfo, CaseInsensitive) = 0;
+end;
+
+{$ifdef FPCGENERICS}
+
+function DynArrayAdd(var DynArray: TArray; const Item): integer;
+begin
+  result := DynArrayAdd(TypeInfo(TArray), DynArray, Item);
+end;
+
+function DynArrayDelete(var DynArray: TArray; Index: PtrInt): boolean;
+begin
+  result := DynArrayDelete(TypeInfo(TArray), DynArray, Index);
+end;
+
+function DynArrayCompare(var Array1, Array2: TArray;
+  CaseInSensitive: boolean): integer;
+begin
+  result := DynArrayCompare(
+    @Array1, @Array2, nil, nil, TypeInfo(TArray), CaseInSensitive);
+end;
+
+{$endif FPCGENERICS}
+
+function _BC_DynArray(A, B: pointer; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := DynArrayCompare(A, B, nil, nil, Info, {caseinsens=}false);
+  result := SizeOf(pointer);
+end;
+
+function _BCI_DynArray(A, B: pointer; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := DynArrayCompare(A, B, nil, nil, Info, {caseinsens=}true);
+  result := SizeOf(pointer);
+end;
+
+function _BC_ObjArray(A, B: pointer; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := DynArrayCompare(
+    A, B, nil, nil, TypeInfo(TObjectDynArray), {caseinsens=}false);
+  result := SizeOf(pointer);
+end;
+
+function _BCI_ObjArray(A, B: pointer; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := DynArrayCompare(
+    A, B, nil, nil, TypeInfo(TObjectDynArray), {caseinsens=}true);
+  result := SizeOf(pointer);
+end;
+
+function _BS_Record(Data: PAnsiChar; Dest: TBufferWriter; Info: PRttiInfo): PtrInt;
+var
+  fields: TRttiRecordManagedFields; // Size/Count/Fields
+  offset: PtrUInt;
+  f: PRttiRecordField;
+begin
+  Info^.RecordManagedFields(fields);
+  f := fields.Fields;
+  fields.Fields := @RTTI_BINARYSAVE; // reuse pointer slot on stack
+  offset := 0;
+  while fields.Count <> 0 do
+  begin
+    dec(fields.Count);
+    Info := f^.{$ifdef HASDIRECTTYPEINFO}TypeInfo{$else}TypeInfoRef^{$endif};
+    {$ifdef FPC_OLDRTTI}
+    if Info^.Kind in rkManagedTypes then
+    {$endif FPC_OLDRTTI}
+    begin
+      offset := f^.Offset - offset;
+      if offset <> 0 then
+      begin
+        Dest.Write(Data, offset);
+        inc(Data, offset);
+      end;
+      offset := PRttiBinarySaves(fields.Fields)[Info^.Kind](Data, Dest, Info);
+      inc(Data, offset);
+      inc(offset, f^.Offset);
+    end;
+    inc(f);
+  end;
+  offset := PtrUInt(fields.Size) - offset;
+  if offset <> 0 then
+    Dest.Write(Data, offset);
+  result := fields.Size;
+end;
+
+function _BL_Record(Data: PAnsiChar; var Source: TFastReader; Info: PRttiInfo): PtrInt;
+var
+  fields: TRttiRecordManagedFields; // Size/Count/Fields
+  offset: PtrUInt;
+  f: PRttiRecordField;
+begin
+  Info^.RecordManagedFields(fields);
+  f := fields.Fields;
+  fields.Fields := @RTTI_BINARYLOAD; // reuse pointer slot on stack
+  offset := 0;
+  while fields.Count <> 0 do
+  begin
+    dec(fields.Count);
+    Info := f^.{$ifdef HASDIRECTTYPEINFO}TypeInfo{$else}TypeInfoRef^{$endif};
+    {$ifdef FPC_OLDRTTI}
+    if Info^.Kind in rkManagedTypes then
+    {$endif FPC_OLDRTTI}
+    begin
+      offset := f^.Offset - offset;
+      if offset <> 0 then
+      begin
+        Source.Copy(Data, offset);
+        inc(Data, offset);
+      end;
+      offset := PRttiBinaryLoads(fields.Fields)[Info^.Kind](Data, Source, Info);
+      inc(Data, offset);
+      inc(offset, f^.Offset);
+    end;
+    inc(f);
+  end;
+  offset := PtrUInt(fields.Size) - offset;
+  if offset <> 0 then
+    Source.Copy(Data, offset);
+  result := fields.Size;
+end;
+
+function _RecordCompare(A, B: PUtf8Char; Info: PRttiInfo;
+ CaseInSensitive: boolean): integer;
+var
+  fields: TRttiRecordManagedFields; // Size/Count/Fields
+  offset: PtrUInt;
+  f: PRttiRecordField;
+begin
+  Info^.RecordManagedFields(fields);
+  f := fields.Fields;
+  fields.Fields := @RTTI_COMPARE[CaseInSensitive]; // reuse pointer slot on stack
+  offset := 0;
+  if fields.Count <> 0 then
+    repeat
+      dec(fields.Count);
+      Info := f^.{$ifdef HASDIRECTTYPEINFO}TypeInfo{$else}TypeInfoRef^{$endif};
+      {$ifdef FPC_OLDRTTI}
+      if Info^.Kind in rkManagedTypes then
+      {$endif FPC_OLDRTTI}
+      begin
+        offset := f^.Offset - offset;
+        if offset <> 0 then
+        begin
+          result := MemCmp(pointer(A), pointer(B), offset); // binary comparison
+          if result <> 0 then
+            exit;
+          inc(A, offset);
+          inc(B, offset);
+        end;
+        offset := PRttiCompares(fields.Fields)[Info^.Kind](A, B, Info, result);
+        inc(A, offset);
+        inc(B, offset);
+        if result <> 0 then
+          exit;
+        inc(offset, f^.Offset);
+      end;
+      inc(f);
+    until fields.Count = 0
+  else
+    result := 0;
+  offset := PtrUInt(fields.Size) - offset;
+  if offset <> 0 then
+    result := MemCmp(pointer(A), pointer(B), offset); // trailing binary
+end;
+
+function _BC_Record(A, B: pointer; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  if A = B then
+    Compared := 0
+  else
+    Compared := _RecordCompare(A, B, Info, {caseinsens=}false);
+  result := Info^.RecordSize;
+end;
+
+function _BCI_Record(A, B: pointer; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  if A = B then
+    Compared := 0
+  else
+    Compared := _RecordCompare(A, B, Info, {caseinsens=}true);
+  result := Info^.RecordSize;
+end;
+
+function _BS_Array(Data: PAnsiChar; Dest: TBufferWriter; Info: PRttiInfo): PtrInt;
+var
+  n: PtrInt;
+  sav: TRttiBinarySave;
+label
+  raw;
+begin
+  Info := Info^.ArrayItemType(n, result);
+  if Info = nil then
+raw:Dest.Write(Data, result)
+  else
+  begin
+    sav := RTTI_BINARYSAVE[Info^.Kind];
+    if Assigned(sav) then // paranoid check
+      repeat
+        inc(Data, sav(Data, Dest, Info));
+        dec(n);
+      until n = 0
+    else
+      goto raw;
+  end;
+end;
+
+function _BL_Array(Data: PAnsiChar; var Source: TFastReader; Info: PRttiInfo): PtrInt;
+var
+  n: PtrInt;
+  load: TRttiBinaryLoad;
+label
+  raw;
+begin
+  Info := Info^.ArrayItemType(n, result);
+  if Info = nil then
+raw:Source.Copy(Data, result)
+  else
+  begin
+    load := RTTI_BINARYLOAD[Info^.Kind];
+    if Assigned(load) then // paranoid check
+      repeat
+        inc(Data, load(Data, Source, Info));
+        dec(n);
+      until n = 0
+    else
+      goto raw;
+  end;
+end;
+
+function _BC_Array(A, B: pointer; Info: PRttiInfo; out Compared: integer): PtrInt;
+var
+  n: PtrInt;
+begin
+  Info := Info^.ArrayItemType(n, result);
+  Compared := BinaryCompare(A, B, Info, n, {CaseInSensitive=}false);
+end;
+
+function _BCI_Array(A, B: pointer; Info: PRttiInfo; out Compared: integer): PtrInt;
+var
+  n: PtrInt;
+begin
+  Info := Info^.ArrayItemType(n, result);
+  Compared := BinaryCompare(A, B, Info, n, {CaseInSensitive=}true);
+end;
+
+procedure _BS_VariantComplex(Data: PVariant; Dest: TBufferWriter);
+var
+  temp: RawUtf8;
+begin
+  // not very fast, but creates valid JSON
+  _VariantSaveJson(Data^, twJsonEscape, temp);
+  Dest.Write(temp);
+end;
+
+procedure _BL_VariantComplex(Data: PVariant; var Source: TFastReader);
+var
+  temp: TSynTempBuffer;
+begin
+  Source.VarBlob(temp); // load into a private copy for in-place JSON parsing
+  try
+    BinaryVariantLoadAsJson(Data^, temp.buf, Source.CustomVariants);
+  finally
+    temp.Done;
+  end;
+end;
+
+const
+  // 0 for unserialized VType, 255 for valOleStr
+  VARIANT_SIZE: array[varEmpty .. varWord64] of byte = (
+    0, 0, 2, 4, 4, 8, 8, 8, 255, 0, 0, 2, 0, 0, 0, 0, 1, 1, 2, 4, 8, 8);
+
+function _BS_Variant(Data: PVarData; Dest: TBufferWriter; Info: PRttiInfo): PtrInt;
+var
+  vt: cardinal;
+begin
+  Data := VarDataFromVariant(PVariant(Data)^); // handle varByRef
+  vt := Data^.VType;
+  Dest.Write2(vt);
+  if vt <= high(VARIANT_SIZE) then
+  begin
+    vt := VARIANT_SIZE[vt];
+    if vt <> 0 then
+      if vt = 255 then // valOleStr
+        Dest.WriteVar(Data^.vAny, length(WideString(Data^.vAny)) * 2)
+      else
+        Dest.Write(@Data^.VInt64, vt); // simple types are stored as binary
+  end
+  else if (vt = varString) and  // expect only RawUtf8
+          (Data^.vAny <> nil) then
+    Dest.WriteVar(Data^.vAny, PStrLen(PAnsiChar(Data^.VAny) - _STRLEN)^)
+  {$ifdef HASVARUSTRING}
+  else if vt = varUString then
+    Dest.WriteVar(Data^.vAny, length(UnicodeString(Data^.vAny)) * 2)
+  {$endif HASVARUSTRING}
+  else
+    _BS_VariantComplex(pointer(Data), Dest);
+  result := SizeOf(Data^);
+end;
+
+function _BL_Variant(Data: PVarData; var Source: TFastReader; Info: PRttiInfo): PtrInt;
+var
+  vt: cardinal;
+begin
+  VarClear(PVariant(Data)^);
+  Source.Copy(@Data^.VType, 2);
+  Data^.VAny := nil; // to avoid GPF below
+  vt := Data^.VType;
+  if vt <= high(VARIANT_SIZE) then
+  begin
+    vt := VARIANT_SIZE[vt];
+    if vt <> 0 then
+      if vt = 255 then
+        with Source.VarBlob do // valOleStr
+          SetString(WideString(Data^.vAny), PWideChar(Ptr), Len shr 1)
+      else
+        Source.Copy(@Data^.VInt64, vt); // simple types
+  end
+  else if vt = varString then
+    with Source.VarBlob do
+      FastSetString(RawUtf8(Data^.vAny), Ptr, Len) // expect only RawUtf8
+  {$ifdef HASVARUSTRING}
+  else if vt = varUString then
+    with Source.VarBlob do
+      SetString(UnicodeString(Data^.vAny), PWideChar(Ptr), Len shr 1)
+  {$endif HASVARUSTRING}
+  else if Assigned(BinaryVariantLoadAsJson) then
+    _BL_VariantComplex(pointer(Data), Source)
+  else
+    Source.ErrorData('RTTI_BINARYLOAD[tkVariant] missing mormot.core.json.pas', []);
+  result := SizeOf(Data^);
+end;
+
+function _BC_Variant(A, B: PVarData; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  if A = B then
+    Compared := 0
+  else
+    Compared := SortDynArrayVariantComp(A^, B^, {caseinsens=}false);
+  result := SizeOf(variant);
+end;
+
+function _BCI_Variant(A, B: PVarData; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  if A = B then
+    Compared := 0
+  else
+    Compared := SortDynArrayVariantComp(A^, B^, {caseinsens=}true);
+  result := SizeOf(variant);
+end;
+
+function ObjectCompare(A, B: TObject; CaseInSensitive: boolean): integer;
+var
+  rA, rB: TRttiCustom;
+  pA, pB: PRttiCustomProp;
+  i: integer;
+begin
+  if (A = nil) or
+     (B = nil) or
+     (A = B) then
+  begin
+    result := ComparePointer(A, B);
+    exit;
+  end;
+  result := 0;
+  rA := Rtti.RegisterClass(A); // faster than RegisterType(Info)
+  pA := pointer(rA.Props.List);
+  if PClass(B)^.InheritsFrom(PClass(A)^) then
+    // same (or similar/inherited) class -> compare per exact properties
+    for i := 1 to rA.Props.Count do
+    begin
+      result := pA^.CompareValue(A, B, pA^, CaseInSensitive);
+      if result <> 0 then
+        exit;
+      inc(pA);
+    end
+  else
+  begin
+    // compare properties by name
+    rB := Rtti.RegisterClass(B);
+    for i := 1 to rA.Props.Count do
+    begin
+      if pA^.Name <> '' then
+      begin
+        pB := rB.Props.Find(pA^.Name);
+        if pB <> nil then // just ignore missing properties
+        begin
+          result := pA^.CompareValue(A, B, pB^, CaseInSensitive);
+          if result <> 0 then
+            exit;
+        end;
+      end;
+      inc(pA);
+    end;
+  end;
+end;
+
+function _BC_Object(A, B: PObject; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := ObjectCompare(A^, B^, {caseinsens=}false);
+  result := SizeOf(pointer);
+end;
+
+function _BCI_Object(A, B: PObject; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := ObjectCompare(A^, B^, {caseinsens=}true);
+  result := SizeOf(pointer);
+end;
+
+function ObjectEquals(A, B: TObject): boolean;
+begin
+  result := ObjectCompare(A, B, {caseinsensitive=}false) = 0;
+end;
+
+function ObjectEqualsI(A, B: TObject): boolean;
+begin
+  result := ObjectCompare(A, B, {caseinsensitive=}true) = 0;
+end;
+
+function ObjectCompare(A, B: PObject; Count: PtrInt;
+  CaseInsensitive: boolean): integer;
+begin
+  if Count > 0 then
+    repeat
+      result := ObjectCompare(A^, B^, CaseInsensitive);
+      if result <> 0 then
+        exit;
+      inc(A);
+      inc(B);
+      dec(Count);
+    until Count = 0;
+  result := 0;
+end;
+
+function BinaryEquals(A, B: pointer; Info: PRttiInfo; PSize: PInteger;
+  Kinds: TRttiKinds; CaseInSensitive: boolean): boolean;
+var
+  size, comp: integer;
+  cmp: TRttiCompare;
+begin
+  cmp := RTTI_COMPARE[CaseInSensitive, Info^.Kind];
+  if Assigned(cmp) and
+     (Info^.Kind in Kinds) then
+  begin
+    size := cmp(A, B, Info, comp);
+    if PSize <> nil then
+      PSize^ := size;
+    result := comp = 0;
+  end
+  else
+    result := false; // no fair comparison possible
+end;
+
+function BinaryCompare(A, B: pointer; Info: PRttiInfo;
+  CaseInSensitive: boolean): integer;
+var
+  cmp: TRttiCompare;
+begin
+  if A <> B then
+    if Info <> nil then
+    begin
+      cmp := RTTI_COMPARE[CaseInSensitive, Info^.Kind];
+      if Assigned(cmp) then
+        cmp(A, B, Info, result)
+      else
+        result := MemCmp(A, B, Info^.RttiSize);
+    end
+    else
+      result := ComparePointer(A, B)
+  else
+    result := 0;
+end;
+
+function BinaryCompare(A, B: pointer; Info: PRttiInfo; Count: PtrInt;
+  CaseInSensitive: boolean): integer;
+var
+  cmp: TRttiCompare;
+  siz: PtrInt;
+begin
+  if (A <> B) and
+     (Count > 0) then
+    if Info <> nil then
+    begin
+      cmp := RTTI_COMPARE[CaseInSensitive, Info^.Kind];
+      if Assigned(cmp) then
+        repeat
+          siz := cmp(A, B, Info, result);
+          inc(PAnsiChar(A), siz);
+          inc(PAnsiChar(B), siz);
+          if result <> 0 then
+            exit;
+          dec(Count);
+        until Count = 0
+      else
+        result := MemCmp(A, B, Count * Info^.RttiSize);
+    end
+    else
+      result := ComparePointer(A, B)
+  else
+    result := 0;
+end;
+
+{$ifndef PUREMORMOT2}
+
+function BinarySaveLength(Data: pointer; Info: PRttiInfo; Len: PInteger;
+  Kinds: TRttiKinds): integer;
+var
+  size: integer;
+  W: TBufferWriter; // not very fast, but good enough (RecordSave don't use it)
+  temp: array[byte] of byte; // will use mostly TFakeWriterStream.Write()
+  save: TRttiBinarySave;
+begin
+  save := RTTI_BINARYSAVE[Info^.Kind];
+  if Assigned(save) and
+     (Info^.Kind in Kinds) then
+  begin
+    W := TBufferWriter.Create(TFakeWriterStream, @temp, SizeOf(temp));
+    try
+      size := save(Data, W, Info);
+      if Len <> nil then
+        Len^ := size;
+      result := W.TotalWritten;
+    finally
+      W.Free;
+    end;
+  end
+  else
+    result := 0;
+end;
+
+function BinarySave(Data: pointer; Dest: PAnsiChar; Info: PRttiInfo;
+  out Len: integer; Kinds: TRttiKinds): PAnsiChar;
+var
+  W: TBufferWriter;
+  save: TRttiBinarySave;
+begin
+  save := RTTI_BINARYSAVE[Info^.Kind];
+  if Assigned(save) and
+     (Info^.Kind in Kinds) then
+  begin
+    W := TBufferWriter.Create(TFakeWriterStream, Dest, 1 shl 30);
+    try
+      Len := save(Data, W, Info);
+      result := Dest + W.BufferPosition; // Dest as a 1GB temporary buffer :)
+    finally
+      W.Free;
+    end;
+  end
+  else
+    result := nil;
+end;
+
+{$endif PUREMORMOT2}
+
+procedure BinarySave(Data: pointer; Info: PRttiInfo; Dest: TBufferWriter);
+var
+  save: TRttiBinarySave;
+begin
+  save := RTTI_BINARYSAVE[Info^.Kind];
+  if Assigned(save) then
+    save(Data, Dest, Info);
+end;
+
+function BinarySave(Data: pointer; Info: PRttiInfo;
+  Kinds: TRttiKinds; WithCrc: boolean): RawByteString;
+var
+  W: TBufferWriter;
+  temp: TTextWriterStackBuffer; // 8KB
+  save: TRttiBinarySave;
+begin
+  save := RTTI_BINARYSAVE[Info^.Kind];
+  if Assigned(save) and
+     (Info^.Kind in Kinds) then
+  begin
+    W := TBufferWriter.Create(temp{%H-});
+    try
+      if WithCrc then
+        W.Write4(0);
+      save(Data, W, Info);
+      result := W.FlushTo;
+      if WithCrc then
+        PCardinal(result)^ :=
+          crc32c(0, @PCardinalArray(result)[1], length(result) - 4);
+    finally
+      W.Free;
+    end;
+  end
+  else
+    result := '';
+end;
+
+function BinarySaveBytes(Data: pointer; Info: PRttiInfo;
+  Kinds: TRttiKinds): TBytes;
+var
+  W: TBufferWriter;
+  temp: TTextWriterStackBuffer; // 8KB
+  save: TRttiBinarySave;
+begin
+  save := RTTI_BINARYSAVE[Info^.Kind];
+  if Assigned(save) and
+     (Info^.Kind in Kinds) then
+  begin
+    W := TBufferWriter.Create(temp{%H-});
+    try
+      save(Data, W, Info);
+      result := W.FlushToBytes;
+    finally
+      W.Free;
+    end;
+  end
+  else
+    result := nil;
+end;
+
+procedure BinarySave(Data: pointer; var Dest: TSynTempBuffer; Info: PRttiInfo;
+  Kinds: TRttiKinds; WithCrc: boolean);
+var
+  W: TBufferWriter;
+  save: TRttiBinarySave;
+begin
+  save := RTTI_BINARYSAVE[Info^.Kind];
+  if Assigned(save) and
+     (Info^.Kind in Kinds) then
+  begin
+    W := TBufferWriter.Create(TRawByteStringStream, @Dest.tmp,
+      SizeOf(Dest.tmp) - 16); // Dest.Init() reserves 16 additional bytes
+    try
+      if WithCrc then
+        W.Write4(0);
+      save(Data, W, Info);
+      if W.Stream.Position = 0 then
+        // only Dest.tmp buffer was used -> just set the proper size
+        Dest.Init(W.TotalWritten)
+      else
+        // more than 4KB -> temporary allocation through the temp RawByteString
+        Dest.Init(W.FlushTo);
+      if WithCrc then
+        PCardinal(Dest.buf)^ :=
+          crc32c(0, @PCardinalArray(Dest.buf)[1], Dest.len  - 4);
+    finally
+      W.Free;
+    end;
+  end
+  else
+    Dest.Init(0);
+end;
+
+function BinarySaveBase64(Data: pointer; Info: PRttiInfo; UriCompatible: boolean;
+  Kinds: TRttiKinds; WithCrc: boolean): RawUtf8;
+var
+  W: TBufferWriter;
+  temp: TTextWriterStackBuffer; // 8KB
+  tmp: RawByteString;
+  P: PAnsiChar;
+  len: integer;
+  save: TRttiBinarySave;
+begin
+  save := RTTI_BINARYSAVE[Info^.Kind];
+  if Assigned(save) and
+     (Info^.Kind in Kinds) then
+  begin
+    W := TBufferWriter.Create(temp{%H-});
+    try
+      if WithCrc then
+        // placeholder for the trailing crc32c
+        W.Write4(0);
+      save(Data, W, Info);
+      len := W.TotalWritten;
+      if W.Stream.Position = 0 then
+        // only temp buffer was used
+        P := pointer(@temp)
+      else
+      begin
+        // more than 8KB -> temporary allocation
+        tmp := W.FlushTo;
+        P := pointer(tmp);
+      end;
+      if WithCrc then
+        // as mORMot 1.18 RecordSaveBase64()
+        PCardinal(P)^ := crc32c(0, P + 4, len - 4);
+      if UriCompatible then
+        result := BinToBase64uri(P, len)
+      else
+        result := BinToBase64(P, len);
+    finally
+      W.Free;
+    end;
+  end
+  else
+    result := '';
+end;
+
+function BinaryLoad(Data: pointer; Source: PAnsiChar; Info: PRttiInfo;
+  Len: PInteger; SourceMax: PAnsiChar; Kinds: TRttiKinds;
+  TryCustomVariants: PDocVariantOptions): PAnsiChar;
+var
+  size: integer;
+  read: TFastReader;
+  load: TRttiBinaryLoad;
+begin
+  load := RTTI_BINARYLOAD[Info^.Kind];
+  if Assigned(load) and
+     (Info^.Kind in Kinds) and
+     (SourceMax <> nil) then
+  begin
+    {%H-}read.Init(Source, SourceMax - Source);
+    read.CustomVariants := TryCustomVariants;
+    size := load(Data, read, Info);
+    if Len <> nil then
+      Len^ := size;
+    result := read.P;
+  end
+  else
+    result := nil;
+end;
+
+function BinaryLoad(Data: pointer; const Source: RawByteString; Info: PRttiInfo;
+  Kinds: TRttiKinds; TryCustomVariants: PDocVariantOptions): boolean;
+var
+  P: PAnsiChar;
+begin
+  if Info^.Kind in Kinds then
+  begin
+    P := pointer(Source);
+    P := BinaryLoad(Data, P, Info, nil, P + length(Source), Kinds, TryCustomVariants);
+    result := (P <> nil) and
+              (P - pointer(Source) = length(Source));
+  end
+  else
+    result := false;
+end;
+
+function BinaryLoadBase64(Source: PAnsiChar; Len: PtrInt; Data: pointer;
+  Info: PRttiInfo; UriCompatible: boolean; Kinds: TRttiKinds;
+  WithCrc: boolean; TryCustomVariants: PDocVariantOptions): boolean;
+var
+  temp: TSynTempBuffer;
+  tempend: pointer;
+begin
+  if (Len > 6) and
+     (Info^.Kind in Kinds) then
+  begin
+    if UriCompatible then
+      result := Base64uriToBin(Source, Len, temp)
+    else
+      result := Base64ToBin(Source, Len, temp);
+    tempend := PAnsiChar(temp.buf) + temp.len;
+    if result then
+      if WithCrc then
+        result := (temp.len >= 4) and
+          (crc32c(0, PAnsiChar(temp.buf) + 4, temp.len - 4) = PCardinal(temp.buf)^) and
+          (BinaryLoad(Data, PAnsiChar(temp.buf) + 4, Info, nil, tempend,
+            Kinds, TryCustomVariants) = tempend)
+      else
+        result := (BinaryLoad(Data, temp.buf, Info, nil, tempend,
+            Kinds, TryCustomVariants) = tempend);
+    temp.Done;
+  end
+  else
+    result := false;
+end;
+
+
+function RecordEquals(const RecA, RecB; TypeInfo: PRttiInfo; PRecSize: PInteger;
+  CaseInSensitive: boolean): boolean;
+begin
+  result := BinaryEquals(@RecA, @RecB, TypeInfo, PRecSize,
+    rkRecordTypes, CaseInSensitive);
+end;
+
+{$ifndef PUREMORMOT2}
+
+function RecordSaveLength(const Rec; TypeInfo: PRttiInfo; Len: PInteger): integer;
+begin
+ result := {%H-}BinarySaveLength(@Rec, TypeInfo, Len, rkRecordTypes);
+end;
+
+function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: PRttiInfo;
+  out Len: integer): PAnsiChar;
+begin
+  result := {%H-}BinarySave(@Rec, Dest, TypeInfo, Len, rkRecordTypes);
+end;
+
+function RecordSave(const Rec; Dest: PAnsiChar; TypeInfo: PRttiInfo): PAnsiChar;
+var
+  dummylen: integer;
+begin
+  result := {%H-}BinarySave(@Rec, Dest, TypeInfo, dummylen, rkRecordTypes);
+end;
+
+{$endif PUREMORMOT2}
+
+function RecordSave(const Rec; TypeInfo: PRttiInfo): RawByteString;
+begin
+  result := BinarySave(@Rec, TypeInfo, rkRecordTypes);
+end;
+
+function RecordSaveBytes(const Rec; TypeInfo: PRttiInfo): TBytes;
+begin
+ result := BinarySaveBytes(@Rec, TypeInfo, rkRecordTypes);
+end;
+
+procedure RecordSave(const Rec; var Dest: TSynTempBuffer; TypeInfo: PRttiInfo);
+begin
+  BinarySave(@Rec, Dest, TypeInfo, rkRecordTypes);
+end;
+
+function RecordSaveBase64(const Rec; TypeInfo: PRttiInfo; UriCompatible: boolean): RawUtf8;
+begin
+  result := BinarySaveBase64(@Rec, TypeInfo, UriCompatible, rkRecordTypes);
+end;
+
+function RecordLoad(var Rec; Source: PAnsiChar; TypeInfo: PRttiInfo;
+  Len: PInteger; SourceMax: PAnsiChar; TryCustomVariants: PDocVariantOptions): PAnsiChar;
+begin
+  {$ifndef PUREMORMOT2}
+  if SourceMax = nil then
+    // mORMot 1 unsafe backward compatible: assume fake 100MB Source input
+    SourceMax := Source + 100 shl 20;
+  {$endif PUREMORMOT2}
+  result := BinaryLoad(@Rec, Source, TypeInfo, Len, SourceMax,
+    rkRecordTypes, TryCustomVariants);
+end;
+
+function RecordLoad(var Rec; const Source: RawByteString; TypeInfo: PRttiInfo;
+  TryCustomVariants: PDocVariantOptions): boolean;
+begin
+  result := BinaryLoad(@Rec, Source, TypeInfo, rkRecordTypes, TryCustomVariants);
+end;
+
+function RecordLoadBase64(Source: PAnsiChar; Len: PtrInt; var Rec;
+  TypeInfo: PRttiInfo; UriCompatible: boolean; TryCustomVariants: PDocVariantOptions): boolean;
+begin
+  result := BinaryLoadBase64(Source, Len, @Rec, TypeInfo, UriCompatible,
+    rkRecordTypes, {withcrc=}true, TryCustomVariants);
+end;
+
+
+
+
+
+{ ************ TDynArray and TDynArrayHashed Wrappers }
+
+const
+  // helper arrays to get the standard comparison/hash functions
+  PT_SORT: array[{caseins=}boolean, TRttiParserType] of TDynArraySortCompare = (
+    // case sensitive comparison/sort functions:
+    (nil,                       //  ptNone
+     nil,                       //  ptArray
+     SortDynArrayBoolean,       //  ptBoolean
+     SortDynArrayByte,          //  ptByte
+     SortDynArrayCardinal,      //  ptCardinal
+     SortDynArrayInt64,         //  ptCurrency
+     SortDynArrayDouble,        //  ptDouble
+     SortDynArrayExtended,      //  ptExtended
+     SortDynArrayInt64,         //  ptInt64
+     SortDynArrayInteger,       //  ptInteger
+     SortDynArrayQWord,         //  ptQWord
+     {$ifdef CPUINTEL}SortDynArrayAnsiString
+     {$else}SortDynArrayRawByteString{$endif}, //  ptRawByteString
+     SortDynArrayAnsiString,    //  ptRawJson
+     SortDynArrayAnsiString,    //  ptRawUtf8
+     nil,                       //  ptRecord
+     SortDynArraySingle,        //  ptSingle
+     {$ifdef UNICODE}SortDynArrayString
+     {$else}SortDynArrayAnsiString{$endif}, //  ptString
+     SortDynArrayUnicodeString, //  ptSynUnicode
+     SortDynArrayDouble,        //  ptDateTime
+     SortDynArrayDouble,        //  ptDateTimeMS
+     SortDynArray128,           //  ptGuid
+     SortDynArray128,           //  ptHash128
+     SortDynArray256,           //  ptHash256
+     SortDynArray512,           //  ptHash512
+     SortDynArrayInt64,         //  ptOrm
+     SortDynArrayInt64,         //  ptTimeLog
+     SortDynArrayUnicodeString, //  ptUnicodeString
+     SortDynArrayInt64,         //  ptUnixTime
+     SortDynArrayInt64,         //  ptUnixMSTime
+     SortDynArrayVariant,       //  ptVariant
+     SortDynArrayUnicodeString, //  ptWideString
+     SortDynArrayAnsiString,    //  ptWinAnsi
+     SortDynArrayWord,          //  ptWord
+     nil,                       //  ptEnumeration
+     nil,                       //  ptSet
+     SortDynArrayPointer,       //  ptClass
+     nil,                       //  ptDynArray
+     SortDynArrayPointer,       //  ptInterface
+     SortDynArrayPUtf8Char,     //  ptPUtf8Char
+     nil),                      //  ptCustom
+    // case insensitive comparison/sort functions:
+    (nil,                        //  ptNone
+     nil,                        //  ptArray
+     SortDynArrayBoolean,        //  ptBoolean
+     SortDynArrayByte,           //  ptByte
+     SortDynArrayCardinal,       //  ptCardinal
+     SortDynArrayInt64,          //  ptCurrency
+     SortDynArrayDouble,         //  ptDouble
+     SortDynArrayExtended,       //  ptExtended
+     SortDynArrayInt64,          //  ptInt64
+     SortDynArrayInteger,        //  ptInteger
+     SortDynArrayQWord,          //  ptQWord
+     {$ifdef CPUINTEL}SortDynArrayAnsiString
+     {$else}SortDynArrayRawByteString{$endif}, //  ptRawByteString
+     SortDynArrayAnsiStringI,    //  ptRawJson
+     SortDynArrayAnsiStringI,    //  ptRawUtf8
+     nil,                        //  ptRecord
+     SortDynArraySingle,         //  ptSingle
+     SortDynArrayStringI,        //  ptString
+     SortDynArrayUnicodeStringI, //  ptSynUnicode
+     SortDynArrayDouble,         //  ptDateTime
+     SortDynArrayDouble,         //  ptDateTimeMS
+     SortDynArray128,            //  ptGuid
+     SortDynArray128,            //  ptHash128
+     SortDynArray256,            //  ptHash256
+     SortDynArray512,            //  ptHash512
+     SortDynArrayInt64,          //  ptOrm
+     SortDynArrayInt64,          //  ptTimeLog
+     SortDynArrayUnicodeStringI, //  ptUnicodeString
+     SortDynArrayInt64,          //  ptUnixTime
+     SortDynArrayInt64,          //  ptUnixMSTime
+     SortDynArrayVariantI,       //  ptVariant
+     SortDynArrayUnicodeStringI, //  ptWideString
+     SortDynArrayAnsiStringI,    //  ptWinAnsi
+     SortDynArrayWord,           //  ptWord
+     nil,                        //  ptEnumeration
+     nil,                        //  ptSet
+     SortDynArrayPointer,        //  ptClass
+     nil,                        //  ptDynArray
+     SortDynArrayPointer,        //  ptInterface
+     SortDynArrayPUtf8CharI,     //  ptPUtf8Char
+     nil));                      //  ptCustom
+
+function DynArraySortOne(Kind: TRttiParserType;
+  CaseInsensitive: boolean): TDynArraySortCompare;
+begin
+  result := PT_SORT[CaseInsensitive, Kind];
+end;
+
+procedure ObjArraySort(var aValue; Compare: TDynArraySortCompare;
+  CountPointer: PInteger);
+begin
+  DynArray(TypeInfo(TObjectDynArray), aValue, CountPointer).Sort(Compare);
+end;
+
+
+{ TDynArray }
+
+procedure TDynArray.InitRtti(aInfo: TRttiCustom; var aValue;
+  aCountPointer: PInteger);
+begin
+  fInfo := aInfo;
+  fValue := @aValue;
+  fCountP := aCountPointer;
+  if fCountP <> nil then
+    fCountP^ := 0;
+  fCompare := nil;
+  fSorted := false;
+  fNoFinalize := false;
+end;
+
+procedure TDynArray.InitRtti(aInfo: TRttiCustom; var aValue);
+begin
+  fInfo := aInfo;
+  fValue := @aValue;
+  fCountP := nil;
+  fCompare := nil;
+  fSorted := false;
+  fNoFinalize := false;
+end;
+
+procedure TDynArray.Init(aTypeInfo: PRttiInfo; var aValue;
+  aCountPointer: PInteger);
+begin
+  if aTypeInfo^.Kind <> rkDynArray then
+    raise EDynArray.CreateUtf8('TDynArray.Init: % is %, expected rkDynArray',
+      [aTypeInfo.RawName, ToText(aTypeInfo.Kind)^]);
+  InitRtti(Rtti.RegisterType(aTypeInfo), aValue, aCountPointer);
+end;
+
+function TDynArray.InitSpecific(aTypeInfo: PRttiInfo; var aValue;
+  aKind: TRttiParserType; aCountPointer: PInteger; aCaseInsensitive: boolean): TRttiParserType;
+begin
+  if aTypeInfo^.Kind <> rkDynArray then
+    raise EDynArray.CreateUtf8('TDynArray.InitSpecific: % is %, expected rkDynArray',
+      [aTypeInfo.RawName, ToText(aTypeInfo.Kind)^]);
+  InitRtti(Rtti.RegisterType(aTypeInfo), aValue, aCountPointer);
+  result := SetParserType(aKind, aCaseInsensitive);
+end;
+
+function TDynArray.SetParserType(aKind: TRttiParserType;
+  aCaseInsensitive: boolean): TRttiParserType;
+begin
+  case aKind of
+    ptNone:
+      if Assigned(fInfo.ArrayRtti) then
+        result := fInfo.ArrayRtti.Parser
+      else
+        result := fInfo.ArrayFirstField;
+  else
+    result := aKind;
+  end;
+  fCompare := PT_SORT[aCaseInsensitive, result];
+  if not Assigned(fCompare) then
+    if result = ptVariant then
+      raise EDynArray.CreateUtf8('TDynArray.SetParserType(%): missing mormot.core.json',
+        [Info.Name, ToText(result)^])
+    else if aKind <> ptNone then
+      raise EDynArray.CreateUtf8('TDynArray.SetParserType(%) unsupported %',
+        [Info.Name, ToText(result)^]);
+end;
+
+function TDynArray.ItemSize: PtrUInt;
+begin
+  result := fInfo.Cache.ItemSize;
+end;
+
+function TDynArray.GetCount: PtrInt;
+begin // use result as a single temporary variable for better FPC asm generation
+  result := PtrUInt(fCountP);
+  if result <> 0 then
+    result := PInteger(result)^ // count is external
+  else
+  begin
+    result := PtrUInt(fValue);
+    if result <> 0 then
+    begin
+      result := PPtrInt(result)^;
+      if result <> 0 then
+      begin
+        result := PDALen(result - _DALEN)^; // count = length()
+        {$ifdef FPC} inc(result, _DAOFF); {$endif}
+      end;
+    end;
+  end;
+end;
+
+function TDynArray.GetCapacity: PtrInt;
+begin
+  result := PtrInt(fValue);
+  if result <> 0 then
+  begin
+    result := PPtrInt(result)^;
+    if result <> 0 then
+    begin
+      result := PDALen(result - _DALEN)^; // capacity = length()
+      {$ifdef FPC} inc(result, _DAOFF); {$endif}
+    end;
+  end;
+end;
+
+procedure TDynArray.ItemCopy(Source, Dest: pointer);
+var
+  nfo: TRttiCustom;
+begin
+  nfo := fInfo.ArrayRtti;
+  if (nfo <> nil) and // inlined nfo.ValueCopy() to avoid MoveFast() twice
+     Assigned(nfo.Copy) then
+    nfo.Copy(Dest, Source, nfo.Info) // also for T*ObjArray
+  else
+    MoveFast(Source^, Dest^, fInfo.Cache.ItemSize);
+end;
+
+procedure TDynArray.ItemClear(Item: pointer);
+begin
+  if Item = nil then
+    exit;
+  if (fInfo.ArrayRtti <> nil) and
+     not fNoFinalize then
+    fInfo.ArrayRtti.ValueFinalize(Item); // also for T*ObjArray
+  FillCharFast(Item^, fInfo.Cache.ItemSize, 0); // always
+end;
+
+procedure TDynArray.ItemRandom(Item: pointer);
+begin
+  if Item <> nil then
+    if fInfo.ArrayRtti <> nil then
+      fInfo.ArrayRtti.ValueRandom(Item)
+    else
+      SharedRandom.Fill(Item, fInfo.Cache.ItemSize);
+end;
+
+function TDynArray.ItemEquals(A, B: pointer; CaseInSensitive: boolean): boolean;
+begin
+  result := ItemCompare(A, B, CaseInSensitive) = 0;
+end;
+
+function TDynArray.ItemCompare(A, B: pointer; CaseInSensitive: boolean): integer;
+var
+  comp: TRttiCompare;
+  rtti: PRttiInfo;
+label
+  bin;
+begin
+  if Assigned(fCompare) then
+    result := fCompare(A^, B^)
+  else if not(rcfArrayItemManaged in fInfo.Flags) then
+bin: // fast binary comparison with length
+     result := MemCmp(A, B, fInfo.Cache.ItemSize)
+  else
+  begin
+    rtti := fInfo.Cache.ItemInfo; // <> nil for managed items
+    comp := RTTI_COMPARE[CaseInsensitive, rtti.Kind];
+    if Assigned(comp) then
+      comp(A, B, rtti, result)
+    else
+      goto bin;
+  end;
+end;
+
+function TDynArray.Add(const Item): PtrInt;
+begin
+  result := GetCount;
+  if fValue = nil then
+    exit; // avoid GPF if void
+  SetCount(result + 1);
+  ItemCopy(@Item, PAnsiChar(fValue^) + result * fInfo.Cache.ItemSize);
+end;
+
+function TDynArray.New: PtrInt;
+begin
+  result := GetCount;
+  SetCount(result + 1);
+end;
+
+function TDynArray.NewPtr: pointer;
+var
+  index: PtrInt;
+begin
+  index := GetCount; // in two explicit steps to ensure no problem at inlining
+  SetCount(index + 1);
+  result := PAnsiChar(fValue^) + index * fInfo.Cache.ItemSize;
+end;
+
+function TDynArray.Peek(var Dest): boolean;
+var
+  index: PtrInt;
+begin
+  index := GetCount - 1;
+  result := index >= 0;
+  if result then
+    ItemCopy(PAnsiChar(fValue^) + index * fInfo.Cache.ItemSize, @Dest);
+end;
+
+function TDynArray.Pop(var Dest): boolean;
+var
+  index: PtrInt;
+begin
+  index := GetCount - 1;
+  result := index >= 0;
+  if result then
+  begin
+    ItemMoveTo(index, @Dest);
+    SetCount(index);
+  end;
+end;
+
+function TDynArray.PeekHead(var Dest): boolean;
+begin
+  result := GetCount <> 0;
+  if result then
+    ItemCopy(fValue^, @Dest);
+end;
+
+function TDynArray.PopHead(var Dest): boolean;
+begin
+  result := GetCount <> 0;
+  if result then
+  begin
+    ItemMoveTo(0, @Dest);
+    Delete(0);
+  end;
+end;
+
+procedure TDynArray.Insert(Index: PtrInt; const Item);
+var
+  n: PtrInt;
+  s: PtrUInt;
+  P: PAnsiChar;
+begin
+  if fValue = nil then
+    exit; // avoid GPF if void
+  n := GetCount;
+  SetCount(n + 1);
+  s := fInfo.Cache.ItemSize;
+  if PtrUInt(Index) < PtrUInt(n) then
+  begin
+    // reserve space for the new item
+    P := PAnsiChar(fValue^) + PtrUInt(Index) * s;
+    MoveFast(P[0], P[s], PtrUInt(n - Index) * s);
+    if rcfArrayItemManaged in fInfo.Flags then // avoid GPF in ItemCopy() below
+      FillCharFast(P^, s, 0);
+  end
+  else
+    // Index>=Count -> add at the end
+    P := PAnsiChar(fValue^) + PtrUInt(n) * s;
+  ItemCopy(@Item, 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.Delete(aIndex: PtrInt): boolean;
+var
+  n: PtrInt;
+  s, len: PtrUInt;
+  P: PAnsiChar;
+  wassorted: boolean;
+begin
+  result := false;
+  if fValue = nil then
+    exit; // avoid GPF if void
+  n := GetCount;
+  if PtrUInt(aIndex) >= PtrUInt(n) then
+    exit; // out of range
+  if PDACnt(PAnsiChar(fValue^) - _DACNT)^ > 1 then
+    InternalSetLength(n, n); // unique
+  dec(n);
+  s := fInfo.Cache.ItemSize;
+  P := PAnsiChar(fValue^) + PtrUInt(aIndex) * s;
+  if (fInfo.ArrayRtti <> nil) and
+     not fNoFinalize then
+    fInfo.ArrayRtti.ValueFinalize(P); // also for T*ObjArray
+  len := n - aIndex;
+  if len <> 0 then
+  begin
+    len := len * s;
+    MoveFast(P[s], P[0], len);
+    inc(P, len);
+  end;
+  FillCharFast(P^, s, 0);
+  wassorted := fSorted;
+  SetCount(n); // won't reallocate
+  fSorted := wassorted; // deletion won't change the order
+  result := true;
+end;
+
+{$ifdef FPC} // very efficient inlined code on FPC
+function TDynArray.ItemPtr(index: PtrInt): pointer;
+label
+  ok, ko; // labels make the code shorter and more efficient
+var
+  c: PtrUInt;
+begin
+  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) < PCardinal(c)^ then
+ok:   inc(PByte(result), index * fInfo.Cache.ItemSize) // branchless ext count
+    else
+      goto ko;
+  end
+  else // FPC stores high() in TDALen=PtrInt
+    if PtrUInt(index) <= PPtrUInt(PAnsiChar(result) - _DALEN)^ then
+      goto ok
+    else
+ko:   result := nil;
+end;
+{$else} // latest Delphi compilers have troubles with inlining + labels
+function TDynArray.ItemPtr(index: PtrInt): pointer;
+var
+  c: PtrUInt;
+begin
+  result := pointer(fValue);
+  if result = nil then
+    exit;
+  result := PPointer(result)^;
+  if result = nil then
+    exit;
+  c := PtrUInt(fCountP);
+  if c <> 0 then
+    if PtrUInt(index) < PCardinal(c)^ then
+      inc(PByte(result), index * fInfo.Cache.ItemSize) // branchless ext count
+    else
+      result := nil
+  else // Delphi stores length() in TDALen=NativeInt
+    if PtrUInt(index) < PPtrUInt(PtrUInt(result) - _DALEN)^ then
+      inc(PByte(result), index * fInfo.Cache.ItemSize)
+    else
+      result := nil;
+end;
+{$endif FPC}
+
+function TDynArray.ItemCopyAt(index: PtrInt; Dest: pointer): boolean;
+var
+  p: pointer;
+begin
+  p := ItemPtr(index);
+  if p <> nil then
+  begin
+    ItemCopy(p, Dest);
+    result := true;
+  end
+  else
+    result := false;
+end;
+
+function TDynArray.ItemMoveTo(index: PtrInt; Dest: pointer): boolean;
+var
+  p: pointer;
+begin
+  p := ItemPtr(index);
+  if (p = nil) or
+     (Dest = nil) then
+  begin
+    result := false;
+    exit;
+  end;
+  if (fInfo.ArrayRtti <> nil) and
+     not fNoFinalize then
+    fInfo.ArrayRtti.ValueFinalize(Dest); // also handle T*ObjArray
+  MoveFast(p^, Dest^, fInfo.Cache.ItemSize);
+  FillCharFast(p^, fInfo.Cache.ItemSize, 0);
+  result := true;
+end;
+
+procedure TDynArray.ItemCopyFrom(Source: pointer; index: PtrInt;
+  ClearBeforeCopy: boolean);
+var
+  p: pointer;
+begin
+  p := ItemPtr(index);
+  if p <> nil then
+  begin
+    if ClearBeforeCopy then // safer if Source is a copy of p^
+      ItemClear(p);
+    ItemCopy(Source, p);
+  end;
+end;
+
+{$ifdef CPU64}
+procedure Exchg16(P1, P2: PPtrIntArray); inline;
+var
+  c: PtrInt;
+begin
+  c := P1[0];
+  P1[0] := P2[0];
+  P2[0] := c;
+  c := P1[1];
+  P1[1] := P2[1];
+  P2[1] := c;
+end;
+{$endif CPU64}
+
+procedure TDynArray.Reverse;
+var
+  n, siz: PtrInt;
+  P1, P2: PAnsiChar;
+  c: AnsiChar;
+  i32: integer;
+  i64: Int64;
+begin
+  n := GetCount - 1;
+  if n > 0 then
+  begin
+    siz := fInfo.Cache.ItemSize;
+    P1 := fValue^;
+    case siz of
+      1:
+        begin
+          // optimized version for TByteDynArray and such
+          P2 := P1 + n;
+          while P1 < P2 do
+          begin
+            c := P1^;
+            P1^ := P2^;
+            P2^ := c;
+            inc(P1);
+            dec(P2);
+          end;
+        end;
+      4:
+        begin
+          // optimized version for TIntegerDynArray and such
+          P2 := P1 + n * SizeOf(integer);
+          while P1 < P2 do
+          begin
+            i32 := PInteger(P1)^;
+            PInteger(P1)^ := PInteger(P2)^;
+            PInteger(P2)^ := i32;
+            inc(P1, 4);
+            dec(P2, 4);
+          end;
+        end;
+      8:
+        begin
+          // optimized version for TInt64DynArray + TDoubleDynArray and such
+          P2 := P1 + n * SizeOf(Int64);
+          while P1 < P2 do
+          begin
+            i64 := PInt64(P1)^;
+            PInt64(P1)^ := PInt64(P2)^;
+            PInt64(P2)^ := i64;
+            inc(P1, 8);
+            dec(P2, 8);
+          end;
+        end;
+      16:
+        begin
+          // optimized version for 32-bit TVariantDynArray and such
+          P2 := P1 + n * 16;
+          while P1 < P2 do
+          begin
+            {$ifdef CPU64}Exchg16{$else}ExchgVariant{$endif}(pointer(P1), pointer(P2));
+            inc(P1, 16);
+            dec(P2, 16);
+          end;
+        end;
+    {$ifdef CPU64}
+      24:
+        begin
+          // optimized version for 64-bit TVariantDynArray and such
+          P2 := P1 + n * 24;
+          while P1 < P2 do
+          begin
+            ExchgVariant(Pointer(P1), Pointer(P2));
+            inc(P1, 24);
+            dec(P2, 24);
+          end;
+        end;
+    {$endif CPU64}
+    else
+      begin
+        // generic version
+        P2 := P1 + n * siz;
+        while P1 < P2 do
+        begin
+          Exchg(P1, P2, siz);
+          inc(P1, siz);
+          dec(P2, siz);
+        end;
+      end;
+    end;
+  end;
+end;
+
+procedure TDynArray.FillZero;
+var
+  n: integer;
+begin
+  n := GetCount;
+  if n <> 0 then
+    if not (rcfArrayItemManaged in fInfo.Flags) then
+      FillCharFast(fValue^^, n * fInfo.Cache.ItemSize, 0) // e.g. THash256
+    else
+      FillZeroRtti(fInfo.Cache.ItemInfo, fValue^^);
+end;
+
+procedure TDynArray.SaveTo(W: TBufferWriter);
+begin
+  DynArraySave(pointer(fValue), fCountP, W, Info.Info);
+end;
+
+procedure TDynArray.SaveToStream(Stream: TStream);
+var
+  W: TBufferWriter;
+  tmp: TTextWriterStackBuffer; // 8KB buffer
+begin
+  if (fValue = nil) or
+     (Stream = nil) then
+    exit; // avoid GPF if void
+  W := TBufferWriter.Create(Stream, @tmp, SizeOf(tmp));
+  try
+    SaveTo(W);
+    W.Flush;
+  finally
+    W.Free;
+  end;
+end;
+
+function TDynArray.SaveTo: RawByteString;
+var
+  W: TRawByteStringStream;
+begin
+  W := TRawByteStringStream.Create;
+  try
+    SaveToStream(W);
+    result := W.DataString;
+  finally
+    W.Free;
+  end;
+end;
+
+function TDynArray.LoadFrom(Source, SourceMax: PAnsiChar): PAnsiChar;
+var
+  read: TFastReader;
+begin
+  {$ifndef PUREMORMOT2}
+  if SourceMax = nil then
+    // mORMot 1 unsafe backward compatible: assume fake 100MB Source input
+    SourceMax := Source + 100 shl 20;
+  {$endif PUREMORMOT2}
+  {%H-}read.Init(Source, SourceMax - Source);
+  LoadFromReader(read);
+  if read.P <> Source then
+    result := read.P
+  else
+    result := nil;
+end;
+
+function TDynArray.LoadFromBinary(const Buffer: RawByteString): boolean;
+var
+  read: TFastReader;
+begin
+  read.Init(Buffer);
+  LoadFromReader(read);
+  result := read.P = read.Last;
+end;
+
+procedure TDynArray.LoadFromReader(var Read: TFastReader);
+begin
+  if fValue <> nil then
+  begin
+    _BL_DynArray(pointer(fValue), Read, Info.Info);
+    if fCountP <> nil then // _BL_DynArray() set length -> reflect on Count
+      if fValue^ = nil then
+        fCountP^ := 0
+      else
+        fCountP^ := PDALen(PAnsiChar(fValue^) - _DALEN)^ + _DAOFF;
+  end;
+end;
+
+procedure TDynArray.LoadFromStream(Stream: TCustomMemoryStream);
+var
+  S, P: PAnsiChar;
+begin
+  S := PAnsiChar(Stream.Memory);
+  P := LoadFrom(S + Stream.Position, S + Stream.Size);
+  Stream.Seek(Int64(PtrUInt(P) - PtrUInt(S)), soBeginning);
+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);
+begin
+  SaveToJson(result, TEXTWRITEROPTIONS_ENUMASTEXT[EnumSetsAsText],
+    TEXTWRITEROBJECTOPTIONS_ENUMASTEXT[EnumSetsAsText], reformat);
+end;
+
+procedure TDynArray.SaveToJson(out result: RawUtf8; Options: TTextWriterOptions;
+  ObjectOptions: TTextWriterWriteObjectOptions; reformat: TTextWriterJsonFormat);
+var
+  W: TTextWriter;
+  temp: TTextWriterStackBuffer;
+begin
+  if GetCount = 0 then
+    result := '[]'
+  else
+  begin
+    W := DefaultJsonWriter.CreateOwnedStream(temp);
+    try
+      W.CustomOptions := W.CustomOptions + Options;
+      SaveToJson(W, ObjectOptions);
+      W.SetText(result, reformat);
+    finally
+      W.Free;
+    end;
+  end;
+end;
+
+procedure TDynArray.SaveToJson(W: TTextWriter;
+  ObjectOptions: TTextWriterWriteObjectOptions);
+var
+  len, backup: PtrInt;
+  hacklen: PDALen;
+begin
+  len := GetCount;
+  if len = 0 then
+    W.Add('[', ']')
+  else
+  begin
+    hacklen := PDALen(PAnsiChar(fValue^) - _DALEN);
+    backup := hacklen^;
+    try
+      hacklen^ := len - _DAOFF; // may use ExternalCount
+      W.AddTypedJson(fValue, Info.Info, ObjectOptions); // from mormot.core.json
+    finally
+      hacklen^ := backup;
+    end;
+  end;
+end;
+
+procedure _GetDataFromJson(Data: pointer; var Json: PUtf8Char;
+  EndOfObject: PUtf8Char; Rtti: TRttiCustom;
+  CustomVariantOptions: PDocVariantOptions; Tolerant: boolean;
+  Interning: TRawUtf8InterningAbstract);
+begin
+  raise ERttiException.Create('GetDataFromJson() not implemented - ' +
+    'please include mormot.core.json in your uses clause');
+end;
+
+function TDynArray.LoadFromJson(P: PUtf8Char; EndOfObject: PUtf8Char;
+  CustomVariantOptions: PDocVariantOptions; Tolerant: boolean;
+  Interning: TRawUtf8InterningAbstract): PUtf8Char;
+begin
+  SetCount(0); // faster to use our own routine now
+  GetDataFromJson(fValue, P,
+    EndOfObject, Info, CustomVariantOptions, Tolerant, Interning);
+  if fCountP <> nil then
+    // GetDataFromJson() set the array length (capacity), not the external count
+    if fValue^ = nil then
+      fCountP^ := 0
+    else
+      fCountP^ := PDALen(PAnsiChar(fValue^) - _DALEN)^ + _DAOFF;
+  result := P;
+end;
+
+function TDynArray.LoadFromJson(const Json: RawUtf8;
+  CustomVariantOptions: PDocVariantOptions; Tolerant: boolean;
+  Interning: TRawUtf8InterningAbstract): boolean;
+var
+  tmp: TSynTempBuffer;
+begin
+  tmp.Init(Json);
+  try
+    result := LoadFromJson(tmp.buf, nil,
+      CustomVariantOptions, Tolerant, Interning) <> nil;
+  finally
+    tmp.Done;
+  end;
+end;
+
+function TDynArray.ItemCopyFirstField(Source, Dest: Pointer): boolean;
+var
+  rtti: PRttiInfo;
+begin
+  result := false;
+  if fInfo.ArrayFirstField in ptUnmanagedTypes then
+    MoveFast(Source^, Dest^, PT_SIZE[fInfo.ArrayFirstField])
+  else
+    begin
+      rtti := PT_INFO[fInfo.ArrayFirstField];
+      if rtti = nil then
+        exit; // ptNone, ptInterface, ptCustom
+      rtti^.Copy(Dest, Source);
+    end;
+  result := true;
+end;
+
+function BruteFind(P, V: PAnsiChar; cmp: TDynArraySortCompare; n, s: PtrInt): PtrInt;
+begin // array is very small, or not sorted -> O(n) iterative search
+  result := 0;
+  repeat
+    if cmp(P^, V^) = 0 then
+      exit;
+    inc(result);
+    inc(P, s);
+  until result = n;
+  result := -1;
+end;
+
+function TDynArray.Find(const Item; const aIndex: TIntegerDynArray;
+  aCompare: TDynArraySortCompare): PtrInt;
+var
+  n, L: PtrInt;
+  cmp: integer;
+  P: PAnsiChar;
+begin
+  n := GetCount;
+  if Assigned(aCompare) and
+     (n > 0) then
+  begin
+    P := fValue^;
+    if length(aIndex) >= n then
+    begin // fast O(log(n)) binary search over aIndex[]
+      dec(n);
+      L := 0;
+      repeat
+        result := (L + n) shr 1;
+        cmp := aCompare(P[aIndex[result] * fInfo.Cache.ItemSize], Item);
+        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
+    begin // fallback to O(n) linear search on void aIndex[]
+      result := BruteFind(P, @Item, aCompare, n, fInfo.Cache.ItemSize);
+      exit;
+    end;
+  end;
+  result := -1;
+end;
+
+function SortFind(P, V: PAnsiChar; cmp: TDynArraySortCompare; R, s: PtrInt): PtrInt;
+var
+  m, L: PtrInt;
+  res: integer;
+begin // array is sorted -> use fast O(log(n)) binary search
+  L := 0;
+  dec(R);
+  repeat
+    result := (L + R) shr 1;
+    res := cmp(P[result * s], V^);
+    if res = 0 then
+      exit;
+    m := result - 1;
+    inc(result);
+    if res > 0 then // compile as cmovnle/cmovle opcodes on FPC x86_64
+      R := m
+    else
+      L := result;
+  until L > R;
+  result := -1;
+end;
+
+function TDynArray.Find(const Item; aCompare: TDynArraySortCompare): PtrInt;
+var
+  n: PtrInt;
+  fnd: function(P, V: PAnsiChar; cmp: TDynArraySortCompare; n, s: PtrInt): PtrInt;
+begin
+  n := GetCount;
+  if not Assigned(aCompare) then
+    aCompare := fCompare;
+  if n > 0 then
+    if Assigned(aCompare) then
+    begin
+      fnd := @BruteFind;
+      if n > 10 then
+        if fSorted and
+           (@aCompare = @fCompare) then
+          fnd := @SortFind
+        else if not(rcfArrayItemManaged in fInfo.Flags) and
+                (fInfo.ArrayRtti <> nil) and
+                (@aCompare = @PT_SORT[false, fInfo.ArrayRtti.Parser]) then
+        begin // optimized brute force search with potential SSE2 asm
+          result := AnyScanIndex(fValue^, @Item, n, fInfo.Cache.ItemSize);
+          exit;
+        end;
+      result := fnd(fValue^, @Item, aCompare, n, fInfo.Cache.ItemSize);
+    end
+    else
+      result := IndexOf(Item, {caseinsens=}false) // no fCompare -> default
+  else
+    result := -1;
+end;
+
+function TDynArray.FindIndex(const Item; aIndex: PIntegerDynArray;
+  aCompare: TDynArraySortCompare): PtrInt;
+begin
+  if aIndex <> nil then
+    result := Find(Item, aIndex^, aCompare)
+  else
+    result := Find(Item, aCompare);
+end;
+
+function TDynArray.FindAndFill(var Item; aIndex: PIntegerDynArray;
+  aCompare: TDynArraySortCompare): integer;
+begin
+  result := FindIndex(Item, aIndex, aCompare);
+  if result >= 0 then
+    // if found, fill Item with the matching item
+    ItemCopy(PAnsiChar(fValue^) + (result * fInfo.Cache.ItemSize), @Item);
+end;
+
+function TDynArray.FindAndDelete(const Item; aIndex: PIntegerDynArray;
+  aCompare: TDynArraySortCompare): integer;
+begin
+  result := FindIndex(Item, aIndex, aCompare);
+  if result >= 0 then
+    // if found, delete the item from the array
+    Delete(result);
+end;
+
+function TDynArray.FindAndUpdate(const Item; aIndex: PIntegerDynArray;
+  aCompare: TDynArraySortCompare): integer;
+begin
+  result := FindIndex(Item, aIndex, aCompare);
+  if result >= 0 then
+    // if found, fill Item with the matching item
+    ItemCopy(@Item, PAnsiChar(fValue^) + (result * fInfo.Cache.ItemSize));
+end;
+
+function TDynArray.FindAndAddIfNotExisting(const Item; aIndex: PIntegerDynArray;
+  aCompare: TDynArraySortCompare): integer;
+begin
+  result := FindIndex(Item, aIndex, aCompare);
+  if result < 0 then
+    // -1 will mark success
+    Add(Item);
+end;
+
+function TDynArray.FindAllSorted(const Item;
+  out FirstIndex, LastIndex: integer): boolean;
+var
+  found, last: integer; // FastLocateSorted() requires an integer
+  siz: PtrInt;
+  P, val: PAnsiChar;
+begin
+  result := FastLocateSorted(Item, found);
+  if not result then
+    exit;
+  FirstIndex := found;
+  P := fValue^;
+  siz := fInfo.Cache.ItemSize;
+  inc(P, found * siz);
+  val := P; // faster than Item after RawUtf8 interning
+  while FirstIndex > 0 do
+  begin
+    dec(P, siz);
+    if fCompare(P^, val^) <> 0 then
+      break;
+    dec(FirstIndex);
+  end;
+  last := GetCount - 1;
+  LastIndex := found;
+  P := val;
+  while LastIndex < last do
+  begin
+    inc(P, siz);
+    if fCompare(P^, val^) <> 0 then
+      break;
+    inc(LastIndex);
+  end;
+end;
+
+function TDynArray.FindAllSorted(const Item; out FindCount: integer): pointer;
+var
+  found: integer; // FastLocateSorted() requires an integer
+  siz: PtrInt;
+  P, fnd, limit: PAnsiChar;
+begin
+  FindCount := 0;
+  result := nil;
+  if not FastLocateSorted(Item, found) then
+    exit;
+  P := fValue^;
+  limit := P;
+  siz := fInfo.Cache.ItemSize;
+  inc(P, found * siz);
+  fnd := P; // faster than Item after RawUtf8 interning
+  repeat
+    result := P;
+    inc(FindCount);
+    dec(P, siz);
+  until (P < limit) or
+        (fCompare(P^, fnd^) <> 0);
+  inc(limit, GetCount * siz);
+  P := fnd;
+  repeat
+    inc(P, siz);
+    if (P >= limit) or
+       (fCompare(P^, fnd^) <> 0) then
+      break;
+    inc(FindCount);
+  until false;
+end;
+
+function TDynArray.FastLocateSorted(const Item; out Index: integer): boolean;
+var
+  n, i: PtrInt;
+  cmp: integer;
+  P: PAnsiChar;
+begin
+  result := False;
+  n := GetCount;
+  if Assigned(fCompare) then
+    if n = 0 then // a void array is always sorted
+      Index := 0
+    else if fSorted then
+    begin
+      P := fValue^;
+      // first compare with the last sorted item (common case, e.g. with IDs)
+      dec(n);
+      cmp := fCompare(Item, P[n * fInfo.Cache.ItemSize]);
+      if cmp >= 0 then
+      begin
+        Index := n;
+        if cmp = 0 then
+          // was just added: returns true + index of last item
+          result := true
+        else
+          // bigger than last item: returns false + insert after last position
+          inc(Index);
+        exit;
+      end;
+      // O(log(n)) binary search of the sorted position
+      Index := 0; // more efficient code if we use Index and not a local var
+      repeat
+        i := (Index + n) shr 1;
+        cmp := fCompare(Item, P[i * fInfo.Cache.ItemSize]);
+        if cmp = 0 then
+        begin
+          // returns true + index of existing Item
+          Index := i;
+          result := True;
+          exit;
+        end
+        else if cmp > 0 then
+          Index := i + 1
+        else
+          n := i - 1;
+      until Index > n;
+      // Item not found: returns false + the index where to insert
+    end
+    else
+      Index := -1 // not Sorted
+  else
+    Index := -1; // no fCompare()
+end;
+
+procedure TDynArray.FastAddSorted(Index: PtrInt; const Item);
+begin
+  Insert(Index, Item);
+  fSorted := true; // Insert -> SetCount -> fSorted := false
+end;
+
+procedure TDynArray.FastDeleteSorted(Index: PtrInt);
+begin
+  Delete(Index);
+  fSorted := true; // Delete -> SetCount -> fSorted := false
+end;
+
+function TDynArray.FastLocateOrAddSorted(const Item; wasAdded: PBoolean): integer;
+var
+  added: boolean;
+begin
+  added := not FastLocateSorted(Item, result) and
+           (result >= 0);
+  if added then
+  begin
+    Insert(result, Item);
+    fSorted := true; // Insert -> SetCount -> fSorted := false
+  end;
+  if wasAdded <> nil then
+    wasAdded^ := added;
+end;
+
+type
+  // internal structure used to make QuickSort faster & with less stack usage
+  {$ifdef USERECORDWITHMETHODS}
+  TDynArrayQuickSort = record
+  {$else}
+  TDynArrayQuickSort = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    Compare: TDynArraySortCompare;
+    CompareEvent: TOnDynArraySortCompare;
+    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; ItemSize, Count: integer;
+  out Indexes: TSynTempBuffer; Compare: TDynArraySortCompare);
+begin
+  DynArraySortIndexed(Values, ItemSize, Count,
+    pointer(Indexes.InitIncreasing(Count)), Compare);
+end;
+
+procedure DynArraySortIndexed(Values: pointer; ItemSize, Count: integer;
+  Indexes: PCardinalArray; Compare: TDynArraySortCompare);
+var
+  QS: TDynArrayQuickSort;
+begin
+  QS.Compare := Compare;
+  QS.Value := Values;
+  QS.ElemSize := ItemSize;
+  QS.Index := Indexes;
+  QS.QuickSortIndexed(0, Count - 1);
+end;
+
+procedure TDynArrayQuickSort.QuickSort(L, R: PtrInt);
+var
+  I, J: PtrInt;
+begin
+  if L < R then
+    repeat
+      I := L;
+      J := R;
+      p := (L + R) shr 1;
+      repeat
+        Pivot := Value + PtrUInt(p) * ElemSize;
+        IP := Value + PtrUInt(I) * ElemSize;
+        JP := Value + PtrUInt(J) * ElemSize;
+        while Compare(IP^, Pivot^) < 0 do
+        begin
+          inc(I);
+          inc(IP, ElemSize);
+        end;
+        while Compare(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
+          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 L < R then
+    repeat
+      I := L;
+      J := R;
+      p := (L + R) shr 1;
+      repeat
+        Pivot := Value + PtrUInt(p) * ElemSize;
+        IP := Value + PtrUInt(I) * ElemSize;
+        JP := Value + PtrUInt(J) * ElemSize;
+        while CompareEvent(IP^, Pivot^) < 0 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
+          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 L < R then
+    repeat
+      I := L;
+      J := R;
+      p := (L + R) shr 1;
+      repeat
+        Pivot := Value + PtrUInt(p) * ElemSize;
+        IP := Value + PtrUInt(I) * ElemSize;
+        JP := Value + PtrUInt(J) * ElemSize;
+        while CompareEvent(IP^, Pivot^) > 0 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 L < R then
+    repeat
+      I := L;
+      J := R;
+      p := (L + R) shr 1;
+      repeat
+        Pivot := Value + index[p] * ElemSize;
+        while Compare(Value[index[I] * ElemSize], Pivot^) < 0 do
+          inc(I);
+        while Compare(Value[index[J] * ElemSize], Pivot^) > 0 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 L < R then
+    repeat
+      I := L;
+      J := R;
+      P := (L + R) shr 1;
+      repeat
+        while Compare(V[I], V[P]) < 0 do
+          inc(I);
+        while Compare(V[J], V[P]) > 0 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 Assigned(aCompare) then
+    QuickSort.Compare := aCompare
+  else
+    QuickSort.Compare := @fCompare;
+  if Assigned(QuickSort.Compare) and
+     (fValue <> nil) and
+     (fValue^ <> nil) then
+  begin
+    if fInfo.ArrayRtti <> nil then
+      case fInfo.ArrayRtti.Parser of
+        // call optimized sorting functions for most simple types
+        ptWord:
+          if @QuickSort.Compare = @SortDynArrayWord then
+          begin
+            QuickSortWord(fValue^, aStart, aStop);
+            exit;
+          end;
+        ptInteger:
+          if @QuickSort.Compare = @SortDynArrayInteger then
+          begin
+            QuickSortInteger(fValue^, aStart, aStop);
+            exit;
+          end;
+        ptInt64:
+          if @QuickSort.Compare = @SortDynArrayInt64 then
+          begin
+            QuickSortInt64(fValue^, aStart, aStop);
+            exit;
+          end;
+        ptQWord:
+          if @QuickSort.Compare = @SortDynArrayQWord then
+          begin
+            QuickSortQWord(fValue^, aStart, aStop);
+            exit;
+          end;
+        ptDouble:
+          if @QuickSort.Compare = @SortDynArrayDouble then
+          begin
+            QuickSortDouble(fValue^, aStart, aStop);
+            exit;
+          end;
+      end;
+    if fInfo.Cache.ItemSize = SizeOf(pointer) then
+      // dedicated function for pointers - e.g. strings or T*ObjArray
+      QuickSortPtr(aStart, aStop, QuickSort.Compare, fValue^)
+    else
+    begin
+      // generic process for any kind of array items
+      QuickSort.Value := fValue^;
+      QuickSort.ElemSize := fInfo.Cache.ItemSize;
+      QuickSort.QuickSort(aStart, aStop);
+    end;
+  end;
+end;
+
+function TDynArray.IsSorted(aCompare: TDynArraySortCompare): boolean;
+var
+  n: integer;
+  siz: PtrInt;
+  p, prev: PAnsiChar;
+begin
+  result := false;
+  n := GetCount;
+  if not Assigned(aCompare) then
+    aCompare := fCompare;
+  if (not Assigned(aCompare)) or
+     (n = 0) then
+    exit; // nothing to sort
+  siz := fInfo.Cache.ItemSize;
+  p := fValue^;
+  prev := p;
+  inc(p, siz);
+  dec(n);
+  if n <> 0 then
+    repeat
+      if aCompare(p^, prev^) < 0 then
+        exit;
+      prev := p;
+      inc(p, siz);
+      dec(n);
+    until n = 0;
+  result := true; // all items are sorted
+end;
+
+procedure TDynArray.EnsureSorted(aCompare: TDynArraySortCompare);
+begin
+  if IsSorted(aCompare) then
+    fSorted := true
+  else
+    Sort(aCompare);
+end;
+
+procedure TDynArray.Sort(const aCompare: TOnDynArraySortCompare; 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 := fInfo.Cache.ItemSize;
+  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 Assigned(aCompare) then
+    QuickSort.Compare := aCompare
+  else
+    QuickSort.Compare := @fCompare;
+  if Assigned(QuickSort.Compare) and
+     (fValue <> nil) and
+     (fValue^ <> nil) then
+  begin
+    n := GetCount;
+    if length(aIndex) < n then
+    begin
+      SetLength(aIndex, n);
+      FillIncreasing(pointer(aIndex), 0, n);
+    end;
+    QuickSort.Value := fValue^;
+    QuickSort.ElemSize := fInfo.Cache.ItemSize;
+    QuickSort.Index := pointer(aIndex);
+    QuickSort.QuickSortIndexed(0, n - 1);
+  end;
+end;
+
+procedure TDynArray.CreateOrderedIndex(out aIndex: TSynTempBuffer;
+  aCompare: TDynArraySortCompare);
+var
+  QuickSort: TDynArrayQuickSort;
+  n: integer;
+begin
+  if Assigned(aCompare) then
+    QuickSort.Compare := aCompare
+  else
+    QuickSort.Compare := @fCompare;
+  if Assigned(QuickSort.Compare) and
+     (fValue <> nil) and
+     (fValue^ <> nil) then
+  begin
+    n := GetCount;
+    QuickSort.Value := fValue^;
+    QuickSort.ElemSize := fInfo.Cache.ItemSize;
+    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;
+
+procedure TDynArray.InitFrom(aAnother: PDynArray; var aValue);
+begin
+  self := aAnother^; // raw RTTI fields copy
+  fValue := @aValue; // points to the new value
+  fCountP := nil;
+end;
+
+procedure TDynArray.AddDynArray(aSource: PDynArray;
+  aStartIndex: integer; aCount: integer);
+var
+  SourceCount: integer;
+begin
+  if (aSource <> nil) and
+     (aSource^.fValue <> nil) and
+     (fInfo.Cache.ItemInfo = aSource^.Info.Cache.ItemInfo) then
+  begin
+    // check supplied aCount paramter with (external) Source.Count
+    SourceCount := aSource^.Count;
+    if (aCount < 0) or
+       (aCount > SourceCount) then
+      aCount := SourceCount;
+    // actually add the items
+    AddArray(aSource.fValue^, aStartIndex, aCount);
+  end;
+end;
+
+function TDynArray.Equals(B: PDynArray; IgnoreCompare, CaseSensitive: boolean): boolean;
+begin
+  result := Compares(B, IgnoreCompare, CaseSensitive) = 0;
+end;
+
+function TDynArray.Compares(B: PDynArray; IgnoreCompare, CaseSensitive: boolean): integer;
+var
+  i, n: integer;
+  s: PtrUInt;
+  P1, P2: PAnsiChar;
+begin
+  n := GetCount;
+  result := n - B.Count;
+  if (result = 0) and
+     (n <> 0) then
+    if fInfo.Cache.ItemInfo <> B.Info.Cache.ItemInfo then
+      result := ComparePointer(fValue^, B.fValue^)
+    else if Assigned(fCompare) and
+       not ignorecompare then
+    begin
+      // use specified fCompare() function
+      P1 := fValue^;
+      P2 := B.fValue^;
+      s := fInfo.Cache.ItemSize;
+      for i := 1 to n do
+      begin
+        result := fCompare(P1^, P2^);
+        if result <> 0 then
+          exit;
+        inc(P1, s);
+        inc(P2, s);
+      end;
+    end
+    else if rcfObjArray in fInfo.Flags then
+      // T*ObjArray comparison of published properties
+      result := ObjectCompare(fValue^, B.fValue^, n, not CaseSensitive)
+    else if not(rcfArrayItemManaged in fInfo.Flags) then
+      // binary comparison with length (always CaseSensitive)
+      result := MemCmp(fValue^, B.fValue^, n * fInfo.Cache.ItemSize)
+    else
+      result := BinaryCompare(fValue^, B.fValue^, fInfo.Cache.ItemInfo, n,
+        not CaseSensitive);
+end;
+
+procedure TDynArray.Copy(Source: PDynArray; ObjArrayByRef: boolean);
+begin
+  if (fValue = nil) or
+     (fInfo.Cache.ItemInfo <> Source.Info.Cache.ItemInfo) then
+    exit;
+  if not ObjArrayByRef and
+     (rcfObjArray in fInfo.Flags) then
+    LoadFromJson(pointer(Source.SaveToJson))
+  else
+  begin
+    DynArrayCopy(fValue, Source.fValue, fInfo.Info, Source.fCountP);
+    if fCountP <> nil then
+      fCountP^ := GetCapacity;
+  end;
+end;
+
+procedure TDynArray.CopyFrom(const Source; MaxItem: integer; ObjArrayByRef: boolean);
+var
+  SourceDynArray: TDynArray;
+begin
+  SourceDynArray.InitRtti(fInfo, pointer(@Source)^);
+  SourceDynArray.fCountP := @MaxItem; // would set Count=0 at Init()
+  Copy(@SourceDynArray, ObjArrayByRef);
+end;
+
+procedure TDynArray.CopyTo(out Dest; ObjArrayByRef: boolean);
+var
+  DestDynArray: TDynArray;
+begin
+  DestDynArray.InitRtti(fInfo, Dest);
+  DestDynArray.Copy(@self, ObjArrayByRef);
+end;
+
+function IndexFind(P, V: PAnsiChar; cmp: TRttiCompare; rtti: PRttiInfo; n: integer): PtrInt;
+var
+  comp: integer;
+begin
+  result := 0;
+  repeat
+    inc(P, cmp(P, V, rtti, comp));
+    if comp = 0 then
+      exit;
+    inc(result);
+    dec(n);
+  until n = 0;
+  result := -1;
+end;
+
+function TDynArray.IndexOf(const Item; CaseInSensitive: boolean): PtrInt;
+var
+  rtti: PRttiInfo;
+  cmp: TRttiCompare;
+  n: PtrInt;
+label
+  bin;
+begin
+  n := GetCount;
+  if (n <> 0) and
+     (@Item <> nil) then
+    if not(rcfArrayItemManaged in fInfo.Flags) then
+bin:  result := AnyScanIndex(fValue^, @Item, n, fInfo.Cache.ItemSize)
+    else
+    begin
+      rtti := fInfo.Cache.ItemInfo;
+      if rtti = nil then
+        goto bin; // unmanaged items
+      cmp := RTTI_COMPARE[CaseInSensitive, rtti.Kind];
+      if Assigned(cmp) then
+        result := IndexFind(fValue^, @Item, cmp, rtti, n)
+      else
+        goto bin;
+    end
+  else
+    result := -1;
+end;
+
+procedure TDynArray.UseExternalCount(aCountPointer: PInteger);
+begin
+  fCountP := aCountPointer;
+end;
+
+procedure TDynArray.Void;
+begin
+  fValue := nil;
+end;
+
+function TDynArray.IsVoid: boolean;
+begin
+  result := fValue = nil;
+end;
+
+procedure TDynArray.InternalSetLength(OldLength, NewLength: PtrUInt);
+var
+  p: PDynArrayRec;
+  NeededSize, minLength: PtrUInt;
+begin
+  // this method is faster than default System.DynArraySetLength() function
+  p := fValue^;
+  // check that new array length is not just a finalize in disguise
+  if NewLength = 0 then
+  begin
+    if p <> nil then
+    begin
+      // FastDynArrayClear() with ObjArray support
+      dec(p);
+      if (p^.refCnt > 0) and
+         DACntDecFree(p^.refCnt) then
+      begin
+        if (OldLength <> 0) and
+           not fNoFinalize then
+          if rcfArrayItemManaged in fInfo.Flags then
+            FastFinalizeArray(fValue^, fInfo.Cache.ItemInfo, OldLength)
+          else if rcfObjArray in fInfo.Flags then
+            RawObjectsClear(fValue^, OldLength);
+        FreeMem(p);
+      end;
+      fValue^ := nil;
+    end;
+    exit;
+  end;
+  // calculate the needed size of the resulting memory structure on heap
+  NeededSize := NewLength * PtrUInt(fInfo.Cache.ItemSize) + SizeOf(TDynArrayRec);
+  {$ifdef CPU32}
+  if NeededSize > 1 shl 30 then
+    // in practice, consider that max workable memory block is 1 GB on 32-bit
+    raise EDynArray.CreateUtf8('TDynArray.InternalSetLength(%,%) size concern',
+      [fInfo.Name, NewLength]);
+  {$endif CPU32}
+  // if not shared (refCnt=1), resize; if shared, create copy (not thread safe)
+  if p = nil then
+  begin
+    p := AllocMem(NeededSize); // RTL/OS will return zeroed memory
+    OldLength := NewLength;    // no FillcharFast() below
+  end
+  else
+  begin
+    dec(p); // p^ = start of heap object
+    if p^.refCnt = 1 then
+    begin
+      // we own the dynamic array instance -> direct reallocation
+      if (NewLength < OldLength) and
+         not fNoFinalize then
+        // reduce array in-place
+        if rcfArrayItemManaged in fInfo.Flags then // in trailing items
+          FastFinalizeArray(pointer(PAnsiChar(p) + NeededSize),
+            fInfo.Cache.ItemInfo, OldLength - NewLength)
+        else if rcfObjArray in fInfo.Flags then // FreeAndNil() of resized objects
+          RawObjectsClear(pointer(PAnsiChar(p) + NeededSize), OldLength - NewLength);
+      ReallocMem(p, NeededSize);
+    end
+    else
+    begin
+      // dynamic array already referenced elsewhere -> create our own copy
+      minLength := OldLength;
+      if minLength > NewLength then
+        minLength := NewLength;
+      if fInfo.Cache.ItemInfo = nil then // unmanaged items
+      begin
+        GetMem(p, NeededSize);
+        MoveFast(fValue^^, PByteArray(p)[SizeOf(TDynArrayRec)],
+          minLength * PtrUInt(fInfo.Cache.ItemSize));
+      end
+      else
+      begin
+        p := AllocMem(NeededSize);
+        OldLength := NewLength;    // no FillcharFast() below
+        CopySeveral(@PByteArray(p)[SizeOf(TDynArrayRec)], fValue^,
+          minLength, fInfo.Cache.ItemInfo, fInfo.Cache.ItemSize);
+      end;
+      // for thread safety, adjust the refcount after data copy
+      if fNoFinalize then
+        FastDynArrayClear(fValue, nil)
+      else // note: rcfObjArray should never appear with refcnt>1
+        FastDynArrayClear(fValue, fInfo.Cache.ItemInfo);
+    end;
+  end;
+  // set refCnt=1 and new length to the heap header
+  with p^ do
+  begin
+    refCnt := 1;
+    length := NewLength;
+  end;
+  inc(p); // start of dynamic aray items
+  fValue^ := p;
+  // reset new allocated items content to zero
+  if NewLength > OldLength then
+  begin
+    minLength := fInfo.Cache.ItemSize;
+    OldLength := OldLength * minLength;
+    FillCharFast(PAnsiChar(p)[OldLength], NewLength * minLength - OldLength, 0);
+  end;
+end;
+
+procedure TDynArray.SetCount(aCount: PtrInt);
+const
+  MINIMUM_SIZE = 64;
+var
+  oldlen, extcount, arrayptr, capa, delta: PtrInt;
+begin
+  arrayptr := PtrInt(fValue);
+  extcount := PtrInt(fCountP);
+  fSorted := false;
+  if arrayptr = 0 then
+    exit; // avoid GPF if void
+  arrayptr := PPtrInt(arrayptr)^;
+  if extcount <> 0 then
+  begin
+    // fCountP^ as external capacity
+    oldlen := PInteger(extcount)^;
+    delta := aCount - oldlen;
+    if delta = 0 then
+      exit;
+    PInteger(extcount)^ := aCount; // store new length
+    if arrayptr <> 0 then
+    begin
+      // non void array: check new count against existing capacity
+      capa := PDALen(arrayptr - _DALEN)^ + _DAOFF;
+      if delta > 0 then
+      begin
+        // size-up - Add() - is handled branchless
+        if capa >= aCount then
+          exit; // no need to grow
+        capa := NextGrow(capa);
+        if capa > aCount then
+          aCount := capa; // grow by chunks
+      end
+      else
+      // size-down - Delete()
+      if (aCount > 0) and
+         ((capa <= MINIMUM_SIZE) or
+          (capa - aCount < capa shr 3)) then
+        // reallocate memory only if worth it (for faster Delete)
+        exit;
+    end
+    else
+    begin
+      // void array
+      if (delta > 0) and
+         (aCount < MINIMUM_SIZE) then
+        // reserve some minimal (64) items for Add()
+        aCount := MINIMUM_SIZE;
+    end;
+  end
+  else
+    // no external capacity: use length()
+    if arrayptr = 0 then
+      oldlen := arrayptr
+    else
+    begin
+      oldlen := PDALen(arrayptr - _DALEN)^ + _DAOFF;
+      if oldlen = aCount then
+        exit; // InternalSetLength(samecount) would have made a private copy
+    end;
+  // no external Count, array size-down or array up-grow -> realloc
+  InternalSetLength(oldlen, aCount);
+end;
+
+procedure TDynArray.SetCapacity(aCapacity: PtrInt);
+var
+  oldlen, capa: PtrInt;
+begin
+  if fValue = nil then
+    exit;
+  capa := GetCapacity;
+  if fCountP <> nil then
+  begin
+    oldlen := fCountP^;
+    if oldlen > aCapacity then
+      fCountP^ := aCapacity;
+  end
+  else
+    oldlen := capa;
+  if capa <> aCapacity then
+    InternalSetLength(oldlen, aCapacity);
+end;
+
+procedure TDynArray.SetCompare(const aCompare: TDynArraySortCompare);
+begin
+  if @aCompare <> @fCompare then
+  begin
+    @fCompare := @aCompare;
+    fSorted := false;
+  end;
+end;
+
+procedure TDynArray.Slice(var Dest; Limit, Offset: cardinal);
+var
+  n: cardinal;
+  dst: TDynArray;
+begin
+  if fValue = nil then
+    exit; // avoid GPF if void
+  n := GetCount;
+  if Offset >= n then
+    Limit := 0
+  else
+  begin
+    dec(n, Offset);
+    if Limit > n  then
+      Limit := n;
+  end;
+  dst.InitRtti(fInfo, Dest);
+  dst.SetCapacity(Limit);
+  CopySeveral(pointer(Dest),
+    @(PByteArray(fValue^)[Offset * cardinal(fInfo.Cache.ItemSize)]),
+    Limit, fInfo.Cache.ItemInfo, fInfo.Cache.ItemSize);
+end;
+
+procedure TDynArray.SliceAsDynArray(Dest: PPointer; Offset, Limit: integer);
+var
+  p: PDynArrayRec;
+  n: integer;
+begin
+  if dest^ <> nil then
+    FastDynArrayClear(dest, fInfo.Cache.ItemInfo); // reset Dest variable slot
+  n := GetCount;
+  if Offset < 0 then
+  begin
+    // ! SliceAsDynArray(DA, -10);  // last Count-10..Count-1 items
+    inc(Offset, n);
+    if Offset < 0 then
+      Offset := 0;
+  end;
+  if Offset >= n then // also handles n = 0
+    exit;
+  if (Offset = 0) and
+     ((Limit = 0) or
+      (Limit >= n)) then
+  begin
+    // we can return the current dynamic array with proper Copy-On-Write
+    p := fValue^;
+    if p = nil then
+      exit;
+    dec(p);
+    inc(p^.refCnt); // COW reuse of the existing dynamic array instance
+    p^.Length := n; // no memory realloc/copy, just force Capacity=Length=Count
+    inc(p);
+    dest^ := p;     // assign to Dest variable
+  end
+  else
+  begin
+    // ! SliceAsDynArray(DA, 0, 10);  // first 0..9 items
+    // ! SliceAsDynArray(DA, 10, 20); // items 10..29 - truncated if Count < 30
+    if Limit = 0 then
+      // ! SliceAsDynArray(DA);       // all items
+      // ! SliceAsDynArray(DA, 10);   // all items excluding the first 0..9
+      Limit := n;
+    Slice(Dest^, Limit, Offset);
+  end;
+end;
+
+function TDynArray.AddArray(const DynArrayVar; aStartIndex, aCount: integer): integer;
+var
+  c, s: PtrInt;
+  n: integer;
+  PS, PD: pointer;
+begin
+  result := 0;
+  if fValue = nil then
+    exit; // avoid GPF if void
+  c := PtrInt(DynArrayVar);
+  if c <> 0 then
+    c := PDALen(c - _DALEN)^ + _DAOFF;
+  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);
+  s := fInfo.Cache.ItemSize;
+  PS := PAnsiChar(DynArrayVar) + aStartIndex * s;
+  PD := PAnsiChar(fValue^) + n * s;
+  CopySeveral(PD, PS, aCount, fInfo.Cache.ItemInfo, s);
+end;
+
+function TDynArray.ItemLoadMem(Source, SourceMax: PAnsiChar): RawByteString;
+begin
+  if (Source <> nil) and
+     (fInfo.Cache.ItemInfo = nil) then // unmanaged items
+    FastSetRawByteString(result, Source, fInfo.Cache.ItemSize)
+  else
+  begin
+    FastSetRawByteString(result, nil, fInfo.Cache.ItemSize);
+    FillCharFast(pointer(result)^, fInfo.Cache.ItemSize, 0);
+    ItemLoad(Source, pointer(result), SourceMax);
+  end;
+end;
+
+procedure TDynArray.ItemLoad(Source, SourceMax: PAnsiChar; Item: pointer);
+begin
+  if Source <> nil then // avoid GPF
+    if fInfo.Cache.ItemInfo = nil then
+    begin
+      if {$ifndef PUREMORMOT2} (SourceMax = nil) or {$endif}
+         (Source + fInfo.Cache.ItemSize <= SourceMax) then
+        MoveFast(Source^, Item^, fInfo.Cache.ItemSize);
+    end
+    else
+      BinaryLoad(Item, Source, fInfo.Cache.ItemInfo, nil, SourceMax, rkAllTypes);
+end;
+
+procedure TDynArray.ItemLoadMemClear(var ItemTemp: RawByteString);
+begin
+  ItemClear(pointer(ItemTemp));
+  ItemTemp := '';
+end;
+
+function TDynArray.ItemSave(Item: pointer): RawByteString;
+begin
+  if fInfo.Cache.ItemInfo = nil then
+    FastSetRawByteString(result, Item, fInfo.Cache.ItemSize)
+  else
+    result := BinarySave(Item, fInfo.Cache.ItemInfo, rkAllTypes);
+end;
+
+function TDynArray.ItemLoadFind(Source, SourceMax: PAnsiChar): integer;
+var
+  tmp: array[0..2047] of byte;
+  data: pointer;
+begin
+  result := -1;
+  if (Source = nil) or
+     (fInfo.Cache.ItemSize > SizeOf(tmp)) then
+    exit;
+  if fInfo.Cache.ItemInfo = nil then // nil for unmanaged items
+    data := Source
+  else
+  begin
+    FillCharFast(tmp, fInfo.Cache.ItemSize, 0);
+    BinaryLoad(@tmp, Source, fInfo.Cache.ItemInfo, nil, SourceMax, rkAllTypes);
+    if Source = nil then
+      exit;
+    data := @tmp;
+  end;
+  try
+    if Assigned(fCompare) then
+      result := Find(data^) // use specific comparer
+    else
+      result := IndexOf(data^); // use RTTI
+  finally
+    if data = @tmp then
+      fInfo.ArrayRtti.ValueFinalize(data);
+  end;
+end;
+
+
+{ ************ TDynArrayHasher }
+
+function HashAnsiString(Item: PAnsiChar; Hasher: THasher): cardinal;
+begin
+  Item := PPointer(Item)^; // passed by reference
+  if Item <> nil then
+    result := Hasher(0, Item, PStrLen(Item - _STRLEN)^)
+  else
+    result := 0;
+end;
+
+function HashAnsiStringI(Item: PUtf8Char; Hasher: THasher): cardinal;
+var
+  tmp: array[byte] of AnsiChar; // avoid slow heap allocation
+begin
+  Item := PPointer(Item)^;
+  if Item <> nil then
+    result := Hasher(0, tmp{%H-},
+      UpperCopy255Buf(tmp{%H-}, Item, PStrLen(Item - _STRLEN)^) - {%H-}tmp)
+  else
+    result := 0;
+end;
+
+function HashSynUnicode(Item: PSynUnicode; Hasher: THasher): cardinal;
+begin
+  if PtrUInt(Item^) <> 0 then
+    result := Hasher(0, Pointer(Item^), Length(Item^) * 2)
+  else
+    result := 0;
+end;
+
+function HashSynUnicodeI(Item: PSynUnicode; Hasher: THasher): cardinal;
+var
+  tmp: array[byte] of AnsiChar; // avoid slow heap allocation
+begin
+  if PtrUInt(Item^) <> 0 then
+    result := Hasher(0, tmp{%H-}, UpperCopy255W(tmp{%H-}, Item^) - {%H-}tmp)
+  else
+    result := 0;
+end;
+
+function HashWideString(Item: PWideString; Hasher: THasher): cardinal;
+begin
+  // WideString internal size is in bytes, not WideChar
+  if PtrUInt(Item^) <> 0 then
+    result := Hasher(0, Pointer(Item^), Length(Item^) * 2)
+  else
+    result := 0;
+end;
+
+function HashWideStringI(Item: PWideString; Hasher: THasher): cardinal;
+var
+  tmp: array[byte] of AnsiChar; // avoid slow heap allocation
+begin
+  if PtrUInt(Item^) <> 0 then
+    result := Hasher(0, tmp{%H-},
+      UpperCopy255W(tmp{%H-}, pointer(Item^), Length(Item^)) - {%H-}tmp)
+  else
+    result := 0;
+end;
+
+function HashPUtf8Char(Item: PAnsiChar; Hasher: THasher): cardinal;
+begin
+  Item := PPointer(Item)^; // passed by reference
+  if Item <> nil then
+    result := Hasher(0, Item, StrLen(Item))
+  else
+    result := 0;
+end;
+
+function HashPUtf8CharI(Item: PUtf8Char; Hasher: THasher): cardinal;
+var
+  tmp: array[byte] of AnsiChar; // avoid slow heap allocation
+begin
+  Item := PPointer(Item)^;
+  if Item <> nil then
+    result := Hasher(0, tmp{%H-},
+      UpperCopy255Buf(tmp{%H-}, Item, StrLen(Item)) - {%H-}tmp)
+  else
+    result := 0;
+end;
+
+function HashByte(Item: pointer; Hasher: THasher): cardinal;
+begin
+  result := Hasher(0, Item, SizeOf(byte));
+end;
+
+function HashWord(Item: pointer; Hasher: THasher): cardinal;
+begin
+  result := Hasher(0, Item, SizeOf(word));
+end;
+
+function HashInteger(Item: pointer; Hasher: THasher): cardinal;
+begin
+  result := Hasher(0, Item, SizeOf(integer));
+end;
+
+function HashInt64(Item: pointer; Hasher: THasher): cardinal;
+begin
+  result := Hasher(0, Item, SizeOf(Int64));
+end;
+
+function HashExtended(Item: pointer; Hasher: THasher): cardinal;
+begin
+  result := Hasher(0, Item, SizeOf(TSynExtended));
+end;
+
+function Hash128(Item: pointer; Hasher: THasher): cardinal;
+begin
+  result := Hasher(0, Item, SizeOf(THash128));
+end;
+
+function Hash256(Item: pointer; Hasher: THasher): cardinal;
+begin
+  result := Hasher(0, Item, SizeOf(THash256));
+end;
+
+function Hash512(Item: pointer; Hasher: THasher): cardinal;
+begin
+  result := Hasher(0, Item, SizeOf(THash512));
+end;
+
+function VariantHash(const value: variant; CaseInsensitive: boolean;
+  Hasher: THasher): cardinal;
+var
+  tmp: array[byte] of AnsiChar; // avoid heap allocation
+  vt: cardinal;
+  S: TStream;
+  W: TTextWriter;
+  P: pointer;
+  len: integer;
+begin
+  if not Assigned(Hasher) then
+    Hasher := DefaultHasher;
+  with TVarData(value) do
+  begin
+    vt := VType;
+    P := @VByte; // same address than VWord/VInteger/VInt64...
+    case vt of
+      varNull, varEmpty:
+        len := 0; // good enough for void values
+      varShortInt, varByte:
+        len := 1;
+      varSmallint, varWord, varboolean:
+        len := 2;
+      varLongWord, varInteger, varSingle:
+        len := 4;
+      varInt64, varDouble, varDate, varCurrency, varWord64:
+        len := 8;
+      varString:
+        begin
+          len := length(RawUtf8(VAny));
+          P := VAny;
+        end;
+      varOleStr:
+        begin
+          len := length(WideString(VAny));
+          P := VAny;
+        end;
+      {$ifdef HASVARUSTRING}
+      varUString:
+        begin
+          len := length(UnicodeString(VAny));
+          P := VAny;
+        end;
+      {$endif HASVARUSTRING}
+      else
+      begin
+        S := TFakeWriterStream.Create;
+        W := DefaultJsonWriter.Create(S, @tmp, SizeOf(tmp));
+        try
+          W.AddVariant(value, twJsonEscape);
+          len := W.WrittenBytes;
+          if len > 255 then
+            len := 255;
+          P := @tmp; // big JSON won't be hasheable anyway -> use only buffer
+        finally
+          W.Free;
+          S.Free;
+        end;
+      end;
+    end;
+    if CaseInsensitive and
+       (P <> @VByte) then
+    begin
+      len := UpperCopy255Buf(tmp, P, len) - tmp;
+      P := @tmp;
+    end;
+    result := Hasher(vt, P, len)
+  end;
+end;
+
+function HashVariant(Item: PVariant; Hasher: THasher): cardinal;
+begin
+  result := VariantHash(Item^, false, Hasher);
+end;
+
+function HashVariantI(Item: PVariant; Hasher: THasher): cardinal;
+begin
+  result := VariantHash(Item^, true, Hasher);
+end;
+
+const
+  // helper arrays to get the standard hash functions
+  PT_HASH: array[{caseinsensitive=}boolean, TRttiParserType] of pointer = (
+   // case sensitive hash functions:
+   (nil,                     //  ptNone
+    nil,                     //  ptArray
+    @HashByte,               //  ptBoolean
+    @HashByte,               //  ptByte
+    @HashInteger,            //  ptCardinal
+    @HashInt64,              //  ptCurrency
+    @HashInt64,              //  ptDouble
+    @HashExtended,           //  ptExtended
+    @HashInt64,              //  ptInt64
+    @HashInteger,            //  ptInteger
+    @HashInt64,              //  ptQWord
+    @HashAnsiString,         //  ptRawByteString
+    @HashAnsiString,         //  ptRawJson
+    @HashAnsiString,         //  ptRawUtf8
+    nil,                     //  ptRecord
+    @HashInteger,            //  ptSingle
+    {$ifdef UNICODE} @HashSynUnicode {$else} @HashAnsiString {$endif}, //  ptString
+    @HashSynUnicode,         //  ptSynUnicode
+    @HashInt64,              //  ptDateTime
+    @HashInt64,              //  ptDateTimeMS
+    @Hash128,                //  ptGuid
+    @Hash128,                //  ptHash128
+    @Hash256,                //  ptHash256
+    @Hash512,                //  ptHash512
+    @HashInt64,              //  ptOrm
+    @HashInt64,              //  ptTimeLog
+    @HashSynUnicode,         //  ptUnicodeString
+    @HashInt64,              //  ptUnixTime
+    @HashInt64,              //  ptUnixMSTime
+    @HashVariant,            //  ptVariant
+    @HashWideString,         //  ptWideString
+    @HashAnsiString,         //  ptWinAnsi
+    @HashWord,               //  ptWord
+    nil,                     //  ptEnumeration
+    nil,                     //  ptSet
+    {$ifdef CPU32} @HashInteger {$else} @HashInt64 {$endif}, // ptClass
+    nil,                     //  ptDynArray
+    {$ifdef CPU32} @HashInteger {$else} @HashInt64 {$endif}, // ptInterface
+    @HashPUtf8Char,          //  ptPUtf8Char
+    nil),                    //  ptCustom
+   // case insensitive hash functions:
+   (nil,                     //  ptNone
+    nil,                     //  ptArray
+    @HashByte,               //  ptBoolean
+    @HashByte,               //  ptByte
+    @HashInteger,            //  ptCardinal
+    @HashInt64,              //  ptCurrency
+    @HashInt64,              //  ptDouble
+    @HashExtended,           //  ptExtended
+    @HashInt64,              //  ptInt64
+    @HashInteger,            //  ptInteger
+    @HashInt64,              //  ptQWord
+    @HashAnsiString,         //  ptRawByteString
+    @HashAnsiStringI,        //  ptRawJson
+    @HashAnsiStringI,        //  ptRawUtf8
+    nil,                     //  ptRecord
+    @HashInteger,            //  ptSingle
+    {$ifdef UNICODE} @HashSynUnicodeI {$else} @HashAnsiStringI {$endif}, //  ptString
+    @HashSynUnicodeI,        //  ptSynUnicode
+    @HashInt64,              //  ptDateTime
+    @HashInt64,              //  ptDateTimeMS
+    @Hash128,                //  ptGuid
+    @Hash128,                //  ptHash128
+    @Hash256,                //  ptHash256
+    @Hash512,                //  ptHash512
+    @HashInt64,              //  ptOrm
+    @HashInt64,              //  ptTimeLog
+    @HashSynUnicodeI,        //  ptUnicodeString
+    @HashInt64,              //  ptUnixTime
+    @HashInt64,              //  ptUnixMSTime
+    @HashVariantI,           //  ptVariant
+    @HashWideStringI,        //  ptWideString
+    @HashAnsiStringI,        //  ptWinAnsi
+    @HashWord,               //  ptWord
+    nil,                     //  ptEnumeration
+    nil,                     //  ptSet
+    {$ifdef CPU32} @HashInteger {$else} @HashInt64 {$endif}, // ptClass
+    nil,                     //  ptDynArray
+    {$ifdef CPU32} @HashInteger {$else} @HashInt64 {$endif}, // ptInterface
+    @HashPUtf8CharI,         //  ptPUtf8Char
+    nil));                   //  ptCustom
+
+function DynArrayHashOne(Kind: TRttiParserType;
+  CaseInsensitive: boolean): TDynArrayHashOne;
+begin
+  result := PT_HASH[CaseInsensitive, Kind];
+end;
+
+procedure TDynArrayHasher.Init(aDynArray: PDynArray; aHashItem: TDynArrayHashOne;
+  const aEventHash: TOnDynArrayHashOne; aHasher: THasher;
+  aCompare: TDynArraySortCompare; const aEventCompare: TOnDynArraySortCompare;
+  aCaseInsensitive: boolean);
+begin
+  fDynArray := aDynArray;
+  fHashItem := aHashItem;
+  fEventHash := aEventHash;
+  if not (Assigned(fHashItem) or
+          Assigned(fEventHash)) then
+  begin
+    fHashItem := PT_HASH[aCaseInsensitive, fDynArray^.Info.ArrayFirstField];
+    if not Assigned(fHashItem) then
+      fEventHash := fDynArray^.Info.ValueFullHash;
+  end;
+  fCompare := aCompare;
+  fEventCompare := aEventCompare;
+  if not (Assigned(fCompare) or
+          Assigned(fEventCompare)) then
+  begin
+    fCompare := PT_SORT[aCaseInsensitive, fDynArray^.Info.ArrayFirstField];
+    if not Assigned(fCompare) then
+      fEventCompare := fDynArray^.Info.ValueFullCompare;
+  end;
+  HashTableInit(aHasher);
+end;
+
+procedure TDynArrayHasher.InitSpecific(aDynArray: PDynArray;
+  aKind: TRttiParserType; aCaseInsensitive: boolean; aHasher: THasher);
+begin
+  fDynArray := aDynArray;
+  fHashItem := PT_HASH[aCaseInsensitive, aKind];
+  if Assigned(fHashItem) then
+    fEventHash := nil
+  else
+    fEventHash := aDynArray^.Info.ValueFullHash;
+  fCompare := PT_SORT[aCaseInsensitive, aKind];
+  if Assigned(fCompare) then
+    fEventCompare := nil
+  else
+    fEventCompare := aDynArray^.Info.ValueFullCompare;
+  HashTableInit(aHasher);
+end;
+
+procedure TDynArrayHasher.HashTableInit(aHasher: THasher);
+begin
+  if not Assigned(aHasher) then
+    aHasher := DefaultHasher;
+  fHasher := aHasher;
+  fHashTableStore := nil;
+  if (Assigned(fHashItem) or
+      Assigned(fEventHash)) and
+     (Assigned(fCompare) or
+      Assigned(fEventCompare)) then
+  begin
+    // same logic than ReHash(true) with no data
+    fHashTableSize := 256;
+    {$ifdef DYNARRAYHASH_16BIT}
+    SetLength(fHashTableStore, 128 {$ifndef DYNARRAYHASH_PO2} + 1 {$endif});
+    fState := [hasHasher, hash16bit];
+    {$else}
+    SetLength(fHashTableStore, 256);
+    byte(State) := 1 shl ord(hasHasher)
+    {$endif DYNARRAYHASH_16BIT}
+  end
+  else
+    byte(fState) := 0;
+  {$ifdef DYNARRAYHASHCOLLISIONCOUNT}
+  CountCollisions := 0;
+  CountCollisionsCurrent := 0;
+  {$endif DYNARRAYHASHCOLLISIONCOUNT}
+end;
+
+procedure TDynArrayHasher.SetEventCompare(const Value: TOnDynArraySortCompare);
+begin
+  if fDynArray^.GetCount <> 0 then
+    raise EDynArray.Create('TDynArrayHasher: unexpected SetEventCompare');
+  fEventCompare := Value;
+  HashTableInit(fHasher);
+end;
+
+procedure TDynArrayHasher.SetEventHash(const Value: TOnDynArrayHashOne);
+begin
+  if fDynArray^.GetCount <> 0 then
+    raise EDynArray.Create('TDynArrayHasher: unexpected SetEventHash');
+  fEventHash := Value;
+  HashTableInit(fHasher);
+end;
+
+function TDynArrayHasher.HashOne(Item: pointer): cardinal;
+begin
+  if Assigned(fEventHash) then
+    result := fEventHash(Item^)
+  else if not Assigned(fHashItem) then
+    result := 0 // will be ignored afterwards for sure
+  else
+    result := fHashItem(Item^, fHasher);
+end;
+
+function TDynArrayHasher.Equals(Item: pointer; ndx: PtrInt): boolean;
+begin
+  ndx := ndx * fDynArray^.fInfo.Cache.ItemSize;
+  inc(ndx, PPtrInt(fDynArray^.Value)^);
+  if Assigned(fEventCompare) then
+    result := fEventCompare(pointer(ndx)^, Item^) = 0
+  else
+    result := fCompare(pointer(ndx)^, Item^) = 0;
+end;
+
+const
+  // reduces memory consumption and enhances distribution at hash table growing
+  _PRIMES: array[0..38 {$ifndef DYNARRAYHASH_PO2} + 13 {$endif}] of integer = (
+    {$ifndef DYNARRAYHASH_PO2}
+    251, 499, 797, 1259, 2011, 3203, 5087, 8089, 12853, 20399, 81649, 129607, 205759,
+    {$endif DYNARRAYHASH_PO2}
+    // start after HASH_PO2=2^18=262144 for DYNARRAYHASH_PO2 (poor 64-bit mul)
+    326617, 411527, 518509, 653267, 823117, 1037059, 1306601, 1646237,
+    2074129, 2613229, 3292489, 4148279, 5226491, 6584983, 8296553, 10453007,
+    13169977, 16593127, 20906033, 26339969, 33186281, 41812097, 52679969,
+    66372617, 83624237, 105359939, 132745199, 167248483, 210719881, 265490441,
+    334496971, 421439783, 530980861, 668993977, 842879579, 1061961721,
+    1337987929, 1685759167, 2123923447);
+
+// as used internally by TDynArrayHasher.ForceReHash()
+function NextPrime(v: integer): integer; {$ifdef HASINLINE}inline;{$endif}
+var
+  i: PtrInt;
+  P: PIntegerArray;
+begin
+  P := @_PRIMES;
+  for i := 0 to high(_PRIMES) do
+  begin
+    result := P^[i];
+    if result > v then
+      exit;
+  end;
+end;
+
+// see TTestCoreBase._TSynDictionary for some numbers, and why
+//  DYNARRAYHASH_LEMIRE + DYNARRAYHASH_PO2 are defined by default
+function TDynArrayHasher.HashTableIndex(aHashCode: PtrUInt): PtrUInt;
+begin
+  result := fHashTableSize;
+  {$ifdef DYNARRAYHASH_PO2}
+  // Delphi Win32 e.g. is not efficient with Lemire 64-bit multiplication
+  if result <= HASH_PO2 then
+    // efficient AND for power of two division
+    result := aHashCode and (result - 1)
+  else
+  {$endif DYNARRAYHASH_PO2}
+  {$ifdef DYNARRAYHASH_LEMIRE}
+    // FPC or dcc64 compile next line as very optimized asm
+    result := (QWord(aHashCode) * result) shr 32;
+    // https://lemire.me/blog/2016/06/27/a-fast-alternative-to-the-modulo-reduction
+  {$else}
+    // regular 32-bit modulo over a Prime: slower but best from our tests
+    result := aHashCode mod result;
+  {$endif DYNARRAYHASH_LEMIRE}
+end;
+
+function TDynArrayHasher.HashTableIndexToIndex(aHashTableIndex: PtrInt): PtrInt;
+begin
+  result := PtrUInt(fHashTableStore);
+  {$ifdef DYNARRAYHASH_16BIT}
+  if hash16bit in fState then
+    result := PWordArray(result)[aHashTableIndex]
+  else
+  {$endif DYNARRAYHASH_16BIT}
+    result := PIntegerArray(result)[aHashTableIndex];
+end;
+
+function TDynArrayHasher.Find(aHashCode: cardinal; aForAdd: boolean): PtrInt;
+var
+  first, last, ndx, siz: PtrInt;
+  P: PAnsiChar;
+begin
+  if not (hasHasher in fState) then
+  begin
+    result := -1;
+    exit;
+  end;
+  result := HashTableIndex(aHashCode);
+  first := result;
+  last := fHashTableSize;
+  P := fDynArray^.Value^;
+  siz := fDynArray^.Info.Cache.ItemSize;
+  repeat
+    ndx := HashTableIndexToIndex(result) - 1; // index+1 was stored
+    if ndx < 0 then
+    begin
+      // found void entry
+      result := -(result + 1);
+      exit;
+    end
+    else if not aForAdd and
+            (HashOne(P + ndx * siz) = aHashCode) then
+    begin
+      result := ndx;
+      exit;
+    end;
+    inc(result); // try next entry on hash collision
+    if result = last then
+      // reached the end -> search once from HashTable[0] to HashTable[first-1]
+      if result = first then
+        break
+      else
+      begin
+        result := 0;
+        last := first;
+      end;
+  until false;
+  RaiseFatalCollision('Find', aHashCode);
+end;
+
+function TDynArrayHasher.FindOrNew(aHashCode: cardinal; Item: pointer;
+  aHashTableIndex: PPtrInt): PtrInt;
+var
+  first, last, ndx: PtrInt;
+  {$ifdef DYNARRAYHASHCOLLISIONCOUNT}
+  collisions: integer;
+  {$endif DYNARRAYHASHCOLLISIONCOUNT}
+  P: PAnsiChar;
+begin
+  if not (hasHasher in fState) then
+  begin
+    result := -1;
+    exit; // we need comparison and hash functions
+  end;
+  {$ifdef DYNARRAYHASHCOLLISIONCOUNT}
+  collisions := 0;
+  {$endif DYNARRAYHASHCOLLISIONCOUNT}
+  result := HashTableIndex(aHashCode);
+  first := result;
+  last := fHashTableSize;
+  repeat
+    ndx := HashTableIndexToIndex(result) - 1; // index+1 was stored
+    if ndx < 0 then
+    begin
+      // not found: returns void index in HashTable[] as negative value
+      result := - (result + 1);
+      {$ifdef DYNARRAYHASHCOLLISIONCOUNT}
+      inc(CountCollisions, collisions);
+      inc(CountCollisionsCurrent, collisions);
+      {$endif DYNARRAYHASHCOLLISIONCOUNT}
+      exit;
+    end;
+    // comparison with item is faster than hash e.g. for huge strings
+    with fDynArray^ do
+      P := PAnsiChar(Value^) + ndx * fInfo.Cache.ItemSize;
+    if ((not Assigned(fEventCompare)) and
+        (fCompare(P^, Item^) = 0)) or
+       (Assigned(fEventCompare) and
+        (fEventCompare(P^, Item^) = 0)) then
+    begin
+      // found: returns the matching index
+      if aHashTableIndex <> nil then
+        aHashTableIndex^ := result;
+      result := ndx;
+      exit;
+    end;
+    // hash or slot collision -> search next item
+    {$ifdef DYNARRAYHASHCOLLISIONCOUNT}
+    inc(collisions);
+    {$endif DYNARRAYHASHCOLLISIONCOUNT}
+    inc(result);
+    if result = last then
+      // reached the end -> search once from HashTable[0] to HashTable[first-1]
+      if result = first then
+        break
+      else
+      begin
+        result := 0;
+        last := first;
+      end;
+  until false;
+  RaiseFatalCollision('FindOrNew', aHashCode);
+end;
+
+function TDynArrayHasher.FindOrNewComp(aHashCode: cardinal; Item: pointer;
+  Comp: TDynArraySortCompare): PtrInt;
+var
+  first, last, ndx: PtrInt;
+begin // cut-down version of FindOrNew()
+  if not Assigned(Comp) then
+    Comp := fCompare;
+  ndx := HashTableIndex(aHashCode);
+  first := ndx;
+  last := fHashTableSize;
+  if hasHasher in fState then
+    repeat
+      result := HashTableIndexToIndex(ndx) - 1; // index+1 was stored
+      if (result < 0) or // void slot = not found, or return matching index
+         (Comp((PAnsiChar(fDynArray^.Value^) +
+           result * fDynArray^.fInfo.Cache.ItemSize)^, Item^) = 0) then
+        exit;
+      inc(ndx); // hash or slot collision -> search next item
+      if ndx = last then
+        if ndx= first then
+          break
+        else
+        begin
+          ndx := 0;
+          last := first;
+        end;
+    until false;
+  result := 0; // make compiler happy
+  RaiseFatalCollision('FindOrNewComp', aHashCode);
+end;
+
+procedure TDynArrayHasher.HashAdd(aHashCode: cardinal; var result: PtrInt);
+var
+  n, ndx: PtrInt;
+begin
+  // on input: HashTable[result] slot is already computed
+  n := fDynArray^.Count;
+  ndx := result;
+  result := n;
+  if fHashTableSize < n then
+    RaiseFatalCollision('HashAdd HashTableSize', aHashCode);
+  if fHashTableSize - n < n shr 2 then
+  begin
+    // grow hash table when 25% void (192/256,384/512,768/1024,1536/2048...)
+    ForceReHash;
+    ndx := Find(aHashCode, {foradd=}true); // recompute position
+    if ndx >= 0 then
+      RaiseFatalCollision('HashAdd', aHashCode);
+  end;
+  ndx := -ndx - 1; // store Index+1 (0 means void slot)
+  inc(n);
+  {$ifdef DYNARRAYHASH_16BIT}
+  if hash16bit in fState then
+    PWordArray(fHashTableStore)[ndx] := n
+  else
+  {$endif DYNARRAYHASH_16BIT}
+    fHashTableStore[ndx] := n;
+end; // on output: result holds the position in fValue[]
+
+procedure TDynArrayHasher.HashDelete(aArrayIndex, aHashTableIndex: PtrInt;
+  aHashCode: cardinal);
+var
+  first, next, last, n, s, ndx, i: PtrInt;
+  P: PAnsiChar;
+  indexes: array[0..511] of integer; // to be rehashed  (seen always < 32)
+begin
+  // retrieve hash table entries to be recomputed
+  first := aHashTableIndex;
+  last := fHashTableSize;
+  next := first;
+  n := 0;
+  repeat
+    {$ifdef DYNARRAYHASH_16BIT}
+    if hash16bit in fState then
+      PWordArray(fHashTableStore)[next] := 0
+    else
+    {$endif DYNARRAYHASH_16BIT}
+      fHashTableStore[next] := 0; // Clear slots
+    inc(next);
+    if next = last then
+      if next = first then
+        RaiseFatalCollision('HashDelete down', aHashCode)
+      else
+      begin
+        next := 0;
+        last := first;
+      end;
+    ndx := HashTableIndexToIndex(next) - 1; // index+1 was stored
+    if ndx < 0 then
+      break; // stop at void entry
+    if n = high(indexes) then // paranoid (typical 0..23 range)
+      RaiseFatalCollision('HashDelete indexes[] overflow', aHashCode);
+    indexes[n] := ndx;
+    inc(n);
+  until false;
+  // ReHash collided entries - note: item is not yet deleted in Value^[]
+  s := fDynArray^.Info.Cache.ItemSize;
+  for i := 0 to n - 1 do
+  begin
+    P := PAnsiChar(fDynArray^.Value^) + {%H-}indexes[i] * s;
+    ndx := FindOrNew(HashOne(P), P, nil);
+    if ndx < 0 then // ignore ndx>=0 dups (like ReHash)
+    begin
+      ndx := -ndx - 1;     // compute the new slot position
+      n := indexes[i] + 1; // store index+1
+      {$ifdef DYNARRAYHASH_16BIT}
+      if hash16bit in fState then
+        PWordArray(fHashTableStore)[ndx] := n
+      else
+      {$endif DYNARRAYHASH_16BIT}
+        fHashTableStore[ndx] := n;
+    end;
+  end;
+  // adjust all stored indexes (using SSE2/AVX2 on x86_64)
+  {$ifdef DYNARRAYHASH_16BIT}
+  if hash16bit in fState then
+    DynArrayHashTableAdjust16(pointer(fHashTableStore), aArrayIndex, fHashTableSize)
+  else
+  {$endif DYNARRAYHASH_16BIT}
+    DynArrayHashTableAdjust(pointer(fHashTableStore), aArrayIndex, fHashTableSize);
+end;
+
+function TDynArrayHasher.FindBeforeAdd(Item: pointer; out wasAdded: boolean;
+  aHashCode: cardinal): PtrInt;
+begin
+  wasAdded := false;
+  if hasHasher in fState then
+  begin
+    result := FindOrNew(aHashCode, Item, nil);
+    if result >= 0 then
+      exit;
+    // found no matching item
+    wasAdded := true;
+    HashAdd(aHashCode, result);
+  end
+  else
+    result := -1
+end;
+
+function TDynArrayHasher.FindBeforeDelete(Item: pointer): PtrInt;
+var
+  h: cardinal;
+  ndx: PtrInt;
+begin
+  if hasHasher in fState then
+  begin
+    h := HashOne(Item);
+    result := FindOrNew(h, Item, @ndx);
+    if result < 0 then
+      result := -1
+    else
+      HashDelete(result, ndx, h);
+  end
+  else
+    result := -1;
+end;
+
+procedure TDynArrayHasher.RaiseFatalCollision(const caller: shortstring;
+  aHashCode: cardinal);
+begin
+  // a dedicated sub-procedure reduces code size
+  raise EDynArray.CreateUtf8('TDynArrayHasher.% fatal collision: ' +
+    'aHashCode=% HashTableSize=% Count=% Capacity=% Array=% Parser=%',
+    [caller, CardinalToHexShort(aHashCode), fHashTableSize, fDynArray^.Count,
+     fDynArray^.Capacity, fDynArray^.Info.Name, ToText(fDynArray^.Info.Parser)^]);
+end;
+
+function TDynArrayHasher.GetHashFromIndex(aIndex: PtrInt): cardinal;
+var
+  P: pointer;
+begin
+  P := fDynArray^.ItemPtr(aIndex);
+  if P <> nil then
+    result := HashOne(P)
+  else
+    result := 0;
+end;
+
+function TDynArrayHasher.Scan(Item: pointer): PtrInt;
+var
+  P: PAnsiChar;
+  i, max, siz: PtrInt;
+begin
+  result := -1;
+  max := fDynArray^.Count - 1;
+  P := fDynArray^.Value^;
+  siz := fDynArray^.Info.Cache.ItemSize;
+  if Assigned(fEventCompare) then // custom comparison
+    for i := 0 to max do
+      if fEventCompare(P^, Item^) = 0 then
+      begin
+        result := i;
+        break;
+      end
+      else
+        inc(P, siz)
+  else if Assigned(fCompare) then
+    for i := 0 to max do
+      if fCompare(P^, Item^) = 0 then
+      begin
+        result := i;
+        break;
+      end
+      else
+        inc(P, siz)
+  else
+    exit;
+end;
+
+function TDynArrayHasher.Find(Item: pointer): PtrInt;
+begin
+  result := Find(Item, HashOne(Item));
+end;
+
+function TDynArrayHasher.Find(Item: pointer; aHashCode: cardinal): PtrInt;
+begin
+  result := FindOrNew(aHashCode, Item, nil); // fallback to Scan() if needed
+  if result < 0 then
+    result := -1; // for coherency with most search methods
+end;
+
+type
+  {$ifdef USERECORDWITHMETHODS}
+  TFastReHash = record
+  {$else}
+  TFastReHash = object // dedicated object for better register allocation
+  {$endif USERECORDWITHMETHODS}
+  public
+    hc: cardinal;
+    {$ifdef DYNARRAYHASHCOLLISIONCOUNT}
+    collisions: integer;
+    {$endif DYNARRAYHASHCOLLISIONCOUNT}
+    ht: integer;
+    values, first, last, siz: PtrInt;
+    duplicates: PInteger;
+    P: PAnsiChar;
+    // fill fHashTableStore[] from all stored items
+    procedure Process(Hasher: PDynArrayHasher; count: PtrInt);
+  end;
+
+procedure TFastReHash.Process(Hasher: PDynArrayHasher; count: PtrInt);
+var
+  fnd, ndx: PtrInt;
+label
+  s;
+begin
+  // should match FindOrNew() logic
+  {$ifdef DYNARRAYHASHCOLLISIONCOUNT}
+  collisions := 0;
+  {$endif DYNARRAYHASHCOLLISIONCOUNT}
+  P := Hasher^.fDynArray^.Value^;
+  values := PtrUInt(P);
+  siz := Hasher^.fDynArray^.Info.Cache.ItemSize;
+  ht := 1; // store index + 1
+  repeat
+s:  if Assigned(Hasher^.fEventHash) then // inlined HashOne()
+      hc := Hasher^.fEventHash(P^)
+    else
+      hc := Hasher^.fHashItem(P^, Hasher^.fHasher);
+    ndx := Hasher^.HashTableIndex(hc);
+    first := ndx;
+    last := Hasher^.fHashTableSize;
+    repeat
+      {$ifdef DYNARRAYHASH_16BIT} // inlined HashTableIndexToIndex()
+      if hash16bit in Hasher^.fState then
+      begin
+        if PWordArray(Hasher^.fHashTableStore)[ndx] = 0 then // store index + 1
+        begin
+          // we can use this void entry (most common case)
+          PWordArray(Hasher^.fHashTableStore)[ndx] := ht;
+          inc(P, siz); // next item
+          inc(ht);
+          dec(count);
+          if count <> 0 then
+            goto s;
+          exit;
+        end;
+      end
+      else
+      {$endif DYNARRAYHASH_16BIT}
+      if Hasher^.fHashTableStore[ndx] = 0 then // void entry
+      begin
+        Hasher^.fHashTableStore[ndx] := ht;
+        inc(P, siz); // next item
+        inc(ht);
+        dec(count);
+        if count <> 0 then
+          goto s;
+        exit;
+      end;
+      {$ifdef DYNARRAYHASHCOLLISIONCOUNT}
+      inc(collisions);
+      {$endif DYNARRAYHASHCOLLISIONCOUNT}
+      if duplicates <> nil then
+      begin
+        // check for duplicated values only if necessary (slow down process)
+        if hash16bit in Hasher^.fState then
+          fnd := PWordArray(Hasher^.fHashTableStore)[ndx]
+        else
+          fnd := Hasher^.fHashTableStore[ndx];
+        fnd := values + (fnd - 1) * siz; // stored index + 1
+        if ((not Assigned(Hasher^.fEventCompare)) and
+            (Hasher^.fCompare(pointer(fnd)^, P^) = 0)) or
+           (Assigned(Hasher^.fEventCompare) and
+            (Hasher^.fEventCompare(pointer(fnd)^, P^) = 0)) then
+        begin
+          inc(duplicates^); // report but ignore duplicates
+          break;
+        end;
+      end;
+      inc(ndx);
+      if ndx = last then
+        // reached the end -> search from HashTable[0] to HashTable[first-1]
+        if ndx = first then
+          Hasher.RaiseFatalCollision('ReHash', hc)
+        else
+        begin
+          ndx := 0;
+          last := first;
+        end;
+    until false;
+    inc(P, siz); // next item
+    inc(ht);
+    dec(count);
+  until count = 0;
+end;
+
+procedure TDynArrayHasher.ForceReHash(duplicates: PInteger);
+var
+  n, cap, siz: PtrInt;
+  fastrehash: TFastReHash;
+begin
+  if duplicates <> nil then
+    duplicates^ := 0;
+  if not (hasHasher in fState) then
+    exit;
+  // Capacity better than Count or HashTableSize, * 2 to reserve some void slots
+  cap := fDynArray^.Capacity * 2;
+  {$ifdef DYNARRAYHASH_PO2}
+  if cap <= HASH_PO2 then
+  begin
+    siz := 256; // find nearest power of two for fast bitwise division
+    while siz < cap do
+      siz := siz shl 1;
+  end
+  else
+  {$endif DYNARRAYHASH_PO2}
+    siz := NextPrime(cap);
+//QueryPerformanceMicroSeconds(t1); write('rehash count=',n,' old=',HashTableSize,
+//' new=', siz, ' oldcol=',CountCollisionsCurrent);
+  fHashTableStore := nil;
+  fHashTableSize := siz;
+  {$ifdef DYNARRAYHASH_16BIT}
+  if siz <= 1 shl 16 then
+  begin
+    include(fState, hash16bit); // we can store indexes as 16-bit word values
+    siz := (siz shr 1) {$ifndef DYNARRAYHASH_PO2} + 1 {$endif}; // 32-bit count
+  end
+  else
+    exclude(fState, hash16bit);
+  {$endif DYNARRAYHASH_16BIT}
+  SetLength(fHashTableStore, siz); // fill with 0 (void slot)
+  {$ifdef DYNARRAYHASHCOLLISIONCOUNT}
+  CountCollisionsCurrent := 0; // count collision for this HashTable[] only
+  {$endif DYNARRAYHASHCOLLISIONCOUNT}
+  // fill fHashTableStore[]=index+1 from all existing items
+  n := fDynArray^.Count;
+  if n <> 0 then
+  begin
+    fastrehash.duplicates := duplicates;
+    fastrehash.Process(@self, n);
+    {$ifdef DYNARRAYHASHCOLLISIONCOUNT}
+    inc(CountCollisions, fastrehash.collisions);
+    inc(CountCollisionsCurrent, fastrehash.collisions);
+    {$endif DYNARRAYHASHCOLLISIONCOUNT}
+  end;
+//QueryPerformanceMicroSeconds(t2); writeln(' newcol=',CountCollisionsCurrent,' ',
+//(CountCollisionsCurrent * 100) div cardinal(n), '%  ',MicroSecToString(t2-t1));
+end;
+
+{$ifndef PUREMORMOT2}
+function TDynArrayHasher.ReHash(forced: boolean): integer;
+begin
+  ForceRehash(@result); // always forced for true thread-safety
+end;
+{$endif PUREMORMOT2}
+
+
+{ ************ TDynArrayHashed }
+
+{ TDynArrayHashed }
+
+{$ifdef UNDIRECTDYNARRAY} // some Delphi 2009+ wrapper definitions
+
+function TDynArrayHashed.GetCount: PtrInt;
+begin
+  result := InternalDynArray.GetCount;
+end;
+
+procedure TDynArrayHashed.SetCount(aCount: PtrInt);
+begin
+  InternalDynArray.SetCount(aCount);
+end;
+
+function TDynArrayHashed.GetCapacity: PtrInt;
+begin
+  result := InternalDynArray.GetCapacity;
+end;
+
+procedure TDynArrayHashed.SetCapacity(aCapacity: PtrInt);
+begin
+  InternalDynArray.SetCapacity(aCapacity);
+end;
+
+function TDynArrayHashed.Value: PPointer;
+begin
+  result := InternalDynArray.fValue;
+end;
+
+function TDynArrayHashed.Info: TRttiCustom;
+begin
+  result := InternalDynArray.fInfo;
+end;
+
+function TDynArrayHashed.ItemSize: PtrUInt;
+begin
+  result := InternalDynArray.fInfo.Cache.ItemSize;
+end;
+
+procedure TDynArrayHashed.ItemCopy(Source, Dest: pointer);
+begin
+  InternalDynArray.ItemCopy(Source, Dest);
+end;
+
+function TDynArrayHashed.ItemPtr(index: PtrInt): pointer;
+begin
+  result := InternalDynArray.ItemPtr(index);
+end;
+
+function TDynArrayHashed.ItemCopyAt(index: PtrInt; Dest: pointer): boolean;
+begin
+  result := InternalDynArray.ItemCopyAt(index, Dest);
+end;
+
+procedure TDynArrayHashed.Clear;
+begin
+  InternalDynArray.SetCount(0);
+end;
+
+function TDynArrayHashed.Add(const Item): PtrInt;
+begin
+  result := InternalDynArray.Add(Item);
+end;
+
+procedure TDynArrayHashed.Delete(aIndex: PtrInt);
+begin
+  InternalDynArray.Delete(aIndex);
+end;
+
+function TDynArrayHashed.SaveTo: RawByteString;
+begin
+  result := InternalDynArray.SaveTo;
+end;
+
+function TDynArrayHashed.LoadFrom(Source, SourceMax: PAnsiChar): PAnsiChar;
+begin
+  result := InternalDynArray.LoadFrom(Source, SourceMax);
+end;
+
+function TDynArrayHashed.LoadFromBinary(const Buffer: RawByteString): boolean;
+begin
+  result := InternalDynArray.LoadFromBinary(Buffer);
+end;
+
+procedure TDynArrayHashed.SaveTo(W: TBufferWriter);
+begin
+  InternalDynArray.SaveTo(W);
+end;
+
+procedure TDynArrayHashed.Sort(aCompare: TDynArraySortCompare);
+begin
+  InternalDynArray.Sort(aCompare);
+end;
+
+procedure TDynArrayHashed.CreateOrderedIndex(var aIndex: TIntegerDynArray;
+  aCompare: TDynArraySortCompare);
+begin
+  InternalDynArray.CreateOrderedIndex(aIndex, aCompare);
+end;
+
+function TDynArrayHashed.SaveToJson(EnumSetsAsText: boolean;
+  reformat: TTextWriterJsonFormat): RawUtf8;
+begin
+  result := InternalDynArray.SaveToJson(EnumSetsAsText, reformat);
+end;
+
+procedure TDynArrayHashed.SaveToJson(out result: RawUtf8; EnumSetsAsText: boolean;
+  reformat: TTextWriterJsonFormat);
+begin
+  InternalDynArray.SaveToJson(result, EnumSetsAsText, reformat);
+end;
+
+procedure TDynArrayHashed.SaveToJson(W: TTextWriter);
+begin
+  InternalDynArray.SaveToJson(W);
+end;
+
+function TDynArrayHashed.LoadFromJson(P: PUtf8Char; aEndOfObject: PUtf8Char;
+  CustomVariantOptions: PDocVariantOptions): PUtf8Char;
+begin
+  result := InternalDynArray.LoadFromJson(P, aEndOfObject, CustomVariantOptions);
+end;
+
+{$endif UNDIRECTDYNARRAY}
+
+procedure TDynArrayHashed.Init(aTypeInfo: PRttiInfo; var aValue;
+  aHashItem: TDynArrayHashOne; aCompare: TDynArraySortCompare;
+  aHasher: THasher; aCountPointer: PInteger; aCaseInsensitive: boolean);
+begin
+  InitRtti(Rtti.RegisterType(aTypeInfo), aValue, aHashItem, aCompare,
+    aHasher, aCountPointer, aCaseInsensitive);
+end;
+
+procedure TDynArrayHashed.InitRtti(aRtti: TRttiCustom; var aValue;
+  aHashItem: TDynArrayHashOne; aCompare: TDynArraySortCompare;
+  aHasher: THasher; aCountPointer: PInteger; aCaseInsensitive: boolean);
+begin
+  {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$else}inherited{$endif}
+    InitRtti(aRtti, aValue, aCountPointer);
+  fHash.Init(@self, aHashItem, nil, aHasher, aCompare, nil, aCaseInsensitive);
+  {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare := fHash.fCompare;
+end;
+
+procedure TDynArrayHashed.InitSpecific(aTypeInfo: PRttiInfo; var aValue;
+  aKind: TRttiParserType; aCountPointer: PInteger; aCaseInsensitive: boolean;
+  aHasher: THasher);
+begin
+  {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$else}inherited{$endif}
+    Init(aTypeInfo, aValue, aCountPointer);
+  fHash.InitSpecific(@self, aKind, aCaseInsensitive, aHasher);
+  {$ifdef UNDIRECTDYNARRAY}InternalDynArray.{$endif}fCompare := fHash.fCompare;
+end;
+
+function TDynArrayHashed.Scan(const Item): PtrInt;
+begin
+  result := fHash.Scan(@Item);
+end;
+
+function TDynArrayHashed.FindHashed(const Item): PtrInt;
+begin
+  result := fHash.FindOrNew(fHash.HashOne(@Item), @Item, nil);
+  if result < 0 then
+    result := -1; // for coherency with most methods
+end;
+
+function TDynArrayHashed.FindFromHash(const Item; aHashCode: cardinal): PtrInt;
+begin
+  // overload FindHashed() trigger F2084 Internal Error: C2130 on Delphi XE3
+  result := fHash.FindOrNew(aHashCode, @Item, nil); // fallback to Scan() if needed
+  if result < 0 then
+    result := -1; // for coherency with most methods
+end;
+
+function TDynArrayHashed.FindHashedForAdding(const Item; out wasAdded: boolean;
+  noAddEntry: boolean): PtrInt;
+begin
+  result := FindHashedForAdding(Item, wasAdded, fHash.HashOne(@Item), noAddEntry);
+end;
+
+function TDynArrayHashed.FindHashedForAdding(const Item; out wasAdded: boolean;
+  aHashCode: cardinal; noAddEntry: boolean): PtrInt;
+begin
+  result := fHash.FindBeforeAdd(@Item, wasAdded, aHashCode);
+  if wasAdded and
+     not noAddEntry then
+    SetCount(result + 1); // reserve space for a void element in array
+end;
+
+function TDynArrayHashed.AddAndMakeUniqueName(aName: RawUtf8): pointer;
+var
+  ndx: PtrInt;
+  j: PtrUInt;
+  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
+      if j > high(SmallUInt32Utf8) then // should never happen - 999 is enough
+        raise EDynArray.Create('TDynArrayHashed.AddAndMakeUniqueName overflow');
+      aName := aName_ + SmallUInt32Utf8[j];
+      ndx := FindHashedForAdding(aName, added);
+      inc(j);
+    until added;
+  end;
+  result := PAnsiChar(Value^) + ndx * Info.Cache.ItemSize;
+  PRawUtf8(result)^ := aName; // store unique name at 1st position
+end;
+
+function TDynArrayHashed.AddUniqueName(const aName: RawUtf8;
+  aNewIndex: PPtrInt): pointer;
+begin
+  result := AddUniqueName(aName, '', [], aNewIndex);
+end;
+
+function TDynArrayHashed.AddUniqueName(const aName: RawUtf8; const ExceptionMsg: RawUtf8;
+  const ExceptionArgs: array of const; aNewIndex: PPtrInt): pointer;
+var
+  ndx: PtrInt;
+  added: boolean;
+begin
+  ndx := FindHashedForAdding(aName, added);
+  if added then
+  begin
+    if aNewIndex <> nil then
+      aNewIndex^ := ndx;
+    result := PAnsiChar(Value^) + ndx * Info.Cache.ItemSize;
+    PRawUtf8(result)^ := aName; // store unique name at 1st position
+  end
+  else if ExceptionMsg = '' then
+    raise EDynArray.CreateUtf8('TDynArrayHashed: Duplicated [%] name', [aName])
+  else
+    raise EDynArray.CreateUtf8(ExceptionMsg, ExceptionArgs);
+end;
+
+function TDynArrayHashed.FindHashedAndFill(var ItemToFill): PtrInt;
+begin
+  result := fHash.FindOrNew(fHash.HashOne(@ItemToFill), @ItemToFill, nil);
+  if result < 0 then
+    result := -1
+  else
+    ItemCopy(PAnsiChar(Value^) + result * Info.Cache.ItemSize, @ItemToFill);
+end;
+
+function TDynArrayHashed.FindHashedAndUpdate(const Item;
+  AddIfNotExisting: boolean): PtrInt;
+var
+  hc: cardinal;
+begin
+  if hasHasher in fHash.fState then
+  begin
+    hc := fHash.HashOne(@Item);
+    result := fHash.FindOrNew(hc, @Item, nil);
+    if (result < 0) and
+       AddIfNotExisting then
+    begin
+      fHash.HashAdd(hc, result); // ReHash only if necessary
+      SetCount(result + 1); // add new item
+    end;
+  end
+  else
+    result := -1;
+  if result >= 0 then // update
+    ItemCopy(@Item, PAnsiChar(Value^) + result * Info.Cache.ItemSize);
+end;
+
+function TDynArrayHashed.FindHashedAndDelete(const Item; FillDeleted: pointer;
+  noDeleteEntry: boolean): PtrInt;
+begin
+  result := fHash.FindBeforeDelete(@Item);
+  if result >= 0 then
+  begin
+    if FillDeleted <> nil then
+      ItemCopyAt(result, FillDeleted);
+    if not noDeleteEntry then
+      Delete(result);
+  end;
+end;
+
+function TDynArrayHashed.GetHashFromIndex(aIndex: PtrInt): cardinal;
+begin
+  result := fHash.GetHashFromIndex(aIndex);
+end;
+
+procedure TDynArrayHashed.ForceReHash;
+begin
+  fHash.ForceReHash;
+end;
+
+{$ifndef PUREMORMOT2}
+function TDynArrayHashed.ReHash(forced: boolean): integer;
+begin
+  fHash.ForceReHash(@result); // always forced
+end;
+{$endif PUREMORMOT2}
+
+procedure TDynArrayHashed.SetEventCompare(const cmp: TOnDynArraySortCompare);
+begin
+  fHash.SetEventCompare(cmp);
+end;
+
+procedure TDynArrayHashed.SetEventHash(const hsh: TOnDynArrayHashOne);
+begin
+  fHash.SetEventHash(hsh);
+end;
+
+
+function DynArray(aTypeInfo: PRttiInfo; var aValue; aCountPointer: PInteger): TDynArray;
+begin
+  result.Init(aTypeInfo, aValue, aCountPointer);
+end;
+
+
+
+{ *************** Integer Arrays Extended Process }
+
+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 < ll then
+        break;
+      Exchg32(Values[ll], Values[hh]);
+    until false;
+    // swap middle item (in position low) back into correct position
+    Exchg32(Values[low], Values[hh]);
+    // next active partition
+    if hh <= median then
+      low := ll;
+    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];
+      {%H-}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];
+      {%H-}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 < ll then
+        break;
+      tmp := ndx[ll];
+      ndx[ll] := ndx[hh];
+      ndx[hh] := tmp; // Exchg32(ndx[ll],ndx[hh]);
+    until false;
+    // swap middle item (in position low) back into correct position
+    Exchg32(ndx[low], ndx[hh]);
+    // next active partition
+    if hh <= median then
+      low := ll;
+    if hh >= median then
+      high := hh - 1;
+  until false;
+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) and
+          (o < oldn) and
+          (old[o] = new[n]) do
+    begin
+      inc(o);
+      inc(n);
+    end;
+    while (o < oldn) and
+          ((n >= newn) or
+           (old[o] < new[n])) do
+    begin
+      if Assigned(deleted) then
+        deleted(sender, old[o]);
+      inc(o);
+    end;
+    while (n < newn) and
+          ((o >= oldn) or
+           (new[n] < old[o])) do
+    begin
+      if Assigned(added) then
+        added(sender, new[n]);
+      inc(n);
+    end;
+  until (o >= oldn) and
+        (n >= newn);
+end;
+
+procedure CopyAndSortInteger(Values: PIntegerArray; ValuesCount: integer;
+  var Dest: TIntegerDynArray);
+begin
+  if ValuesCount > Length(Dest) then
+    SetLength(Dest, ValuesCount);
+  MoveFast(Values^[0], Dest[0], ValuesCount * SizeOf(integer));
+  QuickSortInteger(pointer(Dest), 0, ValuesCount - 1);
+end;
+
+procedure CopyAndSortInt64(Values: PInt64Array; ValuesCount: integer;
+  var Dest: TInt64DynArray);
+begin
+  if ValuesCount > Length(Dest) then
+    SetLength(Dest, ValuesCount);
+  MoveFast(Values^[0], Dest[0], ValuesCount * SizeOf(Int64));
+  QuickSortInt64(pointer(Dest), 0, ValuesCount - 1);
+end;
+
+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
+  EnsureUnique(Values);
+  EnsureUnique(Excluded);
+  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;
+  EnsureUnique(Values);
+  EnsureUnique(Included);
+  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 i last 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: PtrInt): PtrInt;
+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 i last 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: PtrInt): PtrInt;
+begin
+  result := Count;
+  dec(Count);
+  if Count > 0 then
+  begin
+    QuickSortInt64(pointer(Values), 0, Count);
+    result := DeduplicateInt64Sorted(pointer(Values), Count) + 1;
+  end;
+  if result <> Length(Values) then
+    SetLength(Values, result);
+end;
+
+procedure CopyInteger(const Source: TIntegerDynArray; out Dest: TIntegerDynArray);
+var
+  n: integer;
+begin
+  n := Length(Source);
+  SetLength(Dest, n);
+  MoveFast(Source[0], Dest[0], n * SizeOf(integer));
+end;
+
+procedure CopyInt64(const Source: TInt64DynArray; out Dest: TInt64DynArray);
+var
+  n: integer;
+begin
+  n := Length(Source);
+  SetLength(Dest, n);
+  MoveFast(Source[0], Dest[0], n * SizeOf(Int64));
+end;
+
+function MaxInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt; MaxStart: integer): integer;
+var
+  i: PtrInt;
+  v: integer;
+begin
+  result := MaxStart;
+  for i := 0 to ValuesCount - 1 do
+  begin
+    v := Values[i];
+    if v > result then
+      result := v; // movca branchless opcode on FPC
+  end;
+end;
+
+function SumInteger(const Values: TIntegerDynArray; ValuesCount: PtrInt): integer;
+var
+  i: PtrInt;
+begin
+  result := 0;
+  for i := 0 to ValuesCount - 1 do
+    inc(result, Values[i]);
+end;
+
+procedure Reverse(const Values: TIntegerDynArray; ValuesCount: PtrInt; Reversed: PIntegerArray);
+var
+  i: PtrInt;
+begin
+  i := 0;
+  if ValuesCount >= 4 then
+  begin
+    dec(ValuesCount, 4);
+    while i < ValuesCount do
+    begin
+      // faster pipelined version
+      Reversed[Values[i]] := i;
+      Reversed[Values[i + 1]] := i + 1;
+      Reversed[Values[i + 2]] := i + 2;
+      Reversed[Values[i + 3]] := i + 3;
+      inc(i, 4);
+    end;
+    inc(ValuesCount, 4);
+  end;
+  while i < ValuesCount do
+  begin
+    Reversed[Values[i]] := i;
+    inc(i);
+  end;
+  //for i := 0 to Count-1 do Assert(Reverse[Orig[i]]=i);
+end;
+
+procedure Int64ToUInt32(Values64: PInt64Array; Values32: PCardinalArray; Count: PtrInt);
+var
+  i: PtrInt;
+begin
+  for i := 0 to Count - 1 do
+    Values32[i] := Values64[i];
+end;
+
+function AnyScanIndex(P, V: pointer; Count, VSize: PtrInt): PtrInt;
+begin
+  case VSize of
+    // optimized versions for arrays of most simple types
+    1:
+      result := ByteScanIndex(P, Count, PByte(V)^); // SSE2 asm on Intel/AMD
+    2:
+      result := WordScanIndex(P, Count, PWord(V)^); // may use SSE2 asm
+    4:
+      result := IntegerScanIndex(P, Count, PInteger(V)^); // may use SSE2 asm
+    8:
+      result := Int64ScanIndex(P, Count, PInt64(V)^);
+    SizeOf(THash128):
+      result := Hash128Index(P, Count, V);
+    SizeOf(THash256):
+      result := Hash256Index(P, Count, V);
+    // small VSize version (= 0;
+end;
+
+
+{ ************ Abstract Radix Tree Classes }
+
+{ TRadixTreeNode }
+
+function TRadixTreeNode.ComputeDepth: integer;
+var
+  i: PtrInt;
+begin
+  result := 1;
+  for i := 0 to high(Child) do
+    inc(result, Child[i].ComputeDepth); // recursive calculation
+  Depth := result;
+end;
+
+function RadixTreeNodeCompare(const A, B): integer;
+begin // sort static first, then deeper, by path:, by longest path, by text
+  result := ord(TRadixTreeNode(B).Chars[1] <> '<') -
+            ord(TRadixTreeNode(A).Chars[1] <> '<');
+  if result = 0 then
+    result := ord(IdemPChar(pointer(TRadixTreeNode(A).Chars), ' c^) or // may do LowerCaseSelf(Chars) at Insert()
+       (P^ = #0) then
+      break;
+    inc(P);
+    inc(c);
+  until false;
+  if c^ <> #0 then
+    exit; // not enough matched chars
+  // if we reached here, the text do match up to now
+  if P^ = #0 then
+    result := self // exact match found for this entry
+  else
+  begin
+    ch := pointer(Child);
+    if ch = nil then
+      exit;
+    n := PDALen(PAnsiChar(ch) - _DALEN)^ + _DAOFF;
+    repeat
+      if ch^.Chars[1] = t[P^] then
+      begin
+        result := ch^.Find(P);
+        if result <> nil then
+          exit; // match found in children
+      end;
+      inc(ch);
+      dec(n);
+    until n = 0;
+  end;
+end;
+
+procedure TRadixTreeNode.ToText(var Result: RawUtf8; Level: integer);
+var
+  i: PtrInt;
+begin
+  Append(Result, [RawUtf8OfChar(' ', Level), Chars, #10]);
+  for i := 0 to high(Child) do
+    Child[i].ToText(Result, Level + length(Chars));
+end;
+
+
+{ TRadixTree }
+
+constructor TRadixTree.Create(aNodeClass: TRadixTreeNodeClass;
+  aOptions: TRadixTreeOptions);
+begin
+  if aNodeClass = nil then
+    raise ERadixTree.CreateUtf8('%.Create with aNodeClass=nil', [self]);
+  fDefaultNodeClass := aNodeClass;
+  fOptions := aOptions;
+  if rtoCaseInsensitiveUri in aOptions then
+    fNormTable := @NormToLower
+  else
+    fNormTable := @NormToNorm;
+  fRoot := fDefaultNodeClass.Create(self); // with no text
+end;
+
+destructor TRadixTree.Destroy;
+begin
+  inherited Destroy;
+  fRoot.Free; // will recursively free all nested children
+end;
+
+procedure TRadixTree.Clear;
+begin
+  if self = nil then
+    exit;
+  fRoot.Free;
+  fRoot := fDefaultNodeClass.Create(self);
+end;
+
+function TRadixTree.Insert(Text: RawUtf8; Node: TRadixTreeNode;
+  NodeClass: TRadixTreeNodeClass): TRadixTreeNode;
+var
+  match, textlen, nodelen, i: PtrInt;
+  chars: RawUtf8;
+begin
+  result := nil;
+  if Text = '' then
+    exit;
+  if Node = nil then
+    Node := fRoot;
+  if rtoCaseInsensitiveUri in Options then
+    LowerCaseSelf(Text);
+  textlen := length(Text);
+  nodelen := length(Node.Chars);
+  // check how many chars of Text are within Node.Chars
+  match := 0;
+  while (match < textlen) and
+        (match < nodelen) and
+        (Text[match + 1] = Node.Chars[match + 1]) do
+    inc(match);
+  // insert the node where fits
+  chars := copy(Text, match + 1, maxInt);
+  if (match = 0) or
+     (Node = fRoot) or
+     ((match < textlen) and
+      (match >= nodelen)) then
+  begin
+    // we can just insert a new leaf node
+    if chars <> '' then
+      for i := 0 to high(Node.Child) do
+        if Node.Child[i].Chars[1] = chars[1] then
+        begin
+          result := Insert(chars, Node.Child[i]); // recursive insertion
+          result.FullText := Text;
+          exit;
+        end;
+  end
+  else if match <> nodelen then
+  begin
+    // need to split the existing node
+    Node.Split(copy(Node.Chars, match + 1, maxInt)); // split children
+    Node.Chars := copy(Text, 1, match); // new shared root
+    if chars = '' then
+    begin
+      result := Node; // don't need a sub child - use shared root
+      result.FullText := Text;
+      exit;
+    end;
+  end
+  else
+  begin
+    // match an existing node
+    result := Node;
+    exit;
+  end;
+  // create new leaf
+  if NodeClass = nil then
+    NodeClass := fDefaultNodeClass;
+  result := NodeClass.Create(self);
+  result.Chars := chars;
+  result.FullText := Text;
+  ObjArrayAdd(Node.Child, result);
+end;
+
+procedure TRadixTree.AfterInsert;
+begin
+  fRoot.ComputeDepth;
+  fRoot.SortChildren;
+end;
+
+function TRadixTree.Find(const Text: RawUtf8): TRadixTreeNode;
+var
+  n: TDALen;
+  c: AnsiChar;
+  ch: ^TRadixTreeNode;
+begin
+  result := nil;
+  if (self = nil) or
+     (Text = '') then
+    exit;
+  ch := pointer(fRoot.Child);
+  if ch = nil then
+    exit;
+  n := PDALen(PAnsiChar(ch) - _DALEN)^ + _DAOFF;
+  c := fNormTable[Text[1]];
+  repeat
+    if ch^.Chars[1] = c then // recursive call if may match
+    begin
+      result := ch^.Find(pointer(Text));
+      if result <> nil then
+        exit;
+    end;
+    inc(ch);
+    dec(n);
+  until n = 0;
+end;
+
+function TRadixTree.ToText: RawUtf8;
+begin
+  result := '';
+  if self <> nil then
+    fRoot.ToText(result, 0);
+end;
+
+
+{ TRadixTreeNodeParams }
+
+function TRadixTreeNodeParams.Split(const Text: RawUtf8): TRadixTreeNode;
+begin
+  result := inherited Split(Text);
+  TRadixTreeNodeParams(result).Names := Names;
+  Names := nil;
+end;
+
+function TRadixTreeNodeParams.Lookup(P: PUtf8Char; Ctxt: TObject): TRadixTreeNodeParams;
+var
+  n: TDALen;
+  c: PUtf8Char;
+  t: PNormTable;
+  f: TRadixTreeNodeFlags;
+  ch: ^TRadixTreeNodeParams;
+begin
+  result := nil; // no match
+  t := Owner.fNormTable;
+  if Names = nil then
+  begin
+    // static text
+    c := pointer(Chars);
+    if c <> nil then
+    begin
+      repeat
+        if (t^[P^] <> c^) or // may do LowerCaseSelf(Chars) at Insert()
+           (P^ = #0) then
+          break;
+        inc(P);
+        inc(c);
+      until false;
+      if c^ <> #0 then
+        exit; // not enough matched chars
+    end;
+  end
+  else
+  begin
+    //  parameter
+    c := P;
+    f := Flags;
+    if rtfParamInteger in f then //  or rtoIntegerParams
+    begin
+      if (P^ < '0') or (P^ > '9') then
+        exit; // void  is not allowed
+      repeat
+        inc(P)
+      until (P^ < '0') or (P^ > '9');
+      if (P^ <> #0) and (P^ <> '?') and (P^ <> '/') then
+        exit; // not an integer
+    end
+    else if rtfParamPath in f then //  or * as 
+      while (P^ <> #0) and (P^ <> '?') do
+        inc(P)
+    else // regular 
+      while (P^ <> #0) and (P^ <> '?') and (P^ <> '/') do
+        inc(P);
+    if (Ctxt <> nil) and not LookupParam(Ctxt, c, P - c) then
+      exit; // the parameter is not in the expected format for Ctxt
+  end;
+  // if we reached here, the URI do match up to now
+  if (P^ = #0) or (P^ = '?') then
+  begin
+    if (P^ = '?') and (Ctxt <> nil) then
+      LookupParam(Ctxt, P, -1); // store the inlined parameters position in Ctxt
+    result := self; // exact match found for this entry (excluding URI params)
+    exit;
+  end;
+  ch := pointer(Child);
+  if ch = nil then
+    exit;
+  n := PDALen(PAnsiChar(ch) - _DALEN)^ + _DAOFF;
+  repeat
+    if (ch^.Names <> nil) or
+       (ch^.Chars[1] = t^[P^]) then // recursive call only if worth it
+    begin
+      result := ch^.Lookup(P, Ctxt);
+      if result <> nil then
+        exit; // match found in children
+    end;
+    inc(ch);
+    dec(n);
+  until n = 0;
+end;
+
+
+{ TRadixTreeParams }
+
+function TRadixTreeParams.Setup(const aFromUri: RawUtf8;
+  out aNames: TRawUtf8DynArray): TRadixTreeNodeParams;
+var
+  u: PUtf8Char;
+  item, full: RawUtf8;
+  flags: TRadixTreeNodeFlags;
+begin
+  u := pointer(TrimU(aFromUri));
+  if PosExChar('<', aFromUri) = 0 then
+    // a simple static route
+    result := Insert(aFromUri) as TRadixTreeNodeParams
+  else
+    // parse static....static....static into static/param nodes
+    repeat
+      GetNextItem(u, '<', item);
+      full := full + item;
+      result := Insert(full) as TRadixTreeNodeParams; // static (Names = nil)
+      if u = nil then
+        break;
+      GetNextItem(u, '>', item);
+      if item = '' then
+        raise ERadixTree.CreateUtf8('Void <> in %.Setup(''%'')', [self, aFromUri]);
+      flags := [rtfParam];
+      if IdemPChar(pointer(item), 'INT:') then
+      begin
+        delete(item, 1, 4);
+        include(flags, rtfParamInteger);
+      end
+      else if rtoIntegerParams in Options then
+        include(flags, rtfParamInteger);
+      if IdemPChar(pointer(item), 'PATH:') then
+      begin
+        delete(item, 1, 5);
+        include(flags, rtfParamPath);
+      end;
+      if FindRawUtf8(aNames{%H-}, item) >= 0 then
+        raise ERadixTree.CreateUtf8('Duplicated <%> in %.Setup(''%'')',
+          [item, self, aFromUri]);
+      AddRawUtf8(aNames, item);
+      full := full + '<' + item + '>'; // avoid name collision with static
+      result := Insert(full) as TRadixTreeNodeParams; // param (Names <> nil)
+      result.Names := copy(aNames); // each node has its own Names copy
+      result.Flags := flags;
+      if (u = nil) or
+         (u^ = #0) then
+        // TODO: detect wildchar incompatibilities with nested searches?
+        break;
+      if u^ <> '/' then
+        raise ERadixTree.CreateUtf8('Unexpected <%>% in %.Setup(''%'')',
+          [item, u^, self, aFromUri]);
+    until false;
+  AfterInsert; // compute Depth and sort by priority
+end;
+
+
+
+procedure InitializeUnit;
+var
+  k: TRttiKind;
+begin
+  // initialize RTTI low-level comparison functions
+  RTTI_ORD_COMPARE[roSByte]  := @_BC_SByte;
+  RTTI_ORD_COMPARE[roUByte]  := @_BC_UByte;
+  RTTI_ORD_COMPARE[roSWord]  := @_BC_SWord;
+  RTTI_ORD_COMPARE[roUWord]  := @_BC_UWord;
+  RTTI_ORD_COMPARE[roSLong]  := @_BC_SLong;
+  RTTI_ORD_COMPARE[roULong]  := @_BC_ULong;
+  {$ifdef FPC_NEWRTTI}
+  RTTI_ORD_COMPARE[roSQWord] := @_BC_SQWord;
+  RTTI_ORD_COMPARE[roUQWord] := @_BC_UQWord;
+  {$endif FPC_NEWRTTI}
+  RTTI_FLOAT_COMPARE[rfSingle]   := @_BC_Single;
+  RTTI_FLOAT_COMPARE[rfDouble]   := @_BC_Double;
+  RTTI_FLOAT_COMPARE[rfExtended] := @_BC_Extended;
+  RTTI_FLOAT_COMPARE[rfComp]     := @_BC_SQWord; // PInt64 is the best
+  RTTI_FLOAT_COMPARE[rfCurr]     := @_BC_SQWord;
+  // initialize RTTI binary persistence and high-level comparison functions
+  for k := succ(low(k)) to high(k) do
+    case k of
+      rkInteger,
+      rkEnumeration,
+      rkSet,
+      rkChar,
+      rkWChar
+      {$ifdef FPC}, rkBool{$endif}:
+        begin
+          RTTI_BINARYSAVE[k] := @_BS_Ord;
+          RTTI_BINARYLOAD[k] := @_BL_Ord;
+          RTTI_COMPARE[false, k] := @_BC_Ord;
+          RTTI_COMPARE[true,  k] := @_BC_Ord;
+        end;
+      {$ifdef FPC} rkQWord, {$endif}
+      rkInt64:
+        begin
+          RTTI_BINARYSAVE[k] := @_BS_64;
+          RTTI_BINARYLOAD[k] := @_BL_64;
+          RTTI_COMPARE[false, k] := @_BC_64;
+          RTTI_COMPARE[true,  k] := @_BC_64;
+        end;
+      rkFloat:
+        begin
+          RTTI_BINARYSAVE[k] := @_BS_Float;
+          RTTI_BINARYLOAD[k] := @_BS_Float;
+          RTTI_COMPARE[false, k] := @_BC_Float;
+          RTTI_COMPARE[true,  k] := @_BC_Float;
+        end;
+      rkLString:
+        begin
+          RTTI_BINARYSAVE[k] := @_BS_String;
+          RTTI_BINARYLOAD[k] := @_BL_LString;
+          RTTI_COMPARE[false, k] := @_BC_LString;
+          RTTI_COMPARE[true,  k] := @_BCI_LString;
+        end;
+      {$ifdef HASVARUSTRING}
+      rkUString:
+        begin
+          RTTI_BINARYSAVE[k] := @_BS_UString;
+          RTTI_BINARYLOAD[k] := @_BL_UString;
+          RTTI_COMPARE[false, k] := @_BC_WString;
+          RTTI_COMPARE[true,  k] := @_BCI_WString;
+        end;
+      {$endif HASVARUSTRING}
+      rkWString:
+        begin
+          RTTI_BINARYSAVE[k] := @_BS_WString;
+          RTTI_BINARYLOAD[k] := @_BL_WString;
+          RTTI_COMPARE[false, k] := @_BC_WString;
+          RTTI_COMPARE[true,  k] := @_BCI_WString;
+        end;
+      {$ifdef FPC}rkObject,{$else}{$ifdef UNICODE}rkMRecord,{$endif}{$endif}
+      rkRecord:
+        begin
+          RTTI_BINARYSAVE[k] := @_BS_Record;
+          RTTI_BINARYLOAD[k] := @_BL_Record;
+          RTTI_COMPARE[false, k] := @_BC_Record;
+          RTTI_COMPARE[true,  k] := @_BCI_Record;
+        end;
+      rkDynArray:
+        begin
+          RTTI_BINARYSAVE[k] := @_BS_DynArray;
+          RTTI_BINARYLOAD[k] := @_BL_DynArray;
+          RTTI_COMPARE[false, k] := @_BC_DynArray;
+          RTTI_COMPARE[true,  k] := @_BCI_DynArray;
+        end;
+      rkArray:
+        begin
+          RTTI_BINARYSAVE[k] := @_BS_Array;
+          RTTI_BINARYLOAD[k] := @_BL_Array;
+          RTTI_COMPARE[false, k] := @_BC_Array;
+          RTTI_COMPARE[true,  k] := @_BCI_Array;
+        end;
+      rkVariant:
+        begin
+          RTTI_BINARYSAVE[k] := @_BS_Variant;
+          RTTI_BINARYLOAD[k] := @_BL_Variant;
+          RTTI_COMPARE[false, k] := @_BC_Variant;
+          RTTI_COMPARE[true,  k] := @_BCI_Variant;
+        end;
+      rkClass:
+        begin
+          RTTI_COMPARE[false, k] := @_BC_Object;
+          RTTI_COMPARE[true,  k] := @_BCI_Object;
+        end;
+        // unsupported types will contain nil
+    end;
+  // setup internal function wrappers
+  GetDataFromJson := _GetDataFromJson;
+end;
+
+
+initialization
+  InitializeUnit;
+
+end.
+
diff --git a/lib/dmustache/mormot.core.datetime.pas b/lib/dmustache/mormot.core.datetime.pas
new file mode 100644
index 00000000..250cb0ba
--- /dev/null
+++ b/lib/dmustache/mormot.core.datetime.pas
@@ -0,0 +1,3652 @@
+/// Framework Core Low-Level Date and Time Support
+// - this unit is a part of the Open Source Synopse mORMot framework 2,
+// licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+unit mormot.core.datetime;
+
+{
+  *****************************************************************************
+
+   Date and Time definitions and process shared by all framework units
+    - ISO-8601 Compatible Date/Time Text Encoding
+    - TSynDate / TSynDateTime / TSynSystemTime High-Level objects
+    - TUnixTime / TUnixMSTime POSIX Epoch Compatible 64-bit date/time
+    - TTimeLog efficient 64-bit custom date/time encoding
+    - TTextDateWriter supporting date/time ISO-8601 serialization
+    - TValuePUtf8Char text value wrapper record
+
+  *****************************************************************************
+}
+
+interface
+
+{$I mormot.defines.inc}
+
+uses
+  sysutils,
+  classes,
+  mormot.core.base,
+  mormot.core.os,
+  mormot.core.unicode,
+  mormot.core.text;
+
+
+{ ************ ISO-8601 Compatible Date/Time Text Encoding }
+
+const
+  /// 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 the TExtractInlineParameters decoder
+  JSON_SQLDATE_MAGIC_C = $b1bfef;
+
+  /// UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON
+  // - e.g. '"\uFFF12012-05-04"' pattern
+  JSON_SQLDATE_MAGIC_STR: string[3] = #$ef#$bf#$b1;
+
+  /// '"' + UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON
+  JSON_SQLDATE_MAGIC_QUOTE_C = ord('"') + cardinal(JSON_SQLDATE_MAGIC_C) shl 8;
+
+  /// '"' +  UTF-8 encoded \uFFF1 special code to mark ISO-8601 SQLDATE in JSON
+  // - defined as a ShortString constant to be used as:
+  // ! AddShorter(JSON_SQLDATE_MAGIC_QUOTE_STR);
+  JSON_SQLDATE_MAGIC_QUOTE_STR: string[4] = '"'#$ef#$bf#$b1;
+
+/// 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 HASINLINE}inline;{$endif}
+
+/// Date/Time conversion from ISO-8601
+// - handle 'YYYYMMDDThhmmss' and 'YYYY-MM-DD hh:mm:ss' format
+// - could have been written e.g. by DateTimeToIso8601Text()
+// - 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
+// - any ending/trailing single quote will be removed
+// - 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 TJsonWriter.AddDateTime() or RecordSaveJson()
+// - will also recognize '.sss' milliseconds suffix, if any
+function Iso8601CheckAndDecode(P: PUtf8Char; L: integer;
+  var Value: TDateTime): boolean;
+
+/// 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}
+
+/// Time conversion from ISO-8601 (with no Date part)
+// - handle 'hhmmss' and 'hh:mm:ss' format
+// - will also recognize '.sss' milliseconds suffix, if any
+// - if L is left to default 0, it will be computed from StrLen(P)
+function Iso8601ToTimePUtf8Char(P: PUtf8Char; L: integer = 0): TDateTime; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// Time conversion from ISO-8601 (with no Date part)
+// - handle 'hhmmss' and 'hh:mm:ss' format
+// - will also recognize '.sss' milliseconds suffix, if any
+// - if L is left to default 0, it will be computed from StrLen(P)
+procedure Iso8601ToTimePUtf8CharVar(P: PUtf8Char; L: integer;
+  var result: TDateTime);
+
+/// Time conversion from ISO-8601 (with no Date part)
+// - recognize 'hhmmss' and 'hh:mm:ss' format into H,M,S variables
+// - will also recognize '.sss' milliseconds suffix, if any, into MS
+// - if L is left to default 0, it will be computed from StrLen(P)
+function Iso8601ToTimePUtf8Char(P: PUtf8Char; L: integer;
+  var H, M, S, MS: cardinal): boolean; overload;
+
+/// Date conversion from ISO-8601 (with no Time part)
+// - recognize 'YYYY-MM-DD' and 'YYYYMMDD' format into Y,M,D variables
+// - if L is left to default 0, it will be computed from StrLen(P)
+function Iso8601ToDatePUtf8Char(P: PUtf8Char; L: integer;
+  var Y, M, D: cardinal): boolean;
+
+/// Interval date/time conversion from simple text
+// - expected format does not match ISO-8601 Time intervals format, but Oracle
+// interval litteral representation, i.e. '+/-D HH:MM:SS'
+// - e.g. IntervalTextToDateTime('+0 06:03:20') will return 0.25231481481 and
+// IntervalTextToDateTime('-20 06:03:20') -20.252314815
+// - as a consequence, negative intervals will be written as TDateTime values:
+// !DateTimeToIso8601Text(IntervalTextToDateTime('+0 06:03:20'))='T06:03:20'
+// !DateTimeToIso8601Text(IntervalTextToDateTime('+1 06:03:20'))='1899-12-31T06:03:20'
+// !DateTimeToIso8601Text(IntervalTextToDateTime('-2 06:03:20'))='1899-12-28T06:03:20'
+function IntervalTextToDateTime(Text: PUtf8Char): TDateTime;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// Interval date/time conversion from simple text
+// - expected format does not match ISO-8601 Time intervals format, but Oracle
+// interval litteral representation, i.e. '+/-D HH:MM:SS'
+// - e.g. '+1 06:03:20' will return 1.25231481481
+procedure IntervalTextToDateTimeVar(Text: PUtf8Char; var result: TDateTime);
+
+/// basic Date/Time conversion into ISO-8601
+// - use 'YYYYMMDDThhmmss' format if not Expanded
+// - use 'YYYY-MM-DDThh:mm:ss' format if Expanded
+// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
+// - if QuotedChar is not default #0, will (double) quote the resulted text
+// - you may rather use DateTimeToIso8601Text() to handle 0 or date-only values
+function DateTimeToIso8601(D: TDateTime; Expanded: boolean; FirstChar: AnsiChar = 'T';
+  WithMS: boolean = false; QuotedChar: AnsiChar = #0): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// raw basic Date/Time conversion into ISO-8601 RawUtf8
+procedure DateTimeToIso8601Var(D: TDateTime; Expanded, WithMS: boolean;
+  FirstChar, QuotedChar: AnsiChar; var Result: RawUtf8);
+
+/// raw basic Date/Time conversion into ISO-8601 shortstring
+function DateTimeToIso8601Short(D: TDateTime; Expanded: boolean = true;
+  WithMS: boolean = false; FirstChar: AnsiChar = 'T';
+  QuotedChar: AnsiChar = #0): TShort31;
+
+/// basic Date/Time conversion into ISO-8601
+// - use 'YYYYMMDDThhmmss' format if not Expanded
+// - use 'YYYY-MM-DDThh:mm:ss' format if Expanded
+// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
+// - if QuotedChar is not default #0, will (double) quote the resulted text
+// - you may rather use DateTimeToIso8601Text() to handle 0 or date-only values
+// - returns the number of chars written to P^ buffer
+function DateTimeToIso8601(P: PUtf8Char; D: TDateTime; Expanded: boolean;
+  FirstChar: AnsiChar = 'T'; WithMS: boolean = false;
+  QuotedChar: AnsiChar = #0): integer; overload;
+
+/// basic Date conversion into ISO-8601
+// - use 'YYYYMMDD' format if not Expanded
+// - use 'YYYY-MM-DD' format if Expanded
+function DateToIso8601(Date: TDateTime; Expanded: boolean): RawUtf8; overload;
+
+/// basic Date conversion into ISO-8601
+// - use 'YYYYMMDD' format if not Expanded
+// - use 'YYYY-MM-DD' format if Expanded
+function DateToIso8601(Y, M, D: cardinal; Expanded: boolean): RawUtf8; overload;
+
+/// basic Date period conversion into ISO-8601
+// - will convert an elapsed number of days as ISO-8601 text
+// - use 'YYYYMMDD' format if not Expanded
+// - use 'YYYY-MM-DD' format if Expanded
+function DaysToIso8601(Days: cardinal; Expanded: boolean): RawUtf8;
+
+/// basic Time conversion into ISO-8601
+// - use 'Thhmmss' format if not Expanded
+// - use 'Thh:mm:ss' format if Expanded
+// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
+function TimeToIso8601(Time: TDateTime; Expanded: boolean; FirstChar: AnsiChar = 'T';
+  WithMS: boolean = false): RawUtf8;
+
+/// Write a Date to P^ Ansi buffer
+// - if Expanded is false, 'YYYYMMDD' date format is used
+// - if Expanded is true, 'YYYY-MM-DD' date format is used
+function DateToIso8601PChar(P: PUtf8Char; Expanded: boolean;
+  Y, M, D: PtrUInt): PUtf8Char; overload;
+
+/// convert a date into 'YYYY-MM-DD' date format
+// - resulting text is compatible with all ISO-8601 functions
+function DateToIso8601Text(Date: TDateTime): RawUtf8;
+
+/// Write a Date/Time to P^ Ansi buffer
+function DateToIso8601PChar(Date: TDateTime; P: PUtf8Char;
+  Expanded: boolean): PUtf8Char; overload;
+
+/// Write a TDateTime value, expanded as Iso-8601 encoded text into P^ Ansi buffer
+// - if DT=0, returns ''
+// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD'
+// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss'
+// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss'
+// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
+function DateTimeToIso8601ExpandedPChar(const Value: TDateTime; Dest: PUtf8Char;
+  FirstChar: AnsiChar = 'T'; WithMS: boolean = false): PUtf8Char;
+
+/// write a TDateTime into strict ISO-8601 date and/or time text
+// - if DT=0, returns ''
+// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD'
+// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss'
+// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss'
+// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
+// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods
+function DateTimeToIso8601Text(DT: TDateTime; FirstChar: AnsiChar = 'T';
+  WithMS: boolean = false): RawUtf8;
+
+/// write a TDateTime into strict ISO-8601 date and/or time text
+// - if DT=0, returns ''
+// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD'
+// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss'
+// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss'
+// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
+// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods
+procedure DateTimeToIso8601TextVar(DT: TDateTime; FirstChar: AnsiChar;
+  var result: RawUtf8; WithMS: boolean = false);
+
+/// write a TDateTime into strict ISO-8601 date and/or time text
+// - if DT=0, returns ''
+// - if DT contains only a date, returns the date encoded as 'YYYY-MM-DD'
+// - if DT contains only a time, returns the time encoded as 'Thh:mm:ss'
+// - otherwise, returns the ISO-8601 date and time encoded as 'YYYY-MM-DDThh:mm:ss'
+// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
+// - used e.g. by TPropInfo.GetValue() and TPropInfo.NormalizeValue() methods
+procedure DateTimeToIso8601StringVar(DT: TDateTime; FirstChar: AnsiChar;
+  var result: string; WithMS: boolean = false);
+
+/// Write a Time to P^ Ansi buffer
+// - if Expanded is false, 'Thhmmss' time format is used
+// - if Expanded is true, 'Thh:mm:ss' time format is used
+// - you can custom the first char in from of the resulting text time
+// - if WithMS is TRUE, will append MS as '.sss' for milliseconds resolution
+function TimeToIso8601PChar(P: PUtf8Char; Expanded: boolean; H, M, S, MS: PtrUInt;
+  FirstChar: AnsiChar = 'T'; WithMS: boolean = false): PUtf8Char; overload;
+
+/// Write a Time to P^ Ansi buffer
+// - if Expanded is false, 'Thhmmss' time format is used
+// - if Expanded is true, 'Thh:mm:ss' time format is used
+// - you can custom the first char in from of the resulting text time
+// - if WithMS is TRUE, will append '.sss' for milliseconds resolution
+function TimeToIso8601PChar(Time: TDateTime; P: PUtf8Char; Expanded: boolean;
+  FirstChar: AnsiChar = 'T'; WithMS: boolean = false): PUtf8Char; overload;
+
+/// 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;
+
+/// decode most used TimeZone text values (CEST, GMT, +0200, -0800...)
+// - on match, returns true and the time zone minutes offset in respect to UTC
+// - if P is not a time zone, returns false and leave Zone to its supplied value
+// - will recognize only the most used text values using a fixed table (RFC 822
+// with some extensions like -0000 as current system timezone) - using
+// numerical zones is the preferred way in recent RFC anyway
+function ParseTimeZone(var P: PUtf8Char; var Zone: integer): boolean; overload;
+
+/// decode most used TimeZone text values (CEST, GMT, +0200, -0800...)
+// - just a wrapper around overloaded ParseTimeZone(PUtf8Char)
+function ParseTimeZone(const s: RawUtf8; var Zone: integer): boolean; overload;
+
+/// decode a month from its RFC 822 text value (Jan, Feb...)
+function ParseMonth(var P: PUtF8Char; var Month: word): boolean; overload;
+
+/// decode a month from its RFC 822 text value (Jan, Feb...)
+function ParseMonth(const s: RawUtf8; var Month: word): boolean; overload;
+
+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 with the current timestamp 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 with the current timestamp 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'
+function AppendToTextFile(const aLine: RawUtf8; const aFileName: TFileName;
+  aMaxSize: Int64 = MAXLOGSIZE; aUtcTimeStamp: boolean = false): boolean;
+
+
+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 TOrmTable.ExpandAsString()
+  // methods, i.e. TOrmTableToGrid.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 TOrmTable.ExpandAsString() method,
+  // i.e. TOrmTableToGrid.DrawCell()
+  i18nDateTimeText: function(const DateTime: TDateTime): string = nil;
+
+
+
+{ ************ TSynDate / TSynDateTime / TSynSystemTime High-Level objects }
+
+type
+  {$A-}
+
+  /// a simple way to store a date as Year/Month/Day
+  // - with no intermediate computation needed as with TDate/TUnixTime values
+  // - consider using TSynSystemTime if you need to handle both Date and Time
+  // - match the first 4 fields of TSynSystemTime - so PSynDate(@aSynSystemTime)^
+  // is safe to be used
+  // - some Delphi revisions have trouble with "object" as own method parameters
+  // (e.g. IsEqual or Compare) so we force to use "record" type if possible
+  {$ifdef USERECORDWITHMETHODS}
+  TSynDate = record
+  {$else}
+  TSynDate = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// the Year value of this Date
+    Year: word;
+    /// the Month value of this Date (1..12)
+    Month: word;
+    /// which day of week this Date happened
+    // - sunday is DayOfWeek 1, saturday is 7
+    // - DayOfWeek field is not handled by its methods by default, but could be
+    // filled on demand via ComputeDayOfWeek - making this record 64-bit long
+    DayOfWeek: word;
+    /// the Day value of this Date (1..31)
+    Day: word;
+    /// set all fields to 0
+    procedure Clear;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// set internal date to 9999-12-31
+    procedure SetMax;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// returns true if all fields are zero
+    function IsZero: boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// try to parse a YYYY-MM-DD or YYYYMMDD ISO-8601 date from the supplied buffer
+    // - on success, move P^ just after the date, and return TRUE
+    function ParseFromText(var P: PUtf8Char): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// fill fields with the current UTC/local date, using a 8-16ms thread-safe cache
+    procedure FromNow(localtime: boolean = false);
+    /// fill fields with the supplied date
+    procedure FromDate(date: TDate);
+    /// returns true if all fields do match - ignoring DayOfWeek field value
+    function IsEqual(const another: TSynDate): boolean;
+    /// compare the stored value to a supplied value
+    // - returns <0 if the stored value is smaller than the supplied value,
+    // 0 if both are equals, and >0 if the stored value is bigger
+    // - DayOfWeek field value is not compared
+    function Compare(const another: TSynDate): integer;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// fill the DayOfWeek field from the stored Year/Month/Day
+    // - by default, most methods will just store 0 in the DayOfWeek field
+    // - sunday is DayOfWeek 1, saturday is 7
+    procedure ComputeDayOfWeek;
+    /// convert the stored date into a TDate floating-point value
+    function ToDate: TDate;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// encode the stored date as ISO-8601 text
+    // - returns '' if the stored date is 0 (i.e. after Clear)
+    function ToText(Expanded: boolean = true): RawUtf8;
+  end;
+
+  /// store several dates as Year/Month/Day
+  TSynDateDynArray = array of TSynDate;
+
+  /// a pointer to a TSynDate instance
+  PSynDate = ^TSynDate;
+
+  /// a cross-platform and cross-compiler TSystemTime 128-bit structure
+  // - FPC's TSystemTime in datih.inc does NOT match Windows TSystemTime fields!
+  // - also used to store a Date/Time in TSynTimeZone internal structures, or
+  // for fast conversion from TDateTime to its ready-to-display members
+  // - DayOfWeek field is not handled by most methods by default, but could be
+  // filled on demand via ComputeDayOfWeek
+  // - some Delphi revisions have trouble with "object" as own method parameters
+  // (e.g. IsEqual) so we force to use "record" type if possible
+  {$ifdef USERECORDWITHMETHODS}
+  TSynSystemTime = record
+  {$else}
+  TSynSystemTime = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// the Year value of this timestamp
+    Year: word;
+    /// the Month value of this timstamp, in range 1..12
+    Month: word;
+    /// which day of week this Date happened
+    // - Sunday is DayOfWeek 1, Saturday is 7
+    // - DayOfWeek field is not handled by its methods by default, but could be
+    // filled on demand via ComputeDayOfWeek
+    DayOfWeek: word;
+    /// the Day value of this timestamp, in range 1..31
+    Day: word;
+    /// the Hour value of this timestamp, in range 0..59
+    Hour: word;
+    /// the Minute value of this timestamp, in range 0..59
+    Minute: word;
+    /// the Second value of this timestamp, in range 0..59
+    Second: word;
+    /// the MilliSecond value of this timestamp, in range 0..999
+    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: TSynSystemTime): boolean;
+    /// returns true if date fields do match (ignoring DayOfWeek and time fields)
+    function IsDateEqual(const date: TSynDate): boolean;
+    /// internal method 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;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// fill fields with the current Local time, using a 8-16ms thread-safe cache
+    procedure FromNowLocal;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// fill fields with the current UTC or local time, using a 8-16ms thread-safe cache
+    procedure FromNow(localtime: boolean);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// 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 fields from the given value - but not DayOfWeek
+    procedure FromUnixTime(ut: TUnixTime);
+    /// fill fields from the given value - but not DayOfWeek
+    procedure FromUnixMsTime(ut: TUnixMsTime);
+    /// fill Hour/Minute/Second/Millisecond fields from the given number of milliseconds
+    // - faster than the RTL DecodeTime() function
+    procedure FromMS(ms: PtrUInt);
+    /// fill Hour/Minute/Second/Millisecond fields from the given number of seconds
+    // - faster than the RTL DecodeTime() function
+    procedure FromSec(s: PtrUInt);
+    /// fill Hour/Minute/Second/Millisecond fields from the given TDateTime value
+    // - faster than the RTL DecodeTime() function
+    procedure FromTime(const dt: TDateTime);
+    /// fill Year/Month/Day and Hour/Minute/Second fields from the given ISO-8601 text
+    // - returns true on success
+    function FromText(const iso: RawUtf8): boolean;
+    /// fill Year/Month/Day and Hour/Minute/Second fields from HTTP-date format
+    // - defined e.g. by https://datatracker.ietf.org/doc/html/rfc7231#section-7.1.1
+    // $ Sun, 06 Nov 1994 08:49:37 GMT    ; IMF-fixdate
+    // $ Sunday, 06-Nov-94 08:49:37 GMT   ; obsolete RFC 850 format
+    // $ Sun Nov  6 08:49:37 1994         ; ANSI C's asctime() format
+    function FromHttpDate(const httpdate: RawUtf8;
+      tolocaltime: boolean = false): boolean;
+    /// fill Year/Month/Day and Hour/Minute/Second fields from HTTP-date PUtf8Char
+    function FromHttpDateBuffer(P: PUtf8Char; tolocaltime: boolean): boolean;
+    /// encode the stored date/time as ISO-8601 text with Milliseconds
+    function ToText(Expanded: boolean = true; FirstTimeChar: AnsiChar = 'T';
+      const TZD: RawUtf8 = ''): RawUtf8;
+    /// append a value, expanded as Iso-8601 encoded date text
+    // - use 'YYYY-MM-DD' format
+    procedure AddIsoDate(WR: TTextWriter);
+    /// append a value, expanded as Iso-8601 encoded text
+    // - use 'YYYY-MM-DDThh:mm:ss' format with '.sss' optional milliseconds
+    procedure AddIsoDateTime(WR: TTextWriter; WithMS: boolean;
+      FirstTimeChar: AnsiChar = 'T'; const TZD: 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 TJsonWriter.AddCurrentLogTime()
+    procedure AddLogTime(WR: TTextWriter);
+    /// append the stored date and time, in apache-like format, to a TJsonWriter
+    // - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space
+    procedure AddNcsaText(WR: TTextWriter; const TZD: RawUtf8 = '');
+    /// append the stored date and time, in HTTP-like format, to a TJsonWriter
+    // - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space
+    procedure AddHttpDate(WR: TTextWriter; const TZD: RawUtf8 = 'GMT');
+    /// append the stored date and time, in apache-like format, to a memory buffer
+    // - e.g. "Tue, 15 Nov 1994 12:45:26 GMT" to be used as a value of
+    // - e.g. append '19/Feb/2019:06:18:55 ' - including a trailing space
+    // - returns the number of chars added to P, i.e. always 21
+    function ToNcsaText(P: PUtf8Char): PtrInt;
+    /// convert the stored date and time to its text in apache-like format
+    procedure ToNcsaShort(var text: shortstring; const tz: RawUtf8 = 'GMT');
+    /// convert the stored date and time to its text in HTTP-like format
+    // - i.e. "Tue, 15 Nov 1994 12:45:26 GMT" to be used as a value of
+    // "Date", "Expires" or "Last-Modified" HTTP header
+    // - handle UTC/GMT time zone by default, and allow a 'Date: ' prefix
+    procedure ToHttpDate(out text: RawUtf8; const tz: RawUtf8 = 'GMT';
+      const prefix: RawUtf8 = '');
+    /// convert the stored date and time to its text in HTTP-like format
+    procedure ToHttpDateShort(var text: shortstring; const tz: RawUtf8 = 'GMT';
+      const prefix: RawUtf8 = '');
+    /// convert the stored date and time into its Iso-8601 text, with no Milliseconds
+    procedure ToIsoDateTimeShort(var text: shortstring; FirstTimeChar: AnsiChar = 'T');
+    /// convert the stored date and time into its Iso-8601 text, with no Milliseconds
+    procedure ToIsoDateTime(out text: RawUtf8; FirstTimeChar: AnsiChar = 'T');
+    /// convert the stored date into its Iso-8601 text with no time part
+    procedure ToIsoDate(out text: RawUtf8);
+    /// convert the stored time into its Iso-8601 text with no date part nor Milliseconds
+    procedure ToIsoTime(out text: RawUtf8; FirstTimeChar: RawUtf8 = 'T');
+    /// convert the stored time into a TDateTime
+    function ToDateTime: TDateTime;
+    /// convert the stored time into a TUnixTime in seconds since UNIX Epoch
+    function ToUnixTime: TUnixTime;
+    /// copy Year/Month/DayOfWeek/Day fields to a TSynDate
+    procedure ToSynDate(out date: TSynDate);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// convert the stored time into a timestamped local file name
+    // - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits,
+    // expecting a date > 1999 (a current date would be fine)
+    procedure ToFileShort(out result: TShort16);
+    /// fill the DayOfWeek field from the stored Year/Month/Day
+    // - by default, most methods will just store 0 in the DayOfWeek field
+    // - sunday is DayOfWeek 1, saturday is 7
+    procedure ComputeDayOfWeek;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// compute how many days there are in the current month
+    function DaysInMonth: cardinal;
+    /// 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);
+    /// compute all fields so that they are in their natural range
+    // - set e.g. Second := 60 to force the next minute, or Hour := 24 so that
+    // it will be normalized to the next day
+    procedure Normalize;
+    /// change the system date/time with the value stored in this instance
+    // - i.e. call SetSystemTime/fpsettimeofday API with the stored date/time
+    // - will also flush the FromNowLocal/FromNowUtc cached timestamps
+    function ChangeOperatingSystemTime: boolean;
+  end;
+
+  /// pointer to our cross-platform and cross-compiler TSystemTime 128-bit structure
+  PSynSystemTime = ^TSynSystemTime;
+
+  {$A+}
+
+/// internal low-level function to retrieve the cached current decoded date/time
+procedure FromGlobalTime(out NewTime: TSynSystemTime; LocalTime: boolean;
+  tix64: Int64 = 0);
+
+/// our own faster version of the corresponding RTL function
+function TryEncodeDate(Year, Month, Day: cardinal; out Date: TDateTime): boolean;
+
+/// our own faster version of the corresponding RTL function
+function IsLeapYear(Year: cardinal): boolean;
+
+/// compute how many days there are in a given month
+function DaysInMonth(Year, Month: cardinal): cardinal; overload;
+
+/// compute how many days there are in the month of a given date
+function DaysInMonth(Date: TDateTime): cardinal; overload;
+
+/// retrieve the current local Date, in the ISO 8601 layout, but expanded and
+// ready to be displayed
+function NowToString(Expanded: boolean = true; FirstTimeChar: AnsiChar = ' ';
+  UtcDate: boolean = false): 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;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// 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 TJsonWriter.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 TJsonWriter.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, dt value must be converted to UTC first
+// using TSynTimeZone.LocalToUtc, or tz should be properly set
+function DateTimeToHttpDate(dt: TDateTime; const tz: RawUtf8 = 'GMT'): RawUtf8; overload;
+
+/// convert some "HTTP-date" format as defined by RFC 7231 into date/time
+// - wrapper around TSynSystemTime.FromHttpDate() conversion algorithm
+function HttpDateToDateTime(const httpdate: RawUtf8; var datetime: TDateTime;
+  tolocaltime: boolean = false): boolean; overload;
+
+/// convert some "HTTP-date" format as defined by RFC 7231 into date/time
+function HttpDateToDateTime(const httpdate: RawUtf8;
+  tolocaltime: boolean = false): TDateTime; overload;
+
+/// convert some "HTTP-date" format as defined by RFC 7231 into date/time
+// - wrapper around TSynSystemTime.FromHttpDate() conversion algorithm
+function HttpDateToDateTimeBuffer(httpdate: PUtf8Char; var datetime: TDateTime;
+  tolocaltime: boolean = false): boolean;
+
+/// convert some "HTTP-date" format as defined by RFC 7231 into UTC date/time
+function HttpDateToUnixTime(const httpdate: RawUtf8): TUnixTime;
+
+/// convert some "HTTP-date" format as defined by RFC 7231 into UTC date/time
+function HttpDateToUnixTimeBuffer(httpdate: PUtf8Char): TUnixTime;
+
+type
+  THttpDateNowUtc = string[39];
+
+/// returns the current UTC timestamp as the full 'Date' HTTP header line
+// - e.g. as 'Date: Tue, 15 Nov 1994 12:45:26 GMT'#13#10
+// - returns as a 40-bytes shortstring to avoid a memory allocation by caller
+// - use an internal cache for every second refresh
+function HttpDateNowUtc: THttpDateNowUtc;
+
+/// returns the a specified UTC timestamp in HTTP-like format
+// - e.g. as 'Tue, 15 Nov 1994 12:45:26 GMT'
+function UnixMSTimeUtcToHttpDate(UnixMSTime: TUnixMSTime): TShort31;
+
+/// 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;
+
+/// get the current time a small text layout, perfect e.g. for naming a file
+// - use 'YYMMDDHHMMSS' format so year is truncated to last 2 digits
+function NowToFileShort(localtime: boolean = false): TShort16;
+
+/// retrieve the current Time (whithout Date), in the ISO 8601 layout
+// - useful for direct on screen logging e.g.
+function TimeToString: RawUtf8;
+
+const
+  /// used e.g. by DateTimeMSToString and TJsonWriter.AddDateTimeMS
+  DTMS_FMT: array[boolean] of RawUtf8 = (
+    '%%%%%%%%%',
+    '%-%-%%%:%:%.%%');
+
+
+
+{ ************ TUnixTime / TUnixMSTime POSIX Epoch Compatible 64-bit date/time }
+
+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
+  // - or used to store a timestamp without any 32-bit "Year 2038" overflow
+  UNIXTIME_MINIMAL = 1481187020;
+
+/// returns UnixTimeUtc - UNIXTIME_MINIMAL so has no "Year 2038" overflow issue
+function UnixTimeMinimalUtc: cardinal;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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}
+
+/// 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;
+
+/// 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;
+
+
+
+{ ************ TTimeLog efficient 64-bit custom date/time encoding }
+
+type
+  /// pointer to a memory structure for direct access to a TTimeLog type value
+  PTimeLogBits = ^TTimeLogBits;
+
+  /// internal memory structure for direct access to a TTimeLog type value
+  // - most of the time, you should not use this object, but higher level
+  // TimeLogFromDateTime/TimeLogToDateTime/TimeLogNow/Iso8601ToTimeLog functions
+  // - since TTimeLogBits.Value is bit-oriented, you can't just add or substract
+  // two TTimeLog values when doing date/time computation: use a TDateTime
+  // temporary conversion in such case
+  // - TTimeLogBits.Value needs up to 40-bit precision, so features exact
+  // representation as JavaScript numbers (stored in a 52-bit mantissa)
+  {$ifdef USERECORDWITHMETHODS}
+  TTimeLogBits = record
+  {$else}
+  TTimeLogBits = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// the bit-encoded value itself, which follows an abstract "year" of 16
+    // months of 32 days of 32 hours of 64 minutes of 64 seconds
+    // - bits 0..5   = Seconds (0..59)
+    // - bits 6..11  = Minutes (0..59)
+    // - bits 12..16 = Hours   (0..23)
+    // - bits 17..21 = Day-1   (0..31)
+    // - bits 22..25 = Month-1 (0..11)
+    // - bits 26..40 = Year    (0..9999)
+    Value: Int64;
+    /// extract the date and time content in Value into individual values
+    procedure Expand(out Date: TSynSystemTime);
+    /// convert to Iso-8601 encoded text, truncated to date/time only if needed
+    function Text(Expanded: boolean; FirstTimeChar: AnsiChar = 'T'): RawUtf8; overload;
+    /// convert to Iso-8601 encoded text, truncated to date/time only if needed
+    function Text(Dest: PUtf8Char; Expanded: boolean;
+      FirstTimeChar: AnsiChar = 'T'; QuoteChar: AnsiChar = #0): PUtf8Char; overload;
+    /// convert to Iso-8601 encoded text with date and time part
+    // - never truncate to date/time nor return '' as Text() does
+    function FullText(Expanded: boolean; FirstTimeChar: AnsiChar = 'T';
+      QuotedChar: AnsiChar = #0): RawUtf8; overload;
+      {$ifdef FPC}inline;{$endif} //  URW1111 on Delphi 2010 and URW1136 on XE
+    /// convert to Iso-8601 encoded text with date and time part
+    // - never truncate to date/time or return '' as Text() does
+    function FullText(Dest: PUtf8Char; Expanded: boolean;
+      FirstTimeChar: AnsiChar = 'T'; QuotedChar: AnsiChar = #0): PUtf8Char; overload;
+    /// convert to ready-to-be displayed text
+    // - using i18nDateText global event, if set (e.g. by mORMoti18n.pas)
+    function i18nText: string;
+    /// extract the Time value of this date/time as floating-point TTime
+    function ToTime: TTime;
+    /// extract the Date value of this date/time as floating-point TDate
+    // - will return 0 if the stored value is not a valid date
+    function ToDate: TDate;
+    /// convert to a floating-point TDateTime
+    // - 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 low-level system-specific FileAge() integer
+    // - i.e. 32-bit Windows bitmask local time, or 64-bit Unix UTC time
+    procedure FromFileDate(const FileDate: TFileAge);
+    /// 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 floating-point TDateTime
+// - handle TTimeLog bit-encoded Int64 format
+// - just a wrapper around PTimeLogBits(@aTime)^.From()
+// - we defined such a function since TTimeLogBits(aTimeLog).From() won't change
+// the aTimeLog variable content
+function TimeLogFromDateTime(const DateTime: TDateTime): TTimeLog;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// get TTimeLog value from a given Unix seconds since epoch timestamp
+// - handle TTimeLog bit-encoded Int64 format
+// - just a wrapper around PTimeLogBits(@aTime)^.FromUnixTime()
+function TimeLogFromUnixTime(const UnixTime: TUnixTime): TTimeLog;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// Date/Time conversion from a TTimeLog value
+// - handle TTimeLog bit-encoded Int64 format
+// - just a wrapper around PTimeLogBits(@Timestamp)^.ToDateTime
+// - we defined such a function since TTimeLogBits(aTimeLog).ToDateTime gives an
+// internall compiler error on some Delphi IDE versions (e.g. Delphi 6)
+function TimeLogToDateTime(const Timestamp: TTimeLog): TDateTime;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// Unix seconds since epoch timestamp conversion from a TTimeLog value
+// - handle TTimeLog bit-encoded Int64 format
+// - just a wrapper around PTimeLogBits(@Timestamp)^.ToUnixTime
+function TimeLogToUnixTime(const Timestamp: TTimeLog): TUnixTime;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a Iso8601 encoded string into a TTimeLog value
+// - handle TTimeLog bit-encoded Int64 format
+// - use this function only for fast comparison between two Iso8601 date/time
+// - conversion is faster than Iso8601ToDateTime: use only binary integer math
+// - ContainsNoTime optional pointer can be set to a boolean, which will be
+// set according to the layout in P (e.g. TRUE for '2012-05-26')
+// - returns 0 in case of invalid input string
+function Iso8601ToTimeLogPUtf8Char(P: PUtf8Char; L: integer;
+  ContainsNoTime: PBoolean = nil): TTimeLog;
+
+/// convert a Iso8601 encoded string into a TTimeLog value
+// - handle TTimeLog bit-encoded Int64 format
+// - use this function only for fast comparison between two Iso8601 date/time
+// - conversion is faster than Iso8601ToDateTime: use only binary integer math
+function Iso8601ToTimeLog(const S: RawByteString): TTimeLog;
+  {$ifdef HASINLINE}inline;{$endif}
+
+
+
+{ ******************* TTextDateWriter supporting date/time ISO-8601 serialization }
+
+type
+  /// enhanced TTextWriter inherited class
+  // - in addition to TTextWriter, will handle date/time ISO-8601 serialization
+  TTextDateWriter = class(TTextWriter)
+  public
+    /// append a TTimeLog value, expanded as Iso-8601 encoded text
+    procedure AddTimeLog(Value: PInt64; QuoteChar: AnsiChar = #0);
+    /// append a TUnixTime value, expanded as Iso-8601 encoded text
+    procedure AddUnixTime(Value: PInt64; QuoteChar: AnsiChar = #0);
+    /// append a TUnixMSTime value, expanded as Iso-8601 encoded text
+    procedure AddUnixMSTime(Value: PInt64; WithMS: boolean = false;
+      QuoteChar: AnsiChar = #0);
+    /// append a TDateTime value, expanded as Iso-8601 encoded text
+    // - use 'YYYY-MM-DDThh:mm:ss' format (with FirstChar='T')
+    // - if twoDateTimeWithZ CustomOption is set, will append an ending 'Z'
+    // - if WithMS is TRUE, will append '.sss' for milliseconds resolution
+    // - if QuoteChar is not #0, it will be written before and after the date
+    procedure AddDateTime(Value: PDateTime; FirstChar: AnsiChar = 'T';
+      QuoteChar: AnsiChar = #0; WithMS: boolean = false;
+      AlwaysDateAndTime: boolean = false); overload;
+    /// append a TDateTime value, expanded as Iso-8601 encoded text
+    // - use 'YYYY-MM-DDThh:mm:ss' format
+    // - if twoDateTimeWithZ CustomOption is set, will append an ending 'Z'
+    // - append nothing if Value=0
+    // - if WithMS is TRUE, will append '.sss' for milliseconds resolution
+    procedure AddDateTime(const Value: TDateTime; WithMS: boolean = false); overload;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// append a TDateTime value, expanded as Iso-8601 text with milliseconds
+    // and a specified Time Zone designator
+    // - i.e. 'YYYY-MM-DDThh:mm:ss.sssZ' format
+    // - twoDateTimeWithZ CustomOption is ignored in favor of TZD parameter
+    // - 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 the current UTC date and time, expanded as Iso-8601 encoded text
+    // - use 'YYYY-MM-DDThh:mm:ss' format with '.sss' optional milliseconds
+    // - you may set LocalTime=TRUE to write the local date and time instead
+    // - this method will add the supplied TZD and ignore twoDateTimeWithZ flag
+    procedure AddCurrentIsoDateTime(LocalTime, WithMS: boolean;
+      FirstTimeChar: AnsiChar = 'T'; const TZD: RawUtf8 = '');
+    /// append the current UTC date and time, in apache-like format
+     // - e.g. append '19/Feb/2019:06:18:55 +0000' - with a space before the TZD
+    // - you may set LocalTime=TRUE to write the local date and time instead
+    procedure AddCurrentNcsaLogTime(LocalTime: boolean; const TZD: RawUtf8 = '+0000');
+    /// append the current UTC date and time, in our HTTP format
+    // - e.g. append '19/Feb/2019:06:18:55 GMT' - with a space before the TZD
+    // - you may set LocalTime=TRUE to write the local date and time instead
+    procedure AddCurrentHttpTime(LocalTime: boolean; const TZD: RawUtf8 = 'GMT');
+    /// append the current UTC date and time, in our TSynLog human-friendly format
+    // - e.g. append '20110325 19241502' - with no trailing space nor TZD
+    // - you may set LocalTime=TRUE to write the local date and time instead
+    procedure AddCurrentLogTime(LocalTime: boolean);
+    /// append a time period as "seconds.milliseconds" content
+    procedure AddSeconds(MilliSeconds: QWord; Quote: AnsiChar = #0);
+  end;
+
+
+{ ******************* TValuePUtf8Char text value wrapper record }
+
+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 USERECORDWITHMETHODS}
+  TValuePUtf8Char = record
+  {$else}
+  TValuePUtf8Char = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// a pointer to the actual UTF-8 text
+    Text: PUtf8Char;
+    /// how many UTF-8 bytes are stored in Value
+    Len: PtrInt;
+    /// convert the value into a UTF-8 string
+    procedure ToUtf8(var Value: 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 RTL string
+    function ToString: string;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// convert the value into a signed integer
+    function ToInteger: PtrInt;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// convert the value into an unsigned integer
+    function ToCardinal: PtrUInt; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// convert the value into an unsigned integer
+    function ToCardinal(Def: PtrUInt): PtrUInt; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// convert the value into a 64-bit signed integer
+    function ToInt64: Int64;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// returns true if Value is either '1' or 'true'
+    function ToBoolean: boolean;
+    /// convert the value into a floating point number
+    function ToDouble: double;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// convert the ISO-8601 text value as TDateTime
+    // - could have been written e.g. by DateTimeToIso8601Text()
+    function Iso8601ToDateTime: TDateTime;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// will call IdemPropNameU() over the stored text Value
+    function Idem(const Value: RawUtf8): boolean;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+  end;
+  PValuePUtf8Char = ^TValuePUtf8Char;
+  /// used e.g. by JsonDecode() overloaded function to returns values
+  TValuePUtf8CharArray =
+    array[0 .. maxInt div SizeOf(TValuePUtf8Char) - 1] of TValuePUtf8Char;
+  PValuePUtf8CharArray = ^TValuePUtf8CharArray;
+  TValuePUtf8CharDynArray = array of TValuePUtf8Char;
+
+
+implementation
+
+
+{ ************ ISO-8601 Compatible Date/Time Text Encoding }
+
+function Iso8601ToDateTimePUtf8Char(P: PUtf8Char; L: integer): TDateTime;
+var
+  tmp: TDateTime; // circumvent FPC limitation
+begin
+  Iso8601ToDateTimePUtf8CharVar(P, L, tmp);
+  result := tmp;
+end;
+
+function Iso8601ToDateTime(const S: RawByteString): TDateTime;
+var
+  tmp: TDateTime; // circumvent FPC limitation
+begin
+  Iso8601ToDateTimePUtf8CharVar(pointer(S), length(S), tmp);
+  result := tmp;
+end;
+
+procedure Iso8601ToDateTimePUtf8CharVar(P: PUtf8Char; L: integer;
+  var result: TDateTime);
+var
+  B: cardinal;
+  Y, M, D, H, MI, SS, MS: cardinal;
+  d100: TDiv100Rec;
+  {$ifdef CPUX86NOTPIC}
+  tab: TNormTableByte absolute ConvertHexToBin;
+  {$else}
+  tab: PByteArray; // faster on PIC, ARM and x86_64
+  {$endif CPUX86NOTPIC}
+// expect 'YYYYMMDDThhmmss[.sss]' format but handle also 'YYYY-MM-DDThh:mm:ss[.sss]'
+begin
+  unaligned(result) := 0;
+  if P = nil then
+    exit;
+  if L = 0 then
+    L := StrLen(P);
+  if L < 4 then
+    exit; // we need 'YYYY' at least
+  if (P[0] = '''') and
+     (P[L - 1] = '''') then
+  begin
+    // in-place unquote of input - typical from SQL values
+    inc(P);
+    dec(L, 2);
+    if L < 4 then
+      exit;
+  end;
+  if P[0] = 'T' then
+  begin
+    dec(P, 8);
+    inc(L, 8);
+  end
+  else
+  begin
+    {$ifndef CPUX86NOTPIC}
+    tab := @ConvertHexToBin;
+    {$endif CPUX86NOTPIC}
+    B := tab[ord(P[0])]; // first digit
+    if B > 9 then
+      exit
+    else
+      Y := B; // fast check '0'..'9'
+    B := tab[ord(P[1])];
+    if B > 9 then
+      exit
+    else
+      Y := Y * 10 + B;
+    B := tab[ord(P[2])];
+    if B > 9 then
+      exit
+    else
+      Y := Y * 10 + B;
+    B := tab[ord(P[3])];
+    if B > 9 then
+      exit
+    else
+      Y := Y * 10 + B;
+    if P[4] in ['-', '/'] then
+    begin
+      inc(P);
+      dec(L);
+    end; // allow YYYY-MM-DD
+    D := 1;
+    if L >= 6 then
+    begin
+      // YYYYMM
+      M := ord(P[4]) * 10 + ord(P[5]) - (48 + 480);
+      if (M = 0) or
+         (M > 12) then
+        exit;
+      if P[6] in ['-', '/'] then
+      begin
+        inc(P);
+        dec(L);
+      end; // allow YYYY-MM-DD
+      if L >= 8 then
+      begin
+        // YYYYMMDD
+        if (L > 8) and
+           not (P[8] in [#0, ' ', 'T']) then
+          exit; // invalid date format
+        D := ord(P[6]) * 10 + ord(P[7]) - (48 + 480);
+        if (D = 0) or
+           (D > MonthDays[true][M]) then
+          exit; // worse day number to allow is for leapyear=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{%H-});
+    unaligned(result) := (146097 * d100.d) shr 2 + (1461 * d100.m) shr 2 +
+      (153 * M + 2) div 5 + D;
+    unaligned(result) := unaligned(result) - 693900; // avoid sign issue
+    if L < 15 then
+      exit; // not enough space to retrieve the time
+  end;
+  H := ord(P[9]) * 10 + ord(P[10]) - (48 + 480);
+  if P[11] = ':' then
+  begin
+    inc(P);
+    dec(L);
+  end; // allow hh:mm:ss
+  MI := ord(P[11]) * 10 + ord(P[12]) - (48 + 480);
+  if P[13] = ':' then
+  begin
+    inc(P);
+    dec(L);
+  end; // allow hh:mm:ss
+  SS := ord(P[13]) * 10 + ord(P[14]) - (48 + 480);
+  if (L > 16) and
+     (P[15] = '.') then
+  begin
+    // one or more digits representing a decimal fraction of a second
+    MS := ord(P[16]) * 100 - 4800;
+    if L > 17 then
+      MS := MS {%H-}+ byte(P[17]) * 10 - 480;
+    if L > 18 then
+      MS := MS + byte(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 Iso8601CheckAndDecode(P: PUtf8Char; L: integer;
+  var Value: TDateTime): boolean;
+// handle 'YYYY-MM-DDThh:mm:ss[.sss]' or 'YYYY-MM-DD' or 'Thh:mm:ss[.sss]'
+begin
+  if P = nil then
+    result := false
+  else if (((L = 9) or (L = 13)) and
+            (P[0] = 'T') and (P[3] = ':')) or // 'Thh:mm:ss[.sss]'
+          ((L = 10) and
+           (P[4] = '-') and (P[7] = '-')) or // 'YYYY-MM-DD'
+          (((L = 19) or (L = 23)) and
+           (P[4] = '-') and (P[10] = 'T')) then
+  begin
+    Iso8601ToDateTimePUtf8CharVar(P, L, Value);
+    result := PInt64(@Value)^ <> 0;
+  end
+  else
+    result := false;
+end;
+
+function IsIso8601(P: PUtf8Char; L: integer): boolean;
+begin
+  result := Iso8601ToTimeLogPUtf8Char(P, L) <> 0;
+end;
+
+function Iso8601ToTimePUtf8Char(P: PUtf8Char; L: integer): TDateTime;
+begin
+  Iso8601ToTimePUtf8CharVar(P, L, result);
+end;
+
+procedure Iso8601ToTimePUtf8CharVar(P: PUtf8Char; L: integer;
+  var result: TDateTime);
+var
+  H, MI, SS, MS: cardinal;
+begin
+  if Iso8601ToTimePUtf8Char(P, L, H, MI, SS, MS) then
+    result := (H * (MinsPerHour * SecsPerMin * MSecsPerSec) +
+      MI * (SecsPerMin * MSecsPerSec) + SS * MSecsPerSec + MS) / MSecsPerDay
+  else
+    result := 0;
+end;
+
+function Iso8601ToTimePUtf8Char(P: PUtf8Char; L: integer;
+  var H, M, S, MS: cardinal): boolean;
+begin
+  result := false; // error
+  if P = nil then
+    exit;
+  if L = 0 then
+    L := StrLen(P);
+  if L < 6 then
+    exit; // we need 'hhmmss' at least
+  H := ord(P[0]) * 10 + ord(P[1]) - (48 + 480);
+  if P[2] = ':' then
+  begin
+    inc(P);
+    dec(L);
+  end; // allow hh:mm:ss
+  M := ord(P[2]) * 10 + ord(P[3]) - (48 + 480);
+  if P[4] = ':' then
+  begin
+    inc(P);
+    dec(L);
+  end; // allow hh:mm:ss
+  S := ord(P[4]) * 10 + ord(P[5]) - (48 + 480);
+  if (L > 6) and
+     (P[6] = '.') then
+  begin
+    // one or more digits representing a decimal fraction of a second
+    MS := ord(P[7]) * 100 - 4800;
+    if L > 7 then
+      MS := MS {%H-}+ ord(P[8]) * 10 - 480;
+    if L > 8 then
+      MS := MS + ord(P[9]) - 48;
+  end
+  else
+    MS := 0;
+  if (H < 24) and
+     (M < 60) and
+     (S < 60) and
+     (MS < 1000) then
+    result := true;
+end;
+
+function Iso8601ToDatePUtf8Char(P: PUtf8Char; L: integer;
+  var Y, M, D: cardinal): boolean;
+begin
+  result := false; // error
+  if P = nil then
+    exit;
+  if L = 0 then
+    L := StrLen(P);
+  if (L < 8) or
+     not (P[0] in ['0'..'9']) or
+     not (P[1] in ['0'..'9']) or
+     not (P[2] in ['0'..'9']) or
+     not (P[3] in ['0'..'9']) then
+    exit; // we need 'YYYYMMDD' at least
+  Y := ord(P[0]) * 1000 + ord(P[1]) * 100 + ord(P[2]) * 10 +
+       ord(P[3]) - (48 + 480 + 4800 + 48000);
+  if (Y < 1000) or
+     (Y > 2999) then
+    exit;
+  if P[4] in ['-', '/'] then
+    inc(P); // allow YYYY-MM-DD
+  M := ord(P[4]) * 10 + ord(P[5]) - (48 + 480);
+  if (M = 0) or
+     (M > 12) then
+    exit;
+  if P[6] in ['-', '/'] then
+    inc(P);
+  D := ord(P[6]) * 10 + ord(P[7]) - (48 + 480);
+  if (D <> 0) and
+     (D <= MonthDays[true][M]) then
+    // worse day number to allow is for leapyear=true
+    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;
+
+{$ifndef CPUX86NOTPIC}
+procedure YearToPChar2(tab: PWordArray; Y: PtrUInt; P: PUtf8Char); inline;
+var
+  d100: TDiv100Rec;
+begin
+  Div100(Y, d100{%H-});
+  PWordArray(P)[0] := tab[d100.D];
+  PWordArray(P)[1] := tab[d100.M];
+end;
+{$endif CPUX86NOTPIC}
+
+function DateToIso8601PChar(P: PUtf8Char; Expanded: boolean;
+  Y, M, D: PtrUInt): PUtf8Char;
+// use 'YYYYMMDD' format if not Expanded, 'YYYY-MM-DD' format if Expanded
+var
+  {$ifdef CPUX86NOTPIC}
+  tab: TWordArray absolute TwoDigitLookupW;
+  {$else}
+  tab: PWordArray;
+  {$endif CPUX86NOTPIC}
+begin
+  {$ifdef CPUX86NOTPIC}
+  YearToPChar(Y, P);
+  {$else}
+  tab := @TwoDigitLookupW;
+  YearToPChar2(tab, Y, P);
+  {$endif CPUX86NOTPIC}
+  inc(P, 4);
+  if Expanded then
+  begin
+    P^ := '-';
+    inc(P);
+  end;
+  PWord(P)^ := tab[M];
+  inc(P, 2);
+  if Expanded then
+  begin
+    P^ := '-';
+    inc(P);
+  end;
+  PWord(P)^ := tab[D];
+  result := P + 2;
+end;
+
+function TimeToIso8601PChar(P: PUtf8Char; Expanded: boolean;
+  H, M, S, MS: PtrUInt; FirstChar: AnsiChar; WithMS: boolean): PUtf8Char;
+var
+  {$ifdef CPUX86NOTPIC}
+  tab: TWordArray absolute TwoDigitLookupW;
+  {$else}
+  tab: PWordArray;
+  {$endif CPUX86NOTPIC}
+begin
+  // use Thhmmss[.sss] format
+  if FirstChar <> #0 then
+  begin
+    P^ := FirstChar;
+    inc(P);
+  end;
+  {$ifndef CPUX86NOTPIC}
+  tab := @TwoDigitLookupW;
+  {$endif CPUX86NOTPIC}
+  PWord(P)^ := tab[H];
+  inc(P, 2);
+  if Expanded then
+  begin
+    P^ := ':';
+    inc(P);
+  end;
+  PWord(P)^ := tab[M];
+  inc(P, 2);
+  if Expanded then
+  begin
+    P^ := ':';
+    inc(P);
+  end;
+  PWord(P)^ := tab[S];
+  inc(P, 2);
+  if WithMS then
+  begin
+    {$ifdef CPUX86NOTPIC}
+    YearToPChar(MS, P);
+    {$else}
+    YearToPChar2(tab, MS, P);
+    {$endif CPUX86NOTPIC}
+    P^ := '.'; // override first digit
+    inc(P, 4);
+  end;
+  result := P;
+end;
+
+function DateToIso8601PChar(Date: TDateTime; P: PUtf8Char;
+  Expanded: boolean): PUtf8Char;
+var
+  T: TSynSystemTime;
+begin
+  // use YYYYMMDD / YYYY-MM-DD date format
+  T.FromDate(Date);
+  result := DateToIso8601PChar(P, Expanded, T.Year, T.Month, T.Day);
+end;
+
+function DateToIso8601Text(Date: TDateTime): RawUtf8;
+begin
+  // into 'YYYY-MM-DD' date format
+  if Date = 0 then
+    result := ''
+  else
+  begin
+    FastSetString(result, 10);
+    DateToIso8601PChar(Date, pointer(result), True);
+  end;
+end;
+
+function TimeToIso8601PChar(Time: TDateTime; P: PUtf8Char; Expanded: boolean;
+  FirstChar: AnsiChar; WithMS: boolean): PUtf8Char;
+var
+  T: TSynSystemTime;
+begin
+  T.FromTime(Time);
+  result := TimeToIso8601PChar(P, Expanded, T.Hour, T.Minute, T.Second,
+    T.MilliSecond, FirstChar, WithMS);
+end;
+
+function DateTimeToIso8601(P: PUtf8Char; D: TDateTime; Expanded: boolean;
+  FirstChar: AnsiChar; WithMS: boolean; QuotedChar: AnsiChar): integer;
+var
+    S: PUtf8Char;
+begin
+  S := P;
+  if QuotedChar <> #0 then
+  begin
+    P^ := QuotedChar;
+    inc(P);
+  end;
+  P := DateToIso8601PChar(D, P, Expanded);
+  P := TimeToIso8601PChar(D, P, Expanded, FirstChar, WithMS);
+  if QuotedChar <> #0 then
+  begin
+    P^ := QuotedChar;
+    inc(P);
+  end;
+  result := P - S;
+end;
+
+function DateTimeToIso8601(D: TDateTime; Expanded: boolean;
+  FirstChar: AnsiChar; WithMS: boolean; QuotedChar: AnsiChar): RawUtf8;
+begin
+  DateTimeToIso8601Var(D, Expanded, WithMS, FirstChar, QuotedChar, result);
+end;
+
+procedure DateTimeToIso8601Var(D: TDateTime; Expanded, WithMS: boolean;
+  FirstChar, QuotedChar: AnsiChar; var Result: RawUtf8);
+var
+  tmp: array[0 .. 31] of AnsiChar;
+begin
+  // D=0 is handled in DateTimeToIso8601Text()
+  FastSetString(result, @tmp,
+    DateTimeToIso8601(@tmp, D, Expanded, FirstChar, WithMS, QuotedChar));
+end;
+
+function DateTimeToIso8601Short(D: TDateTime; Expanded, WithMS: boolean;
+  FirstChar, QuotedChar: AnsiChar): TShort31;
+begin
+  if D = 0 then
+    result[0] := #0
+  else
+    result[0] := AnsiChar(DateTimeToIso8601(
+                @result[1], D, Expanded, FirstChar, WithMS, QuotedChar));
+end;
+
+function DateToIso8601(Date: TDateTime; Expanded: boolean): RawUtf8;
+// use YYYYMMDD / YYYY-MM-DD date format
+begin
+  FastSetString(result, 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, 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, 7 + 2 * integer(Expanded) + 4 * integer(WithMS));
+  TimeToIso8601PChar(Time, pointer(result), Expanded, FirstChar, WithMS);
+end;
+
+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); // years as increment, not absolute: always 365 days with no leap
+    while Days > MonthDays[false][M] do
+    begin
+      dec(Days, MonthDays[false][M]);
+      inc(M);
+    end;
+  end;
+  result := DateToIso8601(Y, M, Days, Expanded);
+end;
+
+function DateTimeToIso8601Text(DT: TDateTime; FirstChar: AnsiChar;
+  WithMS: boolean): RawUtf8;
+begin
+  DateTimeToIso8601TextVar(DT, FirstChar, result, WithMS);
+end;
+
+procedure DateTimeToIso8601TextVar(DT: TDateTime; FirstChar: AnsiChar;
+  var result: RawUtf8; WithMS: boolean);
+begin
+  if DT = 0 then
+    result := ''
+  else if frac(DT) = 0 then
+    result := DateToIso8601(DT, true)
+  else if trunc(DT) = 0 then
+    result := TimeToIso8601(DT, true, FirstChar, WithMS)
+  else
+    result := DateTimeToIso8601(DT, true, FirstChar, WithMS);
+end;
+
+procedure DateTimeToIso8601StringVar(DT: TDateTime; FirstChar: AnsiChar;
+  var result: string; WithMS: boolean);
+var
+  tmp: RawUtf8;
+begin
+  DateTimeToIso8601TextVar(DT, FirstChar, tmp, WithMS);
+  Ansi7ToString(Pointer(tmp), length(tmp), result);
+end;
+
+function DateTimeToIso8601ExpandedPChar(const Value: TDateTime; Dest: PUtf8Char;
+  FirstChar: AnsiChar; WithMS: boolean): PUtf8Char;
+begin
+  if Value <> 0 then
+  begin
+    if trunc(Value) <> 0 then
+      Dest := DateToIso8601PChar(Value, Dest, true);
+    if frac(Value) <> 0 then
+      Dest := TimeToIso8601PChar(Value, Dest, true, FirstChar, WithMS);
+  end;
+  Dest^ := #0;
+  result := Dest;
+end;
+
+function VariantToDateTime2(const V: Variant; var Value: TDateTime): boolean;
+var
+  tmp: RawUtf8; // sub-procedure to void hidden try..finally
+begin
+  VariantToUtf8(V, tmp);
+  Iso8601ToDateTimePUtf8CharVar(pointer(tmp), length(tmp), Value);
+  result := Value <> 0;
+end;
+
+function VariantToDateTime(const V: Variant; var Value: TDateTime): boolean;
+var
+  vd: TVarData;
+  vt: cardinal;
+begin
+  vt := TVarData(V).VType;
+  if vt = varVariantByRef then
+    result := VariantToDateTime(PVariant(TVarData(V).VPointer)^, Value)
+  else
+  begin
+    result := true;
+    case vt of
+      varEmpty,
+      varNull:
+        Value := 0;
+      varDouble,
+      varDate:
+        Value := TVarData(V).VDouble;
+      varSingle:
+        Value := TVarData(V).VSingle;
+      varCurrency:
+        Value := TVarData(V).VCurrency;
+      {$ifdef OSWINDOWS}
+      varOleFileTime:
+        Value := FileTimeToDateTime(PFileTime(@TVarData(V).VInt64)^);
+      {$endif OSWINDOWS}
+      varString:
+        with TVarData(V) do
+        begin
+          Iso8601ToDateTimePUtf8CharVar(VString, length(RawUtf8(VString)), Value);
+          result := Value <> 0;
+        end;
+    else
+      if SetVariantUnRefSimpleValue(V, vd{%H-}) then
+        result := VariantToDateTime(variant(vd), Value)
+      else
+        result := VariantToDateTime2(V, Value);
+    end;
+  end;
+end;
+
+const
+  _TZs: PAnsiChar = // fast brute force search in L1 cache
+    #3'GMT'#4'NZDT'#1'M'#4'IDLE'#4'NZST'#3'NZT'#4'EADT'#3'GST'#3'JST'#3'CCT' +
+    #4'WADT'#4'WAST'#3'ZP6'#3'ZP5'#3'ZP4'#2'BT'#3'EET'#4'MEST'#4'MESZ'#3'SST'  +
+    #3'FST'#4'CEST'#3'CET'#3'FWT'#3'MET'#4'MEWT'#3'SWT'#2'UT'#3'UTC'#1'Z'  +
+    #3'WET'#1'A'#3'WAT'#3'BST'#2'AT'#3'ADT'#3'AST'#3'EDT'#3'EST'  +
+    #3'CDT'#3'CST'#3'MDT'#3'MST'#3'PDT'#3'PST'#3'YDT'#3'YST'#3'HDT'  +
+    #4'AHST'#3'CAT'#3'HST'#4'EAST'#2'NT'#4'IDLW'#1'Y';
+
+  _TZv: array[0..54] of ShortInt = (
+    0, 13, 12, 12, 12, 12, 11, 10, 9, 8,
+    8, 7, 6, 5, 4, 3, 2, 2, 2, 2,
+    2, 2, 1, 1, 1, 1, 1, 0, 0, 0,
+    0, -1, -1, -1, -2, -3, -4, -4, -5,
+    -5, -6, -6, -7, -7, -8, -8, -9, -9,
+    -10, -10, -10, -10, -11, -12, -12);
+
+  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');
+
+  HTML_MONTH_NAMES_32: array[0..11] of array[0..3] of AnsiChar = (
+    'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN',
+    'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC');
+
+function ParseTimeZone(var P: PUtf8Char; var Zone: integer): boolean;
+var
+  z: integer;
+  S: PUtf8Char;
+begin
+  result := false;
+  if P = nil then
+    exit;
+  P := GotoNextNotSpace(P);
+  S := P;
+  if PCardinal(S)^ and $ffffff = // most common case (always for HTTP dates)
+       ord('G') + ord('M') shl 8 + ord('T') shl 16 then
+  begin
+    P := GotoNextNotSpace(S + 3);
+    Zone := 0;
+    result := true;
+  end
+  else if (S^ = '+') or
+          (S^ = '-') then
+  begin
+    if not (S[1] in ['0'..'9']) or
+       not (S[2] in ['0'..'9']) or
+       not (S[3] in ['0'..'9']) or
+       not (S[4] in ['0'..'9']) then
+      exit;
+    if (S^ = '-') and
+       (PCardinal(S + 1)^ = $30303030) then // '-0000' for current local
+      Zone := TimeZoneLocalBias
+    else
+    begin
+      Zone := (ord(S[1]) * 10 + ord(S[2]) - (48 + 480)) * 60 +
+              (ord(S[3]) * 10 + ord(S[4]) - (48 + 480));
+      if P^ = '-' then
+        Zone := -Zone;
+    end;
+    P := GotoNextNotSpace(S + 5);
+    result := true;
+  end
+  else
+  begin
+    // TODO: enhance TSynTimeZone from mormot.core.search to parse timezones?
+    while (S^ in ['a'..'z', 'A'..'Z']) do
+      inc(S);
+    z := S - P;
+    if (z >= 1) and
+       (z <= 4) then
+    begin
+      z := FindShortStringListExact(@_TZs[0], high(_TZv), P, z);
+      if z >= 0 then
+      begin
+        Zone := integer(_TZv[z]) * 60;
+        P := GotoNextNotSpace(S);
+        result := true
+      end;
+    end;
+  end;
+end;
+
+function ParseTimeZone(const s: RawUtf8; var Zone: integer): boolean;
+var
+  P: PUtf8Char;
+begin
+  P := pointer(s);
+  result := ParseTimeZone(P, Zone) and
+            (GotoNextNotSpace(P)^ = #0);
+end;
+
+function ParseMonth(var P: PUtf8Char; var Month: word): boolean;
+var
+  m: integer;
+begin
+  result := false;
+  if P = nil then
+    exit;
+  P := GotoNextNotSpace(P);
+  m := PCardinal(P)^ and $dfdfdf;
+  if m and $00404040 <> $00404040 then // quick alphabetical guess
+    exit;
+  m := IntegerScanIndex(@HTML_MONTH_NAMES_32, 12, m);
+  if m < 0 then
+    exit;
+  Month := m + 1;
+  inc(P, 3);
+  if P^ = '-' then
+    inc(P) // e.g. '06-Nov-94'
+  else
+    P := GotoNextNotSpace(P);
+  result := true;
+end;
+
+function ParseMonth(const s: RawUtf8; var Month: word): boolean;
+var
+  P: PUtf8Char;
+begin
+  P := pointer(s);
+  result := ParseMonth(P, Month) and
+            (GotoNextNotSpace(P)^ = #0);
+end;
+
+var
+  AppendToTextFileSafe: TLightLock; // to make AppendToTextFile() thread-safe
+
+function AppendToTextFile(const aLine: RawUtf8; const aFileName: TFileName;
+  aMaxSize: Int64; aUtcTimeStamp: boolean): boolean;
+var
+  line: RawUtf8;
+begin
+  result := false;
+  if (aFileName = '') or
+     (aLine = '') then
+    exit;
+  FormatUtf8(CRLF + '% %',
+    [NowToString(true, ' ', aUtcTimeStamp), TrimControlChars(aLine)], line);
+  AppendToTextFileSafe.Lock;
+  try
+    AppendToFile(line, aFileName, aMaxSize);
+  finally
+    AppendToTextFileSafe.UnLock;
+  end;
+end;
+
+var
+  LogToTextFileName: TFileName;
+
+procedure LogToTextFile(Msg: RawUtf8);
+begin
+  if Msg = '' then
+  begin
+    Msg := GetErrorText(GetLastError);
+    if Msg = '' then
+      exit;
+  end;
+  if LogToTextFileName = '' then
+  begin
+    AppendToTextFileSafe.Lock;
+    try
+      LogToTextFileName := ChangeFileExt(Executable.ProgramFileName, '.log');
+      if not IsDirectoryWritable(Executable.ProgramFilePath, [idwExcludeWinSys]) then
+        LogToTextFileName := GetSystemPath(spLog) + ExtractFileName(LogToTextFileName);
+    finally
+      AppendToTextFileSafe.UnLock;
+    end;
+  end;
+  AppendToTextFile(Msg, LogToTextFileName);
+end;
+
+
+{ ************ TSynDate / TSynDateTime / TSynSystemTime High-Level objects }
+
+var
+  // GlobalTime[LocalTime] thread-safe cache
+  GlobalTime: array[boolean] of packed record
+    safe: TLightLock; // better than RCU
+    time: TSystemTime;
+    clock: cardinal;  // avoid slower API call with 8-16ms loss of precision
+    _pad: array[1 .. 64 - SizeOf(TLightLock) - SizeOf(TSystemTime) - 4] of byte;
+  end;
+
+procedure FromGlobalTime(out NewTime: TSynSystemTime; LocalTime: boolean;
+  tix64: Int64);
+var
+  tix: cardinal;
+  newtimesys: TSystemTime absolute NewTime;
+begin
+  if tix64 = 0 then
+    tix64 := GetTickCount64;
+  tix := tix64 shr 4;
+  with GlobalTime[LocalTime] do
+    if clock <> tix then // recompute every 16 ms
+    begin
+      clock := tix;
+      NewTime.Clear;
+      if LocalTime then
+        GetLocalTime(newtimesys)
+      else
+        GetSystemTime(newtimesys);
+      {$ifdef OSPOSIX}
+      // two TSystemTime fields are inverted in FPC datih.inc :(
+      tix := newtimesys.DayOfWeek;
+      NewTime.Day := newtimesys.Day;
+      NewTime.DayOfWeek := tix;
+      {$endif OSPOSIX}
+      safe.Lock;
+      time := newtimesys;
+      safe.UnLock;
+    end
+    else
+    begin
+      safe.Lock;
+      newtimesys := time;
+      safe.UnLock;
+    end;
+end;
+
+
+{ TSynDate }
+
+procedure TSynDate.Clear;
+begin
+  PInt64(@self)^ := 0;
+end;
+
+procedure TSynDate.SetMax;
+begin
+  PInt64(@self)^ := $001F0000000C270F; // 9999 + 12 shl 16 + 31 shl 48
+end;
+
+function TSynDate.IsZero: boolean;
+begin
+  result := PInt64(@self)^ = 0;
+end;
+
+function TSynDate.ParseFromText(var P: PUtf8Char): boolean;
+var
+  L: PtrInt;
+  Y, M, D: cardinal;
+begin
+  result := false;
+  if P = nil then
+    exit;
+  while P^ in [#9, ' '] do
+    inc(P);
+  L := 0;
+  while P[L] in ['0'..'9', '-', '/'] do
+    inc(L);
+  if not Iso8601ToDatePUtf8Char(P, L, Y, M, D) then
+    exit;
+  Year := Y;
+  Month := M;
+  DayOfWeek := 0;
+  Day := D;
+  inc(P, L); // move P^ just after the date
+  result := true;
+end;
+
+procedure TSynDate.FromNow(localtime: boolean);
+var
+  dt: TSynSystemTime;
+begin
+  FromGlobalTime(dt, localtime);
+  self := PSynDate(@dt)^; // 4 first fields of TSynSystemTime do match
+end;
+
+procedure TSynDate.FromDate(date: TDate);
+var
+  dt: TSynSystemTime;
+begin
+  dt.FromDate(date); // faster than RTL DecodeDate()
+  self := PSynDate(@dt)^;
+end;
+
+function TSynDate.IsEqual(const another: TSynDate): boolean;
+begin
+  result := (PCardinal(@Year)^ = PCardinal(@TSynDate(another).Year)^) and
+            (Day = TSynDate(another).Day);
+end;
+
+function TSynDate.Compare(const another: TSynDate): integer;
+begin
+  result := Year - TSynDate(another).Year;
+  if result = 0 then
+  begin
+    result := Month - TSynDate(another).Month;
+    if result = 0 then
+      result := Day - TSynDate(another).Day;
+  end;
+end;
+
+procedure TSynDate.ComputeDayOfWeek;
+var
+  d: TDateTime;
+  i: PtrInt;
+begin
+  if not mormot.core.datetime.TryEncodeDate(Year, Month, Day, d) then
+  begin
+    DayOfWeek := 0;
+    exit;
+  end;
+  i := ((trunc(d) - 1) mod 7) + 1; // sunday is day 1
+  if i <= 0 then
+    DayOfWeek := i + 7
+  else
+    DayOfWeek := i;
+end;
+
+function TSynDate.ToDate: TDate;
+begin
+  if not mormot.core.datetime.TryEncodeDate(Year, Month, Day, PDateTime(@result)^) then
+    result := 0;
+end;
+
+function TSynDate.ToText(Expanded: boolean): RawUtf8;
+begin
+  if PInt64(@self)^ = 0 then
+    result := ''
+  else
+    result := DateToIso8601(Year, Month, Day, Expanded);
+end;
+
+
+function IsLeapYear(Year: cardinal): boolean;
+var
+  d100: TDiv100Rec;
+begin
+  if Year and 3 = 0 then
+  begin
+    Div100(Year, d100{%H-});
+    result := ((d100.M <> 0) or // (Year mod 100 > 0)
+               (Year - ((d100.D shr 2) * 400) = 0)); // (Year mod 400 = 0))
+  end
+  else
+    result := false;
+end;
+
+function DaysInMonth(Year, Month: cardinal): cardinal;
+begin
+  result := MonthDays[IsLeapYear(Year)][Month];
+end;
+
+function DaysInMonth(Date: TDateTime): cardinal;
+var
+  dt: TSynSystemTime;
+begin
+  dt.FromDate(Date); // faster than RTL DecodeDate()
+  result := dt.DaysInMonth;
+end;
+
+
+{ TSynSystemTime }
+
+function TSynSystemTime.DaysInMonth: cardinal;
+begin
+  result := MonthDays[IsLeapYear(Year)][Month];
+end;
+
+function TryEncodeDayOfWeekInMonth(
+  AYear, AMonth, ANthDayOfWeek, ADayOfWeek: integer;
+  out AValue: TDateTime): boolean;
+var
+  LStartOfMonth, LDay: integer;
+begin
+  // adapted from DateUtils
+  result := mormot.core.datetime.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 := mormot.core.datetime.TryEncodeDate(AYear, AMonth, LDay, AValue);
+end;
+
+function TSynSystemTime.EncodeForTimeChange(const aYear: word): TDateTime;
+var
+  dow, d: word;
+begin
+  if DayOfWeek = 0 then
+    dow := 7 // Delphi/FPC Sunday = 7
+  else
+    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
+    // Occurrence 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: TSynSystemTime): boolean;
+begin
+  result := (PInt64Array(@self)[0] = PInt64Array(@another)[0]) and
+            (PInt64Array(@self)[1] = PInt64Array(@another)[1]);
+end;
+
+function TSynSystemTime.IsDateEqual(const date: TSynDate): boolean;
+begin
+  result := (PCardinal(@Year)^ = PCardinal(@TSynDate(date).Year)^) and // +Month
+            (Day = TSynDate(date).Day);
+end;
+
+procedure TSynSystemTime.FromNowUtc;
+begin
+  FromGlobalTime(self, {local=}false);
+end;
+
+procedure TSynSystemTime.FromNowLocal;
+begin
+  FromGlobalTime(self, {local=}true);
+end;
+
+procedure TSynSystemTime.FromNow(localtime: boolean);
+begin
+  FromGlobalTime(self, localtime);
+end;
+
+procedure TSynSystemTime.FromDateTime(const dt: TDateTime);
+begin
+  FromDate(dt);
+  FromTime(dt);
+end;
+
+procedure TSynSystemTime.FromUnixTime(ut: TUnixTime);
+begin
+  FromDateTime(ut / SecsPerDay + UnixDateDelta); // via a temp TDateTime
+end;
+
+procedure TSynSystemTime.FromUnixMsTime(ut: TUnixMsTime);
+begin
+  FromDateTime(ut / MSecsPerDay + UnixDateDelta); // via a temp TDateTime
+end;
+
+procedure TSynSystemTime.FromDate(const dt: TDateTime);
+var
+  t, t2, t3: PtrUInt;
+begin
+  t := Trunc(dt);
+  t := (t + 693900) * 4 - 1;
+  if PtrInt(t) >= 0 then
+  begin
+    t3 := t div 146097;
+    t2 := (t - t3 * 146097) and not 3;
+    t := PtrUInt(t2 + 3) div 1461; // PtrUInt() needed for FPC i386
+    Year := t3 * 100 + t;
+    t2 := ((t2 + 7 - t * 1461) shr 2) * 5;
+    t3 := PtrUInt(t2 - 3) div 153;
+    Day := PtrUInt(t2 + 2 - t3 * 153) div 5;
+    if t3 < 10 then
+      inc(t3, 3)
+    else
+    begin
+      dec(t3, 9);
+      inc(Year);
+    end;
+    Month := t3;
+    DayOfWeek := 0; // not set by default
+  end
+  else
+    PInt64(@Year)^ := 0;
+end;
+
+procedure TSynSystemTime.FromTime(const dt: TDateTime);
+begin
+  FromMS(QWord(round(abs(dt) * MSecsPerDay)) mod MSecsPerDay);
+end;
+
+procedure TSynSystemTime.FromMS(ms: PtrUInt);
+var
+  t: PtrUInt;
+begin
+  t := ms div 3600000;
+  Hour := t;
+  dec(ms, t * 3600000);
+  t := ms div 60000;
+  Minute := t;
+  dec(ms, t * 60000);
+  t := ms div 1000;
+  Second := t;
+  dec(ms, t * 1000);
+  MilliSecond := ms;
+end;
+
+procedure TSynSystemTime.FromSec(s: PtrUInt);
+var
+  t: PtrUInt;
+begin
+  t := s div 3600;
+  Hour := t;
+  dec(s, t * 3600);
+  t := s div 60;
+  Minute := t;
+  dec(s, t * 60);
+  Second := s;
+  MilliSecond := 0;
+end;
+
+function TSynSystemTime.FromText(const iso: RawUtf8): boolean;
+var
+  t: TTimeLogBits;
+begin
+  t.From(iso);
+  if t.Value = 0 then
+    result := false
+  else
+  begin
+    t.Expand(self); // TTimeLogBits is faster than FromDateTime()
+    result := true;
+  end;
+end;
+
+function TSynSystemTime.FromHttpDateBuffer(
+  P: PUtf8Char; tolocaltime: boolean): boolean;
+var
+  pnt: byte;
+  hasday: boolean;
+  S: PUtf8Char;
+  zone: integer;
+  v, H, MI, SS, MS: cardinal;
+  dt, t: TDateTime;
+begin
+  // Sun, 06 Nov 1994 08:49:37 GMT    ; RFC 822, updated by RFC 1123
+  // Sunday, 06-Nov-94 08:49:37 GMT   ; RFC 850, obsoleted by RFC 1036
+  // Sun Nov  6 08:49:37 1994         ; ANSI C's asctime() Format
+  Clear;
+  hasday := false;
+  zone := maxInt; // invalid
+  result := false;
+  if P = nil then
+    exit;
+  repeat
+    P := GotoNextNotSpace(P);
+    case P^ of
+      'A'..'Z',
+      'a'..'z':
+        if (not hasday) or
+           (not ParseMonth(P, Month)) then
+        begin
+          hasday := true; // first alphabetic word is always the week day text
+          P := GotoNextSpace(P); // also ignore trailing '-'
+        end;
+      '0'..'9':
+        begin
+          // e.g. '1994' '08:49:37 GMT' or '6'
+          pnt := 0;
+          S := P;
+          repeat
+            inc(P);
+            case P^ of
+              '0'..'9':
+                ;
+              ':':
+                begin
+                  inc(pnt);
+                  if pnt = 0 then
+                    exit;
+                end;
+              '.':
+                if pnt < 2 then
+                  break;
+            else
+              break;
+            end;
+          until false;
+          case pnt of
+            0:
+              // e.g. '6', '94' or '2014'
+              begin
+                v := GetCardinal(S);
+                if v <> 0 then
+                begin
+                  if (v < 32) and
+                     (Day = 0) then
+                    Day := v
+                  else if (Year = 0) and
+                          (v <= 9999) and
+                          ((v > 12) or
+                           (Month > 0)) then
+                  begin
+                    if v < 32 then
+                      inc(v, 2000)
+                    else if v < 1000 then
+                      inc(v, 1900);
+                    Year := v;
+                  end;
+                end;
+              end;
+            2:
+              // e.g. '08:49:37 GMT'
+              if Iso8601ToTimePUtf8Char(S, P - S, H, MI, SS, MS) then
+              begin
+                Hour := H;
+                Minute := MI;
+                Second := SS;
+                MilliSecond := MS;
+                zone := 0; // GMT by default
+                ParseTimeZone(P, zone);
+              end;
+          end;
+          if P^ = '-' then
+            inc(P); // e.g. '06-Nov-94'
+        end;
+    else
+      P := GotoNextSpace(P);
+    end;
+  until P^ in [#0, #10, #13]; // end of string or end of line (e.g. HTTP header)
+  if (Year = 0) or
+     (zone = maxInt) or
+     (Month = 0) then
+    exit;
+  if Day = 0 then
+    Day := 1 // assume first of the month if none supplied
+  else
+  begin
+    v := DaysInMonth;
+    if Day > v then
+      Day := v; // assume last of the month if too big supplied
+  end;
+  if tolocaltime or
+     (zone <> 0) then
+  begin
+    // need to apply some time zone shift
+    if tolocaltime then
+      dec(zone, TimeZoneLocalBias);
+    dt := ToDateTime - zone div MinsPerDay;
+    v := abs(zone mod MinsPerDay);
+    t := EncodeTime(v div 60, v mod 60, 0, 0);
+    if zone < 0 then
+      dt := dt + t
+    else
+      dt := dt - t;
+    FromDateTime(dt); // local TDateTime to compute time shift
+  end;
+  result := true;
+end;
+
+function TSynSystemTime.FromHttpDate(const httpdate: RawUtf8;
+  tolocaltime: boolean): boolean;
+begin
+  result := (length(httpdate) >= 12) and
+            FromHttpDateBuffer(pointer(httpdate), tolocaltime);
+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.AddIsoDate(WR: TTextWriter);
+var
+  p: PUtf8Char;
+begin
+  if WR.BEnd - WR.B <= 24 then
+    WR.FlushToStream;
+  p := WR.B + 1;
+  inc(WR.B, DateToIso8601PChar(p, {expanded=}true, Year, Month, Day) - p);
+end;
+
+procedure TSynSystemTime.AddIsoDateTime(WR: TTextWriter;
+  WithMS: boolean; FirstTimeChar: AnsiChar; const TZD: RawUtf8);
+var
+  p: PUtf8Char;
+begin
+  if WR.BEnd - WR.B <= 24 then
+    WR.FlushToStream;
+  p := WR.B + 1;
+  inc(WR.B, TimeToIso8601PChar(DateToIso8601PChar(p, true, Year, Month, Day),
+    true, Hour, Minute, Second, MilliSecond, FirstTimeChar, WithMS) - p);
+  if TZD <> '' then
+    WR.AddString(TZD);
+end;
+
+procedure TSynSystemTime.AddLogTime(WR: TTextWriter);
+var
+  d100: TDiv100Rec;
+  p: PUtf8Char;
+  {$ifdef CPUX86NOTPIC}
+  tab: TWordArray absolute TwoDigitLookupW;
+  {$else}
+  tab: PWordArray;
+  {$endif CPUX86NOTPIC}
+begin
+  if WR.BEnd - WR.B <= 18 then
+    WR.FlushToStream;
+  p := WR.B + 1;
+  {$ifndef CPUX86NOTPIC}
+  tab := @TwoDigitLookupW;
+  {$endif CPUX86NOTPIC}
+  Div100(Year, d100{%H-});
+  PWord(p)^     := tab[d100.D];
+  PWord(p + 2)^ := tab[d100.M];
+  PWord(p + 4)^ := tab[PtrUInt(Month)];
+  PWord(p + 6)^ := tab[PtrUInt(Day)];
+  p[8] := ' ';
+  PWord(p + 9)^  := tab[PtrUInt(Hour)];
+  PWord(p + 11)^ := tab[PtrUInt(Minute)];
+  PWord(p + 13)^ := tab[PtrUInt(Second)];
+  PWord(p + 15)^ := tab[PtrUInt(Millisecond) shr 4];
+  inc(WR.B, 17);
+end;
+
+procedure TSynSystemTime.AddNcsaText(WR: TTextWriter; const TZD: RawUtf8);
+begin
+  if WR.BEnd - WR.B <= 21 then
+    WR.FlushToStream;
+  inc(WR.B, ToNcsaText(WR.B + 1));
+  if TZD <> '' then
+    WR.AddString(TZD);
+end;
+
+procedure TSynSystemTime.AddHttpDate(WR: TTextWriter; const TZD: RawUtf8);
+var
+  tmp: shortstring;
+begin
+  ToHttpDateShort(tmp, TZD);
+  WR.AddShort(tmp);
+end;
+
+function TSynSystemTime.ToNcsaText(P: PUtf8Char): PtrInt;
+var
+  y, d100: PtrUInt;
+  {$ifdef CPUX86NOTPIC}
+  tab: TWordArray absolute TwoDigitLookupW;
+  {$else}
+  tab: PWordArray;
+  {$endif CPUX86NOTPIC}
+begin
+  {$ifndef CPUX86NOTPIC}
+  tab := @TwoDigitLookupW;
+  {$endif CPUX86NOTPIC}
+  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.ToNcsaShort(var text: shortstring; const tz: RawUtf8);
+begin
+  text[0] := AnsiChar(ToNcsaText(@text[1]));
+  AppendShortAnsi7String(tz, text);
+end;
+
+procedure TSynSystemTime.ToHttpDate(out text: RawUtf8; const tz, prefix: RawUtf8);
+var
+  tmp: shortstring;
+begin
+  ToHttpDateShort(tmp, tz, prefix);
+  FastSetString(text, @tmp[1], ord(tmp[0]));
+end;
+
+procedure TSynSystemTime.ToHttpDateShort(
+  var text: shortstring; const tz, prefix: RawUtf8);
+begin
+  if DayOfWeek = 0 then
+    PSynDate(@self)^.ComputeDayOfWeek; // first 4 fields do match
+  FormatShort('%%, % % % %:%:% %', [
+    prefix,
+    HTML_WEEK_DAYS[DayOfWeek],
+    UInt2DigitsToShortFast(Day),
+    HTML_MONTH_NAMES[Month],
+    UInt4DigitsToShort(Year),
+    UInt2DigitsToShortFast(Hour),
+    UInt2DigitsToShortFast(Minute),
+    UInt2DigitsToShortFast(Second),
+    tz], text);
+end;
+
+procedure TSynSystemTime.ToIsoDateTime(out text: RawUtf8; FirstTimeChar: AnsiChar);
+var
+  tmp: shortstring;
+begin
+  ToIsoDateTimeShort(tmp, FirstTimeChar);
+  ShortStringToAnsi7String(tmp, text);
+end;
+
+procedure TSynSystemTime.ToIsoDateTimeShort(var text: shortstring;
+  FirstTimeChar: AnsiChar);
+begin
+  FormatShort('%-%-%%%:%:%', [
+    UInt4DigitsToShort(Year),
+    UInt2DigitsToShortFast(Month),
+    UInt2DigitsToShortFast(Day),
+    FirstTimeChar,
+    UInt2DigitsToShortFast(Hour),
+    UInt2DigitsToShortFast(Minute),
+    UInt2DigitsToShortFast(Second)], text);
+end;
+
+procedure TSynSystemTime.ToIsoDate(out text: RawUtf8);
+begin
+  FormatUtf8('%-%-%', [
+    UInt4DigitsToShort(Year),
+    UInt2DigitsToShortFast(Month),
+    UInt2DigitsToShortFast(Day)], text);
+end;
+
+procedure TSynSystemTime.ToIsoTime(out text: RawUtf8; FirstTimeChar: RawUtf8);
+begin
+  FormatUtf8('%%:%:%', [
+    FirstTimeChar,
+    UInt2DigitsToShortFast(Hour),
+    UInt2DigitsToShortFast(Minute),
+    UInt2DigitsToShortFast(Second)], text);
+end;
+
+function TSynSystemTime.ToDateTime: TDateTime;
+var
+  time: TDateTime;
+begin
+  if mormot.core.datetime.TryEncodeDate(Year, Month, Day, result) then
+    if TryEncodeTime(Hour, Minute, Second, MilliSecond, time) then
+      result := result + time
+    else
+      result := 0
+  else
+    result := 0;
+end;
+
+function TSynSystemTime.ToUnixTime: TUnixTime;
+var
+  dt: TDateTime;
+begin
+  dt := ToDateTime;
+  if dt = 0 then
+    result := 0
+  else
+    result := DateTimeToUnixTime(dt);
+end;
+
+procedure TSynSystemTime.ToSynDate(out date: TSynDate);
+begin
+  date := PSynDate(@self)^; // first 4 fields do match
+end;
+
+procedure TSynSystemTime.ToFileShort(out result: TShort16);
+var
+  {$ifdef CPUX86NOTPIC}
+  tab: TWordArray absolute TwoDigitLookupW;
+  {$else}
+  tab: PWordArray;
+  {$endif CPUX86NOTPIC}
+begin
+  if IsZero then
+  begin
+    PWord(@result[0])^ := 1 + ord('0') shl 8;
+    exit;
+  end;
+  if Year > 1999 then
+    if Year < 2100 then
+      dec(Year, 2000)
+    else
+      Year := 99
+  else
+    Year := 0;
+  {$ifndef CPUX86NOTPIC}
+  tab := @TwoDigitLookupW;
+  {$endif CPUX86NOTPIC}
+  result[0] := #12;
+  PWord(@result[1])^  := tab[Year];
+  PWord(@result[3])^  := tab[Month];
+  PWord(@result[5])^  := tab[Day];
+  PWord(@result[7])^  := tab[Hour];
+  PWord(@result[9])^  := tab[Minute];
+  PWord(@result[11])^ := tab[Second];
+end;
+
+procedure TSynSystemTime.ComputeDayOfWeek;
+begin
+  PSynDate(@self)^.ComputeDayOfWeek; // first 4 fields do match
+end;
+
+procedure TSynSystemTime.IncrementMS(ms: integer);
+begin
+  inc(MilliSecond, ms);
+  Normalize;
+end;
+
+procedure TSynSystemTime.Normalize;
+
+  procedure NormalizeMonth;
+  var
+    thismonth: cardinal;
+  begin
+    repeat
+      thismonth := DaysInMonth;
+      if Day <= thismonth then
+        break;
+      dec(Day, thismonth);
+      inc(Month);
+      if Month > 12 then
+      begin
+        dec(Month, 12);
+        inc(Year);
+      end;
+    until false;
+  end;
+
+begin
+  DayOfWeek := 0;
+  while MilliSecond >= 1000 do
+  begin
+    dec(MilliSecond, 1000);
+    inc(Second);
+  end;
+  while Second >= 60 do
+  begin
+    dec(Second, 60);
+    inc(Minute);
+  end;
+  while Minute >= 60 do
+  begin
+    dec(Minute, 60);
+    inc(Hour);
+  end;
+  while Hour >= 24 do
+  begin
+    dec(Hour, 24);
+    inc(Day);
+  end;
+  NormalizeMonth;
+  while Month > 12 do
+  begin
+    dec(Month, 12);
+    inc(Year);
+    NormalizeMonth;
+  end;
+end;
+
+function TSynSystemTime.ChangeOperatingSystemTime: boolean;
+begin
+  {$ifdef OSPOSIX}
+  result := SetSystemTime(ToUnixTime); // fpsettimeofday
+  {$else}
+  result := SetSystemTime(PSystemTime(@self)^); // set privilege + API + notify
+  {$endif OSPOSIX}
+  FillCharFast(GlobalTime, SizeOf(GlobalTime), 0); // reset cache
+end;
+
+
+function TryEncodeDate(Year, Month, Day: cardinal;
+  out Date: TDateTime): boolean;
+var
+  d100: TDiv100Rec;
+begin 
+  result := false;
+  if (Month = 0) or
+     (Month > 12) or
+     (Day = 0) or
+     (Year = 0) or
+     (Year > 10000) or
+     (Day > MonthDays[IsLeapYear(Year)][Month]) then
+    exit;
+  if Month > 2 then
+    dec(Month, 3)
+  else if Month > 0 then
+  begin
+    inc(Month, 9);
+    dec(Year);
+  end;
+  Div100(Year, d100{%H-});
+  Date := (146097 * d100.D) shr 2 + (1461 * d100.M) shr 2 +
+          (153 * Month + 2) div 5 + Day;
+  Date := Date - 693900; // separated to avoid sign issue
+  result := true;
+end;
+
+function NowToString(Expanded: boolean; FirstTimeChar: AnsiChar;
+  UtcDate: boolean): RawUtf8;
+var
+  I: TTimeLogBits;
+begin
+  if UtcDate then
+    I.FromUtcTime
+  else
+    I.FromNow;
+  result := I.Text(Expanded, FirstTimeChar);
+end;
+
+function NowUtcToString(Expanded: boolean; FirstTimeChar: AnsiChar): RawUtf8;
+begin
+  result := NowToString(Expanded, FirstTimeChar, {UTC=}true);
+end;
+
+function DateTimeMSToString(DateTime: TDateTime; Expanded: boolean;
+  FirstTimeChar: AnsiChar; const TZD: RawUtf8): RawUtf8;
+var
+  T: TSynSystemTime;
+begin
+  //  'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format
+  if DateTime = 0 then
+    result := ''
+  else
+  begin
+    T.FromDateTime(DateTime);
+    result := DateTimeMSToString(T.Hour, T.Minute, T.Second, T.MilliSecond,
+      T.Year, T.Month, T.Day, Expanded, FirstTimeChar, TZD);
+  end;
+end;
+
+function DateTimeMSToString(HH, MM, SS, MS, Y, M, D: cardinal; Expanded: boolean;
+  FirstTimeChar: AnsiChar; const TZD: RawUtf8): RawUtf8;
+begin
+  //  'YYYY-MM-DD hh:mm:ss.sssZ' or 'YYYYMMDD hhmmss.sssZ' format
+  FormatUtf8(DTMS_FMT[Expanded], [
+    UInt4DigitsToShort(Y),
+    UInt2DigitsToShortFast(M),
+    UInt2DigitsToShortFast(D),
+    FirstTimeChar,
+    UInt2DigitsToShortFast(HH),
+    UInt2DigitsToShortFast(MM),
+    UInt2DigitsToShortFast(SS),
+    UInt3DigitsToShort(MS),
+    TZD], result);
+end;
+
+function DateTimeToHttpDate(dt: TDateTime; const tz: RawUtf8): RawUtf8;
+var
+  T: TSynSystemTime;
+begin
+  if dt = 0 then
+    result := ''
+  else
+  begin
+    T.FromDateTime(dt);
+    T.ToHttpDate(result, tz);
+  end;
+end;
+
+function HttpDateToDateTime(const httpdate: RawUtf8; var datetime: TDateTime;
+  tolocaltime: boolean): boolean; overload;
+var
+  T: TSynSystemTime;
+begin
+  PInt64(@datetime)^ := 0;
+  result := (httpdate <> '') and
+            T.FromHttpDate(httpdate, tolocaltime);
+  if result then
+    datetime := T.ToDateTime;
+end;
+
+function HttpDateToDateTime(const httpdate: RawUtf8;
+  tolocaltime: boolean): TDateTime;
+begin
+  if not HttpDateToDateTime(httpdate, result, tolocaltime) then
+    result := 0;
+end;
+
+function HttpDateToDateTimeBuffer(httpdate: PUtf8Char; var datetime: TDateTime;
+  tolocaltime: boolean): boolean;
+var
+  T: TSynSystemTime;
+begin
+  PInt64(@datetime)^ := 0;
+  result := (httpdate <> '') and
+            T.FromHttpDateBuffer(httpdate, tolocaltime);
+  if result then
+    datetime := T.ToDateTime;
+end;
+
+function HttpDateToUnixTime(const httpdate: RawUtf8): TUnixTime;
+var
+  dt: TDateTime;
+begin
+  result := 0;
+  if HttpDateToDateTime(httpdate, dt, {tolocaltime=}false) then
+    result := DateTimeToUnixTime(dt);
+end;
+
+function HttpDateToUnixTimeBuffer(httpdate: PUtf8Char): TUnixTime;
+var
+  dt: TDateTime;
+begin
+  result := 0;
+  if HttpDateToDateTimeBuffer(httpdate, dt, {tolocaltime=}false) then
+    result := DateTimeToUnixTime(dt);
+end;
+
+var
+  _HttpDateNowUtc: record
+    Safe: TLightLock;
+    Tix: cardinal; // = GetTickCount64 div 1024 (every second)
+    Value: THttpDateNowUtc;
+  end;
+
+function HttpDateNowUtc: THttpDateNowUtc;
+var
+  c: cardinal;
+  T: TSynSystemTime;
+  now: shortstring; // use a temp variable for _HttpDateNowUtc atomic set
+begin
+  c := GetTickCount64 shr 10;
+  with _HttpDateNowUtc do
+  begin
+    Safe.Lock;
+    if c <> Tix then
+    begin
+      Tix := c; // let this single thread update the Value
+      Safe.UnLock;
+      T.FromNowUtc;
+      T.ToHttpDateShort(now, 'GMT'#13#10, 'Date: ');
+      Safe.Lock;
+      Value := now;
+    end;
+    MoveFast(Value[0], result[0], ord(Value[0]) + 1);
+    Safe.UnLock;
+  end;
+end;
+
+function UnixMSTimeUtcToHttpDate(UnixMSTime: TUnixMSTime): TShort31;
+var
+  T: TSynSystemTime;
+begin
+  if UnixMSTime <= 0 then
+    result[0] := #0
+  else
+  begin
+    T.FromUnixMsTime(UnixMSTime);
+    T.ToHttpDateShort(result);
+  end;
+end;
+
+function TimeToString: RawUtf8;
+var
+  I: TTimeLogBits;
+begin
+  I.FromNow;
+  I.Value := I.Value and (1 shl (6 + 6 + 5) - 1); // keep only time
+  result := I.Text(true, ' ');
+end;
+
+function DateTimeToFileShort(const DateTime: TDateTime): TShort16;
+begin
+  DateTimeToFileShort(DateTime, result);
+end;
+
+procedure DateTimeToFileShort(const DateTime: TDateTime; out result: TShort16);
+var
+  T: TSynSystemTime;
+begin
+  // use 'YYMMDDHHMMSS' format
+  if DateTime <= 0 then
+    PWord(@result[0])^ := 1 + ord('0') shl 8
+  else
+  begin
+    T.FromDate(DateTime);
+    T.FromTime(DateTime);
+    T.ToFileShort(result);
+  end;
+end;
+
+function NowToFileShort(localtime: boolean): TShort16;
+var
+  T: TSynSystemTime;
+begin
+  T.FromNow(localtime);
+  T.ToFileShort(result);
+end;
+
+
+{ ************ TUnixTime / TUnixMSTime POSIX Epoch Compatible 64-bit date/time }
+
+function UnixTimeMinimalUtc: cardinal;
+begin
+  result := UnixTimeUtc - UNIXTIME_MINIMAL;
+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;
+
+function UnixTimeToString(const UnixTime: TUnixTime; Expanded: boolean;
+  FirstTimeChar: AnsiChar): RawUtf8;
+begin
+  // inlined UnixTimeToDateTime() + DateTimeToIso8601()
+  DateTimeToIso8601Var(UnixTime / SecsPerDay + UnixDateDelta,
+    Expanded, false, FirstTimeChar, #0, result);
+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 UnixTime < SecsPerDay then
+    result := TimeToIso8601(UnixTime / SecsPerDay, true, FirstTimeChar)
+  else
+    result := DaysToIso8601(UnixTime div SecsPerDay, true);
+end;
+
+function UnixMSTimeToDateTime(const UnixMSTime: TUnixMSTime): TDateTime;
+begin
+  result := UnixMSTime / MSecsPerDay + UnixDateDelta;
+end;
+
+function UnixMSTimePeriodToString(const UnixMSTime: TUnixMSTime;
+  FirstTimeChar: AnsiChar): RawUtf8;
+begin
+  if UnixMSTime < MSecsPerDay then
+    result := TimeToIso8601(UnixMSTime / MSecsPerDay, true,
+                            FirstTimeChar, UnixMSTime < 1000)
+  else
+    result := DaysToIso8601(UnixMSTime div MSecsPerDay, true);
+end;
+
+function DateTimeToUnixMSTime(const AValue: TDateTime): TUnixMSTime;
+begin
+  if AValue = 0 then
+    result := 0
+  else
+    result := Round((AValue - UnixDateDelta) * MSecsPerDay);
+end;
+
+function UnixMSTimeToString(const UnixMSTime: TUnixMSTime; Expanded: boolean;
+  FirstTimeChar: AnsiChar; const TZD: RawUtf8): RawUtf8;
+begin
+  // inlined UnixMSTimeToDateTime()
+  if UnixMSTime <= 0 then
+    result := ''
+  else
+    result := DateTimeMSToString(UnixMSTime / MSecsPerDay + UnixDateDelta,
+                                 Expanded, FirstTimeChar, TZD);
+end;
+
+
+{ ************ TTimeLog efficient 64-bit custom date/time encoding }
+
+// bits: S=0..5 M=6..11 H=12..16 D=17..21 M=22..25 Y=26..40
+// size: S=6 M=6  H=5  D=5  M=4  Y=12
+// i.e. S<64 M<64 H<32 D<32 M<16 Y<=9999: power of 2 -> use fast shl/shr
+
+{ TTimeLogBits }
+
+procedure TTimeLogBits.From(Y, M, D, HH, MM, SS: cardinal);
+begin
+  inc(HH, D shl 5 + M shl 10 + Y shl 14 - (1 shl 5 + 1 shl 10));
+  Value := SS + MM shl 6 + Int64(HH) shl 12;
+end;
+
+procedure TTimeLogBits.From(P: PUtf8Char; L: integer);
+begin
+  Value := Iso8601ToTimeLogPUtf8Char(P, L);
+end;
+
+procedure TTimeLogBits.Expand(out Date: TSynSystemTime);
+var
+  V: PtrUInt;
+begin
+  V := PPtrUint(@Value)^;
+  {$ifdef CPU32}
+  Date.Year := Value shr (6 + 6 + 5 + 5 + 4);
+  {$else}
+  Date.Year := V shr (6 + 6 + 5 + 5 + 4);
+  {$endif CPU32}
+  Date.Month := 1 + (V shr (6 + 6 + 5 + 5)) and 15;
+  Date.DayOfWeek := 0;
+  Date.Day := 1 + (V shr (6 + 6 + 5)) and 31;
+  Date.Hour := (V shr (6 + 6)) and 31;
+  Date.Minute := (V shr 6) and 63;
+  Date.Second := V and 63;
+  Date.MilliSecond := 0;
+end;
+
+procedure TTimeLogBits.From(const S: RawUtf8);
+begin
+  Value := Iso8601ToTimeLogPUtf8Char(pointer(S), length(S));
+end;
+
+procedure TTimeLogBits.FromFileDate(const FileDate: TFileAge);
+begin
+  {$ifdef OSWINDOWS} // already local time
+  with PLongRec(@FileDate)^ do
+    From(Hi shr 9 + 1980, Hi shr 5 and 15, Hi and 31, Lo shr 11,
+      Lo shr 5 and 63, Lo and 31 shl 1);
+  {$else}
+  From(mormot.core.os.FileDateToDateTime(FileDate)); // convert UTC to local
+  {$endif OSWINDOWS}
+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 oldest Delphi
+  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;
+
+procedure TTimeLogBits.FromUtcTime;
+var
+  now: TSynSystemTime;
+begin
+  FromGlobalTime(now, {local=}false);
+  From(@now);
+end;
+
+procedure TTimeLogBits.FromNow;
+var
+  now: TSynSystemTime;
+begin
+  FromGlobalTime(now, {local=}true);
+  From(@now);
+end;
+
+function TTimeLogBits.ToTime: TTime;
+var
+  lo: PtrUInt;
+begin
+  {$ifdef CPU64}
+  lo := Value;
+  {$else}
+  lo := PCardinal(@Value)^;
+  {$endif CPU64}
+  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 TTimeLogBits.ToDate: TDate;
+var
+  Y, lo: PtrUInt;
+begin
+  {$ifdef CPU64}
+  lo := Value;
+  Y := lo shr (6 + 6 + 5 + 5 + 4);
+  {$else}
+  Y := Value shr (6 + 6 + 5 + 5 + 4);
+  lo := PCardinal(@Value)^;
+  {$endif CPU64}
+  if (Y = 0) or
+     not TryEncodeDate(Y,
+                       1 + (lo shr (6 + 6 + 5 + 5)) and 15,
+                       1 + (lo shr (6 + 6 + 5)) and 31,
+                       TDateTime(result)) then
+    result := 0;
+end;
+
+function TTimeLogBits.ToDateTime: TDateTime;
+var
+  Y, lo: PtrUInt;
+  Time: TDateTime;
+begin
+  {$ifdef CPU64}
+  lo := Value;
+  Y := lo shr (6 + 6 + 5 + 5 + 4);
+  {$else}
+  Y := Value shr (6 + 6 + 5 + 5 + 4);
+  lo := PCardinal(@Value)^;
+  {$endif CPU64}
+  if (Y = 0) or
+      not TryEncodeDate(Y,
+                        1 + (lo shr (6 + 6 + 5 + 5)) and 15,
+                        1 + (lo shr (6 + 6 + 5)) and 31,
+                        result) then
+    result := 0;
+  if (lo and (1 shl (6 + 6 + 5) - 1) <> 0) and
+     TryEncodeTime((lo shr (6 + 6)) and 31,
+                   (lo shr 6) and 63,
+                   lo and 63,
+                   0,
+                   Time) then
+    result := result + Time;
+end;
+
+function TTimeLogBits.Year: integer;
+begin
+  result := Value shr (6 + 6 + 5 + 5 + 4);
+end;
+
+function TTimeLogBits.Month: integer;
+begin
+  result := 1 + (PCardinal(@Value)^ shr (6 + 6 + 5 + 5)) and 15;
+end;
+
+function TTimeLogBits.Day: integer;
+begin
+  result := 1 + (PCardinal(@Value)^ shr (6 + 6 + 5)) and 31;
+end;
+
+function TTimeLogBits.Hour: integer;
+begin
+  result := (PCardinal(@Value)^ shr (6 + 6)) and 31;
+end;
+
+function TTimeLogBits.Minute: integer;
+begin
+  result := (PCardinal(@Value)^ shr 6) and 63;
+end;
+
+function TTimeLogBits.Second: integer;
+begin
+  result := PCardinal(@Value)^ and 63;
+end;
+
+function TTimeLogBits.ToUnixTime: TUnixTime;
+var
+  dt: TDateTime;
+begin
+  dt := ToDateTime;
+  if dt = 0 then
+    result := 0
+  else
+    result := DateTimeToUnixTime(dt);
+end;
+
+function TTimeLogBits.ToUnixMSTime: TUnixMSTime;
+begin
+  result := ToUnixTime * MSecsPerSec;
+end;
+
+function TTimeLogBits.Text(Dest: PUtf8Char; Expanded: boolean;
+  FirstTimeChar, QuoteChar: AnsiChar): PUtf8Char;
+var
+  lo: PtrUInt;
+begin
+  if QuoteChar <> #0 then
+  begin
+    Dest^ := QuoteChar;
+    inc(Dest);
+  end;
+  if Value <> 0 then
+  begin
+    {$ifdef CPU64}
+    lo := Value;
+    {$else}
+    lo := PCardinal(@Value)^;
+    {$endif CPU64}
+    if lo and (1 shl (6 + 6 + 5) - 1) = 0 then
+      // no Time: just convert date
+      Dest := DateToIso8601PChar(Dest, Expanded,
+        {$ifdef CPU64} lo {$else} Value {$endif} shr (6 + 6 + 5 + 5 + 4),
+        1 + (lo shr (6 + 6 + 5 + 5)) and 15,
+        1 + (lo shr (6 + 6 + 5)) and 31)
+    else
+    {$ifdef CPU64}
+    if lo shr (6 + 6 + 5) = 0 then
+    {$else}
+    if Value shr (6 + 6 + 5) = 0 then
+    {$endif CPU64}
+      // no Date: just convert time
+      Dest := TimeToIso8601PChar(Dest, Expanded,
+        (lo shr (6 + 6)) and 31,
+        (lo shr 6) and 63,
+        lo and 63, 0, FirstTimeChar)
+    else
+    begin
+      // convert time and date
+      Dest := DateToIso8601PChar(Dest, Expanded,
+        {$ifdef CPU64} lo {$else} Value {$endif} shr (6+6+5+5+4),
+        1 + (lo shr (6 + 6 + 5 + 5)) and 15,
+        1 + (lo shr (6 + 6 + 5)) and 31);
+      Dest := TimeToIso8601PChar(Dest, Expanded,
+                (lo shr (6 + 6)) and 31,
+                (lo shr 6) and 63,
+                lo and 63, 0, FirstTimeChar);
+    end;
+  end;
+  if QuoteChar <> #0 then
+  begin
+    Dest^ := QuoteChar;
+    inc(Dest);
+  end;
+  result := Dest;
+end;
+
+function TTimeLogBits.Text(Expanded: boolean; FirstTimeChar: AnsiChar): RawUtf8;
+var
+  tmp: array[0..31] of AnsiChar;
+begin
+  if Value = 0 then
+    result := ''
+  else
+    FastSetString(result, @tmp,
+      Text(@tmp, Expanded, FirstTimeChar) - PUtf8Char(@tmp));
+end;
+
+function TTimeLogBits.FullText(Dest: PUtf8Char; Expanded: boolean;
+  FirstTimeChar, QuotedChar: AnsiChar): PUtf8Char;
+var
+  lo: PtrUInt;
+begin
+  // convert full time and date
+  if QuotedChar <> #0 then
+  begin
+    Dest^ := QuotedChar;
+    inc(Dest);
+  end;
+  lo := {$ifdef CPU64}Value{$else}PCardinal(@Value)^{$endif};
+  Dest := DateToIso8601PChar(Dest, Expanded,
+    {$ifdef CPU64}lo{$else}Value{$endif} shr (6 + 6 + 5 + 5 + 4),
+    1 + (lo shr (6 + 6 + 5 + 5)) and 15,
+    1 + (lo shr (6 + 6 + 5)) and 31);
+  Dest := TimeToIso8601PChar(Dest, Expanded,
+    (lo shr (6 + 6)) and 31,
+    (lo shr 6) and 63,
+    lo and 63, 0, FirstTimeChar);
+  if QuotedChar <> #0 then
+  begin
+    Dest^ := QuotedChar;
+    inc(Dest);
+  end;
+  result := Dest;
+end;
+
+function TTimeLogBits.FullText(Expanded: boolean;
+  FirstTimeChar, QuotedChar: AnsiChar): RawUtf8;
+var
+  tmp: array[0..31] of AnsiChar;
+begin
+  FastSetString(result, @tmp,
+    FullText(tmp{%H-}, Expanded, FirstTimeChar, QuotedChar) - PUtf8Char(@tmp));
+end;
+
+function TTimeLogBits.i18nText: string;
+begin
+  if Assigned(i18nDateText) then
+    result := i18nDateText(Value)
+  else
+    result := {$ifdef UNICODE}Ansi7ToString{$endif}(Text(true, ' '));
+end;
+
+function TimeLogNow: TTimeLog;
+begin
+  PTimeLogBits(@result)^.FromNow;
+end;
+
+function TimeLogNowUtc: TTimeLog;
+begin
+  PTimeLogBits(@result)^.FromUtcTime;
+end;
+
+function 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;
+
+function TimeLogToDateTime(const Timestamp: TTimeLog): TDateTime;
+begin
+  result := PTimeLogBits(@Timestamp)^.ToDateTime;
+end;
+
+function TimeLogToUnixTime(const Timestamp: TTimeLog): TUnixTime;
+begin
+  result := PTimeLogBits(@Timestamp)^.ToUnixTime;
+end;
+
+function Iso8601ToTimeLogPUtf8Char(P: PUtf8Char; L: integer;
+  ContainsNoTime: PBoolean): TTimeLog;
+// bits: S=0..5 M=6..11 H=12..16 D=17..21 M=22..25 Y=26..40
+// i.e. S<64 M<64 H<32 D<32 M<16 Y<9999: power of 2 -> use fast shl/shr
+var
+  V, B: PtrUInt;
+  {$ifdef CPUX86NOTPIC}
+  tab: TNormTableByte absolute ConvertHexToBin;
+  {$else}
+  tab: PByteArray; // faster on PIC/x86_64/ARM
+  {$endif CPUX86NOTPIC}
+begin
+  result := 0;
+  if P = nil then
+    exit;
+  if L = 0 then
+    L := StrLen(P);
+  if L < 4 then
+    exit; // we need 'YYYY' at least
+  if P[0] = 'T' then
+    dec(P, 8)
+  else
+  begin
+    // 'YYYY' -> year decode
+    {$ifndef CPUX86NOTPIC}
+    tab := @ConvertHexToBin;
+    {$endif CPUX86NOTPIC}
+    V := tab[ord(P[0])];
+    if V > 9 then
+      exit;
+    B := tab[ord(P[1])];
+    if B > 9 then
+      exit
+    else
+      V := V * 10 + B;
+    B := tab[ord(P[2])];
+    if B > 9 then
+      exit
+    else
+      V := V * 10 + B;
+    B := tab[ord(P[3])];
+    if B > 9 then
+      exit
+    else
+      V := V * 10 + B;
+    result := Int64(V) shl 26;  // store YYYY
+    if P[4] in ['-', '/'] then
+    begin
+      inc(P);
+      dec(L);
+    end; // allow YYYY-MM-DD
+    if L >= 6 then
+    begin
+      // YYYYMM
+      V := ord(P[4]) * 10 + ord(P[5]) - (48 + 480 + 1); // Month 1..12 -> 0..11
+      if V <= 11 then
+        inc(result, V shl 22)
+      else
+      begin
+        result := 0;
+        exit;
+      end;
+      if P[6] in ['-', '/'] then
+      begin
+        inc(P);
+        dec(L);
+      end; // allow YYYY-MM-DD
+      if L >= 8 then
+      begin
+        // YYYYMMDD
+        V := ord(P[6]) * 10 + ord(P[7]) - (48 + 480 + 1); // Day 1..31 -> 0..30
+        if (V <= 30) and
+           ((L = 8) or
+            (L = 14) or
+            (P[8] in [#0, ' ', 'T'])) then
+          inc(result, V shl 17)
+        else
+        begin
+          result := 0;
+          exit;
+        end;
+      end;
+    end;
+    if L = 14 then
+      dec(P) // no 'T' or ' ' separator for YYYYMMDDhhmmss
+    else if L < 14 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 Iso8601ToTimeLog(const S: RawByteString): TTimeLog;
+begin
+  result := Iso8601ToTimeLogPUtf8Char(pointer(S), length(S));
+end;
+
+
+{ ******************* TTextDateWriter supporting date/time ISO-8601 serialization }
+
+{ TTextDateWriter }
+
+procedure TTextDateWriter.AddTimeLog(Value: PInt64; QuoteChar: AnsiChar);
+begin
+  if BEnd - B <= 31 then
+    FlushToStream;
+  B := PTimeLogBits(Value)^.Text(B + 1, true, 'T', QuoteChar) - 1;
+end;
+
+procedure TTextDateWriter.AddUnixTime(Value: PInt64; QuoteChar: AnsiChar);
+var
+  DT: TDateTime;
+begin
+  // inlined UnixTimeToDateTime()
+  DT := Value^ / SecsPerDay + UnixDateDelta;
+  AddDateTime(@DT, 'T', QuoteChar, {withms=}false, {dateandtime=}true);
+end;
+
+procedure TTextDateWriter.AddUnixMSTime(Value: PInt64; WithMS: boolean;
+  QuoteChar: AnsiChar);
+var
+  DT: TDateTime;
+begin
+  // inlined UnixMSTimeToDateTime()
+  DT := Value^ / MSecsPerDay + UnixDateDelta;
+  AddDateTime(@DT, 'T', QuoteChar, WithMS, {dateandtime=}true);
+end;
+
+procedure TTextDateWriter.AddDateTime(Value: PDateTime; FirstChar: AnsiChar;
+  QuoteChar: AnsiChar; WithMS: boolean; AlwaysDateAndTime: boolean);
+var
+  T: TSynSystemTime;
+begin
+  if (PInt64(Value)^ = 0) and
+     (QuoteChar = #0) then
+    exit;
+  if BEnd - B <= 26 then
+    FlushToStream;
+  inc(B);
+  if QuoteChar <> #0 then
+    B^ := QuoteChar
+  else
+    dec(B);
+  if PInt64(Value)^ <> 0 then
+  begin
+    inc(B);
+    if AlwaysDateAndTime or
+       (trunc(Value^) <> 0) then
+    begin
+      T.FromDate(Value^);
+      B := DateToIso8601PChar(B, true, T.Year, T.Month, T.Day);
+    end;
+    if AlwaysDateAndTime or
+       (frac(Value^) <> 0) then
+    begin
+      T.FromTime(Value^);
+      B := TimeToIso8601PChar(B, true, T.Hour, T.Minute, T.Second,
+        T.MilliSecond, FirstChar, WithMS);
+    end;
+    dec(B);
+  end;
+  if twoDateTimeWithZ in fCustomOptions then
+  begin
+    inc(B);
+    B^ := 'Z';
+  end;
+  if QuoteChar <> #0 then
+  begin
+    inc(B);
+    B^ := QuoteChar;
+  end;
+end;
+
+procedure TTextDateWriter.AddDateTime(const Value: TDateTime; WithMS: boolean);
+begin
+  AddDateTime(@Value, 'T', {quotechar=}#0, WithMS, {always=}false);
+end;
+
+procedure TTextDateWriter.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 TTextDateWriter.AddCurrentIsoDateTime(
+  LocalTime, WithMS: boolean; FirstTimeChar: AnsiChar; const TZD: RawUtf8);
+var
+  time: TSynSystemTime;
+begin
+  time.FromNow(LocalTime);
+  time.AddIsoDateTime(self, WithMS, FirstTimeChar, TZD);
+end;
+
+procedure TTextDateWriter.AddCurrentLogTime(LocalTime: boolean);
+var
+  time: TSynSystemTime;
+begin
+  time.FromNow(LocalTime);
+  time.AddLogTime(self);
+end;
+
+procedure TTextDateWriter.AddCurrentNcsaLogTime(
+  LocalTime: boolean; const TZD: RawUtf8);
+var
+  time: TSynSystemTime;
+begin
+  time.FromNow(LocalTime);
+  time.AddNcsaText(self, TZD);
+end;
+
+procedure TTextDateWriter.AddCurrentHttpTime(LocalTime: boolean;
+  const TZD: RawUtf8);
+var
+  time: TSynSystemTime;
+begin
+  time.FromNow(LocalTime);
+  time.AddHttpDate(self, TZD);
+end;
+
+procedure TTextDateWriter.AddSeconds(MilliSeconds: QWord; Quote: AnsiChar);
+begin
+  if Quote <> #0 then
+    Add(Quote);
+  MilliSeconds := MilliSeconds * 10; // convert a.bcd to a.bcd0 currency/Curr64
+  AddCurr64(@MilliSeconds); // fast output
+  if Quote <> #0 then
+    Add(Quote);
+end;
+
+
+{ ******************* TValuePUtf8Char text value wrapper record }
+
+{ TValuePUtf8Char }
+
+procedure TValuePUtf8Char.ToUtf8(var Value: RawUtf8);
+begin
+  FastSetString(Value, Text, Len);
+end;
+
+function TValuePUtf8Char.ToUtf8: RawUtf8;
+begin
+  FastSetString(result, Text, Len);
+end;
+
+function TValuePUtf8Char.ToString: string;
+begin
+  Utf8DecodeToString(Text, Len, result);
+end;
+
+function TValuePUtf8Char.ToInteger: PtrInt;
+begin
+  result := GetInteger(Text);
+end;
+
+function TValuePUtf8Char.ToCardinal: PtrUInt;
+begin
+  result := GetCardinal(Text);
+end;
+
+function TValuePUtf8Char.ToCardinal(Def: PtrUInt): PtrUInt;
+begin
+  result := GetCardinalDef(Text, Def);
+end;
+
+function TValuePUtf8Char.ToInt64: Int64;
+begin
+  SetInt64(Text, result{%H-});
+end;
+
+function TValuePUtf8Char.ToDouble: double;
+begin
+  result := GetExtended(Text);
+end;
+
+function TValuePUtf8Char.Iso8601ToDateTime: TDateTime;
+begin
+  result := Iso8601ToDateTimePUtf8Char(Text, Len);
+end;
+
+function TValuePUtf8Char.Idem(const Value: RawUtf8): boolean;
+begin
+  result := (length(Value) = Len) and
+            ((Len = 0) or
+             IdemPropNameUSameLenNotNull(pointer(Value), Text, Len));
+end;
+
+function TValuePUtf8Char.ToBoolean: boolean;
+begin
+  result := (Text <> nil) and
+            ((PWord(Text)^ = ord('1')) or
+             (GetTrue(Text) = 1));
+end;
+
+
+procedure InitializeUnit;
+begin
+  // as expected by ParseMonth() to call FindShortStringListExact()
+  assert(PtrUInt(@HTML_MONTH_NAMES[3]) - PtrUInt(@HTML_MONTH_NAMES[1]) = 8);
+  assert(SizeOf(GlobalTime) = 128);
+  // some mormot.core.text wrappers are implemented by this unit
+  _VariantToUtf8DateTimeToIso8601 := DateTimeToIso8601TextVar;
+  _Iso8601ToDateTime := Iso8601ToDateTime;
+end;
+
+procedure FinalizeUnit;
+begin
+end;
+
+initialization
+  InitializeUnit;
+
+finalization
+  FinalizeUnit;
+
+end.
+
diff --git a/lib/dmustache/mormot.core.json.pas b/lib/dmustache/mormot.core.json.pas
new file mode 100644
index 00000000..feeb9714
--- /dev/null
+++ b/lib/dmustache/mormot.core.json.pas
@@ -0,0 +1,11904 @@
+/// Framework Core Low-Level JSON Processing
+// - this unit is a part of the Open Source Synopse mORMot framework 2,
+// licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+unit mormot.core.json;
+
+{
+  *****************************************************************************
+
+   JSON functions shared by all framework units
+    - Low-Level JSON Processing Functions
+    - TJsonWriter class with proper JSON escaping and WriteObject() support
+    - JSON-aware TSynNameValue TSynPersistentStoreJson
+    - JSON-aware TSynDictionary Storage
+    - JSON Unserialization for any kind of Values
+    - JSON Serialization Wrapper Functions
+    - Abstract Classes with Auto-Create-Fields
+
+  *****************************************************************************
+}
+
+interface
+
+{$I mormot.defines.inc}
+
+uses
+  classes,
+  contnrs,
+  sysutils,
+  {$ifdef ISDELPHI}
+  typinfo, // for proper Delphi inlining
+  {$endif ISDELPHI}
+  mormot.core.base,
+  mormot.core.os,
+  mormot.core.unicode,
+  mormot.core.text,
+  mormot.core.datetime,
+  mormot.core.rtti,
+  mormot.core.buffers,
+  mormot.core.data;
+
+
+{ ********** Low-Level JSON Processing Functions }
+
+type
+  /// exception raised by this unit, in relation to raw JSON process
+  EJsonException = class(ESynException);
+
+  /// kind of first character used from JSON_TOKENS[] for efficient JSON parsing
+  TJsonToken = (
+    jtNone,
+    jtDoubleQuote,
+    jtFirstDigit,
+    jtNullFirstChar,
+    jtTrueFirstChar,
+    jtFalseFirstChar,
+    jtObjectStart,
+    jtArrayStart,
+    jtObjectStop,
+    jtArrayStop,
+    jtAssign,
+    jtComma,
+    jtSingleQuote,
+    jtEqual,
+    jtIdentifierFirstChar,
+    jtSlash,
+    jtEndOfBuffer);
+
+  /// defines a lookup table used for branch-less first char JSON parsing
+  TJsonTokens = array[AnsiChar] of TJsonToken;
+  /// points to a lookup table used for branch-less first char JSON parsing
+  PJsonTokens = ^TJsonTokens;
+
+  /// kind of character used from JSON_CHARS[] for efficient JSON parsing
+  // - using such a set compiles into TEST [MEM], IMM so is more efficient
+  // than a regular set of AnsiChar which generates much slower BT [MEM], IMM
+  // - the same 256-byte memory will also be reused from L1 CPU cache
+  // during the parsing of complex JSON input
+  // - TTestCoreProcess.JSONBenchmark shows around 900MB/s on my i5 notebook
+  TJsonChar = set of (
+    jcJsonIdentifierFirstChar,
+    jcJsonIdentifier,
+    jcEndOfJsonFieldOr0,
+    jcEndOfJsonFieldNotName,
+    jcEndOfJsonValueField,
+    jcJsonStringMarker,
+    jcDigitFirstChar,
+    jcDigitFloatChar);
+
+  /// defines a lookup table used for branch-less JSON parsing
+  TJsonCharSet = array[AnsiChar] of TJsonChar;
+  /// points to a lookup table used for branch-less JSON parsing
+  PJsonCharSet = ^TJsonCharSet;
+
+const
+  /// JSON_ESCAPE[] lookup value: indicates no escape needed
+  JSON_ESCAPE_NONE = 0;
+  /// JSON_ESCAPE[] lookup value: indicates #0 (end of string)
+  JSON_ESCAPE_ENDINGZERO = 1;
+  /// JSON_ESCAPE[] lookup value: should be escaped as \u00xx
+  JSON_ESCAPE_UNICODEHEX = 2;
+
+  /// JSON_UNESCAPE[] lookup value: indicates #0 or unexpected control char
+  JSON_UNESCAPE_UNEXPECTED = #0;
+  /// JSON_UNESCAPE[] lookup value: indicates '\u0123' UTF-16 pattern
+  JSON_UNESCAPE_UTF16 = #1;
+
+var
+  /// 256-byte lookup table for fast branchless initial character JSON parsing
+  JSON_TOKENS: TJsonTokens;
+  /// 256-byte lookup table for fast branchless JSON parsing
+  // - to be used e.g. as:
+  // ! if jvJsonIdentifier in JSON_CHARS[P^] then ...
+  JSON_CHARS: TJsonCharSet;
+  /// 256-byte lookup table for fast branchless JSON text escaping
+  // - 0 = JSON_ESCAPE_NONE indicates no escape needed
+  // - 1 = JSON_ESCAPE_ENDINGZERO indicates #0 (end of string)
+  // - 2 = JSON_ESCAPE_UNICODEHEX should be escaped as \u00xx
+  // - b,t,n,f,r,\," as escaped character for #8,#9,#10,#12,#13,\,"
+  JSON_ESCAPE: array[byte] of byte;
+
+  /// 256-byte lookup table for fast branchless JSON text un-escaping
+  // - #0 = JSON_UNESCAPE_UNEXPECTED for unexpected #0 or control char
+  // - #1 = JSON_UNESCAPE_UTF16 for '\u0123' UTF-16 pattern
+  // - #8,#9,#10,#12,#13 as unescaped char from b,t,n,f,r
+  // - other characters are litterals and should be written as such
+  JSON_UNESCAPE: array[AnsiChar] of AnsiChar;
+
+  /// how many initial chars of a JSON array are parsed for intial capacity
+  // - used e.g. by _JL_DynArray() and TDocVariantData.InitJsonInPlace()
+  // - 64KB was found out empirically as a good value - but you can tune it
+  JSON_PREFETCH: integer = 65536;
+
+/// returns TRUE if the given text buffers would be escaped when written as JSON
+// - e.g. if contains " or \ characters, as defined by
+// http://www.ietf.org/rfc/rfc4627.txt
+function NeedsJsonEscape(const Text: RawUtf8): boolean; overload;
+
+/// returns TRUE if the given text buffers would be escaped when written as JSON
+// - e.g. if contains " or \ characters, as defined by
+// http://www.ietf.org/rfc/rfc4627.txt
+function NeedsJsonEscape(P: PUtf8Char): boolean; overload;
+
+/// returns TRUE if the given text buffers would be escaped when written as JSON
+// - e.g. if contains " or \ characters, as defined by
+// http://www.ietf.org/rfc/rfc4627.txt
+function NeedsJsonEscape(P: PUtf8Char; PLen: integer): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// UTF-8 decode one or two \u#### JSON escaped codepoints into Dest
+// - P^ should point at 'u1234' just after \u1234
+// - return ending P position, maybe after another \u#### UTF-16 surrogate char
+function JsonUnicodeEscapeToUtf8(var D: PUtf8Char; P: PUtf8Char): PUtf8Char;
+//  {$ifdef HASINLINE}inline;{$endif}
+
+/// ensure all UTF-8 Unicode glyphs are escaped as \u#### UTF-16 JSON
+// - this will work at raw UTF-8 text level: if your input is true JSON,
+// consider using JsonReformat(s, jsonEscapeUnicode) instead
+function JsonUnicodeEscape(const s: RawUtf8): RawUtf8;
+
+/// ensure all \u#### UTF-16 JSON are decoded into plain UTF-8 content
+// - this will work at raw UTF-8 text level: if your input is true JSON,
+// consider using JsonReformat(s, jsonNoEscapeUnicode) instead
+function JsonUnicodeUnEscape(const s: RawUtf8): RawUtf8;
+
+/// encode one \u#### JSON escaped UTF-16 codepoint into Dest
+procedure Utf16ToJsonUnicodeEscape(var B: PUtf8Char; c: PtrUint; tab: PByteToWord);
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// test if the supplied buffer is a "string" value or a numerical value
+// (floating point or integer), according to the characters within
+// - this version will recognize null/false/true as strings
+// - e.g. IsString('0')=false, IsString('abc')=true, IsString('null')=true
+function IsString(P: PUtf8Char): boolean;
+
+/// test if the supplied buffer is a "string" value or a numerical value
+// (floating or integer), according to the JSON encoding schema
+// - this version will NOT recognize JSON null/false/true as strings
+// - e.g. IsStringJson('0')=false, IsStringJson('abc')=true,
+// but IsStringJson('null')=false
+// - will follow the JSON definition of number, i.e. '0123' is a string (i.e.
+// '0' is excluded at the begining of a number) and '123' is not a string
+function IsStringJson(P: PUtf8Char): boolean;
+
+/// test if the supplied text buffer seems to be a correct (extended) JSON value
+// - will allow comments and extended MongoDB JSON syntax unless Strict=true
+// - numbers, escaped strings and commas are wild guessed, for performance
+function IsValidJson(P: PUtf8Char; len: PtrInt; strict: boolean = false): boolean; overload;
+
+/// test if the supplied text seems to be a correct (extended) JSON value
+// - will allow comments and extended MongoDB JSON syntax unless Strict=true
+// - numbers, escaped strings and commas are wild guessed, for performance
+function IsValidJson(const s: RawUtf8; strict: boolean = false): boolean; overload;
+
+/// test if the supplied #0 ended buffer is a correct (extended) JSON value
+// - will allow comments and extended MongoDB JSON syntax unless Strict=true
+// - numbers, escaped strings and commas are wild guessed, for performance
+function IsValidJsonBuffer(P: PUtf8Char; strict: boolean = false): boolean;
+
+/// returns the JSON type of a supplied #0 ended buffer
+// - will move to the first non-space char, then returns its JSON_TOKENS[] value
+// - for valid JSON, is likely to return jtDoubleQuote, jtFirstDigit,
+// jtNullFirstChar, jtTrueFirstChar, jtFalseFirstChar, jtObjectStart or jtArrayStart
+function GetFirstJsonToken(P: PUtf8Char): TJsonToken;
+
+/// validate the supplied #0 ended buffer and returns its JSON type
+// - on parsing error, returns P=nil and jtNone
+// - will move P to the next JSON item, and return the JSON token kind, e.g.
+// jtArrayStart, jtObjectStart, jtDoubleQuote or jtFirstDigit
+// - will allow comments and extended MongoDB JSON syntax unless Strict=true
+// - optionally return the number of nested items for jtArrayStart/jtObjectStart
+function GetNextJsonToken(var P: PUtf8Char; strict: boolean = false;
+  DocCount: PInteger = nil): TJsonToken;
+
+/// simple method to go after the next ',' character
+procedure IgnoreComma(var P: PUtf8Char);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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}
+
+type
+  /// efficient JSON value parser / in-place decoder
+  // - as used by JsonDecode() and all internal JSON functions
+  {$ifdef USERECORDWITHMETHODS}
+  TGetJsonField = record
+  {$else}
+  TGetJsonField = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// input/output JSON parsing buffer address
+    Json: PUtf8Char;
+    /// in-place output parsed JSON value, unescaped and #0 terminated
+    // - see associated WasString to find out its actual type
+    Value: PUtf8Char;
+    /// in-place output parsed JSON value length
+    ValueLen: integer;
+    /// set if the value was actually 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)
+    // - numbers are decoded as text, e.g. '1.234', with WasString=false
+    // - null is decoded as Value=nil and WasString=false
+    // - true/false are decoded as 'true'/'false' with WasString=false
+    WasString: boolean;
+    /// the ',' ':' or '}' separator just after the Value
+    // - may have been overwritten with a #0 termination in the input buffer
+    EndOfObject: AnsiChar;
+    /// decode a JSON field value in-place from an UTF-8 encoded text buffer
+    // - warning: will decode in the Json buffer memory itself (no memory copy
+    // nor allocation), for faster process - so take care that it is not shared
+    // - Value/ValueLen/WasString is set with the parsed value
+    // - EndOfObject is set to the JSON ending char (',' ':' or '}' e.g.)
+    // - Json points to the next field to be decoded, or nil on parsing error
+    procedure GetJsonField;
+    /// decode a JSON 64-bit integer value from an UTF-8 encoded text buffer
+    function GetJsonInt64: Int64;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// decode a JSON field value in-place into a RawUtf8 string
+    procedure GetJsonValue(var Text: RawUtf8);
+    /// decode a JSON content from 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
+    // - warning: will decode in the Json buffer memory itself (no memory
+    // allocation or copy), for faster process - so take care that it is not shared
+    // - Value/ValueLen/WasString is set with the parsed JSON value
+    // - EndOfObject is set to the JSON ending char (',' ':' or '}' e.g.)
+    // - Json points to the next value to be decoded, or nil on parsing error
+    procedure GetJsonFieldOrObjectOrArray(
+      HandleValuesAsObjectOrArray: boolean = true; NormalizeBoolean: boolean = true);
+  end;
+
+{$ifndef PUREMORMOT2}
+/// decode a JSON field value in-place from an UTF-8 encoded text buffer
+// - compatibility wrapper around TGetJsonField.GetJsonField method
+function GetJsonField(P: PUtf8Char; out PDest: PUtf8Char;
+  WasString: PBoolean = nil; EndOfObject: PUtf8Char = nil;
+  Len: PInteger = nil): PUtf8Char;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// decode a JSON content from an UTF-8 encoded buffer
+// - compatibility wrapper around TGetJsonField.GetJsonFieldOrObjectOrArray
+function GetJsonFieldOrObjectOrArray(var Json: PUtf8Char;
+  WasString: PBoolean = nil; EndOfObject: PUtf8Char = nil;
+  HandleValuesAsObjectOrArray: boolean = false;
+  NormalizeBoolean: boolean = true; Len: PInteger = nil): PUtf8Char;
+  {$ifdef HASINLINE} inline; {$endif}
+{$endif PUREMORMOT2}
+
+/// 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, and "..." content
+// properly unescaped unless NoJsonUnescape is set to true
+// - returns 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 Json: PUtf8Char; Len: PInteger = nil;
+  NoJsonUnescape: boolean = false): PUtf8Char;
+
+/// 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 GetJsonPropNameShort(var P: PUtf8Char; out PropName: ShortString);
+
+/// decode a JSON object or array from an UTF-8 encoded buffer
+// - as called by GetJsonFieldOrObjectOrArray() for HandleValuesAsObjectOrArray
+// - return the position of the next JSON item (with EndOfObject and optionally
+// Len^ properly set) or nil on parsing error
+function GetJsonObjectOrArray(P: PUtf8Char;
+  EndOfObject: PUtf8Char; Len: PInteger = nil): PUtf8Char;
+
+/// retrieve the next JSON item as a RawJson undecoded variable
+// - P 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 '}')
+// - input buffer is not modified in-place, since result is directly copied
+procedure GetJsonItemAsRawJson(var P: PUtf8Char; var result: RawJson;
+  EndOfObject: PAnsiChar = nil);
+
+/// retrieve the next JSON item as a RawUtf8 decoded buffer
+// - P 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 calls TGetJsonField, and create a new RawUtf8 from the returned value,
+// after proper string unescape (with WasString^=true)
+// - warning: input buffer is modified in-place during output value parsing
+function GetJsonItemAsRawUtf8(var P: PUtf8Char; var output: RawUtf8;
+  WasString: PBoolean = nil; EndOfObject: PUtf8Char = nil): boolean;
+
+/// get the next character after a quoted buffer
+// - the first character in P^ must be "
+// - it will return the latest " position, ignoring \" within
+// - caller should check that return PUtf8Char is indeed a "
+function GotoEndOfJsonString(P: PUtf8Char): PUtf8Char;
+
+/// reach position just after the current JSON string in the supplied UTF-8 buffer
+// - will first ensure that P^='"' then process like GotoEndJsonItem()
+function GotoEndJsonItemString(P: PUtf8Char): PUtf8Char;
+
+/// reach position 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 ',','}',']'
+// - will allow comments and extended MongoDB JSON syntax - use
+// GotoEndJsonItemStrict() if you expect a more standard JSON parsing
+function GotoEndJsonItem(P: PUtf8Char; PMax: PUtf8Char = nil): PUtf8Char;
+
+/// reach position just after the current JSON item in the supplied UTF-8 buffer
+// - in respect to GotoEndJsonItem(), this function will validate for strict
+// JSON simple values, i.e. real numbers or only true/false/null constants,
+// and refuse commens or MongoDB extended syntax like {age:{$gt:18}}
+// - numbers and escaped strings are not fully validated, just their charset
+function GotoEndJsonItemStrict(P: PUtf8Char; PMax: PUtf8Char = nil): PUtf8Char;
+
+/// reach the position of the next JSON item(s) 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; PMax: PUtf8Char = nil;
+  Strict: boolean = false): PUtf8Char; overload;
+
+/// reach the position of the next JSON item in the supplied UTF-8 buffer
+// - similar to the GotoNextJsonItem() with NumberOfItemsToJump=1
+function GotoNextJsonItem(P: PUtf8Char; var EndOfObject: AnsiChar): PUtf8Char; overload;
+  {don't inline to reduce the stack size of the caller function}
+
+/// search the EndOfObject of a JSON buffer, just like TGetJsonField does
+function ParseEndOfObject(P: PUtf8Char; out EndOfObject: AnsiChar): PUtf8Char;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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 0 if the supplied input is invalid, or the number of identified
+// items in the JSON array buffer
+// - if PMax is set, will abort after this position, and return the current
+// counted number of items as negative, which could be used as initial allocation
+// before the loop - typical use in this case is e.g.
+// ! cap := abs(JsonArrayCount(P, P + JSON_PREFETCH));
+// - some performance numbers on a Core i5-13400:
+// $     JsonArrayCount(P) in 10.95ms i.e. 14.3M/s, 1.7 GB/s
+// $     JsonArrayCount(P,PMax) in 11.05ms i.e. 14.1M/s, 1.7 GB/s
+function JsonArrayCount(P: PUtf8Char; PMax: PUtf8Char = nil;
+  Strict: boolean = false): integer;
+
+/// 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 the positions of all elements of a JSON array
+// - this will handle any kind of arrays, including those with nested
+// JSON objects or arrays
+// - warning: incoming P^ should point to the first char AFTER the initial '['
+// (which may be a closing ']') - calling e.g. NextNotSpaceCharIs()
+// - 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
+// documents, and also comments or MongoDB extended syntax (unless Strict=true)
+// - warning: incoming P^ should point to the first char AFTER the initial '{'
+// (which may be a closing '}')
+// - will abort if P reaches PMax (if not nil), and return the current counted
+// number of items as negative, which could be used as initial allocation before
+// a parsing loop - typical use in this case is e.g.
+// ! cap := abs(JsonObjectPropCount(P, P + JSON_PREFETCH));
+function JsonObjectPropCount(P: PUtf8Char; PMax: PUtf8Char = nil;
+  Strict: boolean = false): PtrInt;
+
+/// 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
+// - PropName is search case-insensitively  as 'propertyname' or 'property*'
+// - returns nil if the supplied property name does not exist
+// - returns a pointer to the matching item value 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; overload;
+
+/// go to a buffer-named property of a JSON object
+// - as called by overloaded JsonObjectItem()
+function JsonObjectItem(P: PUtf8Char; PropName: PUtf8Char; PropNameLen: PtrInt;
+  PropNameFound: PRawUtf8): PUtf8Char; overload;
+
+/// 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
+// - PropPath is search case-insensitively as 'parent.child' or 'parent.ch*'
+// - returns nil if the supplied property path does not exist
+// - returns a pointer to the matching item value 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 case-insensitive full
+// paths, e.g. 'Prop1,Prop2' or 'Obj1.Obj2.Prop*,Obj1.Prop1'
+// - 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 TJsonWriter.AddJsonArraysAsJsonObject() method
+// - used e.g. by TSynDictionary.LoadFromJson
+// - returns the number of items parsed and stored into keys/values, -1 on
+// error parsing the input JSON buffer
+function JsonObjectAsJsonArrays(Json: PUtf8Char;
+  out keys, values: RawUtf8): integer;
+
+/// remove comments and trailing commas from a text buffer before passing
+// it to a JSON parser
+// - handle two types of comments: starting from // till end of line
+// or /* ..... */ blocks anywhere in the text content
+// - trailing commas is replaced by ' ', so resulting JSON is valid for parsers
+// what not allows trailing commas (browsers for example)
+// - may be used to prepare configuration files before loading;
+// for example we store server configuration in file config.json and
+// put some comments in this file then code for loading is:
+// !var
+// !  cfg: RawUtf8;
+// ! ...
+// !  cfg := StringFromFile(Executable.ProgramFilePath + 'config.json');
+// !  RemoveCommentsFromJson(@cfg[1]);
+// !  pLastChar := JsonToObject(obj, pointer(cfg), isvalid);
+procedure RemoveCommentsFromJson(P: PUtf8Char); overload;
+
+/// remove comments from a text buffer before passing it to JSON parser
+// - won't remove the comments in-place, but allocate a new string
+function RemoveCommentsFromJson(const s: RawUtf8): RawUtf8; overload;
+
+/// helper to retrieve the bit mapped integer value of a set from its JSON text
+// - Names and MaxValue should be retrieved from RTTI
+// - 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 prematurely the end of content, or returns
+// the value separator (e.g. , or }) in EndOfObject (like GetJsonField)
+function GetSetNameValue(Names: PShortString; MinValue, MaxValue: integer;
+  var P: PUtf8Char; out EndOfObject: AnsiChar): QWord; overload;
+
+/// helper to retrieve the bit mapped integer value of a set from its JSON text
+// - overloaded function using the RTTI
+function GetSetNameValue(Info: PRttiInfo;
+  var P: PUtf8Char; out EndOfObject: AnsiChar): QWord; overload;
+
+/// retrieve a pointer to JSON string field content, without unescaping it
+// - returns either ':' for name field, or } , 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 TGetJsonField
+function JsonRetrieveStringField(P: PUtf8Char; out Field: PUtf8Char;
+  out FieldLen: integer; ExpectNameField: boolean): PUtf8Char;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// retrieve a class Rtti, as saved by ObjectToJson(...,[...,woStoreClassName,...]);
+// - JSON input should be either 'null', either '{"ClassName":"TMyClass",...}'
+// - calls IdemPropName/JsonRetrieveStringField so input buffer won't be
+// modified, but caller should ignore this "ClassName" property later on
+// - the corresponding class shall have been previously registered by
+// Rtti.RegisterClass(), in order to retrieve the class type from it name -
+// or, at least, by the RTL Classes.RegisterClass() function, if AndGlobalFindClass
+// parameter is left to default true so that RTL Classes.FindClass() is called
+function JsonRetrieveObjectRttiCustom(var Json: PUtf8Char;
+  AndGlobalFindClass: boolean): TRttiCustom;
+
+/// encode a JSON object UTF-8 buffer into URI parameters
+// - you can specify property names to ignore during the object decoding
+// - you can omit the leading query delimiter ('?') by setting IncludeQueryDelimiter=false
+// - warning: the ParametersJson input buffer will be modified in-place
+function UrlEncodeJsonObject(const UriName: RawUtf8; ParametersJson: PUtf8Char;
+  const PropNamesToIgnore: array of RawUtf8;
+  IncludeQueryDelimiter: boolean = true): RawUtf8; overload;
+
+/// encode a JSON object UTF-8 buffer into URI parameters
+// - you can specify property names to ignore during the object decoding
+// - you can omit the leading query delimiter ('?') by setting IncludeQueryDelimiter=false
+// - overloaded function which will make a copy of the input JSON before parsing
+function UrlEncodeJsonObject(const UriName, ParametersJson: RawUtf8;
+  const PropNamesToIgnore: array of RawUtf8;
+  IncludeQueryDelimiter: boolean = true): RawUtf8; overload;
+
+
+/// formats and indents a JSON array or document to the specified layout
+// - just a wrapper around TJsonWriter.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 TJsonWriter.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 TJsonWriter.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 TJsonWriter.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;
+
+
+/// convert UTF-8 content into a JSON string
+// - with proper escaping of the content, and surounding " characters
+procedure QuotedStrJson(const aText: RawUtf8; var result: RawUtf8;
+  const aPrefix: RawUtf8 = ''; const aSuffix: RawUtf8 = ''); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert UTF-8 buffer into a JSON string
+// - with proper escaping of the content, and surounding " characters
+procedure QuotedStrJson(P: PUtf8Char; PLen: PtrInt; var result: RawUtf8;
+  const aPrefix: RawUtf8 = ''; const aSuffix: RawUtf8 = ''); overload;
+
+/// convert UTF-8 content into a JSON string
+// - with proper escaping of the content, and surounding " characters
+function QuotedStrJson(const aText: RawUtf8): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+const
+  FIELDCOUNT_PATTERN: PUtf8Char = '{"fieldCount":'; // PatternLen = 14 chars
+  ROWCOUNT_PATTERN: PUtf8Char   = ',"rowCount":';   // PatternLen = 12 chars
+  VALUES_PATTERN: PUtf8Char     = ',"values":[';    // PatternLen = 11 chars
+
+/// quickly check if an UTF-8 buffer start with the supplied Pattern
+// - PatternLen is at least 8 bytes long, typically FIELDCOUNT_PATTERN,
+// ROWCOUNT_PATTERN or VALUES_PATTERN constants
+// - defined here for TDocVariantData.InitArrayFromResults
+function Expect(var P: PUtf8Char; Pattern: PUtf8Char; PatternLen: PtrInt): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// parse JSON content in not-expanded format
+// - i.e. stored as
+// $ {"fieldCount":2,"values":["f1","f2","1v1",1v2,"2v1",2v2...],"rowCount":20}
+// - search and extract "fieldCount" and "rowCount" field information
+// - defined here for TDocVariantData.InitArrayFromResults
+function IsNotExpandedBuffer(var P: PUtf8Char; PEnd: PUtf8Char;
+  var FieldCount, RowCount: PtrInt): boolean;
+
+/// efficient retrieval of the number of rows in non-expanded layout
+// - search for "rowCount": at the end of the JSON buffer
+function NotExpandedBufferRowCountPos(P, PEnd: PUtf8Char): PUtf8Char;
+
+/// low-level prepare GetFieldCountExpanded() parsing returning '{' or ']'
+function GotoFieldCountExpanded(P: PUtf8Char): PUtf8Char;
+
+/// low-level parsing of the first expanded JSON object to guess fields count
+function GetFieldCountExpanded(P: PUtf8Char): integer;
+
+/// fast Format() function replacement, handling % and ? parameters
+// - call rather FormatSql() and FormatJson() wrappers instead
+// - resulting string has no length limit and uses fast concatenation
+// - any supplied TObject instance will be written as their class name
+procedure FormatParams(const Format: RawUtf8; const Args, Params: array of const;
+  JsonFormat: boolean; var Result: RawUtf8);
+
+/// fast Format() function replacement, handling % but also ? inlined parameters
+// - will include Args[] for every % in Format
+// - will include Params[] for every ? in Format, as "inlined" ORM or DB values,
+// e.g. :(1234): for numbers, and  :('quoted '' string'): for 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)
+// - is a wrapper around FormatParams(Format, Args, Params, false, result);
+function FormatSql(const Format: RawUtf8;
+  const Args, Params: array of const): RawUtf8;
+
+/// fast Format() function replacement, handling % but also ? parameters as JSON
+// - will include Args[] for every % in Format
+// - will include Params[] for every ? in Format, as their JSON value, with
+// proper JSON double quotes and escaping for strings
+// - note that, due to a Delphi compiler limitation, cardinal values should be
+// type-casted to Int64() (otherwise the integer mapped value will be converted)
+// - is a wrapper around FormatParams(Format, Args, Params, true, result);
+function FormatJson(const Format: RawUtf8;
+  const Args, Params: array of const): RawUtf8;
+
+{$ifndef PUREMORMOT2} // rather call FormatSql() and FormatJson() functions
+function FormatUtf8(const Format: RawUtf8; const Args, Params: array of const;
+  JsonFormat: boolean = false): RawUtf8; overload;
+{$endif PUREMORMOT2}
+
+
+{ ********** TJsonWriter class with proper JSON escaping and WriteObject() support }
+
+type
+  /// JSON-capable TTextWriter/TTextDateWriter inherited class
+  // - in addition to TTextWriter/TTextDateWriter, will handle JSON
+  // serialization of any kind of value, including records, classes or arrays
+  TJsonWriter = class(TTextDateWriter)
+  protected
+    // used by AddCRAndIndent for enums, sets and T*ObjArray comment of values
+    fBlockComment: RawUtf8;
+    // used by WriteObjectAsString/AddDynArrayJsonAsString methods
+    fInternalJsonWriter: TJsonWriter;
+    procedure InternalAddFixedAnsi(Source: PAnsiChar; SourceChars: cardinal;
+      AnsiToWide: PWordArray; Escape: TTextWriterKind);
+    // called after TRttiCustomProp.GetValueDirect/GetValueGetter
+    procedure AddRttiVarData(const Value: TRttiVarData; Escape: TTextWriterKind;
+      WriteOptions: TTextWriterWriteObjectOptions);
+  public
+    /// release all internal structures
+    destructor Destroy; override;
+    /// gives access to a temporary TJsonWriter
+    // - returned instance is owned by this TJsonWriter, and voided
+    // - may be used to escape some JSON espaced value (i.e. escape it twice),
+    // in conjunction with AddJsonEscape(Source: TJsonWriter)
+    function GetTempJsonWriter: TJsonWriter;
+    /// append '[' or '{' with proper indentation
+    procedure BlockBegin(Starter: AnsiChar; Options: TTextWriterWriteObjectOptions);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append ',' with proper indentation
+    // - warning: this will break CancelLastComma, since CRLF+tabs are added
+    procedure BlockAfterItem(Options: TTextWriterWriteObjectOptions);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append ']' or '}' with proper indentation
+    procedure BlockEnd(Stopper: AnsiChar; Options: TTextWriterWriteObjectOptions);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// used internally by WriteObject() when serializing a published property
+    // - will call AddCRAndIndent then append "PropName":
+    procedure WriteObjectPropNameHumanReadable(PropName: PUtf8Char; PropNameLen: PtrInt);
+    /// used internally by WriteObject() when serializing a published property
+    // - will call AddCRAndIndent then append "PropName":
+    procedure WriteObjectPropNameShort(const PropName: ShortString;
+      Options: TTextWriterWriteObjectOptions);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// 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]);
+    /// same as AddDynArrayJson(), but will double all internal " and bound with "
+    // - this implementation will avoid most memory allocations
+    procedure AddDynArrayJsonAsString(aTypeInfo: PRttiInfo; var aValue;
+      WriteOptions: TTextWriterWriteObjectOptions = []);
+    /// 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 CR+LF (#13#10) chars and #9 indentation
+    // - will also flush any fBlockComment
+    procedure AddCRAndIndent; override;
+    /// 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); override;
+    /// 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); override;
+    /// 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);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// 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,
+    // CP_WINANSI, or any version supported by the Operating System
+    // - if codepage is 0, the current CurrentAnsiConvert.CodePage would be used
+    // - will use TSynAnsiConvert to perform the conversion to UTF-8
+    procedure AddAnyAnsiBuffer(P: PAnsiChar; Len: PtrInt;
+      Escape: TTextWriterKind; CodePage: integer);
+    /// write some data Base64 encoded
+    // - if withMagic is TRUE, will write as '"\uFFF0base64encodedbinary"'
+    procedure WrBase64(P: PAnsiChar; Len: PtrUInt; withMagic: boolean); override;
+    /// write some binary-saved data with Base64 encoding
+    // - if withMagic is TRUE, will write as '"\uFFF0base64encodedbinary"'
+    // - is a wrapper around BinarySave() and WrBase64()
+    procedure BinarySaveBase64(Data: pointer; Info: PRttiInfo;
+      Kinds: TRttiKinds; withMagic: boolean; withCrc: boolean = false);
+    /// append some values at once
+    // - text values (e.g. RawUtf8) will be escaped as JSON by default
+    procedure Add(const Values: array of const); overload;
+    /// append some values at once with custom escaping
+    procedure Add(const Values: array of const; Escape: TTextWriterKind); overload;
+    /// append an array of RawUtf8 as CSV of JSON strings
+    procedure AddCsvUtf8(const Values: array of RawUtf8);
+    /// append an array of const as CSV of JSON values
+    procedure AddCsvConst(const Values: array of const);
+    /// 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 strings or integers with a specified format
+    // - this overriden version will properly handle JSON escape
+    // - % = #37 marks a string, integer, floating-point, or class parameter
+    // to be appended as text (e.g. class name)
+    // - 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
+    procedure Add(const Format: RawUtf8; const Values: array of const;
+      Escape: TTextWriterKind = twNone;
+      WriteObjectOptions: TTextWriterWriteObjectOptions = [woFullExpand]); override;
+    /// append a variant content as number or string
+    // - this overriden version will properly handle JSON escape
+    // - properly handle Value as a TRttiVarData from TRttiProp.GetValue
+    procedure AddVariant(const Value: variant; Escape: TTextWriterKind = twJsonEscape;
+      WriteOptions: TTextWriterWriteObjectOptions = []); override;
+    /// append complex types as JSON content using raw TypeInfo()
+    // - handle rkClass as WriteObject, rkEnumeration/rkSet with proper options,
+    // rkRecord, rkDynArray or rkVariant using proper JSON serialization
+    // - other types will append 'null'
+    procedure AddTypedJson(Value, TypeInfo: pointer;
+      WriteOptions: TTextWriterWriteObjectOptions = []); override;
+    /// serialize as JSON the given object
+    procedure WriteObject(Value: TObject;
+      WriteOptions: TTextWriterWriteObjectOptions = [woDontStoreDefault]); override;
+    /// append complex types as JSON content using TRttiCustom
+    // - called e.g. by TJsonWriter.AddVariant() for varAny / TRttiVarData
+    procedure AddRttiCustomJson(Value: pointer; RttiCustom: TObject;
+      Escape: TTextWriterKind; WriteOptions: TTextWriterWriteObjectOptions);
+    /// append a JSON value, array or document, in a specified format
+    // - this overriden version will properly handle JSON escape
+    function AddJsonReformat(Json: PUtf8Char; Format: TTextWriterJsonFormat;
+      EndOfObject: PUtf8Char): PUtf8Char; override;
+    /// 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 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
+    // TRttiJson.RegisterCustomSerializer() class method - from a dynamic array
+    // handling this kind of records, or directly from TypeInfo() of the record
+    // - by default, custom serializers defined via RegisterCustomSerializer()
+    // would write enumerates and sets as integer numbers, unless
+    // twoEnumSetsAsTextInRecord or twoEnumSetsAsBooleanInRecord is set in
+    // the instance CustomOptions
+    // - returns the element size
+    function AddRecordJson(Value: pointer; RecordInfo: PRttiInfo;
+      WriteOptions: TTextWriterWriteObjectOptions = []): PtrInt;
+    /// 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(RecordInfo: PRttiInfo;
+      WriteOptions: TTextWriterWriteObjectOptions = []);
+    /// append a dynamic array content as UTF-8 encoded JSON array
+    // - typical content could be
+    // ! '[1,2,3,4]' or '["\uFFF0base64encodedbinary"]'
+    procedure AddDynArrayJson(var DynArray: TDynArray;
+      WriteOptions: TTextWriterWriteObjectOptions = []); overload;
+    /// append a dynamic array content as UTF-8 encoded JSON array
+    // - expect a dynamic array TDynArrayHashed wrapper as incoming parameter
+    procedure AddDynArrayJson(var DynArray: TDynArrayHashed;
+      WriteOptions: TTextWriterWriteObjectOptions = []); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append a dynamic array content as UTF-8 encoded JSON array
+    // - returns the array element size
+    function AddDynArrayJson(Value: pointer; Info: TRttiCustom;
+      WriteOptions: TTextWriterWriteObjectOptions = []): PtrInt; overload;
+    /// append UTF-8 content as text
+    // - Text CodePage will be used (if possible) - assume RawUtf8 otherwise
+    // - will properly handle JSON escape between two " double quotes
+    procedure AddText(const Text: RawByteString; Escape: TTextWriterKind = twJsonEscape);
+    /// append UTF-16 content as text
+    // - P should be a #0 terminated PWideChar buffer
+    // - will properly handle JSON escape between two " double quotes
+    procedure AddTextW(P: PWord; Escape: TTextWriterKind = twJsonEscape);
+    /// append some UTF-8 encoded chars to the buffer
+    // - escapes chars according to the JSON RFC
+    // - if Len is 0, writing will stop at #0 (default Len = 0 is slightly faster
+    // than specifying Len>0 if you are sure P is zero-ended - e.g. from RawUtf8)
+    procedure AddJsonEscape(P: Pointer; Len: PtrInt = 0); overload;
+    /// append some 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 some UTF-8 encoded chars to the buffer, from a RTL 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 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;
+    /// append a UTF-8 JSON string, JSON escaped between double quotes
+    // - "" will always be added, before calling AddJsonEscape()
+    procedure AddJsonString(const Text: RawUtf8);
+    /// flush a supplied TJsonWriter, 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: TJsonWriter); overload;
+    /// flush a supplied TJsonWriter, and write pending data as JSON escaped text
+    // - may be used with InternalJsonWriter, as a faster alternative to
+    // ! AddNoJsonEscapeUtf8(Source.Text);
+    procedure AddNoJsonEscape(Source: TJsonWriter); overload;
+    /// append a UTF-8 already encoded JSON buffer forcing Unicode escape
+    // - don't escapes chars according to the JSON RFC but convert any 8-bit
+    // UTF-8 values as their UTF-16 \u#### escaped content
+    // - i.e. generate a pure ASCII output with no UTF-8 encoding involved
+    // - used for jsonEscapeUnicode to follow python default json.dumps() layout
+    procedure AddNoJsonEscapeForcedUnicode(P: PUtf8Char; Len: PtrInt);
+    /// append a UTF-8 encoded JSON buffer without any \u#### Unicode escape
+    // - i.e. \u#### patterns will be converted into pure UTF-8 output
+    // - as used for jsonNoEscapeUnicode transformation
+    procedure AddNoJsonEscapeForcedNoUnicode(P: PUtf8Char; Len: PtrInt);
+    /// 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;
+    /// 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 mormot.db.nosql.bson 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);
+    /// 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
+    // - used e.g. by TSynDictionary.SaveToJson
+    procedure AddJsonArraysAsJsonObject(keys, values: PUtf8Char);
+  end;
+
+
+{ ************ JSON-aware TSynNameValue TSynPersistentStoreJson }
+
+type
+  /// store one Name/Value pair, as used by TSynNameValue class
+  TSynNameValueItem = record
+    /// the name of the Name/Value pair
+    // - this property is hashed by TSynNameValue for fast retrieval
+    Name: RawUtf8;
+    /// the value of the Name/Value pair
+    Value: RawUtf8;
+    /// any associated Pointer or numerical value
+    Tag: PtrInt;
+  end;
+
+  /// Name/Value pairs storage, as used by TSynNameValue class
+  TSynNameValueItemDynArray = array of TSynNameValueItem;
+
+  /// event handler used to convert on the fly some UTF-8 text content
+  TOnSynNameValueConvertRawUtf8 = function(
+    const text: RawUtf8): RawUtf8 of object;
+
+  /// callback event used by TSynNameValue
+  TOnSynNameValueNotify = procedure(
+    const Item: TSynNameValueItem; Index: PtrInt) of object;
+
+  /// pseudo-class used to store Name/Value RawUtf8 pairs
+  // - use internally a TDynArrayHashed instance for fast retrieval
+  // - is therefore faster than TRawUtf8List
+  // - is defined as an object, not as a class: you can use this in any
+  // class, without the need to destroy the content
+  // - Delphi "object" is buggy on stack -> also defined as record with methods
+  {$ifdef USERECORDWITHMETHODS}
+  TSynNameValue = record
+  private
+  {$else}
+  TSynNameValue = object
+  protected
+  {$endif USERECORDWITHMETHODS}
+    fOnAdd: TOnSynNameValueNotify;
+    function GetBlobData: RawByteString;
+    procedure SetBlobData(const aValue: RawByteString);
+    function GetStr(const aName: RawUtf8): RawUtf8;
+      {$ifdef HASINLINE}inline;{$endif}
+    function GetInt(const aName: RawUtf8): Int64;
+      {$ifdef HASINLINE}inline;{$endif}
+  public
+    /// the internal Name/Value storage
+    List: TSynNameValueItemDynArray;
+    /// the number of Name/Value pairs
+    Count: integer;
+    /// low-level access to the internal storage hasher
+    DynArray: TDynArrayHashed;
+    /// initialize the storage
+    // - will also reset the internal List[] and the internal hash array
+    procedure Init(aCaseSensitive: boolean);
+    /// add an element to the array
+    // - if aName already exists, its associated Value will be updated
+    procedure Add(const aName, aValue: RawUtf8; aTag: PtrInt = 0);
+    /// reset content, then add all name=value pairs from a supplied .ini file
+    // section content
+    // - will first call Init(false) to initialize the internal array
+    // - Section can be retrieved e.g. via FindSectionFirstLine()
+    procedure InitFromIniSection(Section: PUtf8Char;
+      const OnTheFlyConvert: TOnSynNameValueConvertRawUtf8 = nil;
+      const OnAdd: TOnSynNameValueNotify = nil);
+    /// reset content, then add all name=value; CSV pairs
+    // - will first call Init(false) to initialize the internal array
+    // - if ItemSep=#10, then any kind of line feed (CRLF or LF) will be handled
+    procedure InitFromCsv(Csv: PUtf8Char; NameValueSep: AnsiChar = '=';
+      ItemSep: AnsiChar = #10);
+    /// reset content, then add all fields from an JSON object
+    // - will first call Init() to initialize the internal array
+    // - then parse the incoming JSON object, storing all its field values
+    // as RawUtf8, and returning TRUE if the supplied content is correct
+    // - warning: the supplied JSON buffer will be decoded and modified in-place
+    function InitFromJson(Json: PUtf8Char; aCaseSensitive: boolean = false): boolean;
+    /// reset content, then add all name, value pairs
+    // - will first call Init(false) to initialize the internal array
+    procedure InitFromNamesValues(const Names, Values: array of RawUtf8);
+    /// search for a Name, return the index in List
+    // - using fast O(1) hash algoritm
+    function Find(const aName: RawUtf8): PtrInt;
+    /// 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): PtrInt;
+    /// 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): PtrInt;
+    /// 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' / 'true'
+    function ValueBool(const aName: RawUtf8): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// 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: PRttiInfo;
+      out aEnum; aEnumDefault: PtrUInt = 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);
+    /// 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;
+    /// 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, aValueMax: pointer);
+    /// can be used to set or retrieve all stored data as one BLOB content
+    property BlobData: RawByteString
+      read GetBlobData write SetBlobData;
+    /// event triggerred after an item has just been added to the list
+    property OnAfterAdd: TOnSynNameValueNotify
+      read fOnAdd write fOnAdd;
+    /// search for a Name, return the associated Value as a UTF-8 string
+    // - returns '' if aName is not found in the stored keys
+    property Str[const aName: RawUtf8]: RawUtf8
+      read GetStr; default;
+    /// search for a Name, return the associated Value as integer
+    // - returns 0 if aName is not found, or not a valid Int64 in the stored keys
+    property Int[const aName: RawUtf8]: Int64
+      read GetInt;
+    /// search for a Name, return the associated Value as boolean
+    // - returns true if aName stores '1' / 'true' as associated value
+    property Bool[const aName: RawUtf8]: boolean
+      read ValueBool;
+  end;
+
+
+  /// a reference pointer to a Name/Value RawUtf8 pairs storage
+  PSynNameValue = ^TSynNameValue;
+
+  /// 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)
+  TSynCache = class(TSynPersistent)
+  protected
+    fNameValue: TSynNameValue;
+    fRamUsed: cardinal;
+    fMaxRamUsed: cardinal;
+    fTimeoutSeconds: cardinal;
+    fTimeoutTix: cardinal;
+    fSafe: TRWLock; // writes should be reentrant for Reset
+    procedure ResetIfNeeded; // call Reset after TimeoutSeconds
+  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 thread-safe, using the Safe R/W locker of this instance
+    function Find(const aKey: RawUtf8; aResultTag: PPtrInt = nil): RawUtf8;
+    /// 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 R/W 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 R/W locker of this instance
+    function Reset: boolean;
+    /// access to the internal R/W locker, for thread-safe process
+    // - Find/AddOrUpdate methods are protected by this R/W lock
+    property Safe: TRWLock
+      read fSafe;
+  published
+    /// number of entries in the cache
+    property Count: integer
+      read fNameValue.Count;
+    /// 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;
+
+
+type
+  /// implement binary persistence and JSON serialization (not deserialization)
+  TSynPersistentStoreJson = class(TSynPersistentStore)
+  protected
+    // append "name" -> inherited should add properties to the JSON object
+    procedure AddJson(W: TJsonWriter); virtual;
+  public
+    /// serialize this instance as a JSON object
+    function SaveToJson(reformat: TTextWriterJsonFormat = jsonCompact): RawUtf8;
+  end;
+
+
+
+{ *********** JSON-aware TSynDictionary Storage }
+
+type
+  /// exception raised during TSynDictionary process
+  ESynDictionary = class(ESynException);
+
+  // internal flag, used only by TSynDictionary.InArray protected method
+  TSynDictionaryInArray = (
+    iaFind,
+    iaFindAndDelete,
+    iaFindAndUpdate,
+    iaFindAndAddIfNotExisting,
+    iaAdd,
+    iaAddForced);
+
+  /// 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
+  TOnSynDictionary = 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
+  TOnSynDictionaryCanDelete = function(const aKey, aValue;
+    aIndex: integer): boolean of object;
+
+  /// thread-safe dictionary to store some values from associated keys
+  // - will maintain a dynamic array of values, associated with a hash table
+  // for the keys, so that setting or retrieving values would be O(1)
+  // - thread-safe by default, since most methods are protected by a TSynLocker;
+  // use the ThreadUse option to tune thread-safety (e.g. disable or use a TRWLock)
+  // - TDynArray is a wrapper which does not store anything, whereas this class
+  // actually stores both keys and values, and provide convenient methods to
+  // access the stored data, including JSON serialization and binary storage
+  // - consider IKeyValue<> from mormot.core.collections.pas, for more robust
+  // generics-based code where TKey/TValue are propagated to all methods
+  TSynDictionary = class(TSynLocked)
+  protected
+    fKeys: TDynArrayHashed;
+    fValues: TDynArray;
+    fTimeOut: TCardinalDynArray;
+    fTimeOuts: TDynArray;
+    fCompressAlgo: TAlgoCompress;
+    fOnCanDelete: TOnSynDictionaryCanDelete;
+    function InternalAddUpdate(aKey, aValue: pointer; aUpdate: boolean): PtrInt;
+    function InArray(const aKey, aArrayValue; aAction: TSynDictionaryInArray;
+      aCompare: TDynArraySortCompare): boolean;
+    procedure SetTimeouts;
+    function ComputeNextTimeOut: cardinal;
+      {$ifdef HASINLINE} inline; {$endif}
+    function GetCapacity: integer;
+    procedure SetCapacity(const Value: integer);
+    function GetTimeOutSeconds: cardinal;
+      {$ifdef HASINLINE} inline; {$endif}
+    procedure SetTimeOutSeconds(Value: cardinal);
+    function GetThreadUse: TSynLockerUse;
+      {$ifdef HASINLINE} inline; {$endif}
+    procedure SetThreadUse(const Value: TSynLockerUse);
+      {$ifdef HASINLINE} inline; {$endif}
+  public
+    /// initialize the dictionary storage, specifying 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: PRttiInfo;
+      aKeyCaseInsensitive: boolean = false; aTimeoutSeconds: cardinal = 0;
+      aCompressAlgo: TAlgoCompress = nil; aHasher: THasher = nil); reintroduce; virtual;
+    {$ifdef HASGENERICS}
+    /// initialize the dictionary storage, specifying keys/values as generic types
+    // - just a convenient wrapper around TSynDictionary.Create()
+    // - consider IKeyValue<> from mormot.core.collections.pas, for more robust
+    // generics-based code where TKey/TValue are propagated to all methods
+    class function New(aKeyCaseInsensitive: boolean = false;
+      aTimeoutSeconds: cardinal = 0; aCompressAlgo: TAlgoCompress = nil;
+      aHasher: THasher = nil): TSynDictionary;
+        static; {$ifdef FPC} inline; {$endif}
+    {$endif HASGENERICS}
+    /// 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): PtrInt;
+    /// 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): PtrInt;
+    /// 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): PtrInt;
+    /// 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): PtrInt;
+    /// 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: PtrInt): 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(tix64: Int64 = 0): 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): PtrInt;
+    /// 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: PPtrInt = nil): pointer;
+    /// search of a primary key within the internal hashed dictionary
+    // - returns a pointer to the matching or already existing value 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: PPtrInt = 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;
+      var 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; var aValue): boolean;
+    /// search of a stored value, and return seconds since its timeout was set
+    // - returns -1 if aKey was not found
+    // - this method is thread-safe
+    function FindAndGetElapsedSeconds(const aKey): integer;
+    /// search of a stored value, and delete it if its timeout was set too long ago
+    // - returns true if aKey was found and deleted
+    // - returns false if aKey was not found or the entry not deprecated
+    // - this method is thread-safe
+    function FindAndDeleteDeprecated(const aKey; aSeconds: integer): 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;
+    /// search for a value presence
+    // - returns TRUE if aValue was found, FALSE if no match exists
+    // - this method is thread-safe, but will use O(n) slow browsing
+    function ExistsValue(const aValue; aCompare: TDynArraySortCompare = nil): 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 - if the callback modifies the data, set
+    // MayModify=true and call fSafe.Lock/UnLock when writing
+    function ForEach(const OnEach: TOnSynDictionary;
+      Opaque: pointer = nil; MayModify: boolean = true): 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 - if the callback modifies the data, set
+    // MayModify=true and call fSafe.Lock/UnLock when writing
+    function ForEach(const OnMatch: TOnSynDictionary;
+      KeyCompare, ValueCompare: TDynArraySortCompare; const aKey, aValue;
+      Opaque: pointer = nil; MayModify: boolean = true): 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 executed e.g.
+    // from a ForEach() TOnSynDictionary callback
+    procedure SetTimeoutAtIndex(aIndex: PtrInt);
+    /// 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;
+      aCompare: TDynArraySortCompare = nil): boolean;
+    /// search of a stored key by its associated key, and return a key local copy
+    // - won't use any hashed index but RTTI TDynArray.IndexOf search over
+    // over fValues() so is much slower than FindAndCopy() for huge arrays
+    // - will update the associated timeout value of the entry, unless
+    // aUpdateTimeOut is set to false
+    // - 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;
+      aCompare: TDynArraySortCompare = nil): 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, create the entry if not found,
+    //  then use TDynArray.Add to add aArrayValue to the associated dynamic array
+    // - returns FALSE if Values is not a tkDynArray
+    // - this method is thread-safe, since it will lock the instance
+    function AddInArrayForced(const aKey, aArrayValue;
+      aCompare: TDynArraySortCompare = nil): 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;
+      aCompare: TDynArraySortCompare = nil): 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;
+      aCompare: TDynArraySortCompare = nil): 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;
+      aCompare: TDynArraySortCompare = nil): boolean;
+    /// 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);
+    /// serialize the content as a "key":value JSON object
+    procedure SaveToJson(W: TJsonWriter; 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;
+      ReFormat: TTextWriterJsonFormat = jsonCompact): 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;
+      CustomVariantOptions: PDocVariantOptions = nil): boolean; overload;
+    /// unserialize the content from "key":value JSON object
+    // - note that input JSON buffer is not modified in place: no need to create
+    // a temporary copy if the buffer is about to be re-used
+    function LoadFromJson(Json: PUtf8Char;
+      CustomVariantOptions: PDocVariantOptions = nil): 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;
+      Algo: TAlgoCompress = nil): 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 before actual deletion
+    class function OnCanDeleteSynPersistentLock(
+      const aKey, aValue; aIndex: PtrInt): boolean;
+    {$ifndef PUREMORMOT2}
+    class function OnCanDeleteSynPersistentLocked(
+      const aKey, aValue; aIndex: PtrInt): boolean;
+    {$endif PUREMORMOT2}
+    /// 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 Count: 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
+    // - if you set a maximum size of this store (even a rough size), Add() are
+    // likely to be up to twice faster than letting the table grow by chunks
+    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()
+    // - warning: setting a new timeout will clear all previous content
+    property TimeOutSeconds: cardinal
+      read GetTimeOutSeconds write SetTimeOutSeconds;
+    /// 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: TOnSynDictionaryCanDelete
+      read fOnCanDelete write fOnCanDelete;
+    /// can tune TSynDictionary threading process depending on your use case
+    // - will redirect to the internal Safe TSynLocker instance
+    // - warning: to be set only before any process is done
+    // - advice: any performance impact should always be monitored, not guessed
+    property ThreadUse: TSynLockerUse
+      read GetThreadUse write SetThreadUse;
+  end;
+
+const
+  // TSynDictionary.fSafe.Padding[DIC_*] place holders - defined here for inlining
+  DIC_KEYCOUNT   = 0;   // Keys.Count integer
+  DIC_KEY        = 1;   // Key.Value pointer
+  DIC_VALUECOUNT = 2;   // Values.Count integer
+  DIC_VALUE      = 3;   // Values.Value pointer
+  DIC_TIMECOUNT  = 4;   // Timeouts.Count integer
+  DIC_TIMESEC    = 5;   // Timeouts Seconds integer
+  DIC_TIMETIX    = 6;   // last GetTickCount64 shr 10 integer
+
+
+{ ********** Low-level JSON Serialization for any kind of Values }
+
+type
+  /// internal stack-allocated structure for nested JSON serialization
+  // - defined here for low-level use within TRttiJsonSave functions
+  {$ifdef USERECORDWITHMETHODS}
+  TJsonSaveContext = record
+  {$else}
+  TJsonSaveContext = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// the associated stream writer for the JSON output
+    W: TJsonWriter;
+    /// serialization options as specified for this process
+    // - as used by AddShort/Add64/AddDateTime methods
+    Options: TTextWriterWriteObjectOptions;
+    /// the RTTI information of the current serialized type
+    Info: TRttiCustom;
+    /// the RTTI information of the current serialized property
+    // - is likely to be nil outside of properties serialization
+    Prop: PRttiCustomProp;
+    /// initialize this low-level JSON serialization context
+    procedure Init(WR: TJsonWriter;
+      WriteOptions: TTextWriterWriteObjectOptions; Rtti: TRttiCustom);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// some basic function to append a shorstring JSON value according to Options
+    procedure AddShort(PS: PShortString);
+    /// some basic function to append an Int64 JSON value according to Options
+    procedure Add64(Value: PInt64; UnSigned: boolean);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// some basic function to append a TDateTime JSON value according to Options
+    procedure AddDateTime(Value: PDateTime; WithMS: boolean);
+    /// some basic function to append a "name":boolean JSON pair value
+    procedure AddShortBoolean(PS: PShortString; Value: boolean);
+  end;
+
+  /// internal function handler for JSON persistence of any TRttiParserType value
+  // - i.e. the kind of functions called via PT_JSONSAVE[] lookup table
+  TRttiJsonSave = procedure(Data: pointer; const Ctxt: TJsonSaveContext);
+
+
+{ ********** Low-level JSON Unserialization for any kind of Values }
+
+type
+  /// store one name/value pair of raw UTF-8 content, from a JSON buffer
+  // - used e.g. by JsonDecode() overloaded function or UrlEncodeJsonObject()
+  // to returns names/values
+  TNameValuePUtf8Char = record
+    /// pointer and length to the actual UTF-8 name text
+    Name: TValuePUtf8Char;
+    /// pointer and length to the actual UTF-8 value text
+    Value: TValuePUtf8Char;
+  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 object for the supplied field 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 object for the supplied field names
+// - overloaded function expecting the names supplied as a constant array
+// - slightly faster than the one using "const Names: array of RawUtf8"
+function JsonDecode(P: PUtf8Char; Names: PPUtf8CharArray; NamesCount: integer;
+  Values: PValuePUtf8CharArray;
+  HandleValuesAsObjectOrArray: boolean = false): PUtf8Char; overload;
+
+/// decode the supplied UTF-8 JSON object 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 object for the one supplied field 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;
+  {$ifdef HASINLINE} inline; {$endif}
+
+  /// decode the supplied UTF-8 JSON object for the one supplied field name
+// - this function will decode and modify the input JSON buffer in-place
+function JsonDecode(Json: PUtf8Char; const aName: RawUtf8;
+  WasString: PBoolean; HandleValuesAsObjectOrArray: boolean): RawUtf8; overload;
+
+
+type
+  /// available options for JSON parsing process
+  // - by default, parsing will fail if a JSON field name is not part of the
+  // object published properties, unless jpoIgnoreUnknownProperty is defined -
+  // this option will also ignore read-only properties (i.e. with only a getter)
+  // - by default, function will check that the supplied JSON value will
+  // be a JSON string when the property is a string, unless jpoIgnoreStringType
+  // is defined and JSON numbers are accepted and stored as text
+  // - by default any unexpected value for enumerations will be marked as
+  // invalid, unless jpoIgnoreUnknownEnum is defined, so that in such case the
+  // ordinal 0 value is left, and loading continues
+  // - by default, only simple kind of variant types (string/numbers) are
+  // handled: set jpoHandleCustomVariants if you want to handle any custom -
+  // in this case , it will handle direct JSON [array] of {object}: but if you
+  // also define jpoHandleCustomVariantsWithinString, 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)
+  // - by default, a temporary instance will be created if a published field
+  // has a setter, and the instance is expected to be released later by the
+  // owner class: set jpoSetterExpectsToFreeTempInstance to let JsonParser
+  // (and TPropInfo.ClassFromJson) release it when the setter returns, and
+  // jpoSetterNoCreate to avoid the published field instance creation
+  // - set jpoAllowInt64Hex to let Int64/QWord fields accept hexadecimal string
+  // (as generated e.g. via the woInt64AsHex option)
+  // - by default, double values won't be stored as variant values, unless
+  // jpoAllowDouble is set - see also dvoAllowDoubleValue in TDocVariantOptions
+  // - jpoObjectListClassNameGlobalFindClass would also search for "ClassName":
+  // TObjectList serialized field with the global Classes.FindClass() function
+  // - null will release any class instance, unless jpoNullDontReleaseObjectInstance
+  // is set which will leave the instance untouched
+  // - values will be left untouched before parsing, unless jpoClearValues
+  // is defined, to void existing record fields or class published properties
+  TJsonParserOption = (
+    jpoIgnoreUnknownProperty,
+    jpoIgnoreStringType,
+    jpoIgnoreUnknownEnum,
+    jpoHandleCustomVariants,
+    jpoHandleCustomVariantsWithinString,
+    jpoSetterExpectsToFreeTempInstance,
+    jpoSetterNoCreate,
+    jpoAllowInt64Hex,
+    jpoAllowDouble,
+    jpoObjectListClassNameGlobalFindClass,
+    jpoNullDontReleaseObjectInstance,
+    jpoClearValues);
+
+  /// set of options for JsonParser() parsing process
+  TJsonParserOptions = set of TJsonParserOption;
+
+  /// efficient execution context of the JSON parser
+  // - defined here for low-level use of TRttiJsonLoad functions
+  // - inherit from TGetJsonField to include ParseNext/ParseNextAny unserialized
+  // Value/ValueLen and flags, and Json as current position in the JSON input
+  {$ifdef USERECORDWITHMETHODS}
+  TJsonParserContext = record
+  public
+    Get: TGetJsonField;
+    function Json: PUtf8Char;       {$ifdef HASINLINE} inline; {$endif}
+    function Value: PUtf8Char;      {$ifdef HASINLINE} inline; {$endif}
+    function ValueLen: PtrInt;      {$ifdef HASINLINE} inline; {$endif}
+    function WasString: boolean;    {$ifdef HASINLINE} inline; {$endif}
+    function EndOfObject: AnsiChar; {$ifdef HASINLINE} inline; {$endif}
+  {$else}
+  TJsonParserContext = object(TGetJsonField)
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// true if the last parsing succeeded
+    Valid: boolean;
+    /// customize parsing
+    Options: TJsonParserOptions;
+    /// how TDocVariant should be created
+    CustomVariant: PDocVariantOptions;
+    /// contains the current value RTTI
+    Info: TRttiCustom;
+    /// contains the current property value RTTI
+    Prop: PRttiCustomProp;
+    /// force the item class when reading a TObjectList without "ClassName":...
+    ObjectListItem: TRttiCustom;
+    /// optional RawUtf8 values interning
+    Interning: TRawUtf8Interning;
+    /// TDocVariant initialization options
+    DVO: TDocVariantOptions;
+    /// initialize this unserialization context
+    procedure InitParser(P: PUtf8Char; Rtti: TRttiCustom; O: TJsonParserOptions;
+      CV: PDocVariantOptions; ObjectListItemClass: TClass;
+      RawUtf8Interning: TRawUtf8Interning);
+    /// call inherited GetJsonField() to retrieve the next JSON value
+    // - on success, return true and set Value/ValueLen and WasString fields
+    function ParseNext: boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// call inherited GetJsonFieldOrObjectOrArray() to retrieve the next JSON value
+    // - on success, return true and set Value/ValueLen and WasString fields
+    function ParseNextAny: boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// retrieve the next JSON value as UTF-8 text
+    function ParseUtf8: RawUtf8;
+    /// retrieve the next JSON value as RTL string text
+    function ParseString: string;
+    /// retrieve the next JSON value as integer
+    function ParseInteger: Int64;
+    /// set the EndOfObject field of a JSON buffer, just like GetJsonField() does
+    // - to be called whan a JSON object or JSON array has been manually parsed
+    procedure ParseEndOfObject;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// parse a 'null' value from JSON buffer
+    function ParseNull: boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// parse initial '[' token from JSON buffer
+    // - once all the nested values have been read, call ParseEndOfObject
+    function ParseArray: boolean;
+    /// parse initial '{' token from JSON buffer
+    // - once all the nested values have been read, call ParseEndOfObject
+    function ParseObject: boolean; overload;
+    /// wrapper around JsonDecode() to easily get JSON object values
+    function ParseObject(const Names: array of RawUtf8;
+      Values: PValuePUtf8CharArray;
+      HandleValuesAsObjectOrArray: boolean = false): boolean; overload;
+    /// parse a JSON object from the buffer into a
+    // - if ObjectListItem was not defined, expect the JSON input to start as
+    // '{"ClassName":"TMyClass",...}'
+    function ParseNewObject: TObject;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// parse a property value, properly calling any setter
+    procedure ParsePropComplex(Data: pointer);
+  end;
+
+  PJsonParserContext = ^TJsonParserContext;
+
+  /// internal function handler for JSON reading of any TRttiParserType value
+  TRttiJsonLoad = procedure(Data: pointer; var Ctxt: TJsonParserContext);
+
+
+var
+  /// default options for the JSON parser
+  // - as supplied to LoadJson() with Tolerant=false
+  // - defined as var, not as const, to allow process-wide override
+  JSONPARSER_DEFAULTOPTIONS: TJsonParserOptions = [];
+
+  /// some open-minded options for the JSON parser
+  // - as supplied to LoadJson() with Tolerant=true
+  // - won't block JSON unserialization due to some minor unexpected values
+  // - used e.g. by TObjArraySerializer.CustomReader and
+  // TInterfacedObjectFake.FakeCall/TServiceMethodExecute.ExecuteJson methods
+  // - defined as var, not as const, to allow process-wide override
+  JSONPARSER_TOLERANTOPTIONS: TJsonParserOptions =
+    [jpoHandleCustomVariants, jpoIgnoreUnknownEnum,
+     jpoIgnoreUnknownProperty, jpoIgnoreStringType, jpoAllowInt64Hex];
+
+  /// access default (false) or tolerant (true) JSON parser options
+  // - to be used as JSONPARSER_DEFAULTORTOLERANTOPTIONS[tolerant]
+  JSONPARSER_DEFAULTORTOLERANTOPTIONS: array[boolean] of TJsonParserOptions = (
+    [],
+    [jpoHandleCustomVariants, jpoIgnoreUnknownEnum,
+     jpoIgnoreUnknownProperty, jpoIgnoreStringType, jpoAllowInt64Hex]);
+
+// backward compatibility types redirections
+{$ifndef PUREMORMOT2}
+
+type
+  TJsonToObjectOption = TJsonParserOption;
+  TJsonToObjectOptions = TJsonParserOptions;
+
+const
+  j2oSQLRawBlobAsBase64 = woRawBlobAsBase64;
+  j2oIgnoreUnknownProperty = jpoIgnoreUnknownProperty;
+  j2oIgnoreStringType = jpoIgnoreStringType;
+  j2oIgnoreUnknownEnum = jpoIgnoreUnknownEnum;
+  j2oHandleCustomVariants = jpoHandleCustomVariants;
+  j2oHandleCustomVariantsWithinString = jpoHandleCustomVariantsWithinString;
+  j2oSetterExpectsToFreeTempInstance = jpoSetterExpectsToFreeTempInstance;
+  j2oSetterNoCreate = jpoSetterNoCreate;
+  j2oAllowInt64Hex = jpoAllowInt64Hex;
+
+const
+  JSONTOOBJECT_TOLERANTOPTIONS: TJsonParserOptions =
+    [jpoHandleCustomVariants, jpoIgnoreUnknownEnum,
+     jpoIgnoreUnknownProperty, jpoIgnoreStringType, jpoAllowInt64Hex];
+
+{$endif PUREMORMOT2}
+
+
+{ ********** Custom JSON Serialization }
+
+type
+  /// the callback signature used by TRttiJson for serializing JSON data
+  // - Data^ should be written into W, with the supplied Options
+  TOnRttiJsonWrite = procedure(W: TJsonWriter; Data: pointer;
+    Options: TTextWriterWriteObjectOptions) of object;
+
+  /// the callback signature used by TRttiJson for unserializing JSON data
+  // - set Context.Valid=true if Context.JSON has been parsed into Data^
+  TOnRttiJsonRead = procedure(var Context: TJsonParserContext;
+    Data: pointer) of object;
+
+  /// the callback signature used by TRttiJson for serializing JSON classes
+  // - Instance should be written into W, with the supplied Options
+  // - is in fact a convenient alias to the TOnRttiJsonWrite callback
+  TOnClassJsonWrite = procedure(W: TJsonWriter; Instance: TObject;
+    Options: TTextWriterWriteObjectOptions) of object;
+
+  /// the callback signature used by TRttiJson for unserializing JSON classes
+  // - set Context.Valid=true if Context.JSON has been parsed into Instance
+  // - is in fact a convenient alias to the TOnRttiJsonRead callback
+  TOnClassJsonRead = procedure(var Context: TJsonParserContext;
+    Instance: TObject) of object;
+
+  /// JSON-aware TRttiCustom class - used for global RttiCustom: TRttiCustomList
+  TRttiJson = class(TRttiCustom)
+  protected
+    fCompare: array[{CaseInsens:}boolean] of TRttiCompare; // for ValueCompare
+    fIncludeReadOptions: TJsonParserOptions;
+    fIncludeWriteOptions: TTextWriterWriteObjectOptions;
+    // overriden for proper JSON process - set fJsonSave and fJsonLoad
+    function SetParserType(aParser: TRttiParserType;
+      aParserComplex: TRttiParserComplexType): TRttiCustom; override;
+    procedure SetValueClass(aClass: TClass; aInfo: PRttiInfo); override;
+  public
+    /// simple wrapper around TRttiJsonSave(fJsonSave)
+    procedure RawSaveJson(Data: pointer; const Ctxt: TJsonSaveContext);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// simple wrapper around TRttiJsonLoad(fJsonLoad)
+    procedure RawLoadJson(Data: pointer; var Ctxt: TJsonParserContext);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// create and parse a new TObject instance of this rkClass
+    function ParseNewInstance(var Context: TJsonParserContext): TObject;
+    /// compare two stored values of this type
+    function ValueCompare(Data, Other: pointer; CaseInsensitive: boolean): integer; override;
+    /// fill a variant with a stored value of this type
+    // - complex values can be returned as TDocVariant after JSON conversion,
+    // using e.g. @JSON_[mFast] as optional Options parameter
+    function ValueToVariant(Data: pointer; out Dest: TVarData;
+      Options: pointer{PDocVariantOptions} = nil): PtrInt; override;
+    /// unserialize some JSON input into Data^
+    // - as used by LoadJson() and similar high-level functions
+    procedure ValueLoadJson(Data: pointer; var Json: PUtf8Char; EndOfObject: PUtf8Char;
+      ParserOptions: TJsonParserOptions; CustomVariantOptions: PDocVariantOptions;
+      ObjectListItemClass: TClass; Interning: TRawUtf8Interning);
+    /// how many iterations could be done one a given value
+    // - returns -1 if the value is not iterable, or length(DynArray) or
+    // TRawUtf8List.Count or TList.Count or TSynList.Count
+    // - note that TStrings values are not supported, because they require a
+    // temporary string variable for their getter
+    function ValueIterateCount(Data: pointer): integer; override;
+    /// iterate over one sub-item of a given value
+    // - returns nil if the value is not iterable or Index is out of range
+    // - returns a pointer to the value, rkClass/rkLString kinds being already
+    // resolved (as the TList/TSynList/TRawUtf8List items are returned),
+    // so you can directly trans-type the result to TObject() or RawUtf8()
+    // - ResultRtti holds the type of the resolved result pointer
+    // - note that TStrings values are not supported, because they require a
+    // temporary string variable for their getter method
+    function ValueIterate(Data: pointer; Index: PtrUInt;
+      out ResultRtti: TRttiCustom): pointer; override;
+    /// lookup a value by a path name e.g. 'one.two.three' nested values
+    // - for a record/class, will search for a property name
+    // - for a TDocVariant/TBsonVariant, calls TSynInvokeableVariantType.IntGet
+    // - for an enumeration or set, will return true/false about the enum name
+    // - for a string, Data^ will be compared to the name
+    function ValueByPath(var Data: pointer; Path: PUtf8Char; var Temp: TVarData;
+      PathDelim: AnsiChar = '.'): TRttiCustom; override;
+    /// efficient search of TRttiJson from a given RTTI TypeInfo()
+    // - to be used instead of Rtti.Find() to return directly the TRttiJson instance
+    class function Find(Info: PRttiInfo): TRttiJson;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// register a custom callback for JSON serialization of a given TypeInfo()
+    // - for a dynamic array, will customize the item serialization callbacks
+    // - replace deprecated TTextWriter.RegisterCustomJSONSerializer() method
+    class function RegisterCustomSerializer(Info: PRttiInfo;
+      const Reader: TOnRttiJsonRead; const Writer: TOnRttiJsonWrite): TRttiJson;
+    /// unregister any custom callback for JSON serialization of a given TypeInfo()
+    // - will also work after RegisterFromText()
+    class function UnRegisterCustomSerializer(Info: PRttiInfo): TRttiJson;
+    /// register a custom callback for JSON serialization of a given class
+    // - replace deprecated TTextWriter.RegisterCustomJSONSerializer() method
+    class function RegisterCustomSerializerClass(ObjectClass: TClass;
+      const Reader: TOnClassJsonRead; const Writer: TOnClassJsonWrite): TRttiJson;
+    /// unregister any custom callback for JSON serialization of a given class
+    class function UnRegisterCustomSerializerClass(ObjectClass: TClass): TRttiJson;
+    /// register TypeInfo() custom JSON serialization for a given dynamic
+    // array or record
+    // - to be used instead of homonomous Rtti.RegisterFromText() to supply
+    // an additional set of serialization/unserialization JSON options
+    class function RegisterFromText(DynArrayOrRecord: PRttiInfo;
+      const RttiDefinition: RawUtf8;
+      IncludeReadOptions: TJsonParserOptions;
+      IncludeWriteOptions: TTextWriterWriteObjectOptions): TRttiJson;
+    /// define an additional set of unserialization JSON options
+    // - is included for this type to the supplied TJsonParserOptions
+    property IncludeReadOptions: TJsonParserOptions
+      read fIncludeReadOptions write fIncludeReadOptions;
+    /// define an additional set of serialization JSON options
+    // - is included for this type to the supplied TTextWriterWriteObjectOptions
+    property IncludeWriteOptions: TTextWriterWriteObjectOptions
+      read fIncludeWriteOptions write fIncludeWriteOptions;
+  end;
+
+
+{ ********** JSON Serialization Wrapper Functions }
+
+/// 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;
+
+/// 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 mormot.db.nosql.bson 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;
+
+/// 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 TJsonWriter.AddQuotedStringAsJson()
+procedure JsonEncodeNameSQLValue(const Name, SQLValue: RawUtf8;
+  var result: RawUtf8);
+
+
+var
+  /// the options used by TObjArraySerializer, TInterfacedObjectFake and
+  // TServiceMethodExecute when serializing values as JSON
+  // - used as DEFAULT_WRITEOPTIONS[DontStoreVoidJson]
+  // - you can modify this global variable to customize the whole process
+  DEFAULT_WRITEOPTIONS: array[boolean] of TTextWriterWriteObjectOptions = (
+    [woDontStoreDefault, woRawBlobAsBase64],
+    [woDontStoreDefault, woDontStoreVoid, woRawBlobAsBase64]);
+
+  /// the options used by TSynJsonFileSettings.SaveIfNeeded
+  // - you can modify this global variable to customize the whole process
+  SETTINGS_WRITEOPTIONS: TTextWriterWriteObjectOptions =
+    [woHumanReadable, woStoreStoredFalse, woHumanReadableFullSetsAsStar,
+     woHumanReadableEnumSetAsComment, woInt64AsHex];
+
+  /// the options used by TServiceFactoryServer.OnLogRestExecuteMethod
+  // - you can modify this global variable to customize the whole process
+  SERVICELOG_WRITEOPTIONS: TTextWriterWriteObjectOptions =
+    [woDontStoreDefault, woDontStoreVoid, woHideSensitivePersonalInformation];
+
+
+/// serialize most kind of content as JSON, using its RTTI
+// - is just a wrapper around TJsonWriter.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: PRttiInfo;
+  Options: TTextWriterOptions; var result: RawUtf8;
+  ObjectOptions: TTextWriterWriteObjectOptions = []); overload;
+
+/// serialize most kind of content as JSON, using its RTTI
+// - is just a wrapper around TJsonWriter.AddTypedJson()
+function SaveJson(const Value; TypeInfo: PRttiInfo;
+  EnumSetsAsText: boolean): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// serialize most kind of content as JSON, using its RTTI
+function SaveJson(const Value; TypeInfo: PRttiInfo): RawUtf8; overload;
+
+/// serialize most kind of content as JSON, using its RTTI and a type name
+// - could be used if you know the type name and not the TypeInfo()
+// - will use Rtti.RegisterTypeFromName() so the type should be known, i.e. be
+// a simple type, or have been alredy registered
+// - returns '' if TypeName is not recognized
+function SaveJson(const Value; const TypeName: RawUtf8;
+  Options: TTextWriterOptions = []): RawUtf8; overload;
+
+{$ifdef FPC}
+/// special global function exported to Lazarus for runtime evaluation, within
+// latest trunk fpdebug, of any variable as JSON, using mORMot RTTI
+// - the "JsonForDebug" function name is recognized by recent fpdebug, and
+// called and try to serialize a variable as JSON in Lazarus debug windows - see
+// https://wiki.freepascal.org/IDE_Window:_Ide_Options_-_Backend_Value_Converter
+// - this function will recognize 1) all type names registered to mORMot RTTI
+// (using Rtti.Register*() methods), 2) T* class types guessing from their VMT,
+// 3) I* types recognized as interface, and their associated "as TObject" class
+// instance will be serialized
+procedure JsonForDebug(Value: pointer; var TypeName: RawUtf8;
+  out JsonResultText: RawUtf8);
+{$endif FPC}
+
+/// save record into its JSON serialization as saved by TJsonWriter.AddRecordJson
+// - will use default Base64 encoding over RecordSave() binary - or custom true
+// JSON format (as set by Rtti.RegisterFromText/TRttiJson.RegisterCustomSerializer
+// or via enhanced RTTI), if available (following EnumSetsAsText optional
+// parameter for nested enumerates and sets)
+function RecordSaveJson(const Rec; TypeInfo: PRttiInfo;
+  EnumSetsAsText: boolean = false): RawUtf8;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// serialize a dynamic array content as JSON
+// - Value shall be set to the source dynamic array field
+// - is just a wrapper around TJsonWriter.AddDynArrayJson(), creating
+// a temporary TDynArray wrapper on the stack
+// - to be used e.g. for custom record JSON serialization, within a
+// TDynArrayJsonCustomWriter callback or Rtti.RegisterFromText()
+// (following EnumSetsAsText optional parameter for nested enumerates and sets)
+function DynArraySaveJson(const Value; TypeInfo: PRttiInfo;
+  EnumSetsAsText: boolean = false): RawUtf8;
+
+/// 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 TJsonWriter.AddDynArrayJson(), creating
+// a temporary TDynArray wrapper on the stack
+// - to be used e.g. for custom record JSON serialization, within a
+// TDynArrayJsonCustomWriter callback or Rtti.RegisterFromText()
+function DynArrayBlobSaveJson(TypeInfo: PRttiInfo; BlobValue: pointer;
+  BlobLen: PtrInt): RawUtf8;
+
+/// wrapper to serialize a T*ObjArray dynamic array as JSON
+// - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
+function ObjArrayToJson(const aObjArray;
+  aOptions: TTextWriterWriteObjectOptions = [woDontStoreDefault]): RawUtf8;
+
+/// will serialize set of TObject into its UTF-8 JSON representation
+// - follows ObjectToJson()/TJsonWriter.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;
+
+/// persist a class instance into a JSON file
+// - returns TRUE on success, false on error (e.g. the file name is invalid
+// or the file is existing and could not be overwritten)
+// - see ObjectToJson() as defined in momrot.core.text.pas
+function ObjectToJsonFile(Value: TObject; const JsonFile: TFileName;
+  Options: TTextWriterWriteObjectOptions = [woHumanReadable]): boolean;
+
+/// get any (potentially nested) object property by path
+// - complex values (e.g. dynamic array properties) will be returned as
+// TDocVariant after JSON conversion
+function GetValueObject(Instance: TObject; const Path: RawUtf8;
+  out Value: variant): boolean;
+
+/// unserialize most kind of content as JSON, using its RTTI, as saved by
+// TJsonWriter.AddRecordJson / RecordSaveJson
+// - same implementation than GetDataFromJson() global low-level function
+// - returns nil on error, or the end of buffer on success
+// - warning: the JSON buffer will be modified in-place during process - use
+// LoadJson() instead or a make temporary copy if you need to access it later
+function LoadJsonInPlace(var Value; Json: PUtf8Char; TypeInfo: PRttiInfo;
+  EndOfObject: PUtf8Char = nil; CustomVariantOptions: PDocVariantOptions = nil;
+  Tolerant: boolean = true; Interning: TRawUtf8Interning = nil): PUtf8Char;
+
+/// unserialize most kind of content as JSON, using its RTTI, as saved by
+// TJsonWriter.AddRecordJson / RecordSaveJson
+// - this overloaded function will make a private copy before parsing it,
+// so is safe with a read/only or shared string - but slightly slower
+function LoadJson(var Value; const Json: RawUtf8; TypeInfo: PRttiInfo;
+  EndOfObject: PUtf8Char = nil; CustomVariantOptions: PDocVariantOptions = nil;
+  Tolerant: boolean = true; Interning: TRawUtf8Interning = nil): boolean;
+
+/// fill a record content from a JSON serialization as saved by
+// TJsonWriter.AddRecordJson / RecordSaveJson
+// - will use default Base64 encoding over RecordSave() binary - or custom
+// JSON format (as set by Rtti.RegisterFromText/TRttiJson.RegisterCustomSerializer
+// or via enhanced RTTI), if available
+// - returns nil on error, or the end of buffer on success
+// - warning: the JSON buffer will be modified in-place during process - use
+// a temporary copy if you need to access it later or if the string comes from
+// a constant (refcount=-1) - see e.g. the overloaded RecordLoadJson()
+function RecordLoadJson(var Rec; Json: PUtf8Char; TypeInfo: PRttiInfo;
+  EndOfObject: PUtf8Char = nil; CustomVariantOptions: PDocVariantOptions = nil;
+  Tolerant: boolean = true; Interning: TRawUtf8Interning = nil): PUtf8Char; overload;
+
+/// fill a record content from a JSON serialization as saved by
+// TJsonWriter.AddRecordJson / RecordSaveJson
+// - this overloaded function will make a private copy before parsing it,
+// so is safe with a read/only or shared string - but slightly slower
+function RecordLoadJson(var Rec; const Json: RawUtf8; TypeInfo: PRttiInfo;
+  CustomVariantOptions: PDocVariantOptions = nil;
+  Tolerant: boolean = true; Interning: TRawUtf8Interning = nil): boolean; overload;
+
+/// fill a dynamic array content from a JSON serialization as saved by
+// TJsonWriter.AddDynArrayJson with or without twoNonExpandedArrays layout
+// - Value shall be set to the target dynamic array field
+// - return a pointer at the end of the data read from JSON, nil in case
+// of an invalid input buffer
+// - could be used e.g. for custom record JSON unserialization, within a
+// TDynArrayJsonCustomReader callback
+// - warning: the JSON buffer will be modified in-place during process - use
+// a temporary copy if you need to access it later or if the string comes from
+// a constant (refcount=-1) - see e.g. the overloaded DynArrayLoadJson()
+// - some numbers on a Core i5-13500, extracted from our regression tests:
+// $ DynArrayLoadJson exp in 32.86ms i.e. 4.7M rows/s, 596.5 MB/s
+// $ DynArrayLoadJson non exp in 22.46ms i.e. 6.9M rows/s, 383.7 MB/s
+function DynArrayLoadJson(var Value; Json: PUtf8Char; TypeInfo: PRttiInfo;
+  EndOfObject: PUtf8Char = nil; CustomVariantOptions: PDocVariantOptions = nil;
+  Tolerant: boolean = true; Interning: TRawUtf8Interning = nil): PUtf8Char; overload;
+
+/// fill a dynamic array content from a JSON serialization as saved by
+// TJsonWriter.AddDynArrayJson, which won't be modified
+// - this overloaded function will make a private copy before parsing it,
+// so is safe with a read/only or shared string - but slightly slower
+function DynArrayLoadJson(var Value; const Json: RawUtf8;
+  TypeInfo: PRttiInfo; CustomVariantOptions: PDocVariantOptions = nil;
+  Tolerant: boolean = true; Interning: TRawUtf8Interning = nil): boolean; overload;
+
+/// read an object properties, as saved by ObjectToJson function
+// - ObjectInstance must be an existing TObject instance
+// - the data inside From^ is modified in-place (unescaped and transformed):
+// calling JsonToObject(pointer(JSONRawUtf8)) will change the JSONRawUtf8
+// variable content, which may not be what you expect - consider using the
+// ObjectLoadJson() function instead
+// - handle integer, Int64, enumerate (including boolean), set, floating point,
+// TDateTime, TCollection, TStrings, TRawUtf8List, variant, and string properties
+// (excluding ShortString, but including WideString and UnicodeString under
+// Delphi 2009+)
+// - TList won't be handled since it may leak memory when calling TList.Clear
+// - won't handle TObjectList (even if ObjectToJson is able to serialize
+// them) since has no way of knowing the object type to add (TCollection.Add
+// is missing), unless: 1. you set the TObjectListItemClass property as expected,
+// and provide a TObjectList object, or 2. woStoreClassName option has been
+// used at ObjectToJson() call and the corresponding classes have been previously
+// registered by Rtti.RegisterClass()
+// - will clear any previous TCollection objects, and convert any null JSON
+// basic type into nil - e.g. if From='null', will call FreeAndNil(Value)
+// - you can add some custom (un)serializers for ANY class, via mormot.core.json
+// TRttiJson.RegisterCustomSerializer() class method
+// - set Valid=TRUE on success, Valid=FALSE on error, and the main function
+// will point in From at the syntax error place (e.g. on any unknown property name)
+// - caller should explicitly perform a SetDefaultValuesObject(Value) if
+// the default values are expected to be set before JSON parsing
+function JsonToObject(var ObjectInstance; From: PUtf8Char;
+  out Valid: boolean; TObjectListItemClass: TClass = nil;
+  Options: TJsonParserOptions = []; Interning: TRawUtf8Interning = nil): PUtf8Char;
+
+/// parse the supplied JSON with some tolerance about Settings format
+// - will make a TSynTempBuffer copy for parsing, and un-comment it
+// - returns true if the supplied JSON was successfully retrieved
+// - returns false on error
+function JsonSettingsToObject(const JsonContent: RawUtf8;
+  Instance: TObject): boolean;
+
+/// read an object properties, as saved by ObjectToJson function
+// - ObjectInstance must be an existing TObject instance
+// - this overloaded version will make a private copy of the supplied JSON
+// content (via TSynTempBuffer), to ensure the original buffer won't be modified
+// during process, before calling safely JsonToObject()
+// - will return TRUE on success, or FALSE if the supplied JSON was invalid
+function ObjectLoadJson(var ObjectInstance; const Json: RawUtf8;
+  TObjectListItemClass: TClass = nil; Options: TJsonParserOptions = [];
+  Interning: TRawUtf8Interning = nil): boolean;
+
+/// create a new object instance, as saved by ObjectToJson(...,[...,woStoreClassName,...]);
+// - JSON input should be either 'null', either '{"ClassName":"TMyClass",...}'
+// - woStoreClassName option shall have been used at ObjectToJson() call
+// - and the corresponding class shall have been previously registered by
+// Rtti.RegisterClass() to retrieve the class type from it name
+// - the data inside From^ is modified in-place (unescaped and transformed):
+// don't call JsonToObject(pointer(JSONRawUtf8)) but makes a temporary copy of
+// the JSON text buffer before calling this function, if want to reuse it later
+function JsonToNewObject(var From: PUtf8Char; var Valid: boolean;
+  Options: TJsonParserOptions = []; Interning: TRawUtf8Interning = nil): TObject;
+
+/// read an TObject published property, as saved by ObjectToJson() function
+// - will use direct in-memory reference to the object, or call the corresponding
+// setter method (if any), creating a temporary instance
+// - unserialize the JSON input buffer via a call to JsonToObject()
+// - by default, a temporary instance will be created if a published field
+// has a setter, and the instance is expected to be released later by the
+// owner class: you can set the j2oSetterExpectsToFreeTempInstance option
+// to let this method release it when the setter returns
+function PropertyFromJson(Prop: PRttiCustomProp; Instance: TObject;
+  From: PUtf8Char; var Valid: boolean; Options: TJsonParserOptions = [];
+  Interning: TRawUtf8Interning = nil): PUtf8Char;
+
+/// decode a specified parameter compatible with URI encoding into its original
+// object contents
+// - ObjectInstance must be an existing TObject instance
+// - will call internally JsonToObject() function to unserialize its content
+// - 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 UrlDecodeObject(U: PUtf8Char; Upper: PAnsiChar;
+  var ObjectInstance; Next: PPUtf8Char = nil;
+  Options: TJsonParserOptions = []): boolean;
+
+/// fill the object properties from a JSON file content
+// - ObjectInstance must be an existing TObject instance
+// - this function will call RemoveCommentsFromJson() before process
+function JsonFileToObject(const JsonFile: TFileName; var ObjectInstance;
+  TObjectListItemClass: TClass = nil; Options: TJsonParserOptions = [];
+  Interning: TRawUtf8Interning = nil): boolean;
+
+
+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 TJsonWriter.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 TJsonWriter.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;
+
+
+{ ********************* Abstract Classes with Auto-Create-Fields }
+
+/// should be called by T*AutoCreateFields constructors
+// - will also register this class type, if needed, so RegisterClass() is
+// redundant to this method
+function AutoCreateFields(ObjectInstance: TObject): TRttiJson;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// should be called by T*AutoCreateFields destructors
+// - constructor should have called AutoCreateFields()
+procedure AutoDestroyFields(ObjectInstance: TObject; Info: TRttiJson = nil);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// internal function called by AutoCreateFields() when inlined
+// - do not call this internal function, but always AutoCreateFields()
+function DoRegisterAutoCreateFields(ObjectInstance: TObject): TRttiJson;
+
+
+type
+  /// abstract TPersistent class, which will instantiate all its nested class
+  // published properties, then release them (and any T*ObjArray) when freed
+  // - TSynAutoCreateFields is to be preferred in most cases, thanks to its
+  // lower overhead
+  // - note that non published (e.g. public) properties won't be instantiated,
+  // serialized, nor released - but may contain weak references to other classes
+  // - please take care that you will not create any endless recursion: you should
+  // ensure that at one level, nested published properties won't have any class
+  // instance refering to its owner (there is no weak reference - remember!)
+  // - since the destructor will release all nested properties, you should
+  // never store a reference to any of those nested instances if this owner
+  // may be freed before
+  TPersistentAutoCreateFields = class(TPersistentWithCustomCreate)
+  public
+    /// this overriden constructor will instantiate all its nested
+    // class or T*ObjArray published properties
+    constructor Create; override;
+    /// finalize the instance, and its class or T*ObjArray published properties
+    destructor Destroy; override;
+  end;
+
+  /// our own empowered TPersistentAutoCreateFields-like parent class
+  // - this class is a perfect parent to store any data by value, e.g. DDD Value
+  // Objects, Entities or Aggregates
+  // - is defined as an abstract class able with a virtual constructor, RTTI
+  // for published properties, and automatic memory management of all nested
+  // class published properties: any class defined as a published property will
+  // be owned by this instance - i.e. with strong reference
+  // - will also release any T*ObjArray dynamic array storage of persistents,
+  // previously registered via Rtti.RegisterObjArray() for Delphi 7-2009
+  // - nested published classes (or T*ObjArray) don't need to inherit from
+  // TSynAutoCreateFields: they may be from any TPersistent/TSynPersistent type
+  // - note that non published (e.g. public) properties won't be instantiated,
+  // serialized, nor released - but may contain weak references to other classes
+  // - please take care that you will not create any endless recursion: you should
+  // ensure that at one level, nested published properties won't have any class
+  // instance refering to its owner (there is no weak reference - remember!)
+  // - since the destructor will release all nested properties, you should
+  // never store a reference to any of those nested instances if this owner
+  // may be freed before
+  // - TPersistent/TPersistentAutoCreateFields have an unexpected speed overhead
+  // due a giant lock introduced to manage property name fixup resolution
+  // (which we won't use outside the UI) - this class is definitively faster
+  TSynAutoCreateFields = class(TSynPersistent)
+  public
+    /// this overriden constructor will instantiate all its nested
+    // class or T*ObjArray published properties
+    constructor Create; override;
+    /// finalize the instance, and its class or T*ObjArray published properties
+    destructor Destroy; override;
+  end;
+  /// meta-class definition of TSynAutoCreateFields
+  TSynAutoCreateFieldsClass = class of TSynAutoCreateFields;
+
+  /// adding locking methods to a TSynAutoCreateFields with virtual constructor
+  TSynAutoCreateFieldsLocked = class(TSynPersistentLock)
+  public
+    /// initialize the object instance, its associated lock, and its nested
+    // class or T*ObjArray published properties
+    constructor Create; override;
+    /// release the instance (including the locking resource) and nested classes
+    destructor Destroy; override;
+  end;
+  /// meta-class definition of TSynAutoCreateFieldsLocked
+  TSynAutoCreateFieldsLockedClass = class of TSynAutoCreateFieldsLocked;
+
+  /// abstract TInterfacedObject class, which will instantiate all its nested
+  // class published properties, then release them when freed
+  // - will handle automatic memory management of all nested class and T*ObjArray
+  // published properties: any class or T*ObjArray defined as a published
+  // property will be owned by this instance - i.e. with strong reference
+  // - non published properties (e.g. public) won't be instantiated, so may
+  // store weak class references
+  // - could be used for gathering of TCollectionItem properties, e.g. for
+  // Domain objects in DDD, especially for list of value objects, with some
+  // additional methods defined by an Interface
+  // - since the destructor will release all nested properties, you should
+  // never store a reference to any of those nested instances if this owner
+  // may be freed before
+  TInterfacedObjectAutoCreateFields = class(TInterfacedObjectWithCustomCreate)
+  public
+    /// this overriden constructor will instantiate all its nested
+    // class or T*ObjArray published properties
+    constructor Create; override;
+    /// finalize the instance, and release its published properties
+    destructor Destroy; override;
+  end;
+  /// meta-class definition of TInterfacedObjectAutoCreateFields
+  TInterfacedObjectAutoCreateFieldsClass = class of TInterfacedObjectAutoCreateFields;
+
+  /// abstract interface parent with common methods for JSON serialization
+  // - to implement this, you can inherit from TInterfacedSerializable
+  // or TInterfacedSerializableAutoCreateFields
+  ISerializable = interface
+    ['{EA7F298D-06D7-4ADF-9F75-6598B75338B3}']
+    // methods used as getter/setter for the Json property
+    function GetJson: RawUtf8;
+    procedure SetJson(const value: RawUtf8);
+    /// serialize this instance into a JSON array/object specific format
+    function ToJson(format: TTextWriterJsonFormat;
+      options: TTextWriterWriteObjectOptions = []): RawUtf8; overload;
+    /// convert this instance into JSON array/object as RTL string
+    function ToString(format: TTextWriterJsonFormat = jsonCompact;
+      options: TTextWriterWriteObjectOptions = []): string;
+    /// raw unserialization of a JSON content into this instance
+    procedure FromJson(var Context: TJsonParserContext);
+    /// raw serialization of this instance into a JSON writer
+    procedure ToJson(W: TJsonWriter; options: TTextWriterWriteObjectOptions); overload;
+    /// unserialize/serialize this IDocList/IDocDict from/into a JSON array/object
+    // - use ToString if you want the result as RTL string
+    property Json: RawUtf8
+      read GetJson write SetJson;
+  end;
+
+  {$M+}
+  /// abstract class parent with ISerializable methods for JSON serialization
+  // - you need to override Create, ToJson and FromJson abstract methods
+  TInterfacedSerializable = class(TInterfacedObject, ISerializable)
+  protected
+    // methods used as getter/setter for the Json property
+    function GetJson: RawUtf8;
+    procedure SetJson(const value: RawUtf8); virtual;
+    // used internally for proper ISerializable instances serialization
+    class function SerializableInterface: TRttiCustom;
+      {$ifdef HASINLINE} inline; {$endif}
+    class procedure JS(W: TJsonWriter; data: pointer;
+      options: TTextWriterWriteObjectOptions);
+    class procedure JL(var context: TJsonParserContext; data: pointer);
+  public
+    /// factory of one class implementing a ISerializable interface
+    // - this abstract method must be overriden
+    constructor Create(options: PDocVariantOptions); reintroduce; virtual; abstract;
+    /// raw serialization of this instance into a JSON writer
+    // - this abstract method must be overriden
+    procedure ToJson(W: TJsonWriter;
+      options: TTextWriterWriteObjectOptions); overload; virtual; abstract;
+    /// raw unserialization of a JSON content into this instance
+    // - this abstract method must be overriden
+    procedure FromJson(var context: TJsonParserContext); virtual; abstract;
+  public
+    /// register this class to implement a given ISerializer sub-interface
+    class function RegisterToRtti(InterfaceInfo: PRttiInfo): TRttiJson;
+    /// return the associated ISerializer sub-interface TGuid
+    // - as registered by RegisterToRtti() class method
+    class function Guid: PGuid;
+    /// create a new instance as the associated ISerializer sub-interface
+    // - as registered by RegisterToRtti() class method
+    class procedure NewInterface(out Obj);
+    /// serialize this instance into a JSON array/object specific format
+    function ToJson(format: TTextWriterJsonFormat;
+      options: TTextWriterWriteObjectOptions): RawUtf8; overload; virtual;
+    /// convert this instance into JSON array/object as RTL string
+    function ToString(format: TTextWriterJsonFormat;
+      options: TTextWriterWriteObjectOptions): string; reintroduce; virtual;
+    /// unserialize/serialize this instance from/into a JSON array/object
+    // - use ToString if you want the result as RTL string
+    property Json: RawUtf8
+      read GetJson write SetJson;
+  end;
+  {$M-}
+  /// meta-class of the TInterfacedSerializable type
+  TInterfacedSerializableClass = class of TInterfacedSerializable;
+  /// points to a TInterfacedSerializable class instance
+  PInterfacedSerializable = ^TInterfacedSerializable;
+
+  /// abstract ISerializable class parent with auto-create published fields
+  // - you should inherit this class, associated with an interface inheriting
+  // from ISerializable (and propably with a method returning self to access the
+  // properties), then call once the RegisterToRtti() class function
+  // - could be used e.g. to implement a DDD/KDD Aggregate object with both
+  // ref-counted data and methods, ready to be serialized over SOA
+  TInterfacedSerializableAutoCreateFields = class(TInterfacedSerializable)
+  protected
+    fRttiJson: TRttiJson;
+  public
+    /// instantiate all nested  class or T*ObjArray published properties
+    constructor Create(options: PDocVariantOptions = nil); override;
+    /// finalize the instance, and release its published properties
+    destructor Destroy; override;
+    /// raw JSON serialization of the published properties of this instance
+    procedure ToJson(W: TJsonWriter; options: TTextWriterWriteObjectOptions); override;
+    /// raw JSON unserialization into the published properties of this instance
+    procedure FromJson(var context: TJsonParserContext); override;
+    /// low-level access to the RTTI information associated with this class
+    property RttiJson: TRttiJson
+      read fRttiJson;
+  end;
+
+  /// abstract TCollectionItem class, which will instantiate all its nested class
+  // published properties, then release them (and any T*ObjArray) when freed
+  // - could be used for gathering of TCollectionItem properties, e.g. for
+  // Domain objects in DDD, especially for list of value objects
+  // - consider using T*ObjArray dynamic array published properties in your
+  // value types instead of TCollection storage: T*ObjArray have a lower overhead
+  // and are easier to work with, once Rtti.RegisterObjArray is called on Delphi
+  // 7-2009 to register the T*ObjArray type (not needed on FPC and Delphi 2010+)
+  // - note that non published (e.g. public) properties won't be instantiated,
+  // serialized, nor released - but may contain weak references to other classes
+  // - please take care that you will not create any endless recursion: you should
+  // ensure that at one level, nested published properties won't have any class
+  // instance refering to its owner (there is no weak reference - remember!)
+  // - since the destructor will release all nested properties, you should
+  // never store a reference to any of those nested instances if this owner
+  // may be freed before
+  TCollectionItemAutoCreateFields = class(TCollectionItem)
+  public
+    /// this overriden constructor will instantiate all its nested
+    // class or T*ObjArray published properties
+    constructor Create(Collection: TCollection); override;
+    /// finalize the instance, and release its published properties
+    destructor Destroy; override;
+  end;
+
+  /// customize TSynJsonFileSettings process
+  // - fsoDisableSaveIfNeeded will disable SaveIfNeeded method process
+  // - fsoReadIni will disable JSON loading, and expect INI file format
+  // - fsoWriteIni will force SaveIfNeeded to use the INI layout
+  TSynJsonFileSettingsOption = (
+    fsoDisableSaveIfNeeded,
+    fsoReadIni,
+    fsoWriteIni);
+  TSynJsonFileSettingsOptions = set of TSynJsonFileSettingsOption;
+
+  /// abstract parent class able to store settings as JSON file
+  // - would fallback and try to read as INI file if no valid JSON is found
+  TSynJsonFileSettings = class(TSynAutoCreateFields)
+  protected
+    fInitialJsonContent, fSectionName: RawUtf8;
+    fFileName: TFileName;
+    fLoadedAsIni: boolean;
+    fSettingsOptions: TSynJsonFileSettingsOptions;
+    // could be overriden to validate the content coherency and/or clean fields
+    function AfterLoad: boolean; virtual;
+  public
+    /// read existing settings from a JSON content
+    // - if the input is no JSON object, then a .INI structure is tried
+    function LoadFromJson(const aJson: RawUtf8;
+      const aSectionName: RawUtf8 = 'Main'): boolean;
+    /// read existing settings from a JSON or INI file file
+    function LoadFromFile(const aFileName: TFileName;
+      const aSectionName: RawUtf8 = 'Main'): boolean; virtual;
+    /// just a wrapper around ExtractFilePath(FileName);
+    function FolderName: TFileName;
+    /// persist the settings as a JSON file, named from LoadFromFile() parameter
+    // - will use the INI format if it was used at loading, or fsoWriteIni is set
+    procedure SaveIfNeeded; virtual;
+    /// optional persistence file name, as set by LoadFromFile()
+    property FileName: TFileName
+      read fFileName write fFileName;
+    /// allow to customize the storing process
+    property SettingsOptions: TSynJsonFileSettingsOptions
+      read fSettingsOptions write fSettingsOptions;
+  end;
+  /// meta-class definition of TSynJsonFileSettings
+  TSynJsonFileSettingsClass = class of TSynJsonFileSettings;
+
+
+implementation
+
+uses
+  mormot.core.variants;
+
+
+{ ********** Low-Level JSON Processing Functions }
+
+function NeedsJsonEscape(P: PUtf8Char; PLen: integer): boolean;
+var
+  tab: PByteArray;
+begin
+  result := true;
+  tab := @JSON_ESCAPE;
+  if PLen > 0 then
+    repeat
+      if tab[ord(P^)] <> JSON_ESCAPE_NONE then
+        exit;
+      inc(P);
+      dec(PLen);
+    until PLen = 0;
+  result := false;
+end;
+
+function NeedsJsonEscape(const Text: RawUtf8): boolean;
+begin
+  result := NeedsJsonEscape(pointer(Text), length(Text));
+end;
+
+function NeedsJsonEscape(P: PUtf8Char): boolean;
+var
+  tab: PByteArray;
+  esc: byte;
+begin
+  result := false;
+  if P = nil then
+    exit;
+  tab := @JSON_ESCAPE;
+  repeat
+    esc := tab[ord(P^)];
+    if esc = JSON_ESCAPE_NONE then
+      inc(P)
+    else if esc = JSON_ESCAPE_ENDINGZERO then
+      exit
+    else
+      break;
+  until false;
+  result := true;
+end;
+
+function JsonUnicodeEscapeToUtf8(var D: PUtf8Char;  P: PUtf8Char): PUtf8Char;
+var
+  c, s: cardinal;
+begin
+  // P^ points at 'u1234' just after \u0123
+  c := HexToWideChar(P + 1);
+  if c <= $7f then
+    if c >= 32 then
+      D^ := AnsiChar(c)
+    else if c = 0 then
+      D^ := '?' // \u0000 is an invalid value (at least in our framework)
+    else
+    begin
+      PInt64(D)^ := PInt64(P - 1)^; // control chars should always be escaped
+      inc(D, 5);
+    end
+  else if c < $7ff then
+  begin
+    D[0] := AnsiChar($C0 or (c shr 6));
+    D[1] := AnsiChar($80 or (c and $3F));
+    inc(D);
+  end
+  else if (c >= UTF16_HISURROGATE_MIN) and  // decode from two UTF-16 surrogates
+          (c <= UTF16_LOSURROGATE_MAX) then
+    if PWord(P + 5)^ = ord('\') + ord('u') shl 8 then
+    begin
+      s := HexToWideChar(P + 7);
+      if s = 0 then
+        D^ := '?' // invalid surrogate
+      else
+      begin
+        case c of // inlined Utf16CharToUtf8()
+          UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX:
+            c := ((c - UTF16_SURROGATE_OFFSET) shl 10) or
+                 (s xor UTF16_LOSURROGATE_MIN);
+          UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX:
+            c := ((s - UTF16_SURROGATE_OFFSET) shl 10) or
+                 (c xor UTF16_LOSURROGATE_MIN);
+        end;
+        inc(D, Ucs4ToUtf8(c, D));
+        result := P + 11;
+        exit;
+      end;
+    end
+    else
+      D^ := '?' // the first \u#### expects a following \u#### surrogate
+  else
+  begin
+    D[0] := AnsiChar($E0 or (c shr 12));
+    D[1] := AnsiChar($80 or ((c shr 6) and $3F));
+    D[2] := AnsiChar($80 or (c and $3F));
+    inc(D,2);
+  end;
+  inc(D);
+  result := P + 5;
+end;
+
+procedure JsonDoUniEscape(const s: RawUtf8; var result: RawUtf8; esc: boolean);
+var
+  tmp: TTextWriterStackBuffer;
+begin
+  with TJsonWriter.CreateOwnedStream(tmp) do
+    try
+      if esc then
+        AddNoJsonEscapeForcedUnicode(pointer(s), length(s))
+      else
+        AddNoJsonEscapeForcedNoUnicode(pointer(s), length(s));
+      SetText(result);
+    finally
+      Free;
+    end;
+end;
+
+function JsonUnicodeEscape(const s: RawUtf8): RawUtf8;
+begin
+  JsonDoUniEscape(s, result, true);
+end;
+
+function JsonUnicodeUnEscape(const s: RawUtf8): RawUtf8;
+begin
+  JsonDoUniEscape(s, result, false);
+end;
+
+procedure Utf16ToJsonUnicodeEscape(var B: PUtf8Char; c: PtrUInt; tab: PByteToWord);
+var
+  P: PUtf8Char;
+begin
+  P := B;
+  PWord(P + 1)^ := ord('\') + ord('u') shl 8;
+  PWord(P + 3)^ := tab[c shr 8];
+  PWord(P + 5)^ := tab[c and $ff];
+  inc(B, 6);
+end;
+
+function IsString(P: PUtf8Char): boolean;  // test if P^ is a "string" value
+begin
+  if P = nil then
+  begin
+    result := false;
+    exit;
+  end;
+  while (P^ <= ' ') and
+        (P^ <> #0) do
+    inc(P);
+  if (P[0] in ['0'..'9']) or // is first char numeric?
+     ((P[0] in ['-', '+']) and
+      (P[1] in ['0'..'9'])) then
+  begin
+    // check if P^ is a true numerical value
+    repeat
+      inc(P);
+    until not (P^ in ['0'..'9']); // check digits
+    if P^ = '.' then
+      repeat
+        inc(P);
+      until not (P^ in ['0'..'9']); // check fractional digits
+    if ((P^ = 'e') or
+        (P^ = 'E')) and
+       (P[1] in ['0'..'9', '+', '-']) then
+    begin
+      inc(P);
+      if P^ = '+' then
+        inc(P)
+      else if P^ = '-' then
+        inc(P);
+      while (P^ >= '0') and
+            (P^ <= '9') do
+        inc(P);
+    end;
+    while (P^ <= ' ') and
+          (P^ <> #0) do
+      inc(P);
+    result := (P^ <> #0);
+    exit;
+  end
+  else
+    result := true; // don't begin with a numerical value -> must be a string
+end;
+
+function IsStringJson(P: PUtf8Char): boolean;  // test if P^ is a "string" value
+var
+  c4: integer;
+  c: AnsiChar;
+  tab: PJsonCharSet;
+begin
+  if P = nil then
+  begin
+    result := false;
+    exit;
+  end;
+  while (P^ <= ' ') and
+        (P^ <> #0) do
+    inc(P);
+  tab := @JSON_CHARS;
+  c4 := PInteger(P)^;
+  if (((c4 = NULL_LOW) or
+       (c4 = TRUE_LOW)) and
+      (jcEndOfJsonValueField in tab[P[4]])) or
+     ((c4 = FALSE_LOW) and
+      (P[4] = 'e') and
+      (jcEndOfJsonValueField in tab[P[5]])) then
+  begin
+    result := false; // constants are no string
+    exit;
+  end;
+  c := P^;
+  if c = '-' then
+  begin
+    inc(P);
+    c := P^;
+  end;
+  if ((c >= '1') and (c <= '9')) or // is first char numeric?
+     ((c = '0') and ((P[1] < '0') or (P[1] > '9'))) then // '012' not JSON
+  begin
+    // check if c is a true numerical value
+    repeat
+      inc(P);
+    until (P^ < '0') or
+          (P^ > '9'); // check digits
+    if P^ = '.' then
+      repeat
+        inc(P);
+      until (P^ < '0') or
+            (P^ > '9'); // check fractional digits
+    if ((P^ = 'e') or
+        (P^ = 'E')) and
+       (jcDigitFirstChar in tab[P[1]]) then
+    begin
+      inc(P);
+      c := P^;
+      if c = '+' then
+        inc(P)
+      else if c = '-' then
+        inc(P);
+      while (P^ >= '0') and
+            (P^ <= '9') do
+        inc(P);
+    end;
+    while (P^ <= ' ') and
+          (P^ <> #0) do
+      inc(P);
+    result := (P^ <> #0);
+    exit;
+  end
+  else
+    result := true; // don't begin with a numerical value -> must be a string
+end;
+
+type
+  TJsonGotoEndParserState = (
+    stObjectName,
+    stObjectValue,
+    stValue);
+
+  /// state machine for fast (900MB/s) parsing of (extended) JSON input
+  {$ifdef USERECORDWITHMETHODS}
+  TJsonGotoEndParser = record
+  {$else}
+  TJsonGotoEndParser = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    {$ifdef CPUX86}
+    JsonSet: PJsonCharSet; // not enough registers in i386 mode
+    {$endif CPUX86}
+    State: TJsonGotoEndParserState;
+    ExpectStandard: boolean;
+    StackCount: integer;
+    JsonFirst: PJsonTokens;
+    Max: PUtf8Char; // checking Max after each comma is good enough
+    RootCount: integer;
+    // 500 nested documents seem enough in practice (SQlite3 uses 1000)
+    Stack: array[0..500] of TJsonGotoEndParserState;
+    procedure Init(Strict: boolean; PMax: PUtf8Char);
+      {$ifdef HASINLINE} inline; {$endif}
+    procedure InitCount(Strict: boolean; PMax: PUtf8Char;
+      First: TJsonGotoEndParserState);
+    // reusable method able to jump over any JSON value (up to Max)
+    function GotoEnd(P: PUtf8Char): PUtf8Char; overload;
+    function GotoEnd(P: PUtf8Char; var EndOfObject: AnsiChar): PUtf8Char; overload;
+      {$ifdef HASINLINE} inline; {$endif}
+ end;
+
+procedure TJsonGotoEndParser.Init(Strict: boolean; PMax: PUtf8Char);
+begin
+  {$ifdef CPUX86}
+  JsonSet := @JSON_CHARS;
+  {$endif CPUX86}
+  State := stValue;
+  ExpectStandard := Strict;
+  StackCount := 0;
+  JsonFirst := @JSON_TOKENS;
+  Max := PMax;
+end; // RootCount is not initialized by default unless InitCount() is called
+
+procedure TJsonGotoEndParser.InitCount(Strict: boolean; PMax: PUtf8Char;
+  First: TJsonGotoEndParserState);
+begin
+  Init(Strict, PMax);
+  RootCount := 0;
+  Stack[0] := stValue; // emulate parsing of the opening [ or {
+  inc(StackCount);
+  State := First;
+end;
+
+function TJsonGotoEndParser.GotoEnd(P: PUtf8Char): PUtf8Char;
+var
+  n: PtrInt;
+  {$ifndef CPUX86}
+  JsonSet: PJsonCharSet; // will use a register for this lookup table
+  {$endif CPUX86}
+label
+  prop, stop, assign;
+begin
+  result := nil; // to notify unexpected end
+  if P = nil then
+    exit;
+  {$ifndef CPUX86}
+  JsonSet := @JSON_CHARS;
+  {$endif CPUX86}
+  repeat
+    {$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 FPC}
+    case JsonFirst[P^] of // FPC and Delphi will use a jump table :)
+      jtNone:
+        exit;// unexpected character in JSON input
+      jtDoubleQuote: // '"'
+        begin
+          repeat // inlined GotoEndOfJsonString2()
+            inc(P);
+            if not (jcJsonStringMarker in JsonSet[P^]) then // [#0, '"', '\']
+              continue; // very fast parsing of most UTF-8 chars
+            if P^ = '"' then
+              break
+            else if P^ = #0 then
+              exit; // unexpected end of string/buffer
+            inc(P); // P^ was '\' -> ignore \# ou \u0123
+            if P^ = #0 then
+              exit; // buffer overflow detected as \#0
+          until false;
+          inc(P);
+          if (StackCount <> 0) or
+             (State = stObjectName) then
+            continue;
+          break;
+        end;
+      jtFirstDigit: // '-', '0'..'9'
+        begin
+          if (State = stObjectName) and
+             ExpectStandard then
+            exit;
+          // '0123' excluded by JSON, but not here
+          repeat
+            inc(P);
+          until not (jcDigitFloatChar in JsonSet[P^]);
+          // not ['-', '+', '0'..'9', '.', 'E', 'e']
+          if (StackCount <> 0) or
+             (State = stObjectName) then
+            continue;
+          break;
+        end;
+      jtNullFirstChar: // 'n'
+        if (PInteger(P)^ = NULL_LOW) and
+           (jcEndOfJsonValueField in JsonSet[P[4]]) then
+          inc(P, 3)
+        else
+          goto prop;
+      jtTrueFirstChar: // 't'
+        if (PInteger(P)^ = TRUE_LOW) and
+           (jcEndOfJsonValueField in JsonSet[P[4]]) then
+          inc(P, 3)
+        else
+          goto prop;
+      jtFalseFirstChar: // 'f'
+        if (PInteger(P + 1)^ = FALSE_LOW2) and
+           (jcEndOfJsonValueField in JsonSet[P[5]]) then
+          inc(P, 4)
+        else
+          goto prop;
+      jtObjectStart: // {
+        begin
+          n := StackCount;
+          if (State = stObjectName) or
+             (n > high(Stack)) then
+            exit; // too many nested documents
+          Stack[n] := State;
+          inc(StackCount);
+          State := stObjectName;
+          inc(P);
+          continue;
+        end;
+      jtArrayStart: // [
+        begin
+          n := StackCount;
+          if (State = stObjectName) or
+             (n > high(Stack)) then
+            exit; // too many nested documents
+          Stack[n] := State;
+          inc(StackCount);
+          State := stValue;
+          inc(P);
+          continue;
+        end;
+      jtObjectStop: // }
+        begin
+          if State = stValue then
+            exit;
+stop:     n := StackCount;
+          if n = 0 then
+            exit; // invalid input
+          dec(n);
+          inc(RootCount, ord(n = 0));
+          StackCount := n;
+          State := Stack[n];
+        end;
+      jtArrayStop: // ]
+        if State <> stValue then
+          exit
+        else
+          goto stop;
+      jtAssign: // :
+        begin
+assign:   if State <> stObjectName then
+            exit;
+          State := stObjectValue;
+          inc(P);
+          continue;
+        end;
+      jtComma: // ,
+        begin
+          if State = stObjectName then
+            exit;
+          dec(State, ord(State = stObjectValue)); // branchless update
+          inc(P);
+          inc(RootCount, ord(StackCount = 1));
+          if (Max = nil) or // checking Max after each comma is good enough
+             (P < Max) then
+            continue;
+          // reached end of allowed - but valid - input
+          if RootCount = 0 then
+            dec(RootCount) // first item may be huge -> at least -1
+          else
+            RootCount := -RootCount;
+          exit;
+        end;
+      jtSingleQuote: // '''' as single-quoted identifier or value
+        if ExpectStandard then
+          exit
+        else
+          repeat
+            inc(P);
+            if P^ <= ' ' then
+              exit;
+          until P^ = '''';
+      jtEqual: // =
+        if ExpectStandard then
+          exit
+        else
+          goto assign;
+      jtIdentifierFirstChar: // ['_', 'a'..'z', 'A'..'Z', '$']
+        begin
+prop:     if ExpectStandard then
+            exit;
+          repeat
+            repeat
+              inc(P);
+            until not (jcJsonIdentifier in JsonSet[P^]);
+            // not ['_', '0'..'9', 'a'..'z', 'A'..'Z', '.', '[', ']']
+            while (P^ <= ' ') and
+                  (P^ <> #0) do
+              inc(P);
+          until not (jcJsonIdentifierFirstChar in JsonSet[P^]); // new date(...
+          while (P^ <= ' ') and
+                (P^ <> #0) do
+            inc(P);
+          if P^ = '(' then
+          begin
+            // handle e.g. "born":isodate("1969-12-31")
+            repeat
+              inc(P);
+            until (P^ > ' ') or
+                  (P^ = #0);
+            if P^ = '"' then
+            begin
+              repeat
+                inc(P);
+              until jcJsonStringMarker in JsonSet[P^]; // [#0, '"', '\']
+              if P^ <> '"' then
+                exit;
+              inc(P);
+            end;
+            while (P^ <> ')') and
+                  (P^ <> #0) do
+              inc(P);
+            if P^ <> #0 then
+              inc(P);
+          end
+          else if State <> stObjectName then
+            exit; // identifier values are functions like isodate() objectid()
+          continue;
+        end;
+      jtSlash: // '/' extended /regex/i or /*comment*/ or //comment
+        begin
+          if ExpectStandard then
+            exit;
+          inc(P);
+          if P^ = #0 then
+            exit
+          else if P^ = '*' then // ignore /* comment */
+          begin
+            repeat
+              inc(P);
+              if P^ = #0 then
+                exit;
+            until PWord(P)^ = ord('*') + ord('/') shl 8;
+            inc(P, 2);
+            continue;
+          end
+          else if P^ = '/' then // ignore // comment
+          begin
+            P := GotoNextLine(P + 1);
+            if P = nil then
+              exit;
+            continue;
+          end
+          else
+          begin
+            repeat // extended /regex/i syntax
+              inc(P);
+              if P^ = #0 then
+                exit;
+            until P^ = '/';
+            while not (jcEndOfJsonFieldNotName in JsonSet[P[1]]) do
+              inc(P);
+          end;
+        end;
+      jtEndOfBuffer: // #0
+        if StackCount <> 0 then
+          exit // unclosed array or object
+        else
+          break; // return #0
+    else
+      exit; // paranoid (every and each TJsonToken should be handled above)
+    end;
+    // if we are here we know this was an identifier or value
+    inc(P);
+    if (StackCount = 0) and
+       (State <> stObjectName) then
+      break;
+  until false;
+  while (P^ <= ' ') and
+        (P^ <> #0) do
+    inc(P);
+  result := P; // points to the next meaningful char
+end;
+
+function TJsonGotoEndParser.GotoEnd(P: PUtf8Char; var EndOfObject: AnsiChar): PUtf8Char;
+var
+  c: AnsiChar;
+begin
+  result := GotoEnd(P);
+  if result = nil then
+    exit;
+  c := result^; // return last jcEndOfJsonFieldOr0
+  EndOfObject := c;
+  if c <> #0 then
+    inc(result);
+end;
+
+function IsValidJson(const s: RawUtf8; strict: boolean): boolean;
+begin
+  result := IsValidJson(pointer(s), length(s), strict);
+end;
+
+function IsValidJson(P: PUtf8Char; len: PtrInt; strict: boolean): boolean;
+var
+  B: PUtf8Char;
+  parser: TJsonGotoEndParser;
+begin
+  result := false;
+  if (P = nil) or
+     (len <= 0) then
+    exit;
+  B := P;
+  {%H-}parser.Init(strict, P + len);
+  P := parser.GotoEnd(P);
+  result := (P <> nil) and
+            (P - B = len);
+end;
+
+function GetFirstJsonToken(P: PUtf8Char): TJsonToken;
+begin
+  if P <> nil then
+    result := JSON_TOKENS[GotoNextNotSpace(P)^]
+  else
+    result := jtNone;
+end;
+
+function GetNextJsonToken(var P: PUtf8Char; strict: boolean; DocCount: PInteger): TJsonToken;
+var
+  parser: TJsonGotoEndParser;
+begin
+  result := jtNone;
+  if DocCount <> nil then
+    DocCount^ := 0;
+  if P = nil then
+    exit;
+  P := GotoNextNotSpace(P);
+  result := JSON_TOKENS[P^];
+  if result in [jtNone, jtEndOfBuffer, jtAssign, jtEqual, jtComma] then
+  begin
+    P := nil;
+    result := jtNone;
+    exit;
+  end;
+  {%H-}parser.Init(strict, nil);
+  parser.RootCount := 0;
+  P := parser.GotoEnd(P);
+  if P = nil then
+    result := jtNone
+  else if DocCount <> nil then
+    DocCount^ := parser.RootCount;
+end;
+
+function IsValidJsonBuffer(P: PUtf8Char; strict: boolean): boolean;
+var
+  parser: TJsonGotoEndParser;
+begin
+  {%H-}parser.Init(strict, nil);
+  result := parser.GotoEnd(P) <> nil;
+end;
+
+procedure IgnoreComma(var P: PUtf8Char);
+begin
+  if P <> nil then
+  begin
+    while (P^ <= ' ') and
+          (P^ <> #0) do
+      inc(P);
+    if P^ = ',' then
+      inc(P);
+  end;
+end;
+
+function JsonPropNameValid(P: PUtf8Char): boolean;
+var
+  tab: PJsonCharSet;
+begin
+  tab := @JSON_CHARS;
+  if (P <> nil) and
+     (jcJsonIdentifierFirstChar in tab[P^]) then
+  begin
+    // ['_', '0'..'9', 'a'..'z', 'A'..'Z', '$']
+    repeat
+      inc(P);
+    until not (jcJsonIdentifier in tab[P^]);
+    // not ['_', '0'..'9', 'a'..'z', 'A'..'Z', '.', '[', ']']
+    result := P^ = #0;
+  end
+  else
+    result := false;
+end;
+
+{$ifndef PUREMORMOT2}
+function GetJsonField(P: PUtf8Char; out PDest: PUtf8Char; WasString: PBoolean;
+  EndOfObject: PUtf8Char; Len: PInteger): PUtf8Char;
+var
+  info: TGetJsonField;
+begin
+  info.Json := P;
+  info.GetJsonField;
+  PDest := info.Json;
+  if WasString <> nil then
+    WasString^ := info.WasString;
+  if EndOfObject <> nil then
+    EndOfObject^ := info.EndOfObject;
+  if Len <> nil then
+    Len^ := info.ValueLen;
+  result := info.Value;
+end;
+
+function GetJsonFieldOrObjectOrArray(var Json: PUtf8Char; WasString: PBoolean;
+  EndOfObject: PUtf8Char; HandleValuesAsObjectOrArray, NormalizeBoolean: boolean;
+  Len: PInteger): PUtf8Char;
+var
+  info: TGetJsonField;
+begin
+  info.Json := Json;
+  info.GetJsonFieldOrObjectOrArray(HandleValuesAsObjectOrArray, NormalizeBoolean);
+  Json := info.Json;
+  if WasString <> nil then
+    WasString^ := info.WasString;
+  if EndOfObject <> nil then
+    EndOfObject^ := info.EndOfObject;
+  if Len <> nil then
+    Len^ := info.ValueLen;
+  result := info.Value;
+end;
+{$endif PUREMORMOT2}
+
+
+{ TGetJsonField }
+
+procedure TGetJsonField.GetJsonValue(var Text: RawUtf8);
+begin
+  GetJsonField;
+  FastSetString(Text, Value, ValueLen);
+end;
+
+function TGetJsonField.GetJsonInt64: Int64;
+begin
+  GetJsonField;
+  result := GetInt64(Value);
+end;
+
+procedure TGetJsonField.GetJsonField;
+var
+  P, D: PUtf8Char;
+  c4, surrogate, extra: PtrUInt;
+  c: AnsiChar;
+  {$ifdef CPUX86NOTPIC}
+  tab: TJsonCharSet absolute JSON_CHARS; // not enough registers
+  {$else}
+  tab: PJsonCharSet;
+  {$endif CPUX86NOTPIC}
+begin
+  // see http://www.ietf.org/rfc/rfc4627.txt
+  P := Json;
+  Json := nil; // Json=nil indicates error or unexpected end (#0)
+  Value := nil;
+  ValueLen := 0; // ensure returns ValueLen=0 on invalid input (Json=nil)
+  WasString := false; // not a string by default
+  if P = nil then
+    exit;
+  while P^ <= ' ' do
+  begin
+    if P^ = #0 then
+      exit;
+    inc(P);
+  end;
+  {$ifndef CPUX86NOTPIC}
+  tab := @JSON_CHARS;
+  {$endif CPUX86NOTPIC}
+  case JSON_TOKENS[P^] of
+    jtFirstDigit: // '-', '0'..'9'
+      begin
+        // numerical value
+        Value := P;
+        if P^ = '0' then
+          if (P[1] >= '0') and
+             (P[1] <= '9') then
+            // 0123 excluded by JSON!
+            exit;
+        repeat // loop all '-', '+', '0'..'9', '.', 'E', 'e'
+          inc(P);
+        until not (jcDigitFloatChar in tab[P^]);
+        if P^ = #0 then
+          exit; // a JSON number value should be followed by , } or ]
+        ValueLen := P - Value;
+        if (P^ <= ' ') and
+           (P^ <> #0) then
+        begin
+          P^ := #0; // force numerical field with no trailing ' '
+          inc(P);
+        end;
+      end;
+    jtDoubleQuote: // '"'
+      begin
+        // " -> unescape P^ into D^
+        inc(P);
+        Value := P; // points to the unescaped JSON string
+        WasString := true;
+        while not (jcJsonStringMarker in tab[P^]) do
+          // not [#0, '"', '\']
+          inc(P); // very fast parsing of most UTF-8 chars within "string"
+        D := P;
+        if P^ <> '"' then
+        repeat
+          // escape needed -> in-place unescape from P^ into D^
+          c := P^;
+          if not (jcJsonStringMarker in tab[c]) then
+          begin
+            inc(P);
+            D^ := c;
+            inc(D);
+            continue; // very fast parsing of most UTF-8 chars within "string"
+          end;
+          // P^ is either #0, '"' or '\'
+          if c = '"' then
+            // end of string
+            break;
+          if c = #0 then
+            // premature ending (leaving Json=nil)
+            exit;
+          // unescape JSON text: process char after \
+          inc(P); // P^ was '\' here
+          c := JSON_UNESCAPE[P^];
+          if c > JSON_UNESCAPE_UTF16 then
+          begin
+            inc(P);
+            D^ := c;
+            inc(D);
+            continue; // direct un-escape of most \x values
+          end
+          else if c = JSON_UNESCAPE_UNEXPECTED then
+            exit; // avoid \#0 potential buffer overflow issue or control char
+          // JSON_UNESCAPE_UTF16: decode '\u0123' UTF-16 into UTF-8
+          // (inlined JsonUnicodeEscapeToUtf8() to optimize GetJsonField)
+          c4 := (ConvertHexToBin[ord(P[1])] shl 12) or
+                (ConvertHexToBin[ord(P[2])] shl 8) or
+                (ConvertHexToBin[ord(P[3])] shl 4) or
+                 ConvertHexToBin[ord(P[4])]; // optimistic conversion (no check)
+          inc(P, 5);
+          case c4 of
+            0: // \u0000 is an invalid value (at least in our framework)
+              begin
+                D^ := '?';
+                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)^ = ord('\') + ord('u') shl 8 then
+              begin
+                inc(P);
+                surrogate := (ConvertHexToBin[ord(P[1])] shl 12) or
+                             (ConvertHexToBin[ord(P[2])] shl 8) or
+                             (ConvertHexToBin[ord(P[3])] shl 4) or
+                              ConvertHexToBin[ord(P[4])];
+                case c4 of // inlined Utf16CharToUtf8()
+                  UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX:
+                    c4 := ((c4 - UTF16_SURROGATE_OFFSET) shl 10) or
+                          (surrogate xor UTF16_LOSURROGATE_MIN);
+                  UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX:
+                    c4 := ((surrogate - UTF16_SURROGATE_OFFSET) shl 10) or
+                          (c4 xor UTF16_LOSURROGATE_MIN);
+                end;
+                if c4 <= $7ff then
+                  c := #2
+                else if c4 <= $ffff then
+                  c := #3
+                else if c4 <= $1FFFFF then
+                  c := #4
+                else if c4 <= $3FFFFFF then
+                  c := #5
+                else
+                  c := #6;
+                extra := ord(c) - 1;
+                repeat
+                  D[extra] := AnsiChar((c4 and $3f) or $80);
+                  c4 := c4 shr 6;
+                  dec(extra);
+                until extra = 0;
+                D^ := AnsiChar(byte(c4) or UTF8_TABLE.FirstByte[ord(c)]);
+                inc(D, ord(c));
+                inc(P, 5);
+              end
+              else
+              begin
+                // unexpected surrogate without its pair
+                D^ := '?';
+                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;
+        until false;
+        // here P^='"'
+        inc(P);
+        D^ := #0; // make zero-terminated
+        ValueLen := D - Value;
+      end;
+    jtSingleQuote: // extended/non-standard 'text' single quoted content
+      begin
+        inc(P);
+        Value := P; // points to the unquoted string
+        WasString := true;
+        D := P;
+        repeat
+          c := P^;
+          if c = #0 then
+            exit
+          else if c = '''' then
+            if P[1] = '''' then
+              inc(P) // unquote double quotes
+            else
+              break;
+          D^ := c;
+          inc(D);
+          inc(P);
+        until false;
+        inc(P);
+        D^ := #0; // make zero-terminated
+        ValueLen := D - Value;
+      end;
+    jtNullFirstChar: // 'n'
+      if (PInteger(P)^ = NULL_LOW) and
+         (jcEndOfJsonValueField in tab[P[4]]) then
+         // [#0, #9, #10, #13, ' ',  ',', '}', ']']
+        // null -> returns nil and WasString=false
+        inc(P, 4)
+      else
+        exit;
+    jtFalseFirstChar: // 'f'
+      if (PInteger(P + 1)^ = FALSE_LOW2) and
+         (jcEndOfJsonValueField in tab[P[5]]) then
+         // [#0, #9, #10, #13, ' ',  ',', '}', ']']
+      begin
+        // false -> returns 'false' and WasString=false
+        Value := P;
+        ValueLen := 5;
+        inc(P, 5);
+      end
+      else
+        exit;
+    jtTrueFirstChar: // 't'
+      if (PInteger(P)^ = TRUE_LOW) and
+         (jcEndOfJsonValueField in tab[P[4]]) then
+         // [#0, #9, #10, #13, ' ',  ',', '}', ']']
+      begin
+        // true -> returns 'true' and WasString=false
+        Value := P;
+        ValueLen := 4;
+        inc(P, 4);
+      end
+      else
+        exit;
+  else
+    // leave Json=nil on error (e.g. if a {...} or [...] was supplied)
+    exit;
+  end;
+  while not (jcEndOfJsonFieldOr0 in tab[P^]) do
+    // loop until #0 , ] } : delimiter
+    inc(P);
+  EndOfObject := P^;
+  // ensure JSON value is zero-terminated, and continue after it
+  if P^ <> #0 then
+  begin
+    P^ := #0;
+    Json := P + 1;
+  end
+  else
+    Json := P;
+end;
+
+function TryGotoEndOfComment(P: PUtf8Char): PUtf8Char;
+begin
+  repeat
+    result := P; // return input P^ = '/' if no comment was found
+    inc(P);
+    if P^ = '*' then // ignore /* comment */
+    begin
+      repeat
+        inc(P);
+        if P^ = #0 then
+          exit;
+      until PWord(P)^ = ord('*') + ord('/') shl 8;
+      result := GotoNextNotSpace(P + 2);
+    end
+    else if P^ = '/' then // ignore // comment
+    begin
+      P := GotoNextLine(P + 1);
+      if P = nil then
+        exit;
+      result := GotoNextNotSpace(P);
+    end
+    else
+      exit;
+  until P^ <> '/'; // there may be other subsequent comments ;)
+end;
+
+procedure TGetJsonField.GetJsonFieldOrObjectOrArray(
+  HandleValuesAsObjectOrArray, NormalizeBoolean: boolean);
+var
+  P: PUtf8Char;
+  parser: TJsonGotoEndParser;
+  c: integer;
+begin
+  P := Json;
+  Value := nil;
+  ValueLen := 0;
+  if P = nil then
+    exit;
+  while (P^ <= ' ') and
+        (P^ <> #0) do
+    inc(P);
+  if P^ = '/' then
+    P := TryGotoEndOfComment(P);
+  if HandleValuesAsObjectOrArray and
+     (P^ in ['{', '[']) then
+  begin
+    WasString := false;
+    Value := P;
+    {%H-}parser.Init({strict=}false, nil);
+    P := parser.GotoEnd(P);
+    if P = nil then
+      Value := nil
+    else
+    begin
+      ValueLen := P - Value;
+      while (P^ <= ' ') and
+            (P^ <> #0) do
+        inc(P);
+      EndOfObject := P^;
+      if P^ <> #0 then
+      begin
+        P^ := #0; // make zero-terminated as GetJsonField()
+        inc(P);
+      end;
+    end;
+    Json := P;
+  end
+  else
+  begin
+    Json := P;
+    GetJsonField;
+    if not WasString and
+       NormalizeBoolean and
+       (Value <> nil) then
+    begin
+      c := PInteger(Value)^;
+      if c = TRUE_LOW then
+        Value := pointer(SmallUInt32Utf8[1]) // normalize true -> 1
+      else if c = FALSE_LOW then
+        Value := pointer(SmallUInt32Utf8[0]) // normalize false -> 0
+      else
+        exit;
+      ValueLen := 1; // result = '0' or '1'
+    end;
+  end;
+end;
+
+function GotoEndOfJsonString2(P: PUtf8Char; tab: PJsonCharSet): PUtf8Char;
+  {$ifdef HASINLINE} inline; {$endif}
+begin
+  // P[-1]='"' at function call
+  repeat
+    if not (jcJsonStringMarker in tab[P^]) then
+    begin
+      inc(P);   // not [#0, '"', '\']
+      continue; // very fast parsing of most UTF-8 chars
+    end;
+    if (P^ = '"') or
+       (P^ = #0) or
+       (P[1] = #0) then
+      // end of string/buffer, or buffer overflow detected as \#0
+      break;
+    inc(P, 2); // P^ was '\' -> ignore \# ou \u0123
+  until false;
+  result := P;
+  // P^='"' at function return (if input was correct)
+end;
+
+function GotoEndOfJsonString(P: PUtf8Char): PUtf8Char;
+begin
+  // P^='"' at function call and at successful function return
+  result := GotoEndOfJsonString2(P + 1, @JSON_CHARS);
+end;
+
+function GotoEndJsonItemString(P: PUtf8Char): PUtf8Char;
+var
+  tab: PJsonCharSet;
+begin
+  // see TOrmTableJson.ParseAndConvert and TDocVariantData.InitArrayFromResults
+  if P <> nil then
+    repeat
+      if P^ = '"' then
+      begin
+        inc(P);
+        tab := @JSON_CHARS;
+        repeat // inlined GotoEndOfJsonString2()
+          if not (jcJsonStringMarker in tab[P^]) then
+          begin
+            inc(P);   // not [#0, '"', '\']
+            continue; // very fast parsing of most UTF-8 chars
+          end;
+          if P^ = '"' then
+          begin
+            repeat
+              inc(P);
+            until not (P^ in [#1..' ']);
+            result := P;
+            exit;
+          end
+          else if (P^ = #0) or
+                  (P[1] = #0) then
+            // end of string/buffer, or buffer overflow detected as \#0
+            break;
+          inc(P, 2); // P^ was '\' -> ignore \# ou \u0123
+        until false;
+        break;
+      end
+      else if P^ <= ' ' then
+      begin
+        if P^ = #0 then
+          break;
+        inc(P);
+        continue;
+      end;
+      break;
+    until false;
+  result := nil;
+end;
+
+function GetJsonPropName(var Json: PUtf8Char; Len: PInteger;
+  NoJsonUnescape: boolean): PUtf8Char;
+var
+  P, Name: PUtf8Char;
+  tab: PJsonCharSet;
+  info: TGetJsonField;
+begin
+  // should match GotoNextJsonObjectOrArray() and JsonPropNameValid()
+  result := nil; // returns nil on invalid input
+  P := Json;
+  if P = nil then
+    exit;
+  while P^ <= ' ' do
+  begin
+    if P^ = #0 then
+    begin
+      Json := nil; // reached early end of input
+      exit;
+    end;
+    inc(P);
+  end;
+  if P^ = '/' then
+    P := TryGotoEndOfComment(P);
+  Name := P + 1;
+  tab := @JSON_CHARS;
+  if P^ = '"' then
+  begin
+    // handle very efficiently the most common case of unescaped double quotes
+    repeat
+      inc(P);
+    until jcJsonStringMarker in tab[P^]; // [#0, '"', '\']
+    if P^ <> '"' then
+      // we need to handle a complex property name (seldom encoutered)
+      if P^ = #0 then
+        exit
+      else if NoJsonUnescape then
+        P := GotoEndOfJsonString2(P, tab)
+      else
+      begin // should be unescaped
+        info.Json := Name - 1;
+        info.GetJsonField;
+        if (info.Value <> nil) and
+           info.WasString and
+           (info.EndOfObject = ':') then
+        begin
+          result := info.Value;
+          if Len <> nil then
+            Len^ := info.ValueLen;
+        end;
+        Json := info.Json;
+        exit;
+      end;
+  end
+  else if P^ = '''' then
+    // single quotes won't handle nested quote character
+    repeat
+      inc(P);
+      if P^ < ' ' then
+        exit;
+    until P^ = ''''
+  else
+  begin
+    // e.g. '{age:{$gt:18}}'
+    if not (jcJsonIdentifierFirstChar in tab[P^]) then
+      exit; // not ['_', '0'..'9', 'a'..'z', 'A'..'Z', '$']
+    repeat
+      inc(P);
+    until not (jcJsonIdentifier in tab[P^]);
+    // not ['_', '0'..'9', 'a'..'z', 'A'..'Z', '.', '[', ']']
+    if P^ = #0 then
+      exit;
+    dec(Name);
+    if Len <> nil then
+      Len^ := P - Name;
+    info.EndOfObject := P^;
+    P^ := #0; // Name should end with #0
+    if not (info.EndOfObject in [':', '=']) then // relaxed {age=10} syntax
+      repeat
+        inc(P);
+        if P^ = #0 then
+          exit;
+      until P^ in [':', '='];
+    Json := P + 1;
+    result := Name;
+    exit;
+  end;
+  if Len <> nil then
+    Len^ := P - Name;
+  P^ := #0; // ensure Name is #0 terminated
+  repeat
+    inc(P);
+    if P^ = #0 then
+      exit;
+  until P^ = ':';
+  Json := P + 1;
+  result := Name;
+end;
+
+procedure GetJsonPropNameShort(var P: PUtf8Char; out PropName: ShortString);
+var
+  Name: PAnsiChar;
+  c: AnsiChar;
+  tab: PJsonCharSet;
+label
+  ok;
+begin
+  // match GotoNextJsonObjectOrArray() and overloaded GetJsonPropName()
+  PropName[0] := #0;
+  if P = nil then
+    exit;
+  while P^ <= ' ' do
+  begin
+    if P^ = #0 then
+    begin
+      P := nil;
+      exit;
+    end;
+    inc(P);
+  end;
+  Name := pointer(P);
+  c := P^;
+  if c = '/' then
+  begin
+    P := TryGotoEndOfComment(P);
+    c := P^;
+  end;
+  if c = '"' then
+  begin
+    inc(Name);
+    tab := @JSON_CHARS;
+    repeat
+      inc(P);
+    until jcJsonStringMarker in tab[P^]; // end at [#0, '"', '\']
+    if P^ <> '"' then
+      exit;
+ok: SetString(PropName, Name, P - Name); // note: won't unescape JSON strings
+    repeat
+      inc(P)
+    until (P^ > ' ') or
+          (P^ = #0);
+    if P^ <> ':' then
+    begin
+      PropName[0] := #0;
+      exit;
+    end;
+    inc(P);
+  end
+  else if c = '''' then
+  begin
+    // single quotes won't handle nested quote character
+    inc(P);
+    inc(Name);
+    while P^ <> '''' do
+      if P^ < ' ' then
+        exit
+      else
+        inc(P);
+    goto ok;
+  end
+  else
+  begin
+    // e.g. '{age:{$gt:18}}'
+    tab := @JSON_CHARS;
+    if not (jcJsonIdentifierFirstChar in tab[c]) then
+      exit; // not ['_', '0'..'9', 'a'..'z', 'A'..'Z', '$']
+    repeat
+      inc(P);
+    until not (jcJsonIdentifier in tab[P^]);
+    // not ['_', '0'..'9', 'a'..'z', 'A'..'Z', '.', '[', ']']
+    SetString(PropName, Name, P - Name);
+    while (P^ <= ' ') and
+          (P^ <> #0) do
+      inc(P);
+    if (P^ <> ':') and
+       (P^ <> '=') then
+    begin
+      // allow both age:18 and age=18 pairs (very relaxed JSON syntax)
+      PropName[0] := #0;
+      exit;
+    end;
+    inc(P);
+  end;
+end;
+
+function JsonRetrieveStringField(P: PUtf8Char; out Field: PUtf8Char;
+  out FieldLen: integer; ExpectNameField: boolean): PUtf8Char;
+var
+  tab: PJsonCharSet;
+begin
+  result := nil;
+  // retrieve string field
+  if P = nil then
+    exit;
+  while (P^ <= ' ') and
+        (P^ <> #0) do
+    inc(P);
+  if P^ <> '"' then
+    exit;
+  inc(P);
+  Field := P;
+  tab := @JSON_CHARS;
+  while not (jcJsonStringMarker in tab[P^]) do
+    // not [#0, '"', '\']
+    inc(P); // very fast parsing of most UTF-8 chars within "string"
+  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, or } , for value field
+end;
+
+function GlobalFindClass(classname: PUtf8Char; classnamelen: integer): TRttiCustom;
+var
+  name: string;
+  c: TClass;
+begin
+  Utf8DecodeToString(classname, classnamelen, name);
+  c := FindClass(name);
+  if c = nil then
+    result := nil
+  else
+    result := Rtti.RegisterClass(c);
+end;
+
+function JsonRetrieveObjectRttiCustom(var Json: PUtf8Char;
+  AndGlobalFindClass: boolean): TRttiCustom;
+var
+  tab: PNormTable;
+  P, classname: PUtf8Char;
+  classnamelen: integer;
+begin
+  result := nil;
+  P := GotoNextNotSpace(Json + 1); // at input, Json^ = '{'
+  tab := @NormToUpperAnsi7;
+  if IdemPChar(P, '"CLASSNAME":', tab) then
+    inc(P, 12)
+  else if IdemPChar(P, 'CLASSNAME:', tab) then
+    inc(P, 10)
+  else
+    exit; // we expect woStoreClassName option to have been used
+  P := JsonRetrieveStringField(P, classname, classnamelen, false);
+  if P = nil then
+    exit; // invalid (maybe too complex) Json string value
+  Json := P; // Json^ is either } or ,
+  result := Rtti.FindName(classname, classnamelen, rkClass);
+  if (result = nil) and
+     AndGlobalFindClass then
+    result := GlobalFindClass(classname, classnamelen);
+end;
+
+procedure GetJsonItemAsRawJson(var P: PUtf8Char; var result: RawJson;
+  EndOfObject: PAnsiChar);
+var
+  B: PUtf8Char;
+begin
+  result := '';
+  if P = nil then
+    exit;
+  B := GotoNextNotSpace(P);
+  P := GotoEndJsonItem(B);
+  if P = nil then
+    exit;
+  FastSetString(RawUtf8(result), B, P - B);
+  while (P^ <= ' ') and
+        (P^ <> #0) do
+    inc(P);
+  if EndOfObject <> nil then
+    EndOfObject^ := P^;
+  if P^ <> #0 then //if P^=',' then
+    repeat
+      inc(P)
+    until (P^ > ' ') or
+          (P^ = #0);
+end;
+
+function GetJsonItemAsRawUtf8(var P: PUtf8Char; var output: RawUtf8;
+  WasString: PBoolean; EndOfObject: PUtf8Char): boolean;
+var
+  info: TGetJsonField;
+begin
+  info.Json := P;
+  info.GetJsonValue(output);
+  P := info.Json;
+  if WasString <> nil then
+    WasString^ := info.WasString;
+  if EndOfObject <> nil then
+    EndOfObject^ := info.EndOfObject;
+  result := info.Json <> nil;
+end;
+
+function GotoEndJsonItemStrict(P, PMax: PUtf8Char): PUtf8Char;
+var
+  parser: TJsonGotoEndParser;
+begin
+  {%H-}parser.Init({strict=}true, PMax);
+  result := parser.GotoEnd(P);
+end;
+
+function GotoEndJsonItem(P, PMax: PUtf8Char): PUtf8Char;
+var
+  parser: TJsonGotoEndParser;
+begin
+  {%H-}parser.Init({strict=}false, PMax);
+  result := parser.GotoEnd(P);
+end;
+
+function GotoNextJsonItem(P: PUtf8Char; NumberOfItemsToJump: cardinal;
+  EndOfObject: PAnsiChar; PMax: PUtf8Char; Strict: boolean): PUtf8Char;
+var
+  parser: TJsonGotoEndParser;
+begin
+  {%H-}parser.Init(Strict, PMax);
+  result := nil; // to notify unexpected end
+  if NumberOfItemsToJump <> 0 then
+    repeat
+      P := parser.GotoEnd(P);
+      if P = nil then
+        exit;
+      if EndOfObject <> nil then
+        EndOfObject^ := P^; // return last jcEndOfJsonFieldOr0
+      if P^ <> #0 then
+        inc(P);
+      dec(NumberOfItemsToJump);
+    until NumberOfItemsToJump = 0;
+  result := P;
+end;
+
+function GotoNextJsonItem(P: PUtf8Char; var EndOfObject: AnsiChar): PUtf8Char;
+var
+  parser: TJsonGotoEndParser;
+begin
+  {%H-}parser.Init(false, nil);
+  result := parser.GotoEnd(P, EndOfObject);
+end;
+
+function GetJsonObjectOrArray(P: PUtf8Char;
+  EndOfObject: PUtf8Char; Len: PInteger): PUtf8Char;
+var
+  parser: TJsonGotoEndParser;
+begin
+  {%H-}parser.Init({strict=}false, nil);
+  result := parser.GotoEnd(P);
+  if result = nil then
+    exit;
+  if Len <> nil then
+    Len^ := result - P;
+  while (result^ <= ' ') and
+        (result^ <> #0) do
+    inc(result);
+  if EndOfObject <> nil then
+    EndOfObject^ := result^;
+  if result^ <> #0 then
+  begin
+    result^ := #0; // make zero-terminated
+    inc(result);
+  end;
+end;
+
+function JsonArrayCount(P, PMax: PUtf8Char; Strict: boolean): integer;
+var
+  parser: TJsonGotoEndParser;
+begin
+  {%H-}parser.InitCount(Strict, PMax, stValue);
+  if (parser.GotoEnd(P) = nil) and
+     (parser.RootCount >= 0) then
+    result := 0 // invalid input
+  else
+    result := parser.RootCount; // negative if PMax was reached
+end;
+
+function JsonArrayDecode(P: PUtf8Char; out Values: TPUtf8CharDynArray): boolean;
+var
+  n, max: PtrInt;
+  parser: TJsonGotoEndParser;
+begin
+  result := false;
+  max := 0;
+  n := 0;
+  {%H-}parser.Init({strict=}false, nil);
+  P := GotoNextNotSpace(P);
+  if P^ <> ']' then
+    repeat
+      if max = n then
+      begin
+        max := NextGrow(max);
+        SetLength(Values, max);
+      end;
+      Values[n] := P;
+      inc(n);
+      P := parser.GotoEnd(P);
+      if P = nil then
+        exit; // invalid content, or #0 reached
+      if P^ <> ',' then
+        break;
+      inc(P);
+    until false;
+  if P^ = ']' then
+  begin
+    if n <> 0 then
+      DynArrayFakeLength(Values{%H-}, n);
+    result := true;
+  end
+  else
+    Values := nil;
+end;
+
+function JsonArrayItem(P: PUtf8Char; Index: integer): PUtf8Char;
+var
+  parser: TJsonGotoEndParser;
+begin
+  if P <> nil then
+  begin
+    P := GotoNextNotSpace(P);
+    if P^ = '[' then
+    begin
+      {%H-}parser.Init({strict=}false, nil);
+      P := GotoNextNotSpace(P + 1);
+      if P^ <> ']' then
+        repeat
+          if Index <= 0 then
+          begin
+            result := P;
+            exit;
+          end;
+          P := parser.GotoEnd(P);
+          if (P = nil) or
+             (P^ <> ',') then
+            break; // invalid content or #0 reached
+          inc(P);
+          dec(Index);
+        until false;
+    end;
+  end;
+  result := nil;
+end;
+
+function JsonObjectPropCount(P, PMax: PUtf8Char; Strict: boolean): PtrInt;
+var
+  parser: TJsonGotoEndParser;
+begin // is very efficiently inlined on FPC
+  {%H-}parser.InitCount(Strict, PMax, stObjectName);
+  P := parser.GotoEnd(P);
+  result := parser.RootCount;
+  if P = nil then
+    // <0 means aborted when PMax or #0 was reached
+    if result >= 0 then
+      result := 0; // the JSON input was invalid
+end;
+
+function JsonObjectItem(P: PUtf8Char; const PropName: RawUtf8;
+  PropNameFound: PRawUtf8): PUtf8Char;
+begin
+  result := JsonObjectItem(P, pointer(PropName), length(PropName), PropNameFound);
+end;
+
+function JsonObjectItem(P: PUtf8Char; PropName: PUtf8Char; PropNameLen: PtrInt;
+  PropNameFound: PRawUtf8): PUtf8Char;
+var
+  name: ShortString; // no memory allocation nor P^ modification
+  PropNameUpper: array[byte] of AnsiChar;
+  parser: TJsonGotoEndParser;
+begin
+  if P <> nil then
+  begin
+    P := GotoNextNotSpace(P);
+    if PropNameLen > 0 then
+    begin
+      if PropName[PropNameLen - 1] = '*' then
+      begin
+        UpperCopy255Buf(PropNameUpper{%H-}, PropName, PropNameLen - 1)^ := #0;
+        PropNameLen := 0; // mark 'PropName*' search
+      end;
+      if P^ = '{' then
+        P := GotoNextNotSpace(P + 1);
+      if P^ <> '}' then
+        repeat
+          GetJsonPropNameShort(P, name);
+          if (name[0] = #0) or
+             (name[0] > #200) then
+            break;
+          while (P^ <= ' ') and
+                (P^ <> #0) do
+            inc(P);
+          if PropNameLen = 0 then // 'PropName*'
+          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, PropName, PropNameLen) then
+          begin
+            result := P;
+            exit;
+          end;
+          {%H-}parser.Init({strict=}false, nil);
+          P := parser.GotoEnd(P);
+          if (P = nil) or
+             (P^ <> ',') then
+            break; // invalid content, or #0 reached
+          inc(P);
+        until false;
+    end;
+  end;
+  result := nil;
+end;
+
+function JsonObjectByPath(JsonObject, PropPath: PUtf8Char): PUtf8Char;
+var
+  objName: ShortString;
+begin
+  result := nil;
+  if (JsonObject = nil) or
+     (PropPath = nil) then
+    exit;
+  repeat
+    GetNextItemShortString(PropPath, @objName, '.');
+    if objName[0] = #0 then
+      exit;
+    JsonObject := JsonObjectItem(JsonObject, @objName[1], ord(objName[0]), nil);
+    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.AddDirect('{');
+    end
+    else
+      WR.AddComma;
+    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 // single property lookup
+      begin
+        start := JsonObjectByPath(JsonObject, pointer(itemName));
+        if start <> nil then
+          AddFromStart(itemName);
+      end
+      else // 'propname*' may append several properties
+      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.AddDirect('}');
+      WR.SetText(result);
+    end;
+  finally
+    WR.Free;
+  end;
+end;
+
+function JsonObjectAsJsonArrays(Json: PUtf8Char; out keys, values: RawUtf8): integer;
+var
+  wk, wv: TTextWriter;
+  kb, ke, vb, ve: PUtf8Char;
+  temp1, temp2: TTextWriterStackBuffer;
+  parser: TJsonGotoEndParser;
+  n: integer;
+begin
+  result := -1;
+  if (Json = nil) or
+     (Json^ <> '{') then
+    exit;
+  parser.Init({strict=}false, nil);
+  n := 0;
+  wk := TTextWriter.CreateOwnedStream(temp1);
+  wv := TTextWriter.CreateOwnedStream(temp2);
+  try
+    wk.AddDirect('[');
+    wv.AddDirect('[');
+    kb := Json + 1;
+    repeat
+      ke := parser.GotoEnd(kb);
+      if (ke = nil) or
+         (ke^ <> ':') then
+        exit; // invalid input content
+      vb := ke + 1;
+      ve := parser.GotoEnd(vb);
+      if (ve = nil) or
+         not (ve^ in [',', '}']) then
+        exit;
+      wk.AddNoJsonEscape(kb, ke - kb);
+      wk.AddComma;
+      wv.AddNoJsonEscape(vb, ve - vb);
+      wv.AddComma;
+      kb := ve + 1;
+      inc(n);
+    until ve^ = '}';
+    wk.CancelLastComma(']');
+    wk.SetText(keys);
+    wv.CancelLastComma(']');
+    wv.SetText(values);
+    result := n; // success
+  finally
+    wv.Free;
+    wk.Free;
+  end;
+end;
+
+function DoRemoveComment(P: PUtf8Char): PUtf8Char;
+  {$ifdef HASINLINE} inline; {$endif}
+begin
+  result := P + 1;
+  case result^ of
+    '/':
+      begin // this is // comment - replace by ' '
+        dec(result);
+        repeat
+          result^ := ' ';
+          inc(result)
+        until result^ in [#0, #10, #13];
+        if result^ <> #0 then
+          inc(result);
+      end;
+    '*':
+      begin // this is /* comment - replace by ' ' but keep CRLF
+        result[-1] := ' ';
+        repeat
+          if not (result^ in [#10, #13]) then
+            result^ := ' '; // keep CRLF for line numbering (e.g. for error)
+          inc(result);
+          if PWord(result)^ = ord('*') + ord('/') shl 8 then
+          begin
+            PWord(result)^ := $2020;
+            inc(result, 2);
+            break;
+          end;
+        until result^ = #0;
+      end;
+  end;
+end;
+
+procedure RemoveCommentsFromJson(P: PUtf8Char);
+var
+  PComma: PUtf8Char;
+begin // replace comments by ' ' characters which will be ignored by parser
+  if P <> nil then
+    while P^ <> #0 do
+    begin
+      case P^ of
+        '"':
+          begin
+            P := GotoEndOfJsonString2(P + 1, @JSON_CHARS);
+            if P^ <> '"' then
+              exit;
+            inc(P);
+          end;
+        '/':
+          P := DoRemoveComment(P);
+        ',':
+          begin
+            // replace trailing comma by space for strict JSON parsers
+            PComma := P;
+            repeat
+              inc(P)
+            until (P^ > ' ') or
+                  (P^ = #0);
+            if P^ = '/' then
+              P := DoRemoveComment(P);
+            while (P^ <= ' ') and
+                  (P^ <> #0) do
+              inc(P);
+            if P^ in ['}', ']'] then
+              PComma^ := ' '; // see https://github.com/synopse/mORMot/pull/349
+          end;
+      else
+        inc(P);
+      end;
+    end;
+end;
+
+function RemoveCommentsFromJson(const s: RawUtf8): RawUtf8;
+begin
+  if PosExChar('/', s) = 0 then
+    result := s
+  else
+  begin
+    FastSetString(result, pointer(s), length(s));
+    RemoveCommentsFromJson(pointer(s)); // remove in-place
+  end;
+end;
+
+function ParseEndOfObject(P: PUtf8Char; out EndOfObject: AnsiChar): PUtf8Char;
+var
+  tab: PJsonCharSet;
+begin
+  if P <> nil then
+  begin
+    tab := @JSON_CHARS; // mimics GetJsonField()
+    while not (jcEndOfJsonFieldOr0 in tab[P^]) do
+      inc(P); // not #0 , ] } :
+    EndOfObject := P^;
+    if P^ <> #0 then
+      repeat
+        inc(P); // ignore trailing , ] } and any successive spaces
+      until (P^ > ' ') or
+            (P^ = #0);
+  end;
+  result := P;
+end;
+
+function GetSetNameValue(Names: PShortString; MinValue, MaxValue: integer;
+  var P: PUtf8Char; out EndOfObject: AnsiChar): QWord;
+var
+  info: TGetJsonField;
+  tmp: shortstring;
+begin
+  result := 0;
+  if (P = nil) or
+     (Names = nil) or
+     (MinValue < 0) or
+     (MaxValue < 0) then
+    exit;
+  while (P^ <= ' ') and
+        (P^ <> #0) do
+    inc(P);
+  if P^ = '[' then
+  begin // stored as JSON array
+    repeat
+      inc(P)
+    until (P^ > ' ') or
+          (P^ = #0);
+    if P^ = ']' then
+      inc(P)
+    else
+    begin
+      info.Json := P;
+      repeat
+        info.GetJsonField;
+        if (info.Value = nil) or
+           not info.WasString then
+        begin
+          P := nil; // invalid input (expects a JSON array of strings)
+          exit;
+        end;
+        SetNamesValue(Names, MinValue, MaxValue, info.Value, info.ValueLen, result);
+      until info.EndOfObject = ']';
+      P := info.Json;
+      if P = nil then
+        exit; // avoid GPF below if already reached the input end
+    end;
+    P := ParseEndOfObject(P, EndOfObject); // mimics GetJsonField()
+    if EndOfObject = #0 then
+      P := nil; // as in mORMot 1
+  end
+  else
+  begin
+    info.Json := P;
+    info.GetJsonField;
+    P := info.Json;
+    if info.WasString then // stored as CSV text (e.g. from a .INI file)
+      while info.Value <> nil do
+      begin
+        GetNextItemShortString(info.Value, @tmp);
+        SetNamesValue(Names, MinValue, MaxValue, @tmp[1], ord(tmp[0]), result);
+      end
+    else // stored as a 64-bit unsigned integer
+      SetQWord(info.Value, result);
+    EndOfObject := info.EndOfObject;
+  end;
+end;
+
+function GetSetNameValue(Info: PRttiInfo;
+  var P: PUtf8Char; out EndOfObject: AnsiChar): QWord;
+var
+  Names: PShortString;
+  MinValue, MaxValue: integer;
+begin
+  if (Info <> nil) and
+     (Info^.Kind = rkSet) and
+     (Info^.SetEnumType(Names, MinValue, MaxValue) <> nil) then
+    result := GetSetNameValue(Names, MinValue, MaxValue, P, EndOfObject)
+  else
+    result := 0;
+end;
+
+function UrlEncodeJsonObject(const UriName: RawUtf8; ParametersJson: PUtf8Char;
+  const PropNamesToIgnore: array of RawUtf8; IncludeQueryDelimiter: boolean): RawUtf8;
+var
+  i, j: PtrInt;
+  sep: AnsiChar;
+  Params: TNameValuePUtf8CharDynArray;
+  temp: TTextWriterStackBuffer;
+begin
+  if ParametersJson = nil then
+    result := UriName
+  else
+    with TTextWriter.CreateOwnedStream(temp) do
+    try
+      AddString(UriName);
+      if (JsonDecode(ParametersJson, Params, true) <> nil) and
+         (Params <> nil) then
+      begin
+        sep := '?';
+        for i := 0 to length(Params) - 1 do
+          with Params[i] do
+          begin
+            for j := 0 to high(PropNamesToIgnore) do
+              if IdemPropNameU(PropNamesToIgnore[j], Name.Text, Name.Len) then
+              begin
+                Name.Len := 0;
+                break;
+              end;
+            if Name.Len = 0 then
+              continue; // was within PropNamesToIgnore[]
+            if IncludeQueryDelimiter then
+              Add(sep);
+            AddShort(Name.Text, Name.Len);
+            Add('=');
+            AddString(UrlEncode(Value.Text));
+            sep := '&';
+            IncludeQueryDelimiter := true;
+          end;
+      end;
+      SetText(result);
+    finally
+      Free;
+    end;
+end;
+
+function UrlEncodeJsonObject(const UriName, ParametersJson: RawUtf8;
+  const PropNamesToIgnore: array of RawUtf8; IncludeQueryDelimiter: boolean): RawUtf8;
+var
+  temp: TSynTempBuffer;
+begin
+  temp.Init(ParametersJson);
+  try
+    result := UrlEncodeJsonObject(
+      UriName, temp.buf, PropNamesToIgnore, IncludeQueryDelimiter);
+  finally
+    temp.Done;
+  end;
+end;
+
+procedure QuotedStrJson(P: PUtf8Char; PLen: PtrInt; var result: RawUtf8;
+  const aPrefix, aSuffix: RawUtf8);
+var
+  temp: TTextWriterStackBuffer;
+  Lp, Ls: PtrInt;
+  D: PUtf8Char;
+begin
+  if ((P = nil) or
+      (PLen <= 0)) and
+     (aPrefix = '') and
+     (aSuffix = '') then
+    result := '""'
+  else if (pointer(result) = pointer(P)) or
+          NeedsJsonEscape(P, PLen) then
+    // use TJsonWriter.AddJsonEscape() for proper JSON escape
+    with TJsonWriter.CreateOwnedStream(temp) do
+    try
+      AddString(aPrefix);
+      AddDirect('"');
+      AddJsonEscape(P, PLen);
+      AddDirect('"');
+      AddString(aSuffix);
+      SetText(result);
+      exit;
+    finally
+      Free;
+    end
+  else
+  begin
+    // direct allocation if no JSON escape is needed
+    Lp := length(aPrefix);
+    Ls := length(aSuffix);
+    FastSetString(result, PLen + Lp + Ls + 2);
+    D := pointer(result); // we checked dest result <> source P above
+    if Lp > 0 then
+    begin
+      MoveFast(pointer(aPrefix)^, D^, Lp);
+      inc(D, Lp);
+    end;
+    D^ := '"';
+    MoveFast(P^, D[1], PLen);
+    inc(D, PLen);
+    D[1] := '"';
+    if Ls > 0 then
+      MoveFast(pointer(aSuffix)^, D[2], Ls);
+  end;
+end;
+
+procedure QuotedStrJson(const aText: RawUtf8; var result: RawUtf8;
+  const aPrefix, aSuffix: RawUtf8);
+begin
+  QuotedStrJson(pointer(aText), Length(aText), result, aPrefix, aSuffix);
+end;
+
+function QuotedStrJson(const aText: RawUtf8): RawUtf8;
+begin
+  QuotedStrJson(pointer(aText), Length(aText), result, '', '');
+end;
+
+procedure JsonBufferReformat(P: PUtf8Char; out result: RawUtf8;
+  Format: TTextWriterJsonFormat);
+var
+  temp: array[word] of byte; // 64KB buffer
+begin
+  if P <> nil then
+    with TJsonWriter.CreateOwnedStream(@temp, SizeOf(temp)) do
+    try
+      AddJsonReformat(P, Format, nil);
+      SetText(result);
+    finally
+      Free;
+    end;
+end;
+
+function JsonReformat(const Json: RawUtf8; Format: TTextWriterJsonFormat): RawUtf8;
+var
+  tmp: TSynTempBuffer;
+begin
+  tmp.Init(Json);
+  try
+    JsonBufferReformat(tmp.buf, result, Format);
+  finally
+    tmp.Done;
+  end;
+end;
+
+function JsonBufferReformatToFile(P: PUtf8Char; const Dest: TFileName;
+  Format: TTextWriterJsonFormat): boolean;
+var
+  F: TStream;
+  temp: array[word] of word; // 128KB
+begin
+  try
+    F := TFileStreamEx.Create(Dest, fmCreate);
+    try
+      with TJsonWriter.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): boolean;
+var
+  tmp: TSynTempBuffer;
+begin
+  tmp.Init(Json);
+  try
+    result := JsonBufferReformatToFile(tmp.buf, Dest, Format);
+  finally
+    tmp.Done;
+  end;
+end;
+
+function Expect(var P: PUtf8Char; Pattern: PUtf8Char; PatternLen: PtrInt): boolean;
+var
+  i: PtrInt;
+  J: PUtf8Char;
+begin
+  result := false;
+  J := P;
+  if J = nil then
+    exit;
+  while (J^ <= ' ') and
+        (J^ <> #0) do
+    inc(J);
+  if PPtrInt(J)^ = PPtrInt(Pattern)^ then // PatternLen is at least 8 bytes long
+  begin
+    for i := SizeOf(PtrInt) to PatternLen - 1 do
+      if J[i] <> Pattern[i] then
+        exit;
+    P := J + PatternLen;
+    result := true;
+  end;
+end;
+
+function IsNotExpandedBuffer(var P: PUtf8Char; PEnd: PUtf8Char;
+  var FieldCount, RowCount: PtrInt): boolean;
+var
+  RowCountPos: PUtf8Char;
+begin
+  if not Expect(P, FIELDCOUNT_PATTERN, 14) then
+  begin
+    result := false;
+    exit;
+  end;
+  FieldCount := GetNextItemCardinal(P, #0);
+  if Expect(P, ROWCOUNT_PATTERN, 12) then
+    RowCount := GetNextItemCardinal(P, #0)    // initial "rowCount":xxxx
+  else
+  begin
+    if PEnd = nil then
+      PEnd := P + mormot.core.base.StrLen(P); // late search of ending
+    RowCountPos := NotExpandedBufferRowCountPos(P, PEnd);
+    if RowCountPos = nil then
+      RowCount := -1                          // no "rowCount":xxxx
+    else
+      RowCount := GetCardinal(RowCountPos);   // trailing "rowCount":xxxx
+  end;
+  result := (FieldCount <> 0) and
+            Expect(P, VALUES_PATTERN, 11);
+  if result and
+     (RowCount < 0) then
+  begin
+    RowCount := JsonArrayCount(P, PEnd) div FieldCount; // 900MB/s browse
+    if RowCount <= 0 then
+      RowCount := -1; // bad format -> no data
+  end;
+end;
+
+function NotExpandedBufferRowCountPos(P, PEnd: PUtf8Char): PUtf8Char;
+var
+  i: PtrInt;
+begin
+  // search for "rowCount": at the end of the JSON buffer
+  result := nil;
+  if (PEnd <> nil) and
+     (PEnd - P > 24) then
+    for i := 1 to 24 do
+      case PEnd[-i] of
+        ']',
+        ',':
+          exit;
+        ':':
+          begin
+            if CompareMemFixed(PEnd - i - 11, pointer(ROWCOUNT_PATTERN), 11) then
+              result := PEnd - i + 1;
+            exit;
+          end;
+      end;
+end;
+
+function GotoFieldCountExpanded(P: PUtf8Char): PUtf8Char;
+begin
+  result := nil;
+  while P^ <> '[' do
+    if P^ = #0 then
+      exit
+    else
+      inc(P); // need an array of objects
+  repeat
+    inc(P);
+    if P^ = #0 then
+      exit;
+  until P^ in ['{', ']']; // go to object beginning
+  result := P;
+end;
+
+function GetFieldCountExpanded(P: PUtf8Char): integer;
+var
+  EndOfObject: AnsiChar;
+  parser: TJsonGotoEndParser;
+begin
+  result := 0;
+  {%H-}parser.Init(false, nil);
+  repeat
+    P := parser.GotoEnd(P, EndOfObject{%H-}); // ignore Name
+    P := parser.GotoEnd(P, EndOfObject);      // ignore Value
+    if P = nil then
+    begin // unexpected end
+      result := 0;
+      exit;
+    end;
+    inc(result);
+    if EndOfObject = '}' then
+      break; // end of object
+  until false;
+end;
+
+procedure FormatParams(const Format: RawUtf8; const Args, Params: array of const;
+  JsonFormat: boolean; var Result: RawUtf8);
+var
+  A, P: PtrInt;
+  F, FDeb: PUtf8Char;
+  isParam: AnsiChar;
+  tmp: TTempUtf8;
+  wasString: boolean;
+  temp: TTextWriterStackBuffer;
+begin
+  if (Format = '') or
+     ((high(Args) < 0) and
+      (high(Params) < 0)) then
+    // no formatting to process, but may be a const
+    // -> make unique since e.g. _JsonFmt() will parse it in-place
+    FastSetString(Result, pointer(Format), length(Format))
+  else if high(Params) < 0 then
+    // faster function with no ?
+    FormatUtf8(Format, Args, Result)
+  else if Format = '%' then
+    // optimize raw conversion
+    VarRecToUtf8(Args[0], Result)
+  else
+    // handle any number of parameters with minimal memory allocations
+    with TJsonWriter.CreateOwnedStream(temp) do
+    try
+      A := 0;
+      P := 0;
+      F := pointer(Format);
+      while F^ <> #0 do
+      begin
+        if (F^ <> '%') and
+           (F^ <> '?') then
+        begin
+          // handle plain text between % ? markers
+          FDeb := F;
+          repeat
+            inc(F);
+          until F^ in [#0, '%', '?'];
+          AddNoJsonEscape(FDeb, F - FDeb);
+          if F^ = #0 then
+            break;
+        end;
+        isParam := F^;
+        inc(F); // jump '%' or '?'
+        if (isParam = '%') and
+           (A <= high(Args)) then
+        begin
+          // handle % substitution
+          if Args[A].VType = vtObject then
+            AddShort(ClassNameShort(Args[A].VObject)^)
+          else
+            Add(Args[A]);
+          inc(A);
+        end
+        else if (isParam = '?') and
+                (P <= high(Params)) then
+        begin
+          // handle ? substitution as JSON or SQL
+          if JsonFormat then
+            AddJsonEscape(Params[P]) // does the JSON magic including "quotes"
+          else
+          begin
+            Add(':', '('); // markup for SQL parameter binding
+            VarRecToTempUtf8(Params[P], tmp, @wasString);
+            if wasString then
+              AddQuotedStr(tmp.Text, tmp.Len, '''') // SQL quote
+            else
+              AddShort(tmp.Text, tmp.Len); // numbers
+            if tmp.TempRawUtf8 <> nil then
+              RawUtf8(tmp.TempRawUtf8) := '';  // release temp memory
+            Add(')', ':');
+          end;
+          inc(P);
+        end
+        else
+        begin
+          // no more available Args or Params -> add all remaining text
+          AddNoJsonEscape(F, length(Format) - (F - pointer(Format)));
+          break;
+        end;
+      end;
+      SetText(Result);
+    finally
+      Free;
+    end;
+end;
+
+function FormatSql(const Format: RawUtf8;
+  const Args, Params: array of const): RawUtf8;
+begin
+  FormatParams(Format, Args, Params, {json=}false, result);
+end;
+
+function FormatJson(const Format: RawUtf8;
+  const Args, Params: array of const): RawUtf8;
+begin
+  FormatParams(Format, Args, Params, {json=}true, result);
+end;
+
+{$ifndef PUREMORMOT2}
+function FormatUtf8(const Format: RawUtf8; const Args, Params: array of const;
+  JsonFormat: boolean): RawUtf8;
+begin
+  FormatParams(Format, Args, Params, JsonFormat, result);
+end;
+{$endif PUREMORMOT2}
+
+
+{ ********** Low-Level JSON Serialization for all TRttiParserType }
+
+// some methods defined here for proper inlining
+procedure TJsonWriter.BlockAfterItem(Options: TTextWriterWriteObjectOptions);
+begin
+  B[1] := ',';
+  inc(B);
+  if woHumanReadable in Options then
+    AddCRAndIndent;
+end;
+
+procedure TJsonWriter.BlockBegin(Starter: AnsiChar;
+  Options: TTextWriterWriteObjectOptions);
+begin
+  if woHumanReadable in Options then
+  begin
+    AddCRAndIndent;
+    inc(fHumanReadableLevel);
+  end;
+  Add(Starter);
+end;
+
+procedure TJsonWriter.BlockEnd(Stopper: AnsiChar;
+  Options: TTextWriterWriteObjectOptions);
+begin
+  if woHumanReadable in Options then
+  begin
+    dec(fHumanReadableLevel);
+    AddCRAndIndent;
+  end;
+  B[1] := Stopper;
+  inc(B);
+end;
+
+
+{ TJsonSaveContext }
+
+procedure TJsonSaveContext.Init(WR: TJsonWriter;
+  WriteOptions: TTextWriterWriteObjectOptions; Rtti: TRttiCustom);
+begin
+  W := WR;
+  if Rtti <> nil then
+    WriteOptions := WriteOptions + TRttiJson(Rtti).fIncludeWriteOptions;
+  Options := WriteOptions;
+  Info := Rtti;
+  Prop := nil;
+end;
+
+procedure TJsonSaveContext.AddShort(PS: PShortString);
+begin
+  W.Add('"');
+  if twoTrimLeftEnumSets in W.CustomOptions then
+    W.AddTrimLeftLowerCase(PS)
+  else
+    W.AddShort(PS^);
+  W.AddDirect('"');
+end;
+
+procedure TJsonSaveContext.Add64(Value: PInt64; UnSigned: boolean);
+begin
+  if woInt64AsHex in Options then
+    if Value^ = 0 then
+      W.Add('"', '"')
+    else
+      W.AddBinToHexDisplayLower(Value, SizeOf(Value^), '"')
+  else if UnSigned then
+    W.AddQ(PQWord(Value)^)
+  else
+    W.Add(Value^);
+end;
+
+procedure TJsonSaveContext.AddDateTime(Value: PDateTime; WithMS: boolean);
+var
+  d: double;
+begin
+  if woDateTimeWithMagic in Options then
+    W.AddShorter(JSON_SQLDATE_MAGIC_QUOTE_STR)
+  else
+    W.Add('"');
+  d := unaligned(Value^);
+  W.AddDateTime(d, WithMS);
+  if woDateTimeWithZSuffix in Options then
+    if not (twoDateTimeWithZ in W.CustomOptions) then // if not already done
+      if frac(d) = 0 then // FireFox can't decode short form "2017-01-01Z"
+        W.AddShort('T00:00:00Z') // the same pattern for date and dateTime
+      else
+        W.Add('Z');
+  W.AddDirect('"');
+end;
+
+procedure TJsonSaveContext.AddShortBoolean(PS: PShortString; Value: boolean);
+begin
+  AddShort(PS);
+  W.Add(':');
+  W.Add(Value);
+end;
+
+
+procedure _JS_Null(Data: PBoolean; const Ctxt: TJsonSaveContext);
+var
+  W: TJsonWriter;
+begin
+  W := Ctxt.W;
+  W.AddNull;
+end;
+
+procedure _JS_Boolean(Data: PBoolean; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.W.Add(Data^);
+end;
+
+procedure _JS_Byte(Data: PByte; const Ctxt: TJsonSaveContext);
+var
+  W: TJsonWriter;
+begin
+  W := Ctxt.W;
+  W.AddU(Data^);
+end;
+
+procedure _JS_SmallInt(Data: PSmallInt; const Ctxt: TJsonSaveContext);
+var
+  W: TJsonWriter;
+begin
+  W := Ctxt.W;
+  W.Add(Data^);
+end;
+
+procedure _JS_ShortInt(Data: PShortInt; const Ctxt: TJsonSaveContext);
+var
+  W: TJsonWriter;
+begin
+  W := Ctxt.W;
+  W.Add(Data^);
+end;
+
+procedure _JS_Cardinal(Data: PCardinal; const Ctxt: TJsonSaveContext);
+var
+  W: TJsonWriter;
+begin
+  W := Ctxt.W;
+  W.AddU(Data^);
+end;
+
+procedure _JS_Currency(Data: PInt64; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.W.AddCurr64(Data);
+end;
+
+procedure _JS_Double(Data: PDouble; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.W.AddDouble(unaligned(Data^));
+end;
+
+procedure _JS_Extended(Data: PSynExtended; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.W.AddDouble({$ifndef TSYNEXTENDED80}unaligned{$endif}(Data^));
+end;
+
+procedure _JS_Int64(Data: PInt64; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.Add64(Data, {unsigned=}false);
+end;
+
+procedure _JS_Integer(Data: PInteger; const Ctxt: TJsonSaveContext);
+var
+  W: TJsonWriter;
+begin
+  W := Ctxt.W;
+  W.Add(Data^);
+end;
+
+procedure _JS_QWord(Data: PInt64; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.Add64(Data, {unsigned=}true);
+end;
+
+procedure _JS_RawByteString(Data: PRawByteString; const Ctxt: TJsonSaveContext);
+begin
+  if (Data^ = '') or
+     ((rcfIsRawBlob in Ctxt.Info.Cache.Flags) and
+      not (woRawBlobAsBase64 in Ctxt.Options)) then
+    Ctxt.W.AddNull
+  else
+  begin
+    Ctxt.W.Add('"'); // no magic trailer as with mORMot 1
+    Ctxt.W.WrBase64(pointer(Data^), length(Data^), {withmagic=}false);
+    Ctxt.W.AddDirect('"');
+  end;
+end;
+
+procedure _JS_RawJson(Data: PRawJson; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.W.AddRawJson(Data^);
+end;
+
+procedure _JS_RawUtf8(Data: PAnsiChar; const Ctxt: TJsonSaveContext);
+var
+  cp: cardinal;
+begin
+  Ctxt.W.Add('"');
+  Data := PPointer(Data)^;
+  if Data <> nil then
+  begin
+    cp := Ctxt.Info.Cache.CodePage;
+    if cp = CP_UTF8 then
+      Ctxt.W.AddJsonEscape(Data, {len=}0)
+    else
+      Ctxt.W.AddAnyAnsiBuffer(Data, PStrLen(Data - _STRLEN)^, twJsonEscape, cp);
+  end;
+  Ctxt.W.AddDirect('"');
+end;
+
+procedure _JS_Ansi(Data: PAnsiChar; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.W.Add('"');
+  Data := PPointer(Data)^;
+  if Data <> nil then
+    with PStrRec(Data - SizeOf(TStrRec))^ do
+      // will handle any AnsiString, WinAnsiString or other CP
+      Ctxt.W.AddAnyAnsiBuffer(Data, length, twJsonEscape,
+       {$ifdef HASCODEPAGE} codePage {$else} Ctxt.Info.Cache.CodePage {$endif});
+  Ctxt.W.AddDirect('"');
+end;
+
+procedure _JS_Single(Data: PSingle; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.W.AddSingle(Data^);
+end;
+
+procedure _JS_Unicode(Data: PPWord; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.W.Add('"');
+  Ctxt.W.AddJsonEscapeW(Data^);
+  Ctxt.W.AddDirect('"');
+end;
+
+procedure _JS_Char(Data: PAnsiChar; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.W.Add('"');
+  if Data^ <> #0 then // #0 will be serialized as ""
+    Ctxt.W.AddJsonEscape(Data, 1);
+  Ctxt.W.AddDirect('"');
+end;
+
+procedure _JS_WideChar(Data: PWord; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.W.Add('"');
+  if Data^ <> 0 then
+    Ctxt.W.AddJsonEscapeW(Data, 1);
+  Ctxt.W.AddDirect('"');
+end;
+
+procedure _JS_DateTime(Data: PDateTime; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.AddDateTime(Data, {withms=}false);
+end;
+
+procedure _JS_DateTimeMS(Data: PDateTime; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.AddDateTime(Data, {withms=}true);
+end;
+
+procedure _JS_GUID(Data: PGUID; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.W.Add(Data, '"');
+end;
+
+procedure _JS_Hash(Data: pointer; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.W.AddBinToHexDisplayLower(Data, Ctxt.Info.Size, '"');
+end;
+
+procedure _JS_Binary(Data: pointer; const Ctxt: TJsonSaveContext);
+begin
+  if IsZeroSmall(Data, Ctxt.Info.BinarySize) then
+    Ctxt.W.Add('"', '"') // serialize "" for 0 value
+  else
+    Ctxt.W.AddBinToHexDisplayLower(Data, Ctxt.Info.BinarySize, '"');
+end;
+
+procedure _JS_TimeLog(Data: PInt64; const Ctxt: TJsonSaveContext);
+begin
+  if woTimeLogAsText in Ctxt.Options then
+    Ctxt.W.AddTimeLog(Data, '"')
+  else
+    Ctxt.Add64(Data, true);
+end;
+
+procedure _JS_UnixTime(Data: PInt64; const Ctxt: TJsonSaveContext);
+begin
+  if woTimeLogAsText in Ctxt.Options then
+    Ctxt.W.AddUnixTime(Data, '"')
+  else
+    Ctxt.Add64(Data, true);
+end;
+
+procedure _JS_UnixMSTime(Data: PInt64; const Ctxt: TJsonSaveContext);
+begin
+  if woTimeLogAsText in Ctxt.Options then
+    Ctxt.W.AddUnixMSTime(Data, {withms=}true, '"')
+  else
+    Ctxt.Add64(Data, true);
+end;
+
+procedure _JS_WinAnsi(Data: PWinAnsiString; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.W.Add('"');
+  Ctxt.W.AddAnyAnsiBuffer(pointer(Data^), length(Data^), twJsonEscape, CP_WINANSI);
+  Ctxt.W.AddDirect('"');
+end;
+
+procedure _JS_Word(Data: PWord; const Ctxt: TJsonSaveContext);
+begin
+  Ctxt.W.AddU(Data^);
+end;
+
+procedure _JS_Interface(Data: PInterface; const Ctxt: TJsonSaveContext);
+begin
+  {$ifdef HASINTERFACEASTOBJECT}
+  // interfaces can be saved/serialized as their own object instance,
+  // but not restored/unserialized in _JL_Interface()
+  if Data^ <> nil then
+    Ctxt.W.WriteObject(Data^ as TObject)
+  else
+  {$endif HASINTERFACEASTOBJECT}
+    Ctxt.W.AddNull;
+end;
+
+procedure _JS_PUtf8Char(Data: PPUtf8Char; const Ctxt: TJsonSaveContext);
+begin
+  // PUtf8Char can be saved/serialized as their own UTF-8 content,
+  // but not restored/unserialized in _JL_PUtf8Char()
+  Ctxt.W.Add('"');
+  if Data^ <> nil then
+    Ctxt.W.AddJsonEscape(Data^, {len=}0);
+  Ctxt.W.AddDirect('"');
+end;
+
+procedure _JS_ID(Data: PInt64; const Ctxt: TJsonSaveContext);
+var
+  _str: ShortString;
+begin
+  Ctxt.W.Add(Data^);
+  if woIDAsIDstr in Ctxt.Options then
+  begin
+    Ctxt.W.BlockAfterItem(Ctxt.Options);
+    if (Ctxt.Prop <> nil) and
+       (Ctxt.Prop^.Name <> '') then
+    begin
+      Ansi7StringToShortString(Ctxt.Prop^.Name, _str);
+      AppendShort('_str', _str);
+      Ctxt.W.WriteObjectPropNameShort(_str, Ctxt.Options);
+    end
+    else
+      Ctxt.W.WriteObjectPropNameShort('ID_str', Ctxt.Options);
+    Ctxt.W.Add('"');
+    Ctxt.W.Add(Data^);
+    Ctxt.W.AddDirect('"');
+  end;
+end;
+
+procedure _JS_Enumeration(Data: PByte; const Ctxt: TJsonSaveContext);
+var
+  o: TTextWriterOptions;
+  PS: PShortString;
+begin
+  o := Ctxt.W.CustomOptions;
+  if (Ctxt.Options * [woFullExpand, woHumanReadable, woEnumSetsAsText] <> []) or
+     (o * [twoEnumSetsAsBooleanInRecord, twoEnumSetsAsTextInRecord] <> []) then
+  begin
+    PS := Ctxt.Info.Cache.EnumInfo^.GetEnumNameOrd(Data^);
+    if twoEnumSetsAsBooleanInRecord in o then
+      Ctxt.AddShortBoolean(PS, true)
+    else
+      Ctxt.AddShort(PS);
+    if woHumanReadableEnumSetAsComment in Ctxt.Options then
+      Ctxt.Info.Cache.EnumInfo^.GetEnumNameAll(Ctxt.W.fBlockComment, '', true);
+  end
+  else
+    Ctxt.W.AddU(Data^);
+end;
+
+procedure _JS_Set(Data: PCardinal; const Ctxt: TJsonSaveContext);
+var
+  PS: PShortString;
+  i: cardinal;
+  v: QWord;
+  o: TTextWriterOptions;
+begin
+  o := Ctxt.W.CustomOptions;
+  if twoEnumSetsAsBooleanInRecord in o then
+  begin
+    // { "set1": true/false, .... } with proper indentation
+    PS := Ctxt.Info.Cache.EnumList;
+    Ctxt.W.BlockBegin('{', Ctxt.Options);
+    i := 0;
+    repeat
+      if i >= Ctxt.Info.Cache.EnumMin then
+        Ctxt.AddShortBoolean(PS, GetBitPtr(Data, i));
+      if i = Ctxt.Info.Cache.EnumMax then
+        break;
+      inc(i);
+      Ctxt.W.BlockAfterItem(Ctxt.Options);
+      inc(PByte(PS), PByte(PS)^ + 1); // next
+    until false;
+    Ctxt.W.BlockEnd('}', Ctxt.Options);
+  end
+  else if (Ctxt.Options * [woFullExpand, woHumanReadable, woEnumSetsAsText] <> []) or
+          (twoEnumSetsAsTextInRecord in o) then
+  begin
+    // [ "set1", "set4", .... } on same line
+    Ctxt.W.Add('[');
+    if ((twoFullSetsAsStar in o) or
+        (woHumanReadableFullSetsAsStar in Ctxt.Options)) and
+       GetAllBits(Data^, Ctxt.Info.Cache.EnumMax + 1) then
+      Ctxt.W.AddShorter('"*"')
+    else
+    begin
+      PS := Ctxt.Info.Cache.EnumList;
+      for i := 0 to Ctxt.Info.Cache.EnumMax do
+      begin
+        if (i >= Ctxt.Info.Cache.EnumMin) and
+           GetBitPtr(Data, i) then
+        begin
+          Ctxt.AddShort(PS);
+          Ctxt.W.AddComma;
+        end;
+        inc(PByte(PS), PByte(PS)^ + 1); // next
+      end;
+      Ctxt.W.CancelLastComma;
+    end;
+    Ctxt.W.AddDirect(']');
+    if woHumanReadableEnumSetAsComment in Ctxt.Options then
+      Ctxt.Info.Cache.EnumInfo^.GetEnumNameAll(
+        Ctxt.W.fBlockComment, '"*" or a set of ', true);
+  end
+  else
+  begin
+    // standard serialization as unsigned integer (up to 64 items)
+    v := 0;
+    MoveFast(Data^, v, Ctxt.Info.Size);
+    Ctxt.W.AddQ(v);
+  end;
+end;
+
+procedure _JS_Array(Data: PAnsiChar; const Ctxt: TJsonSaveContext);
+var
+  n: integer;
+  jsonsave: TRttiJsonSave;
+  c: TJsonSaveContext;
+begin
+  {%H-}c.Init(Ctxt.W, Ctxt.Options, Ctxt.Info.ArrayRtti);
+  c.W.BlockBegin('[', c.Options);
+  jsonsave := c.Info.JsonSave; // e.g. PT_JSONSAVE/PTC_JSONSAVE
+  if Assigned(jsonsave) then
+  begin
+    // efficient JSON serialization
+    n := Ctxt.Info.Cache.ItemCount;
+    repeat
+      jsonsave(Data, c);
+      dec(n);
+      if n = 0 then
+        break;
+      c.W.BlockAfterItem(c.Options);
+      inc(Data, c.Info.Cache.Size);
+    until false;
+  end
+  else
+    // fallback to raw RTTI binary serialization with Base64 encoding
+    c.W.BinarySaveBase64(Data, Ctxt.Info.Info, [rkArray],
+      {withMagic=}true, {withcrc=}false);
+  c.W.BlockEnd(']', c.Options);
+end;
+
+procedure _JS_DynArray_Custom(Data: pointer; const Ctxt: TJsonSaveContext);
+begin
+  // TRttiJson.RegisterCustomSerializer() custom callback for each item
+  TOnRttiJsonWrite(TRttiJson(Ctxt.Info).fJsonWriter)(
+    Ctxt.W, Data, Ctxt.Options);
+end;
+
+procedure _JS_OneProp(var c: TJsonSaveContext; p: PRttiCustomProp; Data: PAnsiChar);
+  {$ifdef HASINLINE} inline; {$endif}
+begin
+  if (woHideSensitivePersonalInformation in c.Options) and
+     (rcfSpi in p^.Value.Flags) then
+    c.W.AddShorter('"***"')
+  else if p^.OffsetGet >= 0 then
+  begin
+    // direct value write (record field or plain class property)
+    c.Info := p^.Value;
+    c.Prop := p;
+    TRttiJsonSave(c.Info.JsonSave)(Data + p^.OffsetGet, c);
+  end
+  else
+    // need to call a getter method
+    p^.AddValueJson(c.W, Data, c.Options);
+end;
+
+type
+  TCCHook = class(TObjectWithCustomCreate); // to access its protected methods
+
+procedure _JS_NonExpanded(var c: TJsonSaveContext; Data: PAnsiChar; n: integer);
+var
+  v: PAnsiChar;
+  item: TRttiCustom;
+  p: PRttiCustomProp;
+  f: integer;
+begin
+  // {"fieldCount":2,"rowCount":20,"values":["f1","f2","1v1",1v2,"2v1",2v2...]}
+  item := c.Info;
+  c.W.BlockBegin('{', c.Options);
+  c.W.AddShort('"fieldCount":');
+  c.W.AddU(item.Props.CountNonVoid);
+  c.W.AddShort(',"rowCount":');
+  c.W.AddU(n);
+  c.W.AddShort(',"values":[');
+  c.W.AddString(item.Props.NamesAsJsonArray); // pre-computed - with trailing ,
+  if n <> 0 then
+    repeat
+      if item.Kind = rkClass then
+        v := PPointer(Data)^
+      else
+        v := Data;
+      p := pointer(item.Props.List);
+      f := item.Props.Count;
+      repeat
+        if p^.Name <> '' then
+        begin
+          if not (rcfHookWriteProperty in item.Flags) or
+             not TCCHook(v).RttiWritePropertyValue(c.W, p, c.Options) then
+            _JS_OneProp(c, p, v);
+          c.W.AddComma;  // no c.W.BlockAfterItem() if non-expanded
+        end;
+        inc(p);
+        dec(f);
+      until f = 0;
+      inc(Data, item.Cache.Size);
+      dec(n);
+    until n = 0;
+  c.W.CancelLastComma(']');
+  c.W.BlockEnd('}', c.Options);
+end;
+
+procedure _JS_DynArray(Data: PPointer; const Ctxt: TJsonSaveContext);
+var
+  n, s: PtrInt;
+  jsonsave: TRttiJsonSave;
+  P: PAnsiChar;
+  c: TJsonSaveContext;
+begin
+  {%H-}c.Init(Ctxt.W, Ctxt.Options, Ctxt.Info.ArrayRtti);
+  if (twoNonExpandedArrays in c.W.CustomOptions) and
+     (c.Info <> nil) and
+     (c.Info.Props.CountNonVoid > 0) and
+     (Data^ <> nil) then
+  begin
+    // non-expanded format efficient serialization
+    n := PDALen(PAnsiChar(Data^) - _DALEN)^ + _DAOFF; // length(Data)
+    if n <> 1 then // expanded is fine for a single object array
+    begin
+      _JS_NonExpanded(c, Data^, n);
+      exit;
+    end;
+  end;
+  c.W.BlockBegin('[', c.Options);
+  if Data^ <> nil then
+  begin
+    if TRttiJson(Ctxt.Info).fJsonWriter.Code <> nil then
+    begin
+      c.Info := Ctxt.Info;
+      jsonsave := @_JS_DynArray_Custom; // redirect to custom callback
+    end
+    else if c.Info = nil then
+      jsonsave := nil
+    else
+      jsonsave := c.Info.JsonSave; // e.g. PT_JSONSAVE/PTC_JSONSAVE
+    if Assigned(jsonsave) then
+    begin
+      // efficient JSON serialization
+      P := Data^;
+      n := PDALen(P - _DALEN)^ + _DAOFF; // length(Data)
+      s := Ctxt.Info.Cache.ItemSize; // c.Info may be nil
+      repeat
+        jsonsave(P, c);
+        dec(n);
+        if n = 0 then
+          break;
+        c.W.BlockAfterItem(c.Options);
+        inc(P, s);
+      until false;
+    end
+    else
+      // fallback to raw RTTI binary serialization with Base64 encoding
+      c.W.BinarySaveBase64(Data, Ctxt.Info.Info, [rkDynArray],
+        {withMagic=}true, {withcrc=}false);
+  end
+  else if (woHumanReadableEnumSetAsComment in Ctxt.Options) and
+          (c.Info <> nil) and
+          (rcfHasNestedProperties in c.Info.Flags) then
+    // void dynarray should include record/T*ObjArray fields as comment
+    c.Info.Props.AsText(c.W.fBlockComment, true, 'array of {', '}');
+  c.W.BlockEnd(']', c.Options);
+end;
+
+procedure _JS_Variant(Data: PVarData; const Ctxt: TJsonSaveContext); forward;
+
+/// use pointer to allow any kind of Data^ type in _JS_*() functions
+// - typecast to TRttiJsonSave for proper function call
+const
+  VARIANT_JSONSAVE: array[varEmpty .. varOleUInt] of pointer = (
+    {0}  @_JS_Null, @_JS_Null, @_JS_SmallInt, @_JS_Integer, @_JS_Single,
+    {5}  @_JS_Double, @_JS_Currency, @_JS_DateTime, nil, nil,
+    {10} nil, @_JS_Boolean, nil, nil, nil,
+    {15} nil, @_JS_ShortInt, @_JS_Byte, @_JS_Word, @_JS_Cardinal,
+    {20} @_JS_Int64, @_JS_QWord, @_JS_Integer, @_JS_Cardinal);
+
+  // rkRecord and rkClass are handled in TRttiJson.SetParserType
+  PT_JSONSAVE: array[TRttiParserType] of pointer = (
+    nil, @_JS_Array, @_JS_Boolean, @_JS_Byte, @_JS_Cardinal, @_JS_Currency,
+    @_JS_Double, @_JS_Extended, @_JS_Int64, @_JS_Integer, @_JS_QWord,
+    @_JS_RawByteString, @_JS_RawJson, @_JS_RawUtf8, nil, @_JS_Single,
+    {$ifdef UNICODE} @_JS_Unicode {$else} @_JS_Ansi {$endif},
+    @_JS_Unicode, @_JS_DateTime, @_JS_DateTimeMS, @_JS_GUID, @_JS_Hash,
+    @_JS_Hash, @_JS_Hash, nil, @_JS_TimeLog, @_JS_Unicode, @_JS_UnixTime,
+    @_JS_UnixMSTime, @_JS_Variant, @_JS_Unicode, @_JS_WinAnsi, @_JS_Word,
+    @_JS_Enumeration, @_JS_Set, nil, @_JS_DynArray, @_JS_Interface,
+    @_JS_PUtf8Char, nil);
+
+  PTC_JSONSAVE: array[TRttiParserComplexType] of pointer = (
+    nil, nil, nil, nil, @_JS_ID, @_JS_ID, @_JS_QWord, @_JS_QWord, @_JS_QWord);
+
+procedure _JS_Variant(Data: PVarData; const Ctxt: TJsonSaveContext);
+var
+  vt: cardinal;
+  cv: TSynInvokeableVariantType;
+  save: TRttiJsonSave;
+begin
+  repeat
+    vt := Data^.VType;
+    if vt <> varVariantByRef then
+      break;
+    Data := Data^.VPointer;
+  until false;
+  if vt <= high(VARIANT_JSONSAVE) then
+  begin
+    save := VARIANT_JSONSAVE[vt];
+    if Assigned(save) then
+    begin
+      save(@Data^.VAny, Ctxt);
+      exit;
+    end;
+  end;
+  case vt of // most common strings
+    varString:
+      {$ifdef HASCODEPAGE}
+      _JS_Ansi(@Data^.VAny, Ctxt);
+      {$else} // old Delphi can't use Ctxt.Info.Cache.CodePage 
+      Ctxt.W.AddText(RawByteString(Data^.VString), twJsonEscape);
+      {$endif HASCODEPAGE}
+    {$ifdef HASVARUSTRING} varUString, {$endif} varOleStr:
+      _JS_Unicode(@Data^.VAny, Ctxt);
+  else
+    begin
+      cv := FindSynVariantType(vt); // our custom types
+      if cv <> nil then
+        cv.ToJson(Ctxt.W, Data)
+      else // unsupported or seldom used
+        Ctxt.W.AddVariant(PVariant(Data)^, twJsonEscape, Ctxt.Options);
+    end;
+  end;
+end;
+
+procedure AppendExceptionLocation(w: TJsonWriter; e: ESynException);
+begin // call TDebugFile.FindLocationShort if mormot.core.log is used
+  w.Add('"');
+  w.AddShort(GetExecutableLocation(e.RaisedAt));
+  w.Add('"');
+end;
+
+// serialization of properties for both records and classes
+procedure _JS_RttiCustom(Data: PAnsiChar; const Ctxt: TJsonSaveContext);
+var
+  nfo: TRttiJson;
+  p: PRttiCustomProp;
+  t: TClass;
+  n: integer;
+  flags: set of (isNotFirst, noStored, noDefault, noHook, noVoid, isHumanReadable);
+  c: TJsonSaveContext; // dedicated context used for fields/properties
+begin
+  c.W := Ctxt.W;
+  c.Options := Ctxt.Options;
+  nfo := TRttiJson(Ctxt.Info);
+  if nfo.Kind = rkClass then
+  begin
+    if Data <> nil then
+      Data := PPointer(Data)^; // class instances are accessed by reference
+    if Data = nil then
+    begin
+      c.W.AddNull; // append 'null' for nil class instance
+      exit;
+    end;
+    t := PClass(Data)^; // actual class of this instance
+    if t <> nfo.ValueClass then
+      nfo := TRttiJson(Rtti.RegisterClass(t)); // work on proper inherited class
+    flags := [];
+    if (woStoreStoredFalse in c.Options) or
+       (rcfDisableStored in nfo.Flags) then
+      include(flags, noStored);
+    if not (woDontStoreDefault in c.Options) then
+      include(flags, noDefault);
+    if not (rcfHookWriteProperty in nfo.Flags) then
+      include(flags, noHook);
+  end
+  else
+  begin
+    exclude(c.Options, woFullExpand); // not available for null or records
+    flags := [noStored, noDefault, noHook];
+  end;
+  if nfo.fJsonWriter.Code <> nil then // TRttiJson.RegisterCustomSerializer()
+  begin // e.g. TOrm.RttiJsonWrite
+    TOnRttiJsonWrite(nfo.fJsonWriter)(c.W, Data, c.Options);
+    exit;
+  end;
+  if not (rcfHookWrite in nfo.Flags) or
+     not TCCHook(Data).RttiBeforeWriteObject(c.W, c.Options) then
+  begin
+    // regular JSON serialization using nested fields/properties
+    if not ((woDontStoreVoid in c.Options) or
+            (twoIgnoreDefaultInRecord in c.W.CustomOptions)) then
+      include(flags, noVoid);
+    if woHumanReadable in c.Options then
+    begin
+      include(flags, isHumanReadable);
+      c.W.BlockBegin('{', c.Options)
+    end
+    else
+      c.W.Add('{');
+    c.Prop := pointer(nfo.Props.List);
+    n := nfo.Props.Count;
+    if (nfo.Kind = rkClass) and
+       (c.Options * [woFullExpand, woStoreClassName, woStorePointer,
+                     woDontStoreInherited] <> []) then
+    begin
+      if woFullExpand in c.Options then
+      begin
+        c.W.AddInstanceName(TObject(Data), ':');
+        c.W.BlockBegin('{', c.Options);
+      end;
+      if woStoreClassName in c.Options then
+      begin
+        c.W.WriteObjectPropNameShort('ClassName', c.Options);
+        c.W.AddDirect('"');
+        c.W.AddShort(ClassNameShort(PClass(Data)^)^);
+        c.W.AddDirect('"');
+        if (c.Prop <> nil) or
+           (woStorePointer in c.Options) then
+          c.W.BlockAfterItem(c.Options);
+      end;
+      if woStorePointer in c.Options then
+      begin
+        c.W.WriteObjectPropNameShort('Address', c.Options);
+        if nfo.ValueRtlClass = vcESynException then
+          AppendExceptionLocation(c.W, ESynException(Data))
+        else
+          c.W.AddPointer(PtrUInt(Data), '"');
+        if c.Prop <> nil then
+          c.W.BlockAfterItem(c.Options);
+      end;
+      if woDontStoreInherited in c.Options then
+        with nfo.Props do
+          if NotInheritedIndex <> 0 then
+          begin
+            // List[NotInheritedIndex]..List[Count-1] is the last class level
+            inc(c.Prop, NotInheritedIndex);
+            dec(n, NotInheritedIndex);
+          end;
+    end;
+    if n > 0 then
+    begin
+      // this is the main loop serializing Info.Props[]
+      p := c.Prop;
+      repeat
+        if // handle Props.NameChange() set to Name='' to ignore this field
+           (p^.Name <> '') and
+           // handle woStoreStoredFalse flag and "stored" attribute in code
+           ((p^.Stored = rpsTrue) or // most common case
+            (noStored in flags) or
+            ((p^.Stored = rpsGetter) and
+             (p^.Prop.IsStoredGetter(pointer(Data))))) and
+           // handle woDontStoreDefault flag over "default" attribute in code
+           ((noDefault in flags) or
+            (p^.OrdinalDefault = NO_DEFAULT) or
+            not p^.ValueIsDefault(Data)) and
+           // detect 0 numeric values and empty strings
+           ((noVoid in flags) or
+            not p^.ValueIsVoid(Data)) then
+        begin
+          // if we reached here, we should serialize this property
+          if isNotFirst in flags then
+            // append ',' and proper indentation if a field was just appended
+            c.W.BlockAfterItem(c.Options);
+          if isHumanReadable in flags then
+            c.W.WriteObjectPropNameHumanReadable(pointer(p^.Name), length(p^.Name))
+          else
+            c.W.AddProp(pointer(p^.Name), length(p^.Name));
+          if (noHook in flags) or
+             not TCCHook(Data).RttiWritePropertyValue(c.W, p, c.Options) then
+            _JS_OneProp(c, p, Data);
+          include(flags, isNotFirst);
+        end;
+        dec(n);
+        if n = 0 then
+          break;
+        inc(p);
+      until false;
+    end;
+    if rcfHookWrite in nfo.Flags then
+       TCCHook(Data).RttiAfterWriteObject(c.W, c.Options);
+    if isHumanReadable in flags then
+      c.W.BlockEnd('}', c.Options)
+    else
+      c.W.AddDirect('}');
+    if woFullExpand in c.Options then
+      c.W.BlockEnd('}', c.Options);
+  end;
+end;
+
+// most known RTL classes custom serialization
+
+procedure _JS_Objects(W: TJsonWriter; Value: PObject; Count: integer;
+  Options: TTextWriterWriteObjectOptions);
+var
+  ctxt: TJsonSaveContext;
+  save: TRttiJsonSave;
+  c, v: pointer; // reuse ctxt.Info if classes are the same (very likely)
+begin
+  c := nil;
+  save := nil;
+  {%H-}ctxt.Init(W, Options, nil);
+  W.BlockBegin('[', Options);
+  if Count > 0 then
+    repeat
+      v := Value^;
+      if v = nil then
+        W.AddNull
+      else
+      begin
+        v := PPointer(v)^; // check Value class
+        if v <> c then
+        begin
+          // need to retrieve the RTTI
+          c := v;
+          ctxt.Info := Rtti.RegisterClass(TClass(v));
+          save := ctxt.Info.JsonSave;
+        end;
+        // this is where each object is serialized
+        save(pointer(Value), ctxt);
+      end;
+      dec(Count);
+      if Count = 0 then
+        break;
+      W.BlockAfterItem(Options);
+      inc(Value);
+    until false;
+  W.BlockEnd(']', Options);
+end;
+
+procedure _JS_TList(Data: PList; const Ctxt: TJsonSaveContext);
+begin
+  if Data^ = nil then
+    Ctxt.W.AddNull
+  else
+    _JS_Objects(Ctxt.W, pointer(Data^.List), Data^.Count, Ctxt.Options);
+end;
+
+procedure _JS_TObjectList(Data: PObjectList; const Ctxt: TJsonSaveContext);
+var
+  o: TTextWriterWriteObjectOptions;
+begin
+  if Data^ = nil then
+  begin
+    Ctxt.W.AddNull;
+    exit;
+  end;
+  o := Ctxt.Options;
+  if not (woObjectListWontStoreClassName in o) then
+    include(o, woStoreClassName);
+  _JS_Objects(Ctxt.W, pointer(Data^.List), Data^.Count, o);
+end;
+
+procedure _JS_TCollection(Data: PCollection; const Ctxt: TJsonSaveContext);
+var
+  item: TCollectionItem;
+  i, last: PtrInt;
+  c: TJsonSaveContext; // reuse same context for all collection items
+begin
+  if Data^ = nil then
+  begin
+    Ctxt.W.AddNull;
+    exit;
+  end;
+  // can't use AddObjects() since we don't have access to the TCollection list
+  {%H-}c.Init(Ctxt.W, Ctxt.Options, Rtti.RegisterClass(Data^.ItemClass));
+  c.W.BlockBegin('[', c.Options);
+  i := 0;
+  last := Data^.Count - 1;
+  if last >= 0 then
+    repeat
+      item := Data^.Items[i];
+      TRttiJsonSave(c.Info.JsonSave)(@item, c);
+      if i = last then
+        break;
+      c.W.BlockAfterItem(c.Options);
+      inc(i);
+    until false;
+  c.W.BlockEnd(']', c.Options);
+end;
+
+procedure _JS_TStrings(Data: PStrings; const Ctxt: TJsonSaveContext);
+var
+  i, last: PtrInt;
+begin
+  if Data^ = nil then
+  begin
+    Ctxt.W.AddNull;
+    exit;
+  end;
+  Ctxt.W.BlockBegin('[', Ctxt.Options);
+  i := 0;
+  last := Data^.Count - 1;
+  if last >= 0 then
+    repeat
+      Ctxt.W.Add('"');
+      Ctxt.W.AddJsonEscapeString(Data^.Strings[i]);
+      Ctxt.W.AddDirect('"');
+      if i = last then
+        break;
+      Ctxt.W.BlockAfterItem(Ctxt.Options);
+      inc(i);
+    until false;
+  Ctxt.W.BlockEnd(']', Ctxt.Options);
+end;
+
+procedure _JS_TRawUtf8List(Data: PRawUtf8List; const Ctxt: TJsonSaveContext);
+var
+  i, last: PtrInt;
+  u: PPUtf8CharArray;
+begin
+  if Data^ = nil then
+  begin
+    Ctxt.W.AddNull;
+    exit;
+  end;
+  Ctxt.W.BlockBegin('[', Ctxt.Options);
+  i := 0;
+  u := Data^.TextPtr;
+  last := Data^.Count - 1;
+  if last >= 0 then
+    repeat
+      Ctxt.W.Add('"');
+      Ctxt.W.AddJsonEscape(u[i]);
+      Ctxt.W.AddDirect('"');
+      if i = last then
+        break;
+      Ctxt.W.BlockAfterItem(Ctxt.Options);
+      inc(i);
+    until false;
+  Ctxt.W.BlockEnd(']', Ctxt.Options);
+end;
+
+procedure _JS_TSynList(Data: PSynList; const Ctxt: TJsonSaveContext);
+begin
+  if Data^ = nil then
+    Ctxt.W.AddNull
+  else
+    _JS_Objects(Ctxt.W, pointer(Data^.List), Data^.Count, Ctxt.Options);
+end;
+
+procedure _JS_TSynObjectList(Data: PSynObjectList; const Ctxt: TJsonSaveContext);
+var
+  o: TTextWriterWriteObjectOptions;
+begin
+  if Data^ = nil then
+  begin
+    Ctxt.W.AddNull;
+    exit;
+  end;
+  o := Ctxt.Options;
+  if not (woObjectListWontStoreClassName in o) then
+    include(o, woStoreClassName);
+  _JS_Objects(Ctxt.W, pointer(Data^.List), Data^.Count, o);
+end;
+
+
+{ ********** TJsonWriter class with proper JSON escaping and WriteObject() support }
+
+{ TJsonWriter }
+
+procedure TJsonWriter.WriteObjectPropNameHumanReadable(
+  PropName: PUtf8Char; PropNameLen: PtrInt);
+begin
+  AddCRAndIndent; // won't do anything if has already been done
+  AddProp(PropName, PropNameLen); // handle twoForceJsonExtended
+  Add(' ');
+end;
+
+procedure TJsonWriter.WriteObjectPropNameShort(const PropName: ShortString;
+  Options: TTextWriterWriteObjectOptions);
+begin
+  if woHumanReadable in Options then
+    WriteObjectPropNameHumanReadable(@PropName[1], ord(PropName[0]))
+  else
+    AddProp(@PropName[1], ord(PropName[0]));
+end;
+
+procedure TJsonWriter.WriteObjectAsString(Value: TObject;
+  Options: TTextWriterWriteObjectOptions);
+var
+  W: TJsonWriter;
+begin
+  Add('"');
+  W := GetTempJsonWriter;
+  W.WriteObject(Value, Options);
+  AddJsonEscape(W);
+  Add('"');
+end;
+
+procedure TJsonWriter.AddDynArrayJsonAsString(aTypeInfo: PRttiInfo; var aValue;
+  WriteOptions: TTextWriterWriteObjectOptions);
+var
+  temp: TDynArray;
+  W: TJsonWriter;
+begin
+  Add('"');
+  temp.Init(aTypeInfo, aValue);
+  W := GetTempJsonWriter;
+  W.AddDynArrayJson(temp, WriteOptions);
+  AddJsonEscape(W);
+  Add('"');
+end;
+
+procedure TJsonWriter.AddCRAndIndent;
+begin
+  if fBlockComment <> '' then
+  begin
+    AddShorter(' // ');
+    AddString(fBlockComment);
+    fBlockComment := '';
+  end;
+  inherited AddCRAndIndent;
+end;
+
+procedure TJsonWriter.AddPropJsonString(const PropName: ShortString;
+  const Text: RawUtf8);
+begin
+  AddProp(@PropName[1], ord(PropName[0]));
+  AddJsonString(Text); // " + AddJsonEscape(Text) + "
+  AddComma;
+end;
+
+procedure TJsonWriter.InternalAddFixedAnsi(Source: PAnsiChar; SourceChars: cardinal;
+  AnsiToWide: PWordArray; Escape: TTextWriterKind);
+var
+  c: cardinal;
+  esc: byte;
+begin
+  if SourceChars > 0 then
+  repeat
+    case Escape of // twJsonEscape or twOnSameLine only occur on c <= $7f
+      twNone:
+        repeat
+          if B >= BEnd then
+            FlushToStream;
+          c := byte(Source^);
+          inc(Source);
+          if c > $7F then
+             break;
+          if c = 0 then
+            exit;
+          inc(B);
+          B^ := AnsiChar(c);
+          dec(SourceChars);
+          if SourceChars = 0 then
+            exit;
+        until false;
+      twJsonEscape:
+        repeat
+          if B >= BEnd then
+            FlushToStream;
+          c := byte(Source^);
+          inc(Source);
+          if c > $7F then
+             break;
+          if c = 0 then
+            exit;
+          esc := JSON_ESCAPE[c]; // c<>0 -> esc<>JSON_ESCAPE_ENDINGZERO
+          if esc = JSON_ESCAPE_NONE then
+          begin
+            // no escape needed
+            inc(B);
+            B^ := AnsiChar(c);
+          end
+          else if esc = JSON_ESCAPE_UNICODEHEX then
+          begin
+            // characters below ' ', #7 e.g. -> \u0007
+            AddShorter('\u00');
+            AddByteToHex(c);
+          end
+          else
+            Add('\', AnsiChar(esc)); // escaped as \ + b,t,n,f,r,\,"
+          dec(SourceChars);
+          if SourceChars = 0 then
+            exit;
+        until false;
+    else  //twOnSameLine:
+      repeat
+        if B >= BEnd then
+          FlushToStream;
+        c := byte(Source^);
+        inc(Source);
+        if c > $7F then
+           break;
+        if c = 0 then
+          exit;
+        inc(B);
+        if c < 32 then
+          B^ := ' ' // on same line
+        else
+          B^ := AnsiChar(c);
+        dec(SourceChars);
+        if SourceChars = 0 then
+          exit;
+      until false;
+    end;
+    // handle c > $7F (no surrogate is expected in TSynAnsiFixedWidth charsets)
+    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;
+    dec(SourceChars);
+  until SourceChars = 0;
+end;
+
+destructor TJsonWriter.Destroy;
+begin
+  inherited Destroy;
+  fInternalJsonWriter.Free;
+end;
+
+function TJsonWriter.GetTempJsonWriter: TJsonWriter;
+begin
+  if fInternalJsonWriter = nil then
+    fInternalJsonWriter := TJsonWriter.CreateOwnedStream(4096, {noshare=}true)
+  else
+    fInternalJsonWriter.CancelAllAsNew;
+  result := fInternalJsonWriter;
+end;
+
+procedure TJsonWriter.Add(P: PUtf8Char; Escape: TTextWriterKind);
+begin
+  if P <> nil then
+    case Escape of
+      twNone:
+        AddNoJsonEscape(P, StrLen(P));
+      twJsonEscape:
+        AddJsonEscape(P);
+      twOnSameLine:
+        AddOnSameLine(P);
+    end;
+end;
+
+procedure TJsonWriter.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 TJsonWriter.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 TJsonWriter.AddAnsiString(const s: AnsiString; Escape: TTextWriterKind);
+begin
+  AddAnyAnsiBuffer(pointer(s), length(s), Escape, 0);
+end;
+
+procedure TJsonWriter.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_C) then
+  begin
+    AddNoJsonEscape(pointer(s), L); // was marked as a BLOB content
+    exit;
+  end;
+  if CodePage < 0 then
+    {$ifdef HASCODEPAGE}
+    CodePage := GetCodePage(s);
+    {$else}
+    CodePage := CP_ACP; // TSynAnsiConvert.Engine(0)=CurrentAnsiConvert
+    {$endif HASCODEPAGE}
+  AddAnyAnsiBuffer(pointer(s), L, Escape, CodePage);
+end;
+
+procedure EngineAppendUtf8(W: TJsonWriter; Engine: TSynAnsiConvert;
+  P: PAnsiChar; Len: PtrInt; Escape: TTextWriterKind);
+var
+  tmp: TSynTempBuffer;
+begin
+  // explicit conversion using a temporary UTF-16 buffer on stack
+  Engine.AnsiBufferToUnicode(tmp.Init(Len * 3), P, Len); // includes ending #0
+  W.AddW(tmp.buf, 0, Escape);
+  tmp.Done;
+end;
+
+procedure TJsonWriter.AddAnyAnsiBuffer(P: PAnsiChar; Len: PtrInt;
+  Escape: TTextWriterKind; CodePage: integer);
+var
+  B: PUtf8Char;
+  engine: TSynAnsiConvert;
+label
+  utf8;
+begin
+  if (P = nil) or
+     (Len <= 0) then
+    exit;
+  if CodePage = CP_ACP then // CP_UTF8 is very likely on POSIX or LCL
+    CodePage := Unicode_CodePage; // = CurrentAnsiConvert.CodePage
+  case CodePage of
+    CP_UTF8:          // direct write of RawUtf8 content
+      begin
+        if Escape = twJsonEscape then
+          Len := 0;    // faster with no Len
+utf8:   Add(PUtf8Char(P), Len, Escape);
+      end;
+    CP_RAWBYTESTRING: // direct write of RawByteString content as UTF-8
+      goto utf8;
+    CP_UTF16:         // direct write of UTF-16 content
+      AddW(PWord(P), 0, Escape);
+    CP_RAWBLOB:       // RawBlob written with Base64 encoding
+      begin
+        AddShorter(JSON_BASE64_MAGIC_S); // \uFFF0
+        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^ <= #127) 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
+      engine := TSynAnsiConvert.Engine(CodePage);
+      if PClass(engine)^ = TSynAnsiFixedWidth then
+        InternalAddFixedAnsi(P, Len,
+          pointer(TSynAnsiFixedWidth(engine).AnsiToWide), Escape)
+      else
+        EngineAppendUtf8(self, engine, P, Len, Escape);
+    end;
+  end;
+end;
+
+procedure TJsonWriter.WrBase64(P: PAnsiChar; Len: PtrUInt; withMagic: boolean);
+var
+  trailing, main, n: PtrUInt;
+begin
+  if P = nil then
+    Len := 0;
+  if withMagic then
+    if Len <= 0 then
+    begin
+      AddNull; // JSON null is better than "" for BLOBs
+      exit;
+    end
+    else
+      AddShorter(JSON_BASE64_MAGIC_QUOTE_S); // "\uFFF0
+  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); // may use AVX2 on FPC x86_64
+      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
+        n := ((fTempBufSize - 4) shr 2) * 3;
+        if Len < n then
+          n := Len;
+        main := Base64EncodeMain(PAnsiChar(fTempBuf), P, n);
+        n := main * 4;
+        if n < cardinal(fTempBufSize) - 4 then
+          inc(B, n)
+        else
+          WriteToStream(fTempBuf, n);
+        n := main * 3;
+        inc(P, n);
+        dec(Len, n);
+      end;
+    end;
+    if trailing > 0 then
+    begin
+      Base64EncodeTrailing(@B[1], P, trailing);
+      inc(B, 4);
+    end;
+  end;
+  if withMagic then
+    Add('"');
+end;
+
+procedure TJsonWriter.BinarySaveBase64(Data: pointer; Info: PRttiInfo;
+  Kinds: TRttiKinds; withMagic, withCrc: boolean);
+var
+  temp: TSynTempBuffer;
+begin
+  BinarySave(Data, temp, Info, Kinds, withCrc);
+  WrBase64(temp.buf, temp.len, withMagic);
+  temp.Done;
+end;
+
+procedure TJsonWriter.Add(const Format: RawUtf8; const Values: array of const;
+  Escape: TTextWriterKind; WriteObjectOptions: TTextWriterWriteObjectOptions);
+var
+  ValuesIndex: integer;
+  S, F: PUtf8Char;
+begin
+  if Format = '' then
+    exit;
+  if (Format = '%') and
+     (high(Values) >= 0) then
+  begin
+    Add(Values[0], Escape);
+    exit;
+  end;
+  ValuesIndex := 0;
+  F := pointer(Format);
+  repeat
+    S := F;
+    repeat
+      if (F^ = #0) or
+         (F^ = '%') then
+        break;
+      inc(F);
+    until false;
+    AddNoJsonEscape(S, F - S);
+    if F^ = #0 then
+      exit;
+    // add next value as text instead of F^='%' placeholder
+    if ValuesIndex <= high(Values) then // missing value will display nothing
+      Add(Values[ValuesIndex], Escape, WriteObjectOptions);
+    inc(F);
+    inc(ValuesIndex);
+  until false;
+end;
+
+procedure TJsonWriter.AddCsvUtf8(const Values: array of RawUtf8);
+var
+  i: PtrInt;
+begin
+  if length(Values) = 0 then
+    exit;
+  for i := 0 to high(Values) do
+  begin
+    Add('"');
+    AddJsonEscape(pointer(Values[i]));
+    AddDirect('"', ',');
+  end;
+  CancelLastComma;
+end;
+
+procedure TJsonWriter.AddCsvConst(const Values: array of const);
+var
+  i: PtrInt;
+begin
+  if length(Values) = 0 then
+    exit;
+  for i := 0 to high(Values) do
+  begin
+    AddJsonEscape(Values[i]);
+    AddComma;
+  end;
+  CancelLastComma;
+end;
+
+procedure TJsonWriter.Add(const Values: array of const);
+var
+  i: PtrInt;
+begin
+  for i := 0 to high(Values) do
+    AddJsonEscape(Values[i]);
+end;
+
+procedure TJsonWriter.Add(const Values: array of const; Escape: TTextWriterKind);
+var
+  i: PtrInt;
+begin
+  for i := 0 to high(Values) do
+    Add(Values[i], Escape);
+end;
+
+procedure TJsonWriter.AddQuotedStringAsJson(const QuotedString: RawUtf8);
+var
+  L: integer;
+  P, B: PUtf8Char;
+  quote: AnsiChar;
+begin
+  L := length(QuotedString);
+  if L = 0 then
+    exit;
+  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 // was not a quoted string
+    AddNoJsonEscape(pointer(QuotedString), length(QuotedString));
+end;
+
+procedure TJsonWriter.AddVariant(const Value: variant; Escape: TTextWriterKind;
+  WriteOptions: TTextWriterWriteObjectOptions);
+var
+  ctxt: TJsonSaveContext;
+  cv: TSynInvokeableVariantType;
+  v: PVarData;
+  vt: cardinal;
+  save: TRttiJsonSave;
+begin
+  v := @Value;
+  repeat
+    vt := v^.VType;
+    if vt <> varVariantByRef then
+      break;
+    v := v^.VPointer;
+  until false;
+  if vt <= high(VARIANT_JSONSAVE) then
+  begin
+    ctxt.W := self;
+    ctxt.Options := WriteOptions; // other fields are just ignored
+    save := VARIANT_JSONSAVE[vt];
+    if Assigned(save) then
+    begin
+      save(@v^.VAny, ctxt);
+      exit;
+    end;
+  end;
+  if vt = varString then
+    AddText(RawByteString(v^.VString), Escape)
+  else
+  case vt of
+    varOleStr {$ifdef HASVARUSTRING}, varUString{$endif}:
+      AddTextW(v^.VAny, Escape);
+    varAny:
+      // rkEnumeration,rkSet,rkDynArray,rkClass,rkInterface,rkRecord,rkObject
+      // from TRttiCustomProp.GetValueDirect/GetValueGetter
+      AddRttiVarData(PRttiVarData(v)^, Escape, WriteOptions);
+    varVariantByRef:
+      AddVariant(PVariant(v^.VPointer)^, Escape, WriteOptions);
+    varStringByRef:
+      AddText(PRawByteString(v^.VAny)^, Escape);
+    {$ifdef HASVARUSTRING} varUStringByRef, {$endif}
+    varOleStrByRef:
+      AddTextW(PPointer(v^.VAny)^, Escape)
+  else
+    begin
+      cv := FindSynVariantType(vt); // our custom types
+      if cv <> nil then
+        cv.ToJson(self, v)
+      else if not CustomVariantToJson(self, v, Escape) then // other custom
+        raise EJsonException.CreateUtf8('%.AddVariant VType=%', [self, vt]);
+    end;
+  end;
+end;
+
+procedure TJsonWriter.AddTypedJson(Value, TypeInfo: pointer;
+  WriteOptions: TTextWriterWriteObjectOptions);
+var
+  ctxt: TJsonSaveContext;
+  save: TRttiJsonSave;
+begin
+  {%H-}ctxt.Init(self, WriteOptions, Rtti.RegisterType(TypeInfo));
+  if ctxt.Info <> nil then
+  begin
+    save := ctxt.Info.JsonSave;
+    if Assigned(save) then
+      save(Value, ctxt)
+    else
+      BinarySaveBase64(Value, TypeInfo, rkRecordTypes, {withMagic=}true);
+  end
+  else
+    AddNull; // paranoid check
+end;
+
+procedure TJsonWriter.WriteObject(Value: TObject;
+  WriteOptions: TTextWriterWriteObjectOptions);
+var
+  ctxt: TJsonSaveContext;
+  save: TRttiJsonSave;
+begin
+  if Value <> nil then
+  begin
+    // Rtti.RegisterClass() may create fake RTTI if {$M+} was not used
+    {%H-}ctxt.Init(self, WriteOptions, Rtti.RegisterClass(PClass(Value)^));
+    save := ctxt.Info.JsonSave;
+    if Assigned(save) then
+    begin
+      save(@Value, ctxt);
+      exit;
+    end;
+  end;
+  AddNull;
+end;
+
+procedure TJsonWriter.AddRttiCustomJson(Value: pointer; RttiCustom: TObject;
+  Escape: TTextWriterKind; WriteOptions: TTextWriterWriteObjectOptions);
+var
+  ctxt: TJsonSaveContext;
+  save: TRttiJsonSave;
+begin
+  {%H-}ctxt.Init(self, WriteOptions, TRttiCustom(RttiCustom));
+  save := ctxt.Info.JsonSave;
+  if Assigned(save) then
+    save(Value, ctxt)
+  else
+    BinarySaveBase64(Value, ctxt.Info.Info, rkAllTypes,
+      {magic=}Escape <> twOnSameLine);
+end;
+
+procedure TJsonWriter.AddRttiVarData(const Value: TRttiVarData;
+  Escape: TTextWriterKind; WriteOptions: TTextWriterWriteObjectOptions);
+var
+  V64: Int64;
+begin
+  if Value.PropValueIsInstance then
+  begin
+    // from TRttiCustomProp.GetValueGetter
+    if rcfGetOrdProp in Value.Prop.Value.Cache.Flags then
+    begin
+      // rkEnumeration,rkSet,rkDynArray,rkClass,rkInterface
+      V64 := Value.Prop.Prop.GetOrdProp(Value.PropValue);
+      AddRttiCustomJson(@V64, Value.Prop.Value, Escape, WriteOptions);
+    end
+    else
+      // rkRecord,rkObject have no getter methods
+      raise EJsonException.CreateUtf8('%.AddRttiVarData: unsupported % (%)',
+        [self, Value.Prop.Value.Name, ToText(Value.Prop.Value.Kind)^]);
+  end
+  else
+    // from TRttiCustomProp.GetValueDirect
+    AddRttiCustomJson(Value.PropValue, Value.Prop.Value, Escape, WriteOptions);
+end;
+
+procedure TJsonWriter.AddText(const Text: RawByteString; Escape: TTextWriterKind);
+begin
+  if Escape = twJsonEscape then
+    Add('"');
+  {$ifdef HASCODEPAGE}
+  AddAnyAnsiString(Text, Escape);
+  {$else}
+  Add(pointer(Text), length(Text), Escape);
+  {$endif HASCODEPAGE}
+  if Escape <> twJsonEscape then
+    exit;
+  B[1] := '"';
+  inc(B);
+end;
+
+procedure TJsonWriter.AddTextW(P: PWord; Escape: TTextWriterKind);
+begin
+  if Escape = twJsonEscape then
+    Add('"');
+  AddW(P, 0, Escape);
+  if Escape <> twJsonEscape then
+    exit;
+  B[1] := '"';
+  inc(B);
+end;
+
+function TJsonWriter.AddJsonReformat(Json: PUtf8Char; Format: TTextWriterJsonFormat;
+ EndOfObject: PUtf8Char): PUtf8Char;
+var
+  objEnd: AnsiChar;
+  Name, Value: PUtf8Char;
+  NameLen: integer;
+  ValueLen: PtrInt;
+  tab: PJsonCharSet;
+begin
+  result := nil;
+  if Json = nil then
+    exit;
+  while (Json^ <= ' ') and
+        (Json^ <> #0) do
+    inc(Json);
+  case Json^ of
+    '[':
+      begin
+        // array
+        repeat
+          inc(Json)
+        until (Json^ = #0) or
+              (Json^ > ' ');
+        if Json^ = ']' then
+        begin
+          Add('[');
+          inc(Json);
+        end
+        else
+        begin
+          if Format in [jsonHumanReadable, jsonUnquotedPropName] then
+            AddCRAndIndent;
+          inc(fHumanReadableLevel);
+          Add('[');
+          repeat
+            if Json = nil then
+              exit;
+            if Format in [jsonHumanReadable, jsonUnquotedPropName] then
+              AddCRAndIndent;
+            Json := AddJsonReformat(Json, Format, @objEnd);
+            if objEnd = ']' then
+              break;
+            AddDirect(objEnd);
+          until false;
+          dec(fHumanReadableLevel);
+          if Format in [jsonHumanReadable, jsonUnquotedPropName] then
+            AddCRAndIndent;
+        end;
+        AddDirect(']');
+      end;
+    '{':
+      begin
+        // object
+        repeat
+          inc(Json)
+        until (Json^ = #0) or
+              (Json^ > ' ');
+        Add('{');
+        inc(fHumanReadableLevel);
+        if Format in [jsonHumanReadable, jsonUnquotedPropName] then
+          AddCRAndIndent;
+        if Json^ = '}' then
+          repeat
+            inc(Json)
+          until (Json^ = #0) or
+                (Json^ > ' ')
+        else
+          repeat
+            // processs property name
+            Name := GetJsonPropName(Json, @NameLen, {nounescape=}true);
+            if Name = nil then
+              exit;
+            if (Format in [jsonUnquotedPropName, jsonUnquotedPropNameCompact]) and
+               JsonPropNameValid(Name) then
+              AddNoJsonEscape(Name, NameLen)
+            else
+            begin
+              AddDirect('"');
+              if Format < jsonEscapeUnicode then
+                AddNoJsonEscape(Name, NameLen)
+              else if Format = jsonNoEscapeUnicode then
+                AddNoJsonEscapeForcedNoUnicode(Name, NameLen)
+              else
+                AddNoJsonEscapeForcedUnicode(Name, NameLen);
+              AddDirect('"');
+            end;
+            if Format in [jsonHumanReadable, jsonUnquotedPropName] then
+              AddDirect(':', ' ')
+            else
+              AddDirect(':');
+            // recurcisvely process value
+            while (Json^ <= ' ') and
+                  (Json^ <> #0) do
+              inc(Json);
+            Json := AddJsonReformat(Json, Format, @objEnd);
+            if objEnd = '}' then
+              break;
+            Add(objEnd);
+            if Format in [jsonHumanReadable, jsonUnquotedPropName] then
+              AddCRAndIndent;
+          until false;
+        dec(fHumanReadableLevel);
+        if Format in [jsonHumanReadable, jsonUnquotedPropName] then
+          AddCRAndIndent;
+        AddDirect('}');
+      end;
+    '"':
+      begin
+        // string
+        Value := Json;
+        Json := GotoEndOfJsonString2(Json + 1, @JSON_CHARS);
+        if Json^ <> '"' then
+          exit;
+        inc(Json);
+        if Format < jsonEscapeUnicode then
+          AddNoJsonEscape(Value, Json - Value)
+        else if Format = jsonNoEscapeUnicode then
+          AddNoJsonEscapeForcedNoUnicode(Value, Json - Value)
+        else
+          AddNoJsonEscapeForcedUnicode(Value, Json - Value);
+      end;
+  else
+    begin
+      // numeric value or true/false/null constant or MongoDB extended
+      tab := @JSON_CHARS;
+      if jcEndOfJsonFieldOr0 in tab[Json^] then
+        exit; // #0 , ] } :
+      Value := Json;
+      ValueLen := 0;
+      repeat
+        inc(ValueLen);
+      until jcEndOfJsonFieldOr0 in tab[Json[ValueLen]];
+      inc(Json, ValueLen);
+      while (ValueLen > 0) and
+            (Value[ValueLen - 1] <= ' ') do
+        dec(ValueLen);
+      AddShort(Value, ValueLen);
+    end;
+  end;
+  if Json = nil then
+    exit;
+  while (Json^ <= ' ') and
+        (Json^ <> #0) do
+    inc(Json);
+  if EndOfObject <> nil then
+    EndOfObject^ := Json^;
+  if Json^ <> #0 then
+    repeat
+      inc(Json)
+    until (Json^ = #0) or
+          (Json^ > ' ');
+  result := Json;
+end;
+
+function TJsonWriter.AddJsonToXML(Json: PUtf8Char;
+  ArrayName, EndOfObject: PUtf8Char): PUtf8Char;
+var
+  info: TGetJsonField;
+  Name: PUtf8Char;
+  n, c: integer;
+begin
+  result := nil;
+  if Json = nil then
+    exit;
+  while (Json^ <= ' ') and
+        (Json^ <> #0) do
+    inc(Json);
+  if Json^ = '/' then
+    Json := TryGotoEndOfComment(Json);
+  case Json^ of
+  '[':
+    begin
+      repeat
+        inc(Json);
+      until (Json^ = #0) or
+            (Json^ > ' ');
+      if Json^ = ']' then
+        Json := GotoNextNotSpace(Json + 1)
+      else
+      begin
+        n := 0;
+        repeat
+          if Json = nil then
+            exit;
+          Add('<');
+          if ArrayName = nil then
+            Add(n)
+          else
+            AddXmlEscape(ArrayName);
+          Add('>');
+          Json := AddJsonToXML(Json, nil, @info.EndOfObject);
+          Add('<', '/');
+          if ArrayName = nil then
+            Add(n)
+          else
+            AddXmlEscape(ArrayName);
+          Add('>');
+          inc(n);
+        until info.EndOfObject = ']';
+      end;
+    end;
+  '{':
+    begin
+      repeat
+        inc(Json);
+      until (Json^ = #0) or
+            (Json^ > ' ');
+      if Json^ = '}' then
+        Json := GotoNextNotSpace(Json + 1)
+      else
+      begin
+        repeat
+          Name := GetJsonPropName(Json);
+          if Name = nil then
+            exit;
+          while (Json^ <= ' ') and
+                (Json^ <> #0) do
+            inc(Json);
+          if Json^ = '[' then // arrays are written as list of items, without root
+            Json := AddJsonToXML(Json, Name, @info.EndOfObject)
+          else
+          begin
+            Add('<');
+            AddXmlEscape(Name);
+            Add('>');
+            Json := AddJsonToXML(Json, Name, @info.EndOfObject);
+            Add('<', '/');
+            AddXmlEscape(Name);
+            Add('>');
+          end;
+        until info.EndOfObject = '}';
+      end;
+    end;
+  else
+    begin // unescape the JSON content and write as UTF-8 escaped XML
+      info.Json := Json;
+      info.GetJsonField;
+      if info.Value = nil then
+        AddNull
+      else
+      begin
+        c := PInteger(info.Value)^ and $ffffff;
+        if (c = JSON_BASE64_MAGIC_C) or
+           (c = JSON_SQLDATE_MAGIC_C) then
+          inc(info.Value, 3); // ignore the Magic codepoint encoded as UTF-8
+        AddXmlEscape(info.Value);
+      end;
+      if EndOfObject <> nil then
+        EndOfObject^ := info.EndOfObject;
+      result := info.Json;
+      exit;
+    end;
+  end;
+  if Json <> nil then
+  begin
+    while (Json^ <= ' ') and
+          (Json^ <> #0) do
+      inc(Json);
+    if EndOfObject <> nil then
+      EndOfObject^ := Json^;
+    if Json^ <> #0 then
+      repeat
+        inc(Json);
+      until (Json^ = #0) or
+            (Json^ > ' ');
+  end;
+  result := Json;
+end;
+
+procedure TJsonWriter.AddJsonEscape(P: Pointer; Len: PtrInt);
+var
+  i, start: PtrInt;
+  {$ifdef CPUX86NOTPIC}
+  tab: TNormTableByte absolute JSON_ESCAPE;
+  {$else}
+  tab: PByteArray;
+  {$endif CPUX86NOTPIC}
+label
+  noesc;
+begin
+  if P = nil then
+    exit;
+  if Len = 0 then
+    dec(Len); // -1 = no end = AddJsonEscape(P, 0)
+  i := 0;
+  {$ifndef CPUX86NOTPIC}
+  tab := @JSON_ESCAPE;
+  {$endif CPUX86NOTPIC}
+  if tab[PByteArray(P)[i]] = JSON_ESCAPE_NONE then
+  begin
+noesc:
+    start := i;
+    if Len < 0 then  // fastest loop is with AddJsonEscape(P, 0)
+      repeat
+        inc(i);
+      until tab[PByteArray(P)[i]] <> JSON_ESCAPE_NONE
+    else
+      repeat
+        inc(i);
+      until (i >= Len) or
+            (tab[PByteArray(P)[i]] <> JSON_ESCAPE_NONE);
+    inc(PByte(P), start);
+    dec(i, start);
+    if Len >= 0 then
+      dec(Len, start);
+    if BEnd - B <= i then
+      AddNoJsonEscapeBig(P, i)
+    else
+    begin
+      MoveFast(P^, B[1], i);
+      inc(B, i);
+    end;
+    if (Len >= 0) and
+       (i >= Len) then
+      exit;
+  end;
+  repeat
+    if B >= BEnd then
+      FlushToStream;
+    case tab[PByteArray(P)[i]] of // better codegen with no temp var
+      JSON_ESCAPE_NONE:
+        goto noesc;
+      JSON_ESCAPE_ENDINGZERO:
+        // #0
+        exit;
+      JSON_ESCAPE_UNICODEHEX:
+        begin
+          // characters below ' ', #7 e.g. -> // 'u0007'
+          PCardinal(B + 1)^ :=
+            ord('\') + ord('u') shl 8 + ord('0') shl 16 + ord('0') shl 24;
+          inc(B, 4);
+          PWord(B + 1)^ := TwoDigitsHexWB[PByteArray(P)[i]];
+        end;
+    else
+      // escaped as \ + b,t,n,f,r,\,"
+      PWord(B + 1)^ := (integer(tab[PByteArray(P)[i]]) shl 8) or ord('\');
+    end;
+    inc(i);
+    inc(B, 2);
+  until (Len >= 0) and
+        (i >= Len);
+end;
+
+procedure TJsonWriter.AddJsonEscapeString(const s: string);
+begin
+  if s <> '' then
+    {$ifdef UNICODE}
+    AddJsonEscapeW(pointer(s), Length(s));
+    {$else}
+    AddAnyAnsiString(s, twJsonEscape, 0);
+    {$endif UNICODE}
+end;
+
+procedure TJsonWriter.AddJsonEscapeAnsiString(const s: AnsiString);
+begin
+  AddAnyAnsiString(s, twJsonEscape, 0);
+end;
+
+procedure TJsonWriter.AddJsonEscapeW(P: PWord; Len: PtrInt);
+var
+  i, c, s: PtrInt;
+  esc: byte;
+  tab: PByteArray;
+begin
+  if P = nil then
+    exit;
+  if Len = 0 then
+    Len := MaxInt;
+  i := 0;
+  while i < Len do
+  begin
+    s := i;
+    tab := @JSON_ESCAPE;
+    repeat
+      c := PWordArray(P)[i];
+      if (c <= 127) and
+         (tab[c] <> JSON_ESCAPE_NONE) then
+        break;
+      inc(i);
+    until i >= Len;
+    if i <> s then
+      AddNoJsonEscapeW(@PWordArray(P)[s], i - s);
+    if i >= Len then
+      exit;
+    c := PWordArray(P)[i];
+    if c = 0 then
+      exit;
+    esc := tab[c];
+    if esc = JSON_ESCAPE_ENDINGZERO then // #0
+      exit
+    else if esc = JSON_ESCAPE_UNICODEHEX then
+    begin
+      // characters below ' ', #7 e.g. -> \u0007
+      AddShorter('\u00');
+      AddByteToHex(c);
+    end
+    else
+      Add('\', AnsiChar(esc)); // escaped as \ + b,t,n,f,r,\,"
+    inc(i);
+  end;
+end;
+
+procedure TJsonWriter.AddJsonEscape(const V: TVarRec);
+begin
+  with V do
+    case VType of
+      vtPointer:
+        AddNull;
+      vtString,
+      vtAnsiString,
+      {$ifdef HASVARUSTRING}vtUnicodeString, {$endif}
+      vtPChar,
+      vtChar,
+      vtWideChar,
+      vtWideString,
+      vtClass:
+        begin
+          Add('"');
+          case VType of
+            vtString:
+              if (VString <> nil) and
+                 (VString^[0] <> #0) then
+                AddJsonEscape(@VString^[1], ord(VString^[0]));
+            vtAnsiString:
+              AddJsonEscape(VAnsiString);
+            {$ifdef HASVARUSTRING}
+            vtUnicodeString:
+              AddJsonEscapeW(pointer(UnicodeString(VUnicodeString)),
+                              length(UnicodeString(VUnicodeString)));
+            {$endif HASVARUSTRING}
+            vtPChar:
+              AddJsonEscape(VPChar);
+            vtChar:
+              AddJsonEscape(@VChar, 1);
+            vtWideChar:
+              AddJsonEscapeW(@VWideChar, 1);
+            vtWideString:
+              AddJsonEscapeW(VWideString);
+            vtClass:
+              AddClassName(VClass);
+          end;
+          AddDirect('"');
+        end;
+      vtBoolean:
+        Add(VBoolean); // 'true'/'false'
+      vtInteger:
+        Add(VInteger);
+      vtInt64:
+        Add(VInt64^);
+      {$ifdef FPC}
+      vtQWord:
+        AddQ(V.VQWord^);
+      {$endif FPC}
+      vtExtended:
+        AddDouble(VExtended^);
+      vtCurrency:
+        AddCurr64(VInt64);
+      vtObject:
+        WriteObject(VObject);
+      vtVariant:
+        AddVariant(VVariant^, twJsonEscape);
+    end;
+end;
+
+procedure TJsonWriter.AddJsonEscape(Source: TJsonWriter);
+begin
+  if Source.fTotalFileSize = 0 then
+    AddJsonEscape(Source.fTempBuf, Source.B - Source.fTempBuf + 1)
+  else
+    AddJsonEscape(Pointer(Source.Text));
+end;
+
+procedure TJsonWriter.AddNoJsonEscape(Source: TJsonWriter);
+begin
+  if Source.fTotalFileSize = 0 then
+    AddNoJsonEscape(Source.fTempBuf, Source.B - Source.fTempBuf + 1)
+  else
+    AddNoJsonEscapeUtf8(Source.Text);
+end;
+
+procedure TJsonWriter.AddNoJsonEscapeForcedUnicode(P: PUtf8Char; Len: PtrInt);
+var
+  S, P2: PUtf8Char;
+  c: cardinal;
+  tab: PByteToWord;
+label
+  nxt;
+begin
+  if Len > 0 then
+  repeat
+    // handle 7-bit ASCII chars, by quad if possible
+    S := P;
+    if Len >= 4 then
+      repeat
+        if PCardinal(S)^ and $80808080 <> 0 then
+          break; // break on first non ASCII quad
+        inc(S, 4);
+        dec(Len, 4);
+      until Len < 4;
+    if (Len > 0) and
+       (S^ <= #127) then // some 1..3 trailing ASCII chars
+      repeat
+        inc(S);
+        dec(Len);
+      until (Len = 0) or
+            (S^ > #127);
+    P2 := P;
+    P := S;
+    dec(S, PtrUInt(P2));
+    if S <> nil then
+      AddNoJsonEscape(P2, PtrUInt(S));
+nxt:if Len = 0 then
+      exit;
+    // some characters needs UTF-16 \u#### Unicode encoding
+    if B >= BEnd then
+      FlushToStream;
+    P2 := P;
+    c := UTF8_TABLE.GetHighUtf8Ucs4(P);
+    dec(Len, P - P2);
+    if (Len < 0) or
+       (c = 0) then
+      break;
+    tab := @TwoDigitsHexWBLower;
+    if c <= $ffff then
+      Utf16ToJsonUnicodeEscape(B, c, tab)
+    else
+    begin
+      dec(c, $10000); // store as UTF-16 surrogates
+      Utf16ToJsonUnicodeEscape(B, (c shr 10) or UTF16_HISURROGATE_MIN, tab);
+      Utf16ToJsonUnicodeEscape(B, (c and $3FF) or UTF16_LOSURROGATE_MIN, tab);
+    end;
+    if P^ > #127 then
+      goto nxt;
+  until false;
+end;
+
+procedure TJsonWriter.AddNoJsonEscapeForcedNoUnicode(P: PUtf8Char; Len: PtrInt);
+var
+  P2: PUtf8Char;
+begin
+  if Len > 0 then
+  repeat
+    P2 := P;
+    repeat
+      if P^ <> '\' then // quickly search for \### escape marker
+      begin
+        inc(P);
+        dec(Len);
+        if Len = 0 then
+          break;
+        continue;
+      end;
+      if P[1] = 'u' then // found a \u#### pattern
+        break;
+      inc(P, 2); // ignore this \# two-chars escape block
+      dec(Len, 2);
+      if Len = 0 then
+        break;
+      if Len < 0 then
+        exit;
+    until false;
+    if P <> P2 then
+      AddNoJsonEscape(P2, P - P2);
+    if Len <= 0 then
+      exit;
+    // some characters needs UTF-16 \u#### Unicode decoding
+    if B >= BEnd then
+      FlushToStream;
+    P2 := P;
+    inc(P); // P^ should point at 'u1234' just after \u1234
+    inc(B);
+    P := JsonUnicodeEscapeToUtf8(B, P); // decode up to two UTF-16 surrogates
+    dec(B);
+    dec(Len, P - P2);
+  until Len <= 0;
+end;
+
+procedure TJsonWriter.AddJsonString(const Text: RawUtf8);
+begin
+  Add('"');
+  AddJsonEscape(pointer(Text));
+  B[1] := '"';
+  inc(B);
+end;
+
+procedure TJsonWriter.Add(const V: TVarRec; Escape: TTextWriterKind;
+  WriteObjectOptions: TTextWriterWriteObjectOptions);
+begin
+  with V do
+    case VType of
+      vtInteger:
+        Add(VInteger);
+      vtBoolean:
+        if VBoolean then // normalize
+          Add('1')
+        else
+          Add('0');
+      vtChar:
+        Add(@VChar, 1, Escape);
+      vtExtended:
+        AddDouble(VExtended^);
+      vtCurrency:
+        AddCurr64(VInt64);
+      vtInt64:
+        Add(VInt64^);
+      {$ifdef FPC}
+      vtQWord:
+        AddQ(VQWord^);
+      {$endif FPC}
+      vtVariant:
+        AddVariant(VVariant^, Escape);
+      vtString:
+        if (VString <> nil) and
+           (VString^[0] <> #0) then
+          Add(@VString^[1], ord(VString^[0]), Escape);
+      vtInterface,
+      vtPointer:
+        AddPointer(PtrUInt(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 // expect RawUtf8
+          Add(VAnsiString, length(RawUtf8(VAnsiString)), Escape);
+      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 HASVARUSTRING}
+    end;
+end;
+
+procedure TJsonWriter.AddJson(const Format: RawUtf8; const Args, Params: array of const);
+var
+  temp: variant;
+begin
+  _JsonFmt(Format, Args, Params, JSON_FAST, temp);
+  AddVariant(temp, twJsonEscape);
+end;
+
+procedure TJsonWriter.AddJsonArraysAsJsonObject(keys, values: PUtf8Char);
+var
+  k, v: PUtf8Char;
+  parser: TJsonGotoEndParser;
+begin
+  if (keys = nil) or
+     (keys[0] <> '[') or
+     (values = nil) or
+     (values[0] <> '[') or
+     (keys[1] = ']') or
+     (values[1] = ']') then
+  begin
+    AddNull;
+    exit;
+  end;
+  inc(keys); // jump initial [
+  inc(values);
+  Add('{');
+  {%H-}parser.Init({strict=}false, nil);
+  repeat
+    k := parser.GotoEnd(keys);
+    v := parser.GotoEnd(values);
+    if (k = nil) or
+       (v = nil) then
+      break; // invalid JSON input
+    AddNoJsonEscape(keys, k - keys);
+    AddDirect(':');
+    AddNoJsonEscape(values, v - values);
+    AddComma;
+    if (k^ <> ',') or
+       (v^ <> ',') then
+      break; // reached the end of the input JSON arrays
+    keys := k + 1;
+    values := v + 1;
+  until false;
+  CancelLastComma('}');
+end;
+
+procedure TJsonWriter.AddJsonEscape(const NameValuePairs: array of const);
+var
+  a: integer;
+
+  procedure WriteValue;
+  begin
+    case VarRecAsChar(NameValuePairs[a]) of
+      ord('['):
+        begin
+          Add('[');
+          while a < high(NameValuePairs) do
+          begin
+            inc(a);
+            if VarRecAsChar(NameValuePairs[a]) = ord(']') then
+              break;
+            WriteValue;
+          end;
+          CancelLastComma(']');
+        end;
+      ord('{'):
+        begin
+          Add('{');
+          while a < high(NameValuePairs) do
+          begin
+            inc(a);
+            if VarRecAsChar(NameValuePairs[a]) = ord('}') then
+              break;
+            AddJsonEscape(NameValuePairs[a]);
+            Add(':');
+            inc(a);
+            WriteValue;
+          end;
+          CancelLastComma('}');
+        end
+    else
+      AddJsonEscape(NameValuePairs[a]);
+    end;
+    AddComma;
+  end;
+
+begin
+  Add('{');
+  a := 0;
+  while a < high(NameValuePairs) do
+  begin
+    AddJsonEscape(NameValuePairs[a]);
+    inc(a);
+    AddDirect(':');
+    WriteValue;
+    inc(a);
+  end;
+  CancelLastComma('}');
+end;
+
+function TJsonWriter.AddRecordJson(Value: pointer; RecordInfo: PRttiInfo;
+  WriteOptions: TTextWriterWriteObjectOptions): PtrInt;
+var
+  ctxt: TJsonSaveContext;
+begin
+  {%H-}ctxt.Init(self, WriteOptions, Rtti.RegisterType(RecordInfo));
+  if rcfHasNestedProperties in ctxt.Info.Flags then
+    // we know the fields from text definition
+    TRttiJsonSave(ctxt.Info.JsonSave)(Value, ctxt)
+  else
+    // fallback to binary serialization, trailing crc32c and Base64 encoding
+    BinarySaveBase64(Value, RecordInfo, rkRecordTypes, {magic=}true);
+  result := ctxt.Info.Size;
+end;
+
+procedure TJsonWriter.AddVoidRecordJson(RecordInfo: PRttiInfo;
+  WriteOptions: TTextWriterWriteObjectOptions);
+var
+  tmp: TSynTempBuffer;
+begin
+  tmp.InitZero(RecordInfo.RecordSize);
+  AddRecordJson(tmp.buf, RecordInfo, WriteOptions);
+  tmp.Done;
+end;
+
+procedure TJsonWriter.AddDynArrayJson(var DynArray: TDynArray;
+  WriteOptions: TTextWriterWriteObjectOptions);
+var
+  ctxt: TJsonSaveContext;
+  len, backup: PtrInt;
+  hacklen: PDALen;
+begin
+  len := DynArray.Count;
+  if len = 0 then
+    Add('[', ']')
+  else
+  begin
+    {%H-}ctxt.Init(self, WriteOptions, DynArray.Info);
+    hacklen := PDALen(PAnsiChar(DynArray.Value^) - _DALEN);
+    backup := hacklen^;
+    hacklen^ := len - _DAOFF; // may use ExternalCount -> ovewrite length(Array)
+    _JS_DynArray(DynArray.Value, ctxt);
+    hacklen^ := backup; // restore original length/capacity
+  end;
+end;
+
+procedure TJsonWriter.AddDynArrayJson(var DynArray: TDynArrayHashed;
+  WriteOptions: TTextWriterWriteObjectOptions);
+begin
+  // needed if UNDIRECTDYNARRAY is defined (Delphi 2009+)
+  AddDynArrayJson(PDynArray(@DynArray)^, WriteOptions);
+end;
+
+function TJsonWriter.AddDynArrayJson(Value: pointer; Info: TRttiCustom;
+  WriteOptions: TTextWriterWriteObjectOptions): PtrInt;
+var
+  temp: TDynArray;
+begin
+  if Info.Kind <> rkDynArray then
+    raise EDynArray.CreateUtf8('%.AddDynArrayJson: % is %, expected rkDynArray',
+      [self, Info.Name, ToText(Info.Kind)^]);
+  temp.InitRtti(Info, Value^);
+  AddDynArrayJson(temp, WriteOptions);
+  result := temp.Info.Cache.ItemSize;
+end;
+
+
+{ ********** Low-Level JSON UnSerialization for all TRttiParserType }
+
+{ TJsonParserContext }
+
+procedure TJsonParserContext.InitParser(P: PUtf8Char; Rtti: TRttiCustom;
+  O: TJsonParserOptions; CV: PDocVariantOptions; ObjectListItemClass: TClass;
+  RawUtf8Interning: TRawUtf8Interning);
+begin
+  {$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := P;
+  Valid := true;
+  Interning := RawUtf8Interning;
+  if Rtti <> nil then
+    O := O + TRttiJson(Rtti).fIncludeReadOptions;
+  Options := O;
+  if CV <> nil then
+  begin
+    DVO := CV^;
+    CustomVariant := @DVO;
+  end
+  else if jpoHandleCustomVariants in O then
+  begin
+    if jpoAllowDouble in o then
+      DVO := JSON_FAST_FLOAT
+    else
+      DVO := JSON_FAST;
+    CustomVariant := @DVO;
+  end
+  else
+    CustomVariant := nil;
+  if jpoHandleCustomVariantsWithinString in O then
+    include(DVO, dvoJsonObjectParseWithinString);
+  Info := Rtti;
+  Prop := nil;
+  if ObjectListItemClass = nil then
+    ObjectListItem := nil
+  else
+    ObjectListItem := mormot.core.rtti.Rtti.RegisterClass(ObjectListItemClass);
+end;
+
+{$ifdef USERECORDWITHMETHODS}
+function TJsonParserContext.Json: PUtf8Char;
+begin
+  result := Get.Json;
+end;
+
+function TJsonParserContext.Value: PUtf8Char;
+begin
+  result := Get.Value;
+end;
+
+function TJsonParserContext.ValueLen: PtrInt;
+begin
+  result := Get.ValueLen;
+end;
+
+function TJsonParserContext.WasString: boolean;
+begin
+  result := Get.WasString;
+end;
+
+function TJsonParserContext.EndOfObject: AnsiChar;
+begin
+  result := Get.EndOfObject;
+end;
+
+{$endif USERECORDWITHMETHODS}
+
+function TJsonParserContext.ParseNext: boolean;
+begin
+  {$ifdef USERECORDWITHMETHODS}Get.{$endif}GetJsonField;
+  result := Json <> nil;
+  Valid := result;
+end;
+
+function TJsonParserContext.ParseNextAny: boolean;
+begin
+  {$ifdef USERECORDWITHMETHODS}Get.{$endif}GetJsonFieldOrObjectOrArray;
+  result := Json <> nil;
+  Valid := result;
+end;
+
+function TJsonParserContext.ParseUtf8: RawUtf8;
+begin
+  {$ifdef USERECORDWITHMETHODS}Get.{$endif}GetJsonField;
+  Valid := Json <> nil;
+  Interning.Unique(result, Value, ValueLen)
+end;
+
+function TJsonParserContext.ParseString: string;
+begin
+  {$ifdef USERECORDWITHMETHODS}Get.{$endif}GetJsonField;
+  Valid := Json <> nil;
+  Utf8DecodeToString(Value, ValueLen, result);
+end;
+
+function TJsonParserContext.ParseInteger: Int64;
+begin
+  if ParseNext then
+    SetInt64(Value, result{%H-})
+  else
+    result := 0;
+end;
+
+procedure TJsonParserContext.ParseEndOfObject;
+var
+  P: PUtf8Char;
+begin
+  if Valid then
+  begin
+    P := Json;
+    if P^ <> #0 then
+      P := mormot.core.json.ParseEndOfObject(
+        P, {$ifdef USERECORDWITHMETHODS}Get.{$endif}EndOfObject);
+    {$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := P;
+    Valid := P <> nil;
+  end;
+end;
+
+function TJsonParserContext.ParseNull: boolean;
+var
+  P: PUtf8Char;
+begin
+  result := false;
+  if Valid then
+    if Json <> nil then
+    begin
+      P := GotoNextNotSpace(Json);
+      {$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := P;
+      if PCardinal(P)^ = NULL_LOW then
+      begin
+        P := mormot.core.json.ParseEndOfObject(
+          P + 4, {$ifdef USERECORDWITHMETHODS}Get.{$endif}EndOfObject);
+        if P <> nil then
+        begin
+          {$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := P;
+          result := true;
+        end
+        else
+          Valid := false;
+      end;
+    end
+    else
+      result := true; // nil -> null
+end;
+
+function TJsonParserContext.ParseArray: boolean;
+var
+  P: PUtf8Char;
+begin
+  result := false; // no need to parse
+  P := GotoNextNotSpace(Json);
+  {$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := P;
+  if P^ = '[' then
+  begin
+    P := GotoNextNotSpace(P + 1); // ignore trailing [
+    if P^ = ']' then
+    begin
+      // void but valid array
+      P := mormot.core.json.ParseEndOfObject(
+        P + 1, {$ifdef USERECORDWITHMETHODS}Get.{$endif}EndOfObject);
+      Valid := P <> nil;
+      {$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := P;
+    end
+    else
+    begin
+      // we have a non void [...] array -> caller should parse it
+      result := true;
+      {$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := P;
+    end;
+  end
+  else
+    Valid := ParseNull; // only not [...] value allowed is null
+end;
+
+function TJsonParserContext.ParseObject: boolean;
+var
+  P: PUtf8Char;
+begin
+  result := false; // no need to parse
+  P := GotoNextNotSpace(Json);
+  {$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := P;
+  if P^ = '{' then
+  begin
+    P := GotoNextNotSpace(P + 1); // ignore trailing {
+    if P^ = '}' then
+    begin
+      // void but valid array
+      P := mormot.core.json.ParseEndOfObject(
+        P + 1, {$ifdef USERECORDWITHMETHODS}Get.{$endif}EndOfObject);
+      Valid := P <> nil;
+      {$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := P;
+    end
+    else
+    begin
+      // we have a non void {...} array -> caller should parse it
+      result := true;
+      {$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := P;
+    end;
+  end
+  else
+    Valid := ParseNull; // only not {...} value allowed is null
+end;
+
+function TJsonParserContext.ParseNewObject: TObject;
+begin
+  if ObjectListItem = nil then
+  begin
+    Info := JsonRetrieveObjectRttiCustom({$ifdef USERECORDWITHMETHODS}Get.{$endif}Json,
+      jpoObjectListClassNameGlobalFindClass in Options);
+    if (Info <> nil) and
+       (Json^ = ',') then
+      Json^ := '{' // to parse other properties as a regular Json object
+    else
+    begin
+      Valid := false;
+      result := nil;
+      exit;
+    end;
+  end;
+  result := TRttiJson(Info).ParseNewInstance(self);
+end;
+
+function TJsonParserContext.ParseObject(const Names: array of RawUtf8;
+  Values: PValuePUtf8CharArray; HandleValuesAsObjectOrArray: boolean): boolean;
+begin
+  {$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := JsonDecode(
+    Json, Names, Values, HandleValuesAsObjectOrArray);
+  if Json = nil then
+    Valid := false
+  else
+    ParseEndOfObject;
+  result := Valid;
+end;
+
+procedure _JL_Boolean(Data: PBoolean; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    Data^ := GetBoolean(Ctxt.Value);
+end;
+
+procedure _JL_Byte(Data: PByte; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    Data^ := GetCardinal(Ctxt.Value);
+end;
+
+procedure _JL_Cardinal(Data: PCardinal; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    Data^ := GetCardinal(Ctxt.Value);
+end;
+
+procedure _JL_Integer(Data: PInteger; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    Data^ := GetInteger(Ctxt.Value);
+end;
+
+procedure _JL_Currency(Data: PInt64; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    Data^ := StrToCurr64(Ctxt.Value);
+end;
+
+procedure _JL_Double(Data: PDouble; var Ctxt: TJsonParserContext);
+var
+  err: integer;
+begin
+  if Ctxt.ParseNext then
+  begin
+    unaligned(Data^) := GetExtended(Ctxt.Value, err);
+    Ctxt.Valid := (Ctxt.Value = nil) or (err = 0);
+  end;
+end;
+
+procedure _JL_Extended(Data: PSynExtended; var Ctxt: TJsonParserContext);
+var
+  err: integer;
+begin
+  if Ctxt.ParseNext then
+  begin
+    Data^ := GetExtended(Ctxt.Value, err);
+    Ctxt.Valid := (Ctxt.Value = nil) or (err = 0);
+  end;
+end;
+
+procedure _JL_Int64(Data: PInt64; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    if Ctxt.WasString and
+       (Ctxt.ValueLen = SizeOf(Data^) * 2) then
+      Ctxt.Valid := (jpoAllowInt64Hex in Ctxt.Options) and
+        HexDisplayToBin(PAnsiChar(Ctxt.Value), pointer(Data), SizeOf(Data^))
+    else
+      SetInt64(Ctxt.Value, Data^);
+end;
+
+procedure _JL_QWord(Data: PQWord; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    if Ctxt.WasString and
+       (Ctxt.ValueLen = SizeOf(Data^) * 2) then
+      Ctxt.Valid := (jpoAllowInt64Hex in Ctxt.Options) and
+        HexDisplayToBin(PAnsiChar(Ctxt.Value), pointer(Data), SizeOf(Data^))
+    else
+      SetQWord(Ctxt.Value, Data^);
+end;
+
+procedure _JL_RawByteString(Data: PRawByteString; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    if Ctxt.Value = nil then // null
+      Data^ := ''
+    else if not Ctxt.WasString then
+      Ctxt.Valid := false
+    else if Base64MagicTryAndDecode(Ctxt.Value, Ctxt.ValueLen, Data^) then
+      exit // base64-encoded, with magic or not
+    else
+      FastSetRawByteString(Data^, Ctxt.Value, Ctxt.ValueLen); // fallback as text
+end;
+
+procedure _JL_RawJson(Data: PRawJson; var Ctxt: TJsonParserContext);
+begin
+  GetJsonItemAsRawJson(Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json,
+    Data^, @Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}EndOfObject);
+  Ctxt.Valid := Ctxt.Json <> nil;
+end;
+
+procedure _JL_RawUtf8(Data: PRawByteString; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    // will handle RawUtf8 but also AnsiString, WinAnsiString or other CP
+    if Ctxt.Info.Cache.CodePage = CP_UTF8 then
+      Ctxt.Interning.Unique(RawUtf8(Data^), Ctxt.Value, Ctxt.ValueLen)
+    else if Ctxt.Info.Cache.CodePage >= CP_RAWBLOB then
+      Ctxt.Valid := false // paranoid check (RawByteString should handle it)
+    else
+      Ctxt.Info.Cache.Engine.Utf8BufferToAnsi(Ctxt.Value, Ctxt.ValueLen, Data^);
+end;
+
+procedure _JL_Single(Data: PSingle; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    Data^ := GetExtended(Ctxt.Value);
+end;
+
+procedure _JL_String(Data: PString; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    Utf8DecodeToString(Ctxt.Value, Ctxt.ValueLen, Data^);
+end;
+
+procedure _JL_SynUnicode(Data: PSynUnicode; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    Utf8ToSynUnicode(Ctxt.Value, Ctxt.ValueLen, Data^);
+end;
+
+procedure _JL_Char(Data: PByte; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    if Ctxt.WasString then
+      if Ctxt.ValueLen <> 0 then
+        Data^ := ord(Ctxt.Value[0]) // get the first char of the input string
+      else
+        Data^ := 0 // _JS_Char serializes #0 as ""
+    else
+      Data^ := GetCardinal(Ctxt.Value); // allow serialization as integer
+end;
+
+procedure _JL_WideChar(Data: PWord; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    if Ctxt.WasString then
+      Data^ := GetUtf8WideChar(Ctxt.Value)
+    else
+      Data^ := GetCardinal(Ctxt.Value);
+end;
+
+procedure _JL_DateTime(Data: PDateTime; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    if Ctxt.WasString then
+      Iso8601ToDateTimePUtf8CharVar(Ctxt.Value, Ctxt.ValueLen, Data^)
+    else
+      Data^ := GetExtended(Ctxt.Value); // was propbably stored as double
+end;
+
+procedure _JL_GUID(Data: PByteArray; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    Ctxt.Valid := TextToGuid(Ctxt.Value, Data) <> nil;
+end;
+
+procedure _JL_Hash(Data: PByte; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    Ctxt.Valid := (Ctxt.ValueLen = Ctxt.Info.Size * 2) and
+      HexDisplayToBin(PAnsiChar(Ctxt.Value), Data, Ctxt.Info.Size);
+end;
+
+procedure _JL_Binary(Data: PByte; var Ctxt: TJsonParserContext);
+var
+  v: QWord;
+begin
+  if Ctxt.ParseNext then
+    if Ctxt.WasString then
+    begin
+      FillZeroSmall(Data, Ctxt.Info.Size); // BinarySize may be < Size
+      if Ctxt.ValueLen > 0 then // "" -> is valid 0
+        Ctxt.Valid := (Ctxt.ValueLen = Ctxt.Info.BinarySize * 2) and
+          HexDisplayToBin(PAnsiChar(Ctxt.Value), Data, Ctxt.Info.BinarySize);
+    end
+    else
+    begin
+      SetQWord(Ctxt.Value, v{%H-});
+      MoveFast(v, Data^, Ctxt.Info.Size);
+    end;
+end;
+
+procedure _JL_TimeLog(Data: PQWord; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    if Ctxt.WasString then
+      Data^ := Iso8601ToTimeLogPUtf8Char(Ctxt.Value, Ctxt.ValueLen)
+    else
+      SetQWord(Ctxt.Value, Data^);
+end;
+
+procedure _JL_UnicodeString(Data: pointer; var Ctxt: TJsonParserContext);
+begin
+  Ctxt.ParseNext;
+  {$ifdef HASVARUSTRING}
+  if Ctxt.Valid then
+    Utf8DecodeToUnicodeString(Ctxt.Value, Ctxt.ValueLen, PUnicodeString(Data)^);
+  {$endif HASVARUSTRING}
+end;
+
+procedure _JL_UnixTime(Data: PQWord; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    if Ctxt.WasString then
+      Data^ := TimeLogToUnixTime(Iso8601ToTimeLogPUtf8Char(
+        Ctxt.Value, Ctxt.ValueLen))
+    else
+      SetQWord(Ctxt.Value, Data^);
+end;
+
+procedure _JL_UnixMSTime(Data: PQWord; var Ctxt: TJsonParserContext);
+var
+  dt: TDateTime; // for ms resolution
+begin
+  if Ctxt.ParseNext then
+    if Ctxt.WasString then
+    begin
+      Iso8601ToDateTimePUtf8CharVar(Ctxt.Value, Ctxt.ValueLen, dt);
+      Data^ := DateTimeToUnixMSTime(dt);
+    end
+    else
+      SetQWord(Ctxt.Value, Data^);
+end;
+
+procedure _JL_Variant(Data: PVariant; var Ctxt: TJsonParserContext);
+begin
+  JsonToAnyVariant(Data^, Ctxt{$ifdef USERECORDWITHMETHODS}.Get{$endif},
+    Ctxt.CustomVariant, jpoAllowDouble in Ctxt.Options);
+  Ctxt.Valid := Ctxt.Json <> nil;
+end;
+
+procedure _JL_WideString(Data: PWideString; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    Utf8ToWideString(Ctxt.Value, Ctxt.ValueLen, Data^);
+end;
+
+procedure _JL_WinAnsi(Data: PRawByteString; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    WinAnsiConvert.Utf8BufferToAnsi(Ctxt.Value, Ctxt.ValueLen, Data^);
+end;
+
+procedure _JL_Word(Data: PWord; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.ParseNext then
+    Data^ := GetCardinal(Ctxt.Value);
+end;
+
+procedure _JL_Enumeration(Data: pointer; var Ctxt: TJsonParserContext);
+var
+  v: PtrInt;
+  err: integer;
+begin
+  if Ctxt.ParseNext then
+  begin
+    if Ctxt.WasString then
+      v := Ctxt.Info.Cache.EnumInfo.GetEnumNameValue(Ctxt.Value, Ctxt.ValueLen)
+    else
+    begin
+      v := GetInteger(Ctxt.Value, err);
+      if (err <> 0) or
+         (PtrUInt(v) > Ctxt.Info.Cache.EnumMax) or
+         (PtrUInt(v) < Ctxt.Info.Cache.EnumMin) then
+        v := -1;
+    end;
+    if v < 0 then
+      if jpoIgnoreUnknownEnum in Ctxt.Options then
+        v := 0
+      else
+        Ctxt.Valid := false;
+    MoveFast(v, Data^, Ctxt.Info.Size);
+  end;
+end;
+
+procedure _JL_Set(Data: pointer; var Ctxt: TJsonParserContext);
+var
+  v: QWord;
+begin
+  with Ctxt.Info.Cache do
+    v := GetSetNameValue(EnumList, EnumMin, EnumMax,
+      Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json,
+      Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}EndOfObject);
+  Ctxt.Valid := Ctxt.Json <> nil;
+  MoveFast(v, Data^, Ctxt.Info.Size);
+end;
+
+function JsonLoadProp(Data: PAnsiChar; Prop: PRttiCustomProp;
+  var Ctxt: TJsonParserContext): boolean; {$ifdef HASINLINE} inline; {$endif}
+var
+  load: TRttiJsonLoad;
+begin
+  Ctxt.Info := Prop^.Value; // caller will restore it afterwards
+  Ctxt.Prop := Prop;
+  load := Ctxt.Info.JsonLoad;
+  if not Assigned(load) then
+    Ctxt.Valid := false
+  else if Prop^.OffsetSet >= 0 then
+    if (rcfHookReadProperty in Ctxt.Info.Flags) and
+       TCCHook(Data).RttiBeforeReadPropertyValue(@Ctxt, Prop) then
+      // custom parsing method (e.g. TOrm nested TOrm properties)
+    else
+      // default fast parsing into the property/field memory
+      load(Data + Prop^.OffsetSet, Ctxt)
+  else
+    // we need to call a setter
+    Ctxt.ParsePropComplex(Data);
+  Ctxt.Prop := nil;
+  result := Ctxt.Valid;
+end;
+
+procedure _JL_RttiCustomProps(Data: PAnsiChar; var Ctxt: TJsonParserContext);
+var
+  j: PUtf8Char;
+  root: TRttiJson;
+  prop: PRttiCustomProp;
+  propname: PUtf8Char;
+  p, propnamelen: integer;
+label
+  no, nxt, any;
+begin
+  // regular JSON unserialization using nested fields/properties
+  j := GotoNextNotSpace(Ctxt.Json);
+  if j^ <> '{' then
+  begin
+no: Ctxt.Valid := false;
+    exit;
+  end;
+  repeat
+    inc(j);
+  until not (j^ in [#1..' ']);
+  if j^ <> '}' then
+  begin
+    Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := j;
+    root := pointer(Ctxt.Info); // Ctxt.Info overriden in JsonLoadProp()
+    prop := pointer(root.Props.List);
+    for p := 1 to root.Props.Count do
+    begin
+nxt:  propname := GetJsonPropName(
+        Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json, @propnamelen);
+      if (Ctxt.Json = nil) or
+         (propname = nil) then
+        goto no;
+      // O(1) optimistic process of the property name, following RTTI order
+      if prop^.NameMatch(propname, propnamelen) then
+        if JsonLoadProp(Data, prop, Ctxt) then
+          if Ctxt.EndOfObject = '}' then
+            break
+          else
+            inc(prop)
+        else
+          break
+      else if (Ctxt.Info.Kind = rkClass) and
+              (propnamelen = 9) and // fast "ClassName" case sensitive match
+              (PIntegerArray(propname)[0] =
+                ord('C') + ord('l') shl 8 + ord('a') shl 16 + ord('s') shl 24) and
+              (PIntegerArray(propname)[1] =
+                ord('s') + ord('N') shl 8 + ord('a') shl 16 + ord('m') shl 24) and
+              (propname[8] = 'e') then
+      // woStoreClassName was used -> just ignore the class name
+      begin
+        Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := GotoNextJsonItem(
+          Ctxt.Json, Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}EndOfObject);
+        if Ctxt.Json <> nil then
+          goto nxt;
+        goto no;
+      end
+      else
+      begin
+        // we didn't find the property in its natural place -> full lookup
+        repeat
+          prop := FindCustomProp(pointer(root.Props.List),
+            propname, propnamelen, root.Props.Count);
+          if prop = nil then
+            // unexpected "prop": value
+            if (rcfReadIgnoreUnknownFields in root.Flags) or
+               (jpoIgnoreUnknownProperty in Ctxt.Options) then
+            begin
+              Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := GotoNextJsonItem(
+                Ctxt.Json, Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}EndOfObject);
+              if Ctxt.Json = nil then
+                goto no;
+            end
+            else
+              goto no
+          else if not JsonLoadProp(Data, prop, Ctxt) then
+            goto no;
+          if Ctxt.EndOfObject = '}' then
+             break;
+any:      propname := GetJsonPropName(
+            Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json, @propnamelen);
+          if (Ctxt.Json = nil) or
+             (propname = nil) then
+            goto no;
+        until false;
+        break;
+      end;
+    end;
+    if Ctxt.Valid and
+       (Ctxt.EndOfObject = ',') and
+       ((rcfReadIgnoreUnknownFields in root.Flags) or
+        (jpoIgnoreUnknownProperty in Ctxt.Options)) then
+      goto any;
+    Ctxt.Info := root; // restore
+  end
+  else // {}
+    Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := j + 1;
+  Ctxt.ParseEndOfObject; // mimics GetJsonField() - set Ctxt.EndOfObject
+end;
+
+procedure _JL_RttiCustom(Data: PAnsiChar; var Ctxt: TJsonParserContext);
+begin
+  if Ctxt.Json <> nil then
+    Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := GotoNextNotSpace(Ctxt.Json);
+  if TRttiJson(Ctxt.Info).fJsonReader.Code <> nil then
+  begin // TRttiJson.RegisterCustomSerializer() - e.g. TOrm.RttiJsonRead
+    if Ctxt.Info.Kind = rkClass then
+    begin
+      if PPointer(Data)^ = nil then // e.g. from _JL_DynArray for T*ObjArray
+        PPointer(Data)^ := TRttiJson(Ctxt.Info).fNewInstance(Ctxt.Info);
+      Data := PPointer(Data)^; // as expected by the callback
+    end;
+    TOnRttiJsonRead(TRttiJson(Ctxt.Info).fJsonReader)(Ctxt, Data)
+  end
+  else
+  begin
+    // always finalize and reset the existing values (in case of missing props)
+    if Ctxt.Info.Kind = rkClass then
+    begin
+      if Ctxt.ParseNull then
+      begin
+        if not (jpoNullDontReleaseObjectInstance in Ctxt.Options) then
+          FreeAndNil(PObject(Data)^);
+        exit;
+      end;
+      if PPointer(Data)^ = nil then // e.g. from _JL_DynArray for T*ObjArray
+        PPointer(Data)^ := TRttiJson(Ctxt.Info).fNewInstance(Ctxt.Info)
+      else if (jpoClearValues in Ctxt.Options) and
+              not (rcfClassMayBeID in Ctxt.Info.Flags) then
+        Ctxt.Info.Props.FinalizeAndClearPublishedProperties(PPointer(Data)^);
+      // class instances are accessed by reference, records are stored by value
+      Data := PPointer(Data)^;
+      if (rcfHookRead in Ctxt.Info.Flags) and
+         TCCHook(Data).RttiBeforeReadObject(@Ctxt) then
+        exit;
+    end
+    else
+    begin
+      if jpoClearValues in Ctxt.Options then
+        Ctxt.Info.ValueFinalizeAndClear(Data);
+      if Ctxt.ParseNull then
+        exit;
+    end;
+    // regular JSON unserialization using nested fields/properties
+    _JL_RttiCustomProps(Data, Ctxt);
+    if rcfHookRead in Ctxt.Info.Flags then
+      TCCHook(Data).RttiAfterReadObject;
+  end;
+end;
+
+procedure _JL_RttiObjectWithID(Data: PAnsiChar; var Ctxt: TJsonParserContext);
+var
+  P: PUtf8Char;
+begin
+  P := Ctxt.Json;
+  if P <> nil then // in-place replace trailing RowID -> ID for unserialization
+  begin
+    while (P^ <= ' ') and
+          (P^ <> #0) do
+      inc(P);
+    if P^ = '{' then
+    begin
+      repeat
+        inc(P);
+      until (P^ > ' ') or
+            (P^ = #0);
+      if PInt64(P)^ and $00ffdfdfdfdfdfff = // case insensitive search
+        ord('"') + ord('R') shl 8 + ord('O') shl 16 + ord('W') shl 24 +
+        Int64(ord('I')) shl 32 + Int64(ord('D')) shl 40 + Int64(ord('"')) shl 48 then
+      begin // "RowID" -> __{"ID"
+        PCardinal(P)^ := $2020 + ord('{') shl 16 + ord('"') shl 24;
+        Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := P + 2;
+      end
+      else if PInt64(P)^ and $0000ffdfdfdfdfdf =
+        ord('R') + ord('O') shl 8 + ord('W') shl 16 + ord('I') shl 24 +
+        Int64(ord('D')) shl 32 + Int64(ord(':')) shl 40 then
+      begin // RowID: -> __{ID:
+        PCardinal(P)^ := $2020 + ord('{') shl 16 + ord('I') shl 24;
+        Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := P + 2;
+      end;
+    end;
+  end;
+  _JL_RttiCustom(Data, Ctxt); // use default serialization
+end;
+
+procedure _JL_Array(Data: PAnsiChar; var Ctxt: TJsonParserContext);
+var
+  n: integer;
+  arrinfo: TRttiCustom;
+begin
+  if not Ctxt.ParseArray then
+    // detect void (i.e. []) or invalid array
+    exit;
+  if PCardinal(Ctxt.Json)^ = JSON_BASE64_MAGIC_QUOTE_C then
+    // raw RTTI binary layout with a single Base64 encoded item
+    Ctxt.Valid := Ctxt.ParseNext and
+              (Ctxt.EndOfObject = ']') and
+              (Ctxt.Value <> nil) and
+              (PCardinal(Ctxt.Value)^ and $ffffff = JSON_BASE64_MAGIC_C) and
+              BinaryLoadBase64(pointer(Ctxt.Value + 3), Ctxt.ValueLen - 3,
+                Data, Ctxt.Info.Info, {uri=}false, [rkArray], {withcrc=}false)
+  else
+  begin
+    // efficient load of all JSON items
+    arrinfo := Ctxt.Info;
+    Ctxt.Info := arrinfo.ArrayRtti; // nested context = item
+    n := arrInfo.Cache.ItemCount;
+    repeat
+      TRttiJsonLoad(Ctxt.Info.JsonLoad)(Data, Ctxt);
+      dec(n);
+      if Ctxt.Valid then
+        if (n > 0) and
+           (Ctxt.EndOfObject = ',') then
+        begin
+          // continue with the next item
+          inc(Data, arrinfo.Cache.ItemSize);
+          continue;
+        end
+        else if (n = 0) and
+                (Ctxt.EndOfObject = ']') then
+          // reached end of arrray
+          break;
+      Ctxt.Valid := false; // unexpected end
+      exit;
+    until false;
+    Ctxt.Info := arrinfo;
+  end;
+  Ctxt.ParseEndOfObject; // mimics GetJsonField() / Ctxt.ParseNext
+end;
+
+procedure _JL_DynArray_Custom(Data: PAnsiChar; var Ctxt: TJsonParserContext);
+begin
+  // TRttiJson.RegisterCustomSerializer() custom callback for each item
+  TOnRttiJsonRead(TRttiJson(Ctxt.Info).fJsonReader)(Ctxt, Data);
+end;
+
+function _JL_DynArray_FromResults(Data: PPointer; var Ctxt: TJsonParserContext): boolean;
+var
+  fieldcount, rowcount, r, f: PtrInt;
+  arrinfo, iteminfo: TRttiCustom;
+  item: PAnsiChar;
+  prop: PRttiCustomProp;
+  props: PRttiCustomPropDynArray;
+begin
+  // Not Expanded (more optimized) format as array of values
+  // {"fieldCount":2,"values":["f1","f2","1v1",1v2,"2v1",2v2...],"rowCount":20}
+  result := IsNotExpandedBuffer(Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json,
+    nil, fieldcount, rowcount);
+  if not result then
+    exit; // indicates not the expected format: caller will try Ctxt.ParseArray
+  // 1. check rowcount and fieldcount
+  Ctxt.Valid := false;
+  if (rowcount < 0) or
+     (fieldcount = 0) then
+    exit;
+  // 2. initialize the items lookup from the trailing field names
+  arrinfo := Ctxt.Info;
+  iteminfo := arrinfo.ArrayRtti;
+  if (iteminfo = nil) or
+     (iteminfo.Props.CountNonVoid = 0) then
+    exit; // expect an array of objects (classes or records)
+  SetLength(props, fieldcount);
+  for f := 0 to fieldcount - 1 do
+  begin
+    if not Ctxt.ParseNext or
+       not Ctxt.WasString then
+      exit; // should start with field names
+    prop := nil;
+    if Ctxt.ValueLen <> 0 then
+    begin
+      prop := FindCustomProp(pointer(iteminfo.Props.List),
+        Ctxt.Value, Ctxt.ValueLen, iteminfo.Props.Count);
+      if (prop = nil) and
+         (itemInfo.ValueRtlClass = vcObjectWithID) and
+         (PInteger(Ctxt.Value)^ and $dfdfdfdf =
+           ord('R') + ord('O') shl 8 + ord('W') shl 16 + ord('I') shl 24) and
+         (PWord(Ctxt.Value + 4)^ and $ffdf = ord('D')) then
+        prop := @iteminfo.Props.List[0]; // 'RowID' = first TObjectWithID field
+    end;
+    if (prop = nil) and
+       not (jpoIgnoreUnknownProperty in Ctxt.Options) then
+      exit;
+    props[f] := prop;
+  end;
+  // 3. fill all nested items from incoming values
+  Data := DynArrayNew(Data, rowcount, arrinfo.Cache.ItemSize); // alloc
+  for r := 1 to rowcount do
+  begin
+    if iteminfo.Kind = rkClass then
+    begin
+      Ctxt.Info := iteminfo; // as in _JL_RttiCustom()
+      Data^ := TRttiJson(iteminfo).fNewInstance(iteminfo);
+      item := Data^; // class are accessed by reference
+      if (rcfHookRead in iteminfo.Flags) and
+         TCCHook(item).RttiBeforeReadObject(@Ctxt) then
+      begin
+        inc(Data);
+        if Ctxt.Valid then
+          continue
+        else
+          break;
+      end;
+    end
+    else
+      item := pointer(Data); // record (or object) are stored by value
+    for f := 0 to fieldcount - 1 do
+      if props[f] = nil then // skip jpoIgnoreUnknownProperty
+        Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := GotoNextJsonItem(
+          Ctxt.Json, Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}EndOfObject)
+      else if not JsonLoadProp(item, props[f], Ctxt) then
+      begin
+        Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := nil;
+        break;
+      end
+      else if Ctxt.EndOfObject = '}' then
+        break;
+    if Ctxt.Json = nil then
+        break;
+    if rcfHookRead in iteminfo.Flags then
+      TCCHook(item).RttiAfterReadObject;
+    inc(PAnsiChar(Data), arrinfo.Cache.ItemSize);
+  end;
+  Ctxt.Valid := false;
+  if Ctxt.Json <> nil then
+  begin
+    while not (Ctxt.Json^ in [#0, '}']) do
+      inc(Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json);
+    if Ctxt.Json^ = '}' then
+    begin // reached final ..],"rowCount":20}
+      inc(Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json);
+      Ctxt.Valid := true;
+    end;
+  end;
+  Ctxt.Info := arrinfo; // restore
+end;
+
+procedure _JL_DynArray(Data: PAnsiChar; var Ctxt: TJsonParserContext);
+var
+  load: TRttiJsonLoad;
+  n, cap: PtrInt;
+  arr: PPointer;
+  arrinfo: TRttiCustom;
+begin
+  arr := pointer(Data);
+  if arr^ <> nil then
+    Ctxt.Info.ValueFinalize(arr); // reset whole array variable
+  if Ctxt.Json = nil then
+  begin
+    Ctxt.Valid := false;
+    exit;
+  end;
+  Ctxt.{$ifdef USERECORDWITHMETHODS}Get.{$endif}Json := GotoNextNotSpace(Ctxt.Json);
+  if (PCardinal(Ctxt.Json)^ <> ord('{') + ord('"') shl 8 + ord('f') shl 16 +
+      ord('i') shl 24) or // FIELDCOUNT_PATTERN = '{"fieldCount":...
+    not _JL_DynArray_FromResults(arr, Ctxt) then
+  if not Ctxt.ParseArray then
+    // detect void (i.e. []) or invalid array
+    exit
+  else if PCardinal(Ctxt.Json)^ = JSON_BASE64_MAGIC_QUOTE_C then
+    // raw RTTI binary layout with a single Base64 encoded item
+    Ctxt.Valid := Ctxt.ParseNext and
+              (Ctxt.EndOfObject = ']') and
+              (Ctxt.Value <> nil) and
+              (PCardinal(Ctxt.Value)^ and $ffffff = JSON_BASE64_MAGIC_C) and
+              BinaryLoadBase64(pointer(Ctxt.Value + 3), Ctxt.ValueLen - 3,
+                Data, Ctxt.Info.Info, {uri=}false, [rkDynArray], {withcrc=}false)
+  else
+  begin
+    // efficient load of all JSON items
+    arrinfo := Ctxt.Info;
+    if TRttiJson(arrinfo).fJsonReader.Code <> nil then
+      load := @_JL_DynArray_Custom // custom callback
+    else
+    begin
+      Ctxt.Info := arrinfo.ArrayRtti;
+      if Ctxt.Info = nil then
+        load := nil
+      else
+      begin
+        load := Ctxt.Info.JsonLoad;
+        if (@load = @_JL_RttiCustom) and
+           (TRttiJson(Ctxt.Info).fJsonReader.Code = nil) and
+           (Ctxt.Info.Kind <> rkClass) and
+           (not (jpoClearValues in Ctxt.Options)) then
+          load := @_JL_RttiCustomProps; // somewhat faster direct record load
+      end;
+    end;
+    // initial guess of the JSON array count - will browse up to 64KB of input
+    cap := abs(JsonArrayCount(Ctxt.Json, Ctxt.Json + JSON_PREFETCH));
+    if (cap = 0) or
+       (not Assigned(load)) then
+    begin
+      Ctxt.Valid := false;
+      exit;
+    end;
+    Data := DynArrayNew(arr, cap, arrinfo.Cache.ItemSize); // alloc zeroed mem
+    // main JSON unserialization loop
+    n := 0;
+    repeat
+      if n = cap then
+      begin
+        // grow if our initial guess was aborted due to huge input
+        cap := NextGrow(cap);
+        Data := DynArrayGrow(arr, cap, arrinfo.Cache.ItemSize) +
+                  (n * arrinfo.Cache.ItemSize);
+      end;
+      // unserialize one item
+      load(Data, Ctxt); // will call _JL_RttiCustom() for T*ObjArray
+      inc(n);
+      if Ctxt.Valid then
+        if Ctxt.EndOfObject = ',' then
+        begin
+          // continue with the next item
+          inc(Data, arrinfo.Cache.ItemSize);
+          continue;
+        end
+        else if Ctxt.EndOfObject = ']' then
+          // reached end of arrray
+          break;
+      Ctxt.Valid := false; // unexpected end
+      arrinfo.ValueFinalize(arr); // whole array clear on error
+      exit;
+    until false;
+    if n <> cap then
+      if n = 0 then
+        FastDynArrayClear(arr^, arrinfo.Cache.ItemInfo)
+      else
+        DynArrayFakeLength(arr^, n); // faster than SetLength()
+    Ctxt.Info := arrinfo; // restore
+  end;
+  Ctxt.ParseEndOfObject; // mimics GetJsonField() / Ctxt.ParseNext
+end;
+
+procedure _JL_Interface(Data: PInterface; var Ctxt: TJsonParserContext);
+begin
+  // _JS_Interface() may have serialized the object instance properties, but we
+  // can't unserialize it since we don't know which class to create
+  Ctxt.Valid := Ctxt.ParseNull;
+  Data^ := nil;
+end;
+
+procedure _JL_PUtf8Char(Data: PPUtf8Char; var Ctxt: TJsonParserContext);
+begin
+  // _JS_PUtf8Char() may have been serialized as JSON string, but we can't
+  // unserialize it since we can't allocate the memory and Ctxt.Json
+  // input is transient by definition
+  Ctxt.Valid := Ctxt.ParseNull;
+  Data^ := nil;
+end;
+
+// defined here to have _JL_RawJson and _JL_Variant known
+procedure TJsonParserContext.ParsePropComplex(Data: pointer);
+var
+  v: TRttiVarData;
+  tmp: TObject;
+begin
+  // handle special cases of a setter method
+  case Info.Parser of
+    ptClass: // for a class property: use a temp instance for the setter call
+      begin
+        if jpoSetterNoCreate in Options then
+          Valid := false
+        else
+        begin
+          tmp := TRttiJson(Info).fNewInstance(Info);
+          try
+            v.Prop := Prop; // JsonLoad() would reset Prop := nil
+            TRttiJsonLoad(Info.JsonLoad)(@tmp, self); // JsonToObject(tmp)
+            if not Valid then
+              FreeAndNil(tmp)
+            else
+            begin
+              v.Prop.Prop.SetOrdProp(Data, PtrInt(tmp));
+              if jpoSetterExpectsToFreeTempInstance in Options then
+                FreeAndNil(tmp);
+            end;
+          except
+            on Exception do
+              tmp.Free;
+          end;
+        end;
+      end;
+    ptRawJson: // TRttiProp.SetValue() assume RawUtf8 -> dedicated RawJson code
+      begin
+        v.Data.VAny := nil;
+        try
+          _JL_RawJson(@v.Data.VAny, self);
+          if Valid then
+            Prop^.Prop.SetLongStrProp(Data, RawJson(v.Data.VAny));
+        finally
+          FastAssignNew(v.Data.VAny);
+        end;
+      end;
+    ptSet: // use a local temp variable before calling the setter
+      begin
+        v.Data.VInt64 := 0;
+        _JL_Set(@v.Data.VInt64, self);
+        if Valid then
+          Prop^.Prop.SetOrdProp(Data, v.Data.VInt64);
+      end;
+  else // call the getter via TRttiProp.SetValue() of a transient TRttiVarData
+    begin
+      v.VType := 0;
+      try
+        _JL_Variant(@v, self); // VariantLoadJson() over Ctxt
+        Valid := Valid and Prop^.Prop.SetValue(Data, variant(v));
+      finally
+        VarClearProc(v.Data);
+      end;
+    end;
+  end;
+end;
+
+procedure _JL_TObjectList(Data: PObjectList; var Ctxt: TJsonParserContext);
+var
+  root: TRttiCustom;
+  item: TObject;
+begin
+  if Data^ = nil then
+  begin
+    Ctxt.Valid := Ctxt.ParseNull;
+    exit;
+  end;
+  Data^.Clear;
+  if Ctxt.ParseNull or
+     not Ctxt.ParseArray then
+    exit;
+  root := Ctxt.Info;
+  Ctxt.Info := Ctxt.ObjectListItem;
+  repeat
+    item := Ctxt.ParseNewObject;
+    if item = nil then
+      break;
+    Data^.Add(item);
+  until Ctxt.EndOfObject = ']';
+  Ctxt.Info := root;
+  Ctxt.ParseEndOfObject;
+end;
+
+procedure _JL_TCollection(Data: PCollection; var Ctxt: TJsonParserContext);
+var
+  root: TRttiJson;
+  load: TRttiJsonLoad;
+  item: TCollectionItem;
+begin
+  if Data^ = nil then
+  begin
+    Ctxt.Valid := Ctxt.ParseNull;
+    exit;
+  end;
+  Data^.BeginUpdate;
+  try
+    Data^.Clear;
+    if Ctxt.ParseNull or
+       not Ctxt.ParseArray then
+      exit;
+    root := TRttiJson(Ctxt.Info);
+    load := nil;
+    repeat
+      item := Data^.Add;
+      if not Assigned(load) then
+      begin
+        if root.fCollectionItemRtti = nil then
+        begin
+          // RegisterCollection() was not called -> compute after Data^.Add
+          root.fCollectionItem := PPointer(item)^;
+          root.fCollectionItemRtti := Rtti.RegisterClass(PClass(item)^);
+        end;
+        Ctxt.Info := root.fCollectionItemRtti;
+        load := Ctxt.Info.JsonLoad;
+      end;
+      load(@item, Ctxt);
+    until (not Ctxt.Valid) or
+          (Ctxt.EndOfObject = ']');
+    Ctxt.Info := root;
+    Ctxt.ParseEndOfObject;
+  finally
+    Data^.EndUpdate;
+  end;
+end;
+
+procedure _JL_TSynObjectList(Data: PSynObjectList; var Ctxt: TJsonParserContext);
+var
+  root: TRttiCustom;
+  item: TObject;
+begin
+  if Data^ = nil then
+  begin
+    Ctxt.Valid := Ctxt.ParseNull;
+    exit;
+  end;
+  Data^.Clear;
+  if Ctxt.ParseNull or
+     not Ctxt.ParseArray then
+    exit;
+  root := Ctxt.Info;
+  Ctxt.Info := Ctxt.ObjectListItem;
+  if (Ctxt.Info = nil) and
+     (Data^.ItemClass <> nil) then
+    Ctxt.Info := Rtti.RegisterClass(Data^.ItemClass);
+  repeat
+    item := Ctxt.ParseNewObject;
+    if item = nil then
+      break;
+    Data^.Add(item);
+  until Ctxt.EndOfObject = ']';
+  Ctxt.Info := root;
+  Ctxt.ParseEndOfObject;
+end;
+
+procedure _JL_TStrings(Data: PStrings; var Ctxt: TJsonParserContext);
+var
+  item: string;
+begin
+  if Data^ = nil then
+  begin
+    Ctxt.Valid := Ctxt.ParseNull;
+    exit;
+  end;
+  Data^.BeginUpdate;
+  try
+    Data^.Clear;
+    if Ctxt.ParseNull or
+       not Ctxt.ParseArray then
+      exit;
+    repeat
+      if Ctxt.ParseNext then
+      begin
+        Utf8DecodeToString(Ctxt.Value, Ctxt.ValueLen, item);
+        Data^.Add(item);
+      end;
+    until (not Ctxt.Valid) or
+          (Ctxt.EndOfObject = ']');
+  finally
+    Data^.EndUpdate;
+  end;
+  Ctxt.ParseEndOfObject;
+end;
+
+procedure _JL_TRawUtf8List(Data: PRawUtf8List; var Ctxt: TJsonParserContext);
+var
+  item: RawUtf8;
+begin
+  if Data^ = nil then
+  begin
+    Ctxt.Valid := Ctxt.ParseNull;
+    exit;
+  end;
+  Data^.BeginUpdate;
+  try
+    Data^.Clear;
+    if Ctxt.ParseNull or
+       not Ctxt.ParseArray then
+      exit;
+    repeat
+      if Ctxt.ParseNext then
+      begin
+        Ctxt.Interning.Unique(item, Ctxt.Value, Ctxt.ValueLen);
+        Data^.AddObject(item, nil);
+      end;
+    until (not Ctxt.Valid) or
+          (Ctxt.EndOfObject = ']');
+  finally
+    Data^.EndUpdate;
+  end;
+  Ctxt.ParseEndOfObject;
+end;
+
+var
+  /// use pointer to allow any kind of Data^ type in above functions
+  // - typecast to TRttiJsonSave for proper function call
+  // - rkRecord and rkClass are set in TRttiJson.SetParserType
+  PT_JSONLOAD: array[TRttiParserType] of pointer = (
+    nil, @_JL_Array, @_JL_Boolean, @_JL_Byte, @_JL_Cardinal, @_JL_Currency,
+    @_JL_Double, @_JL_Extended, @_JL_Int64, @_JL_Integer, @_JL_QWord,
+    @_JL_RawByteString, @_JL_RawJson, @_JL_RawUtf8, nil,
+    @_JL_Single, @_JL_String, @_JL_SynUnicode, @_JL_DateTime, @_JL_DateTime,
+    @_JL_GUID, @_JL_Hash, @_JL_Hash, @_JL_Hash, @_JL_Int64, @_JL_TimeLog,
+    @_JL_UnicodeString, @_JL_UnixTime, @_JL_UnixMSTime, @_JL_Variant,
+    @_JL_WideString, @_JL_WinAnsi, @_JL_Word, @_JL_Enumeration, @_JL_Set,
+    nil, @_JL_DynArray, @_JL_Interface, @_JL_PUtf8Char, nil);
+
+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; Names: PPUtf8CharArray; NamesCount: integer;
+  Values: PValuePUtf8CharArray; HandleValuesAsObjectOrArray: boolean): PUtf8Char;
+var
+  v: PValuePUtf8Char;
+  name: PUtf8Char;
+  namelen, i: integer;
+  info: TGetJsonField;
+begin
+  result := nil;
+  if (Values = nil) or
+     (NamesCount <= 0) then
+    exit; // avoid GPF
+  FillCharFast(Values[0], NamesCount * SizeOf(Values[0]), 0);
+  dec(NamesCount);
+  if P = nil then
+    exit;
+  while P^ <> '{' do
+    if P^ = #0 then
+      exit
+    else
+      inc(P);
+  info.Json := P + 1; // jump {
+  repeat
+    name := GetJsonPropName(info.Json, @namelen);
+    if name = nil then
+      exit;  // invalid Json content
+    info.GetJsonFieldOrObjectOrArray(HandleValuesAsObjectOrArray);
+    if not (info.EndOfObject in [',', '}']) then
+      exit; // invalid item separator
+    v := pointer(Values);
+    for i := 0 to NamesCount do
+      if (v^.Text = nil) and
+         IdemPropNameU(Names[i], name, namelen) then
+      begin
+        v^.Text := info.Value;
+        v^.Len := info.ValueLen;
+        break;
+      end
+      else
+        inc(v);
+  until (info.Json = nil) or
+        (info.EndOfObject = '}');
+  if info.Json = nil then // result=nil indicates failure -> points to #0
+    result := @NULCHAR
+  else
+    result := info.Json;
+end;
+
+function JsonDecode(P: PUtf8Char; const Names: array of RawUtf8;
+  Values: PValuePUtf8CharArray; HandleValuesAsObjectOrArray: boolean): PUtf8Char;
+begin
+  result := JsonDecode(P, @Names[0], high(Names) + 1,
+    Values, HandleValuesAsObjectOrArray);
+end;
+
+function JsonDecode(var Json: RawUtf8; const aName: RawUtf8; WasString: PBoolean;
+  HandleValuesAsObjectOrArray: boolean): RawUtf8;
+begin
+  result := JsonDecode(pointer(Json), aName, WasString, HandleValuesAsObjectOrArray);
+end;
+
+function JsonDecode(Json: PUtf8Char; const aName: RawUtf8;
+  WasString: PBoolean; HandleValuesAsObjectOrArray: boolean): RawUtf8;
+var
+  info: TGetJsonField;
+begin
+  result := '';
+  if Json = nil then
+    exit;
+  while Json^ <> '{' do
+    if Json^ = #0 then
+      exit
+    else
+      inc(Json);
+  info.Json := Json + 1; // jump {
+  repeat
+    info.Value := GetJsonPropName(info.Json, @info.ValueLen);
+    if info.Value = nil then
+      exit;  // invalid Json content
+    if IdemPropNameU(aName, info.Value, info.ValueLen) then
+    begin
+      info.GetJsonFieldOrObjectOrArray(HandleValuesAsObjectOrArray);
+      if info.Json <> nil then
+        FastSetString(result, info.Value, info.ValueLen);
+      exit;
+    end;
+    info.Json := GotoNextJsonItem(info.Json, info.EndOfObject);
+    if not (info.EndOfObject in [',', '}']) then
+      exit; // invalid item separator
+  until (info.Json = nil) or
+        (info.EndOfObject = '}');
+end;
+
+function JsonDecode(P: PUtf8Char; out Values: TNameValuePUtf8CharDynArray;
+  HandleValuesAsObjectOrArray: boolean): PUtf8Char;
+var
+  n: PtrInt;
+  info: TGetJsonField;
+  nametext: PUtf8Char;
+  namelen: integer;
+begin
+  {$ifdef FPC}
+  Values := nil;
+  {$endif FPC}
+  result := nil;
+  n := 0;
+  if P <> nil then
+  begin
+    while P^ <> '{' do
+      if P^ = #0 then
+        exit
+      else
+        inc(P);
+    inc(P); // jump {
+    info.Json := P;
+    repeat
+      nametext := GetJsonPropName(info.Json, @nameLen);
+      if nametext = nil then
+        exit;  // invalid JSON content
+      info.GetJsonFieldOrObjectOrArray(HandleValuesAsObjectOrArray);
+      if not (info.EndOfObject in [',', '}']) then
+        exit; // invalid item separator
+      if n = length(Values) then
+        SetLength(Values, NextGrow(n));
+      with Values[n] do
+      begin
+        Name.Text := nametext;
+        Name.Len := namelen;
+        Value.Text := info.Value;
+        Value.Len := info.ValueLen;
+      end;
+      inc(n);
+    until (info.Json = nil) or
+          (info.EndOfObject = '}');
+    P := info.Json;
+  end;
+  if n <> 0 then
+    DynArrayFakeLength(Values, n); // SetLength() would have made a realloc()
+  if P = nil then // result=nil indicates failure -> points to #0
+    result := @NULCHAR
+  else
+    result := P;
+end;
+
+
+{ ************ JSON-aware TSynNameValue TSynPersistentStoreJson }
+
+{ TSynNameValue }
+
+procedure TSynNameValue.Add(const aName, aValue: RawUtf8; aTag: PtrInt);
+var
+  added: boolean;
+  i: PtrInt;
+begin
+  i := DynArray.FindHashedForAdding(aName, added);
+  with List[i] do
+  begin
+    if added then
+      Name := aName;
+    Value := aValue;
+    Tag := aTag;
+  end;
+  if Assigned(fOnAdd) then
+    fOnAdd(List[i], i);
+end;
+
+procedure TSynNameValue.InitFromIniSection(Section: PUtf8Char;
+  const OnTheFlyConvert: TOnSynNameValueConvertRawUtf8;
+  const OnAdd: TOnSynNameValueNotify);
+var
+  s: RawUtf8;
+  i: PtrInt;
+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: PtrInt;
+begin
+  Init(false);
+  if high(Names) <> high(Values) then
+    exit;
+  DynArray.Capacity := 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: PUtf8Char;
+  nam, val: RawUtf8;
+  Nlen, c: integer;
+  info: TGetJsonField;
+begin
+  result := false;
+  Init(aCaseSensitive);
+  if Json = nil then
+    exit;
+  while (Json^ <= ' ') and
+        (Json^ <> #0) do
+    inc(Json);
+  if Json^ <> '{' then
+    exit;
+  repeat
+    inc(Json)
+  until (Json^ = #0) or
+        (Json^ > ' ');
+  info.Json := Json;
+  c := JsonObjectPropCount(Json); // fast 900MB/s parsing
+  if c <= 0 then
+    exit;
+  DynArray.Capacity := c;
+  repeat
+    N := GetJsonPropName(info.Json, @Nlen);
+    if N = nil then
+      exit;
+    info.GetJsonFieldOrObjectOrArray;
+    if info.Json = nil then
+      exit;
+    FastSetString(nam, N, Nlen);
+    FastSetString(val, info.Value, info.Valuelen);
+    Add(nam, val);
+  until info.EndOfObject = '}';
+  result := true;
+end;
+
+procedure TSynNameValue.Init(aCaseSensitive: boolean);
+begin
+  // release dynamic arrays memory before FillcharFast()
+  List := nil;
+  Finalize(PDynArrayHasher(@DynArray.Hasher)^);
+  // initialize hashed storage
+  FillCharFast(self, SizeOf(self), 0);
+  DynArray.InitSpecific(TypeInfo(TSynNameValueItemDynArray), List,
+    ptRawUtf8, @Count, not aCaseSensitive);
+end;
+
+function TSynNameValue.Find(const aName: RawUtf8): PtrInt;
+begin
+  result := DynArray.FindHashed(aName);
+end;
+
+function TSynNameValue.FindStart(const aUpperName: RawUtf8): PtrInt;
+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): PtrInt;
+begin
+  for result := 0 to Count - 1 do
+    if List[result].Value = aValue then
+      exit;
+  result := -1;
+end;
+
+function TSynNameValue.Delete(const aName: RawUtf8): boolean;
+begin
+  result := DynArray.FindHashedAndDelete(aName) >= 0;
+end;
+
+function TSynNameValue.DeleteByValue(const aValue: RawUtf8; Limit: integer): integer;
+var
+  ndx: PtrInt;
+begin
+  result := 0;
+  if Limit < 1 then
+    exit;
+  for ndx := Count - 1 downto 0 do
+    if List[ndx].Value = aValue then
+    begin
+      DynArray.Delete(ndx);
+      inc(result);
+      if result >= Limit then
+        break;
+    end;
+  if result > 0 then
+    DynArray.ForceReHash;
+end;
+
+function TSynNameValue.Value(const aName: RawUtf8; const aDefaultValue: RawUtf8): RawUtf8;
+var
+  i: PtrInt;
+begin
+  if @self = nil then
+    i := -1
+  else
+    i := DynArray.FindHashed(aName);
+  if i < 0 then
+    result := aDefaultValue
+  else
+    result := List[i].Value;
+end;
+
+function TSynNameValue.ValueInt(const aName: RawUtf8; const aDefaultValue: Int64): Int64;
+var
+  i: PtrInt;
+  err: integer;
+begin
+  i := DynArray.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 := GetBoolean(pointer(Value(aName)));
+end;
+
+function TSynNameValue.ValueEnum(const aName: RawUtf8; aEnumTypeInfo: PRttiInfo;
+  out aEnum; aEnumDefault: PtrUInt): boolean;
+var
+  rtti: PRttiEnumType;
+  v: RawUtf8;
+  err: integer;
+  i: PtrInt;
+begin
+  result := false;
+  rtti := aEnumTypeInfo.EnumBaseType;
+  if rtti = nil then
+    exit;
+  RTTI_TO_ORD[rtti.RttiOrd](@aEnum, aEnumDefault); // always set default value
+  v := Value(aName, '');
+  TrimSelf(v);
+  if v = '' then
+    exit;
+  i := GetInteger(pointer(v), err);
+  if (err <> 0) or
+     (PtrUInt(i) > PtrUInt(rtti.MaxValue)) then
+    i := rtti.GetEnumNameValue(pointer(v), length(v), {alsotrimleft=}true);
+  if i >= 0 then
+  begin
+    RTTI_TO_ORD[rtti.RttiOrd](@aEnum, i); // we found a proper value
+    result := true;
+  end;
+end;
+
+function TSynNameValue.Initialized: boolean;
+begin
+  result := DynArray.Value = @List;
+end;
+
+function TSynNameValue.GetBlobData: RawByteString;
+begin
+  result := DynArray.SaveTo;
+end;
+
+procedure TSynNameValue.SetBlobDataPtr(aValue, aValueMax: pointer);
+begin
+  DynArray.LoadFrom(aValue, aValueMax);
+  DynArray.ForceReHash;
+end;
+
+procedure TSynNameValue.SetBlobData(const aValue: RawByteString);
+begin
+  DynArray.LoadFromBinary(aValue);
+  DynArray.ForceReHash;
+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.AsCsv(const KeySeparator, ValueSeparator, IgnoreKey: RawUtf8): RawUtf8;
+var
+  i: PtrInt;
+  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: PtrInt;
+  temp: TTextWriterStackBuffer;
+begin
+  with TJsonWriter.CreateOwnedStream(temp) do
+  try
+    Add('{');
+    for i := 0 to Count - 1 do
+      with List[i] do
+      begin
+        AddProp(pointer(Name), length(Name));
+        AddDirect('"');
+        AddJsonEscape(pointer(Value));
+        AddDirect('"', ',');
+      end;
+    CancelLastComma('}');
+    SetText(result);
+  finally
+    Free;
+  end;
+end;
+
+procedure TSynNameValue.AsNameValues(out Names, Values: TRawUtf8DynArray);
+var
+  i: PtrInt;
+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;
+
+function TSynNameValue.ValueVariantOrNull(const aName: RawUtf8): variant;
+var
+  i: PtrInt;
+begin
+  i := Find(aName);
+  if i < 0 then
+    SetVariantNull(result{%H-})
+  else
+    RawUtf8ToVariant(List[i].Value, result);
+end;
+
+procedure TSynNameValue.AsDocVariant(out DocVariant: variant;
+  ExtendedJson, ValueAsString, AllowVarDouble: boolean);
+var
+  ndx: PtrInt;
+  dv: TDocVariantData absolute DocVariant;
+begin
+  if Count > 0 then
+    begin
+      dv.Init(JSON_NAMEVALUE[ExtendedJson], dvObject);
+      dv.SetCount(Count);
+      dv.Capacity := Count;
+      for ndx := 0 to Count - 1 do
+      begin
+        dv.Names[ndx] := List[ndx].Name;
+        if ValueAsString or
+           not GetVariantFromNotStringJson(pointer(List[ndx].Value),
+              TVarData(dv.Values[ndx]), AllowVarDouble) then
+          RawUtf8ToVariant(List[ndx].Value, dv.Values[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: PtrInt;
+  v: variant;
+  intvalues: TRawUtf8Interning;
+begin
+  if dv.VarType <> DocVariantVType then
+    TDocVariant.New(DocVariant, JSON_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{%H-});
+      if ValueAsString or
+         not GetVariantFromNotStringJson(
+            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 FastVarDataComp(@v, @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.Values[ndx]);
+      if intvalues <> nil then
+        intvalues.UniqueVariant(dv.Values[ndx]);
+      inc(result);
+    end;
+end;
+
+
+
+{ TSynPersistentStoreJson }
+
+procedure TSynPersistentStoreJson.AddJson(W: TJsonWriter);
+begin
+  W.AddPropJsonString('name', fName);
+end;
+
+function TSynPersistentStoreJson.SaveToJson(reformat: TTextWriterJsonFormat): RawUtf8;
+var
+  W: TJsonWriter;
+begin
+  W := TJsonWriter.CreateOwnedStream(65536);
+  try
+    W.Add('{');
+    AddJson(W);
+    W.CancelLastComma('}');
+    W.SetText(result, reformat);
+  finally
+    W.Free;
+  end;
+end;
+
+
+
+{ TSynCache }
+
+constructor TSynCache.Create(aMaxCacheRamUsed: cardinal;
+  aCaseSensitive: boolean; aTimeoutSeconds: cardinal);
+begin
+  inherited Create; // may have been overriden
+  fNameValue.Init(aCaseSensitive);
+  fMaxRamUsed := aMaxCacheRamUsed;
+  fTimeoutSeconds := aTimeoutSeconds;
+end;
+
+procedure TSynCache.ResetIfNeeded;
+var
+  tix: cardinal;
+begin
+  if fRamUsed > fMaxRamUsed then
+    Reset;
+  if fTimeoutSeconds > 0 then
+  begin
+    tix := GetTickCount64 shr 10;
+    if fTimeoutTix > tix then
+      Reset;
+    fTimeoutTix := tix + fTimeoutSeconds;
+  end;
+end;
+
+function TSynCache.Find(const aKey: RawUtf8; aResultTag: PPtrInt): RawUtf8;
+var
+  ndx: PtrInt;
+begin
+  result := '';
+  if (self = nil) or
+     (aKey = '') then
+    exit;
+  fSafe.ReadOnlyLock;
+  {$ifdef HASFASTTRYFINALLY}
+  try
+  {$else}
+  begin
+  {$endif HASFASTTRYFINALLY}
+    ndx := fNameValue.Find(aKey);
+    if ndx >= 0 then
+      with fNameValue.List[ndx] do
+      begin
+        result := Value;
+        if aResultTag <> nil then
+          aResultTag^ := Tag;
+      end;
+  {$ifdef HASFASTTRYFINALLY}
+  finally
+  {$endif HASFASTTRYFINALLY}
+    fSafe.ReadOnlyUnLock;
+  end;
+end;
+
+function TSynCache.AddOrUpdate(const aKey, aValue: RawUtf8; aTag: PtrInt): boolean;
+var
+  ndx: PtrInt;
+begin
+  result := false;
+  if self = nil then
+    exit; // avoid GPF
+  fSafe.WriteLock;
+  try
+    ResetIfNeeded;
+    ndx := fNameValue.DynArray.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.WriteUnlock;
+  end;
+end;
+
+function TSynCache.Reset: boolean;
+begin
+  result := false;
+  if (self = nil) or
+     (fNameValue.Count = 0) then
+    exit; // avoid GPF or a lock for nothing
+  fSafe.WriteLock;
+  try
+    if fNameValue.Count <> 0 then
+    begin
+      fNameValue.DynArray.Clear;
+      fNameValue.DynArray.ForceReHash;
+      result := true; // mark something was flushed
+    end;
+    fRamUsed := 0;
+    fTimeoutTix := 0;
+  finally
+    fSafe.WriteUnlock;
+  end;
+end;
+
+
+{ *********** JSON-aware TSynDictionary Storage }
+
+{ TSynDictionary }
+
+constructor TSynDictionary.Create(aKeyTypeInfo, aValueTypeInfo: PRttiInfo;
+  aKeyCaseInsensitive: boolean; aTimeoutSeconds: cardinal;
+  aCompressAlgo: TAlgoCompress; aHasher: THasher);
+begin
+  inherited Create;
+  fSafe.Padding[DIC_KEYCOUNT].VType   := varInteger;  // Keys.Count
+  fSafe.Padding[DIC_KEY].VType        := varUnknown;  // Key.Value
+  fSafe.Padding[DIC_VALUECOUNT].VType := varInteger;  // Values.Count
+  fSafe.Padding[DIC_VALUE].VType      := varUnknown;  // Values.Value
+  fSafe.Padding[DIC_TIMECOUNT].VType  := varInteger;  // Timeouts.Count
+  fSafe.Padding[DIC_TIMESEC].VType    := varInteger;  // Timeouts Seconds
+  fSafe.Padding[DIC_TIMETIX].VType    := varInteger;  // GetTickCount64 shr 10
+  fSafe.PaddingUsedCount := DIC_TIMETIX + 1;          // manual registration
+  fKeys.Init(aKeyTypeInfo, fSafe.Padding[DIC_KEY].VAny, nil, nil, aHasher,
+    @fSafe.Padding[DIC_KEYCOUNT].VInteger, aKeyCaseInsensitive);
+  fValues.Init(aValueTypeInfo, fSafe.Padding[DIC_VALUE].VAny,
+    @fSafe.Padding[DIC_VALUECOUNT].VInteger);
+  fValues.Compare := DynArraySortOne(fValues.Info.ArrayFirstField, aKeyCaseInsensitive);
+  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;
+
+{$ifdef HASGENERICS}
+class function TSynDictionary.New(aKeyCaseInsensitive: boolean;
+  aTimeoutSeconds: cardinal; aCompressAlgo: TAlgoCompress;
+  aHasher: THasher): TSynDictionary;
+begin
+  result := TSynDictionary.Create(TypeInfo(TArray), TypeInfo(TArray),
+    aKeyCaseInsensitive, aTimeoutSeconds, aCompressAlgo, aHasher);
+end;
+{$endif HASGENERICS}
+
+function TSynDictionary.ComputeNextTimeOut: cardinal;
+begin
+  result := fSafe.Padding[DIC_TIMESEC].VInteger;
+  if result <> 0 then
+    result := cardinal(GetTickCount64 shr 10) + result;
+end;
+
+function TSynDictionary.GetCapacity: integer;
+begin
+  result := fKeys.Capacity; // no need to lock for an evolving value
+end;
+
+procedure TSynDictionary.SetCapacity(const Value: integer);
+begin
+  fSafe.Lock; // = RWLock(cWrite);
+  try
+    fKeys.Capacity := Value;
+    fValues.Capacity := Value;
+    if fSafe.Padding[DIC_TIMESEC].VInteger > 0 then
+      fTimeOuts.Capacity := Value;
+  finally
+    fSafe.UnLock;
+  end;
+end;
+
+function TSynDictionary.GetTimeOutSeconds: cardinal;
+begin
+  result := fSafe.Padding[DIC_TIMESEC].VInteger;
+end;
+
+procedure TSynDictionary.SetTimeOutSeconds(Value: cardinal);
+begin
+  // no fSafe.Lock because RWLock(cWrite) in DeleteAll is enough
+  DeleteAll;
+  fSafe.Padding[DIC_TIMESEC].VInteger := Value;
+end;
+
+procedure TSynDictionary.SetTimeouts;
+var
+  i: PtrInt;
+  timeout: cardinal;
+begin
+  if fSafe.Padding[DIC_TIMESEC].VInteger = 0 then
+    exit;
+  fTimeOuts.Count := 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(tix64: Int64): 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;
+  if tix64 = 0 then
+    tix64 := GetTickCount64;
+  now := tix64 shr 10;
+  if fSafe.Padding[DIC_TIMETIX].VInteger = integer(now) then
+    exit; // no need to search more often than every second
+  fSafe.ReadWriteLock; // would upgrade to cWrite only if needed
+  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.ItemPtr(i)^, fValues.ItemPtr(i)^, i)) then
+      begin
+        if result = 0 then
+          fSafe.Lock; // = cWrite
+        fKeys.Delete(i);
+        fValues.Delete(i);
+        fTimeOuts.Delete(i);
+        inc(result);
+      end;
+    if result > 0 then
+      fKeys.ForceReHash; // mandatory after manual fKeys.Delete(i)
+  finally
+    if result > 0 then
+      fSafe.UnLock; // = cWrite
+    fSafe.ReadWriteUnLock;
+  end;
+end;
+
+procedure TSynDictionary.DeleteAll;
+begin
+  if self = nil then
+    exit;
+  fSafe.Lock; // = RWLock(cWrite);
+  try
+    fKeys.Clear;
+    fKeys.Hasher.ForceReHash(nil); // 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.GetThreadUse: TSynLockerUse;
+begin
+  result := fSafe^.RWUse;
+end;
+
+procedure TSynDictionary.SetThreadUse(const Value: TSynLockerUse);
+begin
+  fSafe^.RWUse := Value;
+end;
+
+function TSynDictionary.InternalAddUpdate(
+  aKey, aValue: pointer; aUpdate: boolean): PtrInt;
+var
+  added: boolean;
+  tim: cardinal;
+begin
+  tim := ComputeNextTimeOut;
+  fSafe.Lock; // = RWLock(cWrite) - cReadWrite is not possible here
+  try
+    result := fKeys.FindHashedForAdding(aKey^, added);
+    if added then
+    begin // fKey[result] := aKey;
+      with fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif} do
+        ItemCopy(aKey, PAnsiChar(Value^) + (result * Info.Cache.ItemSize));
+      if fValues.Add(aValue^) <> result then
+        raise ESynDictionary.CreateUtf8('%.Add fValues.Add', [self]);
+      if tim <> 0 then
+        fTimeOuts.Add(tim);
+    end
+    else if aUpdate then
+    begin
+      fValues.ItemCopyFrom(aValue, result, {ClearBeforeCopy=}true);
+      if tim <> 0 then
+        fTimeOut[result] := tim;
+    end
+    else
+      result := -1;
+  finally
+    fSafe.UnLock;
+  end;
+end;
+
+function TSynDictionary.Add(const aKey, aValue): PtrInt;
+begin
+  result := InternalAddUpdate(@aKey, @aValue, {update=}false)
+end;
+
+function TSynDictionary.AddOrUpdate(const aKey, aValue): PtrInt;
+begin
+  result := InternalAddUpdate(@aKey, @aValue, {update=}true)
+end;
+
+function TSynDictionary.Clear(const aKey): PtrInt;
+begin
+  fSafe.ReadWriteLock;
+  try
+    result := fKeys.FindHashed(aKey);
+    if result >= 0 then
+    begin
+      fSafe.Lock;
+      fValues.ItemClear(fValues.ItemPtr(result));
+      if fSafe.Padding[DIC_TIMESEC].VInteger > 0 then
+        fTimeOut[result] := 0;
+      fSafe.UnLock;
+    end;
+  finally
+    fSafe.ReadWriteUnLock;
+  end;
+end;
+
+function TSynDictionary.Delete(const aKey): PtrInt;
+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: PtrInt): boolean;
+begin
+  if cardinal(aIndex) < cardinal(fSafe.Padding[DIC_KEYCOUNT].VInteger) then
+    // use Delete(aKey) to have efficient hash table update
+    result := Delete(fKeys.ItemPtr(aIndex)^) = aIndex
+  else
+    result := false;
+end;
+
+function TSynDictionary.InArray(const aKey, aArrayValue;
+  aAction: TSynDictionaryInArray; aCompare: TDynArraySortCompare): boolean;
+var
+  nested: TDynArray;
+  ndx: PtrInt;
+  new: pointer;
+begin
+  result := false;
+  if (fValues.Info.ArrayRtti = nil) or
+     (fValues.Info.ArrayRtti.Kind <> rkDynArray) then
+    raise ESynDictionary.CreateUtf8('%.Values: % items are not dynamic arrays',
+      [self, fValues.Info.Name]);
+  if aAction = iaFind then
+    fSafe.ReadLock
+  else
+    fSafe.Lock; // other actions may need to write the internal data
+  try
+    ndx := fKeys.FindHashed(aKey);
+    if ndx < 0 then
+      if aAction <> iaAddForced then
+        exit
+      else
+      begin
+        new := nil;
+        ndx := Add(aKey, new);
+      end;
+    nested.InitRtti(fValues.Info.ArrayRtti, fValues.ItemPtr(ndx)^);
+    nested.Compare := aCompare;
+    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,
+      iaAddForced:
+        result := nested.Add(aArrayValue) >= 0;
+    end;
+  finally
+    if aAction = iaFind then
+      fSafe.ReadUnLock
+    else
+      fSafe.UnLock;
+  end;
+end;
+
+function TSynDictionary.FindInArray(const aKey, aArrayValue;
+  aCompare: TDynArraySortCompare): boolean;
+begin
+  result := InArray(aKey, aArrayValue, iaFind, aCompare);
+end;
+
+function TSynDictionary.FindKeyFromValue(const aValue;
+  out aKey; aUpdateTimeOut: boolean): boolean;
+var
+  ndx: PtrInt;
+begin
+  fSafe.ReadLock; // cReadOnly is good enough for SetTimeoutAtIndex()
+  try
+    ndx := fValues.IndexOf(aValue); // use fast RTTI for value search
+    result := ndx >= 0;
+    if result then
+    begin
+      fKeys.ItemCopyAt(ndx, @aKey);
+      if aUpdateTimeOut then
+        SetTimeoutAtIndex(ndx); // no cWrite lock needed
+    end;
+  finally
+    fSafe.ReadUnLock;
+  end;
+end;
+
+function TSynDictionary.DeleteInArray(const aKey, aArrayValue;
+  aCompare: TDynArraySortCompare): boolean;
+begin
+  result := InArray(aKey, aArrayValue, iaFindAndDelete, aCompare);
+end;
+
+function TSynDictionary.UpdateInArray(const aKey, aArrayValue;
+  aCompare: TDynArraySortCompare): boolean;
+begin
+  result := InArray(aKey, aArrayValue, iaFindAndUpdate, aCompare);
+end;
+
+function TSynDictionary.AddInArray(const aKey, aArrayValue;
+  aCompare: TDynArraySortCompare): boolean;
+begin
+  result := InArray(aKey, aArrayValue, iaAdd, aCompare);
+end;
+
+function TSynDictionary.AddInArrayForced(const aKey, aArrayValue;
+  aCompare: TDynArraySortCompare): boolean;
+begin
+  result := InArray(aKey, aArrayValue, iaAddForced, aCompare);
+end;
+
+function TSynDictionary.AddOnceInArray(const aKey, aArrayValue;
+  aCompare: TDynArraySortCompare): boolean;
+begin
+  result := InArray(aKey, aArrayValue, iaFindAndAddIfNotExisting, aCompare);
+end;
+
+function TSynDictionary.Find(const aKey; aUpdateTimeOut: boolean): PtrInt;
+var
+  tim: cardinal;
+begin
+  // caller is expected to call fSafe.Lock/Unlock
+  if self = nil then
+    result := -1
+  else
+  begin
+    result := fKeys.Hasher.FindOrNew(fKeys.Hasher.HashOne(@aKey), @aKey, nil);
+    if result < 0 then
+      result := -1
+    else if aUpdateTimeOut then
+    begin
+      tim := fSafe.Padding[DIC_TIMESEC].VInteger;
+      if tim > 0 then // inlined fTimeout[result] := GetTimeout
+        fTimeout[result] := cardinal(GetTickCount64 shr 10) + tim;
+    end;
+  end;
+end;
+
+function TSynDictionary.FindValue(const aKey; aUpdateTimeOut: boolean;
+  aIndex: PPtrInt): pointer;
+var
+  ndx: PtrInt;
+begin
+  ndx := Find(aKey, aUpdateTimeOut);
+  if aIndex <> nil then
+    aIndex^ := ndx;
+  if ndx < 0 then
+    result := nil
+  else
+    result := PAnsiChar(fValues.Value^) + ndx * fValues.Info.Cache.ItemSize;
+end;
+
+function TSynDictionary.FindValueOrAdd(const aKey; var added: boolean;
+  aIndex: PPtrInt): pointer;
+var
+  ndx: PtrInt;
+  tim: cardinal;
+begin
+  tim := fSafe.Padding[DIC_TIMESEC].VInteger; // inlined tim := GetTimeout
+  if tim <> 0 then
+    tim := cardinal(GetTickCount64 shr 10) + tim;
+  ndx := fKeys.FindHashedForAdding(aKey, added);
+  if added then
+  begin
+    fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif}.
+      ItemCopyFrom(@aKey, ndx); // fKey[i] := aKey
+    fValues.Count := 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 := PAnsiChar(fValues.Value^) + ndx * fValues.Info.Cache.ItemSize;
+end;
+
+function TSynDictionary.FindAndCopy(const aKey;
+  var aValue; aUpdateTimeOut: boolean): boolean;
+var
+  ndx: PtrInt;
+begin
+  result := false;
+  if self = nil then
+    exit;
+  fSafe.ReadLock;
+  {$ifdef HASFASTTRYFINALLY}
+  try
+  {$else}
+  begin
+  {$endif HASFASTTRYFINALLY}
+    ndx := Find(aKey, aUpdateTimeOut);
+    if ndx >= 0 then
+    begin
+      fValues.ItemCopy( // inlined ItemCopyAt(ndx, @aValue)
+        PAnsiChar(fValues.Value^) + ndx * fValues.Info.Cache.ItemSize, @aValue);
+      result := true;
+    end;
+  {$ifdef HASFASTTRYFINALLY}
+  finally
+  {$endif HASFASTTRYFINALLY}
+    fSafe.ReadUnLock;
+  end;
+end;
+
+function TSynDictionary.FindAndGetElapsedSeconds(const aKey): integer;
+var
+  tim: cardinal;
+  ndx: PtrInt;
+begin
+  result := -1;
+  if self = nil then
+    exit;
+  tim := ComputeNextTimeOut;
+  if tim = 0 then
+    exit;
+  fSafe.ReadLock;
+  try
+    ndx := Find(aKey, {aUpdateTimeOut=}false);
+    if ndx >= 0 then
+      result := tim - fTimeOut[ndx];
+  finally
+    fSafe.ReadUnLock;
+  end;
+end;
+
+function TSynDictionary.FindAndDeleteDeprecated(const aKey; aSeconds: integer): boolean;
+var
+  tim: cardinal;
+  ndx: PtrInt;
+begin
+  result := false;
+  if (self = nil) or
+     (aSeconds <= 0) then
+    exit;
+  tim := ComputeNextTimeOut;
+  if tim = 0 then
+    exit;
+  fSafe.ReadWriteLock;
+  try
+    ndx := Find(aKey, {aUpdateTimeOut=}false);
+    if (ndx >= 0) and
+       (tim - fTimeOut[ndx] > cardinal(aSeconds)) then
+      result := DeleteAt(ndx);
+  finally
+    fSafe.ReadWriteUnLock;
+  end;
+end;
+
+function TSynDictionary.FindAndExtract(const aKey; var aValue): boolean;
+var
+  ndx: PtrInt;
+begin
+  result := false;
+  if self = nil then
+    exit;
+  fSafe.ReadWriteLock;
+  try
+    ndx := fKeys.FindHashedAndDelete(aKey);
+    if ndx >= 0 then
+    begin
+      fSafe.Lock;
+      fValues.ItemMoveTo(ndx, @aValue); // faster than ItemCopy()
+      fValues.Delete(ndx);
+      if fSafe.Padding[DIC_TIMESEC].VInteger > 0 then
+        fTimeOuts.Delete(ndx);
+      fSafe.UnLock;
+      result := true;
+    end;
+  finally
+    fSafe.ReadWriteUnLock;
+  end;
+end;
+
+function TSynDictionary.Exists(const aKey): boolean;
+begin
+  result := false;
+  if self = nil then
+    exit;
+  fSafe.ReadLock;
+  {$ifdef HASFASTTRYFINALLY}
+  try
+  {$else}
+  begin
+  {$endif HASFASTTRYFINALLY}
+    result := fKeys.FindHashed(aKey) >= 0;
+  {$ifdef HASFASTTRYFINALLY}
+  finally
+  {$endif HASFASTTRYFINALLY}
+    fSafe.ReadUnLock;
+  end;
+end;
+
+function TSynDictionary.ExistsValue(
+  const aValue; aCompare: TDynArraySortCompare): boolean;
+begin
+  result := false;
+  if self = nil then
+    exit;
+  fSafe.ReadLock;
+  try
+    result := fValues.Find(aValue, aCompare) >= 0;
+  finally
+    fSafe.ReadUnLock;
+  end;
+end;
+
+procedure TSynDictionary.CopyValues(out Dest; ObjArrayByRef: boolean);
+begin
+  fSafe.ReadLock;
+  try
+    fValues.CopyTo(Dest, ObjArrayByRef);
+  finally
+    fSafe.ReadUnLock;
+  end;
+end;
+
+function TSynDictionary.ForEach(const OnEach: TOnSynDictionary;
+  Opaque: pointer; MayModify: boolean): integer;
+var
+  k, v: PAnsiChar;
+  i, n, ks, vs: PtrInt;
+begin
+  result := 0;
+  if MayModify then
+    fSafe.ReadWriteLock
+  else
+    fSafe.ReadLock;
+  try
+    n := fSafe.Padding[DIC_KEYCOUNT].VInteger;
+    if (n = 0) or
+       (not Assigned(OnEach)) then
+      exit;
+    k := fKeys.Value^;
+    ks := fKeys.Info.Cache.ItemSize;
+    v := fValues.Value^;
+    vs := fValues.Info.Cache.ItemSize;
+    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
+    if MayModify then
+      fSafe.ReadWriteUnLock
+    else
+      fSafe.ReadUnLock;
+  end;
+end;
+
+function TSynDictionary.ForEach(const OnMatch: TOnSynDictionary;
+  KeyCompare, ValueCompare: TDynArraySortCompare; const aKey, aValue;
+  Opaque: pointer; MayModify: boolean): integer;
+var
+  k, v: PAnsiChar;
+  i, n, ks, vs: PtrInt;
+begin
+  if MayModify then
+    fSafe.ReadWriteLock
+  else
+    fSafe.ReadLock;
+  try
+    result := 0;
+    if (not Assigned(OnMatch)) or
+       (not (Assigned(KeyCompare) or
+             Assigned(ValueCompare))) then
+      exit;
+    n := fSafe.Padding[DIC_KEYCOUNT].VInteger;
+    k := fKeys.Value^;
+    ks := fKeys.Info.Cache.ItemSize;
+    v := fValues.Value^;
+    vs := fValues.Info.Cache.ItemSize;
+    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
+    if MayModify then
+      fSafe.ReadWriteUnLock
+    else
+      fSafe.ReadUnLock;
+  end;
+end;
+
+procedure TSynDictionary.SetTimeoutAtIndex(aIndex: PtrInt);
+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(GetTickCount64 shr 10) + tim;
+end;
+
+function TSynDictionary.Count: integer;
+begin
+  result := fSafe.Padding[DIC_KEYCOUNT].VInteger;
+end;
+
+procedure TSynDictionary.SaveToJson(W: TJsonWriter; EnumSetsAsText: boolean);
+var
+  k, v: RawUtf8;
+begin
+  fSafe.ReadLock;
+  try
+    if fSafe.Padding[DIC_KEYCOUNT].VInteger > 0 then
+    begin
+      fKeys{$ifdef UNDIRECTDYNARRAY}.InternalDynArray{$endif}.
+        SaveToJson(k, EnumSetsAsText);
+      fValues.SaveToJson(v, EnumSetsAsText);
+    end;
+  finally
+    fSafe.ReadUnLock;
+  end;
+  W.AddJsonArraysAsJsonObject(pointer(k), pointer(v));
+end;
+
+function TSynDictionary.SaveToJson(EnumSetsAsText: boolean): RawUtf8;
+var
+  W: TJsonWriter;
+  temp: TTextWriterStackBuffer;
+begin
+  W := TJsonWriter.CreateOwnedStream(temp) as TJsonWriter;
+  try
+    SaveToJson(W, EnumSetsAsText);
+    W.SetText(result);
+  finally
+    W.Free;
+  end;
+end;
+
+function TSynDictionary.SaveValuesToJson(EnumSetsAsText: boolean;
+  ReFormat: TTextWriterJsonFormat): RawUtf8;
+begin
+  if self = nil then
+  begin
+    result := '';
+    exit;
+  end;
+  fSafe.ReadLock;
+  try
+    fValues.SaveToJson(result, EnumSetsAsText, ReFormat);
+  finally
+    fSafe.ReadUnLock;
+  end;
+end;
+
+function TSynDictionary.LoadFromJson(const Json: RawUtf8;
+  CustomVariantOptions: PDocVariantOptions): boolean;
+begin
+  // pointer(Json) is not modified in-place thanks to JsonObjectAsJsonArrays()
+  result := LoadFromJson(pointer(Json), CustomVariantOptions);
+end;
+
+function TSynDictionary.LoadFromJson(Json: PUtf8Char;
+  CustomVariantOptions: PDocVariantOptions): boolean;
+var
+  k, v: RawUtf8; // private copy of the Json input, expanded as Keys/Values arrays
+  n: integer;
+begin
+  result := false;
+  n := JsonObjectAsJsonArrays(Json, k, v);
+  if n <= 0 then
+    exit;
+  fSafe.Lock;
+  try
+    if (fKeys.LoadFromJson(pointer(k), nil, CustomVariantOptions) <> nil) and
+       (fKeys.Count = n) and
+       (fValues.LoadFromJson(pointer(v), nil, CustomVariantOptions) <> nil) and
+       (fValues.Count = n) then
+      begin
+        SetTimeouts;
+        fKeys.ForceRehash; // warning: duplicated keys won't be identified
+        result := true;
+      end;
+  finally
+    fSafe.UnLock;
+  end;
+end;
+
+function TSynDictionary.LoadFromBinary(const binary: RawByteString): boolean;
+var
+  plain: RawByteString;
+  rdr: TFastReader;
+  n: integer;
+begin
+  result := false;
+  plain := fCompressAlgo.Decompress(binary);
+  if plain = '' then
+    exit;
+  rdr.Init(plain);
+  fSafe.Lock;
+  try
+    try
+      RTTI_BINARYLOAD[rkDynArray](fKeys.Value,   rdr, fKeys.Info.Info);
+      RTTI_BINARYLOAD[rkDynArray](fValues.Value, rdr, fValues.Info.Info);
+      n := fKeys.Capacity;
+      if n = fValues.Capacity then
+      begin
+        // RTTI_BINARYLOAD[rkDynArray]() did not set the external count
+        fSafe.Padding[DIC_KEYCOUNT].VInteger   := n;
+        fSafe.Padding[DIC_VALUECOUNT].VInteger := n;
+        SetTimeouts;  // set ComputeNextTimeOut for all items
+        fKeys.ForceReHash; // optimistic: input from TSynDictionary.SaveToBinary
+        result := true;
+      end;
+    except
+      result := false;
+    end;
+  finally
+    fSafe.UnLock;
+  end;
+end;
+
+class function TSynDictionary.OnCanDeleteSynPersistentLock(
+  const aKey, aValue; aIndex: PtrInt): boolean;
+begin
+  result := not TSynPersistentLock(aValue).Safe^.IsLocked;
+end;
+
+{$ifndef PUREMORMOT2}
+class function TSynDictionary.OnCanDeleteSynPersistentLocked(
+  const aKey, aValue; aIndex: PtrInt): boolean;
+begin
+  result := not TSynPersistentLocked(aValue).Safe^.IsLocked;
+end;
+{$endif PUREMORMOT2}
+
+function TSynDictionary.SaveToBinary(
+  NoCompression: boolean; Algo: TAlgoCompress): RawByteString;
+var
+  tmp: TTextWriterStackBuffer;
+  W: TBufferWriter;
+begin
+  result := '';
+  if fSafe.Padding[DIC_KEYCOUNT].VInteger = 0 then
+    exit;
+  W := TBufferWriter.Create(tmp{%H-});
+  try
+    fSafe.ReadLock;
+    try
+      if fSafe.Padding[DIC_KEYCOUNT].VInteger = 0 then
+        exit;
+      DynArraySave(pointer(fKeys.Value),
+        @fSafe.Padding[DIC_KEYCOUNT].VInteger, W, fKeys.Info.Info);
+      DynArraySave(pointer(fValues.Value),
+        @fSafe.Padding[DIC_VALUECOUNT].VInteger, W, fValues.Info.Info);
+    finally
+      fSafe.ReadUnLock;
+    end;
+    result := W.FlushAndCompress(NoCompression, Algo);
+  finally
+    W.Free;
+  end;
+end;
+
+
+
+{ ********** Custom JSON Serialization }
+
+{ TRttiJson }
+
+function _New_ObjectList(Rtti: TRttiCustom): pointer;
+begin
+  result := TObjectListClass(Rtti.ValueClass).Create;
+end;
+
+function _New_InterfacedObjectWithCustomCreate(Rtti: TRttiCustom): pointer;
+begin
+  result := TInterfacedObjectWithCustomCreateClass(Rtti.ValueClass).Create;
+end;
+
+function _New_PersistentWithCustomCreate(Rtti: TRttiCustom): pointer;
+begin
+  result := TPersistentWithCustomCreateClass(Rtti.ValueClass).Create;
+end;
+
+function _New_Component(Rtti: TRttiCustom): pointer;
+begin
+  result := TComponentClass(Rtti.ValueClass).Create(nil);
+end;
+
+function _New_ObjectWithCustomCreate(Rtti: TRttiCustom): pointer;
+begin
+  result := TObjectWithCustomCreateClass(Rtti.ValueClass).Create;
+end;
+
+function _New_SynObjectList(Rtti: TRttiCustom): pointer;
+begin
+  result := TSynObjectListClass(Rtti.ValueClass).Create({ownobjects=}true);
+end;
+
+function _New_SynLocked(Rtti: TRttiCustom): pointer;
+begin
+  result := TSynLockedClass(Rtti.ValueClass).Create;
+end;
+
+function _New_InterfacedCollection(Rtti: TRttiCustom): pointer;
+begin
+  result := TInterfacedCollectionClass(Rtti.ValueClass).Create;
+end;
+
+function _New_Collection(Rtti: TRttiCustom): pointer;
+begin
+  if Rtti.CollectionItem = nil then
+    raise ERttiException.CreateUtf8('% with CollectionItem=nil: please call ' +
+      'Rtti.RegisterCollection()', [Rtti.ValueClass]);
+  result := TCollectionClass(Rtti.ValueClass).Create(Rtti.CollectionItem);
+end;
+
+function _New_CollectionItem(Rtti: TRttiCustom): pointer;
+begin
+  result := TCollectionItemClass(Rtti.ValueClass).Create(nil);
+end;
+
+function _New_List(Rtti: TRttiCustom): pointer;
+begin
+  result := TListClass(Rtti.ValueClass).Create;
+end;
+
+function _New_Object(Rtti: TRttiCustom): pointer;
+begin
+  result := Rtti.ValueClass.Create; // non-virtual TObject.Create constructor
+end;
+
+function _BC_RawByteString(A, B: PPUtf8Char; Info: PRttiInfo;
+  out Compared: integer): PtrInt;
+begin
+  {$ifdef CPUINTEL}
+  compared := SortDynArrayAnsiString(A^, B^); // i386/x86_64 asm uses length
+  {$else}
+  compared := SortDynArrayRawByteString(A^, B^); // will use length not #0
+  {$endif CPUINTEL}
+  result := SizeOf(pointer);
+end;
+
+function _BC_PUtf8Char(A, B: PPUtf8Char; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  compared := StrComp(A^, B^);
+  result := SizeOf(pointer);
+end;
+
+function _BCI_PUtf8Char(A, B: PPUtf8Char; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  compared := StrIComp(A^, B^);
+  result := SizeOf(pointer);
+end;
+
+function _BC_Default(A, B: pointer; Info: PRttiInfo; out Compared: integer): PtrInt;
+begin
+  Compared := ComparePointer(A, B); // weak fallback
+  result := 0; // not used in TRttiJson.ValueCompare / fCompare[]
+end;
+
+function TRttiJson.SetParserType(aParser: TRttiParserType;
+  aParserComplex: TRttiParserComplexType): TRttiCustom;
+var
+  C: TClass;
+  n: integer;
+begin
+  // set Name and Flags from Props[]
+  inherited SetParserType(aParser, aParserComplex);
+  // set comparison functions
+  fCompare[true]  := RTTI_COMPARE[true][Kind];  // generic comparison
+  fCompare[false] := RTTI_COMPARE[false][Kind];
+  if rcfHasRttiOrd in fCache.Flags then
+  begin
+    fCompare[true]  := @RTTI_ORD_COMPARE[fCache.RttiOrd]; // tuned compare
+    fCompare[false] := fCompare[true];
+  end
+  else if rcfGetInt64Prop in fCache.Flags then
+  begin
+    if rcfQWord in fCache.Flags then
+      fCompare[true] := @_BC_UQWord  // QWord compare
+    else
+      fCompare[true] := @_BC_SQWord; // Int64 compare
+    fCompare[false] := fCompare[true];
+  end
+  else if Kind = rkFloat then
+  begin
+    fCompare[true]  := @RTTI_FLOAT_COMPARE[fCache.RttiFloat]; // tuned compare
+    fCompare[false] := fCompare[true];
+  end
+  else if rcfObjArray in fFlags then
+  begin
+    fCompare[true]  := _BCI_ObjArray; // direct compare
+    fCompare[false] := _BC_ObjArray;
+  end
+  else if aParser = ptPUtf8Char then
+  begin
+    fCompare[true]  := @_BCI_PUtf8Char; // rkPointer with no RTTI
+    fCompare[false] := @_BC_PUtf8Char;
+  end
+  else if Kind = rkLString then // override default StrComp/StrIComp
+    if Cache.CodePage >= CP_RAWBLOB then
+    begin
+      fCompare[true]  := @_BC_RawByteString; // ignore #0 or CaseInsensitive
+      fCompare[false] := @_BC_RawByteString;
+    end
+    else if Cache.CodePage = CP_UTF16 then
+    begin
+      fCompare[true]  := RTTI_COMPARE[true][rkWString];  // StrCompW
+      fCompare[false] := RTTI_COMPARE[false][rkWString]; // StrICompW
+    end;
+  if not Assigned(fCompare[true]) then
+  begin
+    // fallback to ComparePointer(A, B) if not enough RTTI
+    fCompare[true] := @_BC_Default;
+    fCompare[false] := @_BC_Default;
+  end;
+  // set class serialization and initialization
+  if aParser = ptClass then
+  begin
+    // default JSON serialization of published props
+    fJsonSave := @_JS_RttiCustom;
+    fJsonLoad := @_JL_RttiCustom;
+    // prepare efficient ClassNewInstance() and recognize most parents
+    C := fValueClass;
+    repeat
+      if C = TObjectList then // any branch taken will break below
+      begin
+        fNewInstance := @_New_ObjectList;
+        fJsonSave := @_JS_TObjectList;
+        fJsonLoad := @_JL_TObjectList;
+      end
+      else if C = TInterfacedObjectWithCustomCreate then
+        fNewInstance := @_New_InterfacedObjectWithCustomCreate
+      else if C = TPersistentWithCustomCreate then
+        fNewInstance := @_New_PersistentWithCustomCreate
+      else if C = TObjectWithCustomCreate then
+      begin
+        fNewInstance := @_New_ObjectWithCustomCreate;
+        // allow any kind of customization for TObjectWithCustomCreate children
+        // - is used e.g. by TOrm or TObjectWithID
+        n := Props.Count;
+        TObjectWithCustomCreateRttiCustomSetParser(
+          TObjectWithCustomCreateClass(fValueClass), self);
+        if n <> Props.Count then
+          fFlags := fFlags + fProps.AdjustAfterAdded; // added a prop
+      end
+      else if C = TSynObjectList then
+      begin
+        fNewInstance := @_New_SynObjectList;
+        fJsonSave := @_JS_TSynObjectList;
+        fJsonLoad := @_JL_TSynObjectList;
+      end
+      else if C = TSynLocked then
+        fNewInstance := @_New_SynLocked
+      else if C = TComponent then
+        fNewInstance := @_New_Component
+      else if C = TInterfacedCollection then
+      begin
+        if fValueClass <> C then
+        begin
+          fCollectionItem := TInterfacedCollectionClass(fValueClass).GetClass;
+          fCollectionItemRtti := Rtti.RegisterClass(fCollectionItem);
+        end;
+        fNewInstance := @_New_InterfacedCollection;
+        fJsonSave := @_JS_TCollection;
+        fJsonLoad := @_JL_TCollection;
+      end
+      else if C = TCollection then
+      begin
+        fNewInstance := @_New_Collection;
+        fJsonSave := @_JS_TCollection;
+        fJsonLoad := @_JL_TCollection;
+      end
+      else if C = TCollectionItem then
+        fNewInstance := @_New_CollectionItem
+      else if C = TList then
+        fNewInstance := @_New_List
+      else if C = TObject then
+        fNewInstance := @_New_Object
+      else
+      begin
+        // customize JSON serialization
+        if C = TSynList then
+          fJsonSave := @_JS_TSynList
+        else if C = TObjectWithID then
+          fJsonLoad := @_JL_RttiObjectWithID; // also accepts "RowID" field
+        C := C.ClassParent; // continue with the parent class
+        continue;
+      end;
+      break; // we reached the root supported class
+    until false;
+    case fValueRtlClass of
+      vcStrings:
+        begin
+          fJsonSave := @_JS_TStrings;
+          fJsonLoad := @_JL_TStrings;
+        end;
+      vcList:
+        fJsonSave := @_JS_TList;
+      vcRawUtf8List:
+        begin
+          fJsonSave := @_JS_TRawUtf8List;
+          fJsonLoad := @_JL_TRawUtf8List;
+        end;
+    end;
+  end
+  else if rcfBinary in Flags then
+  begin
+    fJsonSave := @_JS_Binary;
+    fJsonLoad := @_JL_Binary;
+  end
+  else
+  case Kind of
+    rkChar:
+      begin
+        fJsonSave := @_JS_Char;
+        fJsonLoad := @_JL_Char;
+        include(fFlags, rcfJsonString);
+      end;
+    rkWChar {$ifdef FPC}, rkUChar {$endif}:
+      begin
+        fJsonSave := @_JS_WideChar;
+        fJsonLoad := @_JL_WideChar;
+        include(fFlags, rcfJsonString);
+      end;
+  else
+    begin
+      // default well-known serialization
+      fJsonSave := PTC_JSONSAVE[aParserComplex];
+      if not Assigned(fJsonSave) then
+        fJsonSave := PT_JSONSAVE[aParser];
+      fJsonLoad := PT_JSONLOAD[aParser];
+      // rkRecordTypes serialization with proper fields RTTI
+      if (not Assigned(fJsonSave)) and
+         (Flags * [rcfWithoutRtti, rcfHasNestedProperties] <> []) then
+        fJsonSave := @_JS_RttiCustom;
+     if (not Assigned(fJsonLoad)) and
+        (Flags * [rcfWithoutRtti, rcfHasNestedProperties] <> []) then
+      fJsonLoad := @_JL_RttiCustom
+    end;
+  end;
+  // TRttiJson.RegisterCustomSerializer() custom callbacks have priority
+  if Assigned(fJsonWriter.Code) then
+    fJsonSave := @_JS_RttiCustom;
+  if Assigned(fJsonReader.Code) then
+    fJsonLoad := @_JL_RttiCustom;
+  result := self;
+end;
+
+procedure TRttiJson.SetValueClass(aClass: TClass; aInfo: PRttiInfo);
+begin
+  inherited SetValueClass(aClass, aInfo);
+  if aClass.InheritsFrom(TSynList) then
+    fValueRtlClass := vcSynList
+  else if aClass.InheritsFrom(TRawUtf8List) then
+    fValueRtlClass := vcRawUtf8List;
+end;
+
+function TRttiJson.ParseNewInstance(var Context: TJsonParserContext): TObject;
+begin
+  result := fNewInstance(self);
+  TRttiJsonLoad(fJsonLoad)(@result, Context);
+  if not Context.Valid then
+    FreeAndNil(result);
+end;
+
+function TRttiJson.ValueCompare(Data, Other: pointer; CaseInsensitive: boolean): integer;
+begin
+  fCompare[CaseInsensitive](Data, Other, Info, result); // at least _BC_Default
+end;
+
+function TRttiJson.ValueToVariant(Data: pointer; out Dest: TVarData;
+  Options: pointer{PDocVariantOptions}): PtrInt;
+var
+  tmp: pointer;
+  vt: cardinal;
+  ctx: TGetJsonField;
+begin
+  // see TRttiCustomProp.GetValueDirect
+  vt := Cache.VarDataVType;
+  TRttiVarData(Dest).VType := vt;
+  case vt of
+    varInt64,
+    varBoolean:
+      // rkInteger,rkBool,rkEnumeration,rkSet using VInt64 for unsigned 32-bit
+      Dest.VInt64 := RTTI_FROM_ORD[Cache.RttiOrd](Data);
+    varWord64:
+      // rkInt64, rkQWord
+      begin
+        if not (rcfQWord in Cache.Flags) then
+          TRttiVarData(Dest).VType := varInt64; // fix VType
+        Dest.VInt64 := PInt64(Data)^;
+      end;
+    varSingle:
+      Dest.VInteger := PInteger(Data)^;
+    varDate,
+    varDouble,
+    varCurrency:
+      Dest.VInt64 := PInt64(Data)^;
+    varString:
+      // rkString
+      begin
+        Dest.VAny := nil; // avoid GPF
+        RawByteString(Dest.VAny) := PRawByteString(Data)^;
+      end;
+    varOleStr:
+      // rkWString
+      begin
+        Dest.VAny := nil; // avoid GPF
+        WideString(Dest.VAny) := PWideString(Data)^;
+      end;
+    {$ifdef HASVARUSTRING}
+    varUString:
+      // rkUString
+      begin
+        Dest.VAny := nil; // avoid GPF
+        UnicodeString(Dest.VAny) := PUnicodeString(Data)^;
+      end;
+    {$endif HASVARUSTRING}
+    varVariant:
+      // rkVariant
+      SetVariantByValue(PVariant(Data)^, PVariant(@Dest)^);
+    varUnknown:
+      // rkChar, rkWChar, rkSString converted into temporary RawUtf8
+      begin
+        TRttiVarData(Dest).VType := varString;
+        Dest.VAny := nil; // avoid GPF
+        Info.StringToUtf8(Data, RawUtf8(Dest.VAny));
+      end;
+   else
+     begin
+       tmp := nil; // use temporary JSON conversion
+       SaveJson(Data^, Info, [], RawUtf8(tmp)); // =TJsonWriter.AddTypedJson()
+       TRttiVarData(Dest).VType := varEmpty;
+       ctx.Json := tmp;
+       JsonToAnyVariant(variant(Dest), ctx, Options, true);
+       FastAssignNew(tmp);
+     end;
+  end;
+  result := Cache.ItemSize;
+end;
+
+procedure TRttiJson.ValueLoadJson(Data: pointer; var Json: PUtf8Char;
+  EndOfObject: PUtf8Char; ParserOptions: TJsonParserOptions;
+  CustomVariantOptions: PDocVariantOptions; ObjectListItemClass: TClass;
+  Interning: TRawUtf8Interning);
+var
+  ctxt: TJsonParserContext;
+begin
+  if Assigned(self) then
+  begin
+    ctxt.InitParser(Json, self, ParserOptions,
+      CustomVariantOptions, ObjectListItemClass, Interning);
+    if Assigned(fJsonLoad) then
+      // efficient direct Json parsing
+      TRttiJsonLoad(fJsonLoad)(Data, ctxt)
+    else
+      // try if binary serialization was used
+      ctxt.Valid := ctxt.ParseNext and
+            (Ctxt.Value <> nil) and
+            (PCardinal(Ctxt.Value)^ and $ffffff = JSON_BASE64_MAGIC_C) and
+            BinaryLoadBase64(pointer(Ctxt.Value + 3), Ctxt.ValueLen - 3,
+              Data, Ctxt.Info.Info, {uri=}false, rkAllTypes, {withcrc=}false);
+    if ctxt.Valid then
+      Json := ctxt.Json
+    else
+      Json := nil;
+  end
+  else
+    Json := nil;
+end;
+
+function TRttiJson.ValueIterateCount(Data: pointer): integer;
+begin
+  result := -1; // unsupported
+  if Data <> nil then
+    case Kind of
+      rkDynArray:
+        result := length(PByteDynArray(Data)^); // length() is for all types
+      rkClass:
+        begin
+          Data := PPointer(Data)^; // TObject are stored by reference
+          if Data <> nil then
+           case ValueRtlClass of
+             // vcStrings can't be supported since TStrings.Items[] is a getter
+             vcCollection:
+               result := TCollection(Data).Count;
+             vcObjectList,
+             vcList:
+               result := TList(Data).Count;
+             vcSynList:
+               result := TSynList(Data).Count;
+             vcRawUtf8List:
+               result := TRawUtf8List(Data).Count;
+           end;
+        end;
+    end;
+end;
+
+function TRttiJson.ValueIterate(Data: pointer; Index: PtrUInt;
+  out ResultRtti: TRttiCustom): pointer;
+begin
+  result := nil;
+  if Data <> nil then
+    case Kind of
+      rkDynArray:
+        if Index < PtrUInt(length(PByteDynArray(Data)^)) then
+        begin
+          result := PPAnsiChar(Data)^ + (Index * PtrUInt(ArrayRtti.Size));
+          ResultRtti := ArrayRtti; // also available for (most) unmanaged types
+          if ArrayRtti.Kind in [rkClass, rkLString] then
+            result := PPointer(result)^; // resolved as for rkClass below
+        end;
+      rkClass:
+        begin
+          Data := PPointer(Data)^; // TObject are stored by reference
+          if Data <> nil then
+           case ValueRtlClass of
+             // getter methods do require resolved results
+             vcCollection:
+               if Index < PtrUInt(TCollection(Data).Count) then
+               begin
+                 result := TCollection(Data).Items[Index];
+                 ResultRtti := fCollectionItemRtti;
+               end;
+             vcObjectList,
+             vcList:
+               if Index < PtrUInt(TList(Data).Count) then
+               begin
+                 result := TList(Data).List[Index];
+                 if result <> nil then
+                   ResultRtti := Rtti.RegisterClass(PClass(result)^);
+               end;
+             vcSynList:
+               if Index < PtrUInt(TSynList(Data).Count) then
+               begin
+                 result := TSynList(Data).List[Index];
+                 if result <> nil then
+                   ResultRtti := Rtti.RegisterClass(PClass(result)^);
+               end;
+             vcRawUtf8List:
+               if Index < PtrUInt(TRawUtf8List(Data).Count) then
+               begin
+                 result := TRawUtf8List(Data).TextPtr[Index];
+                 ResultRtti := PT_RTTI[ptRawUtf8];
+                 exit;
+               end;
+           end;
+        end;
+    end;
+end;
+
+function StrEquA(n, str: PByte): boolean;
+var
+  c: byte;
+begin
+  result := false;
+  if str = nil then
+    exit;
+  repeat
+    c := n^;
+    if c <> str^ then // UTF-8 case-sensitive search
+      exit
+    else if c = 0 then
+      break; // n = str
+    inc(n);
+    inc(str);
+  until false;
+  result := true;
+end;
+
+function StrEquAW(n: PByte; str: PWord): boolean;
+var
+  c: cardinal;
+begin
+  result := false;
+  if str = nil then
+    exit;
+  repeat
+    c := n^;
+    if c <> str^ then // 7-bit ASCII case-sensitive search
+      exit
+    else if c = 0 then
+      break; // n = str
+    inc(n);
+    inc(str);
+  until false;
+  result := true;
+end;
+
+function TRttiJson.ValueByPath(var Data: pointer; Path: PUtf8Char;
+  var Temp: TVarData; PathDelim: AnsiChar): TRttiCustom;
+var
+  vt: TSynInvokeableVariantType;
+  p: PRttiCustomProp;
+  v: TVarData;
+  i: PtrInt;
+  n: ShortString;
+begin
+  result := self;
+  if (self <> nil) and
+     (Data <> nil) then
+  repeat
+    GetNextItemShortString(Path, @n, PathDelim);
+    if n[0] = #0 then
+      break;
+    if result.Props.CountNonVoid <> 0 then
+    begin
+      // search name in rkRecord/rkObject or rkClass properties
+      p := FindCustomProp(
+        pointer(result.Props.List), @n[1], ord(n[0]), result.Props.Count);
+      if (p = nil) or
+         (p^.OffsetGet < 0) then // we don't support getters yet
+        break;
+      result := p^.Value;
+      inc(PAnsiChar(Data), p.OffsetGet);
+      if Path = nil then
+        exit; // reach last path
+      if result.Kind = rkClass then // stored by reference
+        Data := PPointer(PAnsiChar(Data) + p.OffsetGet)^;
+      continue;
+    end
+    else
+    case result.Kind of
+      rkVariant:
+        // try TDocVariant/TBsonVariant name lookup
+        if DocVariantType.FindSynVariantType(PVarData(Data)^.VType, vt) then
+        begin
+          TRttiVarData(v).VType := varEmpty; // IntGet() would clear it
+          vt.IntGet(v, PVarData(Data)^, @n[1], ord(n[0]), {noexc=}true);
+          if v.VType = varEmpty then
+            break;
+          Temp := v;
+          Data := @Temp;
+          result := PT_RTTI[ptVariant];
+          if Path = nil then
+            exit;
+          continue;
+        end;
+      rkEnumeration,
+      rkSet:
+        // check enumeration/set name against the stored value
+        if Path = nil then // last path only
+        begin
+          i := result.Cache.EnumInfo^.GetEnumNameValue(@n[1], ord(n[0]));
+          if i < 0 then
+            break;
+          // enum name match: return a boolean to stop searching
+          if result.Kind = rkEnumeration then
+          begin
+            // true = enum name matches the stored enum value
+            result.ValueToVariant(Data, v); // calls RTTI_FROM_ORD[]
+            PBoolean(@Temp)^ := v.VInt64 = i;
+          end
+          else
+            // true = enum name is part of the set value
+            PBoolean(@Temp)^ := GetBitPtr(Data, i);
+          Data := @Temp;
+          result := PT_RTTI[ptBoolean]; // true/false if enum name found
+          exit;
+        end;
+      rkLString:
+        // case-sensitive comparison of a UTF-8 value with the name
+        if Path = nil then // last path only
+          if StrEquA(@n[1], PPByte(Data)^) then // n[1] ends with #0
+            exit; // return self as non nil value
+      {$ifdef HASVARUSTRING}
+      rkUstring,
+      {$endif HASVARUSTRING}
+      rkWString:
+        // case-sensitive comparison of a UTF-16 value with the name
+        if Path = nil then // last path only
+          if StrEquAW(@n[1], PPWord(Data)^) then
+            exit;
+    end;
+    break;
+  until false;
+  result := nil; // path not found
+end;
+
+procedure TRttiJson.RawSaveJson(Data: pointer; const Ctxt: TJsonSaveContext);
+begin
+  TRttiJsonSave(fJsonSave)(Data, Ctxt);
+end;
+
+procedure TRttiJson.RawLoadJson(Data: pointer; var Ctxt: TJsonParserContext);
+begin
+  TRttiJsonLoad(fJsonLoad)(Data, Ctxt);
+end;
+
+class function TRttiJson.Find(Info: PRttiInfo): TRttiJson;
+begin
+  result := pointer(Rtti.FindType(Info));
+end;
+
+class function TRttiJson.RegisterCustomSerializer(Info: PRttiInfo;
+  const Reader: TOnRttiJsonRead; const Writer: TOnRttiJsonWrite): TRttiJson;
+begin
+  result := Rtti.RegisterType(Info) as TRttiJson;
+  // (re)set fJsonSave/fJsonLoad
+  result.fJsonWriter := TMethod(Writer);
+  result.fJsonReader := TMethod(Reader);
+  if result.Kind <> rkDynArray then // Reader/Writer are for items, not array
+    result.SetParserType(result.Parser, result.ParserComplex);
+end;
+
+class function TRttiJson.RegisterCustomSerializerClass(ObjectClass: TClass;
+  const Reader: TOnClassJsonRead; const Writer: TOnClassJsonWrite): TRttiJson;
+begin
+  // without {$M+} ObjectClasss.ClassInfo=nil -> ensure fake RTTI is available
+  result := Rtti.RegisterClass(ObjectClass) as TRttiJson;
+  result.fJsonWriter := TMethod(Writer);
+  result.fJsonReader := TMethod(Reader);
+  result.SetParserType(ptClass, pctNone);
+end;
+
+class function TRttiJson.UnRegisterCustomSerializer(Info: PRttiInfo): TRttiJson;
+begin
+  result := Rtti.RegisterType(Info) as TRttiJson;
+  result.fJsonWriter.Code := nil; // force reset of the JSON serialization
+  result.fJsonReader.Code := nil;
+  if result.Kind <> rkDynArray then // Reader/Writer are for items, not array
+    result.SetParserType(result.Parser, result.ParserComplex);
+end;
+
+class function TRttiJson.UnRegisterCustomSerializerClass(ObjectClass: TClass): TRttiJson;
+begin
+  // without {$M+} ObjectClasss.ClassInfo=nil -> ensure fake RTTI is available
+  result := Rtti.RegisterClass(ObjectClass) as TRttiJson;
+  result.fJsonWriter.Code := nil; // force reset of the JSON serialization
+  result.fJsonReader.Code := nil;
+  result.SetParserType(result.Parser, result.ParserComplex);
+end;
+
+class function TRttiJson.RegisterFromText(DynArrayOrRecord: PRttiInfo;
+  const RttiDefinition: RawUtf8;
+  IncludeReadOptions: TJsonParserOptions;
+  IncludeWriteOptions: TTextWriterWriteObjectOptions): TRttiJson;
+begin
+  result := Rtti.RegisterFromText(DynArrayOrRecord, RttiDefinition) as TRttiJson;
+  result.fIncludeReadOptions := IncludeReadOptions;
+  result.fIncludeWriteOptions := IncludeWriteOptions;
+end;
+
+
+procedure _GetDataFromJson(Data: pointer; var Json: PUtf8Char;
+  EndOfObject: PUtf8Char; Rtti: TRttiCustom;
+  CustomVariantOptions: PDocVariantOptions; Tolerant: boolean;
+  Interning: TRawUtf8InterningAbstract);
+begin
+  (Rtti as TRttiJson).ValueLoadJson(Data, Json, EndOfObject,
+    JSONPARSER_DEFAULTORTOLERANTOPTIONS[Tolerant],
+    CustomVariantOptions, nil, TRawUtf8Interning(Interning));
+end;
+
+
+{ ********** JSON Serialization Wrapper Functions }
+
+function JsonEncode(const NameValuePairs: array of const): RawUtf8;
+var
+  temp: TTextWriterStackBuffer;
+begin
+  if high(NameValuePairs) < 1 then
+    // return void JSON object on error
+    result := '{}'
+  else
+    with TJsonWriter.CreateOwnedStream(temp) do
+    try
+      AddJsonEscape(NameValuePairs);
+      SetText(result);
+    finally
+      Free
+    end;
+end;
+
+function JsonEncode(const Format: RawUtf8;
+  const Args, Params: array of const): RawUtf8;
+var
+  temp: TTextWriterStackBuffer;
+begin
+  with TJsonWriter.CreateOwnedStream(temp) do
+  try
+    AddJson(Format, Args, Params);
+    SetText(result);
+  finally
+    Free
+  end;
+end;
+
+function JsonEncodeArrayDouble(const Values: array of double): RawUtf8;
+var
+  W: TJsonWriter;
+  temp: TTextWriterStackBuffer;
+begin
+  W := TJsonWriter.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: TJsonWriter;
+  temp: TTextWriterStackBuffer;
+begin
+  W := TJsonWriter.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: TJsonWriter;
+  temp: TTextWriterStackBuffer;
+begin
+  W := TJsonWriter.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 TJsonWriter.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 TJsonWriter.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 SaveJson(const Value; TypeInfo: PRttiInfo; Options: TTextWriterOptions;
+  var result: RawUtf8; ObjectOptions: TTextWriterWriteObjectOptions);
+var
+  temp: TTextWriterStackBuffer;
+begin
+  with TJsonWriter.CreateOwnedStream(temp, twoNoSharedStream in Options) do
+  try
+    CustomOptions := CustomOptions + Options;
+    AddTypedJson(@Value, TypeInfo, ObjectOptions);
+    SetText(result);
+  finally
+    Free;
+  end;
+end;
+
+function SaveJson(const Value; TypeInfo: PRttiInfo; EnumSetsAsText: boolean): RawUtf8;
+begin
+  SaveJson(Value, TypeInfo, TEXTWRITEROPTIONS_SETASTEXT[EnumSetsAsText], result);
+end;
+
+function SaveJson(const Value; TypeInfo: PRttiInfo): RawUtf8;
+begin
+  SaveJson(Value, TypeInfo, [], Result, []);
+end;
+
+function SaveJson(const Value; const TypeName: RawUtf8;
+  Options: TTextWriterOptions): RawUtf8;
+var
+  nfo: TRttiCustom;
+begin
+  nfo := Rtti.RegisterTypeFromName(TypeName);
+  if nfo = nil then
+    result := ''
+  else
+    SaveJson(Value, nfo.Cache.Info, Options, result);
+end;
+
+{$ifdef FPC}
+procedure JsonForDebug(Value: pointer; var TypeName: RawUtf8;
+  out JsonResultText: RawUtf8);
+var
+  nfo: TRttiCustom;
+  vmt: PAnsiChar;
+begin
+  if (TypeName <> '') and
+     (Value <> nil) then
+  try
+    nfo := Rtti.RegisterTypeFromName(TypeName); // from Rtti.Register*() functions
+    {$ifdef HASINTERFACEASTOBJECT} // we target FPC/Lazarus anyway
+    if (nfo = nil) and
+       (TypeName[1] = 'I') then // guess class instance from interface variable
+      nfo := Rtti.RegisterClass(PInterface(Value)^ as TObject);
+    {$endif HASINTERFACEASTOBJECT}
+    if (nfo = nil) and
+       (TypeName[1] = 'T') then
+    begin
+      vmt := PPointer(Value)^; // guess if seems to be a real TObject instance
+      if (vmt <> nil) and
+         SeemsRealPointer(vmt) and
+         (PPtrInt(vmt + vmtInstanceSize)^ >= sizeof(vmt)) and
+         SeemsRealPointer(PPointer(vmt + vmtClassName)^) and
+         IdemPropName(PShortString(vmt + vmtClassName)^,
+           pointer(TypeName), length(TypeName)) then
+        nfo := Rtti.RegisterClass(TClass(pointer(vmt)));
+    end;
+    if nfo <> nil then
+    begin
+      SaveJson(Value^, nfo.Cache.Info, [twoEnumSetsAsBooleanInRecord],
+        JsonResultText, [woEnumSetsAsText]);
+      exit;
+    end;
+  except // especially if Value is no class
+    JsonResultText := ''; // impossible to serialization this value
+  end;
+end;
+{$endif FPC}
+
+function RecordSaveJson(const Rec; TypeInfo: PRttiInfo;
+  EnumSetsAsText: boolean): RawUtf8;
+begin
+  if (TypeInfo <> nil) and
+     (TypeInfo^.Kind in rkRecordTypes) then
+    SaveJson(Rec, TypeInfo, TEXTWRITEROPTIONS_SETASTEXT[EnumSetsAsText], result)
+  else
+    result := NULL_STR_VAR;
+end;
+
+function DynArraySaveJson(const Value; TypeInfo: PRttiInfo;
+  EnumSetsAsText: boolean): RawUtf8;
+begin
+  if (TypeInfo = nil) or
+     (TypeInfo^.Kind <> rkDynArray) then
+    result := NULL_STR_VAR
+  else if pointer(Value) = nil then
+    result := '[]'
+  else
+    SaveJson(Value, TypeInfo, TEXTWRITEROPTIONS_SETASTEXT[EnumSetsAsText], result);
+end;
+
+function DynArrayBlobSaveJson(TypeInfo: PRttiInfo;
+  BlobValue: pointer; BlobLen: PtrInt): RawUtf8;
+var
+  DynArray: TDynArray;
+  Value: pointer; // decode BlobValue into a temporary dynamic array
+  temp: TTextWriterStackBuffer;
+begin
+  Value := nil;
+  DynArray.Init(TypeInfo, Value);
+  try
+    if DynArray.LoadFrom(BlobValue, PAnsiChar(BlobValue) + BlobLen) = nil then
+      result := ''
+    else
+      with TJsonWriter.CreateOwnedStream(temp) do
+      try
+        AddDynArrayJson(DynArray);
+        SetText(result);
+      finally
+        Free;
+      end;
+  finally
+    DynArray.Clear; // release temporary memory
+  end;
+end;
+
+function ObjArrayToJson(const aObjArray;
+  aOptions: TTextWriterWriteObjectOptions): RawUtf8;
+var
+  temp: TTextWriterStackBuffer;
+begin
+  with TJsonWriter.CreateOwnedStream(temp) do
+  try
+    if woEnumSetsAsText in aOptions then
+      CustomOptions := CustomOptions + [twoEnumSetsAsTextInRecord];
+    AddObjArrayJson(aObjArray, aOptions);
+    SetText(result);
+  finally
+    Free;
+  end;
+end;
+
+function ObjectsToJson(const Names: array of RawUtf8;
+  const Values: array of TObject;
+  Options: TTextWriterWriteObjectOptions): RawUtf8;
+var
+  i, n: PtrInt;
+  temp: TTextWriterStackBuffer;
+begin
+  with TJsonWriter.CreateOwnedStream(temp) do
+  try
+    n := high(Names);
+    BlockBegin('{', Options);
+    i := 0;
+    if i <= high(Values) then
+      repeat
+        if i <= n then
+          AddFieldName(Names[i])
+        else if Values[i] = nil then
+          AddFieldName(SmallUInt32Utf8[i])
+        else
+          AddPropName(ClassNameShort(Values[i])^);
+        WriteObject(Values[i], Options);
+        if i = high(Values) then
+          break;
+        BlockAfterItem(Options);
+        inc(i);
+      until false;
+    CancelLastComma;
+    BlockEnd('}', Options);
+    SetText(result);
+  finally
+    Free;
+  end;
+end;
+
+function ObjectToJsonFile(Value: TObject; const JsonFile: TFileName;
+  Options: TTextWriterWriteObjectOptions): boolean;
+var
+  humanread: boolean;
+  json: RawUtf8;
+begin
+  humanread := woHumanReadable in Options;
+  if humanread and
+     (woHumanReadableEnumSetAsComment in Options) then
+    humanread := false
+  else
+    // JsonReformat() erases comments
+    exclude(Options, woHumanReadable);
+  json := ObjectToJson(Value, Options);
+  if humanread then
+    // woHumanReadable not working with custom JSON serializers, e.g. T*ObjArray
+    // TODO: check if this is always the case with our mORMot2 new serialization
+    result := JsonBufferReformatToFile(pointer(json), JsonFile)
+  else
+    result := FileFromString(json, JsonFile);
+end;
+
+function GetValueObject(Instance: TObject; const Path: RawUtf8;
+  out Value: variant): boolean;
+var
+  p: PRttiCustomProp;
+begin
+  result := GetInstanceByPath(Instance, Path, p);
+  if result then
+    p^.GetValueVariant(Instance, TVarData(Value), @JSON_[mFastFloat]);
+end;
+
+function LoadJsonInPlace(var Value; Json: PUtf8Char; TypeInfo: PRttiInfo;
+  EndOfObject: PUtf8Char; CustomVariantOptions: PDocVariantOptions;
+  Tolerant: boolean; Interning: TRawUtf8Interning): PUtf8Char;
+begin
+  TRttiJson(Rtti.RegisterType(TypeInfo)).ValueLoadJson(
+    @Value, Json, EndOfObject, JSONPARSER_DEFAULTORTOLERANTOPTIONS[Tolerant],
+    CustomVariantOptions, nil, Interning);
+  result := Json;
+end;
+
+function LoadJson(var Value; const Json: RawUtf8; TypeInfo: PRttiInfo;
+  EndOfObject: PUtf8Char; CustomVariantOptions: PDocVariantOptions;
+  Tolerant: boolean; Interning: TRawUtf8Interning): boolean;
+var
+  tmp: TSynTempBuffer;
+begin
+  tmp.Init(Json); // make private copy before in-place decoding
+  try
+    result := LoadJsonInPlace(Value, tmp.buf, TypeInfo, EndOfObject,
+      CustomVariantOptions, Tolerant, Interning) <> nil;
+  finally
+    tmp.Done;
+  end;
+end;
+
+function RecordLoadJson(var Rec; Json: PUtf8Char; TypeInfo: PRttiInfo;
+  EndOfObject: PUtf8Char; CustomVariantOptions: PDocVariantOptions;
+  Tolerant: boolean; Interning: TRawUtf8Interning): PUtf8Char;
+begin
+  if (TypeInfo = nil) or
+     not (TypeInfo.Kind in rkRecordTypes) then
+    raise EJsonException.CreateUtf8('RecordLoadJson: % is not a record',
+      [TypeInfo.Name]);
+  TRttiJson(Rtti.RegisterType(TypeInfo)).ValueLoadJson(
+    @Rec, Json, EndOfObject, JSONPARSER_DEFAULTORTOLERANTOPTIONS[Tolerant],
+    CustomVariantOptions, nil, Interning);
+  result := Json;
+end;
+
+function RecordLoadJson(var Rec; const Json: RawUtf8; TypeInfo: PRttiInfo;
+  CustomVariantOptions: PDocVariantOptions; Tolerant: boolean;
+  Interning: TRawUtf8Interning): boolean;
+var
+  tmp: TSynTempBuffer;
+begin
+  tmp.Init(Json); // make private copy before in-place decoding
+  try
+    result := RecordLoadJson(Rec, tmp.buf, TypeInfo, nil,
+      CustomVariantOptions, Tolerant, Interning) <> nil;
+  finally
+    tmp.Done;
+  end;
+end;
+
+function DynArrayLoadJson(var Value; Json: PUtf8Char; TypeInfo: PRttiInfo;
+  EndOfObject: PUtf8Char; CustomVariantOptions: PDocVariantOptions;
+  Tolerant: boolean; Interning: TRawUtf8Interning): PUtf8Char;
+begin
+  if (TypeInfo = nil) or
+     (TypeInfo.Kind <> rkDynArray) then
+    raise EJsonException.CreateUtf8('DynArrayLoadJson: % is not a dynamic array',
+      [TypeInfo.Name]);
+  TRttiJson(Rtti.RegisterType(TypeInfo)).ValueLoadJson(
+    @Value, Json, EndOfObject, JSONPARSER_DEFAULTORTOLERANTOPTIONS[Tolerant],
+    CustomVariantOptions, nil, Interning);
+  result := Json;
+end;
+
+function DynArrayLoadJson(var Value; const Json: RawUtf8; TypeInfo: PRttiInfo;
+  CustomVariantOptions: PDocVariantOptions; Tolerant: boolean;
+  Interning: TRawUtf8Interning): boolean;
+var
+  tmp: TSynTempBuffer;
+begin
+  tmp.Init(Json); // make private copy before in-place decoding
+  try
+    result := DynArrayLoadJson(Value, tmp.buf, TypeInfo, nil,
+      CustomVariantOptions, Tolerant, Interning) <> nil;
+  finally
+    tmp.Done;
+  end;
+end;
+
+function JsonToObject(var ObjectInstance; From: PUtf8Char; out Valid: boolean;
+  TObjectListItemClass: TClass; Options: TJsonParserOptions;
+  Interning: TRawUtf8Interning): PUtf8Char;
+var
+  ctxt: TJsonParserContext;
+begin
+  if pointer(ObjectInstance) = nil then
+    raise ERttiException.Create('JsonToObject(nil)');
+  ctxt.InitParser(From, Rtti.RegisterClass(TObject(ObjectInstance)), Options,
+    nil, TObjectListItemClass, Interning);
+  TRttiJsonLoad(Ctxt.Info.JsonLoad)(@ObjectInstance, ctxt);
+  Valid := ctxt.Valid;
+  result := ctxt.Json;
+end;
+
+function JsonSettingsToObject(const JsonContent: RawUtf8;
+  Instance: TObject): boolean;
+var
+  tmp: TSynTempBuffer;
+begin
+  result := false;
+  if JsonContent = '' then
+    exit;
+  tmp.Init(JsonContent); // copy for in-place comment removal and JSON parsing
+  try
+    RemoveCommentsFromJson(tmp.buf);
+    JsonToObject(Instance, tmp.buf, result, nil, JSONPARSER_TOLERANTOPTIONS);
+  finally
+    tmp.Done;
+  end;
+end;
+
+function ObjectLoadJson(var ObjectInstance; const Json: RawUtf8;
+  TObjectListItemClass: TClass; Options: TJsonParserOptions;
+  Interning: TRawUtf8Interning): boolean;
+var
+  tmp: TSynTempBuffer;
+begin
+  tmp.Init(Json);
+  if tmp.len <> 0 then
+    try
+      JsonToObject(ObjectInstance,
+        tmp.buf, result, TObjectListItemClass, Options, Interning);
+    finally
+      tmp.Done;
+    end
+  else
+    result := false;
+end;
+
+function JsonToNewObject(var From: PUtf8Char; var Valid: boolean;
+  Options: TJsonParserOptions; Interning: TRawUtf8Interning): TObject;
+var
+  ctxt: TJsonParserContext;
+begin
+  ctxt.InitParser(From, nil, Options, nil, nil, Interning);
+  result := ctxt.ParseNewObject;
+  Valid := ctxt.Valid;
+end;
+
+function PropertyFromJson(Prop: PRttiCustomProp; Instance: TObject;
+  From: PUtf8Char; var Valid: boolean; Options: TJsonParserOptions;
+  Interning: TRawUtf8Interning): PUtf8Char;
+var
+  ctxt: TJsonParserContext;
+begin
+  Valid := false;
+  result := nil;
+  if (Prop = nil) or
+     (Prop^.Value.Kind <> rkClass) or
+     (Instance = nil) then
+    exit;
+  ctxt.InitParser(From, Prop^.Value, Options, nil, nil, Interning);
+  if not JsonLoadProp(pointer(Instance), Prop, ctxt) then
+    exit;
+  Valid := true;
+  result := ctxt.Json;
+end;
+
+function UrlDecodeObject(U: PUtf8Char; Upper: PAnsiChar;
+  var ObjectInstance; Next: PPUtf8Char; Options: TJsonParserOptions): boolean;
+var
+  tmp: RawUtf8;
+begin
+  result := UrlDecodeValue(U, Upper, tmp, Next);
+  if result then
+    JsonToObject(ObjectInstance, Pointer(tmp), result, nil, Options);
+end;
+
+function JsonFileToObject(const JsonFile: TFileName; var ObjectInstance;
+  TObjectListItemClass: TClass; Options: TJsonParserOptions;
+  Interning: TRawUtf8Interning): boolean;
+var
+  tmp: RawUtf8;
+begin
+  tmp := RawUtf8FromFile(JsonFile);
+  if tmp = '' then
+    result := false
+  else
+  begin
+    RemoveCommentsFromJson(pointer(tmp));
+    JsonToObject(ObjectInstance,
+      pointer(tmp), result, TObjectListItemClass, Options, Interning);
+  end;
+end;
+
+procedure JsonBufferToXML(P: PUtf8Char; const Header, NameSpace: RawUtf8;
+  out result: RawUtf8);
+var
+  i, j, L: PtrInt;
+  temp: TTextWriterStackBuffer;
+begin
+  if P = nil then
+    result := Header
+  else
+    with TJsonWriter.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, Header, NameSpace: RawUtf8): RawUtf8;
+var
+  tmp: TSynTempBuffer;
+begin
+  tmp.Init(Json);
+  try
+    JsonBufferToXML(tmp.buf, Header, NameSpace, result);
+  finally
+    tmp.Done;
+  end;
+end;
+
+
+{ ********************* Abstract Classes with Auto-Create-Fields }
+
+function DoRegisterAutoCreateFields(ObjectInstance: TObject): TRttiJson;
+begin // sub procedure for smaller code generation in AutoCreateFields/Create
+  result := Rtti.RegisterAutoCreateFieldsClass(PClass(ObjectInstance)^) as TRttiJson;
+end;
+
+function AutoCreateFields(ObjectInstance: TObject): TRttiJson;
+var
+  n: integer;
+  p: PPRttiCustomProp;
+begin
+  // inlined Rtti.RegisterClass()
+  {$ifdef NOPATCHVMT}
+  result := pointer(Rtti.FindType(PPointer(PPAnsiChar(ObjectInstance)^ + vmtTypeInfo)^));
+  {$else}
+  result := PPointer(PPAnsiChar(ObjectInstance)^ + vmtAutoTable)^;
+  {$endif NOPATCHVMT}
+  if (result = nil) or
+     not (rcfAutoCreateFields in result.Flags) then
+    result := DoRegisterAutoCreateFields(ObjectInstance);
+  p := pointer(result.fAutoCreateInstances);
+  if p = nil then
+    exit;
+  // create all published class (or IDocList/IDocDict) fields
+  n := PDALen(PAnsiChar(p) - _DALEN)^ + _DAOFF; // length(AutoCreateClasses)
+  repeat
+    with p^^ do
+      PPointer(PAnsiChar(ObjectInstance) + OffsetGet)^ :=
+        TRttiJson(Value).fNewInstance(Value); // class or interface
+    inc(p);
+    dec(n);
+  until n = 0;
+end;
+
+procedure AutoDestroyFields(ObjectInstance: TObject; Info: TRttiJson);
+var
+  n: integer;
+  p: PPRttiCustomProp;
+  arr: pointer;
+  o: TObject;
+begin
+  if Info = nil then
+    {$ifdef NOPATCHVMT}
+    Info := pointer(Rtti.FindType(PPointer(PPAnsiChar(ObjectInstance)^ + vmtTypeInfo)^));
+    {$else}
+    Info := PPointer(PPAnsiChar(ObjectInstance)^ + vmtAutoTable)^;
+    {$endif NOPATCHVMT}
+  // free all published class fields
+  p := pointer(Info.fAutoDestroyClasses);
+  if p <> nil then
+  begin
+    n := PDALen(PAnsiChar(p) - _DALEN)^ + _DAOFF;
+    repeat
+      o := PObject(PAnsiChar(ObjectInstance) + p^^.OffsetGet)^;
+      if o <> nil then
+        // inlined o.Free
+        o.Destroy;
+      inc(p);
+      dec(n);
+    until n = 0;
+  end;
+  // release all published T*ObjArray fields
+  p := pointer(Info.fAutoCreateObjArrays);
+  if p = nil then
+    exit;
+  n := PDALen(PAnsiChar(p) - _DALEN)^ + _DAOFF;
+  repeat
+    arr := PPointer(PAnsiChar(ObjectInstance) + p^^.OffsetGet)^;
+    if arr <> nil then
+      // inlined ObjArrayClear()
+      RawObjectsClear(arr, PDALen(PAnsiChar(arr) - _DALEN)^ + _DAOFF);
+    inc(p);
+    dec(n);
+  until n = 0;
+end;
+
+
+{ TPersistentAutoCreateFields }
+
+constructor TPersistentAutoCreateFields.Create;
+begin
+  AutoCreateFields(self);
+end; // no need to call the void inherited TPersistentWithCustomCreate
+
+destructor TPersistentAutoCreateFields.Destroy;
+begin
+  AutoDestroyFields(self);
+  inherited Destroy;
+end;
+
+
+{ TSynAutoCreateFields }
+
+constructor TSynAutoCreateFields.Create;
+begin
+  AutoCreateFields(self);
+end; // no need to call the void inherited TSynPersistent
+
+destructor TSynAutoCreateFields.Destroy;
+begin
+  AutoDestroyFields(self);
+  inherited Destroy;
+end;
+
+
+{ TSynAutoCreateFieldsLocked }
+
+constructor TSynAutoCreateFieldsLocked.Create;
+begin
+  AutoCreateFields(self);
+  inherited Create; // initialize fSafe := NewSynLocker
+end;
+
+destructor TSynAutoCreateFieldsLocked.Destroy;
+begin
+  AutoDestroyFields(self);
+  inherited Destroy;
+end;
+
+
+{ TInterfacedObjectAutoCreateFields }
+
+constructor TInterfacedObjectAutoCreateFields.Create;
+begin
+  AutoCreateFields(self);
+end; // no need to call TInterfacedObjectWithCustomCreate.Create
+
+destructor TInterfacedObjectAutoCreateFields.Destroy;
+begin
+  AutoDestroyFields(self);
+  inherited Destroy;
+end;
+
+
+{ TInterfacedSerializable }
+
+class function TInterfacedSerializable.SerializableInterface: TRttiCustom;
+begin
+  result := Rtti.FindClass(self).Cache.SerializableInterface;
+end;
+
+class function TInterfacedSerializable.Guid: PGuid;
+begin
+  result := SerializableInterface.Cache.InterfaceGuid;
+end;
+
+function _New_ISerializable(Rtti: TRttiCustom): pointer;
+begin
+  result := TInterfacedSerializableClass(Rtti.Cache.SerializableClass).Create(nil);
+  TInterfacedSerializable(result).fRefCount := 1; // inlined GetInterface()
+  inc(PByte(result), Rtti.Cache.SerializableInterfaceEntryOffset);
+end;
+
+class procedure TInterfacedSerializable.NewInterface(out Obj);
+begin
+  pointer(Obj) := _New_ISerializable(SerializableInterface);
+end;
+
+class function TInterfacedSerializable.RegisterToRtti(
+  InterfaceInfo: PRttiInfo): TRttiJson;
+var
+  ent: PInterfaceEntry;
+begin
+  ent := nil;
+  if (self <> nil) and
+     InterfaceInfo^.InterfaceImplements(ISerializable) then
+    ent := GetInterfaceEntry(InterfaceInfo^.InterfaceGuid^); // resolve TGuid
+  if (ent = nil) or
+     not InterfaceEntryIsStandard(ent) then
+    raise ERttiException.CreateUtf8('Unexpected %.RegisterToRtti(%)',
+      [self, InterfaceInfo^.Name^]);
+  result := Rtti.RegisterType(InterfaceInfo) as TRttiJson;
+  result.fCache.SerializableClass := self;
+  result.fCache.SerializableInterfaceEntryOffset := ent^.IOffset; // get once
+  TOnRttiJsonRead(result.fJsonReader) := JL;
+  TOnRttiJsonWrite(result.fJsonWriter) := JS;
+  result.SetParserType(result.Parser, result.ParserComplex); // needed
+  result.fNewInstance := @_New_ISerializable;
+  TRttiJson(Rtti.RegisterClass(self)).fCache.SerializableInterface := result;
+end;
+
+procedure TInterfacedSerializable.SetJson(const value: RawUtf8);
+var
+  tmp: TSynTempBuffer;
+  ctx: TJsonParserContext;
+begin
+  tmp.Init(value);
+  try
+    ctx.InitParser(tmp.buf, SerializableInterface, [], nil, nil, nil);
+    FromJson(ctx);
+  finally
+    tmp.Done;
+  end;
+end;
+
+class procedure TInterfacedSerializable.JS(W: TJsonWriter; data: pointer;
+  options: TTextWriterWriteObjectOptions);
+begin
+  data := PPointer(data)^;
+  if data = nil then
+    W.AddNull // avoid GPF if ISerializable = nil
+  else
+    ISerializable(data).ToJson(W, options);
+end;
+
+class procedure TInterfacedSerializable.JL(var context: TJsonParserContext;
+  data: pointer);
+var
+  o: TInterfacedSerializable;
+  i: ^ISerializable absolute data;
+begin
+  if not Assigned(i^) then
+  begin // inlined Create + GetInterface()
+    o := Create(context.CustomVariant);
+    o.fRefCount := 1;
+    inc(PByte(o), context.Info.Cache.SerializableInterfaceEntryOffset);
+    PPointer(data)^ := o;
+  end;
+  i^.FromJson(context)
+end;
+
+function TInterfacedSerializable.GetJson: RawUtf8;
+begin
+  result := ToJson(jsonCompact, []);
+end;
+
+function TInterfacedSerializable.ToJson(format: TTextWriterJsonFormat;
+  options: TTextWriterWriteObjectOptions): RawUtf8;
+var
+  W: TJsonWriter;
+  temp: TTextWriterStackBuffer;
+begin
+  W := TJsonWriter.CreateOwnedStream(temp);
+  try
+    ToJson(W, options);
+    W.SetText(result, Format);
+  finally
+    W.Free;
+  end;
+end;
+
+function TInterfacedSerializable.ToString(format: TTextWriterJsonFormat;
+  options: TTextWriterWriteObjectOptions): string;
+begin
+  Utf8ToStringVar(ToJson(format, options), result);
+end;
+
+
+{ TInterfacedSerializableAutoCreateFields }
+
+constructor TInterfacedSerializableAutoCreateFields.Create(
+  options: PDocVariantOptions);
+begin
+  fRttiJson := AutoCreateFields(self);
+end;
+
+destructor TInterfacedSerializableAutoCreateFields.Destroy;
+begin
+  AutoDestroyFields(self, fRttiJson);
+  inherited Destroy;
+end;
+
+procedure TInterfacedSerializableAutoCreateFields.ToJson(W: TJsonWriter;
+  options: TTextWriterWriteObjectOptions);
+var
+  ctx: TJsonSaveContext;
+begin
+  ctx.W := W;
+  ctx.Info := fRttiJson;
+  ctx.Options := options + fRttiJson.IncludeWriteOptions;
+  _JS_RttiCustom(@self, ctx); // all done via known RTTI
+end;
+
+procedure TInterfacedSerializableAutoCreateFields.FromJson(
+  var context: TJsonParserContext);
+begin
+  context.Info := fRttiJson; // from interface RTTI to class RTTI
+  _JL_RttiCustom(@self, context);
+end;
+
+
+{ TCollectionItemAutoCreateFields }
+
+constructor TCollectionItemAutoCreateFields.Create(Collection: TCollection);
+begin
+  AutoCreateFields(self);
+  inherited Create(Collection);
+end;
+
+destructor TCollectionItemAutoCreateFields.Destroy;
+begin
+  AutoDestroyFields(self);
+  inherited Destroy;
+end;
+
+
+{ TSynJsonFileSettings }
+
+function TSynJsonFileSettings.AfterLoad: boolean;
+begin
+  result := true; // success
+end;
+
+function TSynJsonFileSettings.LoadFromJson(const aJson: RawUtf8;
+  const aSectionName: RawUtf8): boolean;
+begin
+  if fsoReadIni in fSettingsOptions then
+  begin
+    fSectionName := aSectionName;
+    result := false;
+  end
+  else
+    result := JsonSettingsToObject(aJson, self);
+  if not result then
+  begin
+    result := IniToObject(aJson, self, aSectionName, @JSON_[mFastFloat]);
+    if result then
+    begin
+      fSectionName := aSectionName;
+      include(fSettingsOptions, fsoWriteIni); // save back as INI
+    end;
+  end;
+  if result then
+    result := AfterLoad;
+end;
+
+function TSynJsonFileSettings.LoadFromFile(const aFileName: TFileName;
+  const aSectionName: RawUtf8): boolean;
+begin
+  fFileName := aFileName;
+  fInitialJsonContent := RawUtf8FromFile(aFileName); // may detect BOM
+  result := LoadFromJson(fInitialJsonContent, aSectionName);
+  if not result then
+    fInitialJsonContent := ''; // file was neither valid JSON nor INI: ignore
+end;
+
+function TSynJsonFileSettings.FolderName: TFileName;
+begin
+  if self = nil then
+    result := ''
+  else
+    result := ExtractFilePath(fFileName);
+end;
+
+procedure TSynJsonFileSettings.SaveIfNeeded;
+var
+  saved: RawUtf8;
+begin
+  if (self = nil) or
+     (fFileName = '') or
+     (fsoDisableSaveIfNeeded in fSettingsOptions) then
+    exit;
+  if fsoWriteIni in fSettingsOptions then
+    saved := ObjectToIni(self, fSectionName)
+  else
+    saved := ObjectToJson(self, SETTINGS_WRITEOPTIONS);
+  if saved = fInitialJsonContent then
+    exit;
+  FileFromString(saved, fFileName);
+  fInitialJsonContent := saved;
+end;
+
+
+type // local type definitions for their own RTTI to be found by name
+  RawUtf8 = type Utf8String;
+  {$ifdef CPU64}
+  PtrInt  = type Int64;
+  PtrUInt = type QWord;
+  {$else}
+  PtrInt  = type integer;
+  PtrUInt = type cardinal;
+  {$endif CPU64}
+
+procedure InitializeUnit;
+var
+  i: integer; // not PtrInt since has just been overriden
+  c: AnsiChar;
+  {$ifdef FPC} dummy: RawUtf8; {$endif}
+begin
+  // branchless JSON escaping - JSON_ESCAPE_NONE=0 if no JSON escape needed
+  JSON_ESCAPE[0]   := JSON_ESCAPE_ENDINGZERO; // 1 for #0 end of input
+  for i := 1 to 31 do
+    JSON_ESCAPE[i] := JSON_ESCAPE_UNICODEHEX; // 2 to escape #1..#31 as \u00xx
+  JSON_ESCAPE[8]   := ord('b');  // others contain the escaped character
+  JSON_ESCAPE[9]   := ord('t');
+  JSON_ESCAPE[10]  := ord('n');
+  JSON_ESCAPE[12]  := ord('f');
+  JSON_ESCAPE[13]  := ord('r');
+  JSON_ESCAPE[ord('\')] := ord('\');
+  JSON_ESCAPE[ord('"')] := ord('"');
+  for c := #32 to #127 do
+    JSON_UNESCAPE[c] := c;
+  JSON_UNESCAPE['b'] := #8;
+  JSON_UNESCAPE['t'] := #9;
+  JSON_UNESCAPE['n'] := #10;
+  JSON_UNESCAPE['f'] := #12;
+  JSON_UNESCAPE['r'] := #13;
+  JSON_UNESCAPE['u'] := JSON_UNESCAPE_UTF16;
+  for c := low(c) to high(c) do
+  begin
+    if c in [#0, ',', ']', '}', ':'] then
+      include(JSON_CHARS[c], jcEndOfJsonFieldOr0);
+    if c in [#0, ',', ']', '}'] then
+      include(JSON_CHARS[c], jcEndOfJsonFieldNotName);
+    if c in [#0, #9, #10, #13, ' ',  ',', '}', ']'] then
+      include(JSON_CHARS[c], jcEndOfJsonValueField);
+    if c in [#0, '"', '\'] then
+      include(JSON_CHARS[c], jcJsonStringMarker);
+    if c in ['-', '0'..'9'] then
+    begin
+      include(JSON_CHARS[c], jcDigitFirstChar);
+      JSON_TOKENS[c] := jtFirstDigit;
+    end;
+    if c in ['-', '+', '0'..'9', '.', 'E', 'e'] then
+      include(JSON_CHARS[c], jcDigitFloatChar);
+    if c in ['_', '0'..'9', 'a'..'z', 'A'..'Z', '$'] then
+      include(JSON_CHARS[c], jcJsonIdentifierFirstChar);
+    if c in ['_', '0'..'9', 'a'..'z', 'A'..'Z', '.', '[', ']'] then
+      include(JSON_CHARS[c], jcJsonIdentifier);
+    if c in ['_', 'a'..'z', 'A'..'Z', '$'] then
+      // exclude '0'..'9' as already in jcDigitFirstChar
+      JSON_TOKENS[c] := jtIdentifierFirstChar;
+  end;
+  JSON_TOKENS[#0 ]  := jtEndOfBuffer;
+  JSON_TOKENS['{']  := jtObjectStart;
+  JSON_TOKENS['}']  := jtObjectStop;
+  JSON_TOKENS['[']  := jtArrayStart;
+  JSON_TOKENS[']']  := jtArrayStop;
+  JSON_TOKENS[':']  := jtAssign;
+  JSON_TOKENS['=']  := jtEqual;
+  JSON_TOKENS[',']  := jtComma;
+  JSON_TOKENS[''''] := jtSingleQuote;
+  JSON_TOKENS['"']  := jtDoubleQuote;
+  JSON_TOKENS['t']  := jtTrueFirstChar;
+  JSON_TOKENS['f']  := jtFalseFirstChar;
+  JSON_TOKENS['n']  := jtNullFirstChar;
+  JSON_TOKENS['/']  := jtSlash;
+  // initialize JSON serialization
+  Rtti.GlobalClass := TRttiJson; // will ensure Rtti.Count = 0
+  // now we can register some local type alias to be found by name or ASAP
+  Rtti.RegisterTypes([TypeInfo(RawUtf8), TypeInfo(PtrInt), TypeInfo(PtrUInt),
+    TypeInfo(TRawUtf8DynArray), TypeInfo(TIntegerDynArray)]);
+  // prepare some JSON wrappers
+  GetDataFromJson := _GetDataFromJson;
+  InitializeVariantsJson; // from mormot.core.variants
+  {$ifdef FPC} // we need to call it once so that it is linked to the executable
+  JsonForDebug(nil, dummy, dummy);
+  {$endif FPC}
+end;
+
+
+initialization
+  InitializeUnit;
+  DefaultJsonWriter := TJsonWriter;
+
+end.
+
diff --git a/lib/dmustache/mormot.core.mustache.pas b/lib/dmustache/mormot.core.mustache.pas
new file mode 100644
index 00000000..945dc7d8
--- /dev/null
+++ b/lib/dmustache/mormot.core.mustache.pas
@@ -0,0 +1,2563 @@
+/// Framework Core {{mustache}} Templates Renderer
+// - this unit is a part of the Open Source Synopse mORMot framework 2,
+// licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+unit mormot.core.mustache;
+
+{
+  *****************************************************************************
+
+   Logic-Less Mustache Templates Rendering
+   - Mustache Execution Data Context Types
+   - TSynMustache Template Processing
+
+  *****************************************************************************
+}
+
+interface
+
+{$I mormot.defines.inc}
+
+uses
+  classes,
+  sysutils,
+  variants,
+  mormot.core.base,
+  mormot.core.os,
+  mormot.core.unicode,
+  mormot.core.text,
+  mormot.core.search, // for TSynMustache.Match helper
+  mormot.core.buffers,
+  mormot.core.datetime,
+  mormot.core.rtti,
+  mormot.core.json,
+  mormot.core.data,
+  mormot.core.variants;
+
+
+{ ************ Mustache Execution Data Context Types }
+
+type
+  /// exception raised during process of a {{mustache}} template
+  ESynMustache = class(ESynException);
+
+  /// identify the {{mustache}} tag kind
+  // - mtVariable if the tag is a variable - e.g. {{myValue}} - or an Expression
+  // Helper - e.g. {{helperName valueName}}
+  // - mtVariableUnescape, mtVariableUnescapeAmp to unescape the variable HTML - e.g.
+  // {{{myRawValue}}} or {{& name}}
+  // - mtSection and mtInvertedSection for sections beginning - e.g.
+  // {{#person}} or {{^person}}
+  // - mtSectionEnd for sections ending - e.g. {{/person}}
+  // - mtComment for comments - e.g. {{! ignore me}}
+  // - mtPartial for partials - e.g. {{> next_more}}
+  // - mtSetPartial for setting an internal partial - e.g.
+  // {{=}} -
+  // Warning: current implementation only supports two character delimiters
+  // - mtTranslate for content i18n via a callback - e.g. {{"English text}}
+  // - mtText for all text that appears outside a symbol
+  TSynMustacheTagKind = (
+    mtVariable,
+    mtVariableUnescape,
+    mtVariableUnescapeAmp,
+    mtSection,
+    mtInvertedSection,
+    mtSectionEnd,
+    mtComment,
+    mtPartial,
+    mtSetPartial,
+    mtSetDelimiter,
+    mtTranslate,
+    mtText);
+
+  /// store a {{mustache}} tag
+  TSynMustacheTag = record
+    /// points to the mtText buffer start
+    // - main template's text is not allocated as a separate string during
+    // parsing, but will rather be copied directly from the template memory
+    TextStart: PUtf8Char;
+    /// stores the mtText buffer length
+    TextLen: integer;
+    /// the index in Tags[] of the other end of this section (16-bit)
+    // - either the index of mtSectionEnd for mtSection/mtInvertedSection
+    // - or the index of mtSection/mtInvertedSection for mtSectionEnd
+    SectionOppositeIndex: SmallInt;
+    /// the kind of the tag
+    Kind: TSynMustacheTagKind;
+    /// if the Value has an included ' ' within, i.e. could be an helper
+    // - equals PosExChar(' ', Value)
+    ValueSpace: byte;
+    /// the tag content, excluding trailing {{ }} and corresponding symbol
+    // - is not set for mtText nor mtSetDelimiter
+    Value: RawUtf8;
+  end;
+
+  /// store all {{mustache}} tags of a given template
+  TSynMustacheTagDynArray = array of TSynMustacheTag;
+
+  /// states the section content according to a given value
+  // - msNothing for false values or empty lists
+  // - msSingle for non-false values but not a list
+  // - msSinglePseudo is for *-first *-last *-odd and helper values
+  // - msList for non-empty lists
+  TSynMustacheSectionType = (
+    msNothing,
+    msSingle,
+    msSinglePseudo,
+    msList);
+
+  TSynMustache = class;
+
+  /// callback signature used to process an Expression Helper variable
+  // - i.e. {{helperName value}} tags
+  // - returned value will be used to process as replacement of a single {{tag}}
+  TSynMustacheHelperEvent =
+    procedure(const Value: variant; out Result: variant) of object;
+
+  /// used to store a registered Expression Helper implementation
+  TSynMustacheHelper = record
+    /// the Expression Helper name
+    Name: RawUtf8;
+    /// the corresponding callback to process the tag
+    Event: TSynMustacheHelperEvent;
+  end;
+
+  /// used to store all registered Expression Helpers
+  // - i.e. {{helperName value}} tags
+  // - use TSynMustache.HelperAdd/HelperDelete class methods to manage the list
+  // or retrieve standard helpers via TSynMustache.HelpersGetStandardList
+  TSynMustacheHelpers = array of TSynMustacheHelper;
+
+  TSynMustachePartials = class;
+
+  /// handle {{mustache}} template rendering context, i.e. all values
+  // - this abstract class should not be used directly, but rather any
+  // other overridden class
+  TSynMustacheContext = class
+  protected
+    fContextCount: integer;
+    fEscapeInvert: boolean;
+    fOwnWriter: boolean;
+    fGetVarDataFromContextNeedsFree: boolean;
+    fPathDelim: AnsiChar;
+    fWriter: TJsonWriter;
+    fHelpers: TSynMustacheHelpers;
+    fPartials: TSynMustachePartials;
+    fTempProcessHelper: TVariantDynArray;
+    fOnStringTranslate: TOnStringTranslate;
+    fOwner: TSynMustache;
+    fReuse: TLightLock;
+    // some variant support is needed for the helpers
+    function ProcessHelper(const ValueName: RawUtf8; space, helper: PtrInt;
+      var Value: TVarData; OwnValue: PPVarData): TSynMustacheSectionType; virtual;
+    function GetHelperFromContext(ValueSpace: integer; const ValueName: RawUtf8;
+      var Value: TVarData; OwnValue: PPVarData): TSynMustacheSectionType;
+    procedure TranslateBlock(Text: PUtf8Char; TextLen: Integer); virtual;
+    function GetVariantFromContext(const ValueName: RawUtf8): variant;
+    procedure PopContext;
+    procedure AppendVariant(const Value: variant; UnEscape: boolean);
+    // inherited class should override those methods
+    function GotoNextListItem: boolean;
+      virtual; abstract;
+    function GetVarDataFromContext(ValueSpace: integer; const ValueName: RawUtf8;
+      var Value: TVarData): TSynMustacheSectionType; virtual; abstract;
+    procedure AppendValue(ValueSpace: integer; const ValueName: RawUtf8;
+      UnEscape: boolean); virtual; abstract;
+    function AppendSection(ValueSpace: integer;
+      const ValueName: RawUtf8): TSynMustacheSectionType; virtual; abstract;
+  public
+    /// initialize the rendering context for the given text writer
+    constructor Create(Owner: TSynMustache; WR: TJsonWriter; OwnWR: boolean);
+    /// release this rendering context instance
+    destructor Destroy; override;
+    /// allow to reuse this Mustache template rendering context
+    procedure CancelAll;
+
+    /// the registered Expression Helpers, to handle {{helperName value}} tags
+    // - use TSynMustache.HelperAdd/HelperDelete class methods to manage the list
+    // or retrieve standard helpers via TSynMustache.HelpersGetStandardList
+    property Helpers: TSynMustacheHelpers
+      read fHelpers write fHelpers;
+    /// access to the custom Partials associated with this execution context
+    property Partials: TSynMustachePartials
+      read fPartials write fPartials;
+    /// access to the {{"English text}} translation callback
+    property OnStringTranslate: TOnStringTranslate
+      read fOnStringTranslate write fOnStringTranslate;
+    /// read-only access to the associated text writer instance
+    property Writer: TJsonWriter
+      read fWriter;
+    /// invert the HTML characters escaping process
+    // - by default, {{value}} will escape value chars, and {{{value}} won't
+    // - set this property to true to force {{value}} NOT to escape HTML chars
+    // and {{{value}} escaping chars (may be useful e.g. for code generation)
+    property EscapeInvert: boolean
+      read fEscapeInvert write fEscapeInvert;
+    /// the path delimited for getting a value
+    // - equals '.' by default
+    property PathDelim: AnsiChar
+      read fPathDelim write fPathDelim;
+  end;
+
+  /// handle {{mustache}} template rendering context from a custom variant
+  // - the context is given via a custom variant type implementing
+  // TSynInvokeableVariantType.Lookup, e.g. TDocVariant or TSMVariant
+  TSynMustacheContextVariant = class(TSynMustacheContext)
+  protected
+    fContext: array of record
+      Document: TVarData;
+      DocumentType: TSynInvokeableVariantType;
+      ListCount: integer;
+      ListCurrent: integer;
+      ListCurrentDocument: TVarData;
+      ListCurrentDocumentType: TSynInvokeableVariantType;
+    end;
+    procedure PushContext(const aDoc: TVarData);
+    function GotoNextListItem: boolean; override;
+    function GetVarDataFromContext(ValueSpace: integer; const ValueName: RawUtf8;
+      var Value: TVarData): TSynMustacheSectionType; override;
+    procedure AppendValue(ValueSpace: integer; const ValueName: RawUtf8;
+      UnEscape: boolean); override;
+    function AppendSection(ValueSpace: integer;
+      const ValueName: RawUtf8): TSynMustacheSectionType; override;
+  public
+    /// initialize the context from a custom variant document
+    // - note that the aDocument instance shall be available during all
+    // lifetime of this TSynMustacheContextVariant instance
+    // - you should not use this constructor directly, but the
+    // corresponding TSynMustache.Render*() methods
+    constructor Create(Owner: TSynMustache; WR: TJsonWriter;
+      SectionMaxCount: integer; const aDocument: variant; OwnWriter: boolean);
+    /// render this reusable rendering context
+    // - wrap PushContext + Owner.RenderContext + Writer.SetText + CancelAll
+    function Render(const aDoc: variant): RawUtf8;
+  end;
+
+  TSynMustacheContextData = class;
+
+  /// TSynMustacheContextData.OnGetGlobalData callback signature
+  // - Data and Rtti are filled with the {{.}} current context at call
+  // - implementation should lookup ValueName and set Data/Rtti with result=true
+  // - warning: the returned Data pointer should remain active until the
+  // Mustache rendering task is completed
+  TOnGetGlobalData = function(Sender: TSynMustacheContextData;
+    const ValueName: RawUtf8; var Data: pointer; var Rtti: TRttiCustom): boolean;
+
+  /// handle {{mustache}} template rendering context from RTTI and variables
+  // - the context is given via our RTTI information
+  // - performance is somewhat higher than TSynMustacheContextVariant because
+  // less computation is needed for filling transient TDocVariant instances
+  TSynMustacheContextData = class(TSynMustacheContext)
+  protected
+    fContext: array of record
+      Data: pointer;
+      Info: TRttiCustom;
+      ListCount: integer;
+      ListCurrent: integer;
+      Temp: TRttiVarData;
+    end;
+    fOnGetGlobalData: TOnGetGlobalData;
+    procedure PushContext(Value: pointer; Rtti: TRttiCustom);
+    function GotoNextListItem: boolean; override;
+    function GetDataFromContext(const ValueName: RawUtf8;
+      out rc: TRttiCustom; out d: pointer): boolean;
+    function GetVarDataFromContext(ValueSpace: integer; const ValueName: RawUtf8;
+      var Value: TVarData): TSynMustacheSectionType; override;
+    procedure AppendValue(ValueSpace: integer; const ValueName: RawUtf8;
+      UnEscape: boolean); override;
+    function AppendSection(ValueSpace: integer;
+      const ValueName: RawUtf8): TSynMustacheSectionType; override;
+  public
+    /// initialize the context from a document stored in a local variable
+    // - note that the variable instance shall be available during all
+    // lifetime of this TSynMustacheContextData instance
+    // - you should not use this constructor directly, but the
+    // corresponding TSynMustache.RenderData() methods
+    constructor Create(Owner: TSynMustache; WR: TJsonWriter;
+      SectionMaxCount: integer; Value: pointer; ValueRtti: TRttiCustom;
+      OwnWriter: boolean);
+    /// render this reusable rendering context
+    // - wrap PushContext + Owner.RenderContext + Writer.SetText + CancelAll
+    function RenderArray(const arr: TDynArray): RawUtf8;
+    /// render this reusable rendering context
+    // - wrap PushContext + Owner.RenderContext + Writer.SetText + CancelAll
+    function RenderRtti(Value: pointer; Rtti: TRttiCustom): RawUtf8;
+    /// callback to get data at runtime from a global name
+    // - when the Value variable provided to TSynMustache.RenderData is not enough
+    property OnGetGlobalData: TOnGetGlobalData
+      read fOnGetGlobalData write fOnGetGlobalData;
+  end;
+
+  /// maintain a list of {{mustache}} partials
+  // - this list of partials template could be supplied to TSynMustache.Render()
+  // method, to render {{>partials}} as expected
+  // - using a dedicated class allows to share the partials between execution
+  // context, without recurring to non SOLID global variables
+  // - you may also define "internal" partials, e.g. {{partialName}} template
+    // - returns the parsed template
+    function Add(const aName,aTemplate: RawUtf8): TSynMustache; overload;
+    /// register a {{>partialName}} template
+    // - returns the parsed template
+    function Add(const aName: RawUtf8;
+      aTemplateStart, aTemplateEnd: PUtf8Char): TSynMustache; overload;
+    /// search some text withing the {{mustache}} partial
+    function FoundInTemplate(const text: RawUtf8): PtrInt;
+    /// delete the partials
+    destructor Destroy; override;
+    /// low-level access to the internal partials list
+    property List: TRawUtf8List
+      read fList;
+  end;
+
+
+
+{ ************ TSynMustache Template Processing }
+
+  /// handles one {{mustache}} pre-rendered template
+  // - once parsed, a template will be stored in this class instance, to be
+  // rendered lated via the Render() method
+  // - you can use the Parse() class function to maintain a shared cache of
+  // parsed templates
+  // - implements all official mustache specifications, and some extensions
+  // - handles {{.}} pseudo-variable for the current context object (very
+  // handy when looping through a simple list, for instance)
+  // - handles {{-index}} pseudo-variable for the current context array index
+  // (1-based value) so that e.g.
+  // "My favorite things:\n{{#things}}{{-index}}. {{.}}\n{{/things}}"
+  // over {things:["Peanut butter", "Pen spinning", "Handstands"]} renders as
+  // "My favorite things:\n1. Peanut butter\n2. Pen spinning\n3. Handstands\n"
+  // - you could use {{-index0}} for 0-based index value
+  // - handles -first -last and -odd  pseudo-section keys, e.g.
+  // "{{#things}}{{^-first}}, {{/-first}}{{.}}{{/things}}"
+  // over {things:["one", "two", "three"]} renders as 'one, two, three'
+  // - allows inlined partial templates , to be defined e.g. as
+  // {{ <= >= <> operators over two values:
+    // $ {{#if .,"=",123}}  {{#if Total,">",1000}}  {{#if info,"<>",""}}
+    // which may be shortened as such:
+    // $ {{#if .=123}}  {{#if Total>1000}}  {{#if info<>""}}
+    class function HelpersGetStandardList: TSynMustacheHelpers; overload;
+    /// returns a list of most used static Expression Helpers, adding some
+    // custom callbacks
+    // - is just a wrapper around HelpersGetStandardList and HelperAdd()
+    class function HelpersGetStandardList(const aNames: array of RawUtf8;
+      const aEvents: array of TSynMustacheHelperEvent): TSynMustacheHelpers; overload;
+
+    /// renders the {{mustache}} template into a destination text buffer
+    // - the context is given via our abstract TSynMustacheContext wrapper
+    // - the rendering extended in fTags[] is supplied as parameters
+    // - you can specify a list of partials via TSynMustachePartials.CreateOwned
+    procedure RenderContext(Context: TSynMustacheContext;
+      TagStart, TagEnd: integer);
+
+    /// renders the {{mustache}} template from a variant defined context
+    // - the context is given via a custom variant type implementing
+    // TSynInvokeableVariantType.Lookup, e.g. TDocVariant or TSMVariant
+    // - you can specify a list of partials via TSynMustachePartials.CreateOwned,
+    // a list of Expression Helpers, or a custom {{"English text}} callback
+    // - can be used e.g. via a TDocVariant:
+    // !var
+    // !  mustache := TSynMustache;
+    // !  doc: variant;
+    // !  html: RawUtf8;
+    // !begin
+    // !  mustache := TSynMustache.Parse(
+    // !    'Hello {{name}}'#13#10'You have just won {{value}} dollars!');
+    // !  TDocVariant.New(doc);
+    // !  doc.name := 'Chris';
+    // !  doc.value := 10000;
+    // !  html := mustache.Render(doc);
+    // !  // here html='Hello Chris'#13#10'You have just won 10000 dollars!'
+    // - you can also retrieve the context from an ORM query:
+    // ! dummy := TSynMustache.Parse(
+    // !   '{{#items}}'#13#10'{{Int}}={{Test}}'#13#10'{{/items}}').Render(
+    // !   aClient.RetrieveDocVariantArray(TOrmTest, 'items', 'Int,Test'));
+    // - set EscapeInvert = true to force {{value}} NOT to escape HTML chars
+    // and {{{value}} escaping chars (may be useful e.g. for code generation)
+    function Render(const Context: variant;
+      Partials: TSynMustachePartials = nil;
+      const Helpers: TSynMustacheHelpers = nil;
+      const OnTranslate: TOnStringTranslate = nil;
+      EscapeInvert: boolean = false): RawUtf8;
+    /// renders the {{mustache}} template from JSON defined context
+    // - the context is given via a JSON object, defined from UTF-8 buffer
+    // - you can specify a list of partials via TSynMustachePartials.CreateOwned,
+    // a list of Expression Helpers, or a custom {{"English text}} callback
+    // - is just a wrapper around Render(_JsonFast())
+    // - you can write e.g. with the extended JSON syntax:
+    // ! html := mustache.RenderJson('{things:["one", "two", "three"]}');
+    // - set EscapeInvert = true to force {{value}} NOT to escape HTML chars
+    // and {{{value}} escaping chars (may be useful e.g. for code generation)
+    function RenderJson(const Json: RawUtf8;
+      Partials: TSynMustachePartials = nil;
+      const Helpers: TSynMustacheHelpers = nil;
+      const OnTranslate: TOnStringTranslate = nil;
+      EscapeInvert: boolean = false): RawUtf8; overload;
+    /// renders the {{mustache}} template from JSON defined context
+    // - the context is given via a JSON object, defined with parameters
+    // - you can specify a list of partials via TSynMustachePartials.CreateOwned,
+    // a list of Expression Helpers, or a custom {{"English text}} callback
+    // - is just a wrapper around Render(_JsonFastFmt())
+    // - you can write e.g. with the extended JSON syntax:
+    // !   html := mustache.RenderJson('{name:?,value:?}',[],['Chris',10000]);
+    // - set EscapeInvert = true to force {{value}} NOT to escape HTML chars
+    // and {{{value}} escaping chars (may be useful e.g. for code generation)
+    function RenderJson(const Json: RawUtf8;
+      const Args, Params: array of const;
+      Partials: TSynMustachePartials = nil;
+      const Helpers: TSynMustacheHelpers = nil;
+      const OnTranslate: TOnStringTranslate = nil;
+      EscapeInvert: boolean = false): RawUtf8; overload;
+
+    /// renders the {{mustache}} template from a variable defined context
+    // - the context is given via a local variable and RTTI, which may be
+    // a record, a class, a variant, or a dynamic array instance
+    // - you can specify a list of partials via TSynMustachePartials.CreateOwned,
+    // a list of Expression Helpers, or a custom {{"English text}} callback
+    // - set EscapeInvert = true to force {{value}} NOT to escape HTML chars
+    // and {{{value}} escaping chars (may be useful e.g. for code generation)
+    // - just redirects to the RenderDataRtti() method
+    function RenderData(const Value; ValueTypeInfo: PRttiInfo;
+      const OnGetData: TOnGetGlobalData = nil;
+      Partials: TSynMustachePartials = nil;
+      const Helpers: TSynMustacheHelpers = nil;
+      const OnTranslate: TOnStringTranslate = nil;
+      EscapeInvert: boolean = false): RawUtf8;
+    /// renders the {{mustache}} template from a dynamic array variable
+    // - the supplied array is available within a {{.}} main section
+    // - you can specify a list of partials via TSynMustachePartials.CreateOwned,
+    // a list of Expression Helpers, or a custom {{"English text}} callback
+    // - set EscapeInvert = true to force {{value}} NOT to escape HTML chars
+    // and {{{value}} escaping chars (may be useful e.g. for code generation)
+    // - just redirects to the RenderDataRtti() method
+    function RenderDataArray(const Value: TDynArray;
+      const OnGetData: TOnGetGlobalData = nil;
+      Partials: TSynMustachePartials = nil;
+      const Helpers: TSynMustacheHelpers = nil;
+      const OnTranslate: TOnStringTranslate = nil;
+      EscapeInvert: boolean = false): RawUtf8;
+    /// renders the {{mustache}} template from a variable and its RTTI
+    // - the context is given via a local variable and RTTI, which may be
+    // a record, a class, a variant, or a dynamic array instance
+    // - you can specify a list of partials via TSynMustachePartials.CreateOwned,
+    // a list of Expression Helpers, or a custom {{"English text}} callback
+    // - set EscapeInvert = true to force {{value}} NOT to escape HTML chars
+    // and {{{value}} escaping chars (may be useful e.g. for code generation)
+    function RenderDataRtti(Value: pointer; ValueRtti: TRttiCustom;
+      const OnGetData: TOnGetGlobalData = nil;
+      Partials: TSynMustachePartials = nil;
+      const Helpers: TSynMustacheHelpers = nil;
+      const OnTranslate: TOnStringTranslate = nil;
+      EscapeInvert: boolean = false): RawUtf8;
+
+    /// read-only access to the raw UTF-8 {{mustache}} template content
+    property Template: RawUtf8
+      read fTemplate;
+    /// read-only access to the internal representation of the template
+    property Tags: TSynMustacheTagDynArray
+      read fTags;
+    /// the maximum possible number of nested contexts
+    // - i.e. the depth of nested {{#....}} {{/....}} sections
+    property SectionMaxCount: Integer
+      read fSectionMaxCount;
+  end;
+
+
+const
+  /// Mustache-friendly JSON Serialization Options
+  // - as used e.g. from mormot.rest.mvc Data Context from Cookies
+  TEXTWRITEROPTIONS_MUSTACHE =
+     [twoForceJsonExtended,
+      twoEnumSetsAsBooleanInRecord,
+      twoTrimLeftEnumSets];
+
+  /// this constant can be used to define as JSON a tag value
+  NULL_OR_TRUE: array[boolean] of RawUtf8 = (
+    'null', 'true');
+
+  /// this constant can be used to define as JSON a tag value as separator
+  NULL_OR_COMMA: array[boolean] of RawUtf8 = (
+    'null', '","');
+
+
+
+implementation
+
+{ ************ Mustache Execution Data Context Types }
+
+{ TSynMustacheContext }
+
+constructor TSynMustacheContext.Create(Owner: TSynMustache;
+  WR: TJsonWriter; OwnWR: boolean);
+begin
+  fOwner := Owner;
+  fOwnWriter := OwnWR;
+  fWriter := WR;
+  fPathDelim := '.';
+end;
+
+destructor TSynMustacheContext.Destroy;
+begin
+  inherited Destroy;
+  if fOwnWriter then
+    fWriter.Free;
+end;
+
+procedure TSynMustacheContext.PopContext;
+begin
+  if fContextCount > 1 then
+    dec(fContextCount);
+end;
+
+procedure TSynMustacheContext.TranslateBlock(Text: PUtf8Char; TextLen: Integer);
+var
+  s: string;
+begin
+  if Assigned(OnStringTranslate) then
+  begin
+    Utf8DecodeToString(Text, TextLen, s);
+    OnStringTranslate(s);
+    fWriter.AddNoJsonEscapeString(s);
+  end
+  else
+    fWriter.AddNoJsonEscape(Text, TextLen);
+end;
+
+procedure TSynMustacheContext.AppendVariant(
+  const Value: variant; UnEscape: boolean);
+var
+  tmp: TTempUtf8;
+  wasString: boolean;
+begin
+  if fEscapeInvert then
+    UnEscape := not UnEscape;
+  if TVarData(Value).VType > varNull then
+    if Unescape or
+       VarIsNumeric(Value) then
+      // avoid RawUtf8 conversion for plain numbers or if no HTML escaping
+      fWriter.AddVariant(Value, twNone)
+    else
+    begin
+      VariantToTempUtf8(Value, tmp, wasString);
+      fWriter.AddHtmlEscape(tmp.Text, tmp.Len);
+      if tmp.TempRawUtf8 <> nil then
+        FastAssignNew(tmp.TempRawUtf8);
+    end;
+end;
+
+function TSynMustacheContext.GetVariantFromContext(
+  const ValueName: RawUtf8): variant;
+var
+  tmp: TVarData;
+begin
+  if (ValueName = '') or
+     (ValueName[1] in ['-', '0'..'9', '"', '{', '[']) or
+     (ValueName = 'true') or
+     (ValueName = 'false') or
+     (ValueName = 'null') then
+    VariantLoadJson(result, ValueName, @JSON_[mFast])
+  else if fGetVarDataFromContextNeedsFree then
+  begin
+    if TRttiVarData(result).VType <> varEmpty then
+      VarClearProc(TVarData(result));
+    GetVarDataFromContext(-1, ValueName, TVarData(result)); // set directly
+  end
+  else
+  begin
+    GetVarDataFromContext(-1, ValueName, tmp); // get TVarData content
+    SetVariantByValue(variant(tmp), result);   // assign/copy value
+  end;
+end;
+
+function TSynMustacheContext.ProcessHelper(const ValueName: RawUtf8;
+  space, helper: PtrInt; var Value: TVarData;
+  OwnValue: PPVarData): TSynMustacheSectionType;
+var
+  valnam: RawUtf8;
+  p: PUtf8Char;
+  val: TVarData;
+  valArr: TDocVariantData absolute val;
+  valFree, valFound: boolean;
+  names: TRawUtf8DynArray;
+  j, k, n: PtrInt;
+begin
+  valnam := Copy(ValueName, space + 1, maxInt);
+  TRttiVarData(val).VType := varEmpty;
+  valFree := fGetVarDataFromContextNeedsFree;
+  if valnam <> '' then
+  begin
+    if valnam = '.' then
+      GetVarDataFromContext(-1, valnam, val)
+    else if ((valnam <> '') and
+             (valnam[1] in ['1'..'9', '"', '{', '['])) or
+            (valnam = 'true') or
+            (valnam = 'false') or
+            (valnam = 'null') then
+    begin
+      // {{helper 123}} or {{helper "constant"}} or {{helper [1,2,3]}}
+      JsonToVariantInPlace(variant(val), pointer(valnam), JSON_FAST_FLOAT);
+      valFree := true;
+    end
+    else
+    begin
+      valFound := false;
+      for j := 1 to length(valnam) do
+        case valnam[j] of
+          ' ':
+            // allows {{helper1 helper2 value}} recursive calls
+            break;
+          ',':
+            begin
+              // {{helper value,123,"constant"}}
+              p := Pointer(valnam);
+              if j = 1 then
+                inc(p); // for {{helper ,"constant1","constant2",123}}
+              CsvToRawUtf8DynArray(p, names, ',', true);
+              // TODO: handle 123,"a,b,c"
+              valArr.InitFast;
+              for k := 0 to High(names) do
+                valArr.AddItem(GetVariantFromContext(names[k]));
+              valFound := true;
+              break;
+            end;
+          '<',
+          '>',
+          '=':
+            begin
+              // {{#if .=123}} -> {{#if .,"=",123}}
+              k := j + 1;
+              if valnam[k] in ['=', '>'] then
+                inc(k);
+              valArr.InitArray([
+                 GetVariantFromContext(Copy(valnam, 1, j - 1)),
+                 Copy(valnam, j, k - j),
+                 GetVariantFromContext(Copy(valnam, k, maxInt))],
+                JSON_FAST_FLOAT);
+              valFound := true;
+              break;
+            end;
+        end;
+      if valFound then
+        valFree := true
+      else
+        GetVarDataFromContext(-1, valnam, val);
+    end;
+  end;
+  // call helper
+  if OwnValue <> nil then
+  begin
+    // result Value is owned by fTempProcessHelper[]
+    n := fContextCount + 4;
+    if length(fTempProcessHelper) < n then
+      SetLength(fTempProcessHelper, n);
+    OwnValue^ := @fTempProcessHelper[fContextCount - 1];
+    Helpers[helper].Event(variant(val), variant(OwnValue^^));
+    Value := OwnValue^^;
+  end
+  else
+    Helpers[helper].Event(variant(val), variant(Value));
+  if valFree then
+    VarClearProc(val);
+  result := msSinglePseudo;
+end;
+
+function TSynMustacheContext.GetHelperFromContext(ValueSpace: integer;
+  const ValueName: RawUtf8; var Value: TVarData;
+  OwnValue: PPVarData): TSynMustacheSectionType;
+var
+  space, len, helper: PtrInt;
+begin
+  space := ValueSpace;
+  if space < 0 then
+    space := PosExChar(' ', ValueName);
+  if space > 1 then
+    len := space - 1
+  else
+  begin
+    space := length(ValueName);
+    len := space;
+  end;
+  helper := TSynMustache.HelperFind(Helpers, pointer(ValueName), len);
+  if helper >= 0 then
+    result := ProcessHelper(ValueName, space, helper, Value, OwnValue)
+  else
+    result := msNothing;
+end;
+
+procedure TSynMustacheContext.CancelAll;
+begin
+  fContextCount := 0;
+  fEscapeInvert := false;
+  fWriter.CancelAllAsNew;
+  if fTempProcessHelper <> nil then
+    VariantClearSeveral(pointer(fTempProcessHelper), length(fTempProcessHelper));
+  fReuse.UnLock;
+end;
+
+
+{ TSynMustacheContextVariant }
+
+constructor TSynMustacheContextVariant.Create(Owner: TSynMustache;
+  WR: TJsonWriter; SectionMaxCount: integer; const aDocument: variant;
+  OwnWriter: boolean);
+begin
+  inherited Create(Owner, WR, OwnWriter);
+  SetLength(fContext, SectionMaxCount + 4);
+  PushContext(TVarData(aDocument)); // weak copy
+end;
+
+function TSynMustacheContextVariant.Render(const aDoc: variant): RawUtf8;
+begin
+  PushContext(TVarData(aDoc));
+  fOwner.RenderContext(self, 0, high(fOwner.fTags));
+  Writer.SetText(result);
+  CancelAll;
+end;
+
+procedure TSynMustacheContextVariant.PushContext(const aDoc: TVarData);
+begin
+  if fContextCount >= length(fContext) then
+    // was roughtly set by SectionMaxCount
+    SetLength(fContext, fContextCount + 32);
+  with fContext[fContextCount] do
+  begin
+    Document := aDoc;
+    DocumentType := DocVariantType.FindSynVariantType(aDoc.VType);
+    ListCurrent := -1;
+    if DocumentType = nil then
+      ListCount := -1
+    else
+    begin
+      ListCount := DocumentType.IterateCount(aDoc, {GetObjectAsValues=}false);
+      if fContextCount = 0 then
+        ListCurrentDocument := aDoc; // allow {#.}...{/.} at first level
+    end;
+  end;
+  inc(fContextCount);
+end;
+
+function TSynMustacheContextVariant.GotoNextListItem: boolean;
+begin
+  result := false;
+  if fContextCount > 0 then
+    with fContext[fContextCount - 1] do
+    begin
+      ListCurrentDocument.VType := varEmpty;
+      ListCurrentDocumentType := nil;
+      inc(ListCurrent);
+      if ListCurrent >= ListCount then
+        exit;
+      DocumentType.Iterate(ListCurrentDocument, Document, ListCurrent);
+      ListCurrentDocumentType := DocVariantType.FindSynVariantType(
+        ListCurrentDocument.VType);
+      result := true;
+    end;
+end;
+
+function TSynMustacheContextVariant.GetVarDataFromContext(ValueSpace: integer;
+  const ValueName: RawUtf8; var Value: TVarData): TSynMustacheSectionType;
+var
+  i: PtrInt;
+  owned: PVarData;
+begin
+  result := msNothing;
+  if PWord(ValueName)^ = ord('.') then
+    // {{.}} -> context = self
+    with fContext[fContextCount - 1] do
+    begin
+      if ListCount > 0 then
+        Value := ListCurrentDocument
+      else
+        Value := Document;
+      exit;
+    end;
+  // recursive search of {{value}}
+  for i := fContextCount - 1 downto 0 do
+    with fContext[i] do
+      if DocumentType <> nil then
+        if ListCount < 0 then
+        begin
+          // single item context
+          DocumentType.Lookup(Value, Document, pointer(ValueName), fPathDelim);
+          if Value.VType >= varNull then
+            exit;
+        end
+        else if PCardinal(ValueName)^ and $dfdfdfdf = (ord('-') and $df) +
+               ord('I') shl 8 + ord('N') shl 16 + ord('D') shl 24 then
+        begin
+          // {{-index}}
+          Value.VType := varInteger;
+          if ValueName[7] = '0' then
+            Value.VInteger := ListCurrent
+          else
+            Value.VInteger := ListCurrent + 1;
+          exit;
+        end
+        else if (ListCurrent < ListCount) and
+                (ListCurrentDocumentType <> nil) then
+        begin
+          ListCurrentDocumentType.Lookup(
+            Value, ListCurrentDocument, pointer(ValueName), fPathDelim);
+          if Value.VType >= varNull then
+            exit;
+        end;
+  // try {{helper value}} or {{helper}}
+  result := GetHelperFromContext(ValueSpace, ValueName, Value, @owned);
+end;
+
+procedure TSynMustacheContextVariant.AppendValue(ValueSpace: integer;
+  const ValueName: RawUtf8; UnEscape: boolean);
+var
+  Value: TVarData;
+begin
+  GetVarDataFromContext(ValueSpace, ValueName, Value);
+  AppendVariant(variant(Value), UnEscape);
+end;
+
+function SectionIsPseudo(const ValueName: RawUtf8; ListCount, ListCurrent: integer): boolean;
+begin
+  result := ((ValueName = '-first') and
+             (ListCurrent = 0)) or
+            ((ValueName = '-last') and
+             (ListCurrent = ListCount - 1)) or
+            ((ValueName = '-odd') and
+             (ListCurrent and 1 = 0));
+end;
+
+function TSynMustacheContextVariant.AppendSection(ValueSpace: integer;
+  const ValueName: RawUtf8): TSynMustacheSectionType;
+var
+  Value: TVarData;
+  c: cardinal;
+  void: boolean;
+begin
+  result := msNothing;
+  if fContextCount = 0 then
+    exit;
+  if ValueName[1] = '-' then
+    with fContext[fContextCount - 1] do
+      if ListCount >= 0 then
+      begin
+        if SectionIsPseudo(ValueName, ListCount, ListCurrent) then
+          result := msSinglePseudo;
+        exit;
+      end;
+  result := GetVarDataFromContext(ValueSpace, ValueName, Value);
+  c := Value.VType;
+  void := (c <= varNull) or
+          ((c = varBoolean) and
+           (Value.VWord = 0));
+  if (result <> msNothing) and // helper?
+     (c < varFirstCustom) then // simple helper values are not pushed
+  begin
+    if void then
+      result := msNothing;
+    exit;
+  end;
+  PushContext(Value);
+  if void then
+    // null or false value will not display the section
+    result := msNothing
+  else
+    with fContext[fContextCount - 1] do
+      if ListCount < 0 then
+        // single item
+        result := msSingle
+      else if ListCount = 0 then
+        // empty list will not display the section
+        result := msNothing
+      else
+        // non-empty list
+        result := msList;
+end;
+
+
+{ TSynMustacheContextData }
+
+constructor TSynMustacheContextData.Create(Owner: TSynMustache;
+  WR: TJsonWriter; SectionMaxCount: integer; Value: pointer;
+  ValueRtti: TRttiCustom; OwnWriter: boolean);
+begin
+  inherited Create(Owner, WR, OwnWriter);
+  fGetVarDataFromContextNeedsFree := true;
+  SetLength(fContext, SectionMaxCount + 4);
+  PushContext(Value, ValueRtti);
+end;
+
+function TSynMustacheContextData.RenderArray(const arr: TDynArray): RawUtf8;
+var
+  n: PtrInt;
+begin
+  n := arr.Count;
+  if n <> 0 then
+    DynArrayFakeLength(arr.Value^, n); // as required by RenderContext()
+  PushContext(arr.Value, arr.Info);
+  fOwner.RenderContext(self, 0, high(fOwner.fTags));
+  Writer.SetText(result);
+  CancelAll;
+end;
+
+function TSynMustacheContextData.RenderRtti(Value: pointer; Rtti: TRttiCustom): RawUtf8;
+begin
+  PushContext(Value, Rtti);
+  fOwner.RenderContext(self, 0, high(fOwner.fTags));
+  Writer.SetText(result);
+  CancelAll;
+end;
+
+procedure TSynMustacheContextData.PushContext(Value: pointer; Rtti: TRttiCustom);
+var
+  n: PtrInt;
+begin
+  n := fContextCount;
+  if n >= length(fContext) then
+    // was roughtly set by SectionMaxCount
+    SetLength(fContext, n + 32);
+  with fContext[n] do
+  begin
+    Data := Value;
+    Info := Rtti;
+    if Rtti <> nil then
+      ListCount := Rtti.ValueIterateCount(Value);
+    ListCurrent := -1;
+  end;
+  inc(fContextCount);
+end;
+
+function TSynMustacheContextData.GotoNextListItem: boolean;
+var
+  n: PtrInt;
+begin
+  result := false;
+  n := fContextCount;
+  if n > 0 then
+    with fContext[n - 1] do
+      if ListCount >= 0 then
+      begin
+        inc(ListCurrent);
+        if ListCurrent >= ListCount then
+          ListCount := -1
+        else
+          result := true;
+      end;
+end;
+
+function TSynMustacheContextData.GetDataFromContext(const ValueName: RawUtf8;
+  out rc: TRttiCustom; out d: pointer): boolean;
+var
+  i: PtrInt;
+  firstdata: pointer; // OnGetGlobalData is filled with self context
+  firstrc: TRttiCustom;
+begin
+  result := true; // mark found on direct exit
+  // recursive search of {{value}}
+  firstdata := nil;
+  firstrc := nil; // makes Delphi compiler happy
+  for i := fContextCount - 1 downto 0 do
+    with fContext[i] do
+    begin
+      d := Data;
+      rc := Info;
+      if PWord(ValueName)^ = ord('.') then
+        // {{.}} -> context = self
+        exit;
+      if (d <> nil) and
+         (ListCount >= 0) then
+        // within a list
+        if PCardinal(ValueName)^ and $dfdfdfdf = (ord('-') and $df) +
+             ord('I') shl 8 + ord('N') shl 16 + ord('D') shl 24 then
+        begin
+          // {{-index}} pseudo name
+          d := @Temp.Data.VInteger;
+          rc := PT_RTTI[ptInteger];
+          PInteger(d)^ := ListCurrent;
+          if ValueName[7] <> '0' then
+            inc(PInteger(d)^);
+          exit;
+        end
+        else
+          // the current context is the current list item
+          d := rc.ValueIterate(d, ListCurrent, rc); // rkClass is dereferenced
+      if d <> nil then
+      begin
+        // we found a value in this context
+        if firstdata = nil then
+        begin
+          firstdata := d; // for OnGetGlobalData() below
+          firstrc := rc;
+        end;
+        // recursive lookup by {{name1.name2.name3}} against nested variant
+        // fields, record/class properties, or string/set/enum values
+        rc := rc.ValueByPath(d, pointer(ValueName), Temp.Data, fPathDelim);
+        if rc <> nil then
+          exit;
+      end;
+    end;
+  // try to resolve the name at runtime via the OnGetGlobalData callback
+  if Assigned(OnGetGlobalData) then
+  begin
+    d := firstdata; // provide the {{.}} self context to the callback
+    rc := firstrc;
+    result := OnGetGlobalData(self, ValueName, d, rc);
+  end
+  else
+    result := false; // not found
+end;
+
+function TSynMustacheContextData.GetVarDataFromContext(ValueSpace: integer;
+  const ValueName: RawUtf8; var Value: TVarData): TSynMustacheSectionType;
+var
+  d: pointer;
+  rc: TRttiCustom;
+begin
+  // called for Helpers() support: AppendValue() is used for regular values
+  if GetDataFromContext(ValueName, rc, d) then
+  begin
+    // found {{.}} or {{value}} or {{value1.value2.value3}} data
+    result := msNothing;
+    rc.ValueToVariant(d, Value, @JSON_[mFastFloat]);
+  end
+  else
+    // try {{helper value}} or {{helper}}
+    result := GetHelperFromContext(ValueSpace, ValueName, Value, {owned=}nil);
+end;
+
+procedure TSynMustacheContextData.AppendValue(ValueSpace: integer;
+  const ValueName: RawUtf8; UnEscape: boolean);
+var
+  d: pointer;
+  p: PUtf8Char;
+  rc: TRttiCustom;
+  l: PtrInt;
+  tmp: TVarData;
+begin
+  if GetDataFromContext(ValueName, rc, d) then
+  begin
+    // we can directly append the {{###}} found data
+    if fEscapeInvert then
+      UnEscape := not UnEscape;
+    case rc.Parser of // FPC generates a jump table for this case statement
+      // try direct UTF-8 and UTF-16 strings (escaped) rendering
+      {$ifndef UNICODE}
+      ptString,
+      {$endif UNICODE}
+      ptRawUtf8,
+      ptRawJson,
+      ptPUtf8Char:
+        begin
+          p := PPointer(d)^;
+          if p <> nil then
+            if UnEscape then
+            begin
+              if rc.Parser = ptPUtf8Char then
+                l := mormot.core.base.StrLen(p)
+              else
+                l := PStrLen(p - _STRLEN)^;
+              fWriter.AddNoJsonEscape(p, l);
+            end
+            else
+              fWriter.AddHtmlEscape(p); // faster with no length
+        end;
+      {$ifdef UNICODE}
+      ptString,
+      {$endif UNICODE}
+      {$ifdef HASVARUSTRING}
+      ptUnicodeString,
+      {$endif HASVARUSTRING}
+      ptSynUnicode,
+      ptWideString:
+        if UnEscape then
+          fWriter.AddNoJsonEscapeW(PPWord(d)^, 0)
+        else
+          fWriter.AddHtmlEscapeW(PPWideChar(d)^);
+      // unescaped (and unquoted) numbers, date/time, guid or hash
+      ptByte:
+        fWriter.AddU(PByte(d)^);
+      ptWord:
+        fWriter.AddU(PWord(d)^);
+      ptInteger:
+        fWriter.Add(PInteger(d)^);
+      ptCardinal:
+        fWriter.AddU(PCardinal(d)^);
+      ptInt64:
+        fWriter.Add(PInt64(d)^);
+      ptQWord:
+        fWriter.AddQ(PQWord(d)^);
+      ptDouble:
+        fWriter.AddDouble(unaligned(PDouble(d)^));
+      ptCurrency:
+        fWriter.AddCurr64(d);
+      ptBoolean:
+        fWriter.Add(PBoolean(d)^);
+      ptDateTime,
+      ptDateTimeMS:
+        fWriter.AddDateTime(d, 'T', #0, rc.Parser = ptDateTimeMS, {wtime=}true);
+      ptUnixTime:
+        fWriter.AddUnixTime(d);
+      ptUnixMSTime:
+        fWriter.AddUnixMSTime(d, {withms=}true);
+      ptTimeLog:
+        fWriter.AddTimeLog(d);
+      ptGuid:
+        fWriter.Add(PGuid(d), #0);
+      ptHash128,
+      ptHash256,
+      ptHash512:
+        fWriter.AddBinToHexDisplayLower(d, rc.Size);
+    else
+      if rcfIsNumber in rc.Cache.Flags then
+        // ordinals or floats don't need any HTML escape nor quote
+        fWriter.AddRttiCustomJson(d, rc, twNone, [])
+      else
+      begin
+        // use a temporary variant for any complex content (including JSON)
+        rc.ValueToVariant(d, tmp, @JSON_[mFastFloat]);
+        if fEscapeInvert then
+          UnEscape := not UnEscape; // AppendVariant() will reverse it
+        AppendVariant(variant(tmp), UnEscape);
+        VarClearProc(tmp);
+      end;
+    end;
+  end
+  else
+  begin
+    // try {{helper value}} or {{helper}}
+    GetHelperFromContext(ValueSpace, ValueName, tmp, {owned=}nil);
+    AppendVariant(variant(tmp), UnEscape);
+    VarClearProc(tmp);
+  end;
+end;
+
+function IsVoidContext(d: pointer; rc: TRttiCustom): boolean;
+var
+  c: cardinal;
+begin
+  result := true;
+  if d = nil then
+    exit;
+  if rc.Kind = rkClass then
+  begin
+    if PPointer(d)^ = nil then
+      exit;
+  end
+  else if rc.Kind = rkVariant then
+  begin
+    c := PVarData(d)^.VType;
+    if (c <= varNull) or
+       ((c = varBoolean) and
+        (PVarData(d)^.VWord = 0)) then
+      exit;
+  end
+  else if rcfBoolean in rc.Cache.Flags then
+    if PByte(d)^ = 0 then
+      exit;
+  result := false; // not void context, in the Mustache terms
+end;
+
+function TSynMustacheContextData.AppendSection(ValueSpace: integer;
+  const ValueName: RawUtf8): TSynMustacheSectionType;
+var
+  d: pointer;
+  rc: TRttiCustom;
+  tmp: TVarData;
+  void: boolean;
+begin
+  result := msNothing;
+  if fContextCount = 0 then
+    exit;
+  if ValueName[1] = '-' then
+    with fContext[fContextCount - 1] do
+      if ListCount >= 0 then
+      begin
+        if SectionIsPseudo(ValueName, ListCount, ListCurrent) then
+          result := msSinglePseudo;
+        exit;
+      end;
+  if not GetDataFromContext(ValueName, rc, d) then
+  begin
+    result := GetHelperFromContext(ValueSpace, ValueName, tmp, {owned=}d);
+    if result = msNothing then
+      d := nil
+    else
+      rc := PT_RTTI[ptVariant]; // use temp variant value from helper
+  end;
+  void := IsVoidContext(d, rc);
+  if (result <> msNothing) and // helper?
+     (tmp.VType < varFirstCustom) then // simple helper values are not pushed
+  begin
+    if void then
+      result := msNothing;
+    exit;
+  end;
+  if d = nil then
+    exit;
+  PushContext(d, rc);
+  if void then
+    // null or false value will not display the section
+    result := msNothing
+  else
+    with fContext[fContextCount - 1] do
+      if ListCount < 0 then
+        // single item
+        result := msSingle
+      else if ListCount = 0 then
+        // empty list will not display the section
+        result := msNothing
+      else
+        // non-empty list
+        result := msList;
+end;
+
+
+{ TSynMustachePartials }
+
+constructor TSynMustachePartials.Create;
+begin
+  fList := TRawUtf8List.CreateEx([fNoDuplicate, fCaseSensitive, fThreadSafe]);
+end;
+
+constructor TSynMustachePartials.CreateOwned(
+  const NameTemplatePairs: array of RawUtf8);
+var
+  A: PtrInt;
+begin
+  Create;
+  fOwned := true;
+  for A := 0 to high(NameTemplatePairs) div 2 do
+    Add(NameTemplatePairs[A * 2], NameTemplatePairs[A * 2 + 1]);
+end;
+
+function TSynMustachePartials.Add(const aName, aTemplate: RawUtf8): TSynMustache;
+begin
+  result := TSynMustache.Parse(aTemplate);
+  if (result <> nil) and
+     (fList.AddObject(aName, result) < 0) then
+    raise ESynMustache.CreateUtf8('%.Add(%) duplicated name', [self, aName]);
+end;
+
+function TSynMustachePartials.Add(const aName: RawUtf8;
+  aTemplateStart, aTemplateEnd: PUtf8Char): TSynMustache;
+var
+  aTemplate: RawUtf8;
+begin
+  FastSetString(aTemplate, aTemplateStart, aTemplateEnd - aTemplateStart);
+  result := Add(aName, aTemplate);
+end;
+
+function TSynMustachePartials.FoundInTemplate(const text: RawUtf8): PtrInt;
+begin
+  if self <> nil then
+    result := fList.Contains(text)
+  else
+    result := -1;
+end;
+
+class function TSynMustachePartials.CreateOwned(
+  const Partials: variant): TSynMustachePartials;
+var
+  ndx: PtrInt;
+begin
+  result := nil;
+  with _Safe(Partials)^ do
+    if IsObject and
+       (Count > 0) then
+    begin
+      result := TSynMustachePartials.Create;
+      result.fOwned := true;
+      for ndx := 0 to Count - 1 do
+        result.Add(names[ndx], VariantToUtf8(Values[ndx]));
+    end;
+end;
+
+destructor TSynMustachePartials.Destroy;
+begin
+  FreeAndNil(fList);
+  inherited;
+end;
+
+function TSynMustachePartials.GetPartial(
+  const PartialName: RawUtf8): TSynMustache;
+var
+  i: PtrInt;
+begin
+  if self = nil then
+  begin
+    result := nil;
+    exit;
+  end;
+  i := fList.IndexOf(PartialName); // using O(1) hashing
+  if i < 0 then
+    result := nil
+  else
+    result := TSynMustache(fList.Objects[i]);
+end;
+
+function KindToText(Kind: TSynMustacheTagKind): PShortString;
+begin
+  result := GetEnumName(TypeInfo(TSynMustacheTagKind), ord(Kind));
+end;
+
+
+
+{ ************ TSynMustache Template Processing }
+
+type
+  TSynMustacheParser = class
+  protected
+    fTagStartChars, fTagStopChars: word;
+    fPos, fPosMin, fPosMax, fPosTagStart: PUtf8Char;
+    fTagCount: PtrInt;
+    fTemplate: TSynMustache;
+    fScanStart, fScanEnd: PUtf8Char;
+    function Scan(ExpectedTag: cardinal): boolean;
+    procedure AddTag(aKind: TSynMustacheTagKind;
+      aStart: PUtf8Char = nil; aEnd: PUtf8Char = nil);
+  public
+    constructor Create(Template: TSynMustache;
+      const DelimiterStart, DelimiterStop: RawUtf8);
+    procedure Parse(p, PEnd: PUtf8Char);
+  end;
+
+  TSynMustacheCache = class(TRawUtf8List)
+  public
+    function Parse(const aTemplate: RawUtf8): TSynMustache;
+    function UnParse(const aTemplate: RawUtf8): boolean;
+  end;
+
+var
+  SynMustacheCache: TSynMustacheCache = nil;
+
+
+{ TSynMustacheParser }
+
+procedure TSynMustacheParser.AddTag(aKind: TSynMustacheTagKind;
+  aStart, aEnd: PUtf8Char);
+var
+  P: PUtf8Char;
+begin
+  if (aStart = nil) or
+     (aEnd = nil) then
+  begin
+    aStart := fScanStart;
+    aEnd := fScanEnd;
+    case aKind of
+      mtComment,
+      mtSection,
+      mtSectionEnd,
+      mtInvertedSection,
+      mtSetDelimiter,
+      mtPartial:
+        begin
+          // (indented) standalone lines should be removed from the template
+          if aKind <> mtPartial then
+            while (fPosTagStart > fPosMin) and
+                  (fPosTagStart[-1] in [' ', #9]) do
+              // ignore any indentation chars
+              dec(fPosTagStart);
+          if (fPosTagStart = fPosMin) or
+             (fPosTagStart[-1] = #$0A) then
+            // tag starts on a new line -> check if ends on the same line
+            if (fPos > fPosMax) or
+               (fPos^ = #$0A) or
+               (PWord(fPos)^ = $0A0D) then
+            begin
+              if fPos <= fPosMax then
+                if fPos^ = #$0A then
+                  inc(fPos)
+                else if PWord(fPos)^ = $0A0D then
+                  inc(fPos, 2);
+              if fTagCount > 0 then
+                // remove any indentation chars from previous text
+                with fTemplate.fTags[fTagCount - 1] do
+                  if Kind = mtText then
+                    while (TextLen > 0) and
+                          (TextStart[TextLen - 1] in [' ', #9]) do
+                      dec(TextLen);
+            end;
+        end;
+      mtVariable,
+      mtVariableUnescape,
+      mtVariableUnescapeAmp:
+        begin
+          // handle JSON object/array with nested }
+          // e.g. as {{helper [{a:{a:1,b:2}}]}}
+          P := PosChar(aStart, ' ');
+          if (P <> nil) and
+             (P < aEnd) then
+          begin
+            P := GotoNextNotSpaceSameLine(P + 1);
+            if P^ in ['{', '['] then
+            begin
+              P := GotoEndJsonItem(P);
+              if P <> nil then
+              begin
+                aEnd := P;
+                fPos := P;
+                if not Scan(fTagStopChars) then
+                  raise ESynMustache.CreateUtf8('Unfinished {{%', [aStart]);
+                if (aKind = mtVariableUnescape) and
+                   (fTagStopChars = $7d7d) and
+                   (PWord(fPos - 1)^ = $7d7d) then
+                  // {{{name}}} -> point after }}}
+                  inc(fPos);
+              end;
+            end;
+          end;
+        end;
+    end;
+  end;
+  if aEnd <= aStart then
+    exit;
+  if fTagCount >= length(fTemplate.fTags) then
+    SetLength(fTemplate.fTags, NextGrow(fTagCount));
+  with fTemplate.fTags[fTagCount] do
+  begin
+    Kind := aKind;
+    SectionOppositeIndex := -1;
+    case aKind of
+      mtText,
+      mtComment,
+      mtTranslate:
+        begin
+          TextStart := aStart;
+          TextLen := aEnd - aStart;
+        end;
+    else
+      begin
+        TextStart := fPosTagStart;
+        TextLen := aEnd - fPosTagStart;
+        // superfluous in-tag whitespace should be ignored
+        while (aStart < aEnd) and
+              (aStart^ <= ' ') do
+          inc(aStart);
+        while (aEnd > aStart) and
+              (aEnd[-1] <= ' ') do
+          dec(aEnd);
+        if aEnd = aStart then
+          raise ESynMustache.CreateUtf8(
+            'Void % identifier', [KindToText(aKind)^]);
+        FastSetString(Value, aStart, aEnd - aStart);
+        ValueSpace := PosExChar(' ', Value);
+      end;
+    end;
+  end;
+  inc(fTagCount);
+end;
+
+constructor TSynMustacheParser.Create(Template: TSynMustache;
+  const DelimiterStart, DelimiterStop: RawUtf8);
+begin
+  fTemplate := Template;
+  if length(DelimiterStart) <> 2 then
+    raise ESynMustache.CreateUtf8('DelimiterStart="%"', [DelimiterStart]);
+  if length(DelimiterStop) <> 2 then
+    raise ESynMustache.CreateUtf8('DelimiterStop="%"', [DelimiterStop]);
+  fTagStartChars := PWord(DelimiterStart)^;
+  fTagStopChars := PWord(DelimiterStop)^;
+end;
+
+function GotoNextTag(P, PMax: PUtf8Char; ExpectedTag: Word): PUtf8Char;
+begin
+  if P < PMax then
+    repeat
+      if PWord(P)^ <> ExpectedTag then
+      begin
+        inc(P);
+        if P < PMax then
+          continue;
+        break;
+      end;
+      result := P;
+      exit;
+    until false;
+  result := nil;
+end;
+
+function TSynMustacheParser.Scan(ExpectedTag: cardinal): boolean;
+var
+  P: PUtf8Char;
+begin
+  P := GotoNextTag(fPos, fPosMax, ExpectedTag);
+  if P = nil then
+    result := false
+  else
+  begin
+    fScanEnd := P;
+    fScanStart := fPos;
+    fPos := P + 2;
+    result := true;
+  end;
+end;
+
+function SectionNameMatch(const start, finish: RawUtf8): boolean;
+var
+  i: PtrInt;
+begin
+  if start = finish then
+    result := true
+  else
+  begin
+    i := PosExChar(' ', start);
+    result := (i > 0) and
+              IdemPropNameU(finish, pointer(start), i - 1);
+  end;
+end;
+
+procedure TSynMustacheParser.Parse(P, PEnd: PUtf8Char);
+var
+  Kind: TSynMustacheTagKind;
+  Symbol: AnsiChar;
+  i, j, secCount, secLevel: PtrInt;
+begin
+  secCount := 0;
+  if P = nil then
+    exit;
+  fPos := P;
+  fPosMin := P;
+  fPosMax := PEnd - 1;
+  repeat
+    if not Scan(fTagStartChars) then
+      break;
+    fPosTagStart := fScanEnd;
+    AddTag(mtText);
+    if fPos >= fPosMax then
+      break;
+    Symbol := fPos^;
+    case Symbol of
+      '=':
+        Kind := mtSetDelimiter;
+      '{':
+        Kind := mtVariableUnescape;
+      '&':
+        Kind := mtVariableUnescapeAmp;
+      '#':
+        Kind := mtSection;
+      '^':
+        Kind := mtInvertedSection;
+      '/':
+        Kind := mtSectionEnd;
+      '!':
+        Kind := mtComment;
+      '>':
+        Kind := mtPartial;
+      '<':
+        Kind := mtSetPartial;
+      '"':
+        Kind := mtTranslate;
+    else
+      Kind := mtVariable;
+    end;
+    if Kind <> mtVariable then
+      inc(fPos);
+    if not Scan(fTagStopChars) then
+      raise ESynMustache.CreateUtf8('Unfinished {{tag [%]', [fPos]);
+    case Kind of
+      mtSetDelimiter:
+        begin
+          if (fScanEnd - fScanStart <> 6) or
+             (fScanEnd[-1] <> '=') then
+            raise ESynMustache.Create(
+              'mtSetDelimiter syntax is e.g. {{=<% %>=}}');
+          fTagStartChars := PWord(fScanStart)^;
+          fTagStopChars := PWord(fScanStart + 3)^;
+          continue; // do not call AddTag(Kind=mtSetDelimiter)
+        end;
+      mtVariableUnescape:
+        if (Symbol = '{') and
+           (fTagStopChars = $7d7d) and
+           (PWord(fPos - 1)^ = $7d7d) then
+          // {{{name}}} -> point after }}}
+          inc(fPos);
+    end;
+    AddTag(Kind);
+  until false;
+  AddTag(mtText, fPos, fPosMax + 1);
+  for i := 0 to fTagCount - 1 do
+    with fTemplate.fTags[i] do
+      case Kind of
+        mtSection,
+        mtInvertedSection,
+        mtSetPartial:
+          begin
+            inc(secCount);
+            if secCount > fTemplate.fSectionMaxCount then
+              fTemplate.fSectionMaxCount := secCount;
+            secLevel := 1;
+            for j := i + 1 to fTagCount - 1 do
+              case fTemplate.fTags[j].Kind of
+                mtSection,
+                mtInvertedSection,
+                mtSetPartial:
+                  inc(secLevel);
+                mtSectionEnd:
+                  begin
+                    dec(secLevel);
+                    if secLevel = 0 then
+                      if SectionNameMatch(Value, fTemplate.fTags[j].Value) then
+                      begin
+                        fTemplate.fTags[j].SectionOppositeIndex := i;
+                        SectionOppositeIndex := j;
+                        if Kind = mtSetPartial then
+                        begin
+                          if fTemplate.fInternalPartials = nil then
+                            fTemplate.fInternalPartials :=
+                              TSynMustachePartials.Create;
+                          fTemplate.fInternalPartials.Add(Value,
+                            TextStart + TextLen + 2,
+                            fTemplate.fTags[j].TextStart);
+                        end;
+                        break;
+                      end
+                      else
+                        raise ESynMustache.CreateUtf8(
+                          'Got {{/%}}, expected {{/%}}',
+                          [Value, fTemplate.fTags[j].Value]);
+                  end;
+              end;
+            if SectionOppositeIndex < 0 then
+              raise ESynMustache.CreateUtf8(
+                'Missing section end {{/%}}', [Value]);
+          end;
+        mtSectionEnd:
+          begin
+            dec(secCount);
+            if SectionOppositeIndex < 0 then
+              raise ESynMustache.CreateUtf8(
+                'Unexpected section end {{/%}}', [Value]);
+          end;
+      end;
+  SetLength(fTemplate.fTags, fTagCount);
+end;
+
+
+{ TSynMustacheCache }
+
+function TSynMustacheCache.Parse(const aTemplate: RawUtf8): TSynMustache;
+begin
+  result := GetObjectFrom(aTemplate);
+  if result = nil then
+  begin
+    result := TSynMustache.Create(aTemplate);
+    AddObjectUnique(aTemplate, @result);
+  end;
+end;
+
+function TSynMustacheCache.UnParse(const aTemplate: RawUtf8): boolean;
+begin
+  result := Delete(aTemplate) >= 0;
+end;
+
+
+{ TSynMustache }
+
+class function TSynMustache.Parse(const aTemplate: RawUtf8): TSynMustache;
+begin
+  if SynMustacheCache = nil then
+  begin
+    GlobalLock; // RegisterGlobalShutdownRelease() will use it anyway
+    try
+      if SynMustacheCache = nil then
+        SynMustacheCache := RegisterGlobalShutdownRelease(
+          TSynMustacheCache.CreateEx([
+            fObjectsOwned, fNoDuplicate, fCaseSensitive, fThreadSafe]));
+    finally
+      GlobalUnLock;
+    end;
+  end;
+  result := SynMustacheCache.Parse(aTemplate);
+end;
+
+class function TSynMustache.UnParse(const aTemplate: RawUtf8): boolean;
+begin
+  result := SynMustacheCache.UnParse(aTemplate);
+end;
+
+class function TSynMustache.TryRenderJson(const aTemplate, aJson: RawUtf8;
+  out aContent: RawUtf8): boolean;
+var
+  mus: TSynMustache;
+begin
+  if aTemplate <> '' then
+  try
+    mus := Parse(aTemplate);
+    aContent := mus.RenderJson(aJson);
+    result := true;
+  except
+    result := false;
+  end
+  else
+    result := false;
+end;
+
+constructor TSynMustache.Create(const aTemplate: RawUtf8);
+begin
+  Create(pointer(aTemplate), length(aTemplate));
+end;
+
+constructor TSynMustache.Create(aTemplate: PUtf8Char; aTemplateLen: integer);
+begin
+  inherited Create;
+  fTemplate := aTemplate;
+  with TSynMustacheParser.Create(self, '{{', '}}') do
+  try
+    Parse(aTemplate, aTemplate + aTemplateLen);
+  finally
+    Free;
+  end;
+  fCachedContextVariant := NewMustacheContextVariant;
+  fCachedContextData    := NewMustacheContextData;
+end;
+
+function TSynMustache.NewMustacheContextVariant(
+  aBufSize: integer): TSynMustacheContextVariant;
+begin
+  result := TSynMustacheContextVariant.Create(self,
+    TJsonWriter.CreateOwnedStream(aBufSize, {nosharedstream=}true),
+    SectionMaxCount + 4, Null, {ownwriter=}true);
+  result.CancelAll; // to be reused from a void context
+end;
+
+function TSynMustache.NewMustacheContextData(
+  aBufSize: integer): TSynMustacheContextData;
+begin
+  result := TSynMustacheContextData.Create(self,
+    TJsonWriter.CreateOwnedStream(aBufSize, {nosharedstream=}true),
+    SectionMaxCount + 4, nil, nil, {ownwriter=}true);
+  result.CancelAll; // to be reused from a void context
+end;
+
+procedure TSynMustache.RenderContext(Context: TSynMustacheContext;
+  TagStart, TagEnd: integer);
+var
+  partial: TSynMustache;
+begin
+  while TagStart <= TagEnd do
+  begin
+    with fTags[TagStart] do
+      case Kind of
+        mtText:
+          if TextLen <> 0 then
+            // may be 0 e.g. for standalone without previous Line
+            Context.fWriter.AddNoJsonEscape(TextStart, TextLen);
+        mtVariable:
+          Context.AppendValue(ValueSpace, Value, {unescape=}false);
+        mtVariableUnescape,
+        mtVariableUnescapeAmp:
+          Context.AppendValue(ValueSpace, Value, {unescape=}true);
+        mtSection:
+          case Context.AppendSection(ValueSpace, Value) of
+            msNothing:
+              begin
+                // e.g. for no key, false value, or empty list
+                TagStart := SectionOppositeIndex;
+                continue; // ignore whole section
+              end;
+            msList:
+              begin
+                while Context.GotoNextListItem do
+                  RenderContext(Context, TagStart + 1, SectionOppositeIndex - 1);
+                TagStart := SectionOppositeIndex;
+                // ignore whole section since we just rendered it as a list
+                continue;
+              end;
+          // msSingle, msSinglePseudo:
+          //   process the section once with current context
+          end;
+        mtInvertedSection:
+          // display section for no key, false value, or empty list
+          if Context.AppendSection(ValueSpace, Value) <> msNothing then
+          begin
+            TagStart := SectionOppositeIndex;
+            continue; // ignore whole section
+          end;
+        mtSectionEnd:
+          if (fTags[SectionOppositeIndex].Kind in
+               [mtSection, mtInvertedSection]) and
+             (Value[1] <> '-') and
+             (fTags[SectionOppositeIndex].ValueSpace = 0) then
+            Context.PopContext;
+        mtComment:
+          ; // just ignored
+        mtPartial:
+          begin
+            partial := fInternalPartials.GetPartial(Value);
+            if (partial = nil) and
+               (Context.fOwner <> self) then
+              // recursive call
+              partial := Context.fOwner.fInternalPartials.GetPartial(Value);
+            if (partial = nil) and
+               (Context.Partials <> nil) then
+              partial := Context.Partials.GetPartial(Value);
+            if partial <> nil then
+              partial.RenderContext(Context, 0, high(partial.fTags));
+          end;
+        mtSetPartial:
+          // ignore whole internal {{ 0 then
+            Context.TranslateBlock(TextStart, TextLen);
+      else
+        raise ESynMustache.CreateUtf8('Kind=% not implemented yet',
+          [KindToText(fTags[TagStart].Kind)^]);
+      end;
+    inc(TagStart);
+  end;
+end;
+
+function TSynMustache.Render(const Context: variant;
+  Partials: TSynMustachePartials; const Helpers: TSynMustacheHelpers;
+  const OnTranslate: TOnStringTranslate; EscapeInvert: boolean): RawUtf8;
+var
+  ctx: TSynMustacheContextVariant;
+  tmp: TTextWriterStackBuffer;
+begin
+  ctx := fCachedContextVariant; // thread-safe reuse of shared rendering context
+  if ctx.fReuse.TryLock then
+    ctx.PushContext(TVarData(Context)) // weak copy
+  else
+    ctx := TSynMustacheContextVariant.Create(
+      self, TJsonWriter.CreateOwnedStream(tmp), SectionMaxCount, Context, true);
+  try
+    ctx.Helpers := Helpers;
+    ctx.Partials := Partials;
+    ctx.OnStringTranslate := OnTranslate;
+    ctx.EscapeInvert := EscapeInvert;
+    RenderContext(ctx, 0, high(fTags));
+    ctx.Writer.SetText(result);
+  finally
+    if (Partials <> nil) and
+       (Partials.fOwned) then
+      Partials.Free;
+    if ctx = fCachedContextVariant then
+      ctx.CancelAll
+    else
+      ctx.Free;
+  end;
+end;
+
+function TSynMustache.RenderJson(const Json: RawUtf8;
+  Partials: TSynMustachePartials; const Helpers: TSynMustacheHelpers;
+  const OnTranslate: TOnStringTranslate; EscapeInvert: boolean): RawUtf8;
+var
+  context: variant;
+begin
+  _Json(Json, context{%H-}, JSON_FAST_FLOAT);
+  result := Render(context, Partials, Helpers, OnTranslate, EscapeInvert);
+end;
+
+function TSynMustache.RenderJson(const Json: RawUtf8;
+  const Args, Params: array of const; Partials: TSynMustachePartials;
+  const Helpers: TSynMustacheHelpers; const OnTranslate: TOnStringTranslate;
+  EscapeInvert: boolean): RawUtf8;
+var
+  context: variant;
+begin
+  _Json(FormatJson(Json, Args, Params), context{%H-}, JSON_FAST_FLOAT);
+  result := Render(context, Partials, Helpers, OnTranslate, EscapeInvert);
+end;
+
+function TSynMustache.RenderData(const Value; ValueTypeInfo: PRttiInfo;
+  const OnGetData: TOnGetGlobalData; Partials: TSynMustachePartials;
+  const Helpers: TSynMustacheHelpers; const OnTranslate: TOnStringTranslate;
+  EscapeInvert: boolean): RawUtf8;
+begin
+  result := RenderDataRtti(@Value, Rtti.RegisterType(ValueTypeInfo),
+    OnGetData, Partials, Helpers, OnTranslate, EscapeInvert);
+end;
+
+function TSynMustache.RenderDataArray(const Value: TDynArray;
+  const OnGetData: TOnGetGlobalData; Partials: TSynMustachePartials;
+  const Helpers: TSynMustacheHelpers; const OnTranslate: TOnStringTranslate;
+  EscapeInvert: boolean): RawUtf8;
+var
+  n: PtrInt;
+begin
+  n := Value.Count;
+  if n <> 0 then
+    DynArrayFakeLength(Value.Value^, n); // as required by RenderDataRtti()
+  result := RenderDataRtti(Value.Value, Value.Info,
+    OnGetData, Partials, Helpers, OnTranslate, EscapeInvert);
+end;
+
+function TSynMustache.RenderDataRtti(Value: pointer; ValueRtti: TRttiCustom;
+  const OnGetData: TOnGetGlobalData; Partials: TSynMustachePartials;
+  const Helpers: TSynMustacheHelpers; const OnTranslate: TOnStringTranslate;
+  EscapeInvert: boolean): RawUtf8;
+var
+  ctx: TSynMustacheContextData;
+  tmp: TTextWriterStackBuffer;
+begin
+  if ValueRtti = nil then
+    raise ESynMustache.CreateUtf8('%.RenderData: invalid TypeInfo', [self]);
+  ctx := fCachedContextData; // thread-safe reuse of shared rendering context
+  if ctx.fReuse.TryLock then
+    ctx.PushContext(Value, ValueRtti)
+  else
+    ctx := TSynMustacheContextData.Create(
+      self, TJsonWriter.CreateOwnedStream(tmp), SectionMaxCount,
+      Value, ValueRtti, {ownwriter=}true);
+  try
+    ctx.Helpers := Helpers;
+    ctx.Partials := Partials;
+    ctx.OnGetGlobalData := OnGetData;
+    ctx.OnStringTranslate := OnTranslate;
+    ctx.EscapeInvert := EscapeInvert;
+    RenderContext(ctx, 0, high(fTags));
+    ctx.Writer.SetText(result);
+  finally
+    if (Partials <> nil) and
+       (Partials.fOwned) then
+      Partials.Free;
+    if ctx = fCachedContextData then
+      ctx.CancelAll
+    else
+      ctx.Free;
+  end;
+end;
+
+destructor TSynMustache.Destroy;
+begin
+  FreeAndNil(fInternalPartials);
+  inherited;
+  fCachedContextVariant.Free;
+  fCachedContextData.Free;
+end;
+
+function TSynMustache.FoundInTemplate(const text: RawUtf8): boolean;
+begin
+  // internal partials are part of fTemplate
+  result := (self <> nil) and
+            (text <> '') and
+            (PosEx(text, fTemplate) > 0);
+end;
+
+class procedure TSynMustache.HelperAdd(var Helpers: TSynMustacheHelpers;
+  const aName: RawUtf8; aEvent: TSynMustacheHelperEvent);
+var
+  n, i: PtrInt;
+begin
+  n := length(Helpers);
+  for i := 0 to n - 1 do
+    if PropNameEquals(Helpers[i].Name, aName) then
+    begin
+      Helpers[i].Event := aEvent;
+      exit;
+    end;
+  SetLength(Helpers, n + 1);
+  Helpers[n].Name := aName;
+  Helpers[n].Event := aEvent;
+end;
+
+class procedure TSynMustache.HelperAdd(var Helpers: TSynMustacheHelpers;
+  const aNames: array of RawUtf8;
+  const aEvents: array of TSynMustacheHelperEvent);
+var
+  n, i: PtrInt;
+begin
+  n := length(aNames);
+  if n = length(aEvents) then
+    for i := 0 to n - 1 do
+      HelperAdd(Helpers, aNames[i], aEvents[i]);
+end;
+
+class procedure TSynMustache.HelperDelete(var Helpers: TSynMustacheHelpers;
+  const aName: RawUtf8);
+var
+  n, i, j: PtrInt;
+begin
+  n := length(Helpers);
+  for i := 0 to n - 1 do
+    if PropNameEquals(Helpers[i].Name, aName) then
+    begin
+      for j := i to n - 2 do
+        Helpers[j] := Helpers[j + 1];
+      SetLength(Helpers, n - 1);
+      exit;
+    end;
+end;
+
+class function TSynMustache.HelperFind(const Helpers: TSynMustacheHelpers;
+  aName: PUtf8Char; aNameLen: TStrLen): PtrInt;
+var
+  h: ^TSynMustacheHelper;
+  p: PUtf8Char;
+  n: integer;
+begin
+  h := pointer(Helpers);
+  if (h <> nil) and
+     (aNameLen > 0) then
+  begin
+    result := 0;
+    n := PDALen(PAnsiChar(h) - _DALEN)^ + _DAOFF;
+    repeat
+      P := pointer(h^.Name);
+      if (PStrLen(P - _STRLEN)^ = aNameLen) and
+         IdemPropNameUSameLenNotNull(P, aName, aNameLen) then
+        exit;
+      inc(h);
+      inc(result);
+      dec(n);
+    until n = 0;
+  end;
+  result := -1;
+end;
+
+var
+  HelpersStandardList: TSynMustacheHelpers;
+
+class function TSynMustache.HelpersGetStandardList: TSynMustacheHelpers;
+begin
+  if HelpersStandardList = nil then
+    HelperAdd(HelpersStandardList,
+     ['DateTimeToText',
+      'DateToText',
+      'DateFmt',
+      'TimeLogToText',
+      'JsonQuote',
+      'JsonQuoteUri',
+      'ToJson',
+      'MarkdownToHtml',
+      'SimpleToHtml',
+      'WikiToHtml',
+      'BlobToBase64',
+      'EnumTrim',
+      'EnumTrimRight',
+      'PowerOfTwo',
+      'Equals',
+      'If',
+      'NewGuid',
+      'ExtractFileName',
+      'HumanBytes',
+      'Sub',
+      'Values',
+      'Keys',
+      'Match',
+      'MatchI',
+      'Lower',
+      'Upper'],
+     [DateTimeToText,
+      DateToText,
+      DateFmt,
+      TimeLogToText,
+      JsonQuote,
+      JsonQuoteUri,
+      ToJson,
+      MarkdownToHtml,
+      SimpleToHtml,
+      WikiToHtml,
+      BlobToBase64,
+      EnumTrim,
+      EnumTrimRight,
+      PowerOfTwo,
+      Equals_,
+      If_,
+      NewGuid,
+      ExtractFileName,
+      HumanBytes,
+      Sub,
+      Values,
+      Keys,
+      Match,
+      MatchI,
+      Lower,
+      Upper]);
+  result := HelpersStandardList;
+end;
+
+class function TSynMustache.HelpersGetStandardList(
+  const aNames: array of RawUtf8;
+  const aEvents: array of TSynMustacheHelperEvent): TSynMustacheHelpers;
+begin
+  // make first a copy to not change/affect global HelpersStandardList
+  result := copy(HelpersGetStandardList);
+  HelperAdd(result, aNames, aEvents);
+end;
+
+class procedure TSynMustache.DateTimeToText(
+  const Value: variant; out Result: variant);
+var
+  Time: TTimeLogBits;
+  dt: TDateTime;
+begin
+  if VariantToDateTime(Value, dt) then
+  begin
+    Time.From(dt, false);
+    Result := Time.i18nText;
+  end
+  else
+    SetVariantNull(Result{%H-});
+end;
+
+class procedure TSynMustache.DateToText(const Value: variant;
+  out Result: variant);
+var
+  Time: TTimeLogBits;
+  dt: TDateTime;
+begin
+  if VariantToDateTime(Value, dt) then
+  begin
+    Time.From(dt, true);
+    Result := Time.i18nText;
+  end
+  else
+    SetVariantNull(Result{%H-});
+end;
+
+class procedure TSynMustache.DateFmt(const Value: variant;
+  out Result: variant);
+var
+  dt: TDateTime;
+  dv: PDocVariantData;
+begin
+  // {{DateFmt DateValue,"dd/mm/yyy"}}
+  if _SafeArray(Value, 2, dv) and
+       VariantToDateTime(dv^.Values[0], dt) then
+      Result := FormatDateTime(dv^.Values[1], dt)
+    else
+      SetVariantNull(Result{%H-});
+end;
+
+class procedure TSynMustache.TimeLogToText(const Value: variant;
+  out Result: variant);
+var
+  Time: TTimeLogBits;
+begin
+  if VariantToInt64(Value, Time.Value) then
+    Result := Time.i18nText
+  else
+    SetVariantNull(Result{%H-});
+end;
+
+class procedure TSynMustache.ToJson(const Value: variant;
+  out Result: variant);
+var
+  u, r: RawUtf8;
+  wasstring: boolean;
+begin
+  if VarIsEmptyOrNull(Value) then
+    exit;
+  VariantToUtf8(Value, u, wasstring);
+  if wasstring then
+    QuotedStrJson(u, r)
+  else if (u <> '') and
+          (GotoNextNotSpace(pointer(u))^ in ['[', '{']) then
+    r := JsonReformat(u) // e.g. from TDocVariantData
+  else
+    r := u; // false, true, number
+  RawUtf8ToVariant(r, Result);
+end;
+
+class procedure TSynMustache.JsonQuote(const Value: variant;
+  out Result: variant);
+var
+  json: RawUtf8;
+begin
+  if VariantToText(Value, json) then
+    RawUtf8ToVariant(QuotedStrJson(json), Result);
+end;
+
+class procedure TSynMustache.JsonQuoteUri(const Value: variant;
+  out Result: variant);
+var
+  json: RawUtf8;
+begin
+  if VariantToText(Value, json) then
+    RawUtf8ToVariant(UrlEncode(QuotedStrJson(json)), Result);
+end;
+
+procedure ToHtml(const Value: variant; var Result: variant;
+  fmt: TTextWriterHtmlEscape; wiki: boolean = false);
+var
+  txt: RawUtf8;
+  d: PDocVariantData;
+begin
+  // {{{SimpleToHtml content,browserhasnoemoji,nohtmlescape}}}
+  d := _Safe(Value);
+  if d^.IsArray and
+     (d^.Count >= 2) and
+     VariantToText(d^.Values[0], txt) then
+  begin
+    if not VarIsVoid(d^.Values[1]) then
+      exclude(fmt, heEmojiToUtf8);
+    if (d^.Count >= 3) and
+       not VarIsVoid(d^.Values[2]) then
+      exclude(fmt, heHtmlEscape);
+  end
+  else if not VariantToText(Value, txt) then
+    // {{{MarkdownToHtml content}}}
+    exit;
+  if txt <> '' then
+    if wiki then
+      txt := HtmlEscapeWiki(txt, fmt)
+    else
+      txt := HtmlEscapeMarkdown(txt, fmt);
+  RawUtf8ToVariant(txt, Result);
+end;
+
+class procedure TSynMustache.WikiToHtml(const Value: variant;
+  out Result: variant);
+begin
+  ToHtml(Value, Result, [heHtmlEscape, heEmojiToUtf8], {wiki=}true);
+end;
+
+class procedure TSynMustache.MarkdownToHtml(const Value: variant;
+  out Result: variant);
+begin
+  // default Markdown is to allow HTML tags
+  ToHtml(Value, Result, [heEmojiToUtf8]);
+end;
+
+class procedure TSynMustache.SimpleToHtml(const Value: variant;
+  out Result: variant);
+begin
+  ToHtml(Value, Result, [heHtmlEscape, heEmojiToUtf8]);
+end;
+
+class procedure TSynMustache.BlobToBase64(const Value: variant;
+  out Result: variant);
+var
+  tmp: RawUtf8;
+  wasString: boolean;
+begin
+  VariantToUtf8(Value, tmp, wasString);
+  if wasString and
+     (pointer(tmp) <> nil) then
+  begin
+    if PInteger(tmp)^ and $00ffffff = JSON_BASE64_MAGIC_C then
+      delete(tmp, 1, 3);
+    RawUtf8ToVariant(tmp, Result);
+  end
+  else
+    Result := Value;
+end;
+
+class procedure TSynMustache.EnumTrim(const Value: variant;
+  out Result: variant);
+var
+  tmp: RawUtf8;
+  wasString: boolean;
+  short: PUtf8Char;
+begin
+  VariantToUtf8(Value, tmp, wasString);
+  if not wasString then
+    exit;
+  short := TrimLeftLowerCase(tmp);
+  RawUtf8ToVariant(short, StrLen(short), Result);
+end;
+
+class procedure TSynMustache.EnumTrimRight(const Value: variant;
+  out Result: variant);
+var
+  tmp: RawUtf8;
+  wasString: boolean;
+  i, L: PtrInt;
+begin
+  VariantToUtf8(Value, tmp, wasString);
+  if not wasString then
+    exit;
+  L := length(tmp);
+  for i := 1 to L do
+    if not (tmp[i] in ['a'..'z']) then
+    begin
+      L := i - 1;
+      break;
+    end;
+  RawUtf8ToVariant(Pointer(tmp), L, Result);
+end;
+
+class procedure TSynMustache.PowerOfTwo(const Value: variant;
+  out Result: variant);
+var
+  V: Int64;
+begin
+  if TVarData(Value).VType > varNull then
+    if VariantToInt64(Value, V) then
+      Result := Int64(1) shl V;
+end;
+
+class procedure TSynMustache.Equals_(const Value: variant;
+  out Result: variant);
+var
+  dv: PDocVariantData;
+begin
+  // {{#Equals .,12}}
+  if _SafeArray(Value, 2, dv) and
+       (FastVarDataComp(@dv^.Values[0], @dv^.Values[1], false) = 0) then
+      Result := VarTrue
+    else
+      SetVariantNull(Result{%H-});
+end;
+
+class procedure TSynMustache.If_(const Value: variant; out Result: variant);
+var
+  cmp: integer;
+  oper: RawUtf8;
+  dv: PDocVariantData;
+  wasString: boolean;
+begin
+  // {{#if .<>""}} or {{#if .,"=",123}}
+  SetVariantNull(result{%H-});
+  if not _SafeArray(Value, 3, dv) then
+    exit;
+  VariantToUtf8(dv^.Values[1], oper, wasString);
+  if (oper = '') or
+     not wasString then
+    exit;
+  cmp := FastVarDataComp(@dv^.Values[0], @dv^.Values[2], false);
+  case PWord(oper)^ of
+    ord('='):
+      if cmp = 0 then
+        result := VarTrue;
+    ord('>'):
+      if cmp > 0 then
+        result := VarTrue;
+    ord('<'):
+      if cmp < 0 then
+        result := VarTrue;
+    ord('>') + ord('=') shl 8:
+      if cmp >= 0 then
+        result := VarTrue;
+    ord('<') + ord('=') shl 8:
+      if cmp <= 0 then
+        result := VarTrue;
+    ord('<') + ord('>') shl 8:
+      if cmp <> 0 then
+        result := VarTrue;
+  end;
+end;
+
+class procedure TSynMustache.NewGuid(const Value: variant;
+  out Result: variant);
+begin
+  RawUtf8ToVariant(GuidToRawUtf8(RandomGuid), Result);
+end;
+
+class procedure TSynMustache.ExtractFileName(const Value: variant;
+  out Result: variant);
+begin
+  Result := SysUtils.ExtractFileName(Value);
+end;
+
+class procedure TSynMustache.HumanBytes(const Value: variant;
+  out Result: variant);
+var
+  u: RawUtf8;
+  i64: Int64;
+begin
+  if not VarIsEmptyOrNull(Value) then
+    if VariantToInt64(Value, i64) or
+       (VariantToUtf8(Value, u) and
+        ToInt64(u, i64)) then
+      KBU(i64, u);
+  RawUtf8ToVariant(u, Result);
+end;
+
+class procedure TSynMustache.Sub(const Value: variant;
+  out Result: variant);
+var
+  utf: RawUtf8;
+  dv: PDocVariantData;
+  i, n: integer;
+begin
+  // {{Sub AString,12,3}}
+  SetVariantNull(Result{%H-});
+  if _SafeArray(Value, 3, dv) and
+      VariantToText(dv^.Values[0], utf) and
+      VariantToInteger(dv^.Values[1], i) and
+      VariantToInteger(dv^.Values[2], n) then
+    RawUtf8ToVariant(copy(utf, i, n), Result);
+end;
+
+class procedure TSynMustache.Values(const Value: variant;
+  out Result: variant);
+begin
+  TDocVariantData(Result).InitArrayFromObjectValues(Value, JSON_FAST);
+end;
+
+class procedure TSynMustache.Keys(const Value: variant;
+  out Result: variant);
+begin
+  TDocVariantData(Result).InitArrayFromObjectNames(Value, JSON_FAST);
+end;
+
+procedure DoMatch(dv: PDocVariantData; ci: boolean; var res: variant);
+var
+  s, p: RawUtf8;
+begin
+  // {{Match AString,APattern}}
+  if VariantToText(dv^.Values[0], s) and
+     VariantToText(dv^.Values[1], p) and
+     IsMatch(p, s, ci) then
+    res := VarTrue;
+end;
+
+class procedure TSynMustache.Match(const Value: variant; out Result: variant);
+var
+  dv: PDocVariantData;
+begin
+  if _SafeArray(Value, 2, dv) then
+     DoMatch(dv, {caseinsens=}false, Result);
+end;
+
+class procedure TSynMustache.MatchI(const Value: variant; out Result: variant);
+var
+  dv: PDocVariantData;
+begin
+  if _SafeArray(Value, 2, dv) then
+     DoMatch(dv, {caseinsens=}true, Result);
+end;
+
+class procedure TSynMustache.Lower(const Value: variant;
+  out Result: variant);
+var
+  u: RawUtf8;
+begin
+  if VariantToText(Value, u) then
+    RawUtf8ToVariant(LowerCaseUnicode(u), Result);
+end;
+
+class procedure TSynMustache.Upper(const Value: variant;
+  out Result: variant);
+var
+  u: RawUtf8;
+begin
+  if VariantToText(Value, u) then
+    RawUtf8ToVariant(UpperCaseUnicode(u), Result);
+end;
+
+
+
+end.
diff --git a/lib/dmustache/mormot.core.os.pas b/lib/dmustache/mormot.core.os.pas
new file mode 100644
index 00000000..188c7580
--- /dev/null
+++ b/lib/dmustache/mormot.core.os.pas
@@ -0,0 +1,10857 @@
+/// Framework Core Low-Level Wrappers to the Operating-System API
+// - this unit is a part of the Open Source Synopse mORMot framework 2,
+// licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+unit mormot.core.os;
+
+{
+  *****************************************************************************
+
+  Cross-platform functions shared by all framework units
+  - Some Cross-System Type and Constant Definitions
+  - Gather Operating System Information
+  - Operating System Specific Types (e.g. TWinRegistry)
+  - Unicode, Time, File, Console, Library process
+  - Cross-Platform Charset and CodePage Support
+  - Per Class Properties O(1) Lookup via vmtAutoTable Slot (e.g. for RTTI cache)
+  - TSynLocker/TSynLocked and Low-Level Threading Features
+  - Unix Daemon and Windows Service Support
+
+   Aim of this unit is to centralize most used OS-specific API calls, like a
+  SysUtils unit on steroids, to avoid $ifdef/$endif in "uses" clauses.
+   In practice, no "Windows", nor "Linux/Posix" reference should be needed in
+  regular units, once mormot.core.os is included. :)
+   This unit only refers to mormot.core.base so can be used almost stand-alone.
+
+  *****************************************************************************
+}
+
+interface
+
+{$I mormot.defines.inc}
+
+uses
+  {$ifdef OSWINDOWS}
+  Windows, // needed here e.g. for redefinition/redirection of standard types
+  Messages,
+  {$endif OSWINDOWS}
+  classes,
+  contnrs,
+  types,
+  sysutils,
+  mormot.core.base;
+
+
+{ ****************** Some Cross-System Type and Constant Definitions }
+
+const
+  {$ifdef OSWINDOWS}
+  /// operating-system dependent Line Feed characters (#13#10 or #10)
+  CRLF = #13#10;
+  /// operating-system dependent wildchar to match all files in a folder
+  FILES_ALL = '*.*';
+  /// operating-system dependent "inverted" delimiter for NormalizeFileName()
+  InvertedPathDelim = '/';
+  /// operating-system dependent boolean if paths are case-insensitive
+  PathCaseInsensitive = true;
+  {$else}
+  /// operating-system dependent Line Feed characters
+  CRLF = #10;
+  /// operating-system dependent wildchar to match all files in a folder
+  FILES_ALL = '*';
+  /// operating-system dependent "inverted" delimiter for NormalizeFileName()
+  InvertedPathDelim = '\';
+  /// operating-system dependent boolean if paths are case-insensitive
+  PathCaseInsensitive = false;
+  {$endif OSWINDOWS}
+
+  /// human-friendly alias to open a file for exclusive writing
+  fmShareRead      = fmShareDenyWrite;
+  /// human-friendly alias to open a file for exclusive reading
+  fmShareWrite     = fmShareDenyRead;
+  /// human-friendly alias to open a file with no read/write exclusion
+  fmShareReadWrite = fmShareDenyNone;
+
+  /// a convenient constant to open a file for reading without exclusion
+  fmOpenReadShared = fmOpenRead or fmShareReadWrite;
+
+  /// a convenient constant to open a file for writing without exclusion
+  fmOpenWriteShared = fmOpenReadWrite or fmShareReadWrite;
+
+  /// a convenient constant to create a file without exclusion
+  fmCreateShared = fmCreate or fmShareReadWrite;
+
+  /// a convenient array constant to open a file for writing without exclusion
+  fmCreateOrRewrite: array[{rewrite=}boolean] of cardinal = (
+   fmCreateShared,
+   fmOpenWriteShared);
+
+const
+  /// void HTTP Status Code (not a standard value, for internal use only)
+  HTTP_NONE = 0;
+  /// HTTP Status Code for "Continue"
+  HTTP_CONTINUE = 100;
+  /// HTTP Status Code for "Switching Protocols"
+  HTTP_SWITCHINGPROTOCOLS = 101;
+  /// HTTP Status Code for "Success"
+  HTTP_SUCCESS = 200;
+  /// HTTP Status Code for "Created"
+  HTTP_CREATED = 201;
+  /// HTTP Status Code for "Accepted"
+  HTTP_ACCEPTED = 202;
+  /// HTTP Status Code for "Non-Authoritative Information"
+  HTTP_NONAUTHORIZEDINFO = 203;
+  /// HTTP Status Code for "No Content"
+  HTTP_NOCONTENT = 204;
+  /// HTTP Status Code for "Reset Content"
+  HTTP_RESETCONTENT = 205;
+  /// HTTP Status Code for "Partial Content"
+  HTTP_PARTIALCONTENT = 206;
+  /// HTTP Status Code for "Multiple Choices"
+  HTTP_MULTIPLECHOICES = 300;
+  /// HTTP Status Code for "Moved Permanently"
+  HTTP_MOVEDPERMANENTLY = 301;
+  /// HTTP Status Code for "Found"
+  HTTP_FOUND = 302;
+  /// HTTP Status Code for "See Other"
+  HTTP_SEEOTHER = 303;
+  /// HTTP Status Code for "Not Modified"
+  HTTP_NOTMODIFIED = 304;
+  /// HTTP Status Code for "Use Proxy"
+  HTTP_USEPROXY = 305;
+  /// HTTP Status Code for "Temporary Redirect"
+  HTTP_TEMPORARYREDIRECT = 307;
+  /// HTTP Status Code for "Permanent Redirect"
+  HTTP_PERMANENTREDIRECT = 308;
+  /// HTTP Status Code for "Bad Request"
+  HTTP_BADREQUEST = 400;
+  /// HTTP Status Code for "Unauthorized"
+  HTTP_UNAUTHORIZED = 401;
+  /// HTTP Status Code for "Forbidden"
+  HTTP_FORBIDDEN = 403;
+  /// HTTP Status Code for "Not Found"
+  HTTP_NOTFOUND = 404;
+  // HTTP Status Code for "Method Not Allowed"
+  HTTP_NOTALLOWED = 405;
+  // HTTP Status Code for "Not Acceptable"
+  HTTP_NOTACCEPTABLE = 406;
+  // HTTP Status Code for "Proxy Authentication Required"
+  HTTP_PROXYAUTHREQUIRED = 407;
+  /// HTTP Status Code for "Request Time-out"
+  HTTP_TIMEOUT = 408;
+  /// HTTP Status Code for "Conflict"
+  HTTP_CONFLICT = 409;
+  /// HTTP Status Code for "Payload Too Large"
+  HTTP_PAYLOADTOOLARGE = 413;
+  /// HTTP Status Code for "Range Not Satisfiable"
+  HTTP_RANGENOTSATISFIABLE = 416;
+  /// HTTP Status Code for "I'm a teapot"
+  HTTP_TEAPOT = 418;
+  /// HTTP Status Code for "Internal Server Error"
+  HTTP_SERVERERROR = 500;
+  /// HTTP Status Code for "Not Implemented"
+  HTTP_NOTIMPLEMENTED = 501;
+  /// HTTP Status Code for "Bad Gateway"
+  HTTP_BADGATEWAY = 502;
+  /// HTTP Status Code for "Service Unavailable"
+  HTTP_UNAVAILABLE = 503;
+  /// HTTP Status Code for "Gateway Timeout"
+  HTTP_GATEWAYTIMEOUT = 504;
+  /// HTTP Status Code for "HTTP Version Not Supported"
+  HTTP_HTTPVERSIONNONSUPPORTED = 505;
+
+  /// clearly wrong response code, used by THttpServerRequest.SetAsyncResponse
+  // - for internal THttpAsyncServer asynchronous process
+  HTTP_ASYNCRESPONSE = 777;
+
+  /// the successful HTTP response codes after a GET request
+  HTTP_GET_OK = [HTTP_SUCCESS, HTTP_NOCONTENT, HTTP_PARTIALCONTENT];
+
+/// retrieve the HTTP reason text from its integer code as PRawUtf8
+// - e.g. StatusCodeToText(200)^='OK'
+// - as defined in http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html
+// - returns the generic 'Invalid Request' for any unknown Code
+function StatusCodeToText(Code: cardinal): PRawUtf8;
+
+/// retrieve the HTTP reason text from its integer code
+// - as defined in http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html
+procedure StatusCodeToReason(Code: cardinal; var Reason: RawUtf8);
+
+/// convert any HTTP_* constant to an integer status code and its English text
+// - returns e.g. '200 OK' or '404 Not Found', calling StatusCodeToText()
+function StatusCodeToShort(Code: cardinal): TShort47;
+
+/// returns true for successful HTTP status codes, i.e. in 200..399 range
+// - will map mainly SUCCESS (200), CREATED (201), NOCONTENT (204),
+// PARTIALCONTENT (206), NOTMODIFIED (304) or TEMPORARYREDIRECT (307) codes
+// - any HTTP status not part of this range will be identified as erronous
+// request in the internal server statistics
+function StatusCodeIsSuccess(Code: integer): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// check the supplied HTTP header to not contain more than one EOL
+// - to avoid unexpected HTTP body injection, e.g. from unsafe business code
+function IsInvalidHttpHeader(head: PUtf8Char; headlen: PtrInt): boolean;
+
+
+const
+  /// HTTP header name for the content type, as defined in the corresponding RFC
+  HEADER_CONTENT_TYPE = 'Content-Type: ';
+
+  /// HTTP header name for the content type, in upper case
+  // - as defined in the corresponding RFC
+  // - could be used e.g. with IdemPChar() to retrieve the Content-Type value
+  HEADER_CONTENT_TYPE_UPPER = 'CONTENT-TYPE: ';
+
+  /// HTTP header name for the client IP, in upper case
+  // - as defined in our HTTP server classes
+  // - could be used e.g. with IdemPChar() to retrieve the remote IP address
+  HEADER_REMOTEIP_UPPER = 'REMOTEIP: ';
+
+  /// HTTP header name for the authorization token, in upper case
+  // - could be used e.g. with IdemPChar() to retrieve a JWT value
+  // - will detect header computed e.g. by motmot.net.http's
+  // AuthorizationBearer()
+  HEADER_BEARER_UPPER = 'AUTHORIZATION: BEARER ';
+
+  /// MIME content type used for JSON communication (as used by the Microsoft
+  // WCF framework and the YUI framework)
+  // - no 'charset=UTF-8' encoding is necessary, as by specified by RFC 7159
+  JSON_CONTENT_TYPE = 'application/json';
+
+  /// HTTP header for MIME content type used for plain JSON
+  // - i.e. 'Content-Type: application/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';
+
+  /// 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';
+
+  /// a IdemPPChar() compatible array of textual MIME content types
+  // - as used e.g. by IsHtmlContentTypeTextual()
+  CONTENT_TYPE_TEXTUAL: array[0..7] of PAnsiChar = (
+    JSON_CONTENT_TYPE_UPPER,
+    'TEXT/',
+    'APPLICATION/XML',
+    'APPLICATION/JSON',
+    'APPLICATION/JAVASCRIPT',
+    'APPLICATION/X-JAVASCRIPT',
+    'IMAGE/SVG+XML',
+    nil);
+
+  /// internal HTTP content-type for efficient static file sending
+  // - detected e.g. by http.sys' THttpApiServer.Request or via the NGINX
+  // X-Accel-Redirect header's THttpServer.Process (see
+  // THttpServer.NginxSendFileFrom) for direct sending with no local bufferring
+  // - the OutCustomHeader should contain the proper 'Content-type: ....'
+  // corresponding to the file (e.g. by calling GetMimeContentType() function)
+  STATICFILE_CONTENT_TYPE = '!STATICFILE';
+
+  /// internal HTTP content-type Header for efficient static file sending
+  STATICFILE_CONTENT_TYPE_HEADER =
+    HEADER_CONTENT_TYPE + STATICFILE_CONTENT_TYPE;
+
+  /// uppercase version of HTTP header for static file content serving
+  STATICFILE_CONTENT_TYPE_HEADER_UPPPER =
+    HEADER_CONTENT_TYPE_UPPER + STATICFILE_CONTENT_TYPE;
+
+  /// used to notify e.g. the THttpServerRequest not to wait for any response
+  // from the client
+  // - is not to be used in normal HTTP process, but may be used e.g. by
+  // TWebSocketProtocolRest.ProcessFrame() to avoid to wait for an incoming
+  // response from the other endpoint
+  NORESPONSE_CONTENT_TYPE = '!NORESPONSE';
+
+  /// HTTP body following RFC 2324 standard e.g. for banned IP
+  HTTP_BANIP_RESPONSE: string[201] =
+    'HTTP/1.0 418 I''m a teapot'#13#10 +
+    'Content-Length: 125'#13#10 +
+    'Content-Type: text/plain'#13#10#13#10 +
+    'Server refuses to brew coffee because it is currently a teapot.'#13#10 +
+    'Do not mess with it and retry from this IP in a few seconds.';
+
+  /// JSON compatible representation of a boolean value, i.e. 'false' and 'true'
+  // - can be used e.g. in logs, or anything accepting a ShortString
+  BOOL_STR: array[boolean] of string[7] = (
+    'false', 'true');
+
+  /// the JavaScript-like values of non-number IEEE constants
+  // - as recognized by FloatToShortNan, and used by TTextWriter.Add()
+  // when serializing such single/double/extended floating-point values
+  JSON_NAN: array[TFloatNan] of string[11] = (
+    '0', '"NaN"', '"Infinity"', '"-Infinity"');
+
+var
+  /// MIME content type used for JSON communication
+  // - i.e. 'application/json' as stated by datatracker.ietf.org/doc/html/rfc7159
+  // - 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'
+  // - this global will be initialized with 'null' constant, to
+  // avoid a memory allocation each time it is assigned to a variable
+  NULL_STR_VAR: RawUtf8;
+
+  /// JSON compatible representation of a boolean value, i.e. 'false' and 'true'
+  // - can be used when a RawUtf8 string is expected
+  // - this global will be initialized with 'false' and 'true' constants, to
+  // avoid a memory allocation each time it is assigned to a variable
+  BOOL_UTF8: array[boolean] of RawUtf8;
+
+
+type
+  /// Security IDentifier (SID) Authority, encoded as 48-bit binary
+  TSidAuth = array[0..5] of byte;
+  PSidAuth = ^TSidAuth;
+
+  /// Security IDentifier (SID) binary format, as retrieved e.g. by Windows API
+  // - this definition is not detailed on oldest Delphi, and not available on
+  // POSIX, whereas it makes sense to also have it, e.g. for server process
+  TSid = packed record
+     Revision: byte;
+     SubAuthorityCount: byte;
+     IdentifierAuthority: TSidAuth;
+     SubAuthority: array[byte] of cardinal;
+  end;
+  PSid = ^TSid;
+  PSids = array of PSid;
+
+  /// define a list of well-known Security IDentifier (SID) groups
+  // - for instance, wksBuiltinAdministrators is set for local administrators
+  // - warning: does not exactly match winnt.h WELL_KNOWN_SID_TYPE enumeration
+  TWellKnownSid = (
+    wksNull,
+    wksWorld,
+    wksLocal,
+    wksConsoleLogon,
+    wksCreatorOwner,
+    wksCreatorGroup,
+    wksCreatorOwnerServer,
+    wksCreatorGroupServer,
+    wksIntegrityUntrusted,
+    wksIntegrityLow,
+    wksIntegrityMedium,
+    wksIntegrityMediumPlus,
+    wksIntegrityHigh,
+    wksIntegritySystem,
+    wksIntegrityProtectedProcess,
+    wksIntegritySecureProcess,
+    wksAuthenticationAuthorityAsserted,
+    wksAuthenticationServiceAsserted,
+    wksAuthenticationFreshKeyAuth,
+    wksAuthenticationKeyTrust,
+    wksAuthenticationKeyPropertyMfa,
+    wksAuthenticationKeyPropertyAttestation,
+    wksNtAuthority,
+    wksDialup,
+    wksNetwork,
+    wksBatch,
+    wksInteractive,
+    wksService,
+    wksAnonymous,
+    wksProxy,
+    wksEnterpriseControllers,
+    wksSelf,
+    wksAuthenticatedUser,
+    wksRestrictedCode,
+    wksTerminalServer,
+    wksRemoteLogonId,
+    wksThisOrganisation,
+    wksIisUser,
+    wksLocalSystem,
+    wksLocalService,
+    wksNetworkService,
+    wksLocalAccount,
+    wksLocalAccountAndAdministrator,
+    wksBuiltinDomain,
+    wksBuiltinAdministrators,
+    wksBuiltinUsers,
+    wksBuiltinGuests,
+    wksBuiltinPowerUsers,
+    wksBuiltinAccountOperators,
+    wksBuiltinSystemOperators,
+    wksBuiltinPrintOperators,
+    wksBuiltinBackupOperators,
+    wksBuiltinReplicator,
+    wksBuiltinRasServers,
+    wksBuiltinPreWindows2000CompatibleAccess,
+    wksBuiltinRemoteDesktopUsers,
+    wksBuiltinNetworkConfigurationOperators,
+    wksBuiltinIncomingForestTrustBuilders,
+    wksBuiltinPerfMonitoringUsers,
+    wksBuiltinPerfLoggingUsers,
+    wksBuiltinAuthorizationAccess,
+    wksBuiltinTerminalServerLicenseServers,
+    wksBuiltinDcomUsers,
+    wksBuiltinIUsers,
+    wksBuiltinCryptoOperators,
+    wksBuiltinUnknown,
+    wksBuiltinCacheablePrincipalsGroups,
+    wksBuiltinNonCacheablePrincipalsGroups,
+    wksBuiltinEventLogReadersGroup,
+    wksBuiltinCertSvcDComAccessGroup,
+    wksBuiltinRdsRemoteAccessServers,
+    wksBuiltinRdsEndpointServers,
+    wksBuiltinRdsManagementServers,
+    wksBuiltinHyperVAdmins,
+    wksBuiltinAccessControlAssistanceOperators,
+    wksBuiltinRemoteManagementUsers,
+    wksBuiltinDefaultSystemManagedGroup,
+    wksBuiltinStorageReplicaAdmins,
+    wksBuiltinDeviceOwners,
+    wksCapabilityInternetClient,
+    wksCapabilityInternetClientServer,
+    wksCapabilityPrivateNetworkClientServer,
+    wksCapabilityPicturesLibrary,
+    wksCapabilityVideosLibrary,
+    wksCapabilityMusicLibrary,
+    wksCapabilityDocumentsLibrary,
+    wksCapabilityEnterpriseAuthentication,
+    wksCapabilitySharedUserCertificates,
+    wksCapabilityRemovableStorage,
+    wksCapabilityAppointments,
+    wksCapabilityContacts,
+    wksBuiltinAnyPackage,
+    wksBuiltinAnyRestrictedPackage,
+    wksNtlmAuthentication,
+    wksSChannelAuthentication,
+    wksDigestAuthentication);
+
+  /// define a set of well-known SID
+  TWellKnownSids = set of TWellKnownSid;
+
+  /// custom binary buffer type used as convenient Windows SID storage
+  RawSid = type RawByteString;
+
+  /// a dynamic array of binary SID storage buffers
+  RawSidDynArray = array of RawSid;
+
+
+/// a wrapper around MemCmp() on two Security IDentifier binary buffers
+// - will first compare by length, then by content
+function SidCompare(a, b: PSid): integer;
+
+/// compute the actual binary length of a Security IDentifier buffer, in bytes
+function SidLength(sid: PSid): PtrInt;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// allocate a RawSid instance from a PSid raw handler
+procedure ToRawSid(sid: PSid; out result: RawSid);
+
+/// check if a RawSid binary buffer has the expected length of a valid SID
+function IsValidRawSid(const sid: RawSid): boolean;
+
+/// search within SID dynamic array for a given SID
+function HasSid(const sids: PSids; sid: PSid): boolean;
+
+/// search within SID dynamic array for a given dynamic array of SID buffers
+function HasAnySid(const sids: PSids; const sid: RawSidDynArray): boolean;
+
+/// append a SID buffer pointer to a dynamic array of SID buffers
+procedure AddRawSid(var sids: RawSidDynArray; sid: PSid);
+
+/// convert a Security IDentifier as text, following the standard representation
+procedure SidToTextShort(sid: PSid; var result: shortstring);
+
+/// convert a Security IDentifier as text, following the standard representation
+function SidToText(sid: PSid): RawUtf8;
+
+/// convert several Security IDentifier as text dynamic array
+function SidsToText(sids: PSids): TRawUtf8DynArray;
+
+/// convert a Security IDentifier as text, following the standard representation
+function RawSidToText(const sid: RawSid): RawUtf8;
+
+/// parse a Security IDentifier text, following the standard representation
+// - won't support hexadecimal IdentifierAuthority, i.e. S-1-0x######-....
+function TextToSid(P: PUtf8Char; out sid: TSid): boolean;
+
+/// parse a Security IDentifier text, following the standard representation
+function TextToRawSid(const text: RawUtf8): RawSid; overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// parse a Security IDentifier text, following the standard representation
+function TextToRawSid(const text: RawUtf8; out sid: RawSid): boolean; overload;
+
+/// returns a Security IDentifier of a well-known SID as binary
+// - is using an internal cache for the returned RawSid instances
+function KnownRawSid(wks: TWellKnownSid): RawSid;
+
+/// returns a Security IDentifier of a well-known SID as standard text
+// - e.g. wksBuiltinAdministrators as 'S-1-5-32-544'
+function KnownSidToText(wks: TWellKnownSid): PShortString;
+
+/// recognize most well-known SID from a Security IDentifier binary buffer
+// - returns wksNull if the supplied buffer was not recognized
+function SidToKnown(sid: PSid): TWellKnownSid; overload;
+
+/// recognize most well-known SID from a Security IDentifier standard text
+// - returns wksNull if the supplied text was not recognized
+function SidToKnown(const text: RawUtf8): TWellKnownSid; overload;
+
+/// recognize some well-known SIDs from the supplied SID dynamic array
+function SidToKnownGroups(const sids: PSids): TWellKnownSids;
+
+
+{ ****************** Gather Operating System Information }
+
+type
+  /// Exception types raised by this mormot.core.os unit
+  EOSException = class(ExceptionWithProps);
+
+  /// the known operating systems
+  // - it will also recognize most Linux distributions
+  TOperatingSystem = (
+    osUnknown,
+    osWindows,
+    osLinux,
+    osOSX,
+    osBSD,
+    osPOSIX,
+    osArch,
+    osAurox,
+    osDebian,
+    osFedora,
+    osGentoo,
+    osKnoppix,
+    osMint,
+    osMandrake,
+    osMandriva,
+    osNovell,
+    osUbuntu,
+    osSlackware,
+    osSolaris,
+    osSuse,
+    osSynology,
+    osTrustix,
+    osClear,
+    osUnited,
+    osRedHat,
+    osLFS,
+    osOracle,
+    osMageia,
+    osCentOS,
+    osCloud,
+    osXen,
+    osAmazon,
+    osCoreOS,
+    osAlpine,
+    osAndroid);
+
+  /// the recognized Windows versions
+  // - defined even outside OSWINDOWS to access e.g. from monitoring tools
+  TWindowsVersion = (
+    wUnknown,
+    w2000,
+    wXP,
+    wXP_64,
+    wServer2003,
+    wServer2003_R2,
+    wVista,
+    wVista_64,
+    wServer2008,
+    wServer2008_64,
+    wSeven,
+    wSeven_64,
+    wServer2008_R2,
+    wServer2008_R2_64,
+    wEight,
+    wEight_64,
+    wServer2012,
+    wServer2012_64,
+    wEightOne,
+    wEightOne_64,
+    wServer2012R2,
+    wServer2012R2_64,
+    wTen,
+    wTen_64,
+    wServer2016,
+    wServer2016_64,
+    wEleven,
+    wEleven_64,
+    wServer2019_64,
+    wServer2022_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;
+      winbuild: word);
+    osLinux: (
+      utsrelease: array[0..2] of byte);
+  end;
+
+const
+  /// the recognized MacOS versions, as plain text
+  // - indexed from OSVersion32.utsrelease[2] kernel revision
+  MACOS_NAME: array[8 .. 24] of RawUtf8 = (
+    '10.4 Tiger',
+    '10.5 Leopard',
+    '10.6 Snow Leopard',
+    '10.7 Lion',
+    '10.8 Mountain Lion',
+    '10.9 Mavericks',
+    '10.10 Yosemite',
+    '10.11 El Capitan',
+    '10.12 Sierra',
+    '10.13 High Sierra',
+    '10.14 Mojave',
+    '10.15 Catalina',
+    '11 Big Sur',
+    '12 Monterey',
+    '13 Ventura',
+    '14 Sonoma',
+    '15 Glow'); // use known internal codename for upcoming version
+
+  /// the recognized Windows versions, as plain text
+  // - defined even outside OSWINDOWS to allow process e.g. from monitoring tools
+  WINDOWS_NAME: array[TWindowsVersion] of RawUtf8 = (
+    '',
+    '2000',
+    'XP',
+    'XP 64bit',
+    'Server 2003',
+    'Server 2003 R2',
+    'Vista',
+    'Vista 64bit',
+    'Server 2008',
+    'Server 2008 64bit',
+    '7',
+    '7 64bit',
+    'Server 2008 R2',
+    'Server 2008 R2 64bit',
+    '8',
+    '8 64bit',
+    'Server 2012',
+    'Server 2012 64bit',
+    '8.1',
+    '8.1 64bit',
+    'Server 2012 R2',
+    'Server 2012 R2 64bit',
+    '10',
+    '10 64bit',
+    'Server 2016',
+    'Server 2016 64bit',
+    '11',
+    '11 64bit',
+    'Server 2019 64bit',
+    'Server 2022 64bit');
+
+  /// the recognized Windows versions which are 32-bit
+  WINDOWS_32 = [
+     w2000,
+     wXP,
+     wServer2003,
+     wServer2003_R2,
+     wVista,
+     wServer2008,
+     wSeven,
+     wServer2008_R2,
+     wEight,
+     wServer2012,
+     wEightOne,
+     wServer2012R2,
+     wTen,
+     wServer2016,
+     wEleven];
+
+  /// translate one operating system (and distribution) into a its common name
+  OS_NAME: array[TOperatingSystem] of RawUtf8 = (
+    'Unknown',
+    'Windows',
+    'Linux',
+    'OSX',
+    'BSD',
+    'POSIX',
+    'Arch',
+    'Aurox',
+    'Debian',
+    'Fedora',
+    'Gentoo',
+    'Knoppix',
+    'Mint',
+    'Mandrake',
+    'Mandriva',
+    'Novell',
+    'Ubuntu',
+    'Slackware',
+    'Solaris',
+    'Suse',
+    'Synology',
+    'Trustix',
+    'Clear',
+    'United',
+    'RedHat',
+    'LFS',
+    'Oracle',
+    'Mageia',
+    'CentOS',
+    'Cloud',
+    'Xen',
+    'Amazon',
+    'CoreOS',
+    'Alpine',
+    'Android');
+
+  /// translate one operating system (and distribution) into a single character
+  // - may be used internally e.g. for a HTTP User-Agent header, as with
+  // TFileVersion.UserAgent and UserAgentParse()
+  OS_INITIAL: array[TOperatingSystem] of AnsiChar = (
+    '?', // Unknown
+    'W', // Windows
+    'L', // Linux
+    'X', // OSX
+    'B', // BSD
+    'P', // POSIX
+    'A', // Arch
+    'a', // Aurox
+    'D', // Debian
+    'F', // Fedora
+    'G', // Gentoo
+    'K', // Knoppix
+    'M', // Mint
+    'm', // Mandrake
+    'n', // Mandriva
+    'N', // Novell
+    'U', // Ubuntu
+    'S', // Slackware
+    's', // Solaris
+    'u', // Suse
+    'Y', // Synology
+    'T', // Trustix
+    'C', // Clear
+    't', // United
+    'R', // RedHat
+    'l', // LFS
+    'O', // Oracle
+    'G', // Mageia
+    'c', // CentOS
+    'd', // Cloud
+    'x', // Xen
+    'Z', // Amazon
+    'r', // CoreOS
+    'p', // Alpine
+    'J'  // Android (J=JVM)
+    );
+
+  /// the operating systems items which actually have a Linux kernel
+  OS_LINUX = [
+    osLinux,
+    osArch .. osAndroid];
+
+  /// the compiler family used
+  COMP_TEXT = {$ifdef FPC}'Fpc'{$else}'Delphi'{$endif};
+
+  /// the target Operating System used for compilation, as short text
+  OS_TEXT =
+    {$ifdef OSWINDOWS}
+      'Win';
+    {$else} {$ifdef OSDARWIN}
+      'OSX';
+    {$else}{$ifdef OSBSD}
+      'BSD';
+    {$else} {$ifdef OSANDROID}
+      'Android';
+    {$else} {$ifdef OSLINUX}
+      'Linux';
+    {$else}
+      'Posix';
+    {$endif OSLINUX}
+    {$endif OSANDROID}
+    {$endif OSBSD}
+    {$endif OSDARWIN}
+    {$endif OSWINDOWS}
+
+  /// the CPU architecture used for compilation
+  CPU_ARCH_TEXT =
+    {$ifdef CPUX86}
+      'x86'
+    {$else} {$ifdef CPUX64}
+      'x64'
+    {$else} {$ifdef CPUARM}
+      'arm' +
+    {$else} {$ifdef CPUAARCH64}
+      'aarch' +
+    {$ifdef CPUPOWERPC}
+      'ppc' +
+    {$else} {$ifdef CPUSPARC}
+      'sparc' +
+    {$endif CPUSPARC}
+    {$endif CPUPOWERPC}
+    {$endif CPUARM}
+    {$endif CPUAARCH64}
+    {$ifdef CPU32}
+      '32'
+    {$else}
+      '64'
+    {$endif CPU32}
+    {$endif CPUX64}
+    {$endif CPUX86};
+
+var
+  /// the target Operating System used for compilation, as TOperatingSystem
+  // - a specific Linux distribution may be detected instead of plain osLinux
+  OS_KIND: TOperatingSystem =
+    {$ifdef OSWINDOWS}
+      osWindows
+    {$else} {$ifdef OSDARWIN}
+      osOSX
+    {$else} {$ifdef OSBSD}
+      osBSD
+    {$else} {$ifdef OSANDROID}
+      osAndroid
+    {$else} {$ifdef OSLINUX}
+      osLinux
+    {$else}
+      osPOSIX
+    {$endif OSLINUX}
+    {$endif OSANDROID}
+    {$endif OSBSD}
+    {$endif OSDARWIN}
+    {$endif OSWINDOWS};
+
+  /// the current Operating System version, as retrieved for the current process
+  // - contains e.g. 'Windows Seven 64 SP1 (6.1.7601)' or 'Windows XP SP3 (5.1.2600)' or
+  // 'Windows 10 64bit 22H2 (10.0.19045.4046)' or 'macOS 13 Ventura (Darwin 22.3.0)' or
+  // 'Ubuntu 16.04.5 LTS - Linux 3.13.0 110 generic#157 Ubuntu SMP Mon Feb 20 11:55:25 UTC 2017'
+  OSVersionText: RawUtf8;
+  /// some addition system information as text, e.g. 'Wine 1.1.5'
+  // - also always appended to OSVersionText high-level description
+  // - use if PosEx('Wine', OSVersionInfoEx) > 0 then to check for Wine presence
+  OSVersionInfoEx: RawUtf8;
+  /// the current Operating System version, as retrieved for the current process
+  // and computed by ToTextOS(OSVersionInt32)
+  // - contains e.g. 'Windows Vista' or 'Ubuntu Linux 5.4.0' or
+  // 'macOS 13 Ventura 22.3.0'
+  OSVersionShort: RawUtf8;
+
+  {$ifdef OSWINDOWS}
+  /// on Windows, the Update Build Revision as shown with the "ver/winver" command
+  // - to track the current update state of the system
+  WindowsUbr: integer;
+  /// on Windows, the ready-to-be-displayed text version of the system
+  // - e.g. 'Windows 10 Entreprise N'
+  WindowsProductName: RawUtf8;
+  /// on Windows, the ready-to-be-displayed text version of the system
+  // - e.g. '22H2'
+  WindowsDisplayVersion: RawUtf8;
+  {$endif OSWINDOWS}
+
+  /// some textual information about the current CPU and its known cache
+  // - contains e.g. '4 x Intel(R) Core(TM) i5-7300U CPU @ 2.60GHz [3MB]'
+  CpuInfoText: RawUtf8;
+  /// the on-chip cache size, in bytes, as returned by the OS
+  // - retrieved from /proc/cpuinfo "cache size" entry (L3 cache) on Linux or
+  // CpuCache[3/4].Size (from GetLogicalProcessorInformation) on Windows
+  CpuCacheSize: cardinal;
+  /// the available cache information as returned by the OS
+  // - e.g. 'L1=2*32KB  L2=256KB  L3=3MB' on Windows or '3072 KB' on Linux
+  CpuCacheText: RawUtf8;
+  /// some textual information about the current computer hardware, from BIOS
+  // - contains e.g. 'LENOVO 20HES23B0U ThinkPad T470'
+  BiosInfoText: RawUtf8;
+
+  /// how many hardware CPU sockets are defined on this system
+  // - i.e. the number of physical CPU slots, not the number of logical CPU
+  // cores as returned by SystemInfo.dwNumberOfProcessors
+  // - as used e.g. by SetThreadAffinity()
+  CpuSockets: integer;
+
+  /// Level 1 to 4 CPU caches as returned by GetLogicalProcessorInformation
+  // - yes, Intel introduced a Level 4 cache (eDRAM) with some Haswell/Iris CPUs
+  // - this information is not retrieved on all Linux / POSIX systems yet
+  // - only Unified or Data caches are include (not Instruction or Trace)
+  // - note: some CPU - like the Apple M1 - have 128 bytes of LineSize
+  CpuCache: array[1..4] of record
+    Count, Size, LineSize: cardinal;
+  end;
+
+  {$ifdef OSLINUXANDROID}
+  /// contains the Flags: or Features: value of Linux /proc/cpuinfo
+  CpuInfoFeatures: RawUtf8;
+  {$endif OSLINUXANDROID}
+
+  /// the running Operating System
+  OSVersion32: TOperatingSystemVersion;
+  /// the running Operating System, encoded as a 32-bit integer
+  OSVersionInt32: integer absolute OSVersion32;
+
+/// convert an Operating System type into its text representation
+// - returns e.g. 'Windows Vista' or 'Ubuntu' or 'macOS 13 Ventura'
+function ToText(const osv: TOperatingSystemVersion): RawUtf8; overload;
+
+/// convert an Operating System type into its one-word text representation
+// - returns e.g. 'Vista' or 'Ubuntu' or 'OSX'
+function ToTextShort(const osv: TOperatingSystemVersion): RawUtf8;
+
+/// convert a 32-bit Operating System type into its full text representation
+// - including the kernel revision (not the distribution version) on POSIX systems
+// - returns e.g. 'Windows Vista', 'Windows 11 64-bit 22000' or 'Ubuntu Linux 5.4.0'
+function ToTextOS(osint32: integer): RawUtf8;
+
+/// check if the current OS (i.e. OS_KIND value) match a description
+// - will handle osPosix and osLinux as generic detection of those systems
+// - osUnknown will always return true
+function MatchOS(os: TOperatingSystem): boolean;
+
+type
+  /// the recognized ARM/AARCH64 CPU types
+  // - https://github.com/karelzak/util-linux/blob/master/sys-utils/lscpu-arm.c
+  // - is defined on all platforms for cross-system use
+  TArmCpuType = (
+    actUnknown,
+    actARM810,
+    actARM920,
+    actARM922,
+    actARM926,
+    actARM940,
+    actARM946,
+    actARM966,
+    actARM1020,
+    actARM1022,
+    actARM1026,
+    actARM11MPCore,
+    actARM1136,
+    actARM1156,
+    actARM1176,
+    actCortexA5,
+    actCortexA7,
+    actCortexA8,
+    actCortexA9,
+    actCortexA12,
+    actCortexA15,
+    actCortexA17,
+    actCortexR4,
+    actCortexR5,
+    actCortexR7,
+    actCortexR8,
+    actCortexM0,
+    actCortexM1,
+    actCortexM3,
+    actCortexM4,
+    actCortexM7,
+    actCortexM0P,
+    actCortexA32,
+    actCortexA53,
+    actCortexA35,
+    actCortexA55,
+    actCortexA65,
+    actCortexA57,
+    actCortexA72,
+    actCortexA73,
+    actCortexA75,
+    actCortexA76,
+    actNeoverseN1,
+    actCortexA77,
+    actCortexA76AE,
+    actCortexR52,
+    actCortexM23,
+    actCortexM33,
+    actNeoverseV1,
+    actCortexA78,
+    actCortexA78AE,
+    actCortexX1,
+    actCortex510,
+    actCortex710,
+    actCortexX2,
+    actNeoverseN2,
+    actNeoverseE1,
+    actCortexA78C,
+    actCortexX1C,
+    actCortexA715,
+    actCortexX3,
+    actNeoverseV2,
+    actCortexA520,
+    actCortexA720,
+    actCortexX4,
+    actNeoverseV3,
+    actNeoverseN3);
+  /// a set of recognized ARM/AARCH64 CPU types
+  TArmCpuTypes = set of TArmCpuType;
+
+  /// the recognized ARM/AARCH64 CPU hardware implementers
+  // - https://github.com/karelzak/util-linux/blob/master/sys-utils/lscpu-arm.c
+  TArmCpuImplementer = (
+    aciUnknown,
+    aciARM,
+    aciBroadcom,
+    aciCavium,
+    aciDEC,
+    aciFUJITSU,
+    aciHiSilicon,
+    aciInfineon,
+    aciMotorola,
+    aciNVIDIA,
+    aciAPM,
+    aciQualcomm,
+    aciSamsung,
+    aciMarvell,
+    aciApple,
+    aciFaraday,
+    aciIntel,
+    aciMicrosoft,
+    aciPhytium,
+    aciAmpere);
+  /// a set of recognized ARM/AARCH64 CPU hardware implementers
+  TArmCpuImplementers = set of TArmCpuImplementer;
+
+/// recognize a given ARM/AARCH64 CPU from its 12-bit hardware ID
+function ArmCpuType(id: word): TArmCpuType;
+
+/// recognize a given ARM/AARCH64 CPU type name from its 12-bit hardware ID
+function ArmCpuTypeName(act: TArmCpuType; id: word): RawUtf8;
+
+/// recognize a given ARM/AARCH64 CPU implementer from its 8-bit hardware ID
+function ArmCpuImplementer(id: byte): TArmCpuImplementer;
+
+/// recognize a given ARM/AARCH64 CPU implementer name from its 8-bit hardware ID
+function ArmCpuImplementerName(aci: TArmCpuImplementer; id: word): RawUtf8;
+
+
+const
+  /// contains the Delphi/FPC Compiler Version as text
+  // - e.g. 'Delphi 10.3 Rio', 'Delphi 2010' or 'Free Pascal 3.3.1'
+  COMPILER_VERSION: RawUtf8 =
+  {$ifdef FPC}
+    'Free Pascal'
+    {$ifdef VER2_6_4} + ' 2.6.4'{$endif}
+    {$ifdef VER3_0}   + ' 3.0'
+      {$ifdef VER3_0_4}   + '.4' {$else}
+        {$ifdef VER3_0_2} + '.2' {$endif}
+      {$endif VER3_0_4}
+    {$endif VER3_0}
+    {$ifdef VER3_1}   + ' 3.1'
+       {$ifdef VER3_1_1} + '.1' {$endif}
+    {$endif VER3_1}
+    {$ifdef VER3_2}   + ' 3.2'
+      {$ifdef VER3_2_4}     + '.4' {$else}
+        {$ifdef VER3_2_3}   + '.3' {$else}
+          {$ifdef VER3_2_2} + '.2' {$endif}
+        {$endif VER3_2_3}
+      {$endif VER3_2_4}
+    {$endif VER3_2}
+    {$ifdef VER3_3}   + ' 3.3'
+       {$ifdef VER3_3_1} + '.1' {$endif}
+    {$endif VER3_3}
+    {$ifdef VER3_4}   + ' 3.4'  {$endif}
+  {$else}
+    'Delphi'
+    {$if     defined(VER140)} + ' 6'
+    {$elseif defined(VER150)} + ' 7'
+    {$elseif defined(VER160)} + ' 8'
+    {$elseif defined(VER170)} + ' 2005'
+    {$elseif defined(VER185)} + ' 2007'
+    {$elseif defined(VER180)} + ' 2006'
+    {$elseif defined(VER200)} + ' 2009'
+    {$elseif defined(VER210)} + ' 2010'
+    {$elseif defined(VER220)} + ' XE'
+    {$elseif defined(VER230)} + ' XE2'
+    {$elseif defined(VER240)} + ' XE3'
+    {$elseif defined(VER250)} + ' XE4'
+    {$elseif defined(VER260)} + ' XE5'
+    {$elseif defined(VER265)} + ' AppMethod 1'
+    {$elseif defined(VER270)} + ' XE6'
+    {$elseif defined(VER280)} + ' XE7'
+    {$elseif defined(VER290)} + ' XE8'
+    {$elseif defined(VER300)} + ' 10 Seattle'
+    {$elseif defined(VER310)} + ' 10.1 Berlin'
+    {$elseif defined(VER320)} + ' 10.2 Tokyo'
+    {$elseif defined(VER330)} + ' 10.3 Rio'
+    {$elseif defined(VER340)} + ' 10.4 Sydney'
+    {$elseif defined(VER350)} + ' 11'
+      {$if declared(RTLVersion113)} + '.3' {$else}
+      {$if declared(RTLVersion112)} + '.2' {$else}
+      {$if declared(RTLVersion111)} + '.1' {$ifend} {$ifend} {$ifend}
+                              + ' Alexandria'
+    {$elseif defined(VER360)} + ' 12'
+      {$if declared(RTLVersion122)} + '.2' {$else}
+      {$if declared(RTLVersion121)} + '.1' {$ifend} {$ifend}
+                              + ' Athens'
+    {$elseif defined(VER370)} + ' 13 Next'
+    {$ifend}
+  {$endif FPC}
+  {$ifdef CPU64} + ' 64 bit' {$else} + ' 32 bit' {$endif};
+
+{$ifndef PUREMORMOT2}
+const
+  HTTP_RESP_STATICFILE = STATICFILE_CONTENT_TYPE;
+
+/// deprecated function: use COMPILER_VERSION constant instead
+function GetDelphiCompilerVersion: RawUtf8; deprecated;
+{$endif PUREMORMOT2}
+
+{$ifdef OSWINDOWS}
+
+{$ifdef UNICODE}
+
+const
+  /// a global constant to be appended for Windows Ansi or Wide API names
+  // - match the Wide API on Delphi, since String=UnicodeString
+  _AW = 'W';
+
+{$else}
+
+const
+  /// a global constant to be appended for Windows Ansi or Wide API names
+  // - match the Ansi API on FPC or oldest Delphi, where String=AnsiString
+  _AW = 'A';
+
+type
+  /// low-level API structure, not defined in old 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;
+  /// low-level Operating System information, as retrieved for the current process
+  OSVersionInfo: TOSVersionInfoEx;
+  /// the current Windows edition, as retrieved for the current process
+  OSVersion: TWindowsVersion;
+
+{$else OSWINDOWS}
+
+var
+  /// emulate only some used fields of Windows' TSystemInfo
+  SystemInfo: record
+    /// retrieved from libc's getpagesize() - is expected to not be 0
+    dwPageSize: cardinal;
+    /// the number of available logical CPUs
+    // - retrieved from HW_NCPU (BSD) or /proc/cpuinfo (Linux)
+    // - see CpuSockets for the number of physical CPU sockets
+    dwNumberOfProcessors: cardinal;
+    /// meaningful system information, as returned by fpuname()
+    uts: record
+      sysname, release, version: RawUtf8;
+    end;
+    /// Linux Distribution release name, retrieved from /etc/*-release
+    release: RawUtf8;
+  end;
+
+{$endif OSWINDOWS}
+
+  /// the number of physical memory bytes available to the process
+  // - equals TMemoryInfo.memtotal as retrieved from GetMemoryInfo() at startup
+  SystemMemorySize: PtrUInt;
+
+{$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, unless
+  // you define the FPCUSEVERSIONINFO conditional and information is
+  // extracted from executable resources
+  // - for the main executable, do not create once instance of this class, but
+  // call GetExecutableVersion / SetExecutableVersion and access the Executable
+  // global variable
+  TFileVersion = class
+  protected
+    fDetailed: string;
+    fFileName: TFileName;
+    fBuildDateTime: TDateTime;
+    fVersionInfo, fUserAgent: RawUtf8;
+    // change the version - returns true if supplied values are actually new
+    function SetVersion(aMajor, aMinor, aRelease, aBuild: integer): boolean;
+  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
+    CompanyName: RawUtf8;
+    /// associated FileDescription string version resource
+    FileDescription: RawUtf8;
+    /// associated FileVersion string version resource
+    FileVersion: RawUtf8;
+    /// associated InternalName string version resource
+    InternalName: RawUtf8;
+    /// associated LegalCopyright string version resource
+    LegalCopyright: RawUtf8;
+    /// associated OriginalFileName string version resource
+    OriginalFilename: RawUtf8;
+    /// associated ProductName string version resource
+    ProductName: RawUtf8;
+    /// associated ProductVersion string version resource
+    ProductVersion: RawUtf8;
+    /// associated Comments string version resource
+    Comments: RawUtf8;
+    /// associated Language Translation string version resource
+    LanguageInfo: RawUtf8;
+    /// initialize the version information, with optional custom values
+    // - will set the version numbers, and get BuildDateTime/BuildYear
+    // - call RetrieveInformationFromFileName to parse its internal resources
+    // - for the main executable, do not use this constructor, but call
+    // GetExecutableVersion / SetExecutableVersion and access the Executable
+    // global variable
+    constructor Create(const aFileName: TFileName; aMajor: integer = 0;
+      aMinor: integer = 0; aRelease: integer = 0; aBuild: integer = 0);
+    /// open and extract file information from the executable FileName
+    // - note that resource extraction is not available on POSIX, unless the
+    // FPCUSEVERSIONINFO conditional has been specified in the project options
+    function RetrieveInformationFromFileName: boolean;
+    /// retrieve the version as a 32-bit integer with Major.Minor.Release
+    // - following Major shl 16+Minor shl 8+Release bit pattern
+    function Version32: integer;
+    /// build date and time of this exe file, as plain text
+    function BuildDateTimeString: string;
+    /// version info of the exe file as '3.1.0.123' or ''
+    // - this method returns '' if Detailed is '0.0.0.0'
+    function DetailedOrVoid: string;
+    /// returns the version information of this exe file as text
+    // - includes FileName (without path), Detailed and BuildDateTime properties
+    // - e.g. 'myprogram.exe 3.1.0.123 (2016-06-14 19:07:55)'
+    function VersionInfo: RawUtf8;
+    /// returns a ready-to-use User-Agent header with exe name, version and OS
+    // - e.g. 'myprogram/3.1.0.123W32' for myprogram running on Win32
+    // - here OS_INITIAL[] character is used to identify the OS, with '32'
+    // appended on Win32 only (e.g. 'myprogram/3.1.0.2W', is for Win64)
+    // - use UserAgentParse() to decode this text into meaningful information
+    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-}
+
+/// quickly parse the TFileVersion.UserAgent content
+// - identify e.g. 'myprogram/3.1.0.2W' or 'myprogram/3.1.0.2W32' text
+function UserAgentParse(const UserAgent: RawUtf8;
+  out ProgramName, ProgramVersion: RawUtf8;
+  out OS: TOperatingSystem): boolean;
+
+type
+  /// the command line switches supported by TExecutableCommandLine
+  // - clkArg is for "exename arg1 arg2 arg3" main indexed arguments
+  // - clkOption is for "exename -o --opt1" boolean flags
+  // - clkParam is for "exename -n value --name value --name2=value2" pairs
+  TExecutableCommandLineKind = (
+    clkUndefined,
+    clkArg,
+    clkOption,
+    clkParam);
+
+  /// implements command-line arguments parsing e.g. for TExecutable.Command
+  // - call Arg() Options() and Get/Param() to define and retrieve the flags
+  // from their names and supply some description text, then call
+  // DetectUnknown and/or FullDescription to interact with the user
+  // - by default, will use -/-- switches on POSIX, and / on Windows
+  TExecutableCommandLine = class
+  protected
+    fNames: array[clkArg .. clkParam] of TRawUtf8DynArray;
+    fRawParams, fValues: TRawUtf8DynArray; // for clkParam
+    fDesc, fDescDetail: array[clkArg .. clkParam] of RawUtf8;
+    fRetrieved: array[clkArg .. clkParam] of TBooleanDynArray;
+    fDescArg: TRawUtf8DynArray;
+    fCaseSensitiveNames: boolean;
+    fSwitch: array[{long=}boolean] of RawUtf8;
+    fLineFeed, fExeDescription: RawUtf8;
+    procedure Describe(const v: array of RawUtf8;
+      k: TExecutableCommandLineKind; d, def: RawUtf8; argindex: integer);
+    function Find(const v: array of RawUtf8;
+      k: TExecutableCommandLineKind = clkUndefined; const d: RawUtf8 = '';
+      const def: RawUtf8 = ''; f: PtrInt = 0): PtrInt;
+  public
+    /// mark and describe an "arg" value by 0-based index in Args[]
+    function Arg(index: integer; const description: RawUtf8 = '';
+      optional: boolean = true): boolean; overload;
+    /// mark and describe a string/TFileName "arg" value by 0-based index in Args[]
+    function ArgString(index: integer; const description: RawUtf8 = '';
+      optional: boolean = true): string;
+    /// mark and describe an "arg" value in Args[]
+    function Arg(const name: RawUtf8;
+      const description: RawUtf8 = ''): boolean; overload;
+    /// mark and describe or or several "arg" value(s) in Args[]
+    function Arg(const name: array of RawUtf8;
+      const description: RawUtf8 = ''): boolean; overload;
+    /// search for "-optionname" switches in Options[]
+    function Option(const name: RawUtf8;
+      const description: RawUtf8 = ''): boolean; overload;
+    /// search for "-optionname" switches in Options[]
+    function Option(const name: array of RawUtf8;
+      const description: RawUtf8 = ''): boolean; overload;
+    /// search for "-parametername" and return its RawUtf8 "parametervalue"
+    function Get(const name: RawUtf8; out value: RawUtf8;
+      const description: RawUtf8 = ''; const default: RawUtf8 = ''): boolean; overload;
+    /// search for "-parametername" and return its RawUtf8 "parametervalue"
+    function Get(const name: array of RawUtf8; out value: RawUtf8;
+      const description: RawUtf8 = ''; const default: RawUtf8 = ''): boolean; overload;
+    /// search for "-parametername" and return all RawUtf8 "parametervalue" occurrences
+    function Get(const name: array of RawUtf8; out value: TRawUtf8DynArray;
+      const description: RawUtf8 = ''): boolean; overload;
+    /// search for "-parametername" and return its plain string "parametervalue"
+    function Get(const name: RawUtf8; out value: string;
+      const description: RawUtf8 = ''; const default: string = ''): boolean; overload;
+    /// search for "-parametername" and return all string "parametervalue" occurrences
+    function Get(const name: array of RawUtf8; out value: TStringDynArray;
+      const description: RawUtf8 = ''): boolean; overload;
+    /// search for "-parametername" and return its plain string "parametervalue"
+    function Get(const name: array of RawUtf8; out value: string;
+      const description: RawUtf8 = ''; const default: string = ''): boolean; overload;
+    /// search for "-parametername" and return all string "parametervalue" occurrences
+    function Get(const name: RawUtf8; out value: TStringDynArray;
+      const description: RawUtf8 = ''): boolean; overload;
+    /// search for "-parametername" and return its integer "parametervalue"
+    function Get(const name: RawUtf8; out value: integer;
+      const description: RawUtf8 = ''; default: integer = maxInt): boolean; overload;
+    /// search for "-parametername" and return its integer "parametervalue"
+    function Get(const name: array of RawUtf8; out value: integer;
+      const description: RawUtf8 = ''; default: integer = maxInt): boolean; overload;
+    /// search for "-parametername" and return its integer "parametervalue"
+    function Get(const name: RawUtf8; min, max: integer; out value: integer;
+      const description: RawUtf8 = ''; default: integer = maxInt): boolean; overload;
+    /// search for "-parametername" and return its integer "parametervalue"
+    function Get(const name: array of RawUtf8; min, max: integer;
+      out value: integer; const description: RawUtf8 = '';
+      default: integer = -1): boolean; overload;
+    /// search for "-parametername" parameter in Names[]
+    function Has(const name: RawUtf8): boolean; overload;
+    /// search for "-parametername" parameter in Names[]
+    function Has(const name: array of RawUtf8): boolean; overload;
+    /// search for "-parametername" and return '' or its RawUtf8 "parametervalue"
+    function Param(const name: RawUtf8; const description: RawUtf8 = '';
+      const default: RawUtf8 = ''): RawUtf8; overload;
+    /// search for "-parametername" and return '' or its string "parametervalue"
+    function ParamS(const name: array of RawUtf8; const description: RawUtf8 = '';
+      const default: string = ''): string;
+    /// search for "-parametername" and return '' or its RawUtf8 "parametervalue"
+    function Param(const name: array of RawUtf8; const description: RawUtf8 = '';
+      const default: RawUtf8 = ''): RawUtf8; overload;
+    /// search for "-parametername" and return its integer "parametervalue" or default
+    function Param(const name: RawUtf8; default: integer;
+      const description: RawUtf8 = ''): integer; overload;
+    /// search for "-parametername" and return its integer "parametervalue" or default
+    function Param(const name: array of RawUtf8; default: integer;
+      const description: RawUtf8 = ''): integer; overload;
+    /// generate the text from all Arg() Options() and Get/Param() descriptions
+    // and the supplied high-level description of the program
+    // - the parameter  would be extracted from any #word in the
+    // description text,
+    // - for instance:
+    // ! with Executable.Command do
+    // ! begin
+    // !   ExeDescription := 'An executable to test mORMot Execute.Command';
+    // !   verbose := Option(['v', 'verbose'], 'generate verbose output');
+    // !   Get(['t', 'threads'], threads, '#number of threads to run', 5);
+    // !   ConsoleWrite(FullDescription);
+    // ! end;
+    // will fill "verbose" and "threads" local variables, and output on Linux:
+    // $ An executable to test mORMot Execute.Command
+    // $
+    // $ Usage: mormot2tests [options] [params]
+    // $
+    // $ Options:
+    // $   -v, --verbose       generate verbose output
+    // $
+    // $ Params:
+    // $   -t, --threads  (default 5)
+    // $                       number of threads to run
+    function FullDescription(const customexedescription: RawUtf8 = '';
+      const exename: RawUtf8 = ''; const onlyusage: RawUtf8 = ''): RawUtf8;
+    /// check if the supplied parameters were all registered from previous
+    // Arg() Options() and Get/Param() calls
+    // - return '' if no unexpected flag has been supplied
+    // - return an error message like 'Unexpected --name option' otherwise
+    function DetectUnknown: RawUtf8;
+    /// call DetectUnknown and output any error message to the console
+    // - return false if the parameters are valid
+    // - otherwise, return true and caller should exit the process
+    function ConsoleWriteUnknown(const exedescription: RawUtf8 = ''): boolean;
+    /// define 'h help' and call ConsoleWriteUnknown()
+    // - caller should exit the process if this method returned true
+    function ConsoleHelpFailed(const exedescription: RawUtf8 = ''): boolean;
+    /// fill the stored arguments and options from executable parameters
+    // - called e.g. at unit inialization to set Executable.CommandLine variable
+    // - you can execute it again e.g. to customize the switches characters
+    function Parse(const DescriptionLineFeed: RawUtf8 = CRLF;
+      const ShortSwitch: RawUtf8 = {$ifdef OSWINDOWS} '/' {$else} '-' {$endif};
+      const LongSwitch: RawUtf8 = {$ifdef OSWINDOWS} '/' {$else} '--' {$endif}): boolean;
+    /// remove all recognized arguments and switches
+    procedure Clear;
+    /// internal method returning a switch text from its identifier
+    function SwitchAsText(const v: RawUtf8): RawUtf8;
+    /// the ParamStr(1..ParamCount) arguments as RawUtf8, excluding Options[]
+    // switches and Params[]/Values[] parameters
+    property Args: TRawUtf8DynArray
+      read fNames[clkArg];
+    /// the "-optionname" boolean switches as stored in ParamStr()
+    property Options: TRawUtf8DynArray
+      read fNames[clkOption];
+    /// the names of "-parametername parametervalue" as stored in ParamStr()
+    // - mapping the Values[] associated array
+    property Names: TRawUtf8DynArray
+      read fNames[clkParam];
+    /// the values of "-parametername parametervalue" as stored in ParamStr()
+    // - mapping the Names[] associated array
+    property Values: TRawUtf8DynArray
+      read fValues;
+    /// if search within Args[] Options[] or Names[] should be case-sensitive
+    property CaseSensitiveNames: boolean
+      read fCaseSensitiveNames write fCaseSensitiveNames;
+    /// set a text which describes the executable
+    // - as used by default by FullDescription() and ConsoleWriteUnknown()
+    property ExeDescription: RawUtf8
+      read fExeDescription write fExeDescription;
+    /// DescriptionLineFeed value from TExecutableCommandLine.Parse()
+    property LineFeed: RawUtf8
+      read fLineFeed write fLineFeed;
+    /// map ParamStr(1 .. ParamCount) values, encoded as RawUtf8
+    // - may be used e.g. for regression tests instead of ParamStr()
+    property RawParams: TRawUtf8DynArray
+      read fRawParams write fRawParams;
+  end;
+
+  /// stores some global information about the current executable and computer
+  // - as set at unit initialization into the Executable global variable
+  TExecutable = record
+    /// the main executable name, without any path nor extension
+    // - e.g. 'Test' for 'c:\pathto\Test.exe'
+    ProgramName: RawUtf8;
+    /// the main executable details, as used e.g. by TSynLog
+    // - e.g. 'C:\Dev\lib\SQLite3\exe\TestSQL3.exe 1.2.3.123 (2011-03-29 11:09:06)'
+    // - you should have called GetExecutableVersion or SetExecutableVersion
+    // to populate this field
+    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
+    // - you should have called GetExecutableVersion or SetExecutableVersion
+    // to populate this field
+    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 TExecutable 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;
+    /// the Command Line arguments, parsed during unit initialization
+    Command: TExecutableCommandLine;
+  end;
+
+var
+  /// global information about the current executable and computer
+  // - this structure is initialized in this unit's initialization block below
+  // but you need to call GetExecutableVersion to initialize its Version fields
+  // from the executable version resource (if any)
+  // - you can call SetExecutableVersion() with a custom version, if needed
+  Executable: TExecutable;
+
+  {$ifndef PUREMORMOT2}
+  /// deprecated global: use Executable variable instead
+  ExeVersion: TExecutable absolute Executable;
+  {$endif PUREMORMOT2}
+
+/// initialize Executable global variable, from the program version resources
+// - is not retrieved at startup, unless this function is especially called
+// - on POSIX, requires FPCUSEVERSIONINFO conditional to be set for the project
+// - use SetExecutableVersion() if you want to force a custom version
+// - is in fact just a wrapper around SetExecutableVersion(0, 0, 0, 0)
+procedure GetExecutableVersion;
+
+/// initialize Executable global variable with custom version numbers
+// - GetExecutableVersion will retrieve version information from the
+// executable itself (if it was included at build time and FPCUSEVERSIONINFO
+// conditional was specified for the project)
+// - but you can use this function to set any custom version number
+procedure SetExecutableVersion(aMajor, aMinor, aRelease, aBuild: integer); overload;
+
+/// initialize Executable global variable, supplying the version as text
+// - e.g. SetExecutableVersion('7.1.2.512');
+procedure SetExecutableVersion(const aVersionText: RawUtf8); overload;
+
+/// return a function/method location according to the supplied code address
+// - returns the address as hexadecimal by default, e.g. '004cb765'
+// - if mormot.core.log.pas is defined in the project, will redirect to
+// TDebugFile.FindLocationShort() method using .map/.dbg/.mab information, and
+// return filename, symbol name and line number (if any) as plain text, e.g.
+// '4cb765 ../src/core/mormot.core.base.pas statuscodeissuccess (11183)' on FPC
+var
+  GetExecutableLocation: function(aAddress: pointer): ShortString;
+
+/// try to retrieve the file name of the executable/library holding a function
+// - calls dladdr() on POSIX, or GetModuleFileName() on Windows
+function GetExecutableName(aAddress: pointer): TFileName;
+
+var
+  /// retrieve the MAC addresses of all hardware network adapters
+  // - mormot.net.sock.pas will inject here its own cross-platform version
+  // - this unit will include a simple parser of /sys/class/net/* for Linux only
+  // - as used e.g. by GetComputerUuid() fallback if SMBIOS is not available
+  GetSystemMacAddress: function: TRawUtf8DynArray;
+
+
+type
+  /// identify an operating system folder for GetSystemPath()
+  // - on Windows, spCommonData maps e.g. 'C:\ProgramData',
+  // spUserData points to 'C:\Users\\AppData\Local',
+  // spCommonDocuments to 'C:\Users\Public\Documents',
+  // spUserDocuments to 'C:\Users\\Documents',
+  // spTemp will call GetTempPath() or read the $TEMP environment variable,
+  // pointing typically to 'C:\Users\\AppData\Local\Temp\',
+  // and spLog either to '\log' or
+  // 'C:\Users\\AppData\Local\-log' (the first writable)
+  // - on POSIX, spTemp will use $TMPDIR/$TMP environment variables,
+  // spCommonData, spCommonDocuments and spUserDocuments point to $HOME,
+  // spUserData maps $XDG_CACHE_HOME or '$HOME/.cache' or '$TMP/', and
+  // spLog maps '/var/log/' or '/log' or '$TMP/-log'
+  // - on all systems, returned spTemp, spLog and spUserData folders are always
+  // writable by the current user
+  TSystemPath = (
+    spCommonData,
+    spUserData,
+    spCommonDocuments,
+    spUserDocuments,
+    spTemp,
+    spLog);
+
+{$ifndef PUREMORMOT2}
+const
+  spTempFolder = spTemp;
+{$endif PUREMORMOT2}
+
+/// 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 the proper environment variable
+// - spLog is a writable sub-folder specific to mORMot, always created if needed
+// - returned folder name contains the trailing path delimiter (\ or /)
+function GetSystemPath(kind: TSystemPath): TFileName;
+
+/// force an operating system folder
+// - if the default location is not good enough for your project
+// - will just check that the directory exists, not that it is writable
+function SetSystemPath(kind: TSystemPath; const path: TFileName): boolean;
+
+type
+  /// identify the (Windows) system certificate stores for GetSystemStoreAsPem()
+  // - ignored on POSIX systems, in which the main cacert.pem file is used
+  // - scsCA contains known Certification Authority certificates, i.e. from
+  // entities entrusted to issue certificates that assert that the recipient
+  // individual, computer, or organization requesting the certificate fulfills
+  // the conditions of an established policy
+  // - scsMY holds certificates with associated private keys (Windows only)
+  // - scsRoot contains known Root certificates, i.e. self-signed CA certificates
+  // which are the root of the whole certificates trust tree
+  // - scsSpc contains Software Publisher Certificates (Windows only)
+  TSystemCertificateStore = (
+    scsCA,
+    scsMY,
+    scsRoot,
+    scsSpc);
+  TSystemCertificateStores = set of TSystemCertificateStore;
+
+var
+  /// the local PEM file name to be searched by GetSystemStoreAsPem() to
+  // override the OS certificates store
+  // - a relative file name (i.e. with no included path, e.g. 'cacert.pem') will
+  // be searched in the Executable.ProgramFilePath folder
+  // - an absolute file name (e.g. 'C:\path\to\file.pem' or '/posix/path') could
+  // also be specified
+  // - set by default to '' to disable this override (for security purposes)
+  GetSystemStoreAsPemLocalFile: TFileName;
+
+/// retrieve the OS certificates store as PEM text
+// - first search for [Executable.ProgramFilePath+]GetSystemStoreAsPemLocalFile,
+// then for a file pointed by a 'SSL_CA_CERT_FILE' environment variable - unless
+// OnlySystemStore is forced to true
+// - if no such file exists, or if OnlySystemStore is true, will concatenate the
+// supplied CertStores values via individual GetOneSystemStoreAsPem() calls
+// - return CA + ROOT certificates by default, ready to validate a certificate
+// - Darwin specific API is not supported yet, and is handled as a BSD system
+// - an internal cache is refreshed every 4 minutes unless FlushCache is set
+function GetSystemStoreAsPem(
+  CertStores: TSystemCertificateStores = [scsCA, scsRoot];
+  FlushCache: boolean = false; OnlySystemStore: boolean = false): RawUtf8;
+
+/// retrieve all certificates of a given system store as PEM text
+// - on Windows, will use the System Crypt API
+// - on POSIX, scsRoot loads the main CA file of the known system file, and
+// scsCA the additional certificate files which may not be part of the main file
+// - GetSystemStoreAsPemLocalFile file and 'SSL_CA_CERT_FILE' environment
+// variables are ignored: call GetSystemStoreAsPem() instead for the global store
+// - an internal cache is refreshed every 4 minutes unless FlushCache is set
+function GetOneSystemStoreAsPem(CertStore: TSystemCertificateStore;
+  FlushCache: boolean = false; now: cardinal = 0): RawUtf8;
+
+type
+  /// the raw SMBIOS information as filled by GetRawSmbios
+  // - first 4 bytes are $010003ff on POSIX if read from /var/tmp/.synopse.smb
+  TRawSmbiosInfo = record
+    /// some flag only set by GetSystemFirmwareTable() Windows API
+    Reserved: byte;
+    /// typically 2-3
+    SmbMajorVersion: byte;
+    /// typically 0-1
+    SmbMinorVersion: byte;
+    /// typically 0 for SMBIOS 2.1, 1 for SMBIOS 3.0
+    DmiRevision: byte;
+    /// the length of encoded binary in data
+    Length: DWORD;
+    /// low-level binary of the SMBIOS Structure Table
+    Data: RawByteString;
+  end;
+
+var
+  /// global variable filled by GetRawSmbios from SMBIOS binary information
+  RawSmbios: TRawSmbiosInfo;
+
+/// retrieve the SMBIOS raw information as a single RawSmbios gloabl binary blob
+// - will try the Windows API if available, or search and parse the main system
+// memory with UEFI redirection if needed - via /systab system file on Linux, or
+// kenv() on FreeBSD (only fully tested to work on Windows XP+ and Linux)
+// - follow DSP0134 3.6.0 System Management BIOS (SMBIOS) Reference Specification
+// with both SMBIOS 2.1 (32-bit) or SMBIOS 3.0 (64-bit) entry points
+// - the current user should have enough rights to read the main system memory,
+// which means it should be root on most POSIX Operating Systems - so we persist
+// this raw binary in /var/tmp/.synopse.smb to retrieve it from non-root user
+function GetRawSmbios: boolean;
+
+type
+  /// the basic SMBIOS fields supported by GetSmbios/DecodeSmbios functions
+  // - only include the first occurrence for board/cpu/battery types
+  // - see TSmbiosInfo in mormot.core.perf.pas for more complete decoding
+  TSmbiosBasicInfo = (
+    sbiUndefined,
+    sbiBiosVendor,
+    sbiBiosVersion,
+    sbiBiosFirmware,
+    sbiBiosRelease,
+    sbiBiosDate,
+    sbiManufacturer,
+    sbiProductName,
+    sbiVersion,
+    sbiSerial,
+    sbiUuid,
+    sbiSku,
+    sbiFamily,
+    sbiBoardManufacturer,
+    sbiBoardProductName,
+    sbiBoardVersion,
+    sbiBoardSerial,
+    sbiBoardAssetTag,
+    sbiBoardLocation,
+    sbiCpuManufacturer,
+    sbiCpuVersion,
+    sbiCpuSerial,
+    sbiCpuAssetTag,
+    sbiCpuPartNumber,
+    sbiBatteryLocation,
+    sbiBatteryManufacturer,
+    sbiBatteryName,
+    sbiBatteryVersion,
+    sbiBatteryChemistry,
+    sbiOem
+  );
+
+  /// the text fields stored by GetSmbios/DecodeSmbios functions
+  TSmbiosBasicInfos = array[TSmbiosBasicInfo] of RawUtf8;
+
+/// decode basic SMBIOS information as text from a TRawSmbiosInfo binary blob
+// - see DecodeSmbiosInfo() in mormot.core.perf.pas for a more complete decoder
+// - returns the total size of DMI/SMBIOS information in raw.data (may be lower)
+// - will also adjust raw.Length and truncate raw.Data to the actual useful size
+function DecodeSmbios(var raw: TRawSmbiosInfo; out info: TSmbiosBasicInfos): PtrInt;
+
+// some global definitions for proper caching and inlining of GetSmbios()
+procedure ComputeGetSmbios;
+procedure DecodeSmbiosUuid(src: PGuid; out dest: RawUtf8; const raw: TRawSmbiosInfo);
+var
+  _Smbios: TSmbiosBasicInfos;
+  _SmbiosRetrieved: boolean;
+
+  /// customize how DecodeSmbiosUuid() handle endianess of its first bytes
+  // - sduDirect will directly use GUIDToString() layout (seems expected on
+  // Windows to match "wmic csproduct get uuid" value)
+  // - sduInvert will force first values inversion (mandatory on MacOS)
+  // - sduVersion will invert for SMBios version < 2.6 (set outside Windows)
+  _SmbiosDecodeUuid: (sduDirect, sduInvert, sduVersion)
+    {$ifdef OSDARWIN}  = sduInvert  {$else}
+      {$ifdef OSPOSIX} = sduVersion {$endif} {$endif};
+
+/// retrieve SMBIOS information as text
+// - only the main values are decoded - see GetSmbiosInfo in mormot.core.perf
+// for a more complete DMI/SMBIOS decoder
+// - on POSIX, requires root to access full SMBIOS information - will fallback
+// reading /sys/class/dmi/id/* on Linux or kenv() on FreeBSD for most entries
+// if we found no previous root-retrieved cache in local /var/tmp/.synopse.smb
+// - see _SmbiosDecodeUuid global flag for UUID decoding
+function GetSmbios(info: TSmbiosBasicInfo): RawUtf8;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// retrieve a genuine 128-bit UUID identifier for this computer
+// - first try GetSmbios(sbiUuid), i.e. the SMBIOS System UUID
+// - otherwise, will compute a genuine hash from known hardware information
+// (CPU, Bios, MAC) and store it in a local file for the next access, e.g. into
+// '/var/tmp/.synopse.uid' on POSIX
+// - on Mac, include the mormot.core.os.mac unit to properly read this UUID
+// - note: some BIOS have no UUID, so we fallback to our hardware hash on those
+procedure GetComputerUuid(out uuid: TGuid);
+
+
+{ ****************** Operating System Specific Types (e.g. TWinRegistry) }
+
+{$ifdef OSWINDOWS}
+
+type
+  TThreadID     = DWORD;
+  TMessage      = Messages.TMessage;
+  HWND          = Windows.HWND;
+  BOOL          = Windows.BOOL;
+  LARGE_INTEGER = Windows.LARGE_INTEGER;
+  TFileTime     = Windows.FILETIME;
+  PFileTime     = ^TFileTime;
+
+  /// the known Windows Registry Root key used by TWinRegistry.ReadOpen
+  TWinRegistryRoot = (
+    wrClasses,
+    wrCurrentUser,
+    wrLocalMachine,
+    wrUsers);
+
+  /// direct access to the Windows Registry
+  // - could be used as alternative to TRegistry, which doesn't behave the same on
+  // all Delphi versions, and is enhanced on FPC (e.g. which supports REG_MULTI_SZ)
+  // - is also Unicode ready for text, using UTF-8 conversion on all compilers
+  {$ifdef USERECORDWITHMETHODS}
+  TWinRegistry = record
+  {$else}
+  TWinRegistry = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// the opened HKEY handle
+    key: HKEY;
+    /// start low-level read access to a Windows Registry node
+    // - on success (returned true), Close method should be eventually called
+    function ReadOpen(root: TWinRegistryRoot; const keyname: RawUtf8;
+      closefirst: boolean = false): boolean;
+    /// finalize low-level read access to the Windows Registry after ReadOpen()
+    procedure Close;
+    /// read a UTF-8 string from the Windows Registry after ReadOpen()
+    // - in respect to Delphi's TRegistry, will properly handle REG_MULTI_SZ
+    // (return the first value of the multi-list) - use ReadData to retrieve
+    // all REG_MULTI_SZ values as one blob
+    // - we don't use string here since it would induce a dependency to
+    // mormot.core.unicode
+    function ReadString(const entry: SynUnicode; andtrim: boolean = true): RawUtf8;
+    /// read a Windows Registry content after ReadOpen()
+    // - works with any kind of key, but was designed for REG_BINARY
+    function ReadData(const entry: SynUnicode): RawByteString;
+    /// read a Windows Registry 32-bit REG_DWORD value after ReadOpen()
+    function ReadDword(const entry: SynUnicode): cardinal;
+    /// read a Windows Registry 64-bit REG_QWORD value after ReadOpen()
+    function ReadQword(const entry: SynUnicode): QWord;
+    /// read a Windows Registry content as binary buffer after ReadOpen()
+    // - just a wrapper around RegQueryValueExW() API call
+    function ReadBuffer(const entry: SynUnicode; Data: pointer; DataLen: DWORD): boolean;
+    /// retrieve a Windows Registry content size as binary bytes after ReadOpen()
+    // - returns -1 if the entry is not found
+    function ReadSize(const entry: SynUnicode): integer;
+    /// enumeration of all sub-entries names of a Windows Registry key
+    function ReadEnumEntries: TRawUtf8DynArray;
+  end;
+
+  /// TSynWindowsPrivileges enumeration synchronized with WinAPI
+  // - see https://docs.microsoft.com/en-us/windows/desktop/secauthz/privilege-constants
+  TWinSystemPrivilege = (
+    wspCreateToken,
+    wspAssignPrimaryToken,
+    wspLockMemory,
+    wspIncreaseQuota,
+    wspUnsolicitedInput,
+    wspMachineAccount,
+    wspTCP,
+    wspSecurity,
+    wspTakeOwnership,
+    wspLoadDriver,
+    wspSystemProfile,
+    wspSystemTime,
+    wspProfSingleProcess,
+    wspIncBasePriority,
+    wspCreatePageFile,
+    wspCreatePermanent,
+    wspBackup,
+    wspRestore,
+    wspShutdown,
+    wspDebug,
+    wspAudit,
+    wspSystemEnvironment,
+    wspChangeNotify,
+    wspRemoteShutdown,
+    wspUndock,
+    wspSyncAgent,
+    wspEnableDelegation,
+    wspManageVolume,
+    wspImpersonate,
+    wspCreateGlobal,
+    wspTrustedCredmanAccess,
+    wspRelabel,
+    wspIncWorkingSet,
+    wspTimeZone,
+    wspCreateSymbolicLink);
+
+  /// TSynWindowsPrivileges set synchronized with WinAPI
+  TWinSystemPrivileges = set of TWinSystemPrivilege;
+
+  /// define which WinAPI token is to be retrieved
+  // - define the execution context, i.e. if the token is used for the current
+  // process or the current thread
+  // - used e.g. by TSynWindowsPrivileges or CurrentSid()
+  TWinTokenType = (
+    wttProcess,
+    wttThread);
+
+  /// manage available privileges on Windows platform
+  // - not all available privileges are active for all process
+  // - for usage of more advanced WinAPI, explicit enabling of privilege is
+  // sometimes needed
+  {$ifdef USERECORDWITHMETHODS}
+  TSynWindowsPrivileges = record
+  {$else}
+  TSynWindowsPrivileges = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    fAvailable: TWinSystemPrivileges;
+    fEnabled: TWinSystemPrivileges;
+    fDefEnabled: TWinSystemPrivileges;
+    fToken: THandle;
+    function SetPrivilege(wsp: TWinSystemPrivilege; on: boolean): boolean;
+    procedure LoadPrivileges;
+  public
+    /// initialize the object dedicated to management of available privileges
+    // - aTokenPrivilege can be used for current process or current thread
+    procedure Init(aTokenPrivilege: TWinTokenType = wttProcess;
+      aLoadPrivileges: boolean = true);
+    /// finalize the object and relese Token handle
+    // - aRestoreInitiallyEnabled parameter can be used to restore initially
+    // state of enabled privileges
+    procedure Done(aRestoreInitiallyEnabled: boolean = true);
+    /// enable privilege
+    // - if aPrivilege is already enabled return true, if operation is not
+    // possible (required privilege doesn't exist or API error) return false
+    function Enable(aPrivilege: TWinSystemPrivilege): boolean;
+    /// disable privilege
+    // - if aPrivilege is already disabled return true, if operation is not
+    // possible (required privilege doesn't exist or API error) return false
+    function Disable(aPrivilege: TWinSystemPrivilege): boolean;
+    /// set of available privileges for current process/thread
+    property Available: TWinSystemPrivileges
+      read fAvailable;
+    /// set of enabled privileges for current process/thread
+    property Enabled: TWinSystemPrivileges
+      read fEnabled;
+    /// low-level access to the privileges token handle
+    property Token: THandle
+      read fToken;
+  end;
+
+  /// which information was returned by GetProcessInfo() overloaded functions
+  // - wpaiPID is set when PID was retrieved
+  // - wpaiBasic with ParentPID/BasePriority/ExitStatus/PEBBaseAddress/AffinityMask
+  // - wpaiPEB with SessionID/BeingDebugged
+  // - wpaiCommandLine and wpaiImagePath when CommandLine and ImagePath are set
+  TWinProcessAvailableInfos = set of (
+    wpaiPID,
+    wpaiBasic,
+    wpaiPEB,
+    wpaiCommandLine,
+    wpaiImagePath);
+
+  /// information returned by GetProcessInfo() overloaded functions
+  TWinProcessInfo = record
+    /// which information was returned within this structure
+    AvailableInfo: TWinProcessAvailableInfos;
+    /// the Process ID
+    PID: cardinal;
+    /// the Parent Process ID
+    ParentPID: cardinal;
+    /// Terminal Services session identifier associated with this process
+    SessionID: cardinal;
+    /// points to the low-level internal PEB structure
+    // - you can not directly access this memory, unless ReadProcessMemory()
+    // with proper wspDebug priviledge API is called
+    PEBBaseAddress: pointer;
+    /// GetProcessAffinityMask-like value
+    AffinityMask: cardinal;
+    /// process priority
+    BasePriority: integer;
+    /// GetExitCodeProcess-like value
+    ExitStatus: integer;
+    /// indicates whether the specified process is currently being debugged
+    BeingDebugged: byte;
+    /// command-line string passed to the process
+    CommandLine: SynUnicode;
+    /// path of the image file for the process
+    ImagePath: SynUnicode;
+  end;
+
+  PWinProcessInfo = ^TWinProcessInfo;
+  TWinProcessInfoDynArray = array of TWinProcessInfo;
+
+  /// the SID types, as recognized by LookupSid()
+  TSidType = (
+    stUndefined,
+    stTypeUser,
+    stTypeGroup,
+    stTypeDomain,
+    stTypeAlias,
+    stTypeWellKnownGroup,
+    stTypeDeletedAccount,
+    stTypeInvalid,
+    stTypeUnknown,
+    stTypeComputer,
+    stTypeLabel,
+    stTypeLogonSession);
+
+
+function ToText(p: TWinSystemPrivilege): PShortString; overload;
+
+/// calls OpenProcessToken() or OpenThreadToken() to get the current token
+// - caller should then run CloseHandle() once done with the Token handle
+function RawTokenOpen(wtt: TWinTokenType; access: cardinal): THandle;
+
+/// low-level retrieveal of raw binary information for a given token
+// - returns the number of bytes retrieved into buf.buf
+// - caller should then run buf.Done to release the buf result memory
+function RawTokenGetInfo(tok: THandle; tic: TTokenInformationClass;
+  var buf: TSynTempBuffer): cardinal;
+
+/// return the SID of a given token, nil if none found
+// - the returned PSid is located within buf temporary buffer
+// - so caller should call buf.Done once this PSid value is not needed any more
+function RawTokenSid(tok: THandle; var buf: TSynTempBuffer): PSid;
+
+/// return the group SIDs of a given token, nil if none found
+// - the returned PSid is located within buf temporary buffer
+// - so caller should call buf.Done once this PSid value is not needed any more
+function RawTokenGroups(tok: THandle; var buf: TSynTempBuffer): PSids;
+
+/// return the group SIDs of a given token as text dynamic array
+function TokenGroupsText(tok: THandle): TRawUtf8DynArray;
+
+/// check if a group SID is part of a given token
+function TokenHasGroup(tok: THandle; sid: PSid): boolean;
+
+/// check if any group SID is part of a given token
+function TokenHasAnyGroup(tok: THandle; const sid: RawSidDynArray): boolean;
+
+/// return the SID of the current user, from process or thread, as text
+// - e.g. 'S-1-5-21-823746769-1624905683-418753922-1000'
+// - optionally returning the name and domain via LookupSid()
+function CurrentSid(wtt: TWinTokenType = wttProcess;
+  name: PRawUtf8 = nil; domain: PRawUtf8 = nil): RawUtf8; overload;
+
+/// return the SID of the current user, from process or thread, as raw binary
+procedure CurrentRawSid(out sid: RawSid; wtt: TWinTokenType = wttProcess;
+  name: PRawUtf8 = nil; domain: PRawUtf8 = nil); overload;
+
+/// return the SID of the current user groups, from process or thread, as text
+function CurrentGroupsSid(wtt: TWinTokenType = wttProcess): TRawUtf8DynArray;
+
+/// recognize the well-known SIDs from the current user, from process or thread
+// - for instance, for an user with administrator rights on Windows, returns
+// $ [wksWorld, wksLocal, wksConsoleLogon, wksIntegrityHigh, wksInteractive,
+// $  wksAuthenticatedUser, wksThisOrganisation, wksBuiltinAdministrators,
+// $  wksBuiltinUsers, wksNtlmAuthentication]
+function CurrentKnownGroups(wtt: TWinTokenType = wttProcess): TWellKnownSids;
+
+/// fast check if the current user, from process or thread, has a well-known group SID
+// - e.g. CurrentUserHasGroup(wksLocalSystem) returns true for LOCAL_SYSTEM user
+function CurrentUserHasGroup(wks: TWellKnownSid;
+  wtt: TWinTokenType = wttProcess): boolean; overload;
+
+/// fast check if the current user, from process or thread, has a given group SID
+function CurrentUserHasGroup(const sid: RawUtf8;
+  wtt: TWinTokenType = wttProcess): boolean; overload;
+
+/// fast check if the current user, from process or thread, has a given group SID
+function CurrentUserHasGroup(sid: PSid;
+  wtt: TWinTokenType = wttProcess): boolean; overload;
+
+/// fast check if the current user, from process or thread, has any given group SID
+function CurrentUserHasAnyGroup(const sid: RawSidDynArray;
+  wtt: TWinTokenType = wttProcess): boolean;
+
+/// fast check if the current user, from process or thread, match a group by name
+// - calls LookupSid() on each group SID of this user, and filter with name/domain
+function CurrentUserHasGroup(const name, domain, server: RawUtf8;
+  wtt: TWinTokenType = wttProcess): boolean; overload;
+
+/// just a wrapper around CurrentUserHasGroup(wksBuiltinAdministrators)
+function CurrentUserIsAdmin: boolean;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// rough detection of 'c:\windows' and 'c:\program files' folders
+function IsSystemFolder(const Folder: TFileName): boolean;
+
+// check if a folder may be affected by UAC folder virtualization
+// - on Win32 Vista+, detects 'c:\windows' and 'c:\program files' UAC folders
+// - returns always false on Win64
+function IsUacVirtualFolder(const Folder: TFileName): boolean;
+  {$ifdef CPU64} inline; {$endif}
+
+/// check if UAC folder/registry virtualization is enabled for this process
+// - returns always false on Win64 - by design
+// - calls GetTokenInformation(TokenVirtualizationEnabled) on Win32
+// - if you include {$R src\mormot.win.default.manifest.res} in your project,
+// UAC virtualization is disabled and this function returns false
+function IsUacVirtualizationEnabled: boolean;
+  {$ifdef CPU64} inline; {$endif}
+
+/// retrieve the name and domain of a given SID
+// - returns stUndefined if the SID could not be resolved by LookupAccountSid()
+function LookupSid(sid: PSid; out name, domain: RawUtf8;
+  const server: RawUtf8 = ''): TSidType; overload;
+
+/// retrieve the name and domain of a given SID, encoded from text
+// - returns stUndefined if the SID could not be resolved by LookupAccountSid()
+function LookupSid(const sid: RawUtf8; out name, domain: RawUtf8;
+  const server: RawUtf8 = ''): TSidType; overload;
+
+/// retrieve the name and domain of a given Token
+function LookupToken(tok: THandle; out name, domain: RawUtf8;
+  const server: RawUtf8 = ''): boolean; overload;
+
+/// retrieve the 'domain\name' combined value of a given Token
+function LookupToken(tok: THandle; const server: RawUtf8 = ''): RawUtf8; overload;
+
+/// retrieve low-level process information, from the Windows API
+procedure GetProcessInfo(aPid: cardinal; out aInfo: TWinProcessInfo); overload;
+
+/// retrieve low-level process(es) information, from the Windows API
+procedure GetProcessInfo(const aPidList: TCardinalDynArray;
+  out aInfo: TWinProcessInfoDynArray); overload;
+
+/// quickly retrieve a Text value from Registry
+// - could be used if TWinRegistry is not needed, e.g. for a single value
+function ReadRegString(Key: THandle; const Path, Value: string): string;
+
+/// convenient late-binding of any external library function
+// - just wrapper around LoadLibray + GetProcAddress once over a pointer
+function DelayedProc(var api; var lib: THandle;
+  libname: PChar; procname: PAnsiChar): boolean;
+
+type
+  HCRYPTPROV = pointer;
+  HCRYPTKEY = pointer;
+  HCRYPTHASH = pointer;
+  HCERTSTORE = pointer;
+
+  CRYPTOAPI_BLOB = record
+    cbData: DWORD;
+    pbData: PByteArray;
+  end;
+  CRYPT_INTEGER_BLOB = CRYPTOAPI_BLOB;
+  CERT_NAME_BLOB     = CRYPTOAPI_BLOB;
+  CRYPT_OBJID_BLOB   = CRYPTOAPI_BLOB;
+
+  CRYPT_BIT_BLOB = record
+    cbData: DWORD;
+    pbData: PByteArray;
+    cUnusedBits: DWORD;
+  end;
+
+  CRYPT_ALGORITHM_IDENTIFIER = record
+    pszObjId: PAnsiChar;
+    Parameters: CRYPT_OBJID_BLOB;
+  end;
+
+  CERT_PUBLIC_KEY_INFO = record
+    Algorithm: CRYPT_ALGORITHM_IDENTIFIER;
+    PublicKey: CRYPT_BIT_BLOB;
+  end;
+
+  CERT_EXTENSION = record
+    pszObjId: PAnsiChar;
+    fCritical: BOOL;
+    Blob: CRYPT_OBJID_BLOB;
+  end;
+  PCERT_EXTENSION = ^CERT_EXTENSION;
+  CERT_EXTENSIONS = array[word] of CERT_EXTENSION;
+  PCERT_EXTENSIONS = ^CERT_EXTENSIONS;
+
+  CERT_INFO = record
+    dwVersion: DWORD;
+    SerialNumber: CRYPT_INTEGER_BLOB;
+    SignatureAlgorithm: CRYPT_ALGORITHM_IDENTIFIER;
+    Issuer: CERT_NAME_BLOB;
+    NotBefore: TFileTime;
+    NotAfter: TFileTime;
+    Subject: CERT_NAME_BLOB;
+    SubjectPublicKeyInfo: CERT_PUBLIC_KEY_INFO;
+    IssuerUniqueId: CRYPT_BIT_BLOB;
+    SubjectUniqueId: CRYPT_BIT_BLOB;
+    cExtension: DWORD;
+    rgExtension: PCERT_EXTENSIONS;
+  end;
+  PCERT_INFO = ^CERT_INFO;
+
+  CERT_CONTEXT = record
+    dwCertEncodingType: DWORD;
+    pbCertEncoded: PByte;
+    cbCertEncoded: DWORD;
+    pCertInfo: PCERT_INFO;
+    hCertStore: HCERTSTORE;
+  end;
+  PCCERT_CONTEXT = ^CERT_CONTEXT;
+  PPCCERT_CONTEXT = ^PCCERT_CONTEXT;
+
+  CRYPT_KEY_PROV_PARAM = record
+    dwParam: DWORD;
+    pbData: PByte;
+    cbData: DWORD;
+    dwFlags: DWORD;
+  end;
+  PCRYPT_KEY_PROV_PARAM = ^CRYPT_KEY_PROV_PARAM;
+
+  CRYPT_KEY_PROV_INFO = record
+    pwszContainerName: PWideChar;
+    pwszProvName: PWideChar;
+    dwProvType: DWORD;
+    dwFlags: DWORD;
+    cProvParam: DWORD;
+    rgProvParam: PCRYPT_KEY_PROV_PARAM;
+    dwKeySpec: DWORD;
+  end;
+  PCRYPT_KEY_PROV_INFO = ^CRYPT_KEY_PROV_INFO;
+
+  CRYPT_OID_INFO = record
+    cbSize: DWORD;
+    pszOID: PAnsiChar;
+    pwszName: PWideChar;
+    dwGroupId: DWORD;
+    Union: record
+      case integer of
+        0: (dwValue: DWORD);
+        1: (Algid: DWORD);
+        2: (dwLength: DWORD);
+    end;
+    ExtraInfo: CRYPTOAPI_BLOB;
+  end;
+  PCRYPT_OID_INFO = ^CRYPT_OID_INFO;
+
+  PCCRL_CONTEXT = pointer;
+  PPCCRL_CONTEXT = ^PCCRL_CONTEXT;
+  PCRYPT_ATTRIBUTE = pointer;
+
+  CRYPT_SIGN_MESSAGE_PARA = record
+    cbSize: DWORD;
+    dwMsgEncodingType: DWORD;
+    pSigningCert: PCCERT_CONTEXT;
+    HashAlgorithm: CRYPT_ALGORITHM_IDENTIFIER;
+    pvHashAuxInfo: Pointer;
+    cMsgCert: DWORD;
+    rgpMsgCert: PPCCERT_CONTEXT;
+    cMsgCrl: DWORD;
+    rgpMsgCrl: PPCCRL_CONTEXT;
+    cAuthAttr: DWORD;
+    rgAuthAttr: PCRYPT_ATTRIBUTE;
+    cUnauthAttr: DWORD;
+    rgUnauthAttr: PCRYPT_ATTRIBUTE;
+    dwFlags: DWORD;
+    dwInnerContentType: DWORD;
+    HashEncryptionAlgorithm: CRYPT_ALGORITHM_IDENTIFIER;
+    pvHashEncryptionAuxInfo: Pointer;
+  end;
+
+  PFN_CRYPT_GET_SIGNER_CERTIFICATE = function(pvGetArg: Pointer;
+    dwCertEncodingType: DWORD; pSignerId: PCERT_INFO;
+    hMsgCertStore: HCERTSTORE): PCCERT_CONTEXT; stdcall;
+  CRYPT_VERIFY_MESSAGE_PARA = record
+    cbSize: DWORD;
+    dwMsgAndCertEncodingType: DWORD;
+    hCryptProv: HCRYPTPROV;
+    pfnGetSignerCertificate: PFN_CRYPT_GET_SIGNER_CERTIFICATE;
+    pvGetArg: Pointer;
+  end;
+
+  /// direct access to the Windows CryptoApi
+  {$ifdef USERECORDWITHMETHODS}
+  TWinCryptoApi = record
+  {$else}
+  TWinCryptoApi = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    /// if the presence of this API has been tested
+    Tested: boolean;
+    /// if this API has been loaded
+    Handle: THandle;
+    /// used when inlining Available method
+    procedure Resolve;
+  public
+    /// acquire a handle to a particular key container within a
+    // particular cryptographic service provider (CSP)
+    AcquireContextA: function(var phProv: HCRYPTPROV; pszContainer: PAnsiChar;
+      pszProvider: PAnsiChar; dwProvType: DWORD; dwFlags: DWORD): BOOL; stdcall;
+    /// releases the handle of a cryptographic service provider (CSP) and a
+    // key container
+    ReleaseContext: function(hProv: HCRYPTPROV; dwFlags: PtrUInt): BOOL; stdcall;
+    /// transfers a cryptographic key from a key BLOB into a cryptographic
+    // service provider (CSP)
+    ImportKey: function(hProv: HCRYPTPROV; pbData: pointer; dwDataLen: DWORD;
+      hPubKey: HCRYPTKEY; dwFlags: DWORD; var phKey: HCRYPTKEY): BOOL; stdcall;
+    /// customizes various aspects of a session key's operations
+    SetKeyParam: function(hKey: HCRYPTKEY; dwParam: DWORD; pbData: pointer;
+      dwFlags: DWORD): BOOL; stdcall;
+    /// releases the handle referenced by the hKey parameter
+    DestroyKey: function(hKey: HCRYPTKEY): BOOL; stdcall;
+    /// encrypt the data designated by the key held by the CSP module
+    // referenced by the hKey parameter
+    Encrypt: function(hKey: HCRYPTKEY; hHash: HCRYPTHASH; Final: BOOL;
+      dwFlags: DWORD; pbData: pointer; var pdwDataLen: DWORD; dwBufLen: DWORD): BOOL; stdcall;
+    /// decrypts data previously encrypted by using the CryptEncrypt function
+    Decrypt: function(hKey: HCRYPTKEY; hHash: HCRYPTHASH; Final: BOOL;
+      dwFlags: DWORD; pbData: pointer; var pdwDataLen: DWORD): BOOL; stdcall;
+    /// fills a buffer with cryptographically random bytes
+    // - since Windows Vista with Service Pack 1 (SP1), an AES counter-mode
+    // based PRNG specified in NIST Special Publication 800-90 is used
+    GenRandom: function(hProv: HCRYPTPROV; dwLen: DWORD; pbBuffer: Pointer): BOOL; stdcall;
+    /// sign a message (not resolved yet - in crypt32.dll)
+    SignMessage: function(var pSignPara: CRYPT_SIGN_MESSAGE_PARA;
+      fDetachedSignature: BOOL; cToBeSigned: DWORD; rgpbToBeSigned: pointer;
+      var rgcbToBeSigned: DWORD; pbSignedBlob: pointer; var pcbSignedBlob: DWORD): BOOL; stdcall;
+    /// verify a signed message (not resolved yet - in crypt32.dll)
+    VerifyMessageSignature: function(var pVerifyPara: CRYPT_VERIFY_MESSAGE_PARA;
+      dwSignerIndex: DWORD; pbSignedBlob: PByte; cbSignedBlob: DWORD;
+      pbDecoded: PByte; pcbDecoded: LPDWORD; ppSignerCert: PPCCERT_CONTEXT): BOOL; stdcall;
+    /// try to load the CryptoApi on this system
+    function Available: boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+  end;
+
+const
+  NO_ERROR  = Windows.NO_ERROR;
+
+  ERROR_ACCESS_DENIED      = Windows.ERROR_ACCESS_DENIED;
+  ERROR_INVALID_PARAMETER  = Windows.ERROR_INVALID_PARAMETER;
+  ERROR_HANDLE_EOF         = Windows.ERROR_HANDLE_EOF;
+  ERROR_ALREADY_EXISTS     = Windows.ERROR_ALREADY_EXISTS;
+  ERROR_MORE_DATA          = Windows.ERROR_MORE_DATA;
+  ERROR_CONNECTION_INVALID = Windows.ERROR_CONNECTION_INVALID;
+  ERROR_OLD_WIN_VERSION    = Windows.ERROR_OLD_WIN_VERSION;
+  ERROR_IO_PENDING         = Windows.ERROR_IO_PENDING;
+  ERROR_OPERATION_ABORTED  = Windows.ERROR_OPERATION_ABORTED;
+  // see http://msdn.microsoft.com/en-us/library/windows/desktop/aa383770
+  ERROR_WINHTTP_TIMEOUT                 = 12002;
+  ERROR_WINHTTP_CANNOT_CONNECT          = 12029;
+  ERROR_WINHTTP_INVALID_SERVER_RESPONSE = 12152;
+  ERROR_MUI_FILE_NOT_FOUND              = 15100;
+
+  INVALID_HANDLE_VALUE = Windows.INVALID_HANDLE_VALUE; // = HANDLE(-1)
+  ENGLISH_LANGID       = $0409;
+
+  PROV_RSA_FULL        = 1;
+  PROV_RSA_AES         = 24;
+  CRYPT_NEWKEYSET      = 8;
+  CRYPT_VERIFYCONTEXT  = DWORD($F0000000);
+  PLAINTEXTKEYBLOB     = 8;
+  CUR_BLOB_VERSION     = 2;
+  KP_IV                = 1;
+  KP_MODE              = 4;
+  CALG_AES_128         = $660E;
+  CALG_AES_192         = $660F;
+  CALG_AES_256         = $6610;
+  CRYPT_MODE_CBC       = 1;
+  CRYPT_MODE_ECB       = 2;
+  CRYPT_MODE_OFB       = 3;
+  CRYPT_MODE_CFB       = 4;
+  CRYPT_MODE_CTS       = 5;
+  HCRYPTPROV_NOTTESTED = HCRYPTPROV(-1);
+  NTE_BAD_KEYSET       = HRESULT($80090016);
+
+var
+  CryptoApi: TWinCryptoApi;
+
+/// protect some data for the current user, using Windows DPAPI
+// - the application can specify a secret salt text, which should reflect the
+// current execution context, to ensure nobody could decrypt the data without
+// knowing this application-specific AppSecret value
+// - will use CryptProtectData DPAPI function call under Windows
+// - see https://msdn.microsoft.com/en-us/library/ms995355
+// - this function is Windows-only, could be slow, and you don't know which
+// algorithm is really used on your system, so using our mormot.crypt.core.pas
+// CryptDataForCurrentUser() is probably a safer (and cross-platform) alternative
+// - also note that DPAPI has been closely reverse engineered - see e.g.
+// https://www.passcape.com/index.php?section=docsys&cmd=details&id=28
+function CryptDataForCurrentUserDPAPI(const Data, AppSecret: RawByteString;
+  Encrypt: boolean): RawByteString;
+
+const
+  WINDOWS_CERTSTORE: array[TSystemCertificateStore] of PWideChar = (
+    'CA', 'MY', 'ROOT', 'SPC');
+
+/// this global procedure should be called from each thread needing to use OLE
+// - it is called e.g. by TOleDBConnection.Create when an OleDb connection
+// is instantiated for a new thread
+// - every call of CoInit shall be followed by a call to CoUninit
+// - implementation will maintain some global counting, to call the CoInitialize
+// API only once per thread
+// - only made public for user convenience, e.g. when using custom COM objects
+procedure CoInit;
+
+/// this global procedure should be called at thread termination
+// - it is called e.g. by TOleDBConnection.Destroy, when thread associated
+// to an OleDb connection is terminated
+// - every call of CoInit shall be followed by a call to CoUninit
+// - only made public for user convenience, e.g. when using custom COM objects
+procedure CoUninit;
+
+/// retrieves the current executable module handle, i.e.  its memory load address
+// - redefined in mormot.core.os to avoid dependency to the Windows unit
+function GetModuleHandle(lpModuleName: PChar): HMODULE;
+
+/// post a message to the Windows message queue
+// - redefined in mormot.core.os to avoid dependency to the Windows unit
+function PostMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL;
+
+/// retrieves the current stack trace
+// - only available since Windows XP
+// - FramesToSkip + FramesToCapture should be <= 62
+function RtlCaptureStackBackTrace(FramesToSkip, FramesToCapture: cardinal;
+  BackTrace, BackTraceHash: pointer): byte; stdcall;
+
+/// retrieves the current thread ID
+// - redefined in mormot.core.os to avoid dependency to the Windows unit
+function GetCurrentThreadId: DWORD; stdcall;
+
+/// retrieves the current process ID
+// - redefined in mormot.core.os to avoid dependency to the Windows unit
+function GetCurrentProcessId: DWORD; stdcall;
+
+/// retrieves the current process ID
+// - redefined in mormot.core.os to avoid dependency to the Windows unit
+function GetCurrentProcess: THandle; stdcall;
+
+/// redefined in mormot.core.os to avoid dependency to the Windows unit
+function WaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD): DWORD; stdcall;
+
+/// redefined in mormot.core.os to avoid dependency to the Windows unit
+function GetEnvironmentStringsW: PWideChar; stdcall;
+
+/// redefined in mormot.core.os to avoid dependency to the Windows unit
+function FreeEnvironmentStringsW(EnvBlock: PWideChar): BOOL; stdcall;
+
+/// expand any embedded environment variables, i.e %windir%
+function ExpandEnvVars(const aStr: string): string;
+
+/// try to enter a Critical Section (Lock)
+// - returns 1 if the lock was acquired, or 0 if the mutex is already locked
+// - redefined in mormot.core.os to avoid dependency to the Windows unit
+// - under Delphi/Windows, directly call the homonymous Win32 API
+function TryEnterCriticalSection(var cs: TRTLCriticalSection): integer; stdcall;
+
+/// enter a Critical Section (Lock)
+// - redefined in mormot.core.os to avoid dependency to the Windows unit
+// - under Delphi/Windows, directly call the homonymous Win32 API
+procedure EnterCriticalSection(var cs: TRTLCriticalSection); stdcall;
+
+/// leave a Critical Section (UnLock)
+// - redefined in mormot.core.os to avoid dependency to the Windows unit
+// - under Delphi/Windows, directly call the homonymous Win32 API
+procedure LeaveCriticalSection(var cs: TRTLCriticalSection); stdcall;
+
+/// initialize Windows IOCP instance
+// - renamed in mormot.core.os to avoid dependency to the Windows unit
+function IocpCreate(FileHandle, ExistingCompletionPort: THandle;
+  CompletionKey: pointer; NumberOfConcurrentThreads: DWORD): THandle; stdcall;
+
+/// retrieve Windows IOCP instance status
+// - renamed in mormot.core.os to avoid dependency to the Windows unit
+function IocpGetQueuedStatus(CompletionPort: THandle;
+  var lpNumberOfBytesTransferred: DWORD; var lpCompletionKey: pointer;
+  var lpOverlapped: pointer; dwMilliseconds: DWORD): BOOL; stdcall;
+
+/// trigger a Windows IOCP instance
+// - renamed in mormot.core.os to avoid dependency to the Windows unit
+function IocpPostQueuedStatus(CompletionPort: THandle;
+  NumberOfBytesTransferred: DWORD; dwCompletionKey: pointer;
+  lpOverlapped: POverlapped): BOOL; stdcall;
+
+/// finalize a Windows resource (e.g. IOCP instance)
+// - redefined in mormot.core.os to avoid dependency to the Windows unit
+function CloseHandle(hObject: THandle): BOOL; stdcall;
+
+/// redefined here to avoid warning to include "Windows" in uses clause
+// - why did Delphi define this slow RTL function as inlined in SysUtils.pas?
+// - also supports aFileName longer than MAX_PATH
+// - on Windows, aRights parameter is just ignored, and on POSIX aRights = 0
+// will set the default octal 644 file access attributes (-rw-r-r--)
+// - warning: this function replaces ALL SysUtils.FileCreate() overloads,
+// putting aMode as the SECOND parameter, just like with FileOpen()
+function FileCreate(const aFileName: TFileName; aMode: integer = 0;
+  aRights: integer = 0): THandle;
+
+/// redefined here to call CreateFileW() on non-Unicode RTL and support
+// aFileName longer than MAX_PATH
+function FileOpen(const aFileName: TFileName; aMode: integer): THandle;
+
+/// redefined here to avoid warning to include "Windows" in uses clause
+// - why did Delphi define this slow RTL function as inlined in SysUtils.pas?
+procedure FileClose(F: THandle); stdcall;
+
+/// redefined here to support FileName longer than MAX_PATH
+// - as our FileOpen/FileCreate redefinitions
+// - CheckAsDir = true is used by DirectoryExists()
+function FileExists(const FileName: TFileName; FollowLink: boolean = true;
+  CheckAsDir: boolean = false): boolean;
+
+/// redefined here to support FileName longer than MAX_PATH
+function DirectoryExists(const FileName: TFileName;
+  FollowLink: boolean = true): boolean; {$ifdef HASINLINE} inline; {$endif}
+
+/// redefined here to avoid warning to include "Windows" in uses clause
+// and support FileName longer than MAX_PATH
+// - why did Delphi define this slow RTL function as inlined in SysUtils.pas?
+function DeleteFile(const aFileName: TFileName): boolean;
+
+/// redefined here to avoid warning to include "Windows" in uses clause
+// and support FileName longer than MAX_PATH
+// - why did Delphi define this slow RTL function as inlined in SysUtils.pas?
+function RenameFile(const OldName, NewName: TFileName): boolean;
+
+/// redirection to Windows SetFileTime() of a file name from Int64(TFileTime)
+// - if any Int64 is 0, the proper value will be guess from the non-0 values
+function FileSetTime(const FileName: TFileName;
+  const Created, Accessed, Written: Int64): boolean;
+
+{$else}
+
+/// faster cross-platform alternative to sysutils homonymous function
+// - will directly use fpstat() so is slightly faster than default FPC RTL
+function FileExists(const FileName: TFileName): boolean;
+
+/// redefined from FPC RTL sysutils for consistency
+// - warning: this function replaces ALL SysUtils.FileCreate() overloads,
+// putting aMode as the SECOND parameter, just like with FileOpen()
+// - on POSIX, aRights = 0 will set default octal 644 attributes (-rw-r-r--)
+function FileCreate(const aFileName: TFileName; aMode: integer = 0;
+  aRights: integer = 0): THandle;
+
+/// returns how many files could be opened at once on this POSIX system
+// - hard=true is for the maximum allowed limit, false for the current process
+// - returns -1 if the getrlimit() API call failed
+function GetFileOpenLimit(hard: boolean = false): integer;
+
+/// changes how many files could be opened at once on this POSIX system
+// - hard=true is for the maximum allowed limit (requires root priviledges),
+// false for the current process
+// - returns the new value set (may not match the expected max value on error)
+// - returns -1 if the getrlimit().setrlimit() API calls failed
+// - for instance, to set the limit of the current process to its highest value:
+// ! SetFileOpenLimit(GetFileOpenLimit(true));
+function SetFileOpenLimit(max: integer; hard: boolean = false): integer;
+
+/// read /proc/pid/status to ensure pid is of a real process, not a thread
+function IsValidPid(pid: cardinal): boolean;
+
+type
+  /// Low-level access to the ICU library installed on this system
+  // - "International Components for Unicode" (ICU) is an open-source set of
+  // libraries for Unicode support, internationalization and globalization
+  // - used by Unicode_CompareString, Unicode_AnsiToWide, Unicode_WideToAnsi,
+  // Unicode_InPlaceUpper and Unicode_InPlaceLower function from this unit
+  TIcuLibrary = packed object
+  protected
+    icu, icudata, icui18n: pointer;
+    Loaded: boolean;
+    procedure DoLoad(const LibName: TFileName = ''; Version: string = '');
+    procedure Done;
+  public
+    /// Initialize an ICU text converter for a given encoding
+    ucnv_open: function (converterName: PAnsiChar; var err: SizeInt): pointer; cdecl;
+    /// finalize the ICU text converter for a given encoding
+    ucnv_close: procedure (converter: pointer); cdecl;
+    /// customize the ICU text converter substitute char
+    ucnv_setSubstChars: procedure (converter: pointer;
+      subChars: PAnsiChar; len: byte; var err: SizeInt); cdecl;
+    /// enable the ICU text converter fallback
+    ucnv_setFallback: procedure (cnv: pointer; usesFallback: LongBool); cdecl;
+    /// ICU text conversion from UTF-16 to a given encoding
+    ucnv_fromUChars: function (cnv: pointer; dest: PAnsiChar; destCapacity: cardinal;
+      src: PWideChar; srcLength: cardinal; var err: SizeInt): cardinal; cdecl;
+    /// ICU text conversion from a given encoding to UTF-16
+    ucnv_toUChars: function (cnv: pointer; dest: PWideChar; destCapacity: cardinal;
+      src: PAnsiChar; srcLength: cardinal; var err: SizeInt): cardinal; cdecl;
+    /// ICU UTF-16 text conversion to uppercase
+    u_strToUpper: function (dest: PWideChar; destCapacity: cardinal;
+      src: PWideChar; srcLength: cardinal; locale: PAnsiChar;
+      var err: SizeInt): cardinal; cdecl;
+    /// ICU UTF-16 text conversion to lowercase
+    u_strToLower: function (dest: PWideChar; destCapacity: cardinal;
+      src: PWideChar; srcLength: cardinal; locale: PAnsiChar;
+      var err: SizeInt): cardinal; cdecl;
+    /// ICU UTF-16 text comparison
+    u_strCompare: function (s1: PWideChar; length1: cardinal;
+      s2: PWideChar; length2: cardinal; codePointOrder: LongBool): cardinal; cdecl;
+    /// ICU UTF-16 text comparison with options, e.g. for case-insensitivity
+    u_strCaseCompare: function (s1: PWideChar; length1: cardinal;
+      s2: PWideChar; length2: cardinal; options: cardinal;
+      var err: SizeInt): cardinal; cdecl;
+    /// get the ICU data folder
+    u_getDataDirectory: function: PAnsiChar; cdecl;
+    /// set the ICU data folder
+    u_setDataDirectory: procedure(directory: PAnsiChar); cdecl;
+    /// initialize the ICU library
+    u_init: procedure(var status: SizeInt); cdecl;
+    /// try to initialize a specific version of the ICU library
+    // - first finalize any existing loaded instance
+    // - returns true if was successfully loaded and setup
+    function ForceLoad(const LibName: TFileName; const Version: string): boolean;
+    /// returns TRUE if a ICU library is available on this system
+    // - will thread-safely load and initialize it if necessary
+    function IsAvailable: boolean; inline;
+    /// Initialize an ICU text converter for a given codepage
+    // - returns nil if ICU is not available on this system
+    // - wrapper around ucnv_open/ucnv_setSubstChars/ucnv_setFallback calls
+    // - caller should make ucnv_close() once done with the returned instance
+    function ucnv(codepage: cardinal): pointer;
+  end;
+
+var
+  /// low-level late-binding access to any installed ICU library
+  // - typical use is to check icu.IsAvailable then the proper icu.*() functions
+  // - this unit will make icu.Done in its finalization section
+  icu: TIcuLibrary;
+
+  /// contains the current POSIX kernel revision, as one 24-bit integer
+  // - allow quick comparison mainly for kernel feature checking
+  // - e.g. on Linux, may equal $030d02 for 3.13.2, or $020620 for 2.6.32
+  KernelRevision: cardinal;
+
+
+{$ifdef OSLINUX} { some Linux-specific APIs (e.g. systemd or eventfd) }
+
+const
+  /// The first passed file descriptor is fd 3
+  SD_LISTEN_FDS_START = 3;
+
+  /// low-level libcurl library file name, depending on the running OS
+  LIBSYSTEMD_PATH = 'libsystemd.so.0';
+
+  ENV_INVOCATION_ID: PAnsiChar = 'INVOCATION_ID';
+
+type
+  /// low-level systemd parameter to sd.journal_sendv() function
+  TIoVec = record
+    iov_base: PAnsiChar;
+    iov_len: PtrUInt;
+  end;
+
+  /// implements late-binding of the systemd library
+  // - about systemd: see https://www.freedesktop.org/wiki/Software/systemd
+  // and http://0pointer.de/blog/projects/socket-activation.html - to get headers
+  // on debian: `sudo apt install libsystemd-dev && cd /usr/include/systemd`
+  TSystemD = record
+  private
+    systemd: pointer;
+    tested: boolean;
+    procedure DoLoad;
+  public
+    /// returns how many file descriptors have been passed to process
+    // - if result=1 then socket for accepting connection is LISTEN_FDS_START
+    listen_fds: function(unset_environment: integer): integer; cdecl;
+    /// returns 1 if the file descriptor is an AF_UNIX socket of the specified type and path
+    is_socket_unix: function(fd, typr, listening: integer;
+      var path: TFileName; pathLength: PtrUInt): integer; cdecl;
+    /// systemd: submit simple, plain text log entries to the system journal
+    // - priority value can be obtained using integer(LOG_TO_SYSLOG[logLevel])
+    journal_print: function(priority: integer; args: array of const): integer; cdecl;
+    /// systemd: submit array of iov structures instead of the format string to the system journal.
+    // - each structure should reference one field of the entry to submit
+    // - the second argument specifies the number of structures in the array
+    journal_sendv: function(var iov: TIoVec; n: integer): integer; cdecl;
+    /// sends notification to systemd
+    // - see https://www.freedesktop.org/software/systemd/man/notify.html
+    // status notification sample: sd.notify(0, 'READY=1');
+    // watchdog notification: sd.notify(0, 'WATCHDOG=1');
+    notify: function(unset_environment: integer; state: PUtf8Char): integer; cdecl;
+    /// check whether the service manager expects watchdog keep-alive
+    // notifications from a service
+    // - if result > 0 then usec contains the notification interval (app should
+    // notify every usec/2)
+    watchdog_enabled: function(unset_environment: integer; usec: Puint64): integer; cdecl;
+    /// returns true in case the current process was started by systemd
+    // - For systemd v232+
+    function ProcessIsStartedBySystemd: boolean;
+    /// returns TRUE if a systemd library is available
+    // - will thread-safely load and initialize it if necessary
+    function IsAvailable: boolean; inline;
+    /// release the systemd library
+    procedure Done;
+  end;
+
+var
+  /// low-level late-binding of the systemd library
+  // - typical use is to check sd.IsAvailable then the proper sd.*() functions
+  // - this unit will make sd.Done in its finalization section
+  sd: TSystemD;
+
+/// a wrapper to the eventfd() syscall
+// - returns 0 if the kernel does not support eventfd2 (before 2.6.27) or
+// if the platform is not supported (only validated on Linux x86_64 by now)
+// - returns a file descriptor handle on success, which should be fpclose()
+function LinuxEventFD(nonblocking, semaphore: boolean): integer;
+
+/// wrapper to read from a eventfd() file
+// - return 1 and decrement the counter by 1 in semaphore mode
+// - return the current counter value and set it to 0 in non-semaphor mode
+// - may be blocking or not blocking, depending on how LinuxEventFD() was called
+// - return -1 on error
+function LinuxEventFDRead(fd: integer): Int64;
+
+/// wrapper to write to a eventfd() file
+procedure LinuxEventFDWrite(fd: integer; count: QWord);
+
+/// wrapper to wait for a eventfd() file read
+// - return true if was notified for reading, or false on timeout
+function LinuxEventFDWait(fd: integer; ms: integer): boolean; inline;
+
+{$endif OSLINUX}
+
+var
+  /// allow runtime-binding of complex OS API calls
+  // - used e.g. by mormot.core.os.mac.pas to inject its own methods
+  PosixInject: record
+    GetSmbios: function(info: TSmbiosBasicInfo): RawUtf8;
+    GetSmbiosData: function: RawByteString;
+  end;
+
+{$endif OSWINDOWS}
+
+
+{ ****************** Unicode, Time, File, Console, Library process }
+
+{$ifdef OSWINDOWS}
+
+type
+  /// redefined as our own mormot.core.os type to avoid dependency to Windows
+  // - warning: do not use this type directly, but rather TSynSystemTime as
+  // defined in mormot.core.datetime which is really cross-platform, and has
+  // consistent field order (FPC POSIX/Windows fields do not match!)
+  TSystemTime = Windows.TSystemTime;
+  PSystemTime = Windows.PSystemTime;
+
+  /// system-specific type returned by FileAge(): local 32-bit bitmask on Windows
+  TFileAge = integer;
+
+{$ifdef ISDELPHI}
+
+  /// redefined as our own mormot.core.os type to avoid dependency to Windows
+  TRTLCriticalSection = Windows.TRTLCriticalSection;
+
+  /// defined as in FPC RTL, to avoid dependency to Windows.pas unit
+  // - note that on POSIX, a THandle is a 32-bit integer, but library or
+  // resource handles are likely to map pointers, i.e. up to a 64-bit integer
+  TLibHandle = THandle;
+
+{$endif ISDELPHI}
+
+  /// handle for Slim Reader/Writer (SRW) locks in exclusive mode
+  TOSLightMutex = pointer;
+
+/// a wrapper around FileTimeToLocalFileTime/FileTimeToSystemTime Windows APIs
+// - only used by mormot.lib.static for proper SQlite3 linking on Windows
+procedure UnixTimeToLocalTime(I64: TUnixTime; out Local: TSystemTime);
+
+/// convert an Unix seconds time to a Win32 64-bit FILETIME value
+procedure UnixTimeToFileTime(I64: TUnixTime; out FT: TFileTime);
+
+/// convert an Unix milliseconds time to a Win32 64-bit FILETIME value
+procedure UnixMSTimeToFileTime(I64: TUnixMSTime; out FT: TFileTime);
+
+/// convert a TDateTime to a Win32 64-bit FILETIME value
+procedure DateTimeToFileTime(dt: TDateTime; out FT: TFileTime);
+
+/// convert a Win32 64-bit FILETIME value into an Unix seconds time
+function FileTimeToUnixTime(const FT: TFileTime): TUnixTime;
+  {$ifdef FPC} inline; {$endif}
+
+/// convert a Win32 64-bit FILETIME value into a TDateTime
+function FileTimeToDateTime(const FT: TFileTime): TDateTime;
+
+/// convert a Win32 64-bit FILETIME value into an Unix milliseconds time
+function FileTimeToUnixMSTime(const FT: TFileTime): TUnixMSTime;
+  {$ifdef FPC} inline; {$endif}
+
+var
+  // Slim Reader/Writer (SRW) API exclusive mode - fallback to TLightLock on XP
+  InitializeSRWLock,
+  AcquireSRWLockExclusive,
+  ReleaseSRWLockExclusive: procedure(var P: TOSLightMutex); stdcall;
+  TryAcquireSRWLockExclusive: function (var P: TOSLightMutex): BOOL; stdcall;
+
+{$else}
+
+const
+  /// a cross-platform incorrect THandle value, as defined in Windows unit
+  INVALID_HANDLE_VALUE = THandle(-1);
+
+  /// allow to assign proper signed symbol table name for a libc.so.6 method
+  {$ifdef OSLINUXX64}
+  LIBC_SUFFIX = '@GLIBC_2.2.5';
+  {$else}
+  {$ifdef OSLINUXX86}
+  LIBC_SUFFIX = '@GLIBC_2.0';
+  {$else}
+  LIBC_SUFFIX = ''; // no suffix seems needed outside of Intel/AMD systems
+  {$endif OSLINUXX86}
+  {$endif OSLINUXX64}
+
+type
+  /// system-specific type returned by FileAge(): UTC 64-bit Epoch on POSIX
+  TFileAge = TUnixTime;
+
+  /// system-specific structure holding a non-recursive mutex
+  TOSLightMutex = TRTLCriticalSection;
+
+{$ifdef OSLINUX}
+  {$define OSPTHREADSLIB}    // direct pthread calls were tested on Linux only
+{$endif OSLINUX}
+{$ifdef OSDARWIN}
+  {$define OSPTHREADSSTATIC} // direct pthread calls from the 'c' library
+{$endif OSDARWIN}
+{$ifdef OSBSD}
+  {$define OSPTHREADSSTATIC} // direct pthread calls from the c library
+{$endif OSBSD}
+
+// some pthread_mutex_*() API defined here for proper inlining
+{$ifdef OSPTHREADSLIB}
+var
+  {%H-}pthread: pointer; // access to pthread.so e.g. for mormot.lib.static
+  pthread_mutex_lock:    function(mutex: pointer): integer; cdecl;
+  pthread_mutex_trylock: function(mutex: pointer): integer; cdecl;
+  pthread_mutex_unlock:  function(mutex: pointer): integer; cdecl;
+{$endif OSPTHREADSLIB}
+{$ifdef OSPTHREADSSTATIC}
+function pthread_mutex_lock(mutex: pointer): integer; cdecl;
+function pthread_mutex_trylock(mutex: pointer): integer; cdecl;
+function pthread_mutex_unlock(mutex: pointer): integer; cdecl;
+{$endif OSPTHREADSSTATIC}
+
+{$endif OSWINDOWS}
+
+/// raw cross-platform library loading function
+// - alternative to LoadLibrary() and SafeLoadLibrary() Windows API and RTL
+// - on Windows, set the SEM_NOOPENFILEERRORBOX and SEM_FAILCRITICALERRORS flags
+// to avoid unexpected message boxes (which should not happen e.g. on a service)
+// - on Win32, reset the FPU flags after load as required with some libraries
+// - consider inheriting TSynLibrary if you want to map a set of API functions
+function LibraryOpen(const LibraryName: TFileName): TLibHandle;
+
+/// raw cross-platform library unloading function
+// - alternative to FreeLibrary() Windows API and FPC RTL
+procedure LibraryClose(Lib: TLibHandle);
+
+/// raw cross-platform library resolution function, as defined in FPC RTL
+// - alternative to GetProcAddr() Windows API and FPC RTL
+function LibraryResolve(Lib: TLibHandle; ProcName: PAnsiChar): pointer;
+  {$ifdef OSWINDOWS} stdcall; {$endif}
+
+/// raw cross-platform library resolution error, e.g. after LibraryOpen
+function LibraryError: string;
+
+
+const
+  /// redefined here to avoid dependency to the Windows or SyncObjs units
+  INFINITE = cardinal(-1);
+
+/// initialize a Critical Section (for Lock/UnLock)
+// - redefined in mormot.core.os to avoid dependency to the Windows unit
+// - under Delphi/Windows, directly call the homonymous Win32 API
+procedure InitializeCriticalSection(var cs : TRTLCriticalSection);
+  {$ifdef OSWINDOWS} stdcall; {$else} inline; {$endif}
+
+/// finalize a Critical Section (for Lock/UnLock)
+// - redefined in mormot.core.os to avoid dependency to the Windows unit
+// - under Delphi/Windows, directly call the homonymous Win32 API
+procedure DeleteCriticalSection(var cs : TRTLCriticalSection);
+  {$ifdef OSWINDOWS} stdcall; {$else} inline; {$endif}
+
+{$ifdef OSPOSIX}
+
+{$ifndef OSLINUX} // try to stabilize MacOS/BSD pthreads API calls
+  {$define NODIRECTTHREADMANAGER}
+{$endif OSLINUX}
+
+{$ifdef NODIRECTTHREADMANAGER} // try to stabilize MacOS pthreads API calls
+function GetCurrentThreadId: TThreadID; inline;
+function TryEnterCriticalSection(var cs: TRTLCriticalSection): integer; inline;
+procedure EnterCriticalSection(var cs: TRTLCriticalSection); inline;
+procedure LeaveCriticalSection(var cs: TRTLCriticalSection); inline;
+{$else}
+
+/// returns the unique ID of the current running thread
+// - defined in mormot.core.os for inlined FpcCurrentThreadManager call
+var GetCurrentThreadId: function: TThreadID;
+
+/// enter a Critical Section (Lock)
+// - defined in mormot.core.os for inlined FpcCurrentThreadManager call
+var EnterCriticalSection: procedure(var cs: TRTLCriticalSection);
+
+/// leave a Critical Section (UnLock)
+// - defined in mormot.core.os for inlined FpcCurrentThreadManager call
+var LeaveCriticalSection: procedure(var cs: TRTLCriticalSection);
+
+/// try to acquire and lock a Critical Section (Lock)
+// - returns 1 if the lock was acquired, or 0 if the mutex is already locked
+// - defined in mormot.core.os for inlined FpcCurrentThreadManager call
+var TryEnterCriticalSection: function(var cs: TRTLCriticalSection): integer;
+
+{$endif NODIRECTTHREADMANAGER}
+
+{$endif OSPOSIX}
+
+/// 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(var 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 HASINLINEWINAPI}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);
+
+/// returns the current UTC time as TSystemTime from the OS
+// - under Delphi/Windows, directly call the homonymous Win32 API
+// - redefined in mormot.core.os to avoid dependency to the Windows unit
+// - under Linux/POSIX, calls clock_gettime(CLOCK_REALTIME_COARSE) if available
+// or fpgettimeofday() on Darwin/MacOS
+// - warning: do not call this function directly, but rather mormot.core.datetime
+// TSynSystemTime.FromNowUtc cross-platform method instead
+procedure GetSystemTime(out result: TSystemTime);
+  {$ifdef OSWINDOWS} stdcall; {$endif}
+
+/// set the current system time as UTC timestamp
+// - we define two functions with diverse signature to circumvent the FPC RTL
+// TSystemTime field order inconsistency
+// - warning: do not call this function directly, but rather mormot.core.datetime
+// TSynSystemTime.ChangeOperatingSystemTime cross-platform method instead
+{$ifdef OSWINDOWS}
+function SetSystemTime(const utctime: TSystemTime): boolean;
+{$else}
+function SetSystemTime(utctime: TUnixTime): boolean;
+{$endif OSWINDOWS}
+
+/// returns the current Local time as TSystemTime from the OS
+// - under Delphi/Windows, directly call the homonymous Win32 API
+// - redefined in mormot.core.os to avoid dependency to the Windows unit
+// - under Linux/POSIX, calls clock_gettime(CLOCK_REALTIME_COARSE) if available
+// or fpgettimeofday() on Darwin/MacOS, with FPC RTL TZSeconds adjustment (so
+// will be fixed for the whole process lifetime and won't change at daylight)
+// - warning: do not call this function directly, but rather mormot.core.datetime
+// TSynSystemTime.FromNowLocal cross-platform method instead
+procedure GetLocalTime(out result: TSystemTime);
+  {$ifdef OSWINDOWS} stdcall; {$endif}
+
+/// compatibility function, wrapping Win32 API file truncate at current position
+procedure SetEndOfFile(F: THandle);
+  {$ifdef OSWINDOWS} stdcall; {$else} inline; {$endif}
+
+/// compatibility function, wrapping Win32 API file flush to disk
+procedure FlushFileBuffers(F: THandle);
+  {$ifdef OSWINDOWS} stdcall; {$else} inline; {$endif}
+
+/// compatibility function, wrapping Win32 API last error code
+function GetLastError: integer;
+  {$ifdef OSWINDOWS} stdcall; {$else} inline; {$endif}
+
+/// check if the last error reporting by the system is a file access violation
+// - call GetLastError is no ErrorCode is supplied
+function IsSharedViolation(ErrorCode: integer = 0): boolean;
+
+/// compatibility function, wrapping Win32 API last error code
+procedure SetLastError(error: integer);
+  {$ifdef OSWINDOWS} stdcall; {$else} inline; {$endif}
+
+/// returns a given error code as plain text
+// - redirects to WinErrorText(error, nil) on Windows, or StrError() on POSIX
+function GetErrorText(error: integer): RawUtf8;
+  {$ifdef HASINLINE} inline; {$endif}
+
+{$ifdef OSWINDOWS}
+
+/// return the error message of a given Module
+// - first try WinErrorConstant() for system error constants (if ModuleName=nil),
+// then call FormatMessage() and override the RTL function to force the
+// ENGLISH_LANGID flag first
+// - if ModuleName does support this Code, will try it as system error
+// - replace SysErrorMessagePerModule() and SysErrorMessage() from mORMot 1
+function WinErrorText(Code: cardinal; ModuleName: PChar): RawUtf8;
+
+/// return the best known ERROR_* system error message constant texts
+// - without the 'ERROR_' prefix
+// - as used by WinErrorText()
+function WinErrorConstant(Code: cardinal): PUtf8Char;
+
+/// raise an EOSException from the last system error using WinErrorText()
+procedure RaiseLastError(const Context: shortstring;
+  RaisedException: ExceptClass = nil);
+
+/// raise an Exception from the last module error using WinErrorText()
+procedure RaiseLastModuleError(ModuleName: PChar; ModuleException: ExceptClass);
+
+{$endif OSWINDOWS}
+
+/// compatibility function, wrapping Win32 API function
+// - returns the current main Window handle on Windows, or 0 on POSIX/Linux
+function GetDesktopWindow: PtrInt;
+  {$ifdef OSWINDOWS} stdcall; {$else} inline; {$endif}
+
+/// returns the curent system code page for AnsiString types
+// - as used to initialize CurrentAnsiConvert in mormot.core.unicode unit
+// - calls GetACP() Win32 API value on Delphi, or DefaultSystemCodePage on FPC -
+// i.e. GetSystemCodePage() on POSIX (likely to be UTF-8) or the value used
+// by the LCL for its "string" types (also typically UTF-8 even on Windows)
+function Unicode_CodePage: integer;
+  {$ifdef FPC} inline; {$endif}
+
+/// compatibility function, wrapping CompareStringW() Win32 API text comparison
+// - returns 1 if PW1>PW2, 2 if PW1=PW2, 3 if PW1 always use this safe version
+// - warning: FPC's SysUtils.GetTickCount64 may call fpgettimeofday() e.g.
+// on Darwin, which is not monotonic -> always use this more coherent version
+// - on POSIX, will call (via vDSO) the very fast CLOCK_MONOTONIC_COARSE if
+// available, or the low-level mach_absolute_time() monotonic Darwin API
+// - do not expect exact millisecond resolution - steps may rather be e.g.
+// within the 15-16 ms range on Windows, and 4-5 ms range on Linux
+{$ifdef OSWINDOWS}
+var
+  GetTickCount64: function: Int64; stdcall;
+{$else}
+function GetTickCount64: Int64;
+{$endif OSWINDOWS}
+
+/// returns how many seconds the system was up, accouting for time when
+// the computer is asleep
+// - on Windows, computes GetTickCount64 div 1000
+// - on Linux/BSD, will use CLOCK_BOOTTIME/CLOCK_UPTIME clock
+// - on MacOS, will use mach_continuous_time() API
+function GetUptimeSec: cardinal;
+
+/// returns the current UTC time
+// - wrap UnixMSTimeUtcFast, so use e.g. clock_gettime(CLOCK_REALTIME_COARSE)
+// under Linux, or GetSystemTimeAsFileTime under Windows
+function NowUtc: TDateTime;
+
+/// 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
+// - 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;
+
+/// 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
+// - will use e.g. fast clock_gettime(CLOCK_REALTIME_COARSE) under Linux,
+// or GetSystemTimePreciseAsFileTime under Windows 8 and later
+// - on Windows, is slightly more accurate, but slower than UnixMSTimeUtcFast
+function UnixMSTimeUtc: TUnixMSTime;
+
+/// returns the current UTC date/time as a millisecond-based c-encoded time
+// - under Linux/POSIX, is the very same than UnixMSTimeUtc (inlined call)
+// - under Windows 8+, will call GetSystemTimeAsFileTime instead of
+// GetSystemTimePreciseAsFileTime, which has higher precision, but is slower
+// - prefer it under Windows, if a dozen of ms resolution is enough for your task
+function UnixMSTimeUtcFast: TUnixMSTime;
+  {$ifdef OSPOSIX} inline; {$endif}
+
+const
+  /// number of days offset between the Unix Epoch (1970) and TDateTime origin
+  UnixDelta = 25569;
+  /// number of Windows TFileTime ticks (100ns) from year 1601 to 1970
+  UnixFileTimeDelta = 116444736000000000;
+
+/// the number of minutes bias in respect to UTC/GMT date/time
+// - as retrieved via -GetLocalTimeOffset() at startup, so may not be accurate
+// after a time shift during the process execution - but any long-running
+// process (like a service) should use UTC timestamps only
+var
+  TimeZoneLocalBias: integer;
+
+{$ifndef NOEXCEPTIONINTERCEPT}
+
+type
+  /// calling context when intercepting exceptions
+  // - used e.g. for TSynLogExceptionToStr or RawExceptionIntercept() handlers
+  {$ifdef USERECORDWITHMETHODS}
+  TSynLogExceptionContext = record
+  {$else}
+  TSynLogExceptionContext = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// 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;
+    /// = FPC's RaiseProc() FrameCount if EStack is Frame: PCodePointer
+    EStackCount: integer;
+    /// the address where the exception occurred
+    EAddr: PtrUInt;
+    /// the optional stack trace
+    EStack: PPtrUIntArray;
+    /// 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: TSynLogLevel;
+    /// retrieve some extended information about a given Exception
+    // - on Windows, recognize most DotNet CLR Exception Names
+    function AdditionalInfo(out ExceptionNames: TPUtf8CharDynArray): cardinal;
+  end;
+
+  /// the global function signature expected by RawExceptionIntercept()
+  // - assigned e.g. to SynLogException() in mormot.core.log.pas
+  TOnRawLogException = procedure(const Ctxt: TSynLogExceptionContext);
+
+/// setup Exception interception for the whole process
+// - call RawExceptionIntercept(nil) to disable custom exception handling
+procedure RawExceptionIntercept(const Handler: TOnRawLogException);
+
+{$endif NOEXCEPTIONINTERCEPT}
+
+/// returns a high-resolution system-wide monotonic timestamp as microseconds
+// - under Linux/POSIX, has true microseconds resolution, calling e.g.
+// CLOCK_MONOTONIC on Linux/BSD
+// - under Windows, calls QueryPerformanceCounter / QueryPerformanceFrequency
+procedure QueryPerformanceMicroSeconds(out Value: Int64);
+
+/// cross-platform check if the supplied THandle is not invalid
+function ValidHandle(Handle: THandle): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// check for unsafe '..' '/xxx' 'c:xxx' '~/xxx' or '\\' patterns in a path
+function SafePathName(const Path: TFileName): boolean;
+
+/// check for unsafe '..' '/xxx' 'c:xxx' '~/xxx' or '\\' patterns in a RawUtf8 path
+function SafePathNameU(const Path: RawUtf8): boolean;
+
+/// check for unsafe '..' '/xxx' 'c:xxx' '~/xxx' or '\\' patterns in a filename
+function SafeFileName(const FileName: TFileName): boolean;
+
+/// check for unsafe '..' '/xxx' 'c:xxx' '~/xxx' or '\\' patterns in a RawUtf8 filename
+function SafeFileNameU(const FileName: RawUtf8): boolean;
+
+/// ensure all \ / path delimiters are normalized into the current OS expectation
+// - i.e. normalize file name to use '\' on Windows, or '/' on POSIX
+// - see MakePath() from mormot.core.text.pas to concatenate path items
+function NormalizeFileName(const FileName: TFileName): TFileName;
+
+/// add some " before and after if FileName has some space within
+// - could be used when generating command line parameters
+function QuoteFileName(const FileName: TFileName): TFileName;
+
+/// faster cross-platform alternative to sysutils homonymous function
+// - on Windows, just redirect to WindowsFileTimeToDateTime() since FileDate
+// is already expected to be in local time from FileAge()
+// - on POSIX, FileDate is a 64-bit UTC value as returned from OS stat API, and
+// will be converted into a local TDateTime
+// - note: FPC FileAge(TDateTime) is wrong and truncates 1-2 seconds on Windows
+function FileDateToDateTime(const FileDate: TFileAge): TDateTime;
+  {$ifdef HASINLINE}{$ifdef OSWINDOWS}inline;{$endif}{$endif}
+
+/// get a file date and time, from its name
+// - returns 0 if file doesn't exist
+// - returns the local file age, encoded as TDateTime
+// - under Windows, will use GetFileAttributesEx fast API
+function FileAgeToDateTime(const FileName: TFileName): TDateTime;
+
+/// get a file date and time, from its name, as seconds since Unix Epoch
+// - returns 0 if file (or folder if AllowDir is true) doesn't exist
+// - returns the system API file age (not converted local), encoded as TUnixTime
+// - under Windows, will use GetFileAttributesEx and FileTimeToUnixTime
+// - under POSIX, will call directly the stat syscall
+// - faster than FileAgeToDateTime() since don't convert to local time
+function FileAgeToUnixTimeUtc(const FileName: TFileName;
+  AllowDir: boolean = false): TUnixTime;
+
+/// get the date and time of one file into a Windows File 32-bit TimeStamp
+// - this cross-system function is used e.g. by mormot.core.zip which expects
+// Windows TimeStamps in its headers
+function FileAgeToWindowsTime(const FileName: TFileName): integer;
+
+/// copy the date of one file to another
+// - FileSetDate(THandle, Age) is not implemented on POSIX: filename is needed
+function FileSetDateFrom(const Dest: TFileName; SourceHandle: THandle): boolean; overload;
+
+/// copy the date of one file to another
+// - FileSetDate(THandle, Age) is not implemented on POSIX: filename is needed
+function FileSetDateFrom(const Dest, Source: TFileName): boolean; overload;
+
+/// copy the date of one file from a Windows File 32-bit TimeStamp
+// - this cross-system function is used e.g. by mormot.core.zip which expects
+// Windows TimeStamps in its headers
+// - FileSetDate(THandle, Age) is not implemented on POSIX: filename is needed
+function FileSetDateFromWindowsTime(const Dest: TFileName; WinTime: integer): boolean;
+
+/// set the file date/time from a supplied UTC TUnixTime value
+// - avoid any temporary conversion to local time
+// - Time may come from FileAgeToUnixTimeUtc()
+function FileSetDateFromUnixUtc(const Dest: TFileName; Time: TUnixTime): boolean;
+
+/// convert a Windows API File 32-bit TimeStamp into a regular TDateTime
+// - returns 0 if the conversion failed
+// - used e.g. by FileSetDateFromWindowsTime() on POSIX
+function WindowsFileTimeToDateTime(WinTime: integer): TDateTime;
+
+/// convert a Windows API File 64-bit TimeStamp into a regular TUnixMSTime
+// - i.e. a FILETIME value as returned by GetFileTime() Win32 API
+// - some binary formats (e.g. ISO 9660 or LDAP) have such FILETIME fields
+function WindowsFileTime64ToUnixMSTime(WinTime: QWord): TUnixMSTime;
+
+/// low-level conversion of a TDateTime into a Windows File 32-bit TimeStamp
+// - returns 0 if the conversion failed
+function DateTimeToWindowsFileTime(DateTime: TDateTime): integer;
+
+/// check if a file exists and can be written
+// - on POSIX, call fpaccess() and check for the W_OK attribute
+// - on Windows, supports aFileName longer than MAX_PATH
+function FileIsWritable(const FileName: TFileName): boolean;
+
+/// reduce the visibility of a given file, and set its read/write attributes
+// - on POSIX, change attributes for the the owner, and reset group/world flags
+// so that it is accessible by the current user only; under POSIX, there is
+// no "hidden" file attribute, but you should define a FileName starting by '.'
+// - on Windows, will set the "hidden" file attribue
+procedure FileSetHidden(const FileName: TFileName; ReadOnly: boolean);
+
+/// set the "sticky bit" on a file or directory
+// - on POSIX, a "sticky" folder will ensure that its nested files will be
+// deleted by their owner; and a "sticky" file will ensure e.g. that no
+// /var/tmp file is deleted by systemd during its clean up phases
+// - on Windows, will set the Hidden and System file attributes
+procedure FileSetSticky(const FileName: TFileName);
+
+/// get a file size, from its name
+// - returns 0 if file doesn't exist, or is a directory
+// - under Windows, will use GetFileAttributesEx fast API
+// - on POSIX, will use efficient fpStat() single call but not FileOpen/FileClose
+function FileSize(const FileName: TFileName): Int64; overload;
+
+/// get a file size, from its handle
+// - returns 0 if file doesn't exist
+// - under Windows, will use the GetFileSizeEx fast API
+// - on POSIX, will use efficient FpFStat() single call and no file seek
+function FileSize(F: THandle): Int64; overload;
+
+/// FileSeek() overloaded function, working with huge files
+// - Delphi FileSeek() is buggy -> use this function to safely access files
+// bigger than 2 GB (thanks to sanyin for the report)
+function FileSeek64(Handle: THandle; const Offset: Int64;
+  Origin: cardinal = soFromBeginning): Int64;
+
+/// get a file size and its UTC Unix timestamp in milliseconds resolution
+// - return false if FileName was not found
+// - return true and set FileSize and FileTimestampUtc if found - note that
+// no local time conversion is done, so timestamp won't match FileAge()
+// - use a single Operating System call, so is faster than FileSize + FileAge
+function FileInfoByName(const FileName: TFileName; out FileSize: Int64;
+  out FileTimestampUtc: TUnixMSTime): boolean;
+
+/// get low-level file information, in a cross-platform way
+// - returns true on success
+// - you can specify nil for any returned value if you don't need
+// - 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; FileId, FileSize: PInt64;
+  LastWriteAccess, FileCreateDateTime: PUnixMSTime): boolean;
+
+/// check if a given file is likely to be an executable
+// - will check the DOS/WinPE executable header in its first bytes on Windows
+// - will call fpStat() on POSIX to check the File and Executable bits
+function FileIsExecutable(const FileName: TFileName): boolean;
+
+/// compute the size of a directory's files, optionally with nested folders
+// - basic implementation using FindFirst/FindNext so won't be the fastest
+// available, nor fully accurate when files are actually (hard) links
+function DirectorySize(const FileName: TFileName; Recursive: boolean = false;
+  const Mask: TFileName = FILES_ALL): Int64;
+
+/// copy one file to another, similar to the Windows API
+function CopyFile(const Source, Target: TFileName;
+  FailIfExists: boolean): boolean;
+
+/// prompt the user for an error message to notify an unexpected issue
+// - in practice, text encoding is expected to be plain 7-bit ASCII
+// - on Windows, will use Writeln() on a (newly allocated if needed) console
+// - on POSIX, will use Writeln(StdErr)
+procedure DisplayFatalError(const title, msg: RawUtf8);
+
+/// prompt the user for an error message to notify an unexpected issue
+// - redirect to DisplayFatalError() without any title
+// - expects the regular Format() layout with %s %d - not the FormatUtf8() %
+procedure DisplayError(const fmt: string; const args: array of const);
+
+/// 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}
+
+/// get a file UTC date and time, from a FindFirst/FindNext search
+// - SearchRecToDateTime(), SearchRecToWindowsTime() and F.TimeStamp, which have
+// local time and require a conversion, may appear less useful on server side
+// - is implemented as a wrapper around SearchRecToUnixTimeUtc()
+function SearchRecToDateTimeUtc(const F: TSearchRec): TDateTime;
+
+/// get a file UTC date and time, from a FindFirst/FindNext search, as Unix time
+// - SearchRecToDateTime(), SearchRecToWindowsTime() and F.TimeStamp, which have
+// local time and require a conversion, may appear less useful on server side
+function SearchRecToUnixTimeUtc(const F: TSearchRec): TUnixTime;
+  {$ifdef OSPOSIX}inline;{$endif}
+
+/// get a file date and time, from a FindFirst/FindNext search, as Windows time
+// - this cross-system function is used e.g. by mormot.core.zip which expects
+// Windows TimeStamps in its headers
+function SearchRecToWindowsTime(const F: TSearchRec): integer;
+
+/// check if a FindFirst/FindNext found instance is actually a file
+function SearchRecValidFile(const F: TSearchRec): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// check if a FindFirst/FindNext found instance is actually a folder
+function SearchRecValidFolder(const F: TSearchRec): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+type
+  /// FPC TFileStream miss a Create(aHandle) constructor like Delphi
+  TFileStreamFromHandle = class(THandleStream)
+  protected
+    fDontReleaseHandle: boolean;
+  public
+    /// explictely close the handle if needed
+    destructor Destroy; override;
+    /// Destroy calls FileClose(Handle) unless this property is true
+    property DontReleaseHandle: boolean
+      read fDontReleaseHandle write fDontReleaseHandle;
+  end;
+
+  /// a TFileStream replacement which supports FileName longer than MAX_PATH,
+  // and a proper Create(aHandle) constructor in FPC
+  TFileStreamEx = class(TFileStreamFromHandle)
+  protected
+    fFileName : TFileName;
+    function GetSize: Int64; override; // faster (1 API call instead of 3)
+  public
+    /// open or create the file from its name, depending on the supplied Mode
+    // - Mode is typically fmCreate / fmOpenReadShared
+    constructor Create(const aFileName: TFileName; Mode: cardinal);
+    /// can use this class from a low-level file OS handle
+    constructor CreateFromHandle(const aFileName: TFileName; aHandle: THandle);
+    /// open for writing or create a non-existing file from its name
+    // - use fmCreate if aFileName does not exists, or fmOpenWrite otherwise
+    constructor CreateWrite(const aFileName: TFileName);
+    /// the file name assigned to this class constructor
+    property FileName : TFileName
+      read fFilename;
+  end;
+
+  /// file stream which ignores I/O write errors
+  // - in case disk space is exhausted, TFileStreamNoWriteError.WriteBuffer
+  // won't throw any exception, so application will continue to work
+  // - used e.g. by TSynLog to let the application continue with no exception,
+  // even in case of a disk/partition full of logs
+  TFileStreamNoWriteError = class(TFileStreamEx)
+  public
+    /// open for writing, potentially with alternate unlocked file names
+    // - use fmCreate if aFileName does not exists, or fmOpenWrite otherwise
+    // - on error, will try up to aAliases alternate '-locked<#>.'
+    constructor CreateAndRenameIfLocked(
+      var aFileName: TFileName; aAliases: integer = 3);
+    /// this overriden function returns Count, as if it was always successful
+    function Write(const Buffer; Count: Longint): Longint; override;
+  end;
+
+/// a wrapper around FileRead() to ensure a whole memory buffer is retrieved
+// - expects Size to be up to 2GB (seems like a big enough memory buffer)
+// - on Windows, will read by 16MB chunks to avoid ERROR_NO_SYSTEM_RESOURCES
+// - will call FileRead() and retry up to Size bytes are filled in the buffer
+// - return true if all memory buffer has been read, or false on error
+function FileReadAll(F: THandle; Buffer: pointer; Size: PtrInt): boolean;
+
+/// a wrapper around FileWrite() to ensure a whole memory buffer is retrieved
+// - will call FileWrite() and retry up to Size bytes are written from the buffer
+// - return true if all memory buffer has been written, or false on error
+function FileWriteAll(F: THandle; Buffer: pointer; Size: PtrInt): boolean;
+
+/// overloaded function optimized for one pass reading of a (huge) file
+// - 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
+// - on POSIX, calls fpOpen(pointer(FileName),O_RDONLY) with no fpFlock() call
+// - is used e.g. by StringFromFile() or HashFile() functions
+// - note: you could better use FileReadAll() to retrieve a whole data buffer
+function FileOpenSequentialRead(const FileName: TFileName): integer;
+
+/// returns a TFileStreamFromHandle optimized for one pass file reading
+// - will use FileOpenSequentialRead(), i.e. FILE_FLAG_SEQUENTIAL_SCAN on Windows
+// - on POSIX, calls fpOpen(pointer(FileName),O_RDONLY) with no fpFlock() call
+// - is used e.g. by TRestOrmServerFullMemory and TAlgoCompress
+function FileStreamSequentialRead(const FileName: TFileName): THandleStream;
+
+/// try to open the file from its name, as fmOpenReadShared
+// - on Windows, calls CreateFileW(aFileName,GENERIC_READ) then CloseHandle
+// - on POSIX, calls fpOpen(pointer(aFileName),O_RDONLY) with no fpFlock() call
+function FileIsReadable(const aFileName: TFileName): boolean;
+
+/// copy all Source content into Dest from current position
+// - on Delphi, Dest.CopyFrom(Source, 0) uses GetSize and ReadBuffer which is
+// not compatible e.g. with TAesPkcs7Reader padding - and has a small buffer
+// - returns the number of bytes copied from Source to Dest
+function StreamCopyUntilEnd(Source, Dest: TStream): Int64;
+
+/// read a File content into a string
+// - content can be binary or text
+// - returns '' if file was not found or any read error occurred
+// - wil use GetFileSize() API by default, unless HasNoSize is defined,
+// and read will be done using a buffer (required e.g. for POSIX char files)
+// - uses RawByteString for byte storage, whatever the codepage is
+function StringFromFile(const FileName: TFileName;
+  HasNoSize: boolean = false): RawByteString;
+
+/// read a File content from a list of potential files
+// - returns '' if no file was found, or the first matching FileName[] content
+function StringFromFirstFile(const FileName: array of TFileName): RawByteString;
+
+/// read all Files content from a list of file names
+// - returns '' if no FileName[] file was found, or the read content
+function StringFromFiles(const FileName: array of TFileName): TRawByteStringDynArray;
+
+/// read all Files content from a list of folders names
+// - returns the content of every file contained in the supplied Folders[]
+// - with optionally the FileNames[] corresponding to each result[] content
+function StringFromFolders(const Folders: array of TFileName;
+  const Mask: TFileName = FILES_ALL;
+  FileNames: PFileNameDynArray = nil): TRawByteStringDynArray;
+
+/// create a File from a string content
+// - uses RawByteString for byte storage, whatever the codepage is
+// - can optionaly force flush all write buffers to disk
+function FileFromString(const Content: RawByteString; const FileName: TFileName;
+  FlushOnDisk: boolean = false): boolean;
+
+/// create a File from a memory buffer content
+function FileFromBuffer(Buf: pointer; Len: PtrInt; const FileName: TFileName): boolean;
+
+/// create or append a string content to a File
+// - can optionally rotate the file to a FileName+'.bak'  over a specific size
+function AppendToFile(const Content: RawUtf8; const FileName: TFileName;
+  BackupOverMaxSize: Int64 = 0): boolean;
+
+/// compute an unique temporary file name
+// - following 'exename_123.tmp' pattern, in the system temporary folder
+function TemporaryFileName: TFileName;
+
+/// extract a path from a file name like ExtractFilePath function
+// - but cross-platform, i.e. detect both '\' and '/' on all platforms
+function ExtractPath(const FileName: TFileName): TFileName;
+
+/// extract a path from a RawUtf8 file name like ExtractFilePath function
+// - but cross-platform, i.e. detect both '\' and '/' on all platforms
+function ExtractPathU(const FileName: RawUtf8): RawUtf8;
+
+/// extract a name from a file name like ExtractFileName function
+// - but cross-platform, i.e. detect both '\' and '/' on all platforms
+function ExtractName(const FileName: TFileName): TFileName;
+
+/// extract a name from a file name like ExtractFileName function
+// - but cross-platform, i.e. detect both '\' and '/' on all platforms
+function ExtractNameU(const FileName: RawUtf8): RawUtf8;
+
+/// extract an extension from a file name like ExtractFileExt function
+// - but cross-platform, i.e. detect both '\' and '/' on all platforms
+function ExtractExt(const FileName: TFileName; WithoutDot: boolean = false): TFileName;
+
+// defined here for proper ExtractExtP() inlining
+function GetLastDelimU(const FileName: RawUtf8; OtherDelim: AnsiChar): PtrInt;
+
+/// extract an extension from a file name like ExtractFileExt function
+// - but cross-platform, i.e. detect both '\' and '/' on all platforms
+function ExtractExtU(const FileName: RawUtf8; WithoutDot: boolean = false): RawUtf8;
+
+/// extract an extension from a file name like ExtractFileExt function
+// - but cross-platform, i.e. detect both '\' and '/' on all platforms
+function ExtractExtP(const FileName: RawUtf8; WithoutDot: boolean = false): PUtf8Char;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// compute the file name, including its path if supplied, but without its extension
+// - e.g. GetFileNameWithoutExt('/var/toto.ext') = '/var/toto'
+// - may optionally return the extracted extension, as '.ext'
+// - will be cross-platform, i.e. detect both '\' and '/' on all platforms
+function GetFileNameWithoutExt(const FileName: TFileName;
+  Extension: PFileName = nil): TFileName;
+
+/// extract the file name without any path nor extension, as UTF-8
+// - e.g. GetFileNameWithoutExt('/var/toto.ext') = 'toto'
+// - used e.g. to compute Executable.ProgramName
+function GetFileNameWithoutExtOrPath(const FileName: TFileName): RawUtf8;
+
+/// compare two "array of TFileName" elements, grouped by file extension
+// - i.e. with no case sensitivity on Windows
+// - the expected string type is the RTL string, i.e. TFileName
+// - calls internally GetFileNameWithoutExt() and AnsiCompareFileName()
+function SortDynArrayFileName(const A, B): integer;
+
+{$ifdef ISDELPHI20062007}
+/// compatibility function defined to avoid hints on buggy Delphi 2006/2007
+function AnsiCompareFileName(const S1, S2 : TFileName): integer;
+{$endif ISDELPHI20062007}
+
+/// creates a directory if not already existing
+// - returns the full expanded directory name, including trailing path delimiter
+// - returns '' on error, unless RaiseExceptionOnCreationFailure is set
+function EnsureDirectoryExists(const Directory: TFileName;
+  RaiseExceptionOnCreationFailure: ExceptionClass = nil): TFileName;
+
+/// just a wrapper around EnsureDirectoryExists(NormalizeFileName(Directory))
+function NormalizeDirectoryExists(const Directory: TFileName;
+  RaiseExceptionOnCreationFailure: ExceptionClass = nil): TFileName;
+
+/// 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
+// - return false if any deprecated DeleteFile() did fail during the process
+function DirectoryDeleteOlderFiles(const Directory: TFileName;
+  TimePeriod: TDateTime; const Mask: TFileName = FILES_ALL;
+  Recursive: boolean = false; TotalSize: PInt64 = nil): boolean;
+
+type
+  /// defines how IsDirectoryWritable() verifies a folder
+  // - on Win32 Vista+, idwExcludeWinUac will check IsUacVirtualFolder()
+  // - on Windows, idwExcludeWinSys will check IsSystemFolder()
+  // - on Windows, idwTryWinExeFile will try to generate a 'xxxxx.exe' file
+  // - idwWriteSomeContent will also try to write some bytes into the file
+  TIsDirectoryWritable = set of (
+    idwExcludeWinUac,
+    idwExcludeWinSys,
+    idwTryWinExeFile,
+    idwWriteSomeContent);
+
+/// check if the directory is writable for the current user
+// - try to write and delete a void file with a random name in this folder
+function IsDirectoryWritable(const Directory: TFileName;
+  Flags: TIsDirectoryWritable = []): boolean;
+
+type
+  /// cross-platform memory mapping of a file content
+  {$ifdef USERECORDWITHMETHODS}
+  TMemoryMap = record
+  {$else}
+  TMemoryMap = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    fBuf: PAnsiChar;
+    fBufSize: PtrUInt;
+    fFile: THandle;
+    {$ifdef OSWINDOWS}
+    fMap: THandle;
+    {$endif OSWINDOWS}
+    fFileSize: Int64;
+    fFileLocal, fLoadedNotMapped: boolean;
+    function DoMap(aCustomOffset: Int64): boolean;
+    procedure DoUnMap;
+  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; aFileOwned: boolean = false;
+      aFileSize: Int64 = -1): 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
+    // - emulates memory-mapping over an existing buffer
+    procedure Map(aBuffer: pointer; aBufferSize: PtrUInt); overload;
+    /// unmap the file
+    procedure UnMap;
+    /// retrieve the memory buffer mapped to the file content
+    property Buffer: PAnsiChar
+      read fBuf;
+    /// retrieve the buffer size
+    property Size: PtrUInt
+      read fBufSize;
+    /// retrieve the mapped file size
+    property FileSize: Int64
+      read fFileSize;
+    /// access to the low-level associated File handle (if any)
+    property FileHandle: THandle
+      read fFile;
+  end;
+
+  /// a TStream created from a file content, using fast memory mapping
+  TSynMemoryStreamMapped = class(TSynMemoryStream)
+  protected
+    fMap: TMemoryMap;
+    fFileStream: THandleStream;
+    fFileName: TFileName;
+  public
+    /// create a TStream from a file content using fast memory mapping
+    // - if aCustomSize and aCustomOffset are specified, the corresponding
+    // map view if created (by default, will map whole file)
+    constructor Create(const aFileName: TFileName;
+      aCustomSize: PtrUInt = 0; aCustomOffset: Int64 = 0); overload;
+    /// create a TStream from a file content using fast memory mapping
+    // - if aCustomSize and aCustomOffset are specified, the corresponding
+    // map view if created (by default, will map whole file)
+    constructor Create(aFile: THandle;
+      aCustomSize: PtrUInt = 0; aCustomOffset: Int64 = 0); overload;
+    /// release any internal mapped file instance
+    destructor Destroy; override;
+    /// the file name, if created from such Create(aFileName) constructor
+    property FileName: TFileName
+      read fFileName;
+  end;
+
+  /// low-level access to a resource bound to the executable
+  // - so that Windows is not required in your unit uses clause
+  {$ifdef USERECORDWITHMETHODS}
+  TExecutableResource = record
+  {$else}
+  TExecutableResource = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    // note: we can't use THandle which is 32-bit on 64-bit POSIX
+    HResInfo: TLibHandle;
+    HGlobal: TLibHandle;
+  public
+    /// the resource memory pointer, after successful Open()
+    Buffer: pointer;
+    /// the resource memory size in bytes, after successful Open()
+    Size: PtrInt;
+    /// locate and lock a resource
+    // - use the current executable if Instance is left to its 0 default value
+    // - returns TRUE if the resource has been found, and Buffer/Size are set
+    function Open(const ResourceName: string; ResType: PChar;
+      Instance: TLibHandle = 0): boolean;
+    /// unlock and finalize a resource
+    procedure Close;
+  end;
+
+
+type
+  /// store CPU and RAM usage for a given process
+  // - as used by TSystemUse class
+  TSystemUseData = packed record
+    /// when the data has been sampled
+    Timestamp: TDateTime;
+    /// percent of current Kernel-space CPU usage for this process
+    Kernel: single;
+    /// percent of current User-space CPU usage for this process
+    User: single;
+    /// how many KB of working memory are used by this process
+    WorkKB: cardinal;
+    /// how many KB of virtual memory are used by this process
+    VirtualKB: cardinal;
+  end;
+
+  /// store CPU and RAM usage history for a given process
+  // - as returned by TSystemUse.History
+  TSystemUseDataDynArray = array of TSystemUseData;
+
+  /// low-level structure used to compute process memory and CPU usage
+  {$ifdef USERECORDWITHMETHODS}
+  TProcessInfo = record
+  {$else}
+  TProcessInfo = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    {$ifdef OSWINDOWS}
+    fSysPrevIdle, fSysPrevKernel, fSysPrevUser,
+    fDiffIdle, fDiffKernel, fDiffUser, fDiffTotal: Int64;
+    {$endif OSWINDOWS}
+  public
+    /// initialize the system/process resource tracking
+    function Init: boolean;
+    /// to be called before PerSystem() or PerProcess() iteration
+    function Start: boolean;
+    /// percent of current Idle/Kernel/User CPU usage for all processes
+    function PerSystem(out Idle, Kernel, User: single): boolean;
+    /// retrieve CPU and RAM usage for a given process
+    function PerProcess(PID: cardinal; Now: PDateTime;
+      out Data: TSystemUseData; var PrevKernel, PrevUser: Int64): boolean;
+  end;
+
+  /// hold low-level information about current memory usage
+  // - as filled by GetMemoryInfo()
+  TMemoryInfo = record
+    memtotal, memfree, filetotal, filefree,
+    vmtotal, vmfree, allocreserved, allocused: QWord;
+    percent: integer;
+  end;
+
+  /// stores information about a disk partition
+  TDiskPartition = packed record
+    /// the name of this partition
+    // - is the Volume name under Windows, or the Device name under POSIX
+    name: RawUtf8;
+    /// where this partition has been mounted
+    // - e.g. 'C:' or '/home'
+    // - you can use GetDiskInfo(mounted) to retrieve current space information
+    mounted: TFileName;
+    /// total size (in bytes) of this partition
+    size: QWord;
+  end;
+
+  /// stores information about several disk partitions
+  TDiskPartitions = array of TDiskPartition;
+
+
+{$ifdef CPUARM}
+var
+  /// internal wrapper address for ReserveExecutableMemory()
+  // - set to @TInterfacedObjectFake.ArmFakeStub by mormot.core.interfaces.pas
+  ArmFakeStubAddr: pointer;
+{$endif CPUARM}
+
+
+/// cross-platform reserve some executable memory
+// - using PAGE_EXECUTE_READWRITE flags on Windows, and PROT_READ or PROT_WRITE
+// or PROT_EXEC on POSIX
+// - this function maintain an internal list of 64KB memory pages for efficiency
+// - memory blocks can not be released (don't try to use fremeem on them) and
+// will be returned to the system at process finalization
+function ReserveExecutableMemory(size: cardinal): pointer;
+
+/// to be called after ReserveExecutableMemory() when you want to actually write
+// the memory blocks
+// - affect the mapping flags of the first memory page (4KB) of the Reserved
+// buffer, so its size should be < 4KB
+// - do nothing on Windows and Linux, but may be needed on OpenBSD
+procedure ReserveExecutableMemoryPageAccess(Reserved: pointer; Exec: boolean);
+
+/// check if the supplied pointer is actually pointing to some memory page
+// - will call slow but safe VirtualQuery API on Windows, or try a fpaccess()
+// syscall on POSIX systems (validated on Linux only)
+function SeemsRealPointer(p: pointer): boolean;
+
+/// fill a buffer with a copy of some low-level system memory
+// - used e.g. by GetRawSmbios on XP or Linux/POSIX
+// - will allow to read up to 4MB of memory
+// - use low-level ntdll.dll API on Windows, or reading /dev/mem on POSIX - so
+// expect sudo/root rights on most systems
+function ReadSystemMemory(address, size: PtrUInt): RawByteString;
+
+/// return the PIDs of all running processes
+// - under Windows, is a wrapper around EnumProcesses() PsAPI call
+// - on Linux, will enumerate /proc/* pseudo-files
+function EnumAllProcesses: TCardinalDynArray;
+
+/// return the process name of a given process  ID
+// - under Windows, is a wrapper around
+// QueryFullProcessImageNameW/GetModuleFileNameEx PsAPI call
+// - on Linux, will query /proc/[pid]/exe or /proc/[pid]/cmdline pseudo-file
+function EnumProcessName(PID: cardinal): RawUtf8;
+
+/// return the process ID of the parent of a given PID
+// - by default (PID = 0), will search for the parent of the current process
+// - returns 0 if the PID was not found
+function GetParentProcess(PID: cardinal = 0): cardinal;
+
+/// check if this process is currently running into the debugger
+// - redirect to the homonymous WinAPI function on Windows, or check if the
+// /proc/self/status "TracerPid:" value is non zero on Linux, or search if
+// "lazarus" is part of the parent process name for BSD
+{$ifdef OSWINDOWS}
+function IsDebuggerPresent: BOOL; stdcall;
+{$else}
+function IsDebuggerPresent: boolean;
+{$endif ODWINDOWS}
+
+/// return the time and memory usage information about a given process
+// - under Windows, is a wrapper around GetProcessTimes/GetProcessMemoryInfo
+function RetrieveProcessInfo(PID: cardinal; out KernelTime, UserTime: Int64;
+  out WorkKB, VirtualKB: cardinal): boolean;
+
+/// return the system-wide time usage information
+// - under Windows, is a wrapper around GetSystemTimes() kernel API call
+// - return false on POSIX system - call RetrieveLoadAvg() instead
+function RetrieveSystemTimes(out IdleTime, KernelTime, UserTime: Int64): boolean;
+
+/// return the system-wide time usage information
+// - on LINUX, retrieve /proc/loadavg or on OSX/BSD call libc getloadavg()
+// - return '' on Windows - call RetrieveSystemTimes() instead
+function RetrieveLoadAvg: RawUtf8;
+
+/// retrieve low-level information about current memory usage
+// - as used by TSynMonitorMemory
+// - under BSD, only memtotal/memfree/percent are properly returned
+// - allocreserved and allocused are set only if withalloc is TRUE
+function GetMemoryInfo(out info: TMemoryInfo; withalloc: boolean): boolean;
+
+/// retrieve some human-readable text from GetMemoryInfo
+// - numbers are rounded up to a single GB number with no decimals
+// - returns e.g. 'used 6GB/16GB (35% free)' text
+function GetMemoryInfoText: RawUtf8;
+
+/// retrieve some human-readable text about the current system in several lines
+// - includes UTC timestamp, memory and disk availability, and exe/OS/CPU info
+function GetSystemInfoText: RawUtf8;
+
+/// retrieve low-level information about a given disk partition
+// - as used by TSynMonitorDisk and GetDiskPartitionsText()
+// - aDriveFolderOrFile is a directory on disk (no need to specify a raw drive
+// name like 'c:\' on Windows)
+// - warning: aDriveFolderOrFile may be modified at input
+// - only under Windows the Quotas are applied separately to aAvailableBytes
+// in respect to global aFreeBytes
+function GetDiskInfo(var aDriveFolderOrFile: TFileName;
+  out aAvailableBytes, aFreeBytes, aTotalBytes: QWord
+  {$ifdef OSWINDOWS}; aVolumeName: PSynUnicode = nil{$endif}): boolean;
+
+/// retrieve how many bytes are currently available on a given folder
+// - returns 0 if the function fails
+function GetDiskAvailable(aDriveFolderOrFile: TFileName): QWord;
+
+/// retrieve low-level information about all mounted disk partitions of the system
+// - returned partitions array is sorted by "mounted" ascending order
+function GetDiskPartitions: TDiskPartitions;
+
+/// call several Operating System APIs to gather 512-bit of entropy information
+procedure XorOSEntropy(var e: THash512Rec);
+
+/// low-level function returning some random binary from the Operating System
+// - will call /dev/urandom or /dev/random under POSIX, and CryptGenRandom API
+// on Windows then return TRUE, or fallback to mormot.core.base gsl_rng_taus2
+// generator and return FALSE if the system API failed
+// - on POSIX, only up to 32 bytes (256 bits) bits are retrieved from /dev/urandom
+// or /dev/random as stated by "man urandom" Usage - then RandomBytes() padded
+// - so you may consider that the output Buffer is always filled with random
+// - you should not have to call this procedure, but faster and safer TAesPrng
+// from mormot.crypt.core - also consider the TSystemPrng class
+function FillSystemRandom(Buffer: PByteArray; Len: integer;
+  AllowBlocking: boolean): boolean;
+
+type
+  /// available console colors
+  TConsoleColor = (
+    ccBlack,
+    ccBlue,
+    ccGreen,
+    ccCyan,
+    ccRed,
+    ccMagenta,
+    ccBrown,
+    ccLightGray,
+    ccDarkGray,
+    ccLightBlue,
+    ccLightGreen,
+    ccLightCyan,
+    ccLightRed,
+    ccLightMagenta,
+    ccYellow,
+    ccWhite);
+
+var
+  /// low-level handle used for console writing
+  // - may be overriden when console is redirected
+  // - on Windows, is initialized when AllocConsole or TextColor() are called
+  StdOut: THandle;
+
+  {$ifdef OSPOSIX}
+  /// set at initialization if StdOut has the TTY flag and env has a known TERM
+  StdOutIsTTY: boolean;
+  {$endif OSPOSIX}
+
+  /// global flag to modify the code behavior at runtime when run from TSynTests
+  // - e.g. TSynDaemon.AfterCreate won't overwrite TSynTests.RunAsConsole logs
+  RunFromSynTests: boolean;
+
+/// similar to Windows AllocConsole API call, to be truly cross-platform
+// - do nothing on Linux/POSIX, but set StdOut propertly from StdOutputHandle
+// - on Windows, will call the corresponding API, and set StdOut global variable
+procedure AllocConsole;
+
+/// change the console text writing color
+procedure TextColor(Color: TConsoleColor);
+
+/// change the console text background color
+procedure TextBackground(Color: TConsoleColor);
+
+/// write some text to the console using a given color
+// - this method is protected by its own CriticalSection for output consistency
+procedure ConsoleWrite(const Text: RawUtf8; Color: TConsoleColor = ccLightGray;
+  NoLineFeed: boolean = false; NoColor: boolean = false); overload;
+
+/// will wait for the ENTER key to be pressed, with all needed waiting process
+// - on the main thread, will call Synchronize() for proper work e.g. with
+// interface-based service implemented as optExecInMainThread
+// - on Windows, from a non-main Thread, respond to PostThreadMessage(WM_QUIT)
+// - on Windows, also properly respond to Ctrl-C or closing console events
+// - on POSIX, will call SynDaemonIntercept first, so that Ctrl-C or SIG_QUIT
+// will also be intercepted and let this procedure return
+procedure ConsoleWaitForEnterKey;
+
+/// read all available content from stdin
+// - could be used to retrieve some file piped to the command line
+// - the content is not converted, so will follow the encoding used for storage
+function ConsoleReadBody: RawByteString;
+
+{$ifdef OSWINDOWS}
+
+/// low-level access to the keyboard state of a given key
+function ConsoleKeyPressed(ExpectedKey: Word): boolean;
+
+/// local RTL wrapper function to avoid linking mormot.core.unicode.pas
+procedure Win32PWideCharToUtf8(P: PWideChar; Len: PtrInt;
+  out res: RawUtf8); overload;
+
+/// local RTL wrapper function to avoid linking mormot.core.unicode.pas
+procedure Win32PWideCharToUtf8(P: PWideChar; out res: RawUtf8); overload;
+
+/// local RTL wrapper function to avoid linking mormot.core.unicode.pas
+// - returns dest.buf as PWideChar result, and dest.len as length
+// - caller should always call dest.Done to release (unlikely) temporary memory
+function Utf8ToWin32PWideChar(const Text: RawUtf8;
+  var dest: TSynTempBuffer): PWideChar;
+
+/// ask the Operating System to convert a file URL to a local file path
+// - only Windows has a such a PathCreateFromUrl() API
+// - POSIX define this in mormot.net.http.pas, where TUri is available
+// - used e.g. by TNetClientProtocolFile to implement the 'file://' protocol
+function GetFileNameFromUrl(const Uri: string): TFileName;
+
+{$else}
+
+/// internal function to avoid linking mormot.core.buffers.pas
+function PosixParseHex32(p: PAnsiChar): integer;
+
+/// internal function to avoid linking mormot.core.buffers.pas
+procedure ParseHex(p: PAnsiChar; b: PByte; n: integer);
+
+/// internal function just wrapping fppoll(POLLIN or POLLPRI)
+function WaitReadPending(fd, timeout: integer): boolean;
+
+/// POSIX-only function calling directly getdents/getdents64 syscall
+// - could be used when FindFirst/FindNext are an overkill, e.g. to quickly
+// cache all file names of a folder in memory, optionally with its sub-folders
+// - used e.g. by TPosixFileCaseInsensitive from mormot.core.unicode
+// - warning: the file system has to support d_type (e.g. btrfs, ext2-ext4) so
+// that Recursive is handled and only DT_REG files are retrieved; non-compliant
+// file systems (or Linux Kernel older than 2.6.4) won't support the Recursive
+// search, and may return some false positives, like symlinks or nested folders
+function PosixFileNames(const Folder: TFileName; Recursive: boolean): TRawUtf8DynArray;
+
+{$endif OSWINDOWS}
+
+/// internal function to avoid linking mormot.core.buffers.pas
+// - will output the value as one number with one decimal and KB/MB/GB/TB suffix
+function _oskb(Size: QWord): shortstring;
+
+/// direct conversion of a UTF-8 encoded string into a console OEM-encoded string
+// - under Windows, will use the CP_OEM encoding
+// - under Linux, will expect the console to be defined with UTF-8 encoding
+// - we don't propose any ConsoleToUtf8() function because Windows depends on
+// the running program itself: most should generates CP_OEM (e.g. 850) as expected,
+// but some could use the system code page or even UTF-16 binary with BOM (!) -
+// so you may consider using AnsiToUtf8() with the proper code page
+function Utf8ToConsole(const S: RawUtf8): RawByteString;
+
+
+type
+  /// encapsulate cross-platform loading of library files
+  // - this generic class can be used for any external library (.dll/.so)
+  TSynLibrary = class
+  protected
+    fHandle: TLibHandle;
+    fLibraryPath: TFileName;
+    fTryFromExecutableFolder: boolean;
+    {$ifdef OSPOSIX}
+    fLibraryPathTested: boolean;
+    {$endif OSPOSIX}
+  public
+    /// cross-platform resolution of a function entry in this library
+    // - if RaiseExceptionOnFailure is set, missing entry will call FreeLib then raise it
+    // - ProcName can be a space-separated list of procedure names, to try
+    // alternate API names (e.g. for OpenSSL 1.1.1/3.x compatibility)
+    // - if ProcName starts with '?' then RaiseExceptionOnFailure = nil is set
+    function Resolve(const Prefix, ProcName: RawUtf8; Entry: PPointer;
+      RaiseExceptionOnFailure: ExceptionClass = nil): boolean;
+    /// cross-platform resolution of all function entries in this library
+    // - will search and fill Entry^ for all ProcName^ until ProcName^=nil
+    // - return true on success, false and call FreeLib if any entry is missing
+    function ResolveAll(ProcName: PPAnsiChar; Entry: PPointer): boolean;
+    /// cross-platform call to FreeLibrary() + set fHandle := 0
+    // - as called by Destroy, but you can use it directly to reload the library
+    procedure FreeLib;
+    /// same as SafeLoadLibrary() but setting fLibraryPath and cwd on Windows
+    function TryLoadLibrary(const aLibrary: array of TFileName;
+      aRaiseExceptionOnFailure: ExceptionClass): boolean; virtual;
+    /// release associated memory and linked library
+    destructor Destroy; override;
+    /// return TRUE if the library and all procedures were found
+    function Exists: boolean;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// the associated library handle
+    property Handle: TLibHandle
+      read fHandle write fHandle;
+    /// the loaded library path
+    // - on POSIX, contains the full path (via dladdr) once Resolve() is called
+    property LibraryPath: TFileName
+      read fLibraryPath;
+    /// if set, and no path is specified, will try from Executable.ProgramFilePath
+    property TryFromExecutableFolder: boolean
+      read fTryFromExecutableFolder write fTryFromExecutableFolder;
+  end;
+
+
+{ *************** Per Class Properties O(1) Lookup via vmtAutoTable Slot }
+
+/// 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
+// - some systems do forbid such live patching: consider setting NOPATCHVMT
+// and NOPATCHRTL conditionals for such projects
+procedure PatchCode(Old, New: pointer; Size: PtrInt; 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}
+/// low-level i386/x86_64 asm routine patch and redirection
+procedure RedirectCode(Func, RedirectFunc: Pointer);
+{$endif CPUINTEL}
+
+
+{ ************** Cross-Platform Charset and CodePage Support }
+
+{$ifdef OSPOSIX}
+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} // a missing declaration
+const
+  VIETNAMESE_CHARSET = 163;
+{$endif FPC}
+{$endif OSPOSIX}
+
+/// 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;
+
+
+{ **************** TSynLocker/TSynLocked and Low-Level Threading Features }
+
+type
+  /// a lightweight exclusive non-rentrant lock, stored in a PtrUInt value
+  // - calls SwitchToThread after some spinning, but don't use any R/W OS API
+  // - warning: methods are non rentrant, i.e. calling Lock twice in a raw would
+  // deadlock: use TRWLock or TSynLocker/TOSLock for reentrant methods
+  // - several lightlocks, each protecting a few variables (e.g. a list), may
+  // be more efficient than a more global TOSLock/TRWLock
+  // - our light locks are expected to be kept a very small amount of time (some
+  // CPU cycles): use TOSLightLock if the lock may block too long
+  // - TryLock/UnLock can be used to thread-safely acquire a shared resource
+  // - only consume 4 bytes on CPU32, 8 bytes on CPU64
+  {$ifdef USERECORDWITHMETHODS}
+  TLightLock = record
+  {$else}
+  TLightLock = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    Flags: PtrUInt;
+    // low-level function called by the Lock method when inlined
+    procedure LockSpin;
+  public
+    /// to be called if the instance has not been filled with 0
+    // - e.g. not needed if TLightLock is defined as a class field
+    procedure Init;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// could be called to finalize the instance as a TOSLock
+    // - does nothing - just for compatibility with TOSLock
+    procedure Done;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// enter an exclusive non-rentrant lock
+    procedure Lock;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// try to enter an exclusive non-rentrant lock
+    // - if returned true, caller should eventually call UnLock()
+    // - could also be used to thread-safely acquire a shared resource
+    function TryLock: boolean;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// check if the non-rentrant lock has been acquired
+    function IsLocked: boolean;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// leave an exclusive non-rentrant lock
+    procedure UnLock;
+      {$ifdef HASINLINE} inline; {$endif}
+  end;
+
+  /// a lightweight multiple Reads / exclusive Write non-upgradable lock
+  // - calls SwitchToThread after some spinning, but don't use any R/W OS API
+  // - warning: ReadLocks are reentrant and allow concurrent acccess, but calling
+  // WriteLock within a ReadLock, or within another WriteLock, would deadlock
+  // - consider TRWLock if you need an upgradable lock - but for mostly reads,
+  // TRWLightLock.ReadLock/ReadUnLock/WriteLock pattern is faster than upgrading
+  // - our light locks are expected to be kept a very small amount of time (some
+  // CPU cycles): use TSynLocker or TOSLock if the lock may block too long
+  // - several lightlocks, each protecting a few variables (e.g. a list), may
+  // be more efficient than a more global TOSLock/TRWLock
+  // - only consume 4 bytes on CPU32, 8 bytes on CPU64
+  {$ifdef USERECORDWITHMETHODS}
+  TRWLightLock = record
+  {$else}
+  TRWLightLock = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    Flags: PtrUInt; // bit 0 = WriteLock, >0 = ReadLock
+    // low-level functions called by the Lock methods when inlined
+    procedure ReadLockSpin;
+    procedure WriteLockSpin;
+  public
+    /// to be called if the instance has not been filled with 0
+    // - e.g. not needed if TRWLightLock is defined as a class field
+    procedure Init;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// enter a non-upgradable multiple reads lock
+    // - read locks maintain a thread-safe counter, so are reentrant and non blocking
+    // - warning: nested WriteLock call after a ReadLock would deadlock
+    procedure ReadLock;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// try to enter a non-upgradable multiple reads lock
+    // - if returned true, caller should eventually call ReadUnLock
+    // - read locks maintain a thread-safe counter, so are reentrant and non blocking
+    // - warning: nested WriteLock call after a ReadLock would deadlock
+    function TryReadLock: boolean;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// leave a non-upgradable multiple reads lock
+    procedure ReadUnLock;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// enter a non-rentrant non-upgradable exclusive write lock
+    // - warning: nested WriteLock call after a ReadLock or another WriteLock
+    // would deadlock
+    procedure WriteLock;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// try to enter a non-rentrant non-upgradable exclusive write lock
+    // - if returned true, caller should eventually call WriteUnLock
+    // - warning: nested TryWriteLock call after a ReadLock or another WriteLock
+    // would deadlock
+    function TryWriteLock: boolean;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// leave a non-rentrant non-upgradable exclusive write lock
+    procedure WriteUnLock;
+      {$ifdef HASINLINE} inline; {$endif}
+  end;
+
+type
+  /// how TRWLock.Lock and TRWLock.UnLock high-level wrapper methods are called
+  TRWLockContext = (
+    cReadOnly,
+    cReadWrite,
+    cWrite);
+
+  /// a lightweight multiple Reads / exclusive Write reentrant lock
+  // - calls SwitchToThread after some spinning, but don't use any R/W OS API
+  // - our light locks are expected to be kept a very small amount of time (some
+  // CPU cycles): use TSynLocker or TOSLock if the lock may block too long
+  // - warning: all methods are reentrant, but WriteLock/ReadWriteLock would
+  // deadlock if called after a ReadOnlyLock
+  {$ifdef USERECORDWITHMETHODS}
+  TRWLock = record
+  {$else}
+  TRWLock = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    Flags: PtrUInt; // bit 0 = WriteLock, 1 = ReadWriteLock, >1 = ReadOnlyLock
+    LastReadWriteLockThread, LastWriteLockThread: TThreadID; // to be reentrant
+    LastReadWriteLockCount,  LastWriteLockCount: cardinal;
+    {$ifndef FPC_ASMX64}
+    procedure ReadOnlyLockSpin;
+    {$endif FPC_ASMX64}
+  public
+    /// initialize the R/W lock
+    // - not needed if TRWLock is part of a class - i.e. if was filled with 0
+    procedure Init;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// could be called at shutdown to ensure that the R/W lock is in neutral state
+    procedure AssertDone;
+    /// wait for the lock to be available for reading, but not upgradable to write
+    // - several readers could acquire the lock simultaneously
+    // - ReadOnlyLock is reentrant since there is a thread-safe internal counter
+    // - warning: calling ReadWriteLock/WriteLock after ReadOnlyLock would deadlock
+    // - typical usage is the following:
+    // ! rwlock.ReadOnlyLock; // won't block concurrent ReadOnlyLock
+    // ! try
+    // !   result := Exists(value);
+    // ! finally
+    // !   rwlock.ReadOnlyUnLock;
+    // ! end;
+    procedure ReadOnlyLock;
+      {$ifdef HASINLINE} {$ifndef FPC_ASMX64} inline; {$endif} {$endif}
+    /// release a previous ReadOnlyLock call
+    procedure ReadOnlyUnLock;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// wait for the lock to be accessible for reading - later upgradable to write
+    // - will mark the lock with the current thread so that a nested WriteLock
+    // would be possible, but won't block concurrent ReadOnlyLock
+    // - several readers could acquire ReadOnlyLock simultaneously, but only a
+    // single thread could acquire a ReadWriteLock
+    // - reentrant method, and nested WriteLock is allowed
+    // - typical usage is the following:
+    // ! rwlock.ReadWriteLock;      // won't block concurrent ReadOnlyLock
+    // ! try                        // but block other ReadWriteLock/WriteLock
+    // !   result := Exists(value);
+    // !   if not result then
+    // !   begin
+    // !     rwlock.WriteLock; // block any ReadOnlyLock/ReadWriteLock/WriteLock
+    // !     try
+    // !       Add(value);
+    // !     finally
+    // !       rwlock.WriteUnLock;
+    // !     end;
+    // !   end;
+    // ! finally
+    // !   rwlock.ReadWriteUnLock;
+    // ! end;
+    procedure ReadWriteLock;
+    /// release a previous ReadWriteLock call
+    procedure ReadWriteUnLock;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// wait for the lock to be accessible for writing
+    // - the write lock is exclusive
+    // - calling WriteLock within a ReadWriteLock is allowed and won't block
+    // - but calling WriteLock within a ReadOnlyLock would deaadlock
+    // - this method is rentrant from a single thread
+    // - typical usage is the following:
+    // ! rwlock.WriteLock; // block any ReadOnlyLock/ReadWriteLock/WriteLock
+    // ! try
+    // !   Add(value);
+    // ! finally
+    // !   rwlock.WriteUnLock;
+    // ! end;
+    procedure WriteLock;
+    /// release a previous WriteLock call
+    procedure WriteUnlock;
+      {$ifdef FPC_OR_DELPHIXE4} inline; {$endif} // circumvent weird Delphi bug
+    /// a high-level wrapper over ReadOnlyLock/ReadWriteLock/WriteLock methods
+    procedure Lock(context: TRWLockContext {$ifndef PUREMORMOT2} = cWrite {$endif});
+      {$ifdef HASINLINE} inline; {$endif}
+    /// a high-level wrapper over ReadOnlyUnLock/ReadWriteUnLock/WriteUnLock methods
+    procedure UnLock(context: TRWLockContext {$ifndef PUREMORMOT2} = cWrite {$endif});
+      {$ifdef HASINLINE} inline; {$endif}
+  end;
+  PRWLock = ^TRWLock;
+
+  /// the standard rentrant lock supplied by the Operating System
+  // - maps TRTLCriticalSection, i.e. calls Win32 API or pthreads library
+  // - don't forget to call Init and Done to properly initialize the structure
+  // - if you do require a non-rentrant/recursive lock, consider TOSLightLock
+  // - same signature as TLightLock/TOSLightLock, usable as compile time alternatives
+  {$ifdef USERECORDWITHMETHODS}
+  TOSLock = record
+  {$else}
+  TOSLock = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    CS: TRTLCriticalSection;
+  public
+    /// to be called to setup the instance
+    // - mandatory in all cases, even if TOSLock is part of a class
+    procedure Init;
+    /// to be called to finalize the instance
+    procedure Done;
+    /// enter an OS lock
+    // - notice: this method IS reentrant/recursive
+    procedure Lock;
+      {$ifdef FPC} inline; {$endif}
+    /// try to enter an OS lock
+    // - if returned true, caller should eventually call UnLock()
+    function TryLock: boolean;
+      {$ifdef FPC} inline; {$endif}
+    /// leave an OS lock
+    procedure UnLock;
+      {$ifdef FPC} inline; {$endif}
+  end;
+
+  /// the fastest non-rentrant lock supplied by the Operating System
+  // - calls Slim Reader/Writer (SRW) Win32 API in exclusive mode or directly
+  // the pthread_mutex_*() library calls in non-recursive/fast mode on Linux
+  // - on XP, where SRW are not available, fallback to a TLightLock
+  // - on non-Linux POSIX, fallback to regular cthreads/TRTLCriticalSection
+  // - don't forget to call Init and Done to properly initialize the structure
+  // - to protect a very small code section of a few CPU cycles with no Init/Done
+  // needed, and a lower footprint, you may consider our TLightLock
+  // - same signature as TOSLock/TLightLock, usable as compile time alternatives
+  // - warning: non-rentrant, i.e. nested Lock calls would block, as TLightLock
+  // - no TryLock is defined on Windows, because TryAcquireSRWLockExclusive()
+  // raised some unexpected EExternalException C000026 NT_STATUS_RESOURCE_NOT_OWNED
+  // ("Attempt to release mutex not owned by caller") during testing
+  {$ifdef USERECORDWITHMETHODS}
+  TOSLightLock = record
+  {$else}
+  TOSLightLock = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    fMutex: TOSLightMutex;
+  public
+    /// to be called to setup the instance
+    // - mandatory in all cases, even if TOSLock is part of a class
+    procedure Init;
+    /// to be called to finalize the instance
+    procedure Done;
+    /// enter an OS lock
+    // - warning: this method is NOT reentrant/recursive, so any nested call
+    // would deadlock
+    procedure Lock;
+      {$ifdef HASINLINE} inline; {$endif}
+    {$ifdef OSPOSIX}
+    /// access to raw pthread_mutex_trylock() method
+    // - TryAcquireSRWLockExclusive() seems not stable on all Windows revisions
+    function TryLock: boolean;
+     {$ifdef HASINLINE} inline; {$endif}
+    {$endif OSPOSIX}
+    /// leave an OS lock
+    procedure UnLock;
+      {$ifdef HASINLINE} inline; {$endif}
+  end;
+
+  /// points to one data entry in TLockedList
+  PLockedListOne = ^TLockedListOne;
+  /// abstract parent of one data entry in TLockedList, storing two PLockedListOne
+  // - TLockedList should store unmanaged records starting with those fields
+  // - sequence field contains an incremental random-seeded 30-bit integer > 65535,
+  // to avoid ABA problems when instances are recycled
+  TLockedListOne = record
+    next, prev: pointer;
+    sequence: PtrUInt;
+  end;
+  /// optional callback event to finalize one TLockedListOne instance
+  TOnLockedListOne = procedure(one: PLockedListOne) of object;
+
+  /// thread-safe dual-linked list of TLockedListOne descendants with recycling
+  {$ifdef USERECORDWITHMETHODS}
+  TLockedList = record
+  {$else}
+  TLockedList = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    fHead, fBin: pointer;
+    fSize: integer;
+    fSequence: PtrUInt;
+    fOnFree: TOnLockedListOne;
+  public
+    /// thread-safe access to the list
+    Safe: TLightLock;
+    /// how many TLockedListOne instances are currently stored in this list
+    // - excluding the instances in the recycle bin
+    Count: integer;
+    /// initialize the storage for an inherited TLockedListOne size
+    procedure Init(onesize: PtrUInt; const onefree: TOnLockedListOne = nil);
+    /// release all stored memory
+    procedure Done;
+    /// allocate a new PLockedListOne data instance in threadsafe O(1) process
+    function New: pointer;
+    /// release one PLockedListOne used data instance in threadsafe O(1) process
+    function Free(one: pointer): boolean;
+    /// release all TLockedListOne instances currently stored in this list
+    // - without moving any of those instances into the internal recycle bin
+    procedure Clear;
+    /// release all to-be-recycled items available in the internal bin
+    // - returns how many items have been released from the internal collector
+    function EmptyBin: integer;
+    /// raw access to the stored items as PLockedListOne dual-linked list
+    property Head: pointer
+      read fHead;
+    /// the size of one stored instance, including its TLockedListOne header
+    property Size: integer
+      read fSize;
+  end;
+
+type
+  /// how TSynLocker handles its thread processing
+  // - by default, uSharedLock will use the main TRTLCriticalSection
+  // - you may set uRWLock and call overloaded RWLock/RWUnLock() to use our
+  // lighter TRWLock - but be aware that cReadOnly followed by cReadWrite/cWrite
+  // would deadlock - regular Lock/UnLock will use cWrite exclusive lock
+  // - uNoLock will disable the whole locking mechanism
+  TSynLockerUse = (
+    uSharedLock,
+    uRWLock,
+    uNoLock);
+
+  /// allow to add cross-platform locking methods to any class instance
+  // - typical use is to define a Safe: TSynLocker property, call Safe.Init
+  // and Safe.Done in constructor/destructor methods, and use Safe.Lock/UnLock
+  // methods in a try ... finally section
+  // - in respect to the TCriticalSection class, fix a potential CPU cache line
+  // conflict which may degrade the multi-threading performance, as reported by
+  // @http://www.delphitools.info/2011/11/30/fixing-tcriticalsection
+  // - internal padding is used to safely store up to 7 values protected
+  // from concurrent access with a mutex, so that SizeOf(TSynLocker)>128
+  // - for object-level locking, see TSynPersistentLock which owns one such
+  // instance, or call low-level fSafe := NewSynLocker in your constructor,
+  // then fSafe^.DoneAndFreemem in your destructor
+  // - RWUse property could replace the TRTLCriticalSection by a lighter TRWLock
+  // - see also TRWLock and TSynPersistentRWLock if the multiple read / exclusive
+  // write lock is better (only if the locked process does not take too much time)
+  {$ifdef USERECORDWITHMETHODS}
+  TSynLocker = record
+  {$else}
+  TSynLocker = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    fSection: TRTLCriticalSection;
+    fRW: TRWLock;
+    fPaddingUsedCount: byte;
+    fInitialized: boolean;
+    fRWUse: TSynLockerUse;
+    fLockCount: integer;
+    function GetVariant(Index: integer): Variant;
+    procedure SetVariant(Index: integer; const Value: Variant);
+    function GetInt64(Index: integer): Int64;
+    procedure SetInt64(Index: integer; const Value: Int64);
+    function GetBool(Index: integer): boolean;
+    procedure SetBool(Index: integer; const Value: boolean);
+    function GetUnlockedInt64(Index: integer): Int64;
+    procedure SetUnlockedInt64(Index: integer; const Value: Int64);
+    function GetPointer(Index: integer): Pointer;
+    procedure SetPointer(Index: integer; const Value: Pointer);
+    function GetUtf8(Index: integer): RawUtf8;
+    procedure SetUtf8(Index: integer; const Value: RawUtf8);
+    function GetIsLocked: boolean;
+    // - if RWUse=uSharedLock, calls EnterCriticalSection (no parallel readings)
+    // - warning: if RWUse=uRWLock, this method will use the internal TRWLock
+    // - defined in protected section for better inlining and to fix a Delphi
+    // compiler bug about warning a missing Windows unit in the uses classes
+    procedure RWLock(context: TRWLockContext);
+      {$ifdef HASINLINE} inline; {$endif}
+    procedure RWUnLock(context: TRWLockContext);
+      {$ifdef HASINLINE} inline; {$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 PaddingUsedCount property accurately
+    Padding: array[0..6] of TVarData;
+    /// initialize the mutex
+    // - calling this method is mandatory (e.g. in the class constructor owning
+    // the TSynLocker instance), otherwise you may encounter unexpected
+    // behavior, like access violations or memory leaks
+    procedure Init;
+    /// finalize the mutex
+    // - calling this method is mandatory (e.g. in the class destructor owning
+    // the TSynLocker instance), otherwise you may encounter unexpected
+    // behavior, like access violations or memory leaks
+    procedure Done;
+    /// finalize the mutex, and call FreeMem() on the pointer of this instance
+    // - should have been initiazed with a NewSynLocker call
+    procedure DoneAndFreeMem;
+    /// low-level acquisition of the lock, as RWLock(cReadOnly)
+    // - if RWUse=uSharedLock, calls EnterCriticalSection (no parallel readings)
+    // - warning: with RWUse=uRWLock, a nested Lock call would deadlock, but not
+    // nested ReadLock calls
+    procedure ReadLock;
+    /// low-level release of the lock, as RWUnLock(cReadOnly)
+    procedure ReadUnLock;
+    /// low-level acquisition of the lock, as RWLock(cReadWrite)
+    // - if RWUse=uSharedLock, calls EnterCriticalSection (no parallel readings)
+    // - with RWUse=uRWLock, a nested Lock call would not deadlock
+    procedure ReadWriteLock;
+    /// low-level release of the lock, as RWUnLock(cReadWrite)
+    procedure ReadWriteUnLock;
+    /// lock the instance for exclusive access, as RWLock(cWrite)
+    // - is re-entrant from the same thread i.e. you can nest Lock/UnLock calls
+    // - warning: with RWUse=uRWLock, would deadlock after a nested ReadLock,
+    // but not after ReadWriteLock
+    // - use as such to avoid race condition (from a Safe: TSynLocker property):
+    // ! Safe.Lock;
+    // ! try
+    // !   ...
+    // ! finally
+    // !   Safe.Unlock;
+    // ! end;
+    procedure Lock;
+    /// will try to acquire the mutex
+    // - do nothing and return false if RWUse is not the default uSharedLock
+    // - use as such to avoid race condition (from a Safe: TSynLocker property):
+    // ! if Safe.TryLock then
+    // !   try
+    // !     ...
+    // !   finally
+    // !     Safe.Unlock;
+    // !   end;
+    function TryLock: boolean;
+    /// will try to acquire the mutex for a given time
+    // - just wait and return false if RWUse is not the default uSharedLock
+    // - 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; terminated: PBoolean = nil): boolean;
+    /// release the instance for exclusive access, as RWUnLock(cWrite)
+    // - each Lock/TryLock should have its exact UnLock opposite, so a
+    // try..finally block is mandatory for safe code
+    procedure UnLock; overload;
+    /// 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;
+    /// number of values stored in the internal Padding[] array
+    // - equals 0 if no value is actually stored, or a 1..7 number otherwise
+    // - you should not have to use this field, but for optimized low-level
+    // direct access to Padding[] values, within a Lock/UnLock safe block
+    property PaddingUsedCount: byte
+      read fPaddingUsedCount write fPaddingUsedCount;
+    /// returns true if the mutex is currently locked by another thread
+    // - with RWUse=uRWLock, any lock (even ReadOnlyLock) would return true
+    property IsLocked: boolean
+      read GetIsLocked;
+    /// returns true if the Init method has been called for this mutex
+    // - is only relevant if the whole object has been previously filled with 0,
+    // i.e. as part of a class or as global variable, but won't be accurate
+    // when allocated on stack
+    property IsInitialized: boolean
+      read fInitialized;
+    /// 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
+    // - allow concurrent thread reading if RWUse was set to uRWLock
+    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
+    // - allow concurrent thread reading if RWUse was set to uRWLock
+    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
+    // - allow concurrent thread reading if RWUse was set to uRWLock
+    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
+    // - allow concurrent thread reading if RWUse was set to uRWLock
+    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
+    // - allow concurrent thread reading if RWUse was set to uRWLock
+    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;
+    /// how RWLock/RWUnLock would be processed
+    property RWUse: TSynLockerUse
+      read fRWUse write fRWUse;
+  end;
+
+  /// a pointer to a TSynLocker mutex instance
+  // - see also NewSynLocker and TSynLocker.DoneAndFreemem functions
+  PSynLocker = ^TSynLocker;
+
+  /// raw class used by TAutoLocker.ProtectMethod and TSynLocker.ProtectMethod
+  // - defined here for use by TAutoLocker in mormot.core.data.pas
+  TAutoLock = class(TInterfacedObject)
+  protected
+    fLock: PSynLocker;
+  public
+    constructor Create(aLock: PSynLocker);
+    destructor Destroy; override;
+  end;
+
+  /// our lightweight cross-platform TEvent-like component
+  // - on Windows, calls directly the CreateEvent/ResetEvent/SetEvent API
+  // - on Linux, will use eventfd() in blocking and non-semaphore mode
+  // - on other POSIX, will use PRTLEvent which is lighter than TEvent BasicEvent
+  // - only limitation is that we don't know if WaitFor is signaled or timeout,
+  // but this is not a real problem in practice since most code don't need this
+  // information or has already its own flag in its implementation logic
+  TSynEvent = class
+  protected
+    fHandle: pointer; // Windows THandle or FPC PRTLEvent
+    fFD: integer;     // for eventfd()
+  public
+    /// initialize an instance of cross-platform event
+    constructor Create;
+    /// finalize this instance of cross-platform event
+    destructor Destroy; override;
+    /// ignore any pending events, so that WaitFor will be set on next SetEvent
+    procedure ResetEvent;
+      {$ifdef OSPOSIX} inline; {$endif}
+    /// trigger any pending event, releasing the WaitFor/WaitForEver methods
+    procedure SetEvent;
+      {$ifdef OSPOSIX} inline; {$endif}
+    /// wait until SetEvent is called from another thread, with a maximum time
+    // - does not return if it was signaled or timeout
+    // - WARNING: you should wait from a single thread at once
+    procedure WaitFor(TimeoutMS: integer);
+      {$ifdef OSPOSIX} inline; {$endif}
+    /// wait until SetEvent is called from another thread, with no maximum time
+    procedure WaitForEver;
+      {$ifdef OSPOSIX} inline; {$endif}
+    /// calls SleepHiRes() in steps while checking terminated flag and this event
+    function SleepStep(var start: Int64; terminated: PBoolean): Int64;
+    /// could be used to tune your algorithm if the eventfd() API is used
+    function IsEventFD: boolean;
+      {$ifdef HASINLINE} inline; {$endif}
+  end;
+
+
+/// initialize a TSynLocker instance from heap
+// - call DoneandFreeMem to release the associated memory and OS mutex
+// - is used e.g. in TSynPersistentLock to reduce class instance size
+function NewSynLocker: PSynLocker;
+
+type
+  {$M+}
+
+  /// a persistent-agnostic alternative to TSynPersistentLock
+  // - can be used as base class when custom JSON persistence is not needed
+  // - consider a TRWLock field as a lighter multi read / exclusive write option
+  TSynLocked = class
+  protected
+    fSafe: PSynLocker; // TSynLocker would increase inherited fields offset
+  public
+    /// initialize the instance, and its associated lock
+    // - is defined as virtual, just like TObjectWithCustomCreate/TSynPersistent
+    constructor Create; virtual;
+    /// 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;
+
+  {$M-}
+
+  /// meta-class definition of the TSynLocked hierarchy
+  TSynLockedClass = class of TSynLocked;
+
+  /// a thread-safe Pierre L'Ecuyer software random generator
+  // - just wrap TLecuyer with a TLighLock
+  // - should not be used, unless may be slightly faster than a threadvar
+  {$ifdef USERECORDWITHMETHODS}
+  TLecuyerThreadSafe = record
+  {$else}
+  TLecuyerThreadSafe = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    Safe: TLightLock;
+    Generator: TLecuyer;
+    /// compute the next 32-bit generated value
+    function Next: cardinal; overload;
+    /// compute a 64-bit floating point value
+    function NextDouble: double;
+    /// XOR some memory buffer with random bytes
+    procedure Fill(dest: pointer; count: integer);
+    /// fill some string[31] with 7-bit ASCII random text
+    procedure FillShort31(var dest: TShort31);
+  end;
+
+  TThreadIDDynArray = array of TThreadID;
+
+var
+  /// a global thread-safe Pierre L'Ecuyer software random generator
+  // - should not be used, unless may be slightly faster than a threadvar
+  SharedRandom: TLecuyerThreadSafe;
+
+{$ifdef OSPOSIX}
+  /// could be set to TRUE to force SleepHiRes(0) to call the POSIX sched_yield
+  // - in practice, it has been reported as buggy under POSIX systems
+  // - even Linus Torvald himself raged against its usage - see e.g.
+  // https://www.realworldtech.com/forum/?threadid=189711&curpostid=189752
+  // - you may tempt the devil and try it by yourself
+  SleepHiRes0Yield: boolean = false;
+{$endif OSPOSIX}
+
+/// similar to Windows sleep() API call, to be truly cross-platform
+// - using millisecond resolution
+// - SleepHiRes(0) calls ThreadSwitch on Windows, but POSIX version will
+// wait 10 microsecond unless SleepHiRes0Yield is forced to true (bad idea)
+// - in respect to RTL's Sleep() function, it will return on ESysEINTR if was
+// interrupted by any OS signal
+// - warning: wait typically for the next system timer interrupt on Windows,
+// which is every 16ms by default; as a consequence, never rely on the ms
+// supplied value to guess the elapsed time, but call GetTickCount64
+procedure SleepHiRes(ms: cardinal); overload;
+
+/// similar to Windows sleep() API call, but truly cross-platform and checking
+// the Terminated flag during its wait for quick abort response
+// - returns true if terminated^ was set to true (terminatedvalue)
+function SleepHiRes(ms: cardinal; var terminated: boolean;
+  terminatedvalue: boolean = true): boolean; overload;
+
+/// call SleepHiRes() taking count of the activity, in 0/1/5/50/120-250 ms steps
+// - range is agressively designed burning some CPU in favor of responsiveness
+// - should reset start := 0 when some activity occurred, or start := -1 on
+// Windows to avoid any SleepHiRes(0) = SwitchToThread call
+// - would optionally return if terminated^ is set, or event is signaled
+// - returns the current GetTickCount64 value
+function SleepStep(var start: Int64; terminated: PBoolean = nil): Int64;
+
+/// compute optimal sleep time as 0/1/5/50 then 120-250 ms steps
+// - is agressively designed burning some CPU in favor of responsiveness
+function SleepDelay(elapsed: PtrInt): PtrInt;
+
+/// compute optimal sleep time as SleepStep, in 0/1/5/50/120-250 ms steps
+// - is agressively designed burning some CPU in favor of responsiveness
+// - start=0 would fill its value with tix; start<0 would fill its value with
+// tix-50 so that SleepDelay() would never call SleepHiRes(0)
+function SleepStepTime(var start, tix: Int64; endtix: PInt64 = nil): PtrInt;
+
+/// similar to Windows SwitchToThread API call, to be truly cross-platform
+// - call fpnanosleep(10) on POSIX systems, or the homonymous API on Windows
+procedure SwitchToThread;
+  {$ifdef OSWINDOWS} stdcall; {$endif}
+
+/// try LockedExc() in a loop, calling SwitchToThread after some spinning
+procedure SpinExc(var Target: PtrUInt; NewValue, Comperand: PtrUInt);
+
+/// wrapper to implement a thread-safe T*ObjArray dynamic array storage
+function ObjArrayAdd(var aObjArray; aItem: TObject;
+  var aSafe: TLightLock; aCount: PInteger = nil): PtrInt; overload;
+
+/// wrapper to implement a thread-safe pointer dynamic array storage
+function PtrArrayDelete(var aPtrArray; aItem: pointer; var aSafe: TLightLock;
+  aCount: PInteger = nil): PtrInt; overload;
+
+/// try to kill/cancel a thread
+// - on Windows, calls the TerminateThread() API
+// - under Linux/FPC, calls pthread_cancel() API which is asynchronous
+function RawKillThread(Thread: TThread): boolean;
+
+type
+  /// store a bitmask of logical CPU cores, as used by SetThreadMaskAffinity
+  // - has 32/64-bit pointer-size on Windows, or 1024 bits on POSIX
+  TCpuSet = {$ifdef OSWINDOWS} PtrUInt {$else} array[0..127] of byte {$endif};
+var
+  /// low-level bitmasks of logical CPU cores hosted on each hardware CPU socket
+  // - filled at process startup as CpuSocketsMask[0 .. CpuSockets - 1] range
+  CpuSocketsMask: array of TCpuSet;
+
+/// fill a bitmask of CPU cores with zeros
+procedure ResetCpuSet(out CpuSet: TCpuSet);
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// set a particular bit in a mask of CPU cores
+function SetCpuSet(var CpuSet: TCpuSet; CpuIndex: cardinal): boolean;
+
+/// retrieve the current CPU cores masks available of the system
+// - the current process may have been tuned to use only a sub-set of the cores
+// e.g. via "taskset -c" on Linux
+// - return the number of accessible CPU cores - i.e. GetBitsCount(CpuSet) or
+// 0 if the function failed
+function CurrentCpuSet(out CpuSet: TCpuSet): integer;
+
+/// try to assign a given thread to a specific set of logical CPU core(s)
+// - on Windows, calls the SetThreadAffinityMask() API
+// - under Linux/FPC, calls pthread_setaffinity_np() API
+function SetThreadMaskAffinity(Thread: TThread; const Mask: TCpuSet): boolean;
+
+/// try to assign a given thread to a specific logical CPU core
+// - CpuIndex should be in 0 .. SystemInfo.dwNumberOfProcessors - 1 range
+function SetThreadCpuAffinity(Thread: TThread; CpuIndex: cardinal): boolean;
+
+/// try to assign a given thread to a specific hardware CPU socket
+// - SocketIndex should be in 0 .. CpuSockets - 1 range, and will use the
+// CpuSocketsMask[] information retrieved during process startup
+function SetThreadSocketAffinity(Thread: TThread; SocketIndex: cardinal): boolean;
+
+/// low-level naming of a thread
+// - on Windows, will raise a standard "fake" exception to notify the thread name
+// - under Linux/FPC, calls pthread_setname_np() API which truncates to 16 chars
+procedure RawSetThreadName(ThreadID: TThreadID; const Name: RawUtf8);
+
+/// name the current thread so that it would be easily identified in the IDE debugger
+// - could then be retrieved by CurrentThreadNameShort/GetCurrentThreadName
+// - just a wrapper around SetThreadName(GetCurrentThreadId, ...)
+procedure SetCurrentThreadName(const Format: RawUtf8; const Args: array of const); overload;
+
+/// name the current thread so that it would be easily identified in the IDE debugger
+// - could also be retrieved by CurrentThreadNameShort/GetCurrentThreadName
+// - just a wrapper around SetThreadName(GetCurrentThreadId, ...)
+procedure SetCurrentThreadName(const Name: RawUtf8); overload;
+
+var
+  /// name a thread so that it would be easily identified in the IDE debugger
+  // - default implementation does nothing, unless mormot.core.log is included
+  // - you can force this function to do nothing by setting the NOSETTHREADNAME
+  // conditional, if you have issues with this feature when debugging your app
+  // - most meaningless patterns (like 'TSql') are trimmed to reduce the
+  // resulting length - which is convenient e.g. with POSIX truncation to 16 chars
+  // - you can retrieve the name later on using CurrentThreadNameShort
+  // - this method will register TSynLog.LogThreadName(), so threads calling it
+  // should also call TSynLogFamily.OnThreadEnded/TSynLog.NotifyThreadEnded
+  SetThreadName: procedure(ThreadID: TThreadID; const Format: RawUtf8;
+    const Args: array of const);
+
+/// low-level access to the thread name, as set by SetThreadName()
+// - since threadvar can't contain managed strings, it is defined as TShort31,
+// so is limited to 31 chars, which is enough since POSIX truncates to 16 chars
+// and SetThreadName does trim meaningless patterns
+function CurrentThreadNameShort: PShortString;
+
+/// retrieve the thread name, as set by SetThreadName()
+// - if possible, direct CurrentThreadNameShort function is slightly faster
+// - will return the CurrentThreadNameShort^ threadvar 31 chars value
+function GetCurrentThreadName: RawUtf8;
+
+/// returns the thread id and the thread name as a ShortString
+// - returns e.g. 'Thread 0001abcd [shortthreadname]'
+// - for convenient use when logging or raising an exception
+function GetCurrentThreadInfo: ShortString;
+
+/// enter a process-wide 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/TSynLocker or TRWLock - these functions are just here to be
+// convenient, for non time-critical process (e.g. singleton initialization
+// of external libraries, or before RegisterGlobalShutdownRelease() which will
+// use it anyway)
+procedure GlobalLock;
+
+/// release the giant lock for thread-safe shared process
+procedure GlobalUnLock;
+
+/// framework will register here some instances to be released eventually
+// - better in this root unit than in each finalization section
+// - its use is protected by the GlobalLock
+function RegisterGlobalShutdownRelease(Instance: TObject;
+  SearchExisting: boolean = false): pointer;
+
+
+{ ****************** Unix Daemon and Windows Service Support }
+
+type
+  /// all possible states of a Windows service
+  // - on POSIX, will identify only if the daemon is ssRunning or ssStopped
+  TServiceState = (
+    ssNotInstalled,
+    ssStopped,
+    ssStarting,
+    ssStopping,
+    ssRunning,
+    ssResuming,
+    ssPausing,
+    ssPaused,
+    ssFailed,
+    ssErrorRetrievingState);
+  PServiceState = ^TServiceState;
+  TServiceStateDynArray = array of TServiceState;
+
+/// return the ready to be displayed text of a TServiceState value
+function ToText(st: TServiceState): PShortString; overload;
+
+const
+  /// could be used with ConsoleWrite() to notify a Windows service state
+  SERVICESTATE_COLOR: array[TServiceState] of TConsoleColor = (
+    ccBlue,       // NotInstalled
+    ccLightRed,   // Stopped
+    ccGreen,      // Starting
+    ccRed,        // Stopping
+    ccLightGreen, // Running
+    ccGreen,      // Resuming
+    ccBrown,      // Pausing
+    ccWhite,      // Paused
+    ccMagenta,    // Failed
+    ccYellow);    // ErrorRetrievingState
+
+
+{$ifdef OSWINDOWS}
+
+{ *** some minimal Windows API definitions, replacing WinSvc.pas missing for FPC }
+
+const
+  SERVICE_QUERY_CONFIG         = $0001;
+  SERVICE_CHANGE_CONFIG        = $0002;
+  SERVICE_QUERY_STATUS         = $0004;
+  SERVICE_ENUMERATE_DEPENDENTS = $0008;
+  SERVICE_START                = $0010;
+  SERVICE_STOP                 = $0020;
+  SERVICE_PAUSE_CONTINUE       = $0040;
+  SERVICE_INTERROGATE          = $0080;
+  SERVICE_USER_DEFINED_CONTROL = $0100;
+  SERVICE_ALL_ACCESS           = STANDARD_RIGHTS_REQUIRED or
+                                 SERVICE_QUERY_CONFIG or
+                                 SERVICE_CHANGE_CONFIG or
+                                 SERVICE_QUERY_STATUS or
+                                 SERVICE_ENUMERATE_DEPENDENTS or
+                                 SERVICE_START or
+                                 SERVICE_STOP or
+                                 SERVICE_PAUSE_CONTINUE or
+                                 SERVICE_INTERROGATE or
+                                 SERVICE_USER_DEFINED_CONTROL;
+
+  SC_MANAGER_CONNECT            = $0001;
+  SC_MANAGER_CREATE_SERVICE     = $0002;
+  SC_MANAGER_ENUMERATE_SERVICE  = $0004;
+  SC_MANAGER_LOCK               = $0008;
+  SC_MANAGER_QUERY_LOCK_STATUS  = $0010;
+  SC_MANAGER_MODIFY_BOOT_CONFIG = $0020;
+  SC_MANAGER_ALL_ACCESS         = STANDARD_RIGHTS_REQUIRED or
+                                  SC_MANAGER_CONNECT or
+                                  SC_MANAGER_CREATE_SERVICE or
+                                  SC_MANAGER_ENUMERATE_SERVICE or
+                                  SC_MANAGER_LOCK or
+                                  SC_MANAGER_QUERY_LOCK_STATUS or
+                                  SC_MANAGER_MODIFY_BOOT_CONFIG;
+
+  SERVICE_CONFIG_DESCRIPTION    = $0001;
+
+  SERVICE_WIN32_OWN_PROCESS     = $00000010;
+  SERVICE_WIN32_SHARE_PROCESS   = $00000020;
+  SERVICE_INTERACTIVE_PROCESS   = $00000100;
+
+  SERVICE_BOOT_START            = $00000000;
+  SERVICE_SYSTEM_START          = $00000001;
+  SERVICE_AUTO_START            = $00000002;
+  SERVICE_DEMAND_START          = $00000003;
+  SERVICE_DISABLED              = $00000004;
+  SERVICE_ERROR_IGNORE          = $00000000;
+  SERVICE_ERROR_NORMAL          = $00000001;
+  SERVICE_ERROR_SEVERE          = $00000002;
+  SERVICE_ERROR_CRITICAL        = $00000003;
+
+  SERVICE_CONTROL_STOP          = $00000001;
+  SERVICE_CONTROL_PAUSE         = $00000002;
+  SERVICE_CONTROL_CONTINUE      = $00000003;
+  SERVICE_CONTROL_INTERROGATE   = $00000004;
+  SERVICE_CONTROL_SHUTDOWN      = $00000005;
+
+  SERVICE_STOPPED               = $00000001;
+  SERVICE_START_PENDING         = $00000002;
+  SERVICE_STOP_PENDING          = $00000003;
+  SERVICE_RUNNING               = $00000004;
+  SERVICE_CONTINUE_PENDING      = $00000005;
+  SERVICE_PAUSE_PENDING         = $00000006;
+  SERVICE_PAUSED                = $00000007;
+
+  ERROR_FAILED_SERVICE_CONTROLLER_CONNECT = 1063;
+
+type
+  PServiceStatus = ^TServiceStatus;
+  TServiceStatus = record
+    dwServiceType: cardinal;
+    dwCurrentState: cardinal;
+    dwControlsAccepted: cardinal;
+    dwWin32ExitCode: cardinal;
+    dwServiceSpecificExitCode: cardinal;
+    dwCheckPoint: cardinal;
+    dwWaitHint: cardinal;
+  end;
+
+  PServiceStatusProcess = ^TServiceStatusProcess;
+  TServiceStatusProcess = record
+    Service: TServiceStatus;
+    dwProcessId: cardinal;
+    dwServiceFlags: cardinal;
+  end;
+
+  SC_HANDLE = THandle;
+  SERVICE_STATUS_HANDLE = THandle;
+  TServiceTableEntry = record
+    lpServiceName: PWideChar;
+    lpServiceProc: procedure(ArgCount: cardinal; Args: PPWideChar); stdcall;
+  end;
+  PServiceTableEntry = ^TServiceTableEntry;
+  TServiceDescription = record
+    lpDestription: PWideChar;
+  end;
+
+  {$Z4}
+  SC_STATUS_TYPE = (SC_STATUS_PROCESS_INFO);
+  {$Z1}
+
+function OpenSCManagerW(lpMachineName, lpDatabaseName: PWideChar;
+  dwDesiredAccess: cardinal): SC_HANDLE; stdcall; external advapi32;
+function ChangeServiceConfig2W(hService: SC_HANDLE; dwsInfoLevel: cardinal;
+  lpInfo: Pointer): BOOL; stdcall; external advapi32;
+function StartServiceW(hService: SC_HANDLE; dwNumServiceArgs: cardinal;
+  lpServiceArgVectors: PPWideChar): BOOL; stdcall; external advapi32;
+function CreateServiceW(hSCManager: SC_HANDLE;
+  lpServiceName, lpDisplayName: PWideChar;
+  dwDesiredAccess, dwServiceType, dwStartType, dwErrorControl: cardinal;
+  lpBinaryPathName, lpLoadOrderGroup: PWideChar; lpdwTagId: LPDWORD; lpDependencies,
+  lpServiceStartName, lpPassword: PWideChar): SC_HANDLE; stdcall; external advapi32;
+function OpenServiceW(hSCManager: SC_HANDLE; lpServiceName: PWideChar;
+  dwDesiredAccess: cardinal): SC_HANDLE; stdcall; external advapi32;
+function DeleteService(hService: SC_HANDLE): BOOL; stdcall; external advapi32;
+function CloseServiceHandle(hSCObject: SC_HANDLE): BOOL; stdcall; external advapi32;
+function QueryServiceStatus(hService: SC_HANDLE;
+  var lpServiceStatus: TServiceStatus): BOOL; stdcall; external advapi32;
+function QueryServiceStatusEx(hService: SC_HANDLE;
+  InfoLevel: SC_STATUS_TYPE; lpBuffer: Pointer; cbBufSize: cardinal;
+  var pcbBytesNeeded: cardinal): BOOL; stdcall; external advapi32;
+function ControlService(hService: SC_HANDLE; dwControl: cardinal;
+  var lpServiceStatus: TServiceStatus): BOOL; stdcall; external advapi32;
+function SetServiceStatus(hServiceStatus: SERVICE_STATUS_HANDLE;
+  var lpServiceStatus: TServiceStatus): BOOL; stdcall; external advapi32;
+function RegisterServiceCtrlHandlerW(lpServiceName: PWideChar;
+  lpHandlerProc: TFarProc): SERVICE_STATUS_HANDLE; stdcall; external advapi32;
+function StartServiceCtrlDispatcherW(
+  lpServiceStartTable: PServiceTableEntry): BOOL; stdcall; external advapi32;
+
+function OpenServiceManager(const TargetComputer, DatabaseName: RawUtf8;
+  dwDesiredAccess: cardinal): SC_HANDLE;
+function OpenServiceInstance(hSCManager: SC_HANDLE; const ServiceName: RawUtf8;
+  dwDesiredAccess: cardinal): SC_HANDLE;
+
+
+{ *** high level classes to define and manage Windows Services }
+
+var
+  /// can be assigned from TSynLog.DoLog class method for
+  // TServiceController/TService logging
+  // - default is nil, i.e. disabling logging, since it may interfere with the
+  // logging process of the Windows Service itself
+  WindowsServiceLog: TSynLogProc;
+
+type
+  /// TServiceControler class is intended to create a new Windows Service instance
+  // or to maintain (that is start, stop, pause, resume...) an existing Service
+  // - to provide the service itself, use the TService class
+  TServiceController = class
+  protected
+    fSCHandle: THandle;
+    fHandle: THandle;
+    fStatus: TServiceStatus;
+    fName: RawUtf8;
+  protected
+    function GetStatus: TServiceStatus;
+    function GetState: TServiceState;
+  public
+    /// create a new Windows Service and control it and/or its configuration
+    // - TargetComputer - set it to empty string if local computer is the target.
+    // - DatabaseName - set it to empty string if the default database is supposed
+    // ('ServicesActive').
+    // - Name - name of a service.
+    // - DisplayName - display name of a service.
+    // - Path - a path to binary (executable) of the service created.
+    // - OrderGroup - an order group name (unnecessary)
+    // - Dependencies - string containing a list with names of services, which must
+    // start before this service (every name should be separated with ';' or an
+    // empty string can be passed if there is no dependency).
+    // - Username - login name. For service type SERVICE_WIN32_OWN_PROCESS, the
+    // account name in the form of "DomainName\Username"; If the account
+    // belongs to the built-in domain, ".\Username" can be specified;
+    // Services of type SERVICE_WIN32_SHARE_PROCESS are not allowed to
+    // specify an account other than LocalSystem. If '' is specified, the
+    // service will be logged on as the 'LocalSystem' account, in which
+    // case, the Password parameter must be empty too.
+    // - Password - a password for login name. If the service type is
+    // SERVICE_KERNEL_DRIVER or SERVICE_FILE_SYSTEM_DRIVER,
+    // this parameter is ignored.
+    // - DesiredAccess - a combination of following flags:
+    // SERVICE_ALL_ACCESS (default value), SERVICE_CHANGE_CONFIG,
+    // SERVICE_ENUMERATE_DEPENDENTS, SERVICE_INTERROGATE, SERVICE_PAUSE_CONTINUE,
+    // SERVICE_QUERY_CONFIG, SERVICE_QUERY_STATUS, SERVICE_START, SERVICE_STOP,
+    // SERVICE_USER_DEFINED_CONTROL
+    // - ServiceType - a set of following flags:
+    // SERVICE_WIN32_OWN_PROCESS (default value, which specifies a Win32 service
+    // that runs in its own process), SERVICE_WIN32_SHARE_PROCESS,
+    // SERVICE_KERNEL_DRIVER, SERVICE_FILE_SYSTEM_DRIVER,
+    // SERVICE_INTERACTIVE_PROCESS (default value, which enables a Win32 service
+    // process to interact with the desktop)
+    // - StartType - one of following values:
+    // SERVICE_BOOT_START, SERVICE_SYSTEM_START,
+    // SERVICE_AUTO_START (which specifies a device driver or service started by
+    // the service control manager automatically during system startup),
+    // SERVICE_DEMAND_START (default value, which specifies a service started by
+    // a service control manager when a process calls the StartService function,
+    // that is the TServiceController.Start method), SERVICE_DISABLED
+    // - ErrorControl - one of following:
+    // SERVICE_ERROR_IGNORE, SERVICE_ERROR_NORMAL (default value, by which
+    // the startup program logs the error and displays a message but continues
+    // the startup operation), SERVICE_ERROR_SEVERE,
+    // SERVICE_ERROR_CRITICAL
+    constructor CreateNewService(
+      const TargetComputer, DatabaseName, Name, DisplayName: RawUtf8;
+      const Path: TFileName;
+      const OrderGroup: RawUtf8 = ''; const Dependencies: RawUtf8 = '';
+      const Username: RawUtf8 = ''; const Password: RawUtf8 = '';
+      DesiredAccess: cardinal = SERVICE_ALL_ACCESS;
+      ServiceType: cardinal = SERVICE_WIN32_OWN_PROCESS or SERVICE_INTERACTIVE_PROCESS;
+      StartType: cardinal = SERVICE_DEMAND_START;
+      ErrorControl: cardinal = SERVICE_ERROR_NORMAL);
+    /// wrapper around CreateNewService() to install the current executable as service
+    class function Install(const Name, DisplayName, Description: RawUtf8;
+      AutoStart: boolean; ExeName: TFileName = '';
+      const Dependencies: RawUtf8 = ''; const UserName: RawUtf8 = '';
+      const Password: RawUtf8 = ''): TServiceState;
+    /// wrapper around CreateOpenService(SERVICE_QUERY_STATUS) and GetState
+    class function CurrentState(const Name: RawUtf8): TServiceState;
+    /// open an existing service, in order to control it or its configuration
+    // from your application
+    // - TargetComputer - set it to empty string if local computer is the target.
+    // - DatabaseName - set it to empty string if the default database is supposed
+    // ('ServicesActive').
+    // - Name - name of a service.
+    // - DesiredAccess - a combination of following flags:
+    // SERVICE_ALL_ACCESS, SERVICE_CHANGE_CONFIG, SERVICE_ENUMERATE_DEPENDENTS,
+    // SERVICE_INTERROGATE, SERVICE_PAUSE_CONTINUE, SERVICE_QUERY_CONFIG,
+    // SERVICE_QUERY_STATUS, SERVICE_START, SERVICE_STOP, SERVICE_USER_DEFINED_CONTROL
+    constructor CreateOpenService(
+      const TargetComputer, DataBaseName, Name: RawUtf8;
+      DesiredAccess: cardinal = SERVICE_ALL_ACCESS);
+    /// release memory and handles
+    destructor Destroy; override;
+    /// Handle of SC manager
+    property SCHandle: THandle
+      read fSCHandle;
+    /// Handle of service opened or created
+    // - its value is 0 if something failed in any Create*() method
+    property Handle: THandle
+      read fHandle;
+    /// Retrieve the Current status of the service
+    property Status: TServiceStatus
+      read GetStatus;
+    /// Retrieve the Current state of the service
+    property State: TServiceState
+      read GetState;
+    /// Requests the service to stop
+    function Stop: boolean;
+    /// Requests the service to pause
+    function Pause: boolean;
+    /// Requests the paused service to resume
+    function Resume: boolean;
+    /// Requests the service to update immediately its current status information
+    // to the service control manager
+    function Refresh: boolean;
+    /// Request the service to shutdown
+    // - this function always return false
+    function Shutdown: boolean;
+    /// Removes service from the system, i.e. close the Service
+    function Delete: boolean;
+    /// starts the execution of a service with some specified arguments
+    // - this version expect PWideChar pointers, i.e. UTF-16 strings
+    function Start(const Args: array of PWideChar): boolean;
+    /// try to define the description text of this service
+    function SetDescription(const Description: RawUtf8): boolean;
+    /// this class method will check the command line parameters, and will let
+    //  control the service according to it
+    // - MyServiceSetup.exe /install will install the service
+    // - MyServiceSetup.exe /start   will start the service
+    // - MyServiceSetup.exe /stop    will stop the service
+    // - MyServiceSetup.exe /uninstall will uninstall the service
+    // - so that you can write in the main block of your .dpr:
+    // !CheckParameters('MyService.exe',HTTPSERVICENAME,HTTPSERVICEDISPLAYNAME);
+    // - if ExeFileName='', it will install the current executable
+    // - optional Description and Dependencies text may be specified
+    class procedure CheckParameters(const ExeFileName: TFileName;
+      const ServiceName, DisplayName, Description: RawUtf8;
+      const Dependencies: RawUtf8 = '');
+  end;
+
+  {$M+}
+  TService = class;
+  {$M-}
+
+  /// callback procedure for Windows Service Controller
+  TServiceControlHandler = procedure(CtrlCode: cardinal); stdcall;
+
+  /// event triggered for Control handler
+  TServiceControlEvent = procedure(Sender: TService; Code: cardinal) of object;
+
+  /// event triggered to implement the Service functionality
+  TServiceEvent = procedure(Sender: TService) of object;
+
+  /// abstract class to let an executable implement a Windows Service
+  // - do not use this class directly, but TServiceSingle
+  TService = class
+  protected
+    fServiceName: RawUtf8;
+    fDisplayName: RawUtf8;
+    fStartType: cardinal;
+    fServiceType: cardinal;
+    fData: cardinal;
+    fControlHandler: TServiceControlHandler;
+    fOnControl: TServiceControlEvent;
+    fOnInterrogate: TServiceEvent;
+    fOnPause: TServiceEvent;
+    fOnShutdown: TServiceEvent;
+    fOnStart: TServiceEvent;
+    fOnExecute: TServiceEvent;
+    fOnResume: TServiceEvent;
+    fOnStop: TServiceEvent;
+    fStatusRec: TServiceStatus;
+    fArgsList: TRawUtf8DynArray;
+    fStatusHandle: THandle;
+    function GetArgCount: Integer;
+    function GetArgs(Idx: Integer): RawUtf8;
+    function GetInstalled: boolean;
+    procedure SetStatus(const Value: TServiceStatus);
+    procedure CtrlHandle(Code: cardinal);
+    function GetControlHandler: TServiceControlHandler;
+    procedure SetControlHandler(const Value: TServiceControlHandler);
+    procedure ServiceProc(ArgCount: integer; Args: PPWideChar);
+  public
+    /// internal method redirecting to WindowsServiceLog global variable
+    class procedure DoLog(Level: TSynLogLevel; const Fmt: RawUtf8;
+      const Args: array of const; Instance: TObject);
+    /// Creates the service
+    // - the service is added to the internal registered services
+    // - main application must instantiate the TServiceSingle class, then call
+    // the global ServiceSingleRun procedure to actually start the services
+    // - caller must free the TService instance when it's no longer used
+    constructor Create(const aServiceName, aDisplayName: RawUtf8); reintroduce; virtual;
+    /// this method is the main service entrance, from the OS point of view
+    // - it will call OnControl/OnStop/OnPause/OnResume/OnShutdown events
+    // - and report the service status to the system (via ReportStatus method)
+    procedure DoCtrlHandle(Code: cardinal); virtual;
+    /// Reports new status to the system
+    function ReportStatus(dwState, dwExitCode, dwWait: cardinal): BOOL;
+    /// Installs the service in the database
+    // - return true on success
+    // - create a local TServiceController with the current executable file,
+    // with the supplied command line parameters
+    // - you can optionally append some parameters, which will be appended
+    // to the
+    function Install(const Params: TFileName = ''): boolean;
+    /// Removes the service from database
+    //  - uses a local TServiceController with the current Service Name
+    procedure Remove;
+    /// Starts the service
+    //  - uses a local TServiceController with the current Service Name
+    procedure Start;
+    /// Stops the service
+    // - uses a local TServiceController with the current Service Name
+    procedure Stop;
+    /// this is the main method, in which the Service should implement its run
+    procedure Execute; virtual;
+
+    /// Number of arguments passed to the service by the service controler
+    property ArgCount: Integer
+      read GetArgCount;
+    /// List of arguments passed to the service by the service controler
+    // - Idx is in range 0..ArgCount - 1
+    property Args[Idx: Integer]: RawUtf8
+      read GetArgs;
+    /// Any data You wish to associate with the service object
+    property Data: cardinal
+      read FData write FData;
+    /// Whether service is installed in DataBase
+    // - uses a local TServiceController to check if the current Service Name exists
+    property Installed: boolean
+      read GetInstalled;
+    /// Current service status
+    // - To report new status to the system, assign another
+    // value to this record, or use ReportStatus method (preferred)
+    property Status: TServiceStatus
+      read fStatusRec write SetStatus;
+    /// Callback handler for Windows Service Controller
+    // - if handler is not set, then auto generated handler calls DoCtrlHandle
+    // (note that this auto-generated stubb is... not working yet - so you should
+    // either set your own procedure to this property, or use TServiceSingle)
+    // - a typical control handler may be defined as such:
+    // ! var MyGlobalService: TService;
+    // !
+    // ! procedure MyServiceControlHandler(Opcode: LongWord); stdcall;
+    // ! begin
+    // !   if MyGlobalService<>nil then
+    // !     MyGlobalService.DoCtrlHandle(Opcode);
+    // ! end;
+    // !
+    // ! ...
+    // ! MyGlobalService := TService.Create(...
+    // ! MyGlobalService.ControlHandler := MyServiceControlHandler;
+    property ControlHandler: TServiceControlHandler
+      read GetControlHandler write SetControlHandler;
+    /// Start event is executed before the main service thread (i.e. in the Execute method)
+    property OnStart: TServiceEvent
+      read fOnStart write fOnStart;
+    /// custom Execute event
+    // - launched in the main service thread (i.e. in the Execute method)
+    property OnExecute: TServiceEvent
+      read fOnExecute write fOnExecute;
+    /// custom event triggered when a Control Code is received from Windows
+    property OnControl: TServiceControlEvent
+      read fOnControl write fOnControl;
+    /// custom event triggered when the service is stopped
+    property OnStop: TServiceEvent
+      read fOnStop write fOnStop;
+    /// custom event triggered when the service is paused
+    property OnPause: TServiceEvent
+      read fOnPause write fOnPause;
+    /// custom event triggered when the service is resumed
+    property OnResume: TServiceEvent
+      read fOnResume write fOnResume;
+    /// custom event triggered when the service receive an Interrogate command
+    // - could call ReportStatus() e.g. to notify a problem
+    property OnInterrogate: TServiceEvent
+      read fOnInterrogate write fOnInterrogate;
+    /// custom event triggered when the service is shut down
+    property OnShutdown: TServiceEvent
+      read fOnShutdown write fOnShutdown;
+  published
+    /// Name of the service. Must be unique
+    property ServiceName: RawUtf8
+      read fServiceName;
+    /// Display name of the service
+    property DisplayName: RawUtf8
+      read fDisplayName write fDisplayName;
+    /// Type of service
+    property ServiceType: cardinal
+      read fServiceType write fServiceType;
+    /// Type of start of service
+    property StartType: cardinal
+      read fStartType write fStartType;
+  end;
+
+  /// inherit from this class if your application has a single Windows Service
+  // - note that only this single-service implementation is available by now
+  // - the regular way of executing services is to instantiate a TServiceSingle
+  // instance (which will fill the ServiceSingle variable) and its methods,
+  // then eventually call ServiceSingleRun
+  TServiceSingle = class(TService)
+  public
+    /// will set a global function as service controller
+    constructor Create(const aServiceName, aDisplayName: RawUtf8); override;
+    /// will release the global service controller
+    destructor Destroy; override;
+  end;
+
+var
+  /// the main TServiceSingle instance running in the current executable
+  // - the regular way of executing services is to instantiate a TServiceSingle
+  // instance (which will fill this ServiceSingle variable) and its methods,
+  // then eventually call ServiceSingleRun
+  ServiceSingle: TServiceSingle = nil;
+
+/// launch the registered Service execution
+// - ServiceSingle provided by this application (most probably from
+// TServiceSingle.Create) is sent to the operating system
+// - returns TRUE on success
+// - returns FALSE on error (to get extended information, call GetLastError)
+function ServiceSingleRun: boolean;
+
+/// convert the Control Code retrieved from Windows into a service state
+// enumeration item
+function CurrentStateToServiceState(CurrentState: cardinal): TServiceState;
+
+/// return the ProcessID of a given service, by name
+function GetServicePid(const aServiceName: RawUtf8;
+  aServiceState: PServiceState = nil): cardinal;
+
+/// try to gently stop a given Windows console app from its ProcessID
+// - will send a Ctrl-C event (acquiring the process console)
+function CancelProcess(pid: cardinal; waitseconds: integer): boolean;
+
+/// try to gently quit a Windows process from its ProcessID
+// - will send a WM_QUIT message to all its threads
+function QuitProcess(pid: cardinal; waitseconds: integer): boolean;
+
+/// forcibly terminate a Windows process from its ProcessID
+// - call TerminateProcess() and wait for its ending
+function KillProcess(pid: cardinal; waitseconds: integer = 30): boolean;
+
+/// install a Windows event handler for Ctrl+C pressed on the Console
+function HandleCtrlC(const OnClose: TThreadMethod): boolean;
+
+/// define a Windows Job to close associated processes together
+// - warning: main process should include the CREATE_BREAKAWAY_FROM_JOB flag
+// - you should later call CloseHandle() on the returned handle, if not 0 
+function CreateJobToClose(parentpid: cardinal): THandle;
+
+/// associate a process to a Windows Job created by CreateJobToClose()
+function AssignJobToProcess(job, process: THandle; const ctxt: ShortString): boolean;
+
+{$else}
+
+/// low-level function able to properly run or fork the current process
+// then execute the start/stop methods of a TSynDaemon / TDDDDaemon instance
+// - fork will create a local /run/[ProgramName]-[ProgramPathHash].pid file name
+// - onLog can be assigned from TSynLog.DoLog for proper logging
+procedure RunUntilSigTerminated(daemon: TObject; dofork: boolean;
+  const start, stop: TThreadMethod; const onlog: TSynLogProc = nil;
+  const servicename: string = '');
+
+/// kill a process previously created by RunUntilSigTerminated(dofork=true)
+// - will lookup a local /run/[ProgramName]-[ProgramPathHash].pid file name to
+// retrieve the actual PID to be killed, then send a SIGTERM, and wait
+// waitseconds for the .pid file to disapear
+// - returns true on success, false on error (e.g. no valid .pid file or
+// the file didn't disappear, which may mean that the daemon is broken)
+function RunUntilSigTerminatedForKill(waitseconds: integer = 30): boolean;
+
+var
+  /// optional folder where the .pid is created
+  // - should include a trailing '/' character
+  // - to be used if the current executable folder is read/only
+  RunUntilSigTerminatedPidFilePath: TFileName;
+
+/// local .pid file name as created by RunUntilSigTerminated(dofork=true)
+function RunUntilSigTerminatedPidFile(ensureWritable: boolean = false): TFileName;
+
+/// check the local .pid file to return either ssRunning or ssStopped
+function RunUntilSigTerminatedState: TServiceState;
+
+var
+  /// once SynDaemonIntercept has been called, this global variable
+  // contains the SIGQUIT / SIGTERM / SIGINT received signal
+  SynDaemonTerminated: integer;
+
+/// enable low-level interception of executable stop signals
+// - any SIGQUIT / SIGTERM / SIGINT signal will set appropriately the global
+// SynDaemonTerminated variable, with an optional logged entry to log
+// - called e.g. by RunUntilSigTerminated() or ConsoleWaitForEnterKey()
+// - you can call this method several times with no issue
+// - onLog can be assigned from TSynLog.DoLog for proper logging
+procedure SynDaemonIntercept(const onlog: TSynLogProc = nil);
+
+/// disable SIGPIPE signal for the current process
+// - is called e.g. by NewOpenSslNetTls since the OpenSsl TLS layer does not
+// (yet) use MSG_NOSIGNAL when accessing the socket
+procedure SigPipeIntercept;
+
+{$endif OSWINDOWS}
+
+/// change the current UID/GID to another user, by name
+// - only implemented on POSIX by now
+function DropPriviledges(const UserName: RawUtf8 = 'nobody'): boolean;
+
+/// changes the root directory of the calling process
+// - only implemented on POSIX by now
+function ChangeRoot(const FolderName: RawUtf8): boolean;
+
+type
+  /// command line patterns recognized by ParseCommandArgs()
+  TParseCommand = (
+    pcHasRedirection,
+    pcHasSubCommand,
+    pcHasParenthesis,
+    pcHasJobControl,
+    pcHasWildcard,
+    pcHasShellVariable,
+    pcUnbalancedSingleQuote,
+    pcUnbalancedDoubleQuote,
+    pcTooManyArguments,
+    pcInvalidCommand,
+    pcHasEndingBackSlash);
+
+  TParseCommands = set of TParseCommand;
+  PParseCommands = ^TParseCommands;
+
+  /// used to store references of arguments recognized by ParseCommandArgs()
+  TParseCommandsArgs = array[0..31] of PAnsiChar;
+  PParseCommandsArgs = ^TParseCommandsArgs;
+
+const
+  /// identifies some bash-specific processing
+  PARSECOMMAND_BASH =
+    [pcHasRedirection .. pcHasShellVariable];
+
+  /// identifies obvious invalid content
+  PARSECOMMAND_ERROR =
+    [pcUnbalancedSingleQuote .. pcHasEndingBackSlash];
+
+  PARSCOMMAND_POSIX = {$ifdef OSWINDOWS} false {$else} true {$endif};
+
+/// low-level parsing of a RunCommand() execution command
+// - parse and fills argv^[0..argc^-1] with corresponding arguments, after
+// un-escaping and un-quoting if applicable, using temp^ to store the content
+// - if argv=nil, do only the parsing, not the argument extraction - could be
+// used for fast validation of the command line syntax
+// - you can force arguments OS flavor using the posix parameter - note that
+// Windows parsing is not consistent by itself (e.g. double quoting or
+// escaping depends on the actual executable called) so returned flags
+// should be considered as indicative only with posix=false
+function ParseCommandArgs(const cmd: RawUtf8; argv: PParseCommandsArgs = nil;
+  argc: PInteger = nil; temp: PRawUtf8 = nil;
+  posix: boolean = PARSCOMMAND_POSIX): TParseCommands;
+
+/// low-level extration of the executable of a RunCommand() execution command
+// - returns the first parameter returned by ParseCommandArgs()
+function ExtractExecutableName(const cmd: RawUtf8;
+  posix: boolean = PARSCOMMAND_POSIX): RawUtf8;
+
+type
+  /// callback used by RunRedirect() to notify of console output at runtime
+  // - newly console output text is given as raw bytes sent by the application,
+  // with no conversion: on POSIX, it is likely to be UTF-8 but on Windows it
+  // depends on the actual program so is likely to be CP_OEM but others could
+  // use the system code page or even UTF-16 binary with BOM (!) - so you
+  // may consider using AnsiToUtf8() with the proper code page
+  // - should return true to stop the execution, or false to continue
+  // - is called once when the process is started, with text='', ignoring its return
+  // - on idle state (each 200ms), is called with text='' to allow execution abort
+  // - the raw process ID (dword on Windows, cint on POSIX) is also supplied
+  TOnRedirect = function(const text: RawByteString; pid: cardinal): boolean of object;
+
+  /// define how RunCommand() and RunRedirect() run their sub-process
+  // - roEnvAddExisting is used when the env pairs should be added to the
+  // existing system environment variable
+  // - roWinJobCloseChildren will setup a Windows Job to close any child
+  // process(es) when the created process quits
+  // - roWinNoProcessDetach will avoid creating a Windows sub-process and group
+  TRunOptions = set of (
+    roEnvAddExisting,
+    roWinJobCloseChildren,
+    roWinNoProcessDetach);
+
+/// like SysUtils.ExecuteProcess, but allowing not to wait for the process to finish
+// - optional env value follows 'n1=v1'#0'n2=v2'#0'n3=v3'#0#0 Windows layout
+function RunProcess(const path, arg1: TFileName; waitfor: boolean;
+  const arg2: TFileName = ''; const arg3: TFileName = '';
+  const arg4: TFileName = ''; const arg5: TFileName = '';
+  const env: TFileName = ''; options: TRunOptions = []): integer;
+
+/// like fpSystem, but cross-platform
+// - under POSIX, calls bash only if needed, after ParseCommandArgs() analysis
+// - under Windows (especially Windows 10), creating a process can be dead slow
+// https://randomascii.wordpress.com/2019/04/21/on2-in-createprocess
+// - waitfordelayms/processhandle/redirected/onoutput exist on Windows only -
+// and redirected is the raw byte output, which may be OEM, WinAnsi or UTF-16
+// depending on the program itself
+// - parsed is implemented on POSIX only
+// - optional env should be encoded as 'n1=v1'#0'n2=v2'#0#0 pairs
+function RunCommand(const cmd: TFileName; waitfor: boolean;
+  const env: TFileName = ''; options: TRunOptions = [];
+  {$ifdef OSWINDOWS}
+  waitfordelayms: cardinal = INFINITE; processhandle: PHandle = nil;
+  redirected: PRawByteString = nil; const onoutput: TOnRedirect = nil;
+  const wrkdir: TFileName = ''
+  {$else}
+  parsed: PParseCommands = nil
+  {$endif OSWINDOWS}): integer;
+
+/// execute a command, returning its output console as UTF-8 text
+// - calling CreateProcessW on Windows (i.e. our RunCommand), and FPC RTL
+// popen/pclose on POSIX
+// - return '' on cmd execution error, or the whole output console content
+// with no conversion: on POSIX, it is likely to be UTF-8 but on Windows it
+// depends on the actual program so is likely to be CP_OEM but others could
+// use the system code page or even UTF-16 binary with BOM (!) - so you
+// may consider using AnsiToUtf8() with the proper code page
+// - will optionally call onoutput() to notify the new output state
+// - aborts if onoutput() callback returns true, or waitfordelayms expires
+// - optional env is Windows only, (FPC popen does not support it), and should
+// be encoded as name=value#0 pairs
+// - you can specify a wrkdir if the path specified by cmd is not good enough
+function RunRedirect(const cmd: TFileName; exitcode: PInteger = nil;
+  const onoutput: TOnRedirect = nil; waitfordelayms: cardinal = INFINITE;
+  setresult: boolean = true; const env: TFileName = '';
+  const wrkdir: TFileName = ''; options: TRunOptions = []): RawByteString;
+
+var
+  /// how many seconds we should wait for gracefull termination of a process
+  // in RunRedirect() - or RunCommand() on Windows
+  // - set 0 to disable gracefull exit, and force hard SIGKILL/TerminateProcess
+  RunAbortTimeoutSecs: integer = 5;
+
+{$ifdef OSWINDOWS}
+type
+  /// how RunRedirect() or RunCommand() should try to gracefully terminate
+  // - ramCtrlC calls CancelProcess(), i.e. send CTRL_C_EVENT
+  // - ramQuit calls QuitProcess(), i.e. send WM_QUIT on all the process threads
+  // - note that TerminateProcess is always called after RunAbortTimeoutSecs
+  // timeout, or if this set of methods is void
+  TRunAbortMethods = set of (ramCtrlC, ramQuit);
+var
+  /// RunRedirect/RunCommand methods to gracefully terminate before TerminateProcess
+  RunAbortMethods: TRunAbortMethods = [ramCtrlC, ramQuit];
+{$else}
+type
+  /// how RunRedirect() should try to gracefully terminate
+  // - ramSigTerm send a fpkill(pid, SIGTERM) to the process
+  // - note that SIGKILL is always sent after RunAbortTimeoutSecs timeout,
+  // or if ramSigTerm was not supplied
+  TRunAbortMethods = set of (ramSigTerm);
+var
+  /// RunRedirect() methods to gracefully terminate before SIGKILL
+  RunAbortMethods: TRunAbortMethods = [ramSigTerm];
+{$endif OSWINDOWS}
+
+
+implementation
+
+// those include files hold all OS-specific functions
+// note: the *.inc files start with their own "uses" clause, so both $include
+// should remain here, just after the "implementation" clause
+
+{$ifdef OSPOSIX}
+  {$include mormot.core.os.posix.inc}
+{$endif OSPOSIX}
+
+{$ifdef OSWINDOWS}
+  {$include mormot.core.os.windows.inc}
+{$endif OSWINDOWS}
+
+
+{ ****************** Some Cross-System Type and Constant Definitions }
+
+const
+  // StatusCodeToReason() StatusCodeToText() table to avoid memory allocations
+  // - roughly sorted by actual usage order for WordScanIndex()
+  HTTP_REASON: array[0..43] of RawUtf8 = (
+   'OK',                                // HTTP_SUCCESS - should be first
+   'No Content',                        // HTTP_NOCONTENT
+   'Temporary Redirect',                // HTTP_TEMPORARYREDIRECT
+   'Permanent Redirect',                // HTTP_PERMANENTREDIRECT
+   'Moved Permanently',                 // HTTP_MOVEDPERMANENTLY
+   'Bad Request',                       // HTTP_BADREQUEST
+   'Unauthorized',                      // HTTP_UNAUTHORIZED
+   'Forbidden',                         // HTTP_FORBIDDEN
+   'Not Found',                         // HTTP_NOTFOUND
+   'Method Not Allowed',                // HTTP_NOTALLOWED
+   'Not Modified',                      // HTTP_NOTMODIFIED
+   'Not Acceptable',                    // HTTP_NOTACCEPTABLE
+   'Partial Content',                   // HTTP_PARTIALCONTENT
+   'Payload Too Large',                 // HTTP_PAYLOADTOOLARGE
+   'Created',                           // HTTP_CREATED
+   'See Other',                         // HTTP_SEEOTHER
+   'Continue',                          // HTTP_CONTINUE
+   'Switching Protocols',               // HTTP_SWITCHINGPROTOCOLS
+   'Accepted',                          // HTTP_ACCEPTED
+   'Non-Authoritative Information',     // HTTP_NONAUTHORIZEDINFO
+   'Reset Content',                     // HTTP_RESETCONTENT
+   'Multi-Status',                      // 207
+   'Multiple Choices',                  // HTTP_MULTIPLECHOICES
+   'Found',                             // HTTP_FOUND
+   'Use Proxy',                         // HTTP_USEPROXY
+   'Proxy Authentication Required',     // HTTP_PROXYAUTHREQUIRED
+   'Request Timeout',                   // HTTP_TIMEOUT
+   'Conflict',                          // HTTP_CONFLICT
+   'Gone',                              // 410
+   'Length Required',                   // 411
+   'Precondition Failed',               // 412
+   'URI Too Long',                      // 414
+   'Unsupported Media Type',            // 415
+   'Requested Range Not Satisfiable',   // HTTP_RANGENOTSATISFIABLE
+   'I''m a teapot',                     // HTTP_TEAPOT
+   'Upgrade Required',                  // 426
+   'Internal Server Error',             // HTTP_SERVERERROR
+   'Not Implemented',                   // HTTP_NOTIMPLEMENTED
+   'Bad Gateway',                       // HTTP_BADGATEWAY
+   'Service Unavailable',               // HTTP_UNAVAILABLE
+   'Gateway Timeout',                   // HTTP_GATEWAYTIMEOUT
+   'HTTP Version Not Supported',        // HTTP_HTTPVERSIONNONSUPPORTED
+   'Network Authentication Required',   // 511
+   'Invalid Request');                  // 513 - should be last
+
+  HTTP_CODE: array[0..43] of word = (
+    HTTP_SUCCESS,
+    HTTP_NOCONTENT,
+    HTTP_TEMPORARYREDIRECT,
+    HTTP_PERMANENTREDIRECT,
+    HTTP_MOVEDPERMANENTLY,
+    HTTP_BADREQUEST,
+    HTTP_UNAUTHORIZED,
+    HTTP_FORBIDDEN,
+    HTTP_NOTFOUND,
+    HTTP_NOTALLOWED,
+    HTTP_NOTMODIFIED,
+    HTTP_NOTACCEPTABLE,
+    HTTP_PARTIALCONTENT,
+    HTTP_PAYLOADTOOLARGE,
+    HTTP_CREATED,
+    HTTP_SEEOTHER,
+    HTTP_CONTINUE,
+    HTTP_SWITCHINGPROTOCOLS,
+    HTTP_ACCEPTED,
+    HTTP_NONAUTHORIZEDINFO,
+    HTTP_RESETCONTENT,
+    207,
+    HTTP_MULTIPLECHOICES,
+    HTTP_FOUND,
+    HTTP_USEPROXY,
+    HTTP_PROXYAUTHREQUIRED,
+    HTTP_TIMEOUT,
+    HTTP_CONFLICT,
+    410,
+    411,
+    412,
+    414,
+    415,
+    HTTP_RANGENOTSATISFIABLE,
+    HTTP_TEAPOT,
+    426,
+    HTTP_SERVERERROR,
+    HTTP_NOTIMPLEMENTED,
+    HTTP_BADGATEWAY,
+    HTTP_UNAVAILABLE,
+    HTTP_GATEWAYTIMEOUT,
+    HTTP_HTTPVERSIONNONSUPPORTED,
+    511,
+    513);
+
+function StatusCodeToText(Code: cardinal): PRawUtf8;
+var
+  i: PtrInt;
+begin
+  if Code <> 200 then // optimistic approach :)
+    if (Code < 513) and
+       (Code >= 100) then
+    begin
+      i := WordScanIndex(@HTTP_CODE, length(HTTP_CODE), Code); // may use SSE2
+      if i < 0 then
+        i := high(HTTP_CODE); // returns cached 513 'Invalid Request'
+    end
+    else
+      i := high(HTTP_CODE)
+  else
+    i := 0;
+  result := @HTTP_REASON[i];
+end;
+
+procedure StatusCodeToReason(Code: cardinal; var Reason: RawUtf8);
+begin
+  Reason := StatusCodeToText(Code)^;
+end;
+
+function StatusCodeToShort(Code: cardinal): TShort47;
+begin
+  if Code > 599 then
+    Code := 999; // ensure stay in TShort47
+  result[0] := #0;
+  AppendShortCardinal(Code, result);
+  AppendShortChar(' ', result);
+  AppendShortAnsi7String(StatusCodeToText(Code)^, result);
+end;
+
+function StatusCodeIsSuccess(Code: integer): boolean;
+begin
+  result := (Code >= HTTP_SUCCESS) and
+            (Code < HTTP_BADREQUEST); // 200..399
+end;
+
+function IsInvalidHttpHeader(head: PUtf8Char; headlen: PtrInt): boolean;
+var
+  i: PtrInt;
+  c: cardinal;
+begin
+  result := true;
+  for i := 0 to headlen - 3 do
+  begin
+    c := PCardinal(head + i)^;
+    if (c = $0a0d0a0d) or
+       (Word(c) = $0d0d) or
+       (Word(c) = $0a0a) then
+      exit;
+  end;
+  result := false;
+end;
+
+function _oskb(Size: QWord): shortstring;
+const
+  _U: array[0..3] of AnsiChar = 'TGMK';
+var
+  u: PtrInt;
+  b: QWord;
+begin
+  u := 0;
+  b := Qword(1) shl 40;
+  repeat
+    if Size > b shr 1 then
+      break;
+    b := b shr 10;
+    inc(u);
+  until u = high(_u);
+  str(Size / b : 1 : 1, result); // let the FPU + RTL do the conversion for us
+  if (result[0] <= #2) or
+     (result[ord(result[0]) - 1] <> '.') or
+     (result[ord(result[0])] <> '0') then
+    inc(result[0], 2);
+  result[ord(result[0]) - 1] := _U[u];
+  result[ord(result[0])] := 'B';
+end;
+
+function SidLength(sid: PSid): PtrInt;
+begin
+  if sid = nil then
+    result := 0
+  else
+    result := integer(sid^.SubAuthorityCount) shl 2 + 8;
+end;
+
+function SidCompare(a, b: PSid): integer;
+var
+  l: PtrInt;
+begin
+  l := SidLength(a);
+  result := l - SidLength(b);
+  if result = 0 then
+    result := MemCmp(pointer(a), pointer(b), l);
+end;
+
+procedure ToRawSid(sid: PSid; out result: RawSid);
+begin
+  if sid <> nil then
+    FastSetRawByteString(RawByteString(result), sid, SidLength(sid));
+end;
+
+procedure SidToTextShort(sid: PSid; var result: shortstring);
+var
+  a: PSidAuth;
+  i: PtrInt;
+begin // faster than ConvertSidToStringSidA(), and cross-platform
+  if (sid = nil ) or
+     (sid^.Revision <> 1) then
+  begin
+    result[0] := #0; // invalid SID
+    exit;
+  end;
+  a := @sid^.IdentifierAuthority;
+  if (a^[0] <> 0) or
+     (a^[1] <> 0) then
+  begin
+    result := 'S-1-0x';
+    for i := 0 to 5 do
+      AppendShortByteHex(a^[i], result)
+  end
+  else
+  begin
+    result := 'S-1-';
+    AppendShortCardinal(bswap32(PCardinal(@a^[2])^), result);
+  end;
+  for i := 0 to integer(sid^.SubAuthorityCount) - 1 do
+  begin
+    AppendShortChar('-', result);
+    AppendShortCardinal(sid^.SubAuthority[i], result);
+  end;
+end;
+
+function SidToText(sid: PSid): RawUtf8;
+var
+  tmp: shortstring;
+begin
+  SidToTextShort(sid, tmp);
+  FastSetString(result, @tmp[1], ord(tmp[0]));
+end;
+
+function SidsToText(sids: PSids): TRawUtf8DynArray;
+var
+  i: PtrInt;
+begin
+  result := nil;
+  SetLength(result, length(sids));
+  for i := 0 to length(sids) - 1 do
+    result[i] := SidToText(sids[i]);
+end;
+
+function IsValidRawSid(const sid: RawSid): boolean;
+var
+  l: PtrInt;
+begin
+  l := length(sid);
+  result := (l >= SizeOf(TSidAuth) + 2) and
+            (SidLength(pointer(sid)) = l)
+end;
+
+function HasSid(const sids: PSids; sid: PSid): boolean;
+var
+  i: PtrInt;
+begin
+  result := true;
+  if sid <> nil then
+    for i := 0 to length(sids) - 1 do
+      if SidCompare(sid, sids[i]) = 0 then
+        exit;
+  result := false;
+end;
+
+function HasAnySid(const sids: PSids; const sid: RawSidDynArray): boolean;
+var
+  i: PtrInt;
+begin
+  result := true;
+  for i := 0 to length(sid) - 1 do
+    if HasSid(sids, pointer(sid[i])) then
+      exit;
+  result := false;
+end;
+
+procedure AddRawSid(var sids: RawSidDynArray; sid: PSid);
+var
+  n: PtrInt;
+begin
+  if sid = nil then
+    exit;
+  n := length(sids);
+  SetLength(sids, n + 1);
+  ToRawSid(sid, sids[n]);
+end;
+
+function RawSidToText(const sid: RawSid): RawUtf8;
+begin
+  if IsValidRawSid(sid) then
+    result := SidToText(pointer(sid))
+  else
+    result := '';
+end;
+
+// GetNextCardinal() on POSIX does not ignore trailing '-'
+function GetNextUInt32(var P: PUtf8Char): cardinal;
+var
+  c: cardinal;
+begin
+  result := 0;
+  if P = nil then
+    exit;
+  repeat
+    c := ord(P^) - 48;
+    if c > 9 then
+      break
+    else
+      result := result * 10 + c;
+    inc(P);
+  until false;
+  while P^ in ['.', '-', ' '] do
+    inc(P);
+end;
+
+function TextToSid(P: PUtf8Char; out sid: TSid): boolean;
+begin
+  result := false;
+  if (P = nil) or
+     (PCardinal(P)^ <>
+        ord('S') + ord('-') shl 8 + ord('1') shl 16 + ord('-') shl 24) then
+    exit;
+  inc(P, 4);
+  if not (P^ in ['1'..'9']) then
+    exit;
+  PInt64(@sid)^ := 1;
+  PCardinal(@sid.IdentifierAuthority[2])^ := bswap32(GetNextUInt32(P));
+  while P^ in ['0'..'9'] do
+  begin
+    sid.SubAuthority[sid.SubAuthorityCount] := GetNextUInt32(P);
+    inc(sid.SubAuthorityCount);
+    if sid.SubAuthorityCount = 0 then
+      exit; // avoid any overflow
+  end;
+  result := P^ = #0
+end;
+
+function TextToRawSid(const text: RawUtf8): RawSid;
+begin
+  TextToRawSid(text, result);
+end;
+
+function TextToRawSid(const text: RawUtf8; out sid: RawSid): boolean;
+var
+  tmp: TSid; // maximum size possible on stack (1032 bytes)
+begin
+  result := TextToSid(pointer(text), tmp);
+  if result then
+    ToRawSid(@tmp, sid)
+end;
+
+var
+  KNOWN_SID_SAFE: TLightLock; // lighter than GlobalLock/GlobalUnLock
+  KNOWN_SID: array[TWellKnownSid] of RawSid;
+  KNOWN_SID_TEXT: array[TWellKnownSid] of string[15];
+const
+  INTEGRITY_SID: array[0..7] of word = ( // S-1-16-x known values
+    0, 4096, 8192, 8448, 12288, 16384, 20480, 28672);
+
+procedure ComputeKnownSid(wks: TWellKnownSid);
+var
+  sid: TSid;
+begin
+  PInt64(@sid)^ := $0101; // sid.Revision=1, sid.SubAuthorityCount=1
+  if wks <= wksLocal then
+  begin // S-1-1-0
+    sid.IdentifierAuthority[5] := ord(wks);
+    sid.SubAuthority[0] := 0;
+  end
+  else if wks = wksConsoleLogon then
+  begin // S-1-2-1
+    sid.IdentifierAuthority[5] := 2;
+    sid.SubAuthority[0] := 1;
+  end
+  else if wks <= wksCreatorGroupServer then
+  begin // S-1-3-0
+    sid.IdentifierAuthority[5] := 3;
+    sid.SubAuthority[0] := ord(wks) - ord(wksCreatorOwner);
+  end
+  else if wks <= wksIntegritySecureProcess then
+  begin
+    sid.IdentifierAuthority[5] := 16; // S-1-16-x
+    sid.SubAuthority[0] := INTEGRITY_SID[ord(wks) - ord(wksIntegrityUntrusted)];
+  end
+  else if wks <= wksAuthenticationKeyPropertyAttestation then
+  begin // S-1-18-1
+    sid.IdentifierAuthority[5] := 18;
+    sid.SubAuthority[0] := ord(wks) - (ord(wksAuthenticationAuthorityAsserted) - 1)
+  end
+  else
+  begin // S-1-5-x
+    sid.IdentifierAuthority[5] := 5;
+    if wks = wksNtAuthority then
+      sid.SubAuthorityCount := 0
+    else if wks <= wksInteractive then
+      sid.SubAuthority[0] := ord(wks) - ord(wksNtAuthority)
+    else if wks <= wksThisOrganisation then
+      sid.SubAuthority[0] := ord(wks) - (ord(wksNtAuthority) - 1)
+    else if wks <= wksNetworkService then
+      sid.SubAuthority[0] := ord(wks) - (ord(wksNtAuthority) - 2)
+    else if wks <= wksLocalAccountAndAdministrator then //  S-1-5-113
+      sid.SubAuthority[0] := ord(wks) - (ord(wksLocalAccount) - 113)
+    else
+    begin
+      sid.SubAuthority[0] := 32;
+      if wks <> wksBuiltinDomain then
+      begin
+        sid.SubAuthorityCount := 2;
+        if wks <= wksBuiltinDcomUsers then
+          sid.SubAuthority[1] := ord(wks) - (ord(wksBuiltinAdministrators) - 544)
+        else if wks <= wksBuiltinDeviceOwners then // S-1-5-32-583
+          sid.SubAuthority[1] := ord(wks) - (ord(wksBuiltinIUsers) - 568)
+        else if wks <= wksCapabilityContacts then
+        begin // S-1-15-3-1
+          sid.IdentifierAuthority[5] := 15;
+          sid.SubAuthority[0] := 3;
+          sid.SubAuthority[1] := ord(wks) - (ord(wksCapabilityInternetClient) - 1)
+        end
+        else if wks <= wksBuiltinAnyRestrictedPackage then
+        begin // S-1-15-2-1
+          sid.IdentifierAuthority[5] := 15;
+          sid.SubAuthority[0] := 2;
+          sid.SubAuthority[1] := ord(wks) - (ord(wksBuiltinAnyPackage) - 1)
+        end
+        else if wks <= wksDigestAuthentication then
+        begin
+          sid.SubAuthority[0] := 64;
+          case wks of
+            wksNtlmAuthentication:
+              sid.SubAuthority[1] := 10; // S-1-5-64-10
+            wksSChannelAuthentication:
+              sid.SubAuthority[1] := 14;
+            wksDigestAuthentication:
+              sid.SubAuthority[1] := 21;
+          end;
+        end;
+      end;
+    end;
+  end;
+  KNOWN_SID_SAFE.Lock;
+  if KNOWN_SID[wks] = '' then
+  begin
+    SidToTextShort(@sid, KNOWN_SID_TEXT[wks]);
+    ToRawSid(@sid, KNOWN_SID[wks]); // to be set last
+  end;
+  KNOWN_SID_SAFE.UnLock;
+end;
+
+function KnownRawSid(wks: TWellKnownSid): RawSid;
+begin
+  if (wks <> wksNull) and
+     (KNOWN_SID[wks] = '') then
+    ComputeKnownSid(wks);
+  result := KNOWN_SID[wks];
+end;
+
+function KnownSidToText(wks: TWellKnownSid): PShortString;
+begin
+  if (wks <> wksNull) and
+     (KNOWN_SID[wks] = '') then
+    ComputeKnownSid(wks);
+  result := @KNOWN_SID_TEXT[wks];
+end;
+
+// https://learn.microsoft.com/en-us/windows/win32/secauthz/well-known-sids
+// https://learn.microsoft.com/en-us/openspecs/windows_protocols/ms-dtyp/81d92bba-d22b-4a8c-908a-554ab29148ab
+
+function SidToKnown(sid: PSid): TWellKnownSid;
+var
+  c: integer;
+begin
+  result := wksNull; // not recognized
+  if (sid = nil) or
+     (sid.Revision <> 1) or
+     (PCardinal(@sid.IdentifierAuthority)^ <> 0) or
+     (sid.IdentifierAuthority[4] <> 0) then
+    exit;
+  case sid.SubAuthorityCount of // very fast O(1) SID binary recognition
+    0:
+      if sid.IdentifierAuthority[5] = 5 then
+        result := wksNtAuthority; // S-1-5
+    1:
+      begin
+        c := sid.SubAuthority[0];
+        case sid.IdentifierAuthority[5] of
+          1:
+            if c = 0 then
+              result := wksWorld; // S-1-1-0
+          2:
+            if c in [0 .. 1] then // S-1-2-x
+              result := TWellKnownSid(ord(wksLocal) + c);
+          3:
+            if c in [0 .. 3] then // S-1-3-x
+              result := TWellKnownSid(ord(wksCreatorOwner) + c);
+          5:
+            case c of // S-1-5-x
+              1 .. 4:
+                result := TWellKnownSid((ord(wksDialup) - 1) + c);
+              6 .. 15:
+                result := TWellKnownSid((ord(wksService) - 6) + c);
+              17 .. 20:
+                result := TWellKnownSid((ord(wksIisUser) - 17) + c);
+              32:
+                result := wksBuiltinDomain;
+              113 .. 114:
+                result := TWellKnownSid(integer(ord(wksLocalAccount) - 113) + c);
+            end;
+          16:
+            begin // S-1-16-x
+              c := WordScanIndex(@INTEGRITY_SID, length(INTEGRITY_SID), c);
+              if c >= 0 then
+                result := TWellKnownSid(ord(wksIntegrityUntrusted) + c);
+            end;
+          18:
+            if c in [1 .. 6] then // S-1-18-x
+              result :=
+                TWellKnownSid((ord(wksAuthenticationAuthorityAsserted) - 1) + c);
+        end;
+      end;
+    2:
+      begin
+        c := sid.SubAuthority[1];
+        case sid.IdentifierAuthority[5] of
+          5:
+            case sid.SubAuthority[0] of
+              32: // S-1-5-32-544
+                case c of
+                  544 .. 562:
+                    result := TWellKnownSid(ord(wksBuiltinAdministrators) + c - 544);
+                  568 .. 583:
+                    result := TWellKnownSid(ord(wksBuiltinIUsers) + c - 568);
+                end;
+              64: // S-1-5-64-10
+                case c of
+                  10:
+                    result := wksNtlmAuthentication;
+                  14:
+                    result := wksSChannelAuthentication;
+                  21:
+                    result := wksDigestAuthentication;
+                end;
+            end;
+          15:
+            case sid.SubAuthority[0] of
+              2:
+                if c in [1 .. 2] then // S-1-15-2-x
+                  result := TWellKnownSid(ord(pred(wksBuiltinAnyPackage)) + c);
+              3:
+                if c in [1 .. 12] then // S-1-15-3-x
+                  result := TWellKnownSid(ord(pred(wksCapabilityInternetClient)) + c);
+            end;
+        end;
+      end;
+  end;
+end;
+
+function SidToKnown(const text: RawUtf8): TWellKnownSid;
+var
+  sid: TSid;
+begin
+  if TextToSid(pointer(text), sid) then
+    result := SidToKnown(@sid)
+  else
+    result := wksNull;
+end;
+
+function SidToKnownGroups(const sids: PSids): TWellKnownSids;
+var
+  k: TWellKnownSid;
+  i: PtrInt;
+begin
+  result := [];
+  for i := 0 to length(sids) - 1 do
+  begin
+    k := SidToKnown(sids[i]);
+    if k <> wksNull then
+      include(result, k);
+  end;
+end;
+
+
+{ ****************** Gather Operating System Information }
+
+function ToText(const osv: TOperatingSystemVersion): RawUtf8;
+begin
+  result := OS_NAME[osv.os];
+  case osv.os of
+    osWindows:
+      result := 'Windows ' + WINDOWS_NAME[osv.win];
+    osOSX:
+      if osv.utsrelease[2] in [low(MACOS_NAME) .. high(MACOS_NAME)] then
+        result := 'macOS ' + MACOS_NAME[osv.utsrelease[2]];
+  end;
+end;
+
+function ToTextShort(const osv: TOperatingSystemVersion): RawUtf8;
+begin
+  result := OS_NAME[osv.os];
+  case osv.os of
+    osWindows:
+      result := WINDOWS_NAME[osv.win];
+    osOSX:
+      if osv.utsrelease[2] in [low(MACOS_NAME) .. high(MACOS_NAME)] then
+        result := MACOS_NAME[osv.utsrelease[2]];
+  end;
+end;
+
+const
+  LINUX_TEXT: array[boolean] of string[7] = (
+    '', 'Linux ');
+
+function ToTextOS(osint32: integer): RawUtf8;
+var
+  osv: TOperatingSystemVersion absolute osint32;
+begin
+  if osint32 = 0 then
+  begin
+    result := '';
+    exit;
+  end;
+  result := ToText(osv);
+  if (osv.os = osWindows) and
+     (osv.winbuild <> 0) then
+    // include the Windows build number, e.g. 'Windows 11 64bit 22000'
+    result := _fmt('%s %d', [result, osv.winbuild]);
+  if (osv.os >= osLinux) and
+     (osv.utsrelease[2] <> 0) then
+    // include kernel number to the distribution name, e.g. 'Ubuntu Linux 5.4.0'
+    result := _fmt('%s %s%d.%d.%d', [result, LINUX_TEXT[osv.os in OS_LINUX],
+      osv.utsrelease[2], osv.utsrelease[1], osv.utsrelease[0]]);
+end;
+
+function MatchOS(os: TOperatingSystem): boolean;
+var
+  current: TOperatingSystem;
+begin
+  current := OS_KIND;
+  if (os = osUnknown) or
+     (current = osUnknown) or
+     (os = current) then
+    result := true // exact match
+  else
+    case os of // search by family
+      osPosix:
+        result := current <> osWindows;
+      osLinux:
+        result := current in OS_LINUX;
+    else
+      result := false;
+    end;
+end;
+
+const
+  // https://github.com/karelzak/util-linux/blob/master/sys-utils/lscpu-arm.c
+  ARMCPU_ID: array[TArmCpuType] of word = (
+    0,      // actUnknown
+    $0810,  // actARM810
+    $0920,  // actARM920
+    $0922,  // actARM922
+    $0926,  // actARM926
+    $0940,  // actARM940
+    $0946,  // actARM946
+    $0966,  // actARM966
+    $0a20,  // actARM1020
+    $0a22,  // actARM1022
+    $0a26,  // actARM1026
+    $0b02,  // actARM11MPCore
+    $0b36,  // actARM1136
+    $0b56,  // actARM1156
+    $0b76,  // actARM1176
+    $0c05,  // actCortexA5
+    $0c07,  // actCortexA7
+    $0c08,  // actCortexA8
+    $0c09,  // actCortexA9
+    $0c0d,  // actCortexA12
+    $0c0f,  // actCortexA15
+    $0c0e,  // actCortexA17
+    $0c14,  // actCortexR4
+    $0c15,  // actCortexR5
+    $0c17,  // actCortexR7
+    $0c18,  // actCortexR8
+    $0c20,  // actCortexM0
+    $0c21,  // actCortexM1
+    $0c23,  // actCortexM3
+    $0c24,  // actCortexM4
+    $0c27,  // actCortexM7
+    $0c60,  // actCortexM0P
+    $0d01,  // actCortexA32
+    $0d03,  // actCortexA53
+    $0d04,  // actCortexA35
+    $0d05,  // actCortexA55
+    $0d06,  // actCortexA65
+    $0d07,  // actCortexA57
+    $0d08,  // actCortexA72
+    $0d09,  // actCortexA73
+    $0d0a,  // actCortexA75
+    $0d0b,  // actCortexA76
+    $0d0c,  // actNeoverseN1
+    $0d0d,  // actCortexA77
+    $0d0e,  // actCortexA76AE
+    $0d13,  // actCortexR52
+    $0d20,  // actCortexM23
+    $0d21,  // actCortexM33
+    $0d40,  // actNeoverseV1
+    $0d41,  // actCortexA78
+    $0d42,  // actCortexA78AE
+    $0d44,  // actCortexX1
+    $0d46,  // actCortex510
+    $0d47,  // actCortex710
+    $0d48,  // actCortexX2
+    $0d49,  // actNeoverseN2
+    $0d4a,  // actNeoverseE1
+    $0d4b,  // actCortexA78C
+    $0d4c,  // actCortexX1C
+    $0d4d,  // actCortexA715
+    $0d4e,  // actCortexX3
+    $0d4f,  // actNeoverseV2
+    $0d80,  // actCortexA520
+    $0d81,  // actCortexA720
+    $0d82,  // actCortexX4
+    $0d84,  // actNeoverseV3
+    $0d8e); // actNeoverseN3
+
+  ARMCPU_IMPL: array[TArmCpuImplementer] of byte = (
+    0,    // aciUnknown
+    $41,  // aciARM
+    $42,  // aciBroadcom
+    $43,  // aciCavium
+    $44,  // aciDEC
+    $46,  // aciFUJITSU
+    $48,  // aciHiSilicon
+    $49,  // aciInfineon
+    $4d,  // aciMotorola
+    $4e,  // aciNVIDIA
+    $50,  // aciAPM
+    $51,  // aciQualcomm
+    $53,  // aciSamsung
+    $56,  // aciMarvell
+    $61,  // aciApple
+    $66,  // aciFaraday
+    $69,  // aciIntel
+    $6d,  // aciMicrosoft
+    $70,  // aciPhytium
+    $c0); // aciAmpere
+
+  ARMCPU_ID_TXT: array[TArmCpuType] of string[15] = (
+     '',
+     'ARM810', 'ARM920', 'ARM922', 'ARM926', 'ARM940', 'ARM946', 'ARM966',
+     'ARM1020', 'ARM1022', 'ARM1026', 'ARM11 MPCore', 'ARM1136', 'ARM1156',
+     'ARM1176', 'Cortex-A5', 'Cortex-A7', 'Cortex-A8', 'Cortex-A9',
+     'Cortex-A17',{Originally A12} 'Cortex-A15', 'Cortex-A17', 'Cortex-R4',
+     'Cortex-R5', 'Cortex-R7', 'Cortex-R8', 'Cortex-M0', 'Cortex-M1',
+     'Cortex-M3', 'Cortex-M4', 'Cortex-M7', 'Cortex-M0+', 'Cortex-A32',
+     'Cortex-A53', 'Cortex-A35', 'Cortex-A55', 'Cortex-A65', 'Cortex-A57',
+     'Cortex-A72', 'Cortex-A73', 'Cortex-A75', 'Cortex-A76', 'Neoverse-N1',
+     'Cortex-A77', 'Cortex-A76AE', 'Cortex-R52', 'Cortex-M23', 'Cortex-M33',
+     'Neoverse-V1', 'Cortex-A78', 'Cortex-A78AE', 'Cortex-X1', 'Cortex-510',
+     'Cortex-710', 'Cortex-X2', 'Neoverse-N2', 'Neoverse-E1', 'Cortex-A78C',
+     'Cortex-X1C', 'Cortex-A715', 'Cortex-X3', 'Neoverse-V2', 'Cortex-A520',
+     'Cortex-A720', 'Cortex-X4', 'Neoverse-V3', 'Neoverse-N3');
+  ARMCPU_IMPL_TXT: array[TArmCpuImplementer] of string[18] = (
+      '',
+      'ARM', 'Broadcom', 'Cavium', 'DEC', 'FUJITSU', 'HiSilicon', 'Infineon',
+      'Motorola/Freescale', 'NVIDIA', 'APM', 'Qualcomm', 'Samsung', 'Marvell',
+      'Apple', 'Faraday', 'Intel', 'Microsoft', 'Phytium', 'Ampere');
+
+function ArmCpuType(id: word): TArmCpuType;
+begin
+  for result := low(TArmCpuType) to high(TArmCpuType) do
+    if ARMCPU_ID[result] = id then
+      exit;
+  result := actUnknown;
+end;
+
+function ArmCpuTypeName(act: TArmCpuType; id: word): RawUtf8;
+begin
+  if act = actUnknown then
+    result := 'ARM 0x' + RawUtf8(IntToHex(id, 3))
+  else
+    ShortStringToAnsi7String(ARMCPU_ID_TXT[act], result);
+end;
+
+function ArmCpuImplementer(id: byte): TArmCpuImplementer;
+begin
+  for result := low(TArmCpuImplementer) to high(TArmCpuImplementer) do
+    if ARMCPU_IMPL[result] = id then
+      exit;
+  result := aciUnknown;
+end;
+
+function ArmCpuImplementerName(aci: TArmCpuImplementer; id: word): RawUtf8;
+begin
+  if aci = aciUnknown then
+    result := 'HW 0x' + RawUtf8(IntToHex(id, 2))
+  else
+    ShortStringToAnsi7String(ARMCPU_IMPL_TXT[aci], result);
+end;
+
+
+{ *************** Per Class Properties O(1) Lookup via vmtAutoTable Slot }
+
+procedure PatchCodePtrUInt(Code: PPtrUInt; Value: PtrUInt; LeaveUnprotected: boolean);
+begin
+  PatchCode(Code, @Value, SizeOf(Code^), nil, LeaveUnprotected);
+end;
+
+{$ifdef CPUINTEL}
+procedure RedirectCode(Func, RedirectFunc: Pointer);
+var
+  rel: PtrInt;
+  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) or
+     (Func = RedirectFunc) then
+    exit; // nothing to redirect to
+  NewJump.Code := $e9; // on both i386 and x86_64
+  rel := PtrInt(PtrUInt(RedirectFunc) - PtrUInt(Func) - SizeOf(NewJump));
+  NewJump.Distance := rel;
+  {$ifdef CPU64}
+  if NewJump.Distance <> rel then
+    exit; // RedirectFunc is too far away from the original code :(
+  {$endif CPU64}
+  PatchCode(Func, @NewJump, SizeOf(NewJump));
+  assert(PByte(Func)^ = $e9);
+end;
+{$endif CPUINTEL}
+
+
+
+{ ************** Cross-Platform Charset and CodePage Support }
+
+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 := CP_WINANSI; // default 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;
+
+
+{ ****************** Unicode, Time, File, Console, Library process }
+
+procedure InitializeCriticalSectionIfNeededAndEnter(var cs: TRTLCriticalSection);
+begin
+  if not IsInitializedCriticalSection(cs) then
+    InitializeCriticalSection(cs);
+  mormot.core.os.EnterCriticalSection(cs);
+end;
+
+procedure DeleteCriticalSectionIfNeeded(var cs: TRTLCriticalSection);
+begin
+  if IsInitializedCriticalSection(cs) then
+    DeleteCriticalSection(cs);
+end;
+
+function Unicode_CodePage: integer;
+begin
+  {$ifdef FPC}
+  // = GetSystemCodePage on POSIX, Lazarus may override to UTF-8 on Windows
+  result := DefaultSystemCodePage;
+  {$else}
+  // Delphi always uses the main Windows System Code Page
+  result := GetACP;
+  {$endif FPC}
+end;
+
+function Unicode_CompareString(PW1, PW2: PWideChar; L1, L2: PtrInt;
+  IgnoreCase: boolean): integer;
+const
+  _CASEFLAG: array[boolean] of DWORD = (0, NORM_IGNORECASE);
+begin
+  result := CompareStringW(LOCALE_USER_DEFAULT, _CASEFLAG[IgnoreCase], PW1, L1, PW2, L2);
+end;
+
+procedure Unicode_WideToShort(W: PWideChar; LW, CodePage: PtrInt;
+  var res: ShortString);
+var
+  i: PtrInt;
+begin
+  if LW <= 0 then
+    res[0] := #0
+  else if (LW <= 255) and
+          IsAnsiCompatibleW(W, LW) then
+  begin
+    // fast handling of pure English content
+    res[0] := AnsiChar(LW);
+    i := 1;
+    repeat
+      res[i] := AnsiChar(W^);
+      if i = LW then
+        break;
+      inc(W);
+      inc(i);
+    until false;
+  end
+  else
+    // use WinAPI, ICU or cwstring/RTL for accurate conversion
+    res[0] := AnsiChar(
+      Unicode_WideToAnsi(W, PAnsiChar(@res[1]), LW, 255, CodePage));
+end;
+
+function NowUtc: TDateTime;
+begin
+  result := UnixMSTimeUtcFast / Int64(MSecsPerDay) + Int64(UnixDelta);
+end;
+
+function DateTimeToWindowsFileTime(DateTime: TDateTime): integer;
+var
+  YY, MM, DD, H, m, s, ms: word;
+begin
+  DecodeDate(DateTime, YY, MM, DD);
+  DecodeTime(DateTime, h, m, s, ms);
+  if (YY < 1980) or
+     (YY > 2099) then
+    result := 0
+  else
+    result := (s shr 1) or (m shl 5) or (h shl 11) or
+      cardinal((DD shl 16) or (MM shl 21) or (cardinal(YY - 1980) shl 25));
+end;
+
+function WindowsFileTimeToDateTime(WinTime: integer): TDateTime;
+var
+  date, time: TDateTime;
+begin
+  with PLongRec(@WinTime)^ do
+  if TryEncodeDate(Hi shr 9 + 1980, Hi shr 5 and 15, Hi and 31, date) and
+     TryEncodeTime(Lo shr 11, Lo shr 5 and 63, Lo and 31 shl 1, 0, time) then
+    result := date + time
+  else
+    result := 0;
+end;
+
+const
+  FileTimePerMs = 10000; // a tick is 100ns
+
+function WindowsFileTime64ToUnixMSTime(WinTime: QWord): TUnixMSTime;
+begin
+  result := (Int64(WinTime) - UnixFileTimeDelta) div FileTimePerMs;
+end;
+
+function DirectorySize(const FileName: TFileName; Recursive: boolean;
+  const Mask: TFileName): Int64;
+var
+  SR: TSearchRec;
+  dir: TFileName;
+begin
+  result := 0;
+  dir := IncludeTrailingPathDelimiter(FileName);
+  if FindFirst(dir + Mask, faAnyFile, SR) <> 0 then
+    exit;
+  repeat
+   if SearchRecValidFile(SR) then
+     inc(result, SR.Size)
+   else if Recursive and
+           SearchRecValidFolder(SR) then
+     inc(result, DirectorySize(dir + SR.Name, true));
+  until FindNext(SR) <> 0;
+  FindClose(SR);
+end;
+
+function SafePathName(const Path: TFileName): boolean;
+var
+  i, o: PtrInt;
+begin
+  if Path <> '' then
+  begin
+    result := false;
+    if (Path[1] = '/') or
+       (PosExString(':', Path) <> 0) or
+       (PosExString('\\', Path) <> 0) then
+      exit;
+    o := 1;
+    repeat
+      i := PosExString('..', Path, o);
+      if i = 0 then
+        break;
+      o := i + 2; // '..test' or 'test..' are valid folder names
+      if cardinal(Path[o]) in [0, ord('\'), ord('/')] then
+        if (i = 1) or
+           (cardinal(Path[i - 1]) in [ord('\'), ord('/')]) then
+          exit;
+    until false;
+  end;
+  result := true;
+end;
+
+function SafePathNameU(const Path: RawUtf8): boolean;
+var
+  i, o: PtrInt;
+begin
+  if Path <> '' then
+  begin
+    result := false;
+    if (Path[1] = '/') or
+       (PosExChar(':', Path) <> 0) or
+       (PosEx('\\', Path) <> 0) then
+      exit;
+    o := 1;
+    repeat
+      i := PosEx('..', Path, o);
+      if i = 0 then
+        break;
+      o := i + 2;
+      if Path[o] in [#0, '\', '/'] then
+        if (i = 1) or
+           (Path[i - 1] in ['\', '/']) then
+          exit;
+    until false;
+  end;
+  result := true;
+end;
+
+function SafeFileName(const FileName: TFileName): boolean;
+begin
+  result := SafePathName(ExtractPath(FileName));
+end;
+
+function SafeFileNameU(const FileName: RawUtf8): boolean;
+begin
+  result := SafePathNameU(ExtractPathU(FileName));
+end;
+
+function NormalizeFileName(const FileName: TFileName): TFileName;
+begin
+  result := StringReplace(FileName, InvertedPathDelim, PathDelim, [rfReplaceAll]);
+end;
+
+function QuoteFileName(const FileName: TFileName): TFileName;
+begin
+  if (FileName <> '') and
+     (PosExString(' ', FileName) <> 0) and
+     (FileName[1] <> '"') then
+    result := '"' + FileName + '"'
+  else
+    result := FileName;
+end;
+
+procedure DisplayError(const fmt: string; const args: array of const);
+var
+  msg: string;
+begin
+  msg := Format(fmt, args);
+  DisplayFatalError('', RawUtf8(msg));
+end;
+
+function SearchRecToDateTime(const F: TSearchRec): TDateTime;
+begin
+  {$ifdef ISDELPHIXE}
+  result := F.Timestamp; // use new API
+  {$else}
+  result := FileDateToDateTime(F.Time);
+  {$endif ISDELPHIXE}
+end;
+
+function SearchRecToDateTimeUtc(const F: TSearchRec): TDateTime;
+begin
+  result := SearchRecToUnixTimeUtc(F) / Int64(SecsPerDay) + Int64(UnixDelta);
+end;
+
+function SearchRecValidFile(const F: TSearchRec): boolean;
+begin
+  result := (F.Name <> '') and
+            (F.Attr and faInvalidFile = 0);
+end;
+
+function SearchRecValidFolder(const F: TSearchRec): boolean;
+begin
+  result := (F.Attr and faDirectoryMask = faDirectory) and
+            (F.Name <> '') and
+            (F.Name <> '.') and
+            (F.Name <> '..');
+end;
+
+{ TFileStreamFromHandle }
+
+destructor TFileStreamFromHandle.Destroy;
+begin
+  if not fDontReleaseHandle then
+    FileClose(Handle); // otherwise file remains opened (FPC RTL inconsistency)
+end;
+
+{ TFileStreamEx }
+
+function TFileStreamEx.GetSize: Int64;
+begin
+  result := FileSize(Handle); // faster than 3 FileSeek() calls
+end;
+
+constructor TFileStreamEx.Create(const aFileName: TFileName; Mode: cardinal);
+var
+  h: THandle;
+begin
+  if Mode and fmCreate = fmCreate then
+    h := FileCreate(aFileName, Mode and (not fmCreate))
+  else
+    h := FileOpen(aFileName, Mode);
+  CreateFromHandle(aFileName, h);
+end;
+
+constructor TFileStreamEx.CreateFromHandle(const aFileName: TFileName; aHandle: THandle);
+begin
+  if not ValidHandle(aHandle) then
+    raise EOSException.CreateFmt('%s.Create(%s) failed as %s',
+      [ClassNameShort(self)^, aFileName, GetErrorText(GetLastError)]);
+  inherited Create(aHandle); // TFileStreamFromHandle constructor which own it 
+  fFileName := aFileName;
+end;
+
+constructor TFileStreamEx.CreateWrite(const aFileName: TFileName);
+var
+  h: THandle;
+begin
+  h := FileOpen(aFileName, fmOpenReadWrite or fmShareRead);
+  if not ValidHandle(h) then // we may need to create the file
+    h := FileCreate(aFileName, fmShareRead);
+  CreateFromHandle(aFileName, h);
+end;
+
+
+{ TFileStreamNoWriteError }
+
+constructor TFileStreamNoWriteError.CreateAndRenameIfLocked(
+  var aFileName: TFileName; aAliases: integer);
+var
+  h: THandle;
+  fn, ext: TFileName;
+  err, retry: integer;
+
+  function CanOpenWrite: boolean;
+  begin
+    h := FileOpen(aFileName, fmOpenReadWrite or fmShareRead);
+    result := ValidHandle(h);
+    if not result then
+      err := GetLastError;
+  end;
+
+begin
+  // logic similar to TSynLog.CreateLogWriter
+  h := 0;
+  err := 0;
+  if not CanOpenWrite then
+    if not FileExists(aFileName) then
+      // immediately raise EOSException if this new file could not be created
+      h := FileCreate(aFileName, fmShareRead)
+    else
+    begin
+      fn := aFileName;
+      ext := ExtractFileExt(aFileName);
+      for retry := 1 to aAliases do
+      begin
+        if IsSharedViolation(err) then
+        begin
+          // file was locked: wait a little for a background process and retry
+          SleepHiRes(50);
+          if CanOpenWrite then
+            break;
+        end;
+        // file can't be opened: try '-locked<#>.' alternatives
+        aFileName := ChangeFileExt(fn, '-locked' + IntToStr(retry) + ext);
+        if CanOpenWrite then
+          break;
+      end;
+    end;
+  CreateFromHandle(aFileName, h);
+end;
+
+function TFileStreamNoWriteError.Write(const Buffer; Count: Longint): Longint;
+begin
+  FileWriteAll(Handle, @Buffer, Count); // and ignore any I/O error
+  result := Count; //
+end;
+
+
+function FileStreamSequentialRead(const FileName: TFileName): THandleStream;
+begin
+  result := TFileStreamFromHandle.Create(FileOpenSequentialRead(FileName));
+end;
+
+function StreamCopyUntilEnd(Source, Dest: TStream): Int64;
+var
+  tmp: array[word] of word; // 128KB stack buffer
+  read: integer;
+begin
+  result := 0;
+  if (Source <> nil) and
+     (Dest <> nil) then
+    repeat
+      read := Source.Read(tmp, SizeOf(tmp));
+      if read <= 0 then
+        break;
+      Dest.WriteBuffer(tmp, read);
+      inc(result, read);
+    until false;
+end;
+
+function FileReadAll(F: THandle; Buffer: pointer; Size: PtrInt): boolean;
+var
+  chunk, read: PtrInt;
+begin
+  result := false;
+  if Size > 0 then
+    repeat
+      chunk := Size;
+      {$ifdef OSWINDOWS}
+      if chunk > 16 shl 20 then
+        chunk := 16 shl 20; // to avoid ERROR_NO_SYSTEM_RESOURCES errors
+      {$endif OSWINDOWS}
+      read := FileRead(F, Buffer^, chunk);
+      if read <= 0 then
+        exit; // error reading Size bytes
+      inc(PByte(Buffer), read);
+      dec(Size, read);
+    until Size = 0;
+  result := true;
+end;
+
+function FileWriteAll(F: THandle; Buffer: pointer; Size: PtrInt): boolean;
+var
+  written: PtrInt;
+begin
+  result := false;
+  if Size > 0 then
+    repeat
+      written := FileWrite(F, Buffer^, Size);
+      if written <= 0 then
+        exit; // fatal error
+      inc(PByte(Buffer), written); // e.g. may have been interrrupted
+      dec(Size, written);
+    until Size = 0;
+  result := true;
+end;
+
+function StringFromFile(const FileName: TFileName; HasNoSize: boolean): RawByteString;
+var
+  F: THandle;
+  size: Int64;
+  read, pos: integer;
+  tmp: array[0..$7fff] of AnsiChar; // 32KB stack buffer
+begin
+  result := '';
+  if FileName = '' then
+    exit;
+  F := FileOpenSequentialRead(FileName); // = plain fpOpen() on POSIX
+  if ValidHandle(F) then
+  begin
+    if HasNoSize then
+    begin
+      pos := 0;
+      repeat
+        read := FileRead(F, tmp, SizeOf(tmp)); // fill per 32KB local buffer
+        if read <= 0 then
+          break;
+        SetLength(result, pos + read); // in-place resize
+        MoveFast(tmp, PByteArray(result)^[pos], read);
+        inc(pos, read);
+      until false;
+    end
+    else
+    begin
+      size := FileSize(F);
+      if (size < MaxInt) and // 2GB seems big enough for a RawByteString
+         (size > 0) then
+      begin
+        FastSetString(RawUtf8(result), size); // assume CP_UTF8 for FPC RTL bug
+        if not FileReadAll(F, pointer(result), size) then
+          result := ''; // error reading
+      end;
+    end;
+    FileClose(F);
+  end;
+end;
+
+function StringFromFirstFile(const FileName: array of TFileName): RawByteString;
+var
+  f: PtrInt;
+begin
+  for f := 0 to high(FileName) do
+  begin
+    result := StringFromFile(FileName[f]);
+    if result <> '' then
+      exit;
+  end;
+  result := '';
+end;
+
+function StringFromFiles(const FileName: array of TFileName): TRawByteStringDynArray;
+var
+  f: PtrInt;
+begin
+  result := nil;
+  SetLength(result, length(FileName));
+  for f := 0 to high(FileName) do
+    result[f] := StringFromFile(FileName[f]);
+end;
+
+function StringFromFolders(const Folders: array of TFileName;
+  const Mask: TFileName; FileNames: PFileNameDynArray): TRawByteStringDynArray;
+var
+  dir, fn: TFileName;
+  sr: TSearchRec;
+  f, n: PtrInt;
+  one: RawUtf8;
+begin
+  result := nil;
+  if FileNames <> nil then
+    FileNames^ := nil;
+  n := 0;
+  for f := 0 to high(Folders) do
+    if DirectoryExists(Folders[f]) then
+    begin
+      dir := IncludeTrailingPathDelimiter(Folders[f]);
+      if FindFirst(dir + Mask, faAnyFile - faDirectory, sr) = 0 then
+      begin
+        repeat
+          if SearchRecValidFile(sr) then
+          begin
+            fn := dir + sr.Name;
+            one := StringFromFile(fn);
+            if one <> '' then
+            begin
+              if length(result) = n then
+              begin
+                SetLength(result, NextGrow(n));
+                if FileNames <> nil then
+                  SetLength(FileNames^, length(result));
+              end;
+              result[n] := one;
+              if FileNames <> nil then
+                FileNames^[n] := fn;
+              inc(n);
+            end;
+          end;
+        until FindNext(sr) <> 0;
+        FindClose(sr);
+      end;
+    end;
+  if n = 0 then
+    exit;
+  DynArrayFakeLength(result, n);
+  if FileNames <> nil then
+    DynArrayFakeLength(FileNames^, n);
+end;
+
+function FileFromString(const Content: RawByteString;
+  const FileName: TFileName; FlushOnDisk: boolean): boolean;
+var
+  h: THandle;
+begin
+  result := false;
+  h := FileCreate(FileName);
+  if not ValidHandle(h) then
+    exit;
+  if not FileWriteAll(h, pointer(Content), length(Content)) then
+  begin
+    FileClose(h); // abort on write error
+    exit;
+  end;
+  if FlushOnDisk then
+    FlushFileBuffers(h);
+  FileClose(h);
+  result := true;
+end;
+
+function FileFromBuffer(Buf: pointer; Len: PtrInt; const FileName: TFileName): boolean;
+var
+  h: THandle;
+begin
+  result := false;
+  h := FileCreate(FileName);
+  if not ValidHandle(h) then
+    exit;
+  result := FileWriteAll(h, Buf, Len);
+  FileClose(h);
+end;
+
+function AppendToFile(const Content: RawUtf8; const FileName: TFileName;
+  BackupOverMaxSize: Int64): boolean;
+var
+  h: THandle;
+  bak: TFileName;
+begin
+  result := Content = '';
+  if result then
+    exit;
+  if (BackupOverMaxSize > 0) and
+     (FileSize(FileName) > BackupOverMaxSize) then
+  begin
+    bak := FileName + '.bak';
+    DeleteFile(bak);
+    RenameFile(FileName, bak);
+    h := 0;
+  end
+  else
+    h := FileOpen(FileName, fmOpenWriteShared);
+  if ValidHandle(h) then
+    FileSeek64(h, 0, soFromEnd) // append
+  else
+  begin
+    h := FileCreate(FileName, fmShareReadWrite);
+    if not ValidHandle(h) then
+      exit;
+  end;
+  result := FileWriteAll(h, pointer(Content), Length(Content));
+  FileClose(h);
+end;
+
+var
+  _TmpCounter: integer;
+
+function TemporaryFileName: TFileName;
+var
+  folder: TFileName;
+  retry: integer;
+begin
+  // fast cross-platform implementation
+  folder := GetSystemPath(spTemp);
+  if _TmpCounter = 0 then
+    _TmpCounter := Random32;
+  retry := 10;
+  repeat
+    // thread-safe unique file name generation
+    result := Format('%s%s_%x.tmp',
+      [folder, Executable.ProgramName, InterlockedIncrement(_TmpCounter)]);
+    if not FileExists(result) then
+      exit;
+    dec(retry); // no endless loop
+  until retry = 0;
+  raise EOSException.Create('TemporaryFileName failed');
+end;
+
+function GetLastDelim(const FileName: TFileName; OtherDelim: cardinal): PtrInt;
+var
+  {$ifdef UNICODE}
+  p: PWordArray absolute FileName;
+  {$else}
+  p: PByteArray absolute FileName;
+  {$endif UNICODE}
+begin
+  result := length(FileName);
+  while (result > 0) and
+        not (p[result - 1] in [ord('\'), ord('/'), ord(':'), OtherDelim]) do
+    dec(result);
+end;
+
+function GetLastDelimU(const FileName: RawUtf8; OtherDelim: AnsiChar): PtrInt;
+begin
+  result := length(FileName);
+  while (result > 0) and
+        not (FileName[result] in ['\', '/', ':', OtherDelim]) do
+    dec(result);
+end;
+
+function ExtractPath(const FileName: TFileName): TFileName;
+begin
+  SetString(result, PChar(pointer(FileName)), GetLastDelim(FileName, 0));
+end;
+
+function ExtractName(const FileName: TFileName): TFileName;
+begin
+  result := copy(FileName, GetLastDelim(FileName, 0) + 1, maxInt);
+end;
+
+function ExtractNameU(const FileName: RawUtf8): RawUtf8;
+begin
+  result := copy(FileName, GetLastDelimU(FileName, #0) + 1, maxInt);
+end;
+
+function ExtractPathU(const FileName: RawUtf8): RawUtf8;
+begin
+  FastSetString(result, pointer(FileName), GetLastDelimU(FileName, #0));
+end;
+
+function ExtractExt(const FileName: TFileName; WithoutDot: boolean): TFileName;
+var
+  i: PtrInt;
+begin
+  result := '';
+  i := GetLastDelim(FileName, ord('.'));
+  if (i <= 1) or
+     (FileName[i] <> '.') then
+    exit;
+  if WithoutDot then
+    inc(i);
+  result := copy(FileName, i, 100);
+end;
+
+function ExtractExtU(const FileName: RawUtf8; WithoutDot: boolean): RawUtf8;
+var
+  i: PtrInt;
+begin
+  result := '';
+  i := GetLastDelimU(FileName, '.');
+  if (i <= 1) or
+     (FileName[i] <> '.') then
+    exit;
+  if WithoutDot then
+    inc(i);
+  result := copy(FileName, i, 100);
+end;
+
+function ExtractExtP(const FileName: RawUtf8; WithoutDot: boolean): PUtf8Char;
+var
+  i: PtrInt;
+begin
+  result := nil;
+  i := GetLastDelimU(FileName, '.') - 1;
+  if i <= 0 then
+    exit;
+  result := PUtf8Char(pointer(FileName)) + i;
+  if result^ <> '.' then
+    result := nil
+  else if WithoutDot then
+    inc(result);
+end;
+
+function GetFileNameWithoutExt(const FileName: TFileName; Extension: PFileName): TFileName;
+var
+  i, max: PtrInt;
+begin
+  i := length(FileName);
+  max := i - 16; // a file .extension is unlikely to be more than 16 chars
+  while (i > 0) and
+        not (cardinal(FileName[i]) in [ord('\'), 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, 100);
+  end;
+end;
+
+function GetFileNameWithoutExtOrPath(const FileName: TFileName): RawUtf8;
+begin
+  result := RawUtf8(GetFileNameWithoutExt(ExtractFileName(FileName)));
+end;
+
+{$ifdef ISDELPHI20062007} // circumvent Delphi 2007 RTL inlining issue
+function AnsiCompareFileName(const S1, S2 : TFileName): integer;
+begin
+  result := SysUtils.AnsiCompareFileName(S1,S2);
+end;
+{$endif ISDELPHI20062007}
+
+function SortDynArrayFileName(const A, B): integer;
+var
+  Aname, Aext, Bname, Bext: TFileName;
+begin
+  // code below is not very fast, but 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 EnsureDirectoryExists(const Directory: TFileName;
+  RaiseExceptionOnCreationFailure: ExceptionClass): TFileName;
+begin
+  if Directory = '' then
+    if RaiseExceptionOnCreationFailure <> nil then
+      raise RaiseExceptionOnCreationFailure.Create('EnsureDirectoryExists('''')')
+    else
+      result := ''
+  else
+  begin
+    result := IncludeTrailingPathDelimiter(ExpandFileName(Directory));
+    if not DirectoryExists(result) then
+      if not ForceDirectories(result) then
+        if RaiseExceptionOnCreationFailure <> nil then
+          raise RaiseExceptionOnCreationFailure.CreateFmt(
+            'EnsureDirectoryExists(%s) failed as %s',
+            [result, GetErrorText(GetLastError)])
+        else
+          result := '';
+  end;
+end;
+
+function NormalizeDirectoryExists(const Directory: TFileName;
+  RaiseExceptionOnCreationFailure: ExceptionClass): TFileName;
+begin
+  result := EnsureDirectoryExists(NormalizeFileName(Directory),
+    RaiseExceptionOnCreationFailure);
+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 := NowUtc - TimePeriod;
+    repeat
+      if SearchRecValidFolder(F) then
+      begin
+        if Recursive then
+          DirectoryDeleteOlderFiles(
+            Dir + F.Name, TimePeriod, Mask, true, TotalSize);
+      end
+      else if SearchRecValidFile(F) and
+              (SearchRecToDateTimeUtc(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;
+
+var
+  lastIsDirectoryWritable: TFileName; // naive but efficient cache
+
+function IsDirectoryWritable(const Directory: TFileName;
+  Flags: TIsDirectoryWritable): boolean;
+var
+  dir, last, fmt, fn: TFileName;
+  f: THandle;
+  retry: integer;
+begin
+  // check the Directory itself
+  result := false;
+  if Directory = '' then
+    exit;                       
+  dir := ExcludeTrailingPathDelimiter(Directory);
+  if Flags = [] then
+  begin
+    last := lastIsDirectoryWritable;
+    result := (last <> '') and
+              (dir = last);
+    if result then
+      exit; // we just tested this folder
+  end;
+  if not FileIsWritable(dir) then
+    exit; // the folder does not exist or is read-only for the current user
+  {$ifdef OSWINDOWS}
+  // ensure is not a system/virtual folder
+  if ((idwExcludeWinUac in Flags) and
+      IsUacVirtualFolder(dir)) or
+     ((idwExcludeWinSys in Flags) and
+      IsSystemFolder(dir)) then
+    exit;
+  // compute a non existing temporary file name in this Directory
+  if idwTryWinExeFile in Flags then
+    fmt := '%s\%x.exe'  // may trigger the anti-virus heuristic
+  else
+    fmt := '%s\%x.test'; // neutral file name
+    // we tried .crt which triggered UAC heuristic but also some anti-viruses :(
+  {$else}
+  // compute a non existing temporary file name in this Directory
+  fmt := '%s/.%x.test'; // make the file "invisible"
+  {$endif OSWINDOWS}
+  retry := 10;
+  repeat
+    fn := Format(fmt, [dir, Random32]);
+    if not FileExists(fn) then
+      break;
+    dec(retry); // never loop forever
+    if retry = 0 then
+      exit;
+  until false;
+  // ensure we can create this temporary file
+  f := FileCreate(fn);
+  if not ValidHandle(f) then
+    exit; // a file can't be created
+  result := true;
+  if (idwWriteSomeContent in flags) and // some pointers and hash
+     (FileWrite(f, Executable, SizeOf(Executable)) <> SizeOf(Executable)) then
+    result := false;
+  FileClose(f);
+  if not DeleteFile(fn) then // success if the file can be created and deleted
+    result := false
+  else if result then
+    lastIsDirectoryWritable := dir
+end;
+
+
+{$ifndef NOEXCEPTIONINTERCEPT}
+
+{$ifdef WITH_RAISEPROC} // for FPC on Win32 + Linux (Win64=WITH_VECTOREXCEPT)
+var
+  OldRaiseProc: TExceptProc;
+
+procedure SynRaiseProc(Obj: TObject; Addr: CodePointer;
+  FrameCount: integer; Frame: PCodePointer);
+var
+  ctxt: TSynLogExceptionContext;
+  backuplasterror: DWORD;
+  backuphandler: TOnRawLogException;
+begin
+  if (Obj <> nil) and
+     Obj.InheritsFrom(Exception) then
+  begin
+    backuplasterror := GetLastError;
+    backuphandler := _RawLogException;
+    if Assigned(backuphandler) then
+      try
+        _RawLogException := nil; // disable nested exception
+        ctxt.EClass := PPointer(Obj)^;
+        ctxt.EInstance := Exception(Obj);
+        ctxt.EAddr := PtrUInt(Addr);
+        if Obj.InheritsFrom(EExternal) then
+          ctxt.ELevel := sllExceptionOS
+        else
+          ctxt.ELevel := sllException;
+        ctxt.ETimestamp := UnixTimeUtc;
+        ctxt.EStack := pointer(Frame);
+        ctxt.EStackCount := FrameCount;
+        backuphandler(ctxt);
+      except
+        { ignore any nested exception }
+      end;
+    _RawLogException := backuphandler;
+    SetLastError(backuplasterror); // may have changed above
+  end;
+  if Assigned(OldRaiseProc) then
+    OldRaiseProc(Obj, Addr, FrameCount, Frame);
+end;
+
+{$endif WITH_RAISEPROC}
+
+var
+  RawExceptionIntercepted: boolean;
+
+procedure RawExceptionIntercept(const Handler: TOnRawLogException);
+begin
+  _RawLogException := Handler;
+  if RawExceptionIntercepted or
+     not Assigned(Handler) then
+    exit;
+  RawExceptionIntercepted := true; // intercept once
+  {$ifdef WITH_RAISEPROC}
+  // FPC RTL redirection function
+  if not Assigned(OldRaiseProc) then
+  begin
+    OldRaiseProc := RaiseProc;
+    RaiseProc := @SynRaiseProc;
+  end;
+  {$endif WITH_RAISEPROC}
+  {$ifdef WITH_VECTOREXCEPT} // SEH32/SEH64 official API
+  // RemoveVectoredContinueHandler() is available under 64 bit editions only
+  if Assigned(AddVectoredExceptionHandler) then
+  begin
+    AddVectoredExceptionHandler(0, @SynLogVectoredHandler);
+    AddVectoredExceptionHandler := nil;
+  end;
+  {$endif WITH_VECTOREXCEPT}
+  {$ifdef WITH_RTLUNWINDPROC}
+  // Delphi x86 RTL redirection function
+  if not Assigned(OldUnWindProc) then
+  begin
+    OldUnWindProc := RTLUnwindProc;
+    RTLUnwindProc := @SynRtlUnwind;
+  end;
+  {$endif WITH_RTLUNWINDPROC}
+end;
+
+{$endif NOEXCEPTIONINTERCEPT}
+
+
+{ TMemoryMap }
+
+function TMemoryMap.Map(aFile: THandle; aCustomSize: PtrUInt;
+  aCustomOffset: Int64; aFileOwned: boolean; aFileSize: Int64): boolean;
+var
+  Available: Int64;
+begin
+  fBuf := nil;
+  fBufSize := 0;
+  {$ifdef OSWINDOWS}
+  fMap := 0;
+  {$endif OSWINDOWS}
+  fFileLocal := aFileOwned;
+  fFile := aFile;
+  if aFileSize < 0 then
+    aFileSize := mormot.core.os.FileSize(fFile);
+  fFileSize := aFileSize;
+  if aFileSize = 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 on CPU32)
+    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;
+  fLoadedNotMapped := fBufSize < 1 shl 20;
+  if fLoadedNotMapped then
+  begin
+    // mapping is not worth it for size < 1MB which can be just read at once
+    GetMem(fBuf, fBufSize);
+    FileSeek64(fFile, aCustomOffset);
+    if FileReadAll(fFile, fBuf, fBufSize) then
+      result := true
+    else
+    begin
+      Freemem(fBuf);
+      fBuf := nil;
+      fLoadedNotMapped := false;
+    end;
+  end
+  else
+    // call actual Windows/POSIX memory mapping API
+    result := DoMap(aCustomOffset);
+end;
+
+procedure TMemoryMap.Map(aBuffer: pointer; aBufferSize: PtrUInt);
+begin
+  fBuf := aBuffer;
+  fFileSize := aBufferSize;
+  fBufSize := aBufferSize;
+  {$ifdef OSWINDOWS}
+  fMap := 0;
+  {$endif OSWINDOWS}
+  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, fmOpenReadShared);
+  if not ValidHandle(F) then
+    exit;
+  result := Map(F);
+  if not result then
+    FileClose(F);
+  fFileLocal := result;
+end;
+
+procedure TMemoryMap.UnMap;
+begin
+  if fLoadedNotMapped then
+    // mapping was not worth it
+    Freemem(fBuf)
+  else
+    // call actual Windows/POSIX map API
+    DoUnMap;
+  fBuf := nil;
+  fBufSize := 0;
+  if fFile <> 0 then
+  begin
+    if fFileLocal then
+      FileClose(fFile);
+    fFile := 0;
+  end;
+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 := TFileStreamEx.Create(aFileName, fmOpenReadShared);
+  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 EOSException.CreateFmt('%s.Create(%s) mapping error',
+      [ClassNameShort(self)^, fFileName]);
+  inherited Create(fMap.fBuf, fMap.fBufSize);
+end;
+
+destructor TSynMemoryStreamMapped.Destroy;
+begin
+  fMap.UnMap;
+  fFileStream.Free;
+  inherited;
+end;
+
+
+{ TExecutableResource }
+
+function TExecutableResource.Open(const ResourceName: string; ResType: PChar;
+  Instance: TLibHandle): boolean;
+begin
+  result := false;
+  if Instance = 0 then
+    Instance := HInstance;
+  HResInfo := FindResource(Instance, PChar(ResourceName), ResType);
+  if HResInfo = 0 then
+    exit;
+  HGlobal := LoadResource(Instance, HResInfo);
+  if HGlobal = 0 then // direct decompression from memory mapped .exe content
+    exit;
+  Buffer := LockResource(HGlobal);
+  Size := SizeofResource(Instance, HResInfo);
+  if Size > 0 then
+    result := true
+  else
+    Close; // paranoid check
+end;
+
+procedure TExecutableResource.Close;
+begin
+  if HGlobal <> 0 then
+  begin
+    UnlockResource(HGlobal); // only needed outside of Windows
+    FreeResource(HGlobal);
+    HGlobal := 0;
+  end;
+end;
+
+
+{ ReserveExecutableMemory() / TFakeStubBuffer }
+
+type
+  // internal memory buffer created with PAGE_EXECUTE_READWRITE flags
+  TFakeStubBuffer = class
+  public
+    Stub: PByteArray;
+    StubUsed: cardinal;
+    constructor Create;
+    destructor Destroy; override;
+    function Reserve(size: cardinal): pointer;
+  end;
+
+var
+  CurrentFakeStubBuffer: TFakeStubBuffer;
+  CurrentFakeStubBuffers: array of TFakeStubBuffer;
+  CurrentFakeStubBufferLock: TLightLock;
+  {$ifdef UNIX}
+  MemoryProtection: boolean = false; // set to true if PROT_EXEC seems to fail
+  {$endif UNIX}
+
+constructor TFakeStubBuffer.Create;
+begin
+  {$ifdef OSWINDOWS}
+  Stub := VirtualAlloc(nil, STUB_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
+  if Stub = nil then
+  {$else OSWINDOWS}
+  if not MemoryProtection then
+    Stub := StubCallAllocMem(STUB_SIZE, PROT_READ or PROT_WRITE or PROT_EXEC);
+  if (Stub = MAP_FAILED) or
+     MemoryProtection then
+  begin
+    // i.e. on OpenBSD or OSX M1, we can not have w^x protection
+    Stub := StubCallAllocMem(STUB_SIZE, PROT_READ OR PROT_WRITE);
+    if Stub <> MAP_FAILED then
+      MemoryProtection := True;
+  end;
+  if Stub = MAP_FAILED then
+  {$endif OSWINDOWS}
+    raise EOSException.Create('ReserveExecutableMemory(): OS mmap failed');
+  PtrArrayAdd(CurrentFakeStubBuffers, self);
+end;
+
+destructor TFakeStubBuffer.Destroy;
+begin
+  {$ifdef OSWINDOWS}
+  VirtualFree(Stub, 0, MEM_RELEASE);
+  {$else}
+  fpmunmap(Stub, STUB_SIZE);
+  {$endif OSWINDOWS}
+  inherited;
+end;
+
+function TFakeStubBuffer.Reserve(size: cardinal): pointer;
+begin
+  result := @Stub[StubUsed];
+  while size and 15 <> 0 do
+    inc(size); // ensure the returned buffers are 16 bytes aligned
+  inc(StubUsed, size);
+end;
+
+function ReserveExecutableMemory(size: cardinal): pointer;
+begin
+  if size > STUB_SIZE then
+    raise EOSException.CreateFmt('ReserveExecutableMemory(size=%d>%d)',
+      [size, STUB_SIZE]);
+  CurrentFakeStubBufferLock.Lock;
+  try
+    if (CurrentFakeStubBuffer = nil) or
+       (CurrentFakeStubBuffer.StubUsed + size > STUB_SIZE) then
+      CurrentFakeStubBuffer := TFakeStubBuffer.Create;
+    result := CurrentFakeStubBuffer.Reserve(size);
+  finally
+    CurrentFakeStubBufferLock.UnLock;
+  end;
+end;
+
+{$ifdef UNIX}
+procedure ReserveExecutableMemoryPageAccess(Reserved: pointer; Exec: boolean);
+var
+  PageAlignedFakeStub: pointer;
+  flags: cardinal;
+begin
+  if not MemoryProtection then
+    // nothing to be done on this platform
+    exit;
+  // toggle execution permission of memory to be able to write into memory
+  PageAlignedFakeStub := Pointer(
+    (PtrUInt(Reserved) div SystemInfo.dwPageSize) * SystemInfo.dwPageSize);
+  if Exec then
+    flags := PROT_READ OR PROT_EXEC
+  else
+    flags := PROT_READ or PROT_WRITE;
+  if SynMProtect(PageAlignedFakeStub, SystemInfo.dwPageSize shl 1, flags) < 0 then
+     raise EOSException.Create('ReserveExecutableMemoryPageAccess: mprotect fail');
+end;
+{$else}
+procedure ReserveExecutableMemoryPageAccess(Reserved: pointer; Exec: boolean);
+begin
+  // nothing to be done
+end;
+{$endif UNIX}
+
+{$ifndef PUREMORMOT2}
+function GetDelphiCompilerVersion: RawUtf8;
+begin
+  result := COMPILER_VERSION;
+end;
+{$endif PUREMORMOT2}
+
+function GetMemoryInfoText: RawUtf8;
+var
+  info: TMemoryInfo;
+begin
+  if GetMemoryInfo(info, false) then
+    _fmt('used %s/%s (%d%s free)', [_oskb(info.memtotal - info.memfree),
+      _oskb(info.memtotal), info.percent, '%'], result)
+  else
+    result := '';
+end;
+
+function GetDiskAvailable(aDriveFolderOrFile: TFileName): QWord;
+var
+  free, total: QWord; // dummy values
+begin
+  if not GetDiskInfo(aDriveFolderOrFile, result, free, total) then
+    result := 0;
+end;
+
+function GetSystemInfoText: RawUtf8;
+var
+  avail, free, total: QWord;
+begin
+  GetDiskInfo(Executable.ProgramFilePath, avail, free, total);
+  result := _fmt('Current UTC date is %s (%d)'#13#10'Memory %s'#13#10 +
+                 'Executable free disk %s/%s'#13#10 +
+                 {$ifdef OSPOSIX} 'LoadAvg is %s'#13#10 + {$endif OSPOSIX}
+                 '%s'#13#10'%s'#13#10'%s'#13#10'%s'#13#10,
+    [FormatDateTime('yyyy"-"mm"-"dd" "hh":"nn":"ss', NowUtc), UnixTimeUtc,
+     GetMemoryInfoText, _oskb(avail), _oskb(total),
+     {$ifdef OSPOSIX} RetrieveLoadAvg, {$endif} Executable.Version.VersionInfo,
+     OSVersionText, CpuInfoText, BiosInfoText]);
+end;
+
+function ConsoleReadBody: RawByteString;
+var
+  len, n: integer;
+  P: PByte;
+begin
+  len := ConsoleStdInputLen;
+  FastNewRawByteString(result, len);
+  P := pointer(result);
+  while len > 0 do
+  begin
+    n := FileRead(StdInputHandle, P^, len);
+    if n <= 0 then
+    begin
+      result := ''; // read error
+      break;
+    end;
+    dec(len, n);
+    inc(P, n);
+  end;
+end;
+
+var
+  GlobalCriticalSection: TOSLock;
+
+{ TSynLibrary }
+
+function TSynLibrary.Resolve(const Prefix, ProcName: RawUtf8; Entry: PPointer;
+  RaiseExceptionOnFailure: ExceptionClass): boolean;
+var
+  P: PAnsiChar;
+  name, search: RawUtf8;
+{$ifdef OSPOSIX}
+  dlinfo: dl_info;
+{$endif OSPOSIX}
+begin
+  result := false;
+  if (Entry = nil) or
+     (fHandle = 0) or
+     (ProcName = '') then
+    exit; // avoid GPF
+  P := pointer(ProcName);
+  repeat
+    name := GetNextItem(P); // try all alternate names
+    if name = '' then
+      break;
+    if name[1] = '?' then
+    begin
+      RaiseExceptionOnFailure := nil;
+      delete(name, 1, 1);
+    end;
+    search := Prefix + name;
+    Entry^ := LibraryResolve(fHandle, pointer(search));
+    if (Entry^ = nil) and
+       (Prefix <> '') then // try without the prefix
+      Entry^ := LibraryResolve(fHandle, pointer(name));
+    result := Entry^ <> nil;
+  until result;
+  {$ifdef OSPOSIX}
+  if result and
+     not fLibraryPathTested then
+  begin
+    fLibraryPathTested := true;
+    FillCharFast(dlinfo, SizeOf(dlinfo), 0);
+    dladdr(Entry^, @dlinfo);
+    if dlinfo.dli_fname <> nil then
+      fLibraryPath := dlinfo.dli_fname;
+  end;
+  {$endif OSPOSIX}
+  if (RaiseExceptionOnFailure <> nil) and
+     not result then
+  begin
+    FreeLib;
+    raise RaiseExceptionOnFailure.CreateFmt(
+      '%s.Resolve(''%s%s''): not found in %s',
+      [ClassNameShort(self)^, Prefix, ProcName, LibraryPath]);
+  end;
+end;
+
+function TSynLibrary.ResolveAll(ProcName: PPAnsiChar; Entry: PPointer): boolean;
+var
+  tmp: RawUtf8;
+begin
+  repeat
+    if ProcName^ = nil then
+      break;
+    FastSetString(tmp, ProcName^, StrLen(ProcName^));
+    if not Resolve('', tmp, Entry) then
+    begin
+      FreeLib;
+      result := false;
+      exit;
+    end;
+    inc(ProcName);
+    inc(Entry);
+  until false;
+  result := true;
+end;
+
+destructor TSynLibrary.Destroy;
+begin
+  FreeLib;
+  inherited Destroy;
+end;
+
+procedure TSynLibrary.FreeLib;
+begin
+  if fHandle = 0 then
+    exit; // nothing to free
+  LibraryClose(fHandle);
+  fHandle := 0;
+end;
+
+function TSynLibrary.TryLoadLibrary(const aLibrary: array of TFileName;
+  aRaiseExceptionOnFailure: ExceptionClass): boolean;
+var
+  i, j: PtrInt;
+  {$ifdef OSWINDOWS}
+  cwd,
+  {$endif OSWINDOWS}
+  lib, libs, nwd: TFileName;
+  err: string;
+begin
+  for i := 0 to high(aLibrary) do
+  begin
+    // check library name
+    lib := aLibrary[i];
+    if lib = '' then
+      continue;
+    result := true;
+    for j := 0 to i - 1 do
+      if aLibrary[j] = lib then
+      begin
+        result := false;
+        break;
+      end;
+    if not result then
+      continue; // don't try twice the same library name
+    // open the library
+    nwd := ExtractFilePath(lib);
+    if fTryFromExecutableFolder  and
+       (nwd = '') and
+       FileExists(Executable.ProgramFilePath + lib) then
+    begin
+      lib := Executable.ProgramFilePath + lib;
+      nwd := Executable.ProgramFilePath;
+    end;
+    {$ifdef OSWINDOWS}
+    if nwd <> '' then
+    begin
+      cwd := GetCurrentDir;
+      SetCurrentDir(nwd); // change the current folder at loading on Windows
+    end;
+    fHandle := LibraryOpen(lib); // preserve x87 flags and prevent msg box 
+    if nwd <> '' then
+      SetCurrentDir(cwd{%H-});
+    {$else}
+    fHandle := LibraryOpen(lib); // use regular .so loading behavior
+    {$endif OSWINDOWS}
+    if fHandle <> 0 then
+    begin
+      {$ifdef OSWINDOWS} // on POSIX, will call dladdr() in Resolve()
+      fLibraryPath := GetModuleName(fHandle);
+      if length(fLibraryPath) < length(lib) then
+      {$endif OSWINDOWS}
+        fLibraryPath := lib;
+      exit;
+    end;
+    // handle any error
+    if {%H-}libs = '' then
+      libs := lib
+    else
+      libs := libs + ', ' + lib;
+    err := LibraryError;
+    if err <> '' then
+      libs := libs + ' [' + err + ']';
+  end;
+  result := false;
+  if aRaiseExceptionOnFailure <> nil then
+    raise aRaiseExceptionOnFailure.CreateFmt('%s.TryLoadLibray failed' +
+      ' - searched in %s', [ClassNameShort(self)^, libs]);
+end;
+
+function TSynLibrary.Exists: boolean;
+begin
+  result := (self <> nil) and
+            (fHandle <> 0);
+end;
+
+
+{ TFileVersion }
+
+constructor TFileVersion.Create(const aFileName: TFileName;
+  aMajor, aMinor, aRelease, aBuild: integer);
+var
+  M, D: word;
+begin
+  fFileName := aFileName;
+  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
+  if self = nil then
+    result := 0
+  else
+    result := Major shl 16 + Minor shl 8 + Release;
+end;
+
+function TFileVersion.SetVersion(aMajor, aMinor, aRelease, aBuild: integer): boolean;
+begin
+  result := (Major <> aMajor) or
+            (Minor <> aMinor) or
+            (Release <> aRelease) or
+            (Build <> aBuild);
+  if not result then
+    exit;
+  Major := aMajor;
+  Minor := aMinor;
+  Release := aRelease;
+  Build := aBuild;
+  Main := Format('%d.%d', [Major, Minor]);
+  if Build <> 0 then
+    fDetailed := Format('%s.%d.%d', [Main, Release, Build])
+  else if Release <> 0 then
+    fDetailed := Format('%s.%d', [Main, Release])
+  else
+    fDetailed := Main;
+  fVersionInfo :=  '';
+  fUserAgent := '';
+end;
+
+function TFileVersion.BuildDateTimeString: string;
+begin
+  result := DateTimeToIsoString(fBuildDateTime);
+end;
+
+function TFileVersion.DetailedOrVoid: string;
+begin
+  if (self = nil) or
+     (Major or Minor or Release or Build = 0) then
+    result := ''
+  else
+    result := fDetailed;
+end;
+
+function TFileVersion.VersionInfo: RawUtf8;
+begin
+  if self = nil then
+    result := ''
+  else
+  begin
+    if fVersionInfo = '' then
+      _fmt('%s %s (%s)', [ExtractFileName(fFileName),
+        DetailedOrVoid, BuildDateTimeString], fVersionInfo);
+    result := fVersionInfo;
+  end;
+end;
+
+function TFileVersion.UserAgent: RawUtf8;
+begin
+  if self = nil then
+    result := ''
+  else
+  begin
+    if fUserAgent = '' then
+    begin
+      _fmt('%s/%s%s', [GetFileNameWithoutExtOrPath(fFileName), DetailedOrVoid,
+        OS_INITIAL[OS_KIND]], fUserAgent);
+      {$ifdef OSWINDOWS}
+      if OSVersion in WINDOWS_32 then
+        fUserAgent := fUserAgent + '32';
+      {$endif OSWINDOWS}
+    end;
+    result := fUserAgent;
+  end;
+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;
+
+function UserAgentParse(const UserAgent: RawUtf8;
+  out ProgramName, ProgramVersion: RawUtf8;
+  out OS: TOperatingSystem): boolean;
+var
+  i, v, vlen, o: PtrInt;
+begin
+  result := false;
+  ProgramName := Split(UserAgent, '/');
+  v := length(ProgramName);
+  if (v = 0) or
+     (UserAgent[v + 1] <> '/') then
+    exit;
+  inc(v, 2);
+  vlen := 0;
+  o := -1;
+  for i := v to length(UserAgent) do
+    if not (UserAgent[i] in ['0' .. '9', '.']) then
+    begin
+      vlen := i - v; // vlen may be 0 if DetailedOrVoid was ''
+      if UserAgent[i + 1] in [#0, '3'] then // end with OS_INITIAL or '32' suffix
+        o := ByteScanIndex(pointer(@OS_INITIAL),
+          ord(high(TOperatingSystem)) + 1, ord(UserAgent[i]));
+      break;
+    end;
+  if o < 0 then
+    exit; // should end with OS_INITIAL[OS_KIND]]
+  os := TOperatingSystem(o);
+  ProgramVersion := copy(UserAgent, v, vlen);
+  result := true;
+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] := GetNextUInt32(P);
+  SetExecutableVersion(ver[0], ver[1], ver[2], ver[3]);
+end;
+
+procedure ComputeExecutableHash;
+begin
+  with Executable do
+  begin
+    _fmt('%s %s (%s)', [ProgramFileName,
+      Version.DetailedOrVoid, Version.BuildDateTimeString], ProgramFullSpec);
+    Hash.c0 := Version.Version32;
+    {$ifdef OSLINUXANDROID}
+    Hash.c0 := crc32c(Hash.c0, pointer(CpuInfoFeatures), length(CpuInfoFeatures));
+    {$else}
+    {$ifdef CPUINTELARM}
+    Hash.c0 := crc32c(Hash.c0, @CpuFeatures, SizeOf(CpuFeatures));
+    {$else}
+    Hash.c0 := crc32c(Hash.c0, pointer(CpuInfoText), length(CpuInfoText));
+    {$endif OSLINUXANDROID}
+    {$endif CPUINTELARM}
+    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;
+
+procedure GetExecutableVersion;
+begin
+  if Executable.Version.RetrieveInformationFromFileName then
+    ComputeExecutableHash;
+end;
+
+procedure InitializeExecutableInformation; // called once at startup
+begin
+  with Executable do
+  begin
+    {$ifdef OSWINDOWS}
+    ProgramFileName := ParamStr(0); // RTL seems just fine here
+    {$else}
+    ProgramFileName := GetExecutableName(@InitializeExecutableInformation);
+    if (ProgramFileName = '') or
+       not FileExists(ProgramFileName) then
+      ProgramFileName := ExpandFileName(ParamStr(0));
+    {$endif OSWINDOWS}
+    ProgramFilePath := ExtractFilePath(ProgramFileName);
+    if IsLibrary then
+      InstanceFileName := GetModuleName(HInstance)
+    else
+      InstanceFileName := ProgramFileName;
+    ProgramName := GetFileNameWithoutExtOrPath(ProgramFileName);
+    GetUserHost(User, Host);
+    if Host = '' then
+      Host := 'unknown';
+    if User = '' then
+      User := 'unknown';
+    Version := TFileVersion.Create(ProgramFileName); // with versions=0
+    Command := TExecutableCommandLine.Create;
+    Command.ExeDescription := ProgramName;
+    Command.Parse;
+  end;
+  ComputeExecutableHash;
+end;
+
+procedure SetExecutableVersion(aMajor, aMinor, aRelease, aBuild: integer);
+begin
+  if Executable.Version.SetVersion(aMajor, aMinor, aRelease, aBuild) then
+    ComputeExecutableHash; // re-compute if changed
+end;
+
+
+{ TExecutableCommandLine }
+
+function TExecutableCommandLine.SwitchAsText(const v: RawUtf8): RawUtf8;
+begin
+  result := fSwitch[length(v) > 1] + v;
+end;
+
+procedure TExecutableCommandLine.Describe(const v: array of RawUtf8;
+  k: TExecutableCommandLineKind; d, def: RawUtf8; argindex: integer);
+var
+  i, j: PtrInt;
+  desc, param, pnames, sp: RawUtf8;
+begin
+  if (self = nil) or
+     (d = '') then
+    exit;
+  if k <> clkArg then
+  begin
+    if high(v) < 0 then
+      exit;
+    desc := SwitchAsText(v[0]);
+    if length(v[0]) <> 1 then
+      desc := '    ' + desc; // right align --#
+    for i := 1 to high(v) do
+      desc := desc + ', ' + SwitchAsText(v[i]);
+  end;
+  if k <> clkOption then
+  begin
+    i := PosExChar('#', d); // #valuename in description -> 
+    if i > 0 then
+    begin
+      j := 1;
+      while d[i + j] > ' ' do
+        inc(j);
+      delete(d, i, 1); // remove #
+      if d[i] <> '#' then
+        param := copy(d, i, j - 1) // extract ''
+      else
+      begin
+        param := copy(d, i + 1, j - 2); // ##type
+        delete(d, i, j);                // not included in description
+      end;
+    end
+    else if k = clkArg then
+      if high(v) = 0 then
+        param := v[0]
+      else if argindex > 0 then
+        param := _fmt('arg%d', [argindex])
+      else
+        param := 'arg'
+    else
+    begin
+      i := PosEx(' - values: ', d); // see SetObjectFromExecutableCommandLine()
+      if i > 0 then
+      begin
+        inc(i, 11);
+        j := 1;
+        if copy(d, i, 7) = 'set of ' then
+          inc(j, 7);
+        while d[i + j] > ' ' do
+          inc(j);
+        param := copy(d, i, j);
+        dec(i, 11);
+        delete(d, i, j + 11);
+        if j > 50 then
+        begin
+          j := 50;
+          for i := 50 downto 1 do
+            if param[i] = '|' then
+            begin
+              j := i;
+              break;
+            end;
+          insert(fLineFeed + '         ', param, j + 1);
+        end;
+      end
+      else
+        param := 'value';
+    end;
+    desc := desc + ' <' + param + '>';
+    if (k = clkArg) and
+       (argindex > 0) then
+    begin
+      if argindex > length(fDescArg) then
+        SetLength(fDescArg, argindex);
+      fDescArg[argindex - 1] := param;
+    end;
+  end;
+  fDesc[k] := fDesc[k] + ' ' + desc;
+  j := 1;
+  if fSwitch[true] <> '--' then
+    repeat
+      i := PosEx('--', d, j); // e.g. '--switch' -> '/switch' on Windows
+      if i = 0 then
+        break;
+      delete(d, i, 2);
+      insert(fSwitch[true], d, i);
+      j := i;
+    until false;
+  if def <> '' then
+    def := ' (default ' + def + ')';
+  pnames := _fmt('  %0:-20s', [desc + def]);
+  if (length(pnames) > 22) or
+     (length(d) > 80) then
+  begin
+    // write description on next line(s)
+    sp := fLineFeed + '                      ';
+    while length(d) > 57 do
+    begin
+      j := 57;
+      for i := 57 downto 1 do
+        if d[i] = ' ' then
+        begin
+          j := i;
+          break;
+        end;
+      if j = 57 then
+        for i := 57 downto 1 do
+          if d[i] in [',', ';', '|'] then
+          begin
+            j := i;
+            break;
+          end;
+      pnames := pnames + sp + copy(d, 1, j);
+      delete(d, 1, j);
+    end;
+    pnames := pnames + sp + d;
+  end
+  else
+    pnames := pnames + d; // we can put everything on the same line
+  fDescDetail[k] := fDescDetail[k] + pnames + fLineFeed;
+end;
+
+function TExecutableCommandLine.Find(const v: array of RawUtf8;
+  k: TExecutableCommandLineKind; const d, def: RawUtf8; f: PtrInt): PtrInt;
+var
+  i: PtrInt;
+begin
+  if self <> nil then
+  begin
+    if k <> clkUndefined then
+      Describe(v, k, d, def, -1);
+    if (high(v) >= 0) and
+       (fNames[k] <> nil) then
+      for i := 0 to high(v) do
+      begin
+        result := FindNonVoid[fCaseSensitiveNames](
+          @fNames[k][f], pointer(v[i]), length(v[i]), length(fNames[k]) - f);
+        if result >= 0 then
+        begin
+          inc(result, f);
+          fRetrieved[k][result] := true;
+          exit;
+        end;
+      end;
+  end;
+  result := -1
+end;
+
+function TExecutableCommandLine.Arg(index: integer; const description: RawUtf8;
+  optional: boolean): boolean;
+var
+  n: PtrUInt;
+begin
+  result := self <> nil;
+  if not result then
+    exit;
+  n := length(fNames[clkArg]);
+  result := PtrUInt(index) < n;
+  if result then
+    fRetrieved[clkArg][index] := true
+  else
+  begin
+    SetLength(fRetrieved[clkArg], n + 1); // to notify missing 
+    if optional then
+      fRetrieved[clkArg][index] := true;
+  end;
+  Describe([], clkArg, description, '', index + 1);
+end;
+
+function TExecutableCommandLine.ArgString(index: integer;
+  const description: RawUtf8; optional: boolean): string;
+begin
+  result := '';
+  if Arg(index, description, optional) then
+    result := string(Args[0]);
+end;
+
+function TExecutableCommandLine.Arg(const name, description: RawUtf8): boolean;
+begin
+  result := Arg([name], description);
+end;
+
+function TExecutableCommandLine.Arg(const name: array of RawUtf8;
+  const description: RawUtf8): boolean;
+begin
+  result := Find(name, clkArg, description) >= 0;
+end;
+
+function TExecutableCommandLine.Option(const name, description: RawUtf8): boolean;
+begin
+  result := Find([name], clkOption, description) >= 0;
+end;
+
+function TExecutableCommandLine.Option(const name: array of RawUtf8;
+  const description: RawUtf8): boolean;
+begin
+  result := Find(name, clkOption, description) >= 0;
+end;
+
+function TExecutableCommandLine.Get(const name: RawUtf8; out value: RawUtf8;
+  const description, default: RawUtf8): boolean;
+begin
+  result := Get([name], value, description, default);
+end;
+
+procedure AddRawUtf8(var Values: TRawUtf8DynArray; const Value: RawUtf8);
+var
+  n: PtrInt;
+begin
+  n := length(Values);
+  SetLength(Values, n + 1);
+  Values[n] := Value;
+end;
+
+function TExecutableCommandLine.Get(const name: array of RawUtf8;
+  out value: TRawUtf8DynArray; const description: RawUtf8): boolean;
+var
+  first, i: PtrInt;
+begin
+  result := false;
+  if self = nil then
+    exit;
+  Describe(name, clkParam, description, '', -1);
+  first := 0;
+  repeat
+    i := Find(name, clkParam, '', '', first);
+    if i < 0 then
+      break;
+    AddRawUtf8(value, fValues[i]);
+    result := true;
+    first := i + 1;
+  until first >= length(fValues);
+end;
+
+function TExecutableCommandLine.Get(const name: array of RawUtf8;
+  out value: RawUtf8; const description, default: RawUtf8): boolean;
+var
+  i: PtrInt;
+begin
+  if self = nil then
+    i := -1
+  else
+    i := Find(name, clkParam, description, default);
+  if i >= 0 then
+  begin
+    value := Values[i];
+    result := true;
+  end
+  else
+  begin
+    value := default;
+    result := false;
+  end;
+end;
+
+function TExecutableCommandLine.Get(const name: RawUtf8; out value: string;
+  const description: RawUtf8; const default: string): boolean;
+begin
+  result := Get([name], value, description, default);
+end;
+
+function TExecutableCommandLine.Get(const name: array of RawUtf8;
+  out value: string; const description: RawUtf8; const default: string): boolean;
+var
+  tmp: RawUtf8;
+begin
+  result := Get(name, tmp, description);
+  if result then
+    value := string(tmp)
+  else
+    value := default; // no conversion needed
+end;
+
+function TExecutableCommandLine.Get(const name: RawUtf8;
+  out value: TStringDynarray; const description: RawUtf8): boolean;
+begin
+  result := Get([name], value, description);
+end;
+
+function TExecutableCommandLine.Get(const name: array of RawUtf8;
+  out value: TStringDynarray; const description: RawUtf8): boolean;
+var
+  tmp: TRawUtf8DynArray;
+  i: PtrInt;
+begin
+  result := Get(name, tmp, description);
+  SetLength(value, length(tmp));
+  for i := 0 to length(tmp) - 1 do
+    value[i] := string(tmp[i]);
+end;
+
+function TExecutableCommandLine.Get(const name: RawUtf8;
+  out value: integer; const description: RawUtf8; default: integer): boolean;
+begin
+  result := Get([name], value, description, default);
+end;
+
+function defI(default: integer): RawUtf8;
+begin
+  if default = maxInt then
+    result := ''
+  else
+    result := RawUtf8(IntToStr(default));
+end;
+
+function TExecutableCommandLine.Get(const name: array of RawUtf8;
+  out value: integer; const description: RawUtf8; default: integer): boolean;
+var
+  i: PtrInt;
+begin
+  if self = nil then
+    i := -1
+  else
+    i := Find(name, clkParam, description, defI(default));
+  result := (i >= 0) and
+            ToInteger(Values[i], value);
+  if not result and
+     (default <> maxInt) then
+    value := default;
+end;
+
+function TExecutableCommandLine.Get(const name: RawUtf8; min, max: integer;
+  out value: integer; const description: RawUtf8; default: integer): boolean;
+begin
+  result := Get([name], min, max, value, description, default);
+end;
+
+function TExecutableCommandLine.Get(const name: array of RawUtf8;
+  min, max: integer; out value: integer; const description: RawUtf8;
+  default: integer): boolean;
+begin
+  result := Get(name, value, description, default) and
+            (value >= min) and
+            (value <= max);
+end;
+
+function TExecutableCommandLine.Has(const name: RawUtf8): boolean;
+begin
+  result := Find([name], clkParam) >= 0;
+end;
+
+function TExecutableCommandLine.Has(const name: array of RawUtf8): boolean;
+begin
+  result := Find(name, clkParam) >= 0;
+end;
+
+function TExecutableCommandLine.Param(
+  const name, description, default: RawUtf8): RawUtf8;
+begin
+  Get([name], result, description, default);
+end;
+
+function TExecutableCommandLine.Param(const name: array of RawUtf8;
+  const description, default: RawUtf8): RawUtf8;
+begin
+  Get(name, result, description, default);
+end;
+
+function TExecutableCommandLine.ParamS(const name: array of RawUtf8;
+  const description: RawUtf8; const default: string): string;
+begin
+  Get(name, result, description, default);
+end;
+
+function TExecutableCommandLine.Param(const name: RawUtf8;
+  default: integer; const description: RawUtf8): integer;
+begin
+  Get([name], result, description, default);
+end;
+
+function TExecutableCommandLine.Param(const name: array of RawUtf8;
+  default: integer;const description: RawUtf8): integer;
+begin
+  Get(name, result, description, default);
+end;
+
+const
+  CLK_TXT: array[clkOption .. clkParam] of RawUtf8 = (
+    ' [options]', ' [params]');
+  CLK_DESCR: array[clkOption .. clkParam] of RawUtf8 = (
+    'Options', 'Params');
+  CASE_DESCR: array[boolean] of RawUtf8 = (
+    ':', ' (case-sensitive):');
+
+function TExecutableCommandLine.FullDescription(
+  const customexedescription, exename, onlyusage: RawUtf8): RawUtf8;
+var
+  clk: TExecutableCommandLineKind;
+begin
+  if customexedescription <> '' then
+    fExeDescription := customexedescription;
+  result := fExeDescription + fLineFeed + fLineFeed + 'Usage: ';
+  if exename = '' then
+    result := result + Executable.ProgramName
+  else
+    result := result + exename;
+  result := result + fDesc[clkArg];
+  for clk := low(CLK_TXT) to high(CLK_TXT) do
+    if fDesc[clk] <> '' then
+      result := result + CLK_TXT[clk];
+  result := result + fLineFeed;
+  if onlyusage <> '' then
+    result := result + onlyusage
+  else
+    for clk := low(fDescDetail) to high(fDescDetail) do
+      if fDescDetail[clk] <> '' then
+      begin
+        if clk in [low(CLK_TXT) .. high(CLK_TXT)] then
+          result := result + fLineFeed +
+                    CLK_DESCR[clk] + CASE_DESCR[CaseSensitiveNames];
+        result := result + fLineFeed + fDescDetail[clk];
+      end;
+end;
+
+function TExecutableCommandLine.DetectUnknown: RawUtf8;
+var
+  clk: TExecutableCommandLineKind;
+  i: PtrInt;
+begin
+  result := '';
+  for clk := low(fRetrieved) to high(fRetrieved) do
+    for i := 0 to length(fRetrieved[clk]) - 1 do
+      if not fRetrieved[clk][i] then
+        if clk = clkArg then
+          result := result + 'Missing <' + fDescArg[i] + '> argument' + fLineFeed
+        else
+        begin
+          result := result + 'Unexpected ' + SwitchAsText(fNames[clk][i]) + ' ';
+          case clk of
+            clkOption:
+              result := result + 'option';
+            clkParam:
+              result := result + fValues[i] + ' parameter';
+          end;
+          result := result + fLineFeed;
+        end;
+end;
+
+function TExecutableCommandLine.ConsoleWriteUnknown(
+  const exedescription: RawUtf8): boolean;
+var
+  err: RawUtf8;
+begin
+  err := DetectUnknown;
+  result := err <> '';
+  if not result then
+    exit;
+  ConsoleWrite(FullDescription(exedescription));
+  ConsoleWrite(err, ccLightRed);
+  TextColor(ccLightGray);
+end;
+
+function TExecutableCommandLine.ConsoleHelpFailed(
+  const exedescription: RawUtf8): boolean;
+begin
+  if exedescription <> '' then
+    fExeDescription := exedescription;
+  result := Option(['h', 'help'], 'display this help');
+  if result then
+    ConsoleWrite(FullDescription)
+  else
+    result := ConsoleWriteUnknown(exedescription);
+end;
+
+procedure TExecutableCommandLine.Clear;
+begin
+  CleanupInstance; // finalize all TRawUtf8DynArray fields
+end;
+
+function TExecutableCommandLine.Parse(
+  const DescriptionLineFeed, ShortSwitch, LongSwitch: RawUtf8): boolean;
+var
+  i, j, n: PtrInt;
+  swlen: TByteDynArray;
+  s: RawUtf8;
+begin
+  result := false;
+  fLineFeed := DescriptionLineFeed;
+  if (ShortSwitch = '') or
+     (LongSwitch  = '') then
+    exit;
+  fSwitch[false] := ShortSwitch;
+  fSwitch[true]  := LongSwitch;
+  if fRawParams = nil then
+  begin
+    n := ParamCount;
+    if n <= 0 then
+      exit; // may equal -1 e.g. from a .so on MacOS
+    SetLength(fRawParams, n);
+    for i := 0 to n - 1 do
+      fRawParams[i] := RawUtf8(ParamStr(i + 1));
+  end;
+  n := length(fRawParams);
+  if n = 0 then
+  begin
+    result := true;
+    exit;
+  end;
+  SetLength(swlen, n);
+  for i := 0 to n - 1 do
+  begin
+    s := fRawParams[i];
+    if s <> '' then
+      if CompareMemSmall(pointer(s), pointer(LongSwitch), length(LongSwitch)) then
+        swlen[i] := length(LongSwitch)
+      else if CompareMemSmall(pointer(s), pointer(ShortSwitch), length(ShortSwitch)) then
+        swlen[i] := length(ShortSwitch)
+      {$ifdef OSWINDOWS}
+      else while s[swlen[i] + 1] = '-' do
+        inc(swlen[i]); // allow -v --verbose on Windows for cross-platform run
+      {$endif OSWINDOWS}
+  end;
+  i := 0;
+  repeat
+    s := fRawParams[i];
+    if s <> '' then
+      if swlen[i] <> 0 then
+      begin
+        delete(s, 1, swlen[i]);
+        if s <> '' then
+        begin
+          j := PosExChar('=', s);
+          if j <> 1 then
+            if j <> 0 then
+            begin
+              AddRawUtf8(fNames[clkParam], copy(s, 1, j - 1));
+              AddRawUtf8(fValues, copy(s, j + 1, MaxInt));
+            end
+            else if (i + 1 = n) or
+                    (swlen[i + 1] <> 0) then
+              AddRawUtf8(fNames[clkOption], s)
+            else
+            begin
+              AddRawUtf8(fNames[clkParam], s);
+              inc(i);
+              AddRawUtf8(fValues, fRawParams[i]);
+            end;
+          end;
+      end
+      else
+        AddRawUtf8(fNames[clkArg], s);
+    inc(i);
+  until i = n;
+  SetLength(fRetrieved[clkArg],    length(fNames[clkArg]));
+  SetLength(fRetrieved[clkOption], length(fNames[clkOption]));
+  SetLength(fRetrieved[clkParam],  length(fNames[clkParam]));
+  result := true;
+end;
+
+var
+  _SystemPath: array[TSystemPath] of TFileName; // GetSystemPath() cache
+
+function GetSystemPath(kind: TSystemPath): TFileName;
+begin
+  result := _SystemPath[kind];
+  if result <> '' then
+    exit;
+  _ComputeSystemPath(kind, result); // in os.posix.inc or os.windows.inc
+  _SystemPath[kind] := result;
+end;
+
+function SetSystemPath(kind: TSystemPath; const path: TFileName): boolean;
+var
+  full: TFileName;
+begin
+  full := ExpandFileName(ExcludeTrailingPathDelimiter(path));
+  result := DirectoryExists(full);
+  if result then
+    _SystemPath[kind] := IncludeTrailingPathDelimiter(full);
+end;
+
+function _GetExecutableLocation(aAddress: pointer): ShortString;
+var
+  i: PtrInt;
+begin // return the address as hexadecimal - hexstr() is not available on Delphi
+  result[0] := #0;
+  for i := SizeOf(aAddress) - 1 downto 0 do
+    AppendShortByteHex(PByteArray(aAddress)[i], result);
+end; // mormot.core.log.pas will properly decode debug info - and handle .mab
+
+var
+  _SystemStoreAsPemSafe: TLightLock;
+  _OneSystemStoreAsPem: array[TSystemCertificateStore] of record
+    Tix: cardinal;
+    Pem: RawUtf8;
+  end;
+  _SystemStoreAsPem: record
+    Tix: cardinal;
+    Scope: TSystemCertificateStores;
+    Pem: RawUtf8;
+  end;
+
+function GetOneSystemStoreAsPem(CertStore: TSystemCertificateStore;
+  FlushCache: boolean; now: cardinal): RawUtf8;
+begin
+  if now = 0 then
+    now := GetTickCount64 shr 18 + 1; // div 262.144 seconds = every 4.4 min
+  _SystemStoreAsPemSafe.Lock;
+  try
+    // first search if not already in cache
+    with _OneSystemStoreAsPem[CertStore] do
+    begin
+      if not FlushCache then
+        if Tix = now then
+        begin
+          result := Pem; // quick retrieved from cache
+          exit;
+        end;
+      // fallback search depending on the POSIX / Windows specific OS
+      result := _GetSystemStoreAsPem(CertStore); // implemented in each .inc
+      Tix := now;
+      Pem := result;
+    end;
+  finally
+    _SystemStoreAsPemSafe.UnLock;
+  end;
+end;
+
+function GetSystemStoreAsPem(CertStores: TSystemCertificateStores;
+  FlushCache, OnlySystemStore: boolean): RawUtf8;
+var
+  now: cardinal;
+  s: TSystemCertificateStore;
+  v: RawUtf8;
+begin
+  result := '';
+  now := GetTickCount64 shr 18 + 1;
+  _SystemStoreAsPemSafe.Lock;
+  try
+    // first search if not already in cache
+    if not FlushCache then
+      with _SystemStoreAsPem do
+        if (Tix = now) and
+           (Scope = CertStores) and
+           (Pem <> '') then
+        begin
+          result := Pem; // quick retrieved from cache
+          exit;
+        end;
+    // load from a file, bounded within the application or from env variable
+    if not OnlySystemStore then
+    begin
+      if GetSystemStoreAsPemLocalFile <> '' then
+        {$ifdef OSPOSIX}
+        if GetSystemStoreAsPemLocalFile[1] = '/' then // full /posix/path
+        {$else}
+        if GetSystemStoreAsPemLocalFile[2] = ':' then // 'C:\path\to\file.pem'
+        {$endif OSPOSIX}
+          result := StringFromFile(GetSystemStoreAsPemLocalFile)
+        else
+          result := StringFromFile(
+            Executable.ProgramFilePath + GetSystemStoreAsPemLocalFile);
+      if result = '' then
+        result := StringFromFile(GetEnvironmentVariable('SSL_CA_CERT_FILE'));
+    end;
+  finally
+    _SystemStoreAsPemSafe.UnLock; // GetOneSystemStoreAsPem() blocks
+  end;
+  // fallback to search depending on the POSIX / Windows specific OS stores
+  if result = '' then
+    for s := low(s) to high(s) do
+      if s in CertStores then
+      begin
+        v := GetOneSystemStoreAsPem(s, FlushCache, now);
+        if v <> '' then
+          result := result + v + #13#10;
+      end;
+  if result <> '' then
+  begin
+    _SystemStoreAsPemSafe.Lock;
+    try
+      with _SystemStoreAsPem do
+      begin
+        Tix := now;
+        Scope := CertStores;
+        Pem := result;
+      end;
+    finally
+      _SystemStoreAsPemSafe.UnLock;
+    end;
+  end;
+end;
+
+{$ifdef CPUINTEL} // don't mess with raw SMBIOS encoding outside of Intel/AMD
+
+// from DSP0134 3.6.0 System Management BIOS (SMBIOS) Reference Specification
+const
+  SMB_ANCHOR  = $5f4d535f;  // _SM_
+  SMB_INT4    = $494d445f;  // _DMI
+  SMB_INT5    = $5f;        // _
+  SMB_ANCHOR4 = $334d535f;  // _SM3
+  SMB_ANCHOR5 = $5f;        // _
+
+type
+  TSmbEntryPoint32 = packed record
+    Anchor: cardinal;  // = SMB_ANCHOR
+    Checksum: byte;
+    Length: byte;
+    MajVers: byte;
+    MinVers: byte;
+    MaxSize: word;
+    Revision: byte;
+    PadTo16: array[1 .. 5] of byte;
+    IntAnch4: cardinal; // = SMB_INT4
+    IntAnch5: byte;     // = SMB_INT5
+    IntChecksum: byte;
+    StructLength: word;
+    StructAddr: cardinal;
+    NumStruct: word;
+    BcdRevision: byte;
+  end;
+  PSmbEntryPoint32 = ^TSmbEntryPoint32;
+
+  TSmbEntryPoint64 = packed record
+    Anch4: cardinal; // = SMB_ANCHOR4
+    Anch5: byte;     // = SMB_ANCHOR5
+    Checksum: byte;
+    Length: byte;
+    MajVers: byte;
+    MinVers: byte;
+    DocRev: byte;
+    Revision: byte;
+    Reserved: byte;
+    StructMaxLength: cardinal;
+    StructAddr: QWord;
+  end;
+  PSmbEntryPoint64 = ^TSmbEntryPoint64;
+
+function GetRawSmbios32(p: PSmbEntryPoint32; var info: TRawSmbiosInfo): PtrUInt;
+var
+  cs: byte;
+  i: PtrInt;
+begin
+  cs := 0;
+  for i := 0 to p^.Length - 1 do
+    inc(cs, PByteArray(p)[i]);
+  if cs <> 0 then
+  begin
+    result := 0; // invalid checksum
+    exit;
+  end;
+  result := p^.StructAddr;
+  info.SmbMajorVersion := p^.MajVers;
+  info.SmbMinorVersion := p^.MinVers;
+  info.DmiRevision := p^.Revision; // 0 = SMBIOS 2.1
+  info.Length := p^.StructLength;
+end;
+
+function GetRawSmbios64(p: PSmbEntryPoint64; var info: TRawSmbiosInfo): PtrUInt;
+var
+  cs: byte;
+  i: PtrInt;
+begin
+  cs := 0;
+  for i := 0 to p^.Length - 1 do
+    inc(cs, PByteArray(p)[i]);
+  if cs <> 0 then
+  begin
+    result := 0;
+    exit;
+  end;
+  result := p^.StructAddr;
+  info.SmbMajorVersion := p^.MajVers;
+  info.SmbMinorVersion := p^.MinVers;
+  info.DmiRevision := p^.Revision; // 1 = SMBIOS 3.0
+  info.Length := p^.StructMaxLength;
+end;
+
+// caller should then try to decode SMB from pointer(result) + info.Len
+function SearchSmbios(const mem: RawByteString; var info: TRawSmbiosInfo): PtrUInt;
+var
+  p, pend: PSmbEntryPoint32;
+begin
+  result := 0;
+  if mem = '' then
+    exit;
+  p := pointer(mem);
+  pend := @PByteArray(mem)[length(mem) - SizeOf(p^)];
+  repeat
+    if (p^.Anchor = SMB_ANCHOR) and
+       (p^.IntAnch4 = SMB_INT4) and
+       (p^.IntAnch5 = SMB_INT5) then
+    begin
+      result := GetRawSmbios32(p, info);
+      if result <> 0 then
+        exit;
+    end
+    else if (p^.Anchor = SMB_ANCHOR4) and
+            (p^.Checksum = SMB_ANCHOR5) then
+    begin
+      result := GetRawSmbios64(pointer(p), info);
+      if result <> 0 then
+        exit; // here info.Length = max length
+    end;
+    inc(PHash128(p)); // search on 16-byte (paragraph) boundaries
+  until PtrUInt(p) >= PtrUInt(pend);
+end;
+
+{$endif CPUINTEL}
+
+procedure ComputeGetSmbios;
+begin
+  GlobalLock; // thread-safe retrieval
+  try
+    if not _SmbiosRetrieved then
+    begin
+      _SmbiosRetrieved := true;
+      Finalize(RawSmbios.Data);
+      FillCharFast(RawSmbios, SizeOf(RawSmbios), 0);
+      if _GetRawSmbios(RawSmbios) then // OS specific call
+         if DecodeSmbios(RawSmbios, _Smbios) <> 0 then
+         begin
+           // we were able to retrieve and decode SMBIOS information
+           {$ifdef OSPOSIX}
+           _AfterDecodeSmbios(RawSmbios); // persist in SMB_CACHE for non-root
+           {$endif OSPOSIX}
+           exit;
+         end;
+      // if not root on POSIX, SMBIOS is not available
+      // -> try to get what the OS exposes (Linux, MacOS or FreeBSD)
+      DirectSmbiosInfo(_Smbios);
+    end;
+  finally
+    GlobalUnLock;
+  end;
+end;
+
+function GetRawSmbios: boolean;
+begin
+  if not _SmbiosRetrieved then
+    ComputeGetSmbios; // fill both RawSmbios and _Smbios[]
+  result := RawSmbios.Data <> '';
+end;
+
+function GetSmbios(info: TSmbiosBasicInfo): RawUtf8;
+begin
+  if not _SmbiosRetrieved then
+    ComputeGetSmbios; // fill both RawSmbios and _Smbios[]
+  result := _Smbios[info];
+end;
+
+{$ifdef ISDELPHI} // missing convenient RTL function in Delphi
+function TryStringToGUID(const s: string; var uuid: TGuid): boolean;
+begin
+  try
+    uuid := StringToGUID(s);
+    result := true;
+  except
+    result := false;
+  end;
+end;
+{$endif ISDELPHI}
+
+procedure GetComputerUuid(out uuid: TGuid);
+var
+  n, i: PtrInt;
+  u: THash128Rec absolute uuid;
+  s: RawByteString;
+  fn: TFileName;
+  mac: TRawUtf8DynArray;
+
+  procedure crctext(const s: RawUtf8);
+  begin
+    if s = '' then
+      exit;
+    u.c[n] := crc32c(u.c[n], pointer(s), length(s));
+    n := (n + 1) and 3; // update only 32-bit of UUID per crctext() call
+  end;
+
+begin
+  // first try to retrieve the Machine BIOS UUID
+  if not _SmbiosRetrieved then
+    ComputeGetSmbios; // maybe from local SMB_CACHE file for non-root
+  if (_Smbios[sbiUuid] <> '') and
+     TryStringToGUID('{' + string(_Smbios[sbiUuid]) + '}', uuid) then
+    exit;
+  // did we already compute this UUID?
+  fn := UUID_CACHE;
+  s := StringFromFile(fn);
+  if length(s) = SizeOf(uuid) then
+  begin
+    uuid := PGuid(s)^; // seems to be a valid UUID binary blob
+    exit;
+  end;
+  // no known UUID: compute and store a 128-bit hash from HW specs
+  // which should remain identical even between full OS reinstalls
+  // note: /etc/machine-id is no viable alternative since it is from SW random
+  {$ifdef CPUINTELARM}
+  crc128c(@CpuFeatures, SizeOf(CpuFeatures), u.b);
+  {$else}
+  s := CPU_ARCH_TEXT;
+  crc128c(pointer(s), length(s), u.b); // rough starting point
+  {$endif CPUINTELARM}
+  if RawSmbios.Data <> '' then // some bios have no uuid but some HW info
+    crc32c128(@u.b, pointer(RawSmbios.Data), length(RawSmbios.Data));
+  n := 0;
+  for i := 0 to length(_Smbios) - 1 do // some of _Smbios[] may be set
+    crctext(PRawUtf8Array(@_Smbios)[i]);
+  crctext(CpuCacheText);
+  crctext(BiosInfoText);
+  crctext(CpuInfoText);
+  if Assigned(GetSystemMacAddress) then
+    // from mormot.net.sock or mormot.core.os.posix.inc for Linux only
+    mac := GetSystemMacAddress;
+  if mac <> nil then
+  begin
+    // MAC should make it unique at least over the local network
+    for i := 0 to high(mac) do
+      crctext(mac[i]);
+    // we have enough unique HW information to store it locally for next startup
+    // note: RawSmbios.Data may not be genuine e.g. between VMs
+    if FileFromBuffer(@u, SizeOf(u), fn) then
+      FileSetSticky(fn); // use S_ISVTX so that file is not removed from /var/tmp
+  end
+  else
+    // unpersisted fallback if mormot.net.sock is not included (very unlikely)
+    crctext(Executable.Host);
+end;
+
+procedure DecodeSmbiosUuid(src: PGuid; out dest: RawUtf8; const raw: TRawSmbiosInfo);
+var
+  uid: TGuid;
+begin
+  uid := src^;
+  // reject full $00 = unsupported or full $ff = not set
+  if IsZero(@uid, SizeOf(uid)) or
+     ((PCardinalArray(@uid)[0] = $ffffffff) and
+      (PCardinalArray(@uid)[1] = $ffffffff) and
+      (PCardinalArray(@uid)[2] = $ffffffff) and
+      (PCardinalArray(@uid)[3] = $ffffffff)) then
+    exit;
+  // GUIDToString() already displays the first 4 bytes as little-endian
+  // - we don't need to swap those bytes as dmi_system_uuid() in dmidecode.c
+  // on Windows, to match "wmic csproduct get uuid" official value
+  // - on MacOs, sduInvert is set to match IOPlatformUUID value from ioreg :(
+  if (_SmbiosDecodeUuid = sduInvert) or
+  // - dmi_save_uuid() from the Linux kernel do check for SMBIOS 2.6 version
+  // https://elixir.bootlin.com/linux/latest/source/drivers/firmware/dmi_scan.c
+     ((_SmbiosDecodeUuid = sduVersion) and
+      (raw.SmbMajorVersion shl 8 + raw.SmbMinorVersion < $0206)) then
+  begin
+    uid.D1 := bswap32(uid.D1);
+    uid.D2 := swap(uid.D2);
+    uid.D3 := swap(uid.D3);
+  end;
+  dest := RawUtf8(UpperCase(copy(GUIDToString(uid), 2, 36)));
+end;
+
+function DecodeSmbios(var raw: TRawSmbiosInfo; out info: TSmbiosBasicInfos): PtrInt;
+var
+  lines: array[byte] of TSmbiosBasicInfo; // single pass efficient decoding
+  len, trimright: PtrInt;
+  cur: ^TSmbiosBasicInfo;
+  s, sEnd: PByteArray;
+begin
+  result := 0;
+  Finalize(info);
+  s := pointer(raw.Data);
+  if s = nil then
+    exit;
+  sEnd := @s[length(raw.Data)];
+  FillCharFast(lines, SizeOf(lines), 0);
+  repeat
+    if (s[0] = 127) or // type (127=EOT)
+       (s[1] < 4) or   // length
+       (PtrUInt(@s[s[1]]) > PtrUInt(sEnd)) then
+    begin
+      s := @s[2]; // truncate to the exact end of DMI/SMBIOS input
+      break;
+    end;
+    case s[0] of
+      0: // Bios Information (type 0)
+        begin
+          lines[s[4]] := sbiBiosVendor;
+          lines[s[5]] := sbiBiosVersion;
+          lines[s[8]] := sbiBiosDate;
+          if s[1] >= $17 then // 2.4+
+          begin
+            _fmt('%d.%d', [s[$14], s[$15]], info[sbiBiosRelease]);
+            _fmt('%d.%d', [s[$16], s[$17]], info[sbiBiosFirmware]);
+          end;
+        end;
+      1: // System Information (type 1)
+        begin
+          lines[s[4]] := sbiManufacturer;
+          lines[s[5]] := sbiProductName;
+          lines[s[6]] := sbiVersion;
+          lines[s[7]] := sbiSerial;
+          if s[1] >= $18 then // 2.1+
+          begin
+            DecodeSmbiosUuid(@s[8], info[sbiUuid], raw);
+            if s[1] >= $1a then // 2.4+
+            begin
+              lines[s[$19]] := sbiSku;
+              lines[s[$1a]] := sbiFamily;
+            end;
+          end;
+        end;
+      2: // Baseboard (or Module) Information (type 2) - keep only the first
+        begin
+          lines[s[4]] := sbiBoardManufacturer;
+          lines[s[5]] := sbiBoardProductName;
+          lines[s[6]] := sbiBoardVersion;
+          lines[s[7]] := sbiBoardSerial;
+          lines[s[8]] := sbiBoardAssetTag;
+          lines[s[10]] := sbiBoardLocation;
+        end;
+      4: // Processor Information (type 4) - keep only the first
+        begin
+          lines[s[7]] := sbiCpuManufacturer;
+          lines[s[$10]] := sbiCpuVersion;
+          if s[1] >= $22 then // 2.3+
+          begin
+            lines[s[$20]] := sbiCpuSerial;
+            lines[s[$21]] := sbiCpuAssetTag;
+            lines[s[$22]] := sbiCpuPartNumber;
+          end;
+        end;
+      11: // OEM Strings (Type 11) - keep only the first
+        if s[4] <> 0 then
+          lines[1] := sbiOem; // e.g. 'vboxVer_6.1.36'
+      22: // Portable Battery (type 22) - keep only the first
+        if s[1] >= $0f then // 2.1+
+        begin
+          lines[s[4]] := sbiBatteryLocation;
+          lines[s[5]] := sbiBatteryManufacturer;
+          lines[s[8]] := sbiBatteryName;
+          lines[s[$0e]] := sbiBatteryVersion;
+          if s[1] >= $14 then // 2.2+
+            lines[s[$14]] := sbiBatteryChemistry;
+        end;
+    end;
+    s := @s[s[1]]; // go to string table
+    cur := @lines[1];
+    if s[0] = 0 then
+      inc(PByte(s)) // no string table
+    else
+      repeat
+        len := StrLen(s);
+        if cur^ <> sbiUndefined then
+        begin
+          if info[cur^] = '' then // only set the first occurrence if multiple
+          begin
+            trimright := len;
+            while (trimright <> 0) and
+                  (s[trimright - 1] <= ord(' ')) do
+              dec(trimright);
+            FastSetString(info[cur^], s, trimright);
+          end;
+          cur^ := sbiUndefined; // reset slot in lines[]
+        end;
+        s := @s[len + 1]; // next string
+        inc(cur);
+      until s[0] = 0; // end of string table
+    inc(PByte(s)); // go to next structure
+  until false;
+  // compute the exact DMI/SMBIOS size, and adjust the raw.Data length
+  result := PtrUInt(s) - PtrUInt(raw.Data);
+  raw.Length := result;
+  if length(raw.Data) <> result then
+    FakeSetLength(raw.Data, result);
+end;
+
+
+{ **************** TSynLocker Threading Features }
+
+// as reference, take a look at Linus insight
+// from https://www.realworldtech.com/forum/?threadid=189711&curpostid=189755
+{$ifdef CPUINTEL}
+procedure DoPause; {$ifdef FPC} assembler; nostackframe; {$endif}
+asm
+      pause
+end;
+{$endif CPUINTEL}
+
+const
+  {$ifdef CPUINTEL}
+  SPIN_COUNT = 1000;
+  {$else}
+  SPIN_COUNT = 100; // since DoPause does nothing, switch to thread sooner
+  {$endif CPUINTEL}
+
+function DoSpin(spin: PtrUInt): PtrUInt;
+  {$ifdef CPUINTEL} {$ifdef HASINLINE} inline; {$endif} {$endif}
+  // on Intel, the pause CPU instruction would relax the core
+  // on ARM/AARCH64, the not-inlined function call makes a small delay
+begin
+  {$ifdef CPUINTEL}
+  DoPause;
+  {$endif CPUINTEL}
+  dec(spin);
+  if spin = 0 then
+  begin
+    SwitchToThread; // fpnanosleep on POSIX
+    spin := SPIN_COUNT;
+  end;
+  result := spin;
+end;
+
+
+{ TLightLock }
+
+procedure TLightLock.Init;
+begin
+  Flags := 0;
+end;
+
+procedure TLightLock.Done;
+begin // just for compatibility with TOSLock
+end;
+
+procedure TLightLock.Lock;
+begin
+  // we tried a dedicated asm but it was slower: inlining is preferred
+  if not LockedExc(Flags, 1, 0) then
+    LockSpin;
+end;
+
+procedure TLightLock.UnLock;
+begin
+  {$ifdef CPUINTEL}
+  Flags := 0; // non reentrant locks need no additional thread safety
+  {$else}
+  LockedExc(Flags, 0, 1); // ARM can be weak-ordered
+  // https://preshing.com/20121019/this-is-why-they-call-it-a-weakly-ordered-cpu
+  {$endif CPUINTEL}
+end;
+
+function TLightLock.TryLock: boolean;
+begin
+  result := (Flags = 0) and // first check without any (slow) atomic opcode
+            LockedExc(Flags, 1, 0);
+end;
+
+function TLightLock.IsLocked: boolean;
+begin
+  result := Flags <> 0;
+end;
+
+procedure TLightLock.LockSpin;
+var
+  spin: PtrUInt;
+begin
+  spin := SPIN_COUNT;
+  repeat
+    spin := DoSpin(spin);
+  until TryLock;
+end;
+
+
+{ TRWLightLock }
+
+procedure TRWLightLock.Init;
+begin
+  Flags := 0; // bit 0=WriteLock, >0=ReadLock counter
+end;
+
+procedure TRWLightLock.ReadLock;
+var
+  f: PtrUInt;
+begin
+  // if not writing, atomically increase the RD counter in the upper flag bits
+  f := Flags and not 1; // bit 0=WriteLock, >0=ReadLock counter
+  if not LockedExc(Flags, f + 2, f) then
+    ReadLockSpin;
+end;
+
+function TRWLightLock.TryReadLock: boolean;
+var
+  f: PtrUInt;
+begin
+  // if not writing, atomically increase the RD counter in the upper flag bits
+  f := Flags and not 1; // bit 0=WriteLock, >0=ReadLock counter
+  result := LockedExc(Flags, f + 2, f);
+end;
+
+procedure TRWLightLock.ReadUnLock;
+begin
+  LockedDec(Flags, 2);
+end;
+
+procedure TRWLightLock.ReadLockSpin;
+var
+  spin: PtrUInt;
+begin
+  spin := SPIN_COUNT;
+  repeat
+    spin := DoSpin(spin);
+  until TryReadLock;
+end;
+
+function TRWLightLock.TryWriteLock: boolean;
+var
+  f: PtrUInt;
+begin
+  f := Flags and not 1; // bit 0=WriteLock, >0=ReadLock
+  result := (Flags = f) and
+            LockedExc(Flags, f + 1, f);
+end;
+
+procedure TRWLightLock.WriteLock;
+begin
+  if not TryWriteLock then
+    WriteLockSpin;
+end;
+
+procedure TRWLightLock.WriteUnLock;
+begin
+  LockedDec(Flags, 1);
+end;
+
+procedure TRWLightLock.WriteLockSpin;
+var
+  spin: PtrUInt;
+begin
+  spin := SPIN_COUNT;
+  repeat
+    spin := DoSpin(spin);
+  until TryWriteLock;
+end;
+
+
+{ TRWLock }
+
+procedure TRWLock.Init;
+begin
+  // bit 0 = WriteLock, 1 = ReadWriteLock, 2.. = ReadOnlyLock counter
+  Flags := 0;
+  // no need to set the other fields because they will be reset if Flags=0
+end;
+
+procedure TRWLock.AssertDone;
+begin
+  if Flags <> 0 then
+    raise EOSException.CreateFmt('TRWLock Flags=%x', [Flags]);
+end;
+
+// dedicated asm for this most simple (and used) method
+{$ifdef FPC_ASMX64} // some Delphi version was reported to fail with no clue why
+
+procedure TRWLock.ReadOnlyLock;
+asm     // stack frame is required since we may call SwitchToThread
+        {$ifdef SYSVABI}
+        mov     rcx, rdi      // rcx = self
+        {$endif SYSVABI}
+@retry: mov     r8d, SPIN_COUNT
+@spin:  mov     rax, qword ptr [rcx + TRWLock.Flags]
+        and     rax, not 1
+        lea     rdx, [rax + 4]
+   lock cmpxchg qword ptr [rcx + TRWLock.Flags], rdx
+        jz      @done
+        pause
+        dec     r8d
+        jnz     @spin
+        push    rcx
+        call    SwitchToThread
+        pop     rcx
+        jmp     @retry
+@done:  // restore the stack frame
+end;
+
+{$else}
+
+procedure TRWLock.ReadOnlyLock;
+var
+  f: PtrUInt;
+begin
+  // if not writing, atomically increase the RD counter in the upper flag bits
+  f := Flags and not 1; // bit 0=WriteLock, 1=ReadWriteLock, >1=ReadOnlyLock
+  if not LockedExc(Flags, f + 4, f) then
+    ReadOnlyLockSpin;
+end;
+
+procedure TRWLock.ReadOnlyLockSpin;
+var
+  spin, f: PtrUInt;
+begin
+  spin := SPIN_COUNT;
+  repeat
+    spin := DoSpin(spin);
+    f := Flags and not 1; // retry ReadOnlyLock
+  until (Flags = f) and
+        LockedExc(Flags, f + 4, f);
+end;
+
+{$endif FPC_ASMX64}
+
+procedure TRWLock.ReadOnlyUnLock;
+begin
+  LockedDec(Flags, 4);
+end;
+
+procedure TRWLock.ReadWriteLock;
+var
+  spin, f: PtrUInt;
+  tid: TThreadID;
+begin
+  tid := GetCurrentThreadId;
+  if (Flags and 2 = 2) and
+     (LastReadWriteLockThread = tid) then
+  begin
+    inc(LastReadWriteLockCount); // allow ReadWriteLock to be reentrant
+    exit;
+  end;
+  // if not writing, atomically acquire the upgradable RD flag bit
+  spin := SPIN_COUNT;
+  repeat
+    f := Flags and not 3; // bit 0=WriteLock, 1=ReadWriteLock, >1=ReadOnlyLock
+    if (Flags = f) and
+       LockedExc(Flags, f + 2, f) then
+      break;
+    spin := DoSpin(spin);
+  until false;
+  LastReadWriteLockThread := tid;
+  LastReadWriteLockCount := 0;
+end;
+
+procedure TRWLock.ReadWriteUnLock;
+begin
+  if LastReadWriteLockCount <> 0 then
+  begin
+    dec(LastReadWriteLockCount);
+    exit;
+  end;
+  LastReadWriteLockThread := TThreadID(0);
+  LockedDec(Flags, 2);
+end;
+
+procedure TRWLock.WriteLock;
+var
+  spin, f: PtrUInt;
+  tid: TThreadID;
+begin
+  tid := GetCurrentThreadId;
+  if (Flags and 1 = 1) and
+     (LastWriteLockThread = tid) then
+  begin
+    inc(LastWriteLockCount); // allow WriteLock to be reentrant
+    exit;
+  end;
+  spin := SPIN_COUNT;
+  // acquire the WR flag bit
+  repeat
+    f := Flags and not 1; // bit 0=WriteLock, 1=ReadWriteLock, >1=ReadOnlyLock
+    if (Flags = f) and
+       LockedExc(Flags, f + 1, f) then
+      if (Flags and 2 = 2) and
+         (LastReadWriteLockThread <> tid) then
+        // there is a pending ReadWriteLock but not on this thread
+        LockedDec(Flags, 1) // try again
+      else
+        // we exclusively acquired the WR lock
+        break;
+    spin := DoSpin(spin);
+  until false;
+  LastWriteLockThread := tid;
+  LastWriteLockCount := 0;
+  // wait for all readers to have finished their job
+  while Flags > 3 do
+    spin := DoSpin(spin);
+end;
+
+procedure TRWLock.WriteUnlock;
+begin
+  if LastWriteLockCount <> 0 then
+  begin
+    dec(LastWriteLockCount); // reentrant call
+    exit;
+  end;
+  LastWriteLockThread := TThreadID(0);
+  LockedDec(Flags, 1);
+end;
+
+procedure TRWLock.Lock(context: TRWLockContext);
+begin
+  if context = cReadOnly then
+    ReadOnlyLock
+  else if context = cReadWrite then
+    ReadWriteLock
+  else
+    WriteLock;
+end;
+
+procedure TRWLock.UnLock(context: TRWLockContext);
+begin
+  if context = cReadOnly then
+    ReadOnlyUnLock
+  else if context = cReadWrite then
+    ReadWriteUnLock
+  else
+    WriteUnLock;
+end;
+
+
+{ TOSLock }
+
+procedure TOSLock.Init;
+begin
+  mormot.core.os.InitializeCriticalSection(CS);
+end;
+
+procedure TOSLock.Done;
+begin
+  DeleteCriticalSectionIfNeeded(CS);
+end;
+
+procedure TOSLock.Lock;
+begin
+  mormot.core.os.EnterCriticalSection(CS);
+end;
+
+function TOSLock.TryLock: boolean;
+begin
+  result := mormot.core.os.TryEnterCriticalSection(CS) <> 0;
+end;
+
+procedure TOSLock.UnLock;
+begin
+  mormot.core.os.LeaveCriticalSection(CS);
+end;
+
+
+{ TLockedList }
+
+procedure TLockedList.Init(onesize: PtrUInt; const onefree: TOnLockedListOne);
+begin
+  FillCharFast(self, SizeOf(self), 0);
+  fSize := onesize;
+  fOnFree := onefree;
+  fSequence := (Random32 shr 2) + 65536; // 65535 < sequence < MaxInt
+end;
+
+function LockedListFreeAll(o: PLockedListOne; const OnFree: TOnLockedListOne): integer;
+var
+  next: PLockedListOne;
+begin
+  result := 0;
+  while o <> nil do
+  begin
+    inc(result);
+    next := o.next;
+    if Assigned(OnFree) then
+      OnFree(o);
+    FreeMem(o);
+    o := next;
+  end;
+end;
+
+procedure TLockedList.Done;
+begin
+  Clear;
+  EmptyBin;
+end;
+
+procedure TLockedList.Clear;
+begin
+  Safe.Lock;
+  try
+    LockedListFreeAll(fHead, fOnFree);
+    fHead := nil;
+    Count := 0;
+  finally
+    Safe.UnLock;
+  end;
+end;
+
+function TLockedList.EmptyBin: integer;
+begin
+  Safe.Lock;
+  try
+    result := LockedListFreeAll(fBin, nil);
+    fBin := nil;
+  finally
+    Safe.UnLock;
+  end;
+end;
+
+function TLockedList.New: pointer;
+begin
+  Safe.Lock;
+  try
+    // try to recycle from single-linked list bin, or allocate
+    result := fBin;
+    if result <> nil then
+      fBin := PLockedListOne(result).next
+    else
+      result := AllocMem(fSize);
+    PLockedListOne(result).sequence := fSequence;
+    inc(fSequence); // protected by Safe.Lock
+    // insert at beginning of the main double-linked list
+    PLockedListOne(result).next := fHead;
+    if fHead <> nil then
+      PLockedListOne(fHead).prev := result;
+    fHead := result;
+    inc(Count);
+  finally
+    Safe.UnLock;
+  end;
+end;
+
+function TLockedList.Free(one: pointer): boolean;
+var
+  o: PLockedListOne absolute one;
+begin
+  result := false;
+  if (o = nil) or
+     (o^.sequence = 0) then
+    exit;
+  Safe.Lock;
+  try
+    // remove from main double-linked list
+    if o = fHead then
+      fHead := o.next;
+    if o.next <> nil then
+      PLockedListOne(o.next).prev := o.prev;
+    if o.prev <> nil then
+      PLockedListOne(o.prev).next := o.next;
+    // release internals and add to the recycle bin
+    if Assigned(fOnFree) then
+      fOnFree(o);
+    FillCharFast(o^, fSize, 0); // garbage collect as void
+    o.next := fBin;
+    fBin := o;
+    dec(Count);
+  finally
+    Safe.UnLock;
+  end;
+  result := true;
+end;
+
+
+{ TAutoLock }
+
+constructor TAutoLock.Create(aLock: PSynLocker);
+begin
+  fLock := aLock;
+  fLock^.Lock;
+end;
+
+destructor TAutoLock.Destroy;
+begin
+  fLock^.UnLock;
+end;
+
+
+{ TSynLocker }
+
+function NewSynLocker: PSynLocker;
+begin
+  result := AllocMem(SizeOf(TSynLocker));
+  InitializeCriticalSection(result^.fSection);
+  result^.fInitialized := true;
+end;
+
+procedure TSynLocker.Init;
+begin
+  InitializeCriticalSection(fSection);
+  fLockCount := 0;
+  fPaddingUsedCount := 0;
+  fInitialized := true;
+  fRW.Init;
+end;
+
+procedure TSynLocker.Done;
+var
+  i: PtrInt;
+begin
+  for i := 0 to fPaddingUsedCount - 1 do
+    if not (integer(Padding[i].VType) in VTYPE_SIMPLE) then
+      VarClearProc(Padding[i]);
+  DeleteCriticalSection(fSection);
+  fInitialized := false;
+end;
+
+procedure TSynLocker.DoneAndFreeMem;
+begin
+  Done;
+  FreeMem(@self);
+end;
+
+function TSynLocker.GetIsLocked: boolean;
+begin
+  case fRWUse of
+    uSharedLock:
+      result := fLockCount <> 0; // only updated by uSharedLock
+    uRWLock:
+      result := fRW.Flags = 0;   // no lock at all
+  else
+    result := false;             // uNoLock will never lock
+  end;
+end;
+
+procedure TSynLocker.RWLock(context: TRWLockContext);
+begin
+  case fRWUse of
+    uSharedLock:
+      begin
+        mormot.core.os.EnterCriticalSection(fSection);
+        inc(fLockCount);
+      end;
+    uRWLock:
+      fRW.Lock(context);
+  end; // uNoLock will just do nothing
+end;
+
+procedure TSynLocker.RWUnLock(context: TRWLockContext);
+begin
+  case fRWUse of
+    uSharedLock:
+      begin
+        dec(fLockCount);
+        mormot.core.os.LeaveCriticalSection(fSection);
+      end;
+    uRWLock:
+      fRW.UnLock(context);
+  end; // uNoLock will just do nothing
+end;
+
+procedure TSynLocker.ReadLock;
+begin
+  RWLock(cReadOnly); // will be properly inlined
+end;
+
+procedure TSynLocker.ReadUnLock;
+begin
+  RWUnLock(cReadOnly);
+end;
+
+procedure TSynLocker.ReadWriteLock;
+begin
+  RWLock(cReadWrite);
+end;
+
+procedure TSynLocker.ReadWriteUnLock;
+begin
+  RWUnLock(cReadWrite);
+end;
+
+procedure TSynLocker.Lock;
+begin
+  RWLock(cWrite);
+end;
+
+procedure TSynLocker.UnLock;
+begin
+  RWUnLock(cWrite);
+end;
+
+function TSynLocker.TryLock: boolean;
+begin
+  result := (fRWUse = uSharedLock) and
+            (mormot.core.os.TryEnterCriticalSection(fSection) <> 0);
+  if result then
+    inc(fLockCount);
+end;
+
+function TSynLocker.TryLockMS(retryms: integer; terminated: PBoolean): boolean;
+var
+  ms: integer;
+  endtix: Int64;
+begin
+  result := TryLock;
+  if result or
+     (fRWUse <> uSharedLock) or
+     (retryms <= 0) then
+    exit;
+  ms := 0;
+  endtix := GetTickCount64 + retryms;
+  repeat
+    SleepHiRes(ms);
+    result := TryLock;
+    if result or
+       ((terminated <> nil) and
+        terminated^) then
+      exit;
+    ms := ms xor 1; // 0,1,0,1... seems to be good for scaling
+  until GetTickCount64 > endtix;
+end;
+
+function TSynLocker.ProtectMethod: IUnknown;
+begin
+  result := TAutoLock.Create(@self);
+end;
+
+function TSynLocker.GetVariant(Index: integer): Variant;
+begin
+  if cardinal(Index) < cardinal(fPaddingUsedCount) then
+  {$ifdef HASFASTTRYFINALLY}
+  try
+  {$else}
+  begin
+  {$endif HASFASTTRYFINALLY}
+    RWLock(cReadOnly);
+    result := variant(Padding[Index]);
+  {$ifdef HASFASTTRYFINALLY}
+  finally
+  {$endif HASFASTTRYFINALLY}
+    RWUnLock(cReadOnly);
+  end
+  else
+    VarClear(result);
+end;
+
+procedure TSynLocker.SetVariant(Index: integer; const Value: Variant);
+begin
+  if cardinal(Index) <= high(Padding) then
+  try
+    RWLock(cWrite);
+    if Index >= fPaddingUsedCount then
+      fPaddingUsedCount := Index + 1;
+    variant(Padding[Index]) := Value;
+  finally
+    RWUnLock(cWrite);
+  end;
+end;
+
+function TSynLocker.GetInt64(Index: integer): Int64;
+begin
+  if cardinal(Index) < cardinal(fPaddingUsedCount) then
+  {$ifdef HASFASTTRYFINALLY}
+  try
+  {$else}
+  begin
+  {$endif HASFASTTRYFINALLY}
+    RWLock(cReadOnly);
+    if not VariantToInt64(variant(Padding[Index]), result) then
+      result := 0;
+  {$ifdef HASFASTTRYFINALLY}
+  finally
+  {$endif HASFASTTRYFINALLY}
+    RWUnLock(cReadOnly);
+  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 cardinal(Index) < cardinal(fPaddingUsedCount) then
+  {$ifdef HASFASTTRYFINALLY}
+  try
+  {$else}
+  begin
+  {$endif HASFASTTRYFINALLY}
+    RWLock(cReadOnly);
+    if not VariantToBoolean(variant(Padding[Index]), result) then
+      result := false;
+  {$ifdef HASFASTTRYFINALLY}
+  finally
+  {$endif HASFASTTRYFINALLY}
+    RWUnLock(cReadOnly);
+  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 (cardinal(Index) >= cardinal(fPaddingUsedCount)) 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 >= fPaddingUsedCount then
+      fPaddingUsedCount := Index + 1;
+    variant(Padding[Index]) := Value;
+  end;
+end;
+
+function TSynLocker.GetPointer(Index: integer): Pointer;
+begin
+  if cardinal(Index) < cardinal(fPaddingUsedCount) then
+  {$ifdef HASFASTTRYFINALLY}
+  try
+  {$else}
+  begin
+  {$endif HASFASTTRYFINALLY}
+    RWLock(cReadOnly);
+    with Padding[Index] do
+      if VType = varUnknown then
+        result := VUnknown
+      else
+        result := nil;
+  {$ifdef HASFASTTRYFINALLY}
+  finally
+  {$endif HASFASTTRYFINALLY}
+    RWUnLock(cReadOnly);
+  end
+  else
+    result := nil;
+end;
+
+procedure TSynLocker.SetPointer(Index: integer; const Value: Pointer);
+begin
+  if cardinal(Index) <= high(Padding) then
+  try
+    RWLock(cWrite);
+    if Index >= fPaddingUsedCount then
+      fPaddingUsedCount := Index + 1;
+    with Padding[Index] do
+    begin
+      VarClearAndSetType(PVariant(@VType)^, varUnknown);
+      VUnknown := Value;
+    end;
+  finally
+    RWUnLock(cWrite);
+  end;
+end;
+
+function TSynLocker.GetUtf8(Index: integer): RawUtf8;
+begin
+  if cardinal(Index) < cardinal(fPaddingUsedCount) then
+  {$ifdef HASFASTTRYFINALLY}
+  try
+  {$else}
+  begin
+  {$endif HASFASTTRYFINALLY}
+    RWLock(cReadOnly);
+    VariantStringToUtf8(variant(Padding[Index]), result);
+  {$ifdef HASFASTTRYFINALLY}
+  finally
+  {$endif HASFASTTRYFINALLY}
+    RWUnLock(cReadOnly);
+  end
+  else
+    result := '';
+end;
+
+procedure TSynLocker.SetUtf8(Index: integer; const Value: RawUtf8);
+begin
+  if cardinal(Index) <= high(Padding) then
+  try
+    RWLock(cWrite);
+    if Index >= fPaddingUsedCount then
+      fPaddingUsedCount := Index + 1;
+    RawUtf8ToVariant(Value, variant(Padding[Index]));
+  finally
+    RWUnLock(cWrite);
+  end;
+end;
+
+function TSynLocker.LockedInt64Increment(Index: integer; const Increment: Int64): Int64;
+begin
+  if cardinal(Index) <= high(Padding) then
+  try
+    RWLock(cWrite);
+    result := 0;
+    if Index < fPaddingUsedCount then
+      VariantToInt64(variant(Padding[Index]), result)
+    else
+      fPaddingUsedCount := Index + 1;
+    variant(Padding[Index]) := Int64(result + Increment);
+  finally
+    RWUnLock(cWrite);
+  end
+  else
+    result := 0;
+end;
+
+function TSynLocker.LockedExchange(Index: integer; const Value: variant): variant;
+begin
+  VarClear(result);
+  if cardinal(Index) <= high(Padding) then
+  try
+    RWLock(cWrite);
+    with Padding[Index] do
+    begin
+      if Index < fPaddingUsedCount then
+        result := PVariant(@VType)^
+      else
+        fPaddingUsedCount := Index + 1;
+      PVariant(@VType)^ := Value;
+    end;
+  finally
+    RWUnLock(cWrite);
+  end;
+end;
+
+function TSynLocker.LockedPointerExchange(Index: integer; Value: pointer): pointer;
+begin
+  if cardinal(Index) <= high(Padding) then
+  try
+    RWLock(cWrite);
+    with Padding[Index] do
+    begin
+      if Index < fPaddingUsedCount then
+        if VType = varUnknown then
+          result := VUnknown
+        else
+        begin
+          VarClear(PVariant(@VType)^);
+          result := nil;
+        end
+      else
+      begin
+        fPaddingUsedCount := Index + 1;
+        result := nil;
+      end;
+      VType := varUnknown;
+      VUnknown := Value;
+    end;
+  finally
+    RWUnLock(cWrite);
+  end
+  else
+    result := nil;
+end;
+
+
+
+{ TSynLocked }
+
+constructor TSynLocked.Create;
+begin
+  fSafe := NewSynLocker;
+end;
+
+destructor TSynLocked.Destroy;
+begin
+  inherited Destroy;
+  fSafe^.DoneAndFreeMem;
+end;
+
+
+{ TSynEvent }
+
+function TSynEvent.SleepStep(var start: Int64; terminated: PBoolean): Int64;
+var
+  ms: integer;
+  endtix: Int64;
+begin
+  ms := SleepStepTime(start, result, @endtix);
+  if (ms < 10) or
+     (terminated = nil) then
+    if ms = 0 then
+      SleepHiRes(0) // < 16 ms is a pious wish on Windows anyway
+    else
+      WaitFor(ms)
+  else
+    repeat
+      WaitFor(10);
+      if terminated^ then
+        exit;
+      result := GetTickCount64;
+    until result >= endtix;
+end;
+
+function TSynEvent.IsEventFD: boolean;
+begin
+  {$ifdef HASEVENTFD}
+  result := fFD <> 0;
+  {$else}
+  result := false;
+  {$endif HASEVENTFD}
+end;
+
+
+{ TLecuyerThreadSafe }
+
+function TLecuyerThreadSafe.Next: cardinal;
+begin
+  Safe.Lock;
+  result := Generator.Next;
+  Safe.UnLock;
+end;
+
+function TLecuyerThreadSafe.NextDouble: double;
+begin
+  Safe.Lock;
+  result := Generator.NextDouble;
+  Safe.UnLock;
+end;
+
+procedure TLecuyerThreadSafe.Fill(dest: pointer; count: integer);
+begin
+  Safe.Lock;
+  Generator.Fill(dest, count);
+  Safe.UnLock;
+end;
+
+procedure TLecuyerThreadSafe.FillShort31(var dest: TShort31);
+begin
+  Fill(@dest, 32);
+  FillAnsiStringFromRandom(@dest, 32);
+end;
+
+
+procedure GlobalLock;
+begin
+  mormot.core.os.EnterCriticalSection(GlobalCriticalSection.CS);
+end;
+
+procedure GlobalUnLock;
+begin
+  mormot.core.os.LeaveCriticalSection(GlobalCriticalSection.CS);
+end;
+
+var
+  InternalGarbageCollection: record // RegisterGlobalShutdownRelease() list
+    Instances:  TObjectDynArray;
+    Count: integer;
+    Shutdown: boolean; // paranoid check to avoid messing with Instances[]
+  end;
+
+function RegisterGlobalShutdownRelease(Instance: TObject;
+  SearchExisting: boolean): pointer;
+begin
+  if not InternalGarbageCollection.Shutdown then
+  begin
+    GlobalLock;
+    try
+      with InternalGarbageCollection do
+        if not SearchExisting or
+           not PtrUIntScanExists(pointer(Instances), Count, PtrUInt(Instance)) then
+          PtrArrayAdd(Instances, Instance, Count);
+    finally
+      GlobalUnLock;
+    end;
+  end;
+  result := Instance;
+end;
+
+function SleepDelay(elapsed: PtrInt): PtrInt;
+begin
+  if elapsed < 50 then
+    result := 0 // 10us on POSIX, SwitchToThread on Windows
+  else if elapsed < 200 then
+    result := 1
+  else if elapsed < 500 then
+    result := 5
+  else if elapsed < 2000 then
+    result := 50
+  else
+    result := 120 + Random32(130); // random 120-250 ms
+end;
+
+function SleepStepTime(var start, tix: Int64; endtix: PInt64): PtrInt;
+begin
+  tix := GetTickCount64;
+  if (start = 0) or
+     (tix < 50) then
+    start := tix
+  else if start < 0 then
+    start := tix - 50; // ensure tix - start = elapsed is not < 50
+  result := SleepDelay(tix - start);
+  if endtix <> nil then
+    endtix^ := tix + result;
+end;
+
+function SleepStep(var start: Int64; terminated: PBoolean): Int64;
+var
+  ms: integer;
+  endtix: Int64;
+begin
+  ms := SleepStepTime(start, result, @endtix);
+  if (ms < 10) or
+     (terminated = nil) then
+    SleepHiRes(ms) // < 16 ms is a pious wish on Windows anyway
+  else
+    repeat
+      SleepHiRes(10); // on Windows, HW clock resolution is around 16 ms
+      result := GetTickCount64;
+    until (ms = 0) or
+          terminated^ or
+          (result >= endtix);
+end;
+
+function SleepHiRes(ms: cardinal; var terminated: boolean;
+  terminatedvalue: boolean): boolean;
+var
+  start, endtix: Int64;
+begin
+  if terminated <> terminatedvalue then
+    if ms < 20 then
+      SleepHiRes(ms) // below HW clock resolution
+    else
+    begin
+      start := GetTickCount64;
+      endtix := start + ms;
+      repeat
+      until (terminated = terminatedvalue) or
+            (SleepStep(start, @terminated) > endtix);
+    end;
+  result := terminated = terminatedvalue;
+end;
+
+procedure SpinExc(var Target: PtrUInt; NewValue, Comperand: PtrUInt);
+var
+  spin: PtrUInt;
+begin
+  spin := SPIN_COUNT;
+  while (Target <> Comperand) or
+        not LockedExc(Target, NewValue, Comperand) do
+    spin := DoSpin(spin);
+end;
+
+function ObjArrayAdd(var aObjArray; aItem: TObject;
+  var aSafe: TLightLock; aCount: PInteger): PtrInt;
+begin
+  aSafe.Lock;
+  if aCount <> nil then
+    result := PtrArrayAdd(aObjArray, aItem, aCount^)
+  else
+    result := PtrArrayAdd(aObjArray, aItem);
+  aSafe.UnLock;
+end;
+
+function PtrArrayDelete(var aPtrArray; aItem: pointer; var aSafe: TLightLock;
+  aCount: PInteger): PtrInt;
+begin
+  if pointer(aPtrArray) = nil then
+  begin
+    result := -1; // no need to lock anything
+    exit;
+  end;
+  aSafe.Lock;
+  result := PtrArrayDelete(aPtrArray, aItem, aCount);
+  aSafe.UnLock;
+end;
+
+function SetCpuSet(var CpuSet: TCpuSet; CpuIndex: cardinal): boolean;
+begin
+  result := false;
+  if (CpuIndex >= SizeOf(CpuSet) shl 3) or
+     (CpuIndex >= SystemInfo.dwNumberOfProcessors) then
+    exit;
+  SetBitPtr(@CpuSet, CpuIndex);
+  result := true;
+end;
+
+function CurrentCpuSet(out CpuSet: TCpuSet): integer;
+begin
+  ResetCpuSet(CpuSet);
+  if GetMaskAffinity(CpuSet) then
+    result := GetBitsCount(CpuSet, SizeOf(CpuSet) shl 3)
+  else
+    result := 0;
+end;
+
+function SetThreadCpuAffinity(Thread: TThread; CpuIndex: cardinal): boolean;
+var
+  mask: TCpuSet;
+begin
+  ResetCpuSet(mask);
+  result := SetCpuSet(mask, CpuIndex) and
+            SetThreadMaskAffinity(Thread, mask);
+end;
+
+function SetThreadSocketAffinity(Thread: TThread; SocketIndex: cardinal): boolean;
+begin
+  result := (SocketIndex < cardinal(length(CpuSocketsMask))) and
+            SetThreadMaskAffinity(Thread, CpuSocketsMask[SocketIndex]);
+end;
+
+procedure _SetThreadName(ThreadID: TThreadID; const Format: RawUtf8;
+  const Args: array of const);
+begin
+  // do nothing - properly implemented in mormot.core.log
+end;
+
+procedure SetCurrentThreadName(const Format: RawUtf8; const Args: array of const);
+begin
+  SetThreadName(GetCurrentThreadId, Format, Args);
+end;
+
+procedure SetCurrentThreadName(const Name: RawUtf8);
+begin
+  SetThreadName(GetCurrentThreadId, '%', [Name]);
+end;
+
+threadvar // do not publish for compilation within Delphi packages
+  _CurrentThreadName: TShort31; // 31 chars is enough for our debug purpose
+
+function CurrentThreadNameShort: PShortString;
+begin
+  result := @_CurrentThreadName;
+end;
+
+function GetCurrentThreadName: RawUtf8;
+begin
+  ShortStringToAnsi7String(_CurrentThreadName, result);
+end;
+
+function GetCurrentThreadInfo: ShortString;
+begin
+  result := ShortString(format('Thread %x [%s]',
+    [PtrUInt(GetCurrentThreadId), _CurrentThreadName]));
+end;
+
+
+{ ****************** Unix Daemon and Windows Service Support }
+
+const
+  // hardcoded to avoid linking mormot.core.rtti for GetEnumName()
+  _SERVICESTATE: array[TServiceState] of string[12] = (
+    'NotInstalled',
+    'Stopped',
+    'Starting',
+    'Stopping',
+    'Running',
+    'Resuming',
+    'Pausing',
+    'Paused',
+    'Failed',
+    'Error');
+
+function ToText(st: TServiceState): PShortString; overload;
+begin
+  result := @_SERVICESTATE[st];
+end;
+
+function ExtractExecutableName(const cmd: RawUtf8; posix: boolean): RawUtf8;
+var
+  temp: RawUtf8;
+  argv: TParseCommandsArgs;
+  argc: integer;
+begin
+  if (pcInvalidCommand in ParseCommandArgs(cmd, @argv, @argc, @temp, posix)) or
+     ({%H-}argc = 0) then
+    result := ''
+  else
+    FastSetString(result, argv[0], StrLen(argv[0]));
+end;
+
+function ParseCommandArgs(const cmd: RawUtf8; argv: PParseCommandsArgs;
+  argc: PInteger; temp: PRawUtf8; posix: boolean): TParseCommands;
+var
+  n: PtrInt;
+  state: set of (sWhite, sInArg, sInSQ, sInDQ, sSpecial, sBslash);
+  c: AnsiChar;
+  D, P: PAnsiChar;
+begin
+  result := [pcInvalidCommand];
+  if argv <> nil then
+    argv[0] := nil;
+  if argc <> nil then
+    argc^ := 0;
+  if cmd = '' then
+    exit;
+  if argv = nil then
+    D := nil
+  else
+  begin
+    if temp = nil then
+      exit;
+    SetLength(temp^, length(cmd));
+    D := pointer(temp^);
+  end;
+  state := [];
+  n := 0;
+  P := pointer(cmd);
+  repeat
+    c := P^;
+    if D <> nil then
+      D^ := c;
+    inc(P);
+    case c of
+      #0:
+        begin
+          if sInSQ in state then
+            include(result, pcUnbalancedSingleQuote);
+          if sInDQ in state then
+            include(result, pcUnbalancedDoubleQuote);
+          exclude(result, pcInvalidCommand);
+          if argv <> nil then
+            argv[n] := nil;
+          if argc <> nil then
+            argc^ := n;
+          exit;
+        end;
+      #1 .. ' ':
+        begin
+         if state = [sInArg] then
+         begin
+           state := [];
+           if D <> nil then
+           begin
+             D^ := #0;
+             inc(D);
+           end;
+           continue;
+         end;
+         if state * [sInSQ, sInDQ] = [] then
+           continue;
+        end;
+      '\':
+        if posix and
+           (state * [sInSQ, sBslash] = []) then
+          if sInDQ in state then
+          begin
+            case P^ of
+              '"', '\', '$', '`':
+                begin
+                  include(state, sBslash);
+                  continue;
+                end;
+            end;
+          end
+          else if P^ = #0 then
+          begin
+            include(result, pcHasEndingBackSlash);
+            exit;
+          end
+          else
+          begin
+            if D <> nil then
+              D^ := P^;
+            inc(P);
+          end;
+      '^':
+        if not posix and
+           (state * [sInSQ, sInDQ, sBslash] = []) then
+          if PWord(P)^ = $0a0d then
+          begin
+            inc(P, 2);
+            continue;
+          end
+          else if P^ = #0 then
+          begin
+            include(result, pcHasEndingBackSlash);
+            exit;
+          end
+          else
+          begin
+            if D <> nil then
+              D^ := P^;
+            inc(P);
+          end;
+      '''':
+        if posix and
+           not(sInDQ in state) then
+          if sInSQ in state then
+          begin
+            exclude(state, sInSQ);
+            continue;
+          end
+          else if state = [] then
+          begin
+            if argv <> nil then
+            begin
+              argv[n] := D;
+              inc(n);
+              if n = high(argv^) then
+                exit;
+            end;
+            state := [sInSQ, sInArg];
+            continue;
+          end
+          else if state = [sInArg] then
+          begin
+            state := [sInSQ, sInArg];
+            continue;
+          end;
+      '"':
+        if not(sInSQ in state) then
+          if sInDQ in state then
+          begin
+            exclude(state, sInDQ);
+            continue;
+          end
+          else if state = [] then
+          begin
+            if argv <> nil then
+            begin
+              argv[n] := D;
+              inc(n);
+              if n = high(argv^) then
+                exit;
+            end;
+            state := [sInDQ, sInArg];
+            continue;
+          end
+          else if state = [sInArg] then
+          begin
+            state := [sInDQ, sInArg];
+            continue;
+          end;
+      '|',
+      '<',
+      '>':
+        if state * [sInSQ, sInDQ] = [] then
+          include(result, pcHasRedirection);
+      '&',
+      ';':
+        if posix and
+           (state * [sInSQ, sInDQ] = []) then
+        begin
+          include(state, sSpecial);
+          include(result, pcHasJobControl);
+        end;
+      '`':
+        if posix and
+           (state * [sInSQ, sBslash] = []) then
+           include(result, pcHasSubCommand);
+      '(',
+      ')':
+        if posix and
+           (state * [sInSQ, sInDQ] = []) then
+          include(result, pcHasParenthesis);
+      '$':
+        if posix and
+           (state * [sInSQ, sBslash] = []) then
+          if p^ = '(' then
+            include(result, pcHasSubCommand)
+          else
+            include(result, pcHasShellVariable);
+      '*',
+      '?':
+        if posix and
+           (state * [sInSQ, sInDQ] = []) then
+          include(result, pcHasWildcard);
+    end;
+    exclude(state, sBslash);
+    if state = [] then
+    begin
+      if argv <> nil then
+      begin
+        argv[n] := D;
+        inc(n);
+        if n = high(argv^) then
+          exit;
+      end;
+      state := [sInArg];
+    end;
+    if D <> nil then
+      inc(D);
+  until false;
+end;
+
+procedure TrimDualSpaces(var s: RawUtf8);
+var
+  f, i: integer;
+begin
+  f := 1;
+  repeat
+    i := PosEx('  ', s, f);
+    if i = 0 then
+      break;
+    delete(s, i, 1); // dual space -> single space
+    f := i;
+  until false;
+  TrimSelf(s);
+end;
+
+
+procedure InitializeUnit;
+begin
+  {$ifdef ISFPC27}
+  SetMultiByteConversionCodePage(CP_UTF8);
+  SetMultiByteRTLFileSystemCodePage(CP_UTF8);
+  {$endif ISFPC27}
+  GlobalCriticalSection.Init;
+  ConsoleCriticalSection.Init;
+  InitializeSpecificUnit; // in mormot.core.os.posix/windows.inc files
+  TrimDualSpaces(OSVersionText);
+  TrimDualSpaces(OSVersionInfoEx);
+  TrimDualSpaces(BiosInfoText);
+  TrimDualSpaces(CpuInfoText);
+  OSVersionShort := ToTextOS(OSVersionInt32);
+  InitializeExecutableInformation;
+  JSON_CONTENT_TYPE_VAR := JSON_CONTENT_TYPE;
+  JSON_CONTENT_TYPE_HEADER_VAR := JSON_CONTENT_TYPE_HEADER;
+  NULL_STR_VAR := 'null';
+  BOOL_UTF8[false] := 'false';
+  BOOL_UTF8[true]  := 'true';
+  // minimal stubs which will be properly implemented in mormot.core.log.pas
+  GetExecutableLocation := _GetExecutableLocation;
+  SetThreadName := _SetThreadName;
+end;
+
+procedure FinalizeUnit;
+var
+  i: PtrInt;
+begin
+  with InternalGarbageCollection do
+  begin
+    Shutdown := true; // avoid nested initialization at shutdown
+    for i := Count - 1 downto 0 do
+      FreeAndNilSafe(Instances[i]); // before GlobalCriticalSection deletion
+  end;
+  ObjArrayClear(CurrentFakeStubBuffers);
+  Executable.Version.Free;
+  Executable.Command.Free;
+  FinalizeSpecificUnit; // in mormot.core.os.posix/windows.inc files
+  ConsoleCriticalSection.Done;
+  GlobalCriticalSection.Done;
+  {$ifndef NOEXCEPTIONINTERCEPT}
+  _RawLogException := nil;
+  RawExceptionIntercepted := true;
+  {$endif NOEXCEPTIONINTERCEPT}
+end;
+
+
+initialization
+  InitializeUnit;
+
+finalization
+  FinalizeUnit;
+
+end.
+
diff --git a/lib/dmustache/mormot.core.os.posix.inc b/lib/dmustache/mormot.core.os.posix.inc
new file mode 100644
index 00000000..26583a30
--- /dev/null
+++ b/lib/dmustache/mormot.core.os.posix.inc
@@ -0,0 +1,4311 @@
+{
+  This file is a part of the Open Source Synopse mORMot framework 2,
+  licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+
+   POSIX API calls for FPC, as used by mormot.core.os.pas
+}
+
+uses
+  baseunix,
+  unix,
+  unixcp,
+  unixtype,
+  unixutil, // for TZSeconds - as used by sysutils anyway
+  {$ifdef OSBSDDARWIN}
+  sysctl,
+  {$else}
+  linux,
+  syscall,
+  {$endif OSBSDDARWIN}
+  {$ifdef FPCUSEVERSIONINFO} // to be enabled in mormot.defines.inc
+    fileinfo,        // FPC 3.0 and up
+    {$ifdef OSDARWIN}
+      machoreader,   // MACH-O executables
+    {$else}
+      elfreader,     // ELF executables
+    {$endif OSDARWIN}
+  {$endif FPCUSEVERSIONINFO}
+  errors,
+  termio,
+  dl,
+  initc; // we statically link the libc for some raw calls
+
+{$ifdef UNICODE}
+  'mORMot assumes no UNICODE on POSIX, i.e. as TFileName = PChar = PUtf8Char'
+{$endif UNICODE}
+
+
+// define some raw text functions, to avoid linking mormot.core.text
+
+function IdemPChar(p, up: PUtf8Char): boolean; inline;
+var
+  c, u: AnsiChar;
+begin
+  // we know that p<>nil and up<>nil within this unit
+  result := false;
+  repeat
+    u := up^;
+    if u = #0 then
+      break;
+    inc(up);
+    c := p^;
+    inc(p);
+    if c <> u then
+      if (c >= 'a') and
+         (c <= 'z') then
+      begin
+        dec(c, 32);
+        if c <> u then
+          exit;
+      end
+      else
+        exit;
+  until false;
+  result := true;
+end;
+
+function IdemPChars(const s: RawUtf8; const up: array of PUtf8Char): boolean;
+var
+  i: PtrInt;
+begin
+  if s <> '' then
+  begin
+    result := true;
+    for i := 0 to high(up) do
+      if IdemPChar(pointer(s), up[i]) then
+        exit;
+  end;
+  result := false;
+end;
+
+procedure FindNameValue(const s, up: RawUtf8; var res: RawUtf8);
+var
+  p: PUtf8Char;
+  L: PtrInt;
+begin
+  p := pointer(s);
+  while p <> nil do
+  begin
+    if IdemPChar(p, pointer(up)) then
+    begin
+      inc(p, length(up));
+      while (p^ <= ' ') and
+            (p^ <> #0) do
+        inc(p); // trim left
+      L := 0;
+      while p[L] > #13 do
+        inc(L);
+      while p[L - 1] = ' ' do
+        dec(L); // trim right
+      FastSetString(res, p, L);
+      exit;
+    end;
+    p := GotoNextLine(p);
+  end;
+  res := '';
+end;
+
+function GetNextCardinal(var P: PAnsiChar): PtrUInt;
+var
+  c: cardinal;
+begin
+  result := 0;
+  while not (P^ in ['0'..'9']) do
+    if P^ = #0 then
+      exit
+    else
+      inc(P);
+  repeat
+    c := ord(P^) - 48;
+    if c > 9 then
+      break;
+    result := result * 10 + c;
+    inc(P);
+  until false;
+end;
+
+function GetNextItem(var P: PAnsiChar): RawUtf8;
+var
+  S: PAnsiChar;
+begin
+  result := '';
+  while P^ <= ' ' do
+    if P^ = #0 then
+      exit
+    else
+      inc(P);
+  S := P;
+  repeat
+    inc(P);
+  until P^ <= ' ';
+  FastSetString(result, S, P - S);
+end;
+
+procedure RawUtf8Append(var s: RawUtf8; p: PUtf8Char; l: PtrInt);
+var
+  n: PtrInt;
+begin
+  if l = 0 then
+    exit;
+  n := length(s);
+  SetLength(s, n + l);
+  MoveFast(p^, PByteArray(s)[n], l);
+end;
+
+function _fmt(const Fmt: string; const Args: array of const): RawUtf8; overload;
+begin
+  result := RawUtf8(format(Fmt, Args)); // good enough (seldom called)
+end;
+
+procedure _fmt(const Fmt: string; const Args: array of const;
+  var result: RawUtf8); overload;
+begin
+  result := RawUtf8(format(Fmt, Args)); // good enough (seldom called)
+end;
+
+
+{ ****************** Unicode, Time, File process }
+
+function LibraryOpen(const LibraryName: TFileName): TLibHandle;
+begin
+  result := TLibHandle(dlopen(pointer(LibraryName), RTLD_LAZY));
+end;
+
+procedure LibraryClose(Lib: TLibHandle);
+begin
+  dlclose(pointer(Lib));
+end;
+
+function LibraryResolve(Lib: TLibHandle; ProcName: PAnsiChar): pointer;
+begin
+  result := dlsym(pointer(Lib), ProcName);
+end;
+
+function LibraryError: string;
+begin
+  result := dlerror;
+end;
+
+
+{ TIcuLibrary }
+
+procedure TIcuLibrary.Done;
+begin
+  if icui18n <> nil then
+    dlclose(icui18n);
+  if icu <> nil then
+    dlclose(icu);
+  if icudata <> nil then
+    dlclose(icudata);
+  icu := nil;
+  icudata := nil;
+  icui18n := nil;
+  @ucnv_open := nil;
+end;
+
+function TIcuLibrary.IsAvailable: boolean;
+begin
+  if not Loaded then
+    DoLoad;
+  result := Assigned(ucnv_open);
+end;
+
+function IsWideStringManagerProperlyInstalled: boolean;
+const
+  u: WideChar = #$2020; // should convert to dagger glyph #134 in CP 1252
+var
+  d: RawByteString;
+begin
+  try
+    widestringmanager.Unicode2AnsiMoveProc(@u, d, 1252, 1);
+    result := (length(d) = 1) and
+              (d[1] = #134);
+    // the default RTL handler would just return '?'
+  except
+    result := false;
+  end;
+end;
+
+procedure TIcuLibrary.DoLoad(const LibName: TFileName; Version: string);
+const
+  NAMES: array[0..12] of string = (
+    'ucnv_open',
+    'ucnv_close',
+    'ucnv_setSubstChars',
+    'ucnv_setFallback',
+    'ucnv_fromUChars',
+    'ucnv_toUChars',
+    'u_strToUpper',
+    'u_strToLower',
+    'u_strCompare',
+    'u_strCaseCompare',
+    'u_getDataDirectory',
+    'u_setDataDirectory',
+    'u_init');
+  {$ifdef OSANDROID}
+  // https://developer.android.com/guide/topics/resources/internationalization
+  ICU_VER: array[1..15] of string = (
+    '_3_8', '_4_2', '_44', '_46', '_48', '_50', '_51', '_53', '_55',
+    '_56', '_58', '_60', '_63', '_66', '_68');
+  ICU_MAX = 80;
+  ICU_MIN = 69; // previous versions are known and listed within ICU_VER[]
+  SYSDATA: PAnsiChar = '/system/usr/icu';
+  {$else}
+  ICU_MAX = 80;
+  ICU_MIN = 44;
+  SYSDATA: PAnsiChar = '';
+  {$endif OSANDROID}
+var
+  i: integer;
+  err: SizeInt;
+  P: PPointer;
+  {$ifndef OSDARWIN}
+  so: string;
+  {$endif OSDARWIN}
+  v, vers: string;
+  data: PAnsiChar;
+begin
+  GlobalLock;
+  try
+    if Loaded then
+      exit;
+    Loaded := true;
+    if LibName <> '' then
+    begin
+      icu := dlopen(pointer(LibName), RTLD_LAZY);
+      if icu = nil then
+        exit;
+    end
+    else
+    begin
+      {$ifdef OSDARWIN}
+      // Mach OS has its own ICU set of libraries
+      icu := dlopen('libicuuc.dylib', RTLD_LAZY);
+      if icu <> nil then
+        icui18n := dlopen('libicui18n.dylib', RTLD_LAZY);
+      {$else}
+      // libicudata should be loaded first because other two depend on it
+      icudata := dlopen('libicudata.so', RTLD_LAZY);
+      {$ifndef OSANDROID}
+      if icudata = nil then
+      begin
+        // there is no link to the library -> try e.g. 'libicudata.so.67'
+        if Version <> '' then
+          icudata := dlopen(pointer('libicudata.so.' + Version), RTLD_LAZY);
+        if icudata = nil then
+          for i := ICU_MAX downto ICU_MIN do
+          begin
+            str(i, v);
+            icudata := dlopen(pointer('libicudata.so.' + v), RTLD_LAZY);
+            if icudata <> nil then
+            begin
+              Version := v;
+              break;
+            end;
+          end;
+        if icudata <> nil then
+          so := '.' + Version;
+      end;
+      {$endif OSANDROID}
+      if icudata <> nil then
+      begin
+        icu := dlopen(pointer('libicuuc.so' + so), RTLD_LAZY);
+        if icu <> nil then
+          icui18n := dlopen(pointer('libicui18n.so' + so), RTLD_LAZY);
+      end;
+      {$endif OSDARWIN}
+      if icui18n = nil then
+      begin
+        // we did not find any ICU installed -> ensure iconv/RTL fallback is ok
+        if not IsWideStringManagerProperlyInstalled then
+          DisplayFatalError('ICU ' + CPU_ARCH_TEXT + ' is not available',
+            'Either install it or put cwstring in your uses clause as fallback');
+        Done;
+        exit;
+      end
+    end;
+    // ICU append a version prefix to all its functions e.g. ucnv_open_66
+    if (Version <> '') and
+       (dlsym(icu, pointer('ucnv_open_' + Version)) <> nil) then
+      vers := '_' + Version // matched the explicit version
+    else
+    begin
+      {$ifdef OSANDROID}
+      for i := high(ICU_VER) downto 1 do
+      begin
+        if dlsym(icu, pointer(NAMES[0] + ICU_VER[i])) <> nil then
+        begin
+          vers := ICU_VER[i];
+          break;
+        end;
+      end;
+      if vers <> '' then
+      {$endif OSANDROID}
+      if dlsym(icu, 'ucnv_open') = nil then
+        for i := ICU_MAX downto ICU_MIN do
+        begin
+          str(i, v);
+          if dlsym(icu, pointer('ucnv_open_' + v)) <> nil then
+          begin
+            vers := '_' + v;
+            break;
+          end;
+        end;
+    end;
+    P := @@ucnv_open;
+    for i := 0 to high(NAMES) do
+    begin
+      P[i] := dlsym(icu, pointer(NAMES[i] + vers));
+      if P[i] = nil then
+      begin
+        @ucnv_open := nil;
+        exit;
+      end;
+    end;
+    data := u_getDataDirectory;
+    if (data = nil) or
+       (data^ = #0) then
+      if SYSDATA <> '' then
+        u_setDataDirectory(SYSDATA);
+    err := 0;
+    u_init(err);
+  finally
+    GlobalUnLock;
+  end;
+end;
+
+function TIcuLibrary.ForceLoad(const LibName: TFileName; const Version: string): boolean;
+begin
+  Done;
+  Loaded := false;
+  DoLoad(LibName, Version);
+  result := Assigned(ucnv_open);
+end;
+
+function TIcuLibrary.ucnv(codepage: cardinal): pointer;
+var
+  s: ShortString;
+  err: SizeInt;
+  {$ifdef CPUINTEL}
+  mask: cardinal;
+  {$endif CPUINTEL}
+begin
+  if not IsAvailable then
+    exit(nil);
+  str(codepage, s);
+  MoveFast(s[1], s[3], ord(s[0]));
+  PWord(@s[1])^ := ord('c') + ord('p') shl 8;
+  inc(s[0], 3);
+  s[ord(s[0])] := #0;
+  {$ifdef CPUINTEL}
+  mask := GetMXCSR;
+  SetMXCSR(mask or $0080 {MM_MaskInvalidOp} or $1000 {MM_MaskPrecision});
+  {$endif CPUINTEL}
+  err := 0;
+  result := ucnv_open(@s[1], err);
+  if result <> nil then
+  begin
+    err := 0;
+    ucnv_setSubstChars(result, '?', 1, err);
+    ucnv_setFallback(result, true);
+  end;
+  {$ifdef CPUINTEL}
+  SetMXCSR(mask);
+  {$endif CPUINTEL}
+end;
+
+
+const
+  // for CompareStringW()
+  LOCALE_USER_DEFAULT = $400;
+  NORM_IGNORECASE = 1 shl ord(coIgnoreCase); // [widestringmanager.coIgnoreCase]
+
+function CompareStringRTL(A, B: PWideChar; AL, BL, flags: integer): integer;
+var
+  U1, U2: UnicodeString; // allocate two temporary strings
+begin
+  // cwstring as fallback, using iconv on systems where ICU is not available
+  SetString(U1, A, AL);
+  SetString(U2, B, BL);
+  result := widestringmanager.CompareUnicodeStringProc(
+    U1, U2, TCompareOptions(flags));
+end;
+
+function CompareStringW(locale, flags: DWORD;
+  A: PWideChar; AL: integer; B: PWideChar; BL: integer): PtrInt;
+const
+  CODE_POINT_ORDER = $8000;
+var
+  err: SizeInt;
+begin
+  if AL < 0 then
+    AL := StrLenW(A);
+  if BL < 0 then
+    BL := StrLenW(B);
+  err := 0;
+  if icu.IsAvailable then
+    if flags and NORM_IGNORECASE <> 0 then
+      result := icu.u_strCaseCompare(A, AL, B, BL, CODE_POINT_ORDER, err)
+    else
+      result := icu.u_strCompare(A, AL, B, BL, true)
+  else
+    result := CompareStringRTL(A, B, AL, BL, flags);
+  inc(result, 2); // caller would make -2 to get regular -1/0/1 comparison values
+end;
+
+function AnsiToWideRTL(CodePage: cardinal; A: PAnsiChar; W: PWideChar;
+  AL, WL: PtrInt): PtrInt;
+var
+  tmp: UnicodeString;
+begin
+  // cwstring as fallback, using iconv on systems where ICU is not available
+  widestringmanager.Ansi2UnicodeMoveProc(A, CodePage, tmp, AL);
+  result := length(tmp);
+  if result > WL then
+    result := WL;
+  MoveFast(pointer(tmp)^, W^, result * 2);
+end;
+
+function Unicode_AnsiToWide(A: PAnsiChar; W: PWideChar;
+  LA, LW, CodePage: PtrInt): integer;
+var
+  cnv: pointer;
+  err: SizeInt;
+begin
+  if CodePage = CP_UTF8 then
+    exit(Utf8ToUnicode(W, A, LA));
+  cnv := icu.ucnv(CodePage);
+  if cnv = nil then
+    exit(AnsiToWideRTL(CodePage, A, W, LA, LW)); // fallback to cwstring/iconv
+  err := 0;
+  result := icu.ucnv_toUChars(cnv, W, LW, A, LA, err);
+  if result < 0 then
+    result := 0;
+  icu.ucnv_close(cnv);
+end;
+
+function WideToAnsiRTL(CodePage: cardinal; W: PWideChar; A: PAnsiChar;
+  WL, AL: PtrInt): PtrInt;
+var
+  tmp: RawByteString;
+begin
+  // cwstring as fallback, using iconv on systems where ICU is not available
+  widestringmanager.Unicode2AnsiMoveProc(W, tmp, CodePage, WL);
+  result := length(tmp);
+  if result > AL then
+    result := AL;
+  MoveFast(pointer(tmp)^, A^, result);
+end;
+
+function Unicode_WideToAnsi(W: PWideChar; A: PAnsiChar;
+  LW, LA, CodePage: PtrInt): integer;
+var
+  cnv: pointer;
+  err: SizeInt;
+begin
+  if CodePage = CP_UTF8 then
+    exit(UnicodeToUtf8(A, W, LW));
+  cnv := icu.ucnv(CodePage);
+  if cnv = nil then
+    exit(WideToAnsiRTL(CodePage, W, A, LW, LA)); // fallback to cwstring/iconv
+  err := 0;
+  result := icu.ucnv_fromUChars(cnv, A, LA, W, LW, err);
+  if result < 0 then
+    result := 0;
+  icu.ucnv_close(cnv);
+end;
+
+function Unicode_InPlaceUpper(W: PWideChar; WLen: integer): integer;
+var
+  err, i: SizeInt;
+begin
+  if icu.IsAvailable then
+  begin
+    // call the accurate ICU library
+    err := 0;
+    result := icu.u_strToUpper(W, WLen, W, WLen, nil, err);
+  end
+  else
+  begin
+    // simple fallback code only handling 'a'..'z' -> 'A'..'Z' basic conversion
+    for i := 0 to WLen - 1 do
+      if ord(W[i]) in [ord('a')..ord('z')] then
+        dec(W[i], 32);
+    result := WLen;
+  end;
+end;
+
+function Unicode_InPlaceLower(W: PWideChar; WLen: integer): integer;
+var
+  err, i: SizeInt;
+begin
+  if icu.IsAvailable then
+  begin
+    // call the accurate ICU library
+    err := 0;
+    result := icu.u_strToLower(W, WLen, W, WLen, nil, err);
+  end
+  else
+  begin
+    // simple fallback code only handling 'A'..'Z' -> 'a'..'z' basic conversion
+    for i := 0 to WLen - 1 do
+      if ord(W[i]) in [ord('A')..ord('Z')] then
+        inc(W[i], 32);
+    result := WLen;
+  end;
+end;
+
+function GetDesktopWindow: PtrInt;
+begin
+  result := 0; // fixed result on a window-abstracted system
+end;
+
+
+{$ifdef NODIRECTTHREADMANAGER} // try to stabilize MacOS/BSD pthreads API calls
+
+function GetCurrentThreadId: TThreadID;
+begin
+  result := system.GetCurrentThreadID();
+end;
+
+function TryEnterCriticalSection(var cs: TRTLCriticalSection): integer;
+begin
+  result := system.TryEnterCriticalSection(cs);
+end;
+
+procedure EnterCriticalSection(var cs: TRTLCriticalSection);
+begin
+  system.EnterCriticalSection(cs);
+end;
+
+procedure LeaveCriticalSection(var cs: TRTLCriticalSection);
+begin
+  system.LeaveCriticalSection(cs);
+end;
+
+{$endif NODIRECTTHREADMANAGER}
+
+const
+  HoursPerDay = 24;
+  MinsPerHour = 60;
+  SecsPerMin  = 60;
+  MinsPerDay  = HoursPerDay * MinsPerHour;
+  SecsPerDay  = MinsPerDay  * SecsPerMin;
+  SecsPerHour = MinsPerHour * SecsPerMin;
+  MilliSecsPerSec = 1000;
+  MicroSecsPerSec = 1000000;
+  MicroSecsPerMilliSec = 1000;
+  NanoSecsPerMicroSec  = 1000;
+  NanoSecsPerMilliSec  = 1000000;
+  NanoSecsPerSec       = 1000000000;
+
+const
+  // Date Translation - see http://en.wikipedia.org/wiki/Julian_day
+  D0 = 1461;
+  D1 = 146097;
+  D2 = 1721119;
+  C1970 = 2440588;
+
+procedure JulianToGregorian(JulianDN: PtrUInt; out result: TSystemTime);
+  {$ifdef HASINLINE}inline;{$endif}
+var
+  YYear, XYear, Temp, TempMonth: PtrUInt;
+begin
+  Temp := ((JulianDN - D2) * 4) - 1;
+  JulianDN := Temp div D1;
+  XYear := (Temp - (JulianDN * D1)) or 3;
+  YYear := XYear div D0;
+  Temp := (((XYear - (YYear * D0) + 4) shr 2) * 5) - 3;
+  TempMonth := Temp div 153;
+  result.Day := ((Temp - (TempMonth * 153)) + 5) div 5;
+  if TempMonth >= 10 then
+  begin
+    inc(YYear);
+    dec(TempMonth, 12 - 3);
+  end
+  else
+    inc(TempMonth, 3);
+  result.Month := TempMonth;
+  result.Year := YYear + (JulianDN * 100);
+  // initialize fake dayOfWeek - as used by FromGlobalTime()
+  result.DayOfWeek := 0;
+end;
+
+procedure EpochToSystemTime(epoch: PtrUInt; out result: TSystemTime);
+var
+  t: PtrUInt;
+begin
+  t := epoch div SecsPerDay;
+  JulianToGregorian(t + C1970, result);
+  dec(epoch, t * SecsPerDay);
+  t := epoch div SecsPerHour;
+  result.Hour := t;
+  dec(epoch, t * SecsPerHour);
+  t := epoch div SecsPerMin;
+  result.Minute := t;
+  result.Second := epoch - t * SecsPerMin;
+end;
+
+{$ifdef OSDARWIN} // OSX has no clock_gettime() API
+
+type
+  TTimebaseInfoData = record
+    Numer: cardinal;
+    Denom: cardinal;
+  end;
+
+function mach_absolute_time: UInt64;
+  cdecl external clib name 'mach_absolute_time';
+
+function mach_continuous_time: UInt64;
+  cdecl external clib name 'mach_continuous_time';
+
+function mach_timebase_info(var TimebaseInfoData: TTimebaseInfoData): integer;
+  cdecl external clib name 'mach_timebase_info';
+
+var
+  mach_timeinfo: TTimebaseInfoData;
+  mach_timecoeff: double;
+  mach_timenanosecond: boolean; // very likely to be TRUE on Intel CPUs
+
+procedure machtimetonanosec(var Value: Int64); inline;
+begin
+  if not mach_timenanosecond then
+    if mach_timeinfo.Denom = 1 then
+      // integer resolution is enough
+      Value := Value * mach_timeinfo.Numer
+    else
+      // use floating point to avoid potential overflow
+      Value := round(Value * mach_timecoeff);
+end;
+
+procedure QueryPerformanceMicroSeconds(out Value: Int64);
+begin
+  Value := mach_absolute_time;
+  machtimetonanosec(Value);
+  Value := Value div NanoSecsPerMicroSec; // ns to us
+end;
+
+function GetTickCount64: Int64;
+begin
+  result := mach_absolute_time;
+  machtimetonanosec(result);
+  result := result div NanoSecsPerMilliSec; // ns to ms
+end;
+
+function GetUptimeSec: cardinal;
+var
+  v: Int64;
+begin
+  v := mach_continuous_time;
+  machtimetonanosec(v);
+  result := v div NanoSecsPerSec; // ns to s
+end;
+
+function UnixTimeUtc: TUnixTime;
+var
+  tz: timeval;
+begin
+  fpgettimeofday(@tz, nil); // from libc
+  result := tz.tv_sec;
+end;
+
+function UnixMSTimeUtc: TUnixMSTime;
+var
+  tz: timeval;
+begin
+  fpgettimeofday(@tz, nil);
+  result := (Int64(tz.tv_sec) * MilliSecsPerSec) +
+            tz.tv_usec div MicroSecsPerMilliSec; // in milliseconds
+end;
+
+procedure GetSystemTime(out result: TSystemTime);
+var
+  tz: timeval;
+begin
+  fpgettimeofday(@tz, nil);
+  EpochToSystemTime(tz.tv_sec, result);
+  result.MilliSecond := tz.tv_usec div MicroSecsPerMilliSec;
+end;
+
+procedure GetLocalTime(out result: TSystemTime);
+var
+  tz: timeval;
+begin
+  fpgettimeofday(@tz, nil);
+  // + unixutil.TZSeconds = UTC to local time conversion
+  EpochToSystemTime(tz.tv_sec + TZSeconds, result);
+  result.MilliSecond := tz.tv_usec div MicroSecsPerMilliSec;
+end;
+
+{$else}
+
+
+{$ifdef OSBSD}
+
+const
+  {$ifdef OSFREEBSD}
+  // see https://github.com/freebsd/freebsd/blob/master/sys/sys/time.h
+  CLOCK_REALTIME  = 0;
+  CLOCK_MONOTONIC = 4;
+  CLOCK_BOOTTIME  = 5;
+  CLOCK_REALTIME_COARSE  = 10; // named CLOCK_REALTIME_FAST in FreeBSD 8.1+
+  CLOCK_MONOTONIC_COARSE = 12;
+  {$else}
+  // see https://github.com/openbsd/src/blob/master/sys/sys/_time.h#L63
+  CLOCK_REALTIME  = 0;
+  CLOCK_MONOTONIC = 3;
+  CLOCK_BOOTTIME  = 6;
+  CLOCK_REALTIME_COARSE  = CLOCK_REALTIME; // no FAST/COARSE version
+  CLOCK_MONOTONIC_COARSE = CLOCK_MONOTONIC;
+  {$endif OSFREEBSD}
+
+function clock_gettime(clk_id: cardinal; tp: ptimespec): integer;
+  cdecl external clib name 'clock_gettime';
+
+function clock_getres(clk_id: cardinal; tp: ptimespec): integer;
+  cdecl external clib name 'clock_getres';
+
+{$else}
+
+const
+  CLOCK_REALTIME         = 0;
+  CLOCK_MONOTONIC        = 1;
+  CLOCK_REALTIME_COARSE  = 5; // see http://lwn.net/Articles/347811
+  CLOCK_MONOTONIC_COARSE = 6;
+  CLOCK_BOOTTIME         = 7; // includes asleep time (2.6.39+)
+
+// libc's clock_gettime function uses vDSO (avoid syscall) while FPC by default
+// is compiled without FPC_USE_LIBC defined and do a syscall each time
+//   GetTickCount64 fpc    2 494 563 op/sec
+//   GetTickCount64 libc 119 919 893 op/sec
+function clock_gettime(clk_id: clockid_t; tp: ptimespec): cint;
+  cdecl external clib name 'clock_gettime'; // LIBC_SUFFIX fails on CentOS 7
+
+function gettimeofday(tp: ptimeval; tzp: ptimezone): cint;
+  cdecl external clib name 'gettimeofday' + LIBC_SUFFIX;
+
+{$endif OSBSD}
+
+var
+  // contains CLOCK_REALTIME_COARSE since kernel 2.6.32
+  CLOCK_REALTIME_FAST: integer = CLOCK_REALTIME;
+
+  // contains CLOCK_MONOTONIC_COARSE since kernel 2.6.32
+  CLOCK_MONOTONIC_FAST: integer = CLOCK_MONOTONIC;
+
+  // contains CLOCK_MONOTONIC_RAW since kernel 2.6.28
+  // - so that QueryPerformanceMicroSeconds() is not subject to NTP adjustments
+  CLOCK_MONOTONIC_HIRES: integer = CLOCK_MONOTONIC;
+
+  // contains CLOCK_BOOTTIME since kernel 2.6.39
+  CLOCK_UPTIME: integer = CLOCK_MONOTONIC;
+
+function UnixMSTimeUtc: TUnixMSTime;
+var
+  r: timespec;
+begin
+  clock_gettime(CLOCK_REALTIME_FAST, @r); // likely = CLOCK_REALTIME_COARSE
+  // convert from nanoseconds into milliseconds
+  result := QWord(PtrUInt(r.tv_nsec) div PtrUInt(NanoSecsPerMilliSec)) +
+            QWord(r.tv_sec) * MilliSecsPerSec;
+end;
+
+function UnixTimeUtc: TUnixTime;
+var
+  r: timespec;
+begin
+  clock_gettime(CLOCK_REALTIME_FAST, @r);
+  result := r.tv_sec;
+end;
+
+procedure QueryPerformanceMicroSeconds(out Value: Int64);
+var
+  r : TTimeSpec;
+begin
+  clock_gettime(CLOCK_MONOTONIC_HIRES, @r);
+  // convert from nanoseconds into microseconds
+  Value := QWord(PtrUInt(r.tv_nsec) div PtrUInt(NanoSecsPerMicroSec)) +
+           QWord(r.tv_sec) * MicroSecsPerSec;
+end;
+
+procedure GetSystemTime(out result: TSystemTime);
+var
+  r: timespec;
+begin
+  // faster than fpgettimeofday() which makes a syscall and don't use vDSO
+  clock_gettime(CLOCK_REALTIME_FAST, @r);
+  EpochToSystemTime(r.tv_sec, result);
+  result.MilliSecond := PtrUInt(r.tv_nsec) div PtrUInt(NanoSecsPerMilliSec);
+end;
+
+// c_timezone: longint external 'c' name 'timezone'; is broken and returns 0
+
+procedure GetLocalTime(out result: TSystemTime);
+var
+  r: timespec;
+begin
+  // faster than fpgettimeofday() which makes a syscall and don't use vDSO
+  clock_gettime(CLOCK_REALTIME_FAST, @r);
+  // + unixutil.TZSeconds = UTC to local time conversion
+  EpochToSystemTime(r.tv_sec + TZSeconds, result);
+  result.MilliSecond := PtrUInt(r.tv_nsec) div PtrUInt(NanoSecsPerMilliSec);
+end;
+
+function GetTickCount64: Int64;
+var
+  tp: timespec;
+begin
+  clock_gettime(CLOCK_MONOTONIC_FAST, @tp); // likely = CLOCK_MONOTONIC_COARSE
+  // convert from nanoseconds into milliseconds
+  result := QWord(PtrUInt(tp.tv_nsec) div PtrUInt(NanoSecsPerMilliSec)) +
+            QWord(tp.tv_sec) * MilliSecsPerSec;
+end;
+
+function GetUptimeSec: cardinal;
+var
+  tp: timespec;
+begin
+  tp.tv_sec := 0;
+  clock_gettime(CLOCK_UPTIME, @tp);
+  // convert from nanoseconds into milliseconds
+  result := tp.tv_sec;
+end;
+
+{$endif OSDARWIN}
+
+function SetSystemTime(utctime: TUnixTime): boolean;
+var
+  u: timeval;
+begin
+  u.tv_sec := utctime;
+  u.tv_usec := 0;
+  result := fpsettimeofday(@u, nil) = 0;
+end;
+
+function UnixMSTimeUtcFast: TUnixMSTime;
+begin
+  result := UnixMSTimeUtc;
+end;
+
+{$undef OSPTHREADS}
+{$undef HAS_PTHREADSETNAMENP}
+{$undef HAS_PTHREADSETAFFINITY}
+
+{$ifdef OSPTHREADSLIB}
+  {$define OSPTHREADS}
+var
+  {$ifdef OSLINUX}
+  // pthread_setname_np for Linux https://stackoverflow.com/a/7989973/458259
+  {$define HAS_PTHREADSETNAMENP}
+  pthread_setname_np: function(thread: pointer; name: PAnsiChar): integer; cdecl;
+  // pthread_setaffinity_np has been tested on Linux only
+  {$define HAS_PTHREADSETAFFINITY}
+  pthread_setaffinity_np: function(thread: pointer;
+    cpusetsize: SizeUInt; cpuset: pointer): integer; cdecl;
+  {$endif OSLINUX}
+  pthread_cancel: function(thread: pointer): integer; cdecl;
+  pthread_mutex_init: function(mutex, attr: pointer): integer; cdecl;
+  pthread_mutex_destroy: function(mutex: pointer): integer; cdecl;
+{$endif OSPTHREADSLIB}
+
+{$ifdef OSPTHREADSSTATIC}
+  // note: pthread_setname_np() has no consistent API across POSIX systems
+  {$define OSPTHREADS}
+
+{$ifdef OSDARWIN}
+// we specify link to clib='c' as in rtl/darwin/pthread.inc
+function pthread_cancel(thread: pointer): integer;
+  cdecl; external clib name 'pthread_cancel';
+function pthread_mutex_init(mutex, attr: pointer): integer;
+  cdecl; external clib name 'pthread_mutex_init';
+function pthread_mutex_destroy(mutex: pointer): integer;
+  cdecl; external clib name 'pthread_mutex_destroy';
+function pthread_mutex_lock(mutex: pointer): integer;
+  cdecl; external clib name 'pthread_mutex_lock';
+function pthread_mutex_trylock(mutex: pointer): integer;
+  cdecl; external clib name 'pthread_mutex_trylock';
+function pthread_mutex_unlock(mutex: pointer): integer;
+  cdecl; external clib name 'pthread_mutex_unlock';
+{$else}
+// just "external" without clib='c' as in rtl/*bsd/pthread.inc
+function pthread_cancel(thread: pointer): integer;           cdecl; external;
+function pthread_mutex_init(mutex, attr: pointer): integer;  cdecl; external;
+function pthread_mutex_destroy(mutex: pointer): integer;     cdecl; external;
+function pthread_mutex_lock(mutex: pointer): integer;        cdecl; external;
+function pthread_mutex_trylock(mutex: pointer): integer;     cdecl; external;
+function pthread_mutex_unlock(mutex: pointer): integer;      cdecl; external;
+{$endif OSDARWIN}
+{$endif OSPTHREADSSTATIC}
+
+
+function IsInitializedCriticalSection(var cs: TRTLCriticalSection): boolean;
+begin
+  {$ifdef OSLINUX}
+  result := cs.__m_kind <> 0;
+  {$else}
+  result := not IsZero(@cs, SizeOf(cs));
+  {$endif OSLINUX}
+end;
+
+{$ifdef OSPTHREADS}
+
+{ TOSLightLock }
+
+procedure TOSLightLock.Init;
+begin
+  FillCharFast(self, SizeOf(self), 0); // may be bigger than pthread struct
+  {$ifdef OSPTHREADSLIB}
+  if not Assigned(pthread_mutex_init) then
+    EOSException.Create('TOSLightLock.Init: no pthread_mutex_init')
+  else // no recursive attribute -> fast mutex
+  {$endif OSPTHREADSLIB}
+    pthread_mutex_init(@fMutex, nil);
+end;
+
+procedure TOSLightLock.Done;
+begin
+  if IsInitializedCriticalSection(fMutex) then
+    pthread_mutex_destroy(@fMutex);
+end;
+
+procedure TOSLightLock.Lock;
+begin
+  pthread_mutex_lock(@fMutex);
+end;
+
+function TOSLightLock.TryLock: boolean;
+begin
+  result := pthread_mutex_trylock(@fMutex) = 0;
+end;
+
+procedure TOSLightLock.UnLock;
+begin
+  pthread_mutex_unlock(@fMutex);
+end;
+
+{$else} // fallback to plain recursive TRTLCriticalSection
+
+{ TOSLightLock }
+
+procedure TOSLightLock.Init;
+begin
+  InitCriticalSection(fMutex);
+end;
+
+procedure TOSLightLock.Done;
+begin
+  DeleteCriticalSectionIfNeeded(fMutex);
+end;
+
+procedure TOSLightLock.Lock;
+begin
+  EnterCriticalSection(fMutex);
+end;
+
+function TOSLightLock.TryLock: boolean;
+begin
+  result := TryEnterCriticalSection(fMutex) <> 0;
+end;
+
+procedure TOSLightLock.UnLock;
+begin
+  LeaveCriticalSection(fMutex);
+end;
+
+{$endif OSPTHREADS}
+
+
+procedure SetUnixThreadName(ThreadID: TThreadID; const Name: RawByteString);
+var
+  // truncated to 16 non space chars (including #0)
+  {%H-}trunc: array[0..15] of AnsiChar;
+  i, L, c4: integer;
+begin
+  if Name = '' then
+    exit;
+  L := 0; // trim unrelevant spaces and prefixes when filling the 16 chars
+  i := 1;
+  if Name[1] = 'T' then
+  begin
+    c4 := PCardinal(Name)^ and $dfdfdfdf;
+    if (c4 = ord('T') + ord('S') shl 8 + ord('Q') shl 16 + ord('L') shl 24) or
+       (c4 = ord('T') + ord('O') shl 8 + ord('R') shl 16 + ord('M') shl 24) then
+      i := 5
+    else
+      i := 2;
+  end;
+  while i <= length(Name) do
+  begin
+    if Name[i] > ' ' then
+    begin
+      trunc[L] := Name[i];
+      inc(L);
+      if L = high(trunc) then
+        break;
+    end;
+    inc(i);
+  end;
+  if L = 0 then
+    exit;
+  trunc[L] := #0;
+  {$ifdef HAS_PTHREADSETNAMENP} // see https://stackoverflow.com/a/7989973
+  {$ifdef OSPTHREADSLIB}
+  if Assigned(pthread_setname_np) then
+    try
+      pthread_setname_np(pointer(ThreadID), @trunc[0]);
+    except
+      // ignore any exception (pthread confusion with its static version?)
+      @pthread_setname_np := nil; // don't continue that way
+    end;
+  {$endif OSPTHREADSLIB}
+  {$endif HAS_PTHREADSETNAMENP}
+end;
+
+procedure RawSetThreadName(ThreadID: TThreadID; const Name: RawUtf8);
+begin
+  if ThreadID <> MainThreadID then // don't change the main process name
+    SetUnixThreadName(ThreadID, Name); // call pthread_setname_np()
+end;
+
+function RawKillThread(Thread: TThread): boolean;
+begin
+  result := false;
+  {$ifdef OSPTHREADSLIB}
+  if Assigned(pthread_cancel) then
+    try
+      result := pthread_cancel(pointer(Thread.ThreadID)) = 0;
+    except
+      // ignore any exception (pthread confusion with its static version?)
+      @pthread_cancel := nil; // don't continue that way
+    end;
+  {$endif OSPTHREADSLIB}
+  {$ifdef OSPTHREADSSTATIC}
+  result := pthread_cancel(pointer(Thread.ThreadID)) = 0;
+  {$endif OSPTHREADSSTATIC}
+end;
+
+procedure ResetCpuSet(out CpuSet: TCpuSet);
+begin
+  FillCharFast(CpuSet, SizeOf(CpuSet), 0);
+end;
+
+function SetThreadMaskAffinity(Thread: TThread; const Mask: TCpuSet): boolean;
+begin
+  result := false;
+  {$ifdef HAS_PTHREADSETAFFINITY}
+  {$ifdef OSPTHREADSLIB}
+  if (Thread <> nil) and
+     Assigned(pthread_setaffinity_np) then
+    try
+      result := pthread_setaffinity_np(
+        pointer(Thread.ThreadID), SizeOf(Mask), @Mask) = 0;
+    except
+      // ignore any exception (pthread confusion with its static version?)
+      @pthread_setaffinity_np := nil; // don't continue that way
+    end;
+  {$endif OSPTHREADSLIB}
+  {$endif HAS_PTHREADSETAFFINITY}
+end;
+
+{$ifdef HAS_PTHREADSETAFFINITY}
+function sched_getaffinity(pid: integer;
+  cpusetsize: SizeUInt; cpuset: pointer): integer;
+    cdecl external clib name 'sched_getaffinity';
+{$endif HAS_PTHREADSETAFFINITY}
+
+function GetMaskAffinity(out CpuSet: TCpuSet): boolean;
+begin
+  {$ifdef HAS_PTHREADSETAFFINITY}
+  result := sched_getaffinity(0, SizeOf(CpuSet), @CpuSet) = 0;
+  {$else}
+  result := false; // unsupported by now
+  {$endif HAS_PTHREADSETAFFINITY}
+end;
+
+
+{$ifndef NOEXCEPTIONINTERCEPT}
+
+function TSynLogExceptionContext.AdditionalInfo(
+  out ExceptionNames: TPUtf8CharDynArray): cardinal;
+begin
+  result := 0; // Windows/CLR specific by now
+end;
+
+var
+  _RawLogException: TOnRawLogException;
+
+// FPC: intercept via the RaiseProc global variable
+{$define WITH_RAISEPROC}
+// RaiseProc redirection is implemented in main mormot.core.os.pas
+
+{$endif NOEXCEPTIONINTERCEPT}
+
+function GetFileNameFromUrl(const Uri: string): TFileName;
+begin
+  result := ''; // no such native API on POSIX
+end;
+
+const
+  faInvalidFile   = faDirectory;
+  faDirectoryMask = faDirectory;
+
+function FileDateToDateTime(const FileDate: TFileAge): TDateTime;
+begin
+  if FileDate <= 0 then
+    result := 0
+  else
+    // + unixutil.TZSeconds = UTC to local time conversion
+    result := Int64(FileDate + TZSeconds) / Int64(SecsPerDay) + Int64(UnixDelta);
+end;
+
+function FileAgeToDateTime(const FileName: TFileName): TDateTime;
+begin
+  // faster to use POSIX time than RTL FileDateToDateTime(FileAge())
+  result := FileDateToDateTime(FileAgeToUnixTimeUtc(FileName)); // UTC to local
+end;
+
+function FileAgeToUnixTimeUtc(const FileName: TFileName; AllowDir: boolean): TUnixTime;
+var
+  st: TStat;
+begin
+  result := 0;
+  if (FileName <> '') and
+     (fpStat(pointer(FileName), st) = 0) and
+     (AllowDir or
+      (not FpS_ISDIR(st.st_mode))) then
+    result := st.st_mtime; // as TUnixTime seconds, with no local conversion
+end;
+
+function FileHandleToUnixTimeUtc(F: THandle): TUnixTime;
+var
+  st: TStat;
+begin
+  result := 0;
+  if ValidHandle(F) and
+     (FpFStat(F, st) = 0) then
+    result := st.st_mtime;
+end;
+
+function FileSetDateFromUnixUtc(const Dest: TFileName; Time: TUnixTime): boolean;
+var
+  t: TUtimBuf;
+begin
+  result := false;
+  if (Dest = '') or
+     (Time = 0) then
+    exit;
+  t.actime := Time;
+  t.modtime := Time;
+  result := FpUtime(pointer(Dest), @t) = 0; // direct syscall
+end;
+
+function FileSetDateFrom(const Dest: TFileName; SourceHandle: THandle): boolean;
+begin
+  result := FileSetDateFromUnixUtc(Dest, FileHandleToUnixTimeUtc(SourceHandle));
+end;
+
+function FileSetDateFrom(const Dest, Source: TFileName): boolean;
+begin
+  result := FileSetDateFromUnixUtc(Dest, FileAgeToUnixTimeUtc(Source));
+end;
+
+function FileSetDateFromWindowsTime(const Dest: TFileName;
+  WinTime: integer): boolean;
+var
+  dt: TDateTime;
+begin
+  dt := WindowsFileTimeToDateTime(WinTime);
+  result := (Dest <> '') and
+            (dt <> 0) and
+            (FileSetDate(Dest, DateTimeToFileDate(dt)) = 0); // with LocalToEpoch()
+end;
+
+function SearchRecToWindowsTime(const F: TSearchRec): integer;
+begin
+  result := DateTimeToWindowsFileTime(FileDateToDateTime(F.Time));
+end;
+
+function SearchRecToUnixTimeUtc(const F: TSearchRec): TUnixTime;
+begin
+  result := F.Time; // raw POSIX FileDate is already in UTC seconds
+end;
+
+function FileAgeToWindowsTime(const FileName: TFileName): integer;
+begin
+  result := DateTimeToWindowsFileTime(FileAgeToDateTime(FileName));
+end;
+
+function FileIsWritable(const FileName: TFileName): boolean;
+begin
+  result := (FileName <> '') and
+            (fpaccess(pointer(FileName), W_OK) = 0);
+end;
+
+procedure FileSetHidden(const FileName: TFileName; ReadOnly: boolean);
+begin
+  if FileName <> '' then
+    if ReadOnly then
+      fpchmod(pointer(FileName), S_IRUSR)
+    else
+      fpchmod(pointer(FileName), S_IRUSR or S_IWUSR);
+end;
+
+procedure FileSetSticky(const FileName: TFileName);
+begin
+  fpchmod(FileName, S_IRUSR or S_IWUSR or S_IRGRP or S_IROTH or S_ISVTX);
+end;
+
+function FileSize(const FileName: TFileName): Int64;
+var
+  st: TStat;
+begin
+  if (FileName = '') or
+     (fpStat(pointer(FileName), st) <> 0) or
+     FpS_ISDIR(st.st_mode) then
+    result := 0
+  else
+    result := st.st_size;
+end;
+
+function FileExists(const FileName: TFileName): boolean;
+var
+  st: TStat;
+begin
+  result := (FileName <> '') and
+            (fpStat(pointer(FileName), st) = 0) and
+            not FpS_ISDIR(st.st_mode);
+end;
+
+function FileCreate(const aFileName: TFileName; aMode, aRights: integer): THandle;
+begin
+  if aFileName = '' then
+    result := 0
+  else if (aMode = 0) and
+          (aRights = 0) then
+    result := sysutils.FileCreate(aFileName) // direct call of the FPC RTL
+  else
+  begin
+    if aRights = 0 then // use 644 / '-rw-r-r--' default POSIX file attributes
+      aRights := S_IRUSR or S_IWUSR or S_IRGRP or S_IROTH;
+    result := sysutils.FileCreate(aFileName, aMode, aRights);
+  end;
+end;
+
+procedure StatTimeMS(const st: TStat; out time: TUnixMSTime); inline;
+begin
+  time := QWord(st.st_mtime) * MilliSecsPerSec + // no local conversion needed
+          // include milliseconds information
+          {$ifdef OSLINUXANDROID}
+          st.st_mtime_nsec div NanoSecsPerMilliSec;
+          {$else}
+          st.st_mtimensec div NanoSecsPerMilliSec;
+          {$endif OSLINUXANDROID}
+end;
+
+function FileInfoByName(const FileName: TFileName; out FileSize: Int64;
+  out FileTimestampUtc: TUnixMSTime): boolean;
+var
+  st: TStat;
+begin
+  result := fpStat(pointer(FileName), st) = 0;
+  if not result then
+    exit;
+  FileSize := st.st_size;
+  StatTimeMS(st, FileTimestampUtc);
+end;
+
+function FileSize(F: THandle): Int64;
+var
+  st: TStat;
+begin
+  if fpFstat(F, st) <> 0 then
+    result := 0
+  else
+    result := st.st_size;
+end;
+
+function FileSeek64(Handle: THandle; const Offset: Int64; Origin: cardinal): Int64;
+begin
+  result := FPLSeek(Handle, Offset, Origin);
+end;
+
+function FileInfoByHandle(aFileHandle: THandle; FileId, FileSize: PInt64;
+  LastWriteAccess, FileCreateDateTime: PUnixMSTime): boolean;
+var
+  mtime, atime, ctime: Int64;
+  lp: TStat;
+  r: integer;
+begin
+  r := FpFStat(aFileHandle, lp);
+  result := r >= 0;
+  if not result then
+    exit;
+  if FileId <> nil then
+    FileId^ := lp.st_ino;
+  if FileSize <> nil then
+    FileSize^ := lp.st_size;
+  if (LastWriteAccess = nil) and
+     (FileCreateDateTime = nil) then
+    exit;
+  StatTimeMS(lp, mtime);
+  if LastWriteAccess <> nil then
+    LastWriteAccess^ := mtime;
+  if FileCreateDateTime = nil then
+    exit;
+  // some FS don't populate all fields, so we use what we actually got
+  {$ifdef OSOPENBSD}
+  if (lp.st_birthtime <> 0) and
+     (lp.st_birthtime < lp.st_ctime) then
+    lp.st_ctime := lp.st_birthtime;
+  {$endif OSOPENBSD}
+  // ignore nanoseconds/Milliseconds for FileCreateDateTime
+  ctime := Int64(lp.st_ctime) * MilliSecsPerSec;
+  atime := Int64(lp.st_atime) * MilliSecsPerSec;
+  if mtime <> 0 then
+    if (ctime = 0) or
+       (ctime > mtime) then
+      ctime := mtime;
+  if atime <> 0 then
+    if (ctime = 0) or
+       (ctime > atime) then
+      ctime := atime;
+  FileCreateDateTime^ := ctime;
+end;
+
+function FileIsExecutable(const FileName: TFileName): boolean;
+var
+  st: TStat;
+begin
+  result := (fpStat(pointer(FileName), st) = 0) and
+            (st.st_mode and (S_IXUSR or S_IXGRP or S_IXOTH) <> 0) and
+            not FpS_ISDIR(st.st_mode);
+end;
+
+function GetExecutableName(aAddress: pointer): TFileName;
+var
+  dlinfo: dl_info;
+begin
+  FillCharFast(dlinfo, sizeof(dlinfo), 0);
+  dladdr(aAddress, @dlinfo);
+  result := ExpandFileName(string(dlinfo.dli_fname));
+end;
+
+function CopyFile(const Source, Target: TFileName;
+  FailIfExists: boolean): boolean;
+var
+  src, dst: THandleStream;
+begin
+  result := false;
+  if FileExists(Target) then
+    if FailIfExists then
+      exit
+    else
+      DeleteFile(Target);
+  try
+    src := TFileStreamEx.Create(Source, fmOpenReadShared);
+    try
+      dst := TFileStreamEx.Create(Target, fmCreate);
+      try
+        StreamCopyUntilEnd(src, dst); // faster than dst.CopyFrom()
+      finally
+        dst.Free;
+      end;
+      FileSetDateFrom(Target, src.Handle);
+    finally
+      src.Free;
+    end;
+    result := true;
+  except
+    result := false;
+  end;
+end;
+
+function ValidHandle(Handle: THandle): boolean;
+begin
+  result := PtrInt(Handle) >= 0; // 0=StdIn is a valid POSIX file descriptor
+end;
+
+function WaitReadPending(fd, timeout: integer): boolean;
+var
+  p: TPollFD; // select() limits process to 1024 sockets in POSIX -> use poll()
+  // https://moythreads.com/wordpress/2009/12/22/select-system-call-limitation
+begin
+  p.fd := fd;
+  p.events := POLLIN or POLLPRI;
+  p.revents := 0;
+  result := FpPoll(@p, 1, timeout) > 0;
+end;
+
+{$I-}
+procedure DisplayFatalError(const title, msg: RawUtf8);
+var
+  err: ^Text;
+begin
+  err := @StdErr;
+  if title <> '' then
+    writeln(err^, Executable.ProgramName, ': ', title);
+  writeln(err^, Executable.ProgramName, ': ', msg);
+  ioresult;
+end;
+{$I+}
+
+function FileOpenSequentialRead(const FileName: TFileName): integer;
+begin
+  // SysUtils.FileOpen = fpOpen + fpFlock
+  result := fpOpen(pointer(FileName), O_RDONLY); // no fpFlock() call
+end;
+
+function FileIsReadable(const aFileName: TFileName): boolean;
+var
+  fd: integer;
+begin
+  fd := fpOpen(pointer(aFileName), O_RDONLY); // no fpFlock() call
+  result := ValidHandle(fd);
+  if result then
+    FpClose(fd);
+end;
+
+procedure SetEndOfFile(F: THandle);
+begin
+  FpFtruncate(F, FPLseek(F, 0, SEEK_CUR));
+end;
+
+procedure FlushFileBuffers(F: THandle);
+begin
+  FpFsync(F);
+end;
+
+function GetLastError: integer;
+begin
+  result := fpgeterrno;
+end;
+
+function IsSharedViolation(ErrorCode: integer): boolean;
+begin
+  if ErrorCode = 0 then
+    ErrorCode := fpgeterrno;
+  result := ErrorCode = ESysEACCES;
+end;
+
+procedure SetLastError(error: integer);
+begin
+  fpseterrno(error);
+end;
+
+function GetErrorText(error: integer): RawUtf8;
+begin
+  result := StrError(error); // from FPC RTL: using a OS-specific array of const
+end;
+
+function TMemoryMap.DoMap(aCustomOffset: Int64): boolean;
+begin
+  if aCustomOffset <> 0 then
+    if (aCustomOffset and (SystemInfo.dwPageSize - 1)) <> 0 then
+      raise EOSException.CreateFmt(
+        'DoMap(aCustomOffset=%d) incompatible with dwPageSize=%d',
+        [aCustomOffset, SystemInfo.dwPageSize]);
+  fBuf := fpmmap(nil, fBufSize, PROT_READ, MAP_SHARED, fFile, aCustomOffset);
+  if fBuf = MAP_FAILED then
+  begin
+    fBuf := nil;
+    result := false;
+  end
+  else
+    result := true;
+end;
+
+procedure TMemoryMap.DoUnMap;
+begin
+  if (fBuf <> nil) and
+     (fBufSize > 0) and
+     (fFile <> 0) then
+    fpmunmap(fBuf, fBufSize);
+end;
+
+procedure SleepHiRes(ms: cardinal);
+var
+  timeout: TTimespec;
+  s: cardinal;
+begin
+  if ms = 0 then
+    // handle SleepHiRes(0) special case
+    if SleepHiRes0Yield then
+    begin
+      // warning: reported as buggy by Alan on POSIX, and despitable by Linus
+      // - from our testing, it gives worse performance than fpnanosleep()
+      ThreadSwitch; // call e.g. POSIX libc's sched_yield API
+      exit;
+    end
+    else
+    begin
+      timeout.tv_sec := 0;
+      timeout.tv_nsec := 10000; // 10us is around timer resolution on modern HW
+    end
+  else
+  begin
+    s := ms div MilliSecsPerSec;
+    timeout.tv_sec := s;
+    timeout.tv_nsec := (ms - s * MilliSecsPerSec) * NanoSecsPerMilliSec;
+  end;
+  fpnanosleep(@timeout, nil)
+  // no retry loop on ESysEINTR (as with regular RTL's Sleep)
+end;
+
+procedure SwitchToThread;
+var
+  timeout: Ttimespec;
+begin
+  // nanosleep() seems better than FPC RTL ThreadSwitch = POSIX libc sched_yield
+  timeout.tv_sec := 0;
+  timeout.tv_nsec := 10; // empirically identified on a recent Linux Kernel
+  // note: nanosleep() adds a few dozen of microsecs for context switching
+  fpnanosleep(@timeout, nil);
+end;
+
+
+{$undef HASEVENTFD}
+{$ifdef OSLINUX}
+  {$ifdef CPUX64}
+    {$define HASEVENTFD}
+  {$endif CPUX64}
+  {$ifdef CPUX86}
+    {.$define HASEVENTFD} // untested
+  {$endif CPUX86}
+  {$ifdef CPUAARCH64}
+    {.$define HASEVENTFD} // untested
+  {$endif CPUAARCH64}
+{$endif OSLINUX}
+
+
+{ TSynEvent }
+
+constructor TSynEvent.Create;
+begin
+  {$ifdef HASEVENTFD}
+  fFD := LinuxEventFD({nonblocking=}false, {semaphore=}false);
+  if fFD = 0 then // fallback to PRTLEvent on oldest kernel
+  {$endif HASEVENTFD}
+    fHandle := RTLEventCreate;
+end;
+
+destructor TSynEvent.Destroy;
+begin
+  {$ifdef HASEVENTFD}
+  if fFD <> 0 then
+  begin
+    LinuxEventFDWrite(fFD, 1); // release the lock or do nothing
+    fpClose(fFD);
+  end
+  else
+  {$endif HASEVENTFD}
+    RTLEventDestroy(fHandle);
+  inherited Destroy;
+end;
+
+procedure TSynEvent.ResetEvent;
+begin
+  {$ifdef HASEVENTFD}
+  if fFD = 0 then // no need to reset the eventfd() handle
+  {$endif HASEVENTFD}
+    RTLEventResetEvent(fHandle);
+end;
+
+procedure TSynEvent.SetEvent;
+begin
+  {$ifdef HASEVENTFD}
+  if fFD <> 0 then
+    LinuxEventFDWrite(fFD, 1)
+  else
+  {$endif HASEVENTFD}
+    RTLEventSetEvent(fHandle);
+end;
+
+procedure TSynEvent.WaitFor(TimeoutMS: integer);
+begin
+  {$ifdef HASEVENTFD}
+  if fFD <> 0 then
+  begin
+    if WaitReadPending(fFD, TimeoutMS) then // = LinuxEventFDWait()
+      LinuxEventFDRead(fFD);
+  end
+  else
+  {$endif HASEVENTFD}
+    RTLEventWaitFor(fHandle, TimeoutMS);
+end;
+
+procedure TSynEvent.WaitForEver;
+begin
+  {$ifdef HASEVENTFD}
+  if fFD <> 0 then
+    LinuxEventFDRead(fFD)
+  else
+  {$endif HASEVENTFD}
+    RTLEventWaitFor(fHandle);
+end;
+
+
+procedure InitializeCriticalSection(var cs : TRTLCriticalSection);
+begin
+  InitCriticalSection(cs);
+end;
+
+procedure DeleteCriticalSection(var cs : TRTLCriticalSection);
+begin
+  DoneCriticalSection(cs);
+end;
+
+function GetFileOpenLimit(hard: boolean): integer;
+var
+  limit: TRLIMIT;
+begin
+  if fpgetrlimit(RLIMIT_NOFILE, @limit) = 0 then
+    if hard then
+      result := limit.rlim_max
+    else
+      result := limit.rlim_cur
+  else
+    result := -1;
+end;
+
+function SetFileOpenLimit(max: integer; hard: boolean): integer;
+var
+  limit: TRLIMIT;
+begin
+  result := -1;
+  if fpgetrlimit(RLIMIT_NOFILE, @limit) <> 0 then
+    exit;
+  if (hard and
+      (integer(limit.rlim_max) = max)) or
+     (not hard and
+      (integer(limit.rlim_cur) = max)) then
+    exit(max); // already to the expected value
+  if hard then
+    limit.rlim_max := max
+  else
+    limit.rlim_cur := max;
+  if fpsetrlimit(RLIMIT_NOFILE, @limit) = 0 then
+    result := GetFileOpenLimit(hard);
+end;
+
+
+{$ifdef OSLINUX} { the systemd API is Linux-specific }
+
+{ TSystemD }
+
+procedure TSystemD.DoLoad;
+var
+  p: PPointer;
+  i, j: PtrInt;
+const
+  NAMES: array[0..5] of PAnsiChar = (
+    'sd_listen_fds',
+    'sd_is_socket_unix',
+    'sd_journal_print',
+    'sd_journal_sendv',
+    'sd_notify',
+    'sd_watchdog_enabled');
+begin
+  GlobalLock;
+  if not tested then
+  begin
+    systemd := dlopen(LIBSYSTEMD_PATH, RTLD_LAZY);
+    if systemd <> nil then
+    begin
+      p := @@listen_fds;
+      for i := 0 to high(NAMES) do
+      begin
+        p^ := dlsym(systemd, NAMES[i]);
+        if p^ = nil then
+        begin
+          p := @@listen_fds;
+          for j := 0 to i do
+          begin
+            p^ := nil;
+            inc(p);
+          end;
+          break;
+        end;
+        inc(p);
+      end;
+    end;
+    tested := true;
+  end;
+  GlobalUnLock;
+end;
+
+function TSystemD.IsAvailable: boolean;
+begin
+  if not tested then
+    DoLoad;
+  result := Assigned(listen_fds);
+end;
+
+function TSystemD.ProcessIsStartedBySystemd: boolean;
+begin
+  result := IsAvailable and
+    // note: for example on Ubuntu 20.04 INVOCATION_ID is always defined
+    // from the other side PPID 1 can be in case we run under docker of started
+    // by init.d so let's verify both
+    (fpgetppid() = 1) and
+    (fpGetenv(ENV_INVOCATION_ID) <> nil);
+end;
+
+procedure TSystemD.Done;
+begin
+  if systemd <> nil then
+  begin
+    dlclose(systemd);
+    systemd := nil;
+  end;
+end;
+
+{$ifdef HASEVENTFD}
+
+const
+  EFD_SEMAPHORE = $00000001;
+  EFD_NONBLOCK  = O_NONBLOCK;
+  EFD_CLOEXEC   = O_CLOEXEC;
+
+  // exists since Kernel 2.6.27
+  {$ifdef CPUX64}
+  syscall_nr_eventfd2 = 290;
+  {$endif CPUX64}
+  {$ifdef CPUX86}
+  syscall_nr_eventfd2 = 328;
+  {$endif CPUX86}
+  {$ifdef CPUAARCH64}
+  syscall_nr_eventfd2 = 356;
+  {$endif CPUAARCH64}
+
+function eventfd(initval, flags: cardinal): integer; inline;
+begin
+  result := do_syscall(syscall_nr_eventfd2, TSysParam(initval), TSysParam(flags));
+end;
+
+function LinuxEventFD(nonblocking, semaphore: boolean): integer;
+var
+  flags: cardinal;
+begin
+  result := 0;
+  if KernelRevision < $02061b then
+    exit; // not available prior to kernel 2.6.27
+  flags := 0;
+  if nonblocking then
+    flags := EFD_NONBLOCK;
+  if semaphore then
+    flags := flags or EFD_SEMAPHORE;
+  result := eventfd(0, flags);
+  if not ValidHandle(result) then
+    result := 0;
+end;
+
+{$else}
+
+function LinuxEventFD(nonblocking, semaphore: boolean): integer;
+begin
+  result := 0; // non implemented (not tested, infact) on this CPU
+end;
+
+{$endif HASEVENTFD}
+
+function LinuxEventFDRead(fd: integer): Int64;
+begin
+  { If EFD_SEMAPHORE was specified and the eventfd counter has a nonzero value,
+    then a read returns 8 bytes containing the value 1, and the counter's value
+    is decremented by 1 }
+  result := 0;
+  if do_syscall(syscall_nr_read, fd, TSysParam(@result), 8) <> 8 then
+    result := -1;
+end;
+
+procedure LinuxEventFDWrite(fd: integer; count: QWord);
+begin
+  if count <> 0 then
+    do_syscall(syscall_nr_write, fd, TSysParam(@count), SizeOf(count));
+end;
+
+function LinuxEventFDWait(fd: integer; ms: integer): boolean;
+begin
+  result := WaitReadPending(fd, ms);
+end;
+
+{$endif OSLINUX}
+
+
+// we bypass crt.pp since this unit cancels the SIGINT signal
+
+procedure AllocConsole;
+begin
+  StdOut := StdOutputHandle;
+end;
+
+var
+  TextAttr: integer = 255; // always change the color at startup
+
+procedure TextColorCmd(Color: TConsoleColor; var s: TShort8);
+const
+  TERM_CTRL: string[8] = '04261537';
+begin
+  s[0] := #0;
+  if (ord(Color) = TextAttr) or
+     not StdOutIsTTY then
+    exit;
+  TextAttr := ord(Color);
+  s := #27'[0;3#m';
+  if ord(Color) >= 8 then
+    s[3] := '1';
+  s[6] := TERM_CTRL[(ord(Color) and 7) + 1];
+end;
+
+procedure TextColorAppend(Color: TConsoleColor; var s: RawUtf8);
+var
+  c: TShort8;
+begin
+  TextColorCmd(Color, c);
+  RawUtf8Append(s, @c[1], ord(c[0]));
+end;
+
+procedure TextColor(Color: TConsoleColor);
+var
+  c: TShort8;
+begin
+  TextColorCmd(Color, c);
+  if c[0] <> #0 then
+    fpwrite(StdOutputHandle, @c[1], ord(c[0])); // single syscall
+end;
+
+procedure TextBackground(Color: TConsoleColor);
+begin
+  // not implemented yet - but not much needed either
+end;
+
+var
+  ConsoleCriticalSection: TOSLock;
+const
+  PosixLineFeed: AnsiChar = #10;
+
+procedure ConsoleWrite(const Text: RawUtf8; Color: TConsoleColor;
+  NoLineFeed, NoColor: boolean);
+var
+  s: RawUtf8;
+begin
+  // pre-compute the whole chars to be sent to the console
+  if not NoColor then
+    TextColorAppend(Color, s);
+  RawUtf8Append(s, pointer(Text), length(Text));
+  if not NoLineFeed then
+    RawUtf8Append(s, @PosixLineFeed, 1);
+  if not NoColor then
+    TextColorAppend(ccLightGray, s);
+  // display whole line in a single syscall
+  ConsoleCriticalSection.Lock;
+  FileWriteAll(StdOutputHandle, pointer(s), length(s)); // UTF-8 console
+  ConsoleCriticalSection.UnLock;
+end;
+
+function UnixKeyPending: boolean;
+begin
+  result := WaitReadPending(StdInputHandle, 0);
+end;
+
+{$I-}
+procedure ConsoleWaitForEnterKey;
+var
+  c: AnsiChar;
+begin
+  if GetCurrentThreadID = MainThreadID then
+  begin
+    SynDaemonIntercept; // intercept ^C and SIGQUIT - do nothing if already set
+    repeat
+      if IsMultiThread then
+        CheckSynchronize(100)
+      else
+        Sleep(100);
+      if SynDaemonTerminated <> 0 then
+        break;
+      if UnixKeyPending then
+        repeat
+          c := #0;
+          if FpRead(StdInputHandle, c, 1) <> 1 then
+            break;
+          if c in [#10, #13] then
+            exit;
+        until false;
+    until false;
+  end
+  else
+    ReadLn;
+  ioresult;
+end;
+{$I+}
+
+function ConsoleStdInputLen: integer;
+begin
+  if fpioctl(StdInputHandle, FIONREAD, @result) < 0 then
+    result := 0;
+end;
+
+function Utf8ToConsole(const S: RawUtf8): RawByteString;
+begin
+  result := S; // expect a UTF-8 console under Linux/BSD
+end;
+
+
+{$ifdef FPCUSEVERSIONINFO} // FPC 3.0+ if enabled in .inc / project options
+function TFileVersion.RetrieveInformationFromFileName: boolean;
+var
+  VI: TVersionInfo;
+  TI: integer;
+begin
+  result := false;
+  if fFileName = '' then
+    exit;
+  VI := TVersionInfo.Create;
+  try
+    try
+      // extract information - VI.Load() may raise EResNotFound
+      if (fFileName <> '') and
+         (fFileName <> ParamStr(0)) then
+        VI.Load(fFileName)
+      else
+        VI.Load(HInstance); // load info for currently running program
+      result := VI.FixedInfo.FileVersion[0] <> 0;
+      // set extracted version numbers
+      SetVersion(VI.FixedInfo.FileVersion[0],
+                 VI.FixedInfo.FileVersion[1],
+                 VI.FixedInfo.FileVersion[2],
+                 VI.FixedInfo.FileVersion[3]);
+      // detect translation
+      if VI.VarFileInfo.Count > 0 then
+        with VI.VarFileInfo.Items[0] do
+          LanguageInfo := _fmt('%.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 language index
+        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;
+    except
+      // trap EResNotFound exception from VI.Load()
+    end;
+  finally
+    VI.Free;
+  end;
+end;
+{$else}
+function TFileVersion.RetrieveInformationFromFileName: boolean;
+begin
+  result := false; // nothing to be done
+end;
+{$endif FPCUSEVERSIONINFO}
+
+procedure GetUserHost(out User, Host: RawUtf8);
+begin
+  Host := RawUtf8(GetHostName);
+  if Host = '' then
+    Host := RawUtf8(GetEnvironmentVariable('HOSTNAME'));
+  User := RawUtf8(GetEnvironmentVariable('LOGNAME')); // POSIX
+  if User = '' then
+    User := RawUtf8(GetEnvironmentVariable('USER'));
+end;
+
+function GetEnvFolder(const name: string; var folder: TFileName;
+  writable: boolean): boolean;
+begin
+  folder := GetEnvironmentVariable(name);
+  if folder <> '' then
+    if writable and
+       not IsDirectoryWritable(folder) then
+      folder := ''
+    else
+      folder := IncludeTrailingPathDelimiter(folder);
+  result := folder <> '';
+end;
+
+function WritableFolder(const parent, sub: TFileName; var folder: TFileName): boolean;
+begin
+  result := false;
+  if not IsDirectoryWritable(parent) then
+    exit;
+  folder := EnsureDirectoryExists(parent + sub);
+  if folder = '' then
+    exit;
+  if IsDirectoryWritable(folder) then
+    result := true
+  else
+    folder := '';
+end;
+
+procedure _ComputeSystemPath(kind: TSystemPath; var result: TFileName);
+begin
+  result := ''; // "out result" param is not enough for FPC
+  case kind of
+    spLog:
+         // try '/var/log/'
+      if not WritableFolder('/var/log/', TFileName(Executable.ProgramName), result) and
+         // try '/log'
+         not WritableFolder(Executable.ProgramFilePath, 'log', result) then
+        // fallback to '$TMP/-log' - spUserData/$HOME is no option
+        result := EnsureDirectoryExists(format('%s%s-log',
+          [GetSystemPath(spTemp), Executable.ProgramName]));
+    // warning: $HOME is reported wrong with sudo for spUserData/spUserDocuments
+    spUserData:
+         // try $XDG_CACHE_HOME
+      if not GetEnvFolder('XDG_CACHE_HOME', result, {writable=}true) and
+         // try '$HOME/.cache'
+         not WritableFolder(GetSystemPath(spUserDocuments), '.cache', result) then
+        // fallback to '$TMP/'
+        WritableFolder(GetSystemPath(spTemp), TFileName(Executable.User), result);
+    spTemp:
+      begin
+        // try $TMPDIR (POSIX standard) and $TMP and $TEMP
+        if GetEnvFolder('TMPDIR', result, {writable=}true) or
+           GetEnvFolder('TMP',    result, {writable=}true) or
+           GetEnvFolder('TEMP',   result, {writable=}true) then
+          exit;
+        // try /tmp
+        result := '/tmp/';
+        if not IsDirectoryWritable(result) then
+          // fallback to /var/tmp
+          result := '/var/tmp/';
+      end;
+  else
+    // POSIX requires a value for the $HOME environment variable
+    GetEnvFolder('HOME', result, {writable=}false);
+  end;
+end;
+
+function _GetSystemStoreAsPem(CertStore: TSystemCertificateStore): RawUtf8;
+var
+  files: TRawUtf8DynArray;
+  f: PtrInt;
+begin
+  // see https://go.dev/src/crypto/x509/root_unix.go as reference
+  case CertStore of
+    scsRoot:
+      result := StringFromFirstFile([
+        {$ifdef OSLINUXANDROID}
+          '/etc/ssl/certs/ca-certificates.crt',                // Debian/Gentoo
+      	  '/etc/pki/tls/certs/ca-bundle.crt',                  // Fedora/RHEL 6
+          '/etc/ssl/ca-bundle.pem',                            // OpenSUSE
+          '/etc/pki/tls/cacert.pem',                           // OpenELEC
+          '/etc/pki/ca-trust/extracted/pem/tls-ca-bundle.pem', // CentOS/RHEL 7
+          '/etc/ssl/cert.pem'                                  // Alpine Linux
+        {$else}
+      	  '/usr/local/etc/ssl/cert.pem',            // FreeBSD
+      	  '/etc/ssl/cert.pem',                      // OpenBSD
+      	  '/usr/local/share/certs/ca-root-nss.crt', // DragonFly
+      	  '/etc/openssl/certs/ca-certificates.crt'  // NetBSD
+        {$endif OSLINUXANDROID}
+        ]);
+    scsCA:
+      begin
+        files := StringFromFolders([
+          {$ifdef OSLINUXANDROID}
+            '/etc/ssl/certs',               // Debian/SLES10/SLES11
+            '/etc/pki/tls/certs',           // Fedora/RHEL
+      	    '/system/etc/security/cacerts'  // Android
+          {$else}
+            '/etc/ssl/certs',         // FreeBSD 12.2+
+            '/usr/local/share/certs', // FreeBSD
+            '/etc/openssl/certs'      // NetBSD
+          {$endif OSLINUXANDROID}
+          ]);
+        for f := 0 to length(files) - 1 do
+          if (PosEx('-----BEGIN', files[f]) <> 0) and
+             IsAnsiCompatible(files[f]) and
+             (PosEx(files[f], result) = 0) then // append PEM files once
+            result := result + #10 + files[f];
+      end;
+  end;
+end;
+
+
+const
+  // on POSIX, we store the SMBIOS data in a local cache for non-root users
+  SMB_CACHE = '/var/tmp/.synopse.smb';
+  SMB_FLAGS = $010003ff; // assume 3.0 SMB is good enough
+  // local storage of fallback UUID
+  UUID_CACHE = '/var/tmp/.synopse.uid';
+  // note: /var/tmp is cleaned up by systemd after 30 days so we set S_ISVTX
+  //   see https://systemd.io/TEMPORARY_DIRECTORIES
+
+{$ifdef CPUINTEL}
+const
+  // potential location of the SMBIOS buffer pointers within a 64KB fixed frame
+  SMB_START  = $000f0000;
+  SMB_STOP   = $00100000;
+
+function GetSmbEfiMem: RawByteString; forward; // Linux/BSD dedicated versions
+function SearchSmbios(const mem: RawByteString; var info: TRawSmbiosInfo): PtrUInt;
+  forward; // implemented later in mormot.core.os.pas
+
+function GetRawSmbiosFromMem(var info: TRawSmbiosInfo): boolean;
+var
+  mem: RawByteString;
+  addr: PtrUInt;
+  {$ifdef OSLINUX}
+  fromsysfs: boolean;
+  {$endif OSLINUX}
+begin
+  result := false;
+  {$ifdef OSLINUX}
+  // on Linux, first try from sysfs tables
+  fromsysfs := false;
+  mem := StringFromFile('/sys/firmware/dmi/tables/smbios_entry_point', true);
+  if mem <> '' then
+    fromsysfs := true
+  else
+  {$endif OSLINUX}
+    // then try to read system EFI entries
+    mem := GetSmbEfiMem;
+  if mem = '' then
+    // last fallback to raw memory reading (won't work on modern/EFI systems)
+    mem := ReadSystemMemory(SMB_START, SMB_STOP - SMB_START);
+  if mem = '' then
+    exit;
+  addr := SearchSmbios(mem, info);
+  if addr = 0 then
+    exit;
+  {$ifdef OSLINUX}
+  if fromsysfs then
+    info.data := StringFromFile('/sys/firmware/dmi/tables/DMI', {nosize=}true)
+  else
+  {$endif OSLINUX}
+    info.data := ReadSystemMemory(addr, info.Length);
+  result := info.data <> '';
+end;
+{$endif CPUINTEL}
+
+function _GetRawSmbios(var info: TRawSmbiosInfo): boolean;
+begin
+  {$ifdef CPUINTEL}
+  result := GetRawSmbiosFromMem(info);
+  if result then
+    exit;
+  {$else} // do not mess with low-level RAM buffer scanning on ARM/AARCH64
+  result := false; // untested and reported as clearly faulty on some platforms
+  {$endif CPUINTEL}
+  PCardinal(@info)^ := SMB_FLAGS; // mark as retrieved from cache
+  info.Data := StringFromFile(SMB_CACHE); // cache is better than PosixInject
+  if (info.Data <> '') and
+     (CompressSynLZ(info.Data, false) = '') then
+    info.Data := ''; // tampered file
+  if info.Data = '' then
+    if Assigned(PosixInject.GetSmbiosData) then
+    begin
+      info.Data := PosixInject.GetSmbiosData; // e.g. from mormot.core.os.mac
+      if info.Data <> '' then
+        PCardinal(@info)^ := SMB_FLAGS - 1; // mark retrieved from PosixInject
+    end;
+  if info.Data = '' then
+    exit;
+  info.Length := length(info.Data);
+  result := true;
+end;
+
+procedure PosixInjectSmbiosInfo(var info: TSmbiosBasicInfos);
+var
+  i: TSmbiosBasicInfo;
+begin
+  if Assigned(PosixInject.GetSmbios) then // e.g. from mormot.core.os.mac
+    for i := succ(low(i)) to high(i) do
+      if info[i] = '' then
+        info[i] := PosixInject.GetSmbios(i);
+end;
+
+procedure _AfterDecodeSmbios(var info: TRawSmbiosInfo);
+var
+  s: RawByteString;
+begin
+  // complete information e.g. from mormot.core.os.mac
+  if Assigned(PosixInject.GetSmbios) then
+    PosixInjectSmbiosInfo(_Smbios);
+  // check if require persistence after some HW changes
+  if (PCardinal(@info)^ = SMB_FLAGS) or
+     (CompressSynLZGetHash32(StringFromFile(SMB_CACHE)) = Hash32(info.Data)) then
+    exit;
+  // cache raw SMBIOS data for non-root users
+  s := info.Data;
+  CompressSynLZ(s, true); // SynLZ + Hash32 to avoid tampered file
+  FileFromString(s, SMB_CACHE);
+  FileSetSticky(SMB_CACHE);
+  DeleteFile(UUID_CACHE); // this file is now superfluous and maybe inconsistent
+end;
+
+function SeemsRealPointer(p: pointer): boolean;
+begin
+  // let the GPF happen silently in the kernel (validated on Linux only)
+  result := (PtrUInt(p) > 65535) and
+            (fpaccess(p, F_OK) <> 0) and
+            (fpgeterrno <> ESysEFAULT);
+end;
+
+const
+  DT_UNKNOWN  = 0; // need to call fpstat() if this is returned (depends on FS)
+  DT_FIFO     = 1;
+  DT_CHR      = 2;
+  DT_DIR      = 4;
+  DT_BLK      = 6;
+  DT_REG      = 8;
+  DT_LNK      = 10;
+  DT_SOCK     = 12;
+  DT_WHT      = 14;
+
+function PosixFileNames(const Folder: TFileName; Recursive: boolean): TRawUtf8DynArray;
+var
+  n: PtrInt;
+  root: TFileName;
+
+  procedure DoFolder(const subpath: TFileName);
+  var
+    d: pDir;
+    e: pDirent;
+    pl, el: PtrInt;
+    fn: RawUtf8;
+  begin
+    d := FpOpendir(root + subpath); // (much) faster alternative to FindFirst()
+    if d = nil then
+      exit;
+    pl := length(subpath);
+    if pl <> 0 then
+      inc(pl);
+    repeat
+      e := FpReaddir(d^); // FPC RTL use getdents64 syscall on Linux and BSD :)
+      if e = nil then
+        break;
+      // fn := [subpath + '/'] + e^.d_name
+      el := StrLen(@e^.d_name);
+      FastSetString(fn, pl + el);
+      if pl <> 0 then
+      begin
+        MoveFast(pointer(subpath)^, pointer(fn)^, pl - 1);
+        PByteArray(fn)[pl - 1] := ord('/');
+      end;
+      MoveFast(e^.d_name, PByteArray(fn)[pl], el);
+      // handle this entry
+      case e.d_type of
+        DT_UNKNOWN, // assume modern FS over BSD or Linux Kernel >= 2.6.4
+        DT_REG:
+          begin
+            if n = 0 then // generous initial result capacity
+              SetLength(result, 128)
+            else if n = length(result) then
+              SetLength(result, NextGrow(n));
+            result[n] := fn;
+            inc(n);
+          end;
+        DT_DIR:
+          if Recursive and
+             (e^.d_name[0] <> '.')  then
+            DoFolder(fn);
+      end;
+    until false;
+    FpClosedir(d^);
+  end;
+
+begin
+  result := nil;
+  n := 0;
+  root := IncludeTrailingPathDelimiter(Folder);
+  DoFolder('');
+  if n <> 0 then
+    DynArrayFakeLength(result, n);
+end;
+
+{$ifdef OSBSDDARWIN}
+
+function IsValidPid(pid: cardinal): boolean;
+begin
+  result := pid <> 0;
+end;
+
+function EnumAllProcesses: TCardinalDynArray;
+begin
+  result := nil;
+  // not implemented yet on BSD/Darwin
+  // - fpsysctl with CTL_KERN + KERN_PROC + KERN_PROC_ALL is highly OS dependent
+  // and headers are over-complicated so almost impossible to safely use in FPC:
+  // https://github.com/apple-opensource/xnu/blob/master/bsd/sys/sysctl.h#L975
+  // https://stackoverflow.com/a/6945542/458259
+  // - kvm_openfiles / kvm_getprocs may be a good option:
+  // https://kaashif.co.uk/2015/06/18/how-to-get-a-list-of-processes-on-openbsd-in-c
+end;
+
+function EnumProcessName(PID: cardinal): RawUtf8;
+begin
+  result := ''; // not implemented yet on BSD/Darwin
+  // use fpsysctl with CTL_KERN + KERN_PROC + KERN_PROC_PID
+  //  https://man.openbsd.org/sysctl.2#KERN_PROC_PID
+  // another trouble is that the name is likely to be truncated to 16 chars
+  // because it is defined p_comm[MAXCOMLEN + 1] in the very complex headers
+end;
+
+function _IsDebuggerPresent: boolean;
+begin
+  // rough detection for FPC on BSD (not yet working because of EnumProcessName)
+  result := PosEx('lazarus', LowerCase(EnumProcessName(FpGetppid))) <> 0;
+end;
+
+function GetParentProcess(PID: cardinal): cardinal;
+begin
+  if PID = 0 then
+    result := FpGetppid // we have a system call for the currrent process :)
+  else
+    result := 0; // not implemented yet on BSD/Darwin
+end;
+
+function fpsysctlhwint(hwid: cint): Int64;
+var
+  mib: array[0..1] of cint;
+  len: cint;
+begin
+  result := 0;
+  mib[0] := CTL_HW;
+  mib[1] := hwid;
+  len := SizeOf(result);
+  fpsysctl(pointer(@mib), 2, @result, @len, nil, 0);
+end;
+
+function fpsysctlhwstr(hwid: cint; var temp: ShortString): PUtf8Char;
+var
+  mib: array[0..1] of cint;
+  len: cint;
+begin
+  mib[0] := CTL_HW;
+  mib[1] := hwid;
+  FillCharFast(temp, SizeOf(temp), 0); // ShortString as 0-terminated buffer
+  len := SizeOf(temp);
+  fpsysctl(pointer(@mib), 2, @temp, @len, nil, 0);
+  if temp[0] <> #0 then
+    result := @temp
+  else
+    result := nil;
+end;
+
+function fpsysctlbynamehwstr(name: PAnsiChar; var temp: ShortString): PUtf8Char;
+var
+  len: cint;
+begin
+  FillCharFast(temp, SizeOf(temp), 0); // ShortString as 0-terminated buffer
+  len := SizeOf(temp);
+  FPsysctlbyname(name, @temp, @len, nil, 0);
+  if temp[0] <> #0 then
+    result := @temp
+  else
+    result := nil;
+end;
+
+type
+  TLoadAvg = array[0..2] of double;
+
+function getloadavg(var loadavg: TLoadAvg; nelem: integer): integer;
+  cdecl external clib name 'getloadavg';
+
+function RetrieveLoadAvg: RawUtf8;
+var
+  avg: TLoadAvg;
+begin
+  if getloadavg(avg, 3) = 3 then
+    result := _fmt('%g %g %g', [avg[0], avg[1], avg[2]])
+  else
+    result := '';
+end;
+
+{$ifdef OSFREEBSD}
+
+const
+  KENV_GET = 0;
+  KENV_SET = 1;
+
+function kenv(action: integer; name, value: PAnsiChar; len: integer): integer;
+  cdecl external clib name 'kenv';
+
+function GetSmbEfiMem: RawByteString;
+var
+  tmp: array[byte] of AnsiChar;
+  xaddr: PtrUInt;
+begin
+  result := '';
+  if kenv(KENV_GET, 'hint.smbios.0.mem', @tmp, SizeOf(tmp)) < 0 then
+    exit;
+  xaddr := PosixParseHex32(@tmp); // typical value is '0xf05b0'
+  if xaddr <> 0 then
+    result := ReadSystemMemory(xaddr, 1024); // 32 bytes is enough
+end;
+
+const
+  _KNOWN: array[0..14] of record
+    id: TSmbiosBasicInfo;
+    fn: RawUtf8;
+  end = (
+    (id: sbiBiosVendor;        fn: 'bios.vendor'),
+    (id: sbiBiosVersion;       fn: 'bios.version'),
+    (id: sbiBiosDate;          fn: 'bios.reldate'),
+    (id: sbiManufacturer;      fn: 'system.maker'),
+    (id: sbiProductName;       fn: 'system.product'),
+    (id: sbiVersion;           fn: 'system.version'),
+    (id: sbiSerial;            fn: 'system.serial'),
+    (id: sbiUuid;              fn: 'system.uuid'),
+    (id: sbiSku;               fn: 'system.sku'),
+    (id: sbiFamily;            fn: 'system.family'),
+    (id: sbiBoardManufacturer; fn: 'planar.maker'),
+    (id: sbiBoardProductName;  fn: 'planar.product'),
+    (id: sbiBoardVersion;      fn: 'planar.version'),
+    (id: sbiBoardSerial;       fn: 'planar.serial'),
+    (id: sbiBoardAssetTag;     fn: 'planar.tag')
+  );
+
+procedure _DirectSmbiosInfo(out info: TSmbiosBasicInfos);
+var
+  i: PtrInt;
+  tmp: array[byte] of AnsiChar;
+begin
+  for i := 0 to high(_KNOWN) do
+    with _KNOWN[i] do
+      if kenv(KENV_GET, PAnsiChar('smbios.' + fn), @tmp, SizeOf(tmp)) >= 0 then
+        info[id] := TrimU(tmp);
+end;
+
+{$else}
+
+// help is needed to implement those on buggy Mac OS
+// may fallback to PosixInject wrappers from mormot.core.os.mac
+
+function GetSmbEfiMem: RawByteString;
+begin
+  result := '';
+end;
+
+{$ifdef OSDARWIN}
+function ReadSystemMemory(address, size: PtrUInt): RawByteString;
+begin
+  result := '';
+end;
+{$endif OSDARWIN}
+
+procedure _DirectSmbiosInfo(out info: TSmbiosBasicInfos);
+begin
+end;
+
+{$endif OSFREEBSD}
+
+function GetMemoryInfo(out info: TMemoryInfo; withalloc: boolean): boolean;
+begin
+  FillCharFast(info, SizeOf(info), 0);
+  info.memtotal := SystemMemorySize; // retrieved at startup
+  info.memfree := info.memtotal - fpsysctlhwint(HW_USERMEM);
+  result := info.memtotal <> 0;// avoid div per 0 exception
+  if result then
+    info.percent := ((info.memtotal - info.memfree) * 100) div info.memtotal;
+end;
+
+procedure XorOSEntropy(var e: THash512Rec);
+var
+  mem: TMemoryInfo;
+  avg: TLoadAvg absolute mem;
+  us: Int64 absolute mem.vmtotal; // =0 after above GetMemoryInfo()
+  guid: THash128Rec absolute mem.filetotal; // also = 0
+begin
+  //some minimal OS entropy we could get for BSD/Darwin
+  QueryPerformanceMicroSeconds(us);
+  e.i[0] := e.i[0] xor us;
+  e.i[1] := e.i[1] xor GetTickCount64;
+  getloadavg(avg, 3);
+  DefaultHasher128(@e.h1, @avg, SizeOf(avg)); // may be AesNiHash128
+  GetMemoryInfo(mem, {withalloc=}false);
+  DefaultHasher128(@e.h2, @mem, SizeOf(mem));
+  {$ifdef OSDARWIN} // FPC CreateGuid calls /dev/urandom which is not advised
+  guid.Lo := mach_absolute_time; // monotonic clock in nanoseconds
+  guid.Hi := mach_continuous_time;
+  {$else}
+  CreateGuid(guid.guid); // use e.g. FreeBSD syscall or /dev/urandom
+  {$endif OSDARWIN}
+  QueryPerformanceMicroSeconds(us); // should have changed in-between
+  crcblocks(@e.h3, @mem, SizeOf(mem) shr 4); // another algo
+end;
+
+{$else} // Linux-specific code
+
+function IsValidPid(pid: cardinal): boolean;
+var
+  status, tgid: RawUtf8;
+begin
+  result := false;
+  if pid = 0 then
+    exit;
+  status := StringFromFile('/proc/' + IntToStr(pid) + '/status', {nosize=}true);
+  // ensure is a real process, not a thread
+  // https://www.memsql.com/blog/the-curious-case-of-thread-groups-identifiers
+  FindNameValue(status, 'TGID:', tgid);
+  result := GetCardinal(pointer(tgid)) = pid;
+end;
+
+function EnumAllProcesses: TCardinalDynArray;
+var
+  d: pDir;
+  e: pDirent;
+  n: integer;
+  pid: cardinal;
+begin
+  result := nil;
+  d := FpOpendir('/proc'); // (much) faster alternative to FindFirst()
+  if d = nil then
+    exit;
+  n := 0;
+  SetLength(result, 128);
+  repeat
+    e := FpReaddir(d^); // FPC RTL uses direct getdents syscall on Linux/BSD :)
+    if e = nil then
+      break;
+    if (e.d_type in [DT_UNKNOWN, DT_DIR]) and
+       (e.d_name[0] in ['1'..'9']) then
+    begin
+      pid := GetCardinal(@e.d_name[0]);
+      if (pid <> 0) and
+         IsValidPid(pid) then
+        AddInteger(TIntegerDynArray(result), n, pid);
+    end;
+  until false;
+  FpClosedir(d^);
+  if n = 0 then
+    result := nil
+  else
+    DynArrayFakeLength(result, n);
+end;
+
+var
+  tryprocexe: boolean = true;
+
+function EnumProcessName(PID: cardinal): RawUtf8;
+var
+  proc: TFileName;
+  cmdline: RawUtf8;
+begin
+  proc := '/proc/' + IntToStr(PID);
+  if tryprocexe then
+  begin
+    // need to be root to follow /proc/[pid]/exe
+    result := fpReadLink(proc + '/exe');
+    if result <> '' then
+      exit;
+  end;
+  cmdline := StringFromFile(proc + '/cmdline', {nosize=}true);
+  // set of strings separated by null bytes -> exe is the first argument
+  FastSetString(result, pointer(cmdline), StrLen(pointer(cmdline)));
+  if result <> '' then
+    tryprocexe := false; // no need to try again next time
+end;
+
+function GetParentProcess(PID: cardinal): cardinal;
+var
+  status, ppid: RawUtf8;
+begin
+  if PID = 0 then
+    result := FpGetppid // we have a system call for the current process :)
+  else
+  begin
+    result := 0;
+    status := StringFromFile('/proc/' + IntToStr(PID) + '/status', {nosize=}true);
+    if status = '' then
+      exit; // no such process
+    FindNameValue(status, 'PPID:', ppid);
+    result := GetCardinal(pointer(ppid));
+  end;
+end;
+
+function _IsDebuggerPresent: boolean;
+var
+  status, tracerpid: RawUtf8;
+begin
+  status := StringFromFile('/proc/self/status', {nosize=}true);
+  FindNameValue(status, 'TRACERPID:', tracerpid);
+  result := (tracerpid <> '0');
+end;
+
+function RetrieveLoadAvg: RawUtf8;
+begin
+  // the libc parses this file anyway :)
+  result := TrimU(StringFromFile('/proc/loadavg', {nosize=}true));
+end;
+
+function FindMemInfo(const meminfo, up: RawUtf8): PtrUInt;
+var
+  v: RawUtf8;
+begin
+  FindNameValue(meminfo, up, v);
+  result := GetCardinal(pointer(v)) shl 10; // from KB to bytes
+end;
+
+function GetMemoryInfo(out info: TMemoryInfo; withalloc: boolean): boolean;
+var
+  proc: RawUtf8;
+  P: PUtf8Char;
+begin
+  result := false;
+  FillCharFast(info, SizeOf(info), 0);
+  // sysinfo() syscall has not enough information: use /proc sysfiles
+  proc := StringFromFile('/proc/meminfo', {hasnosize=}true);
+  if proc = '' then
+    exit;
+  info.memtotal  := FindMemInfo(proc, 'MEMTOTAL:');
+  info.memfree   := FindMemInfo(proc, 'MEMAVAILABLE:'); // MemFree is too low
+  info.filetotal := FindMemInfo(proc, 'SWAPTOTAL:');
+  info.filefree  := FindMemInfo(proc, 'SWAPFREE:');
+  // note: Windows-like virtual memory information is not available under Linux
+  info.vmtotal   := FindMemInfo(proc, 'COMMITLIMIT:');
+  info.vmfree    := FindMemInfo(proc, 'MEMFREE:');
+  if info.memfree = 0 then // kernel < 3.14 may not have the MemAvailable field
+    info.memfree  := info.vmfree +
+                     FindMemInfo(proc, 'BUFFERS:') +
+                     FindMemInfo(proc, 'CACHED:')  +
+                     FindMemInfo(proc, 'SRECLAIMABLE:') -
+                     FindMemInfo(proc, 'SHMEM:');
+  if info.memtotal <> 0 then
+  begin
+    info.percent := ((info.memtotal - info.memfree) * 100) div info.memtotal;
+    result := true;
+  end;
+  if not withalloc then
+    exit;
+  // GetHeapStatus is only about current thread -> use /proc/[pid]/statm
+  proc := StringFromFile('/proc/self/statm', {hasnosize=}true);
+  P := pointer(proc);
+  info.allocreserved := GetNextCardinal(P) * SystemInfo.dwPageSize; // VmSize
+  info.allocused     := GetNextCardinal(P) * SystemInfo.dwPageSize; // VmRSS
+end;
+
+procedure DoHash128File(var h: THash128; const filename: TFileName);
+var
+  s: RawByteString;
+begin
+  s := StringFromFile(filename, {nosize=}true);
+  DefaultHasher128(@h, pointer(s), length(s)); // maybe AesNiHash128
+end;
+
+procedure XorOSEntropy(var e: THash512Rec);
+var
+  si: TSysInfo;  // Linuxism
+  rt: TTimeSpec; // with nanoseconds resolution
+begin
+  clock_gettime(CLOCK_MONOTONIC_HIRES, @rt);
+  DefaultHasher128(@e.h0, @rt, SizeOf(rt)); // maybe AesNiHash128
+  SysInfo(@si); // uptime + loadavg + meminfo + numprocess
+  DefaultHasher128(@e.h0, @si, SizeOf(si));
+  // detailed CPU execution context and timing from Linux kernel
+  DoHash128File(e.h0, '/proc/self/statm');
+  DoHash128File(e.h0, '/proc/self/stat');
+  DoHash128File(e.h1, '/proc/stat');
+  clock_gettime(CLOCK_UPTIME, @rt);
+  DefaultHasher128(@e.h2, @rt, SizeOf(rt)); // maybe AesNiHash128
+  // read-only 122-bit random UUID text '6fd5a44b-35f4-4ad4-a9b9-6b9be13e1fe9'
+  DoHash128File(e.h2, '/proc/sys/kernel/random/uuid');
+  DoHash128File(e.h3, '/proc/sys/kernel/random/boot_id');
+  clock_gettime(CLOCK_MONOTONIC_HIRES, @rt); // should have changed in-between
+  DefaultHasher128(@e.h3, @rt, SizeOf(rt));
+end;
+
+{$ifdef OSANDROID}
+
+procedure _DirectSmbiosInfo(out info: TSmbiosBasicInfos);
+begin
+end;
+
+{$else} // pure Linux
+
+const
+  // note: reading some of the /sys/class/dmi/id/* files may require root access
+  _KNOWN: array[0..15] of record
+    id: TSmbiosBasicInfo;
+    fn: string;
+  end = (
+    (id: sbiBiosVendor;        fn: 'bios_vendor'),
+    (id: sbiBiosVersion;       fn: 'bios_version'),
+    (id: sbiBiosDate;          fn: 'bios_date'),
+    (id: sbiBiosRelease;       fn: 'bios_release'),
+    (id: sbiManufacturer;      fn: 'sys_vendor'),
+    (id: sbiProductName;       fn: 'product_name'),
+    (id: sbiVersion;           fn: 'product_version'),
+    (id: sbiSerial;            fn: 'product_serial'),
+    (id: sbiUuid;              fn: 'product_uuid'),
+    (id: sbiSku;               fn: 'product_sku'),
+    (id: sbiFamily;            fn: 'product_family'),
+    (id: sbiBoardManufacturer; fn: 'board_vendor'),
+    (id: sbiBoardProductName;  fn: 'board_name'),
+    (id: sbiBoardVersion;      fn: 'board_version'),
+    (id: sbiBoardSerial;       fn: 'board_serial'),
+    (id: sbiBoardAssetTag;     fn: 'board_asset_tag')
+  );
+
+procedure _DirectSmbiosInfo(out info: TSmbiosBasicInfos);
+var
+  i: PtrInt;
+begin
+  for i := 0 to high(_KNOWN) do
+    with _KNOWN[i] do
+      info[id] := TrimU(StringFromFile('/sys/class/dmi/id/' + fn, {nosize=}true));
+  // note: /var/lib/dbus/machine-id and /etc/machine-id are SW generated from
+  // random at system install so do NOT match sbiUuid HW DMI value - see
+  // https://www.freedesktop.org/software/systemd/man/machine-id.html
+end;
+
+{$endif OSANDROID}
+
+{$endif OSBSDDARWIN}
+
+var
+  __IsDebuggerPresent: (idpUntested, idpNone, idpPresent);
+
+function IsDebuggerPresent: boolean;
+begin
+  if __IsDebuggerPresent = idpUntested then
+    if _IsDebuggerPresent then
+      __IsDebuggerPresent := idpPresent
+    else
+      __IsDebuggerPresent := idpNone;
+  result := __IsDebuggerPresent = idpPresent;
+end;
+
+{$ifndef OSDARWIN}
+// on POSIX systems, /dev/mem may be available from root
+// but sometimes even root can't access it on hardened systems
+function ReadSystemMemory(address, size: PtrUInt): RawByteString;
+var
+  mem: cInt;
+  map: PAnsiChar;
+  off: PtrUInt;
+begin
+  result := '';
+  if size > 4 shl 20 then
+    exit; // read up to 4MB
+  mem := FpOpen('/dev/mem', O_RDONLY, 0);
+  if mem <= 0 then
+    exit;
+  // Fpmmap() is more complex but works around problems using plain read() calls
+  off := address mod SystemInfo.dwPageSize;
+  map := Fpmmap(nil, off + size, PROT_READ, MAP_SHARED, mem, address - off);
+  if map <> MAP_FAILED then
+  begin
+    FastSetRawByteString(result, map + off, size);
+    Fpmunmap(map, off + size);
+  end;
+  FpClose(mem);
+end;
+{$endif OSDARWIN}
+
+procedure DirectSmbiosInfo(out info: TSmbiosBasicInfos);
+begin
+  // retrieve OS-dependent information
+  _DirectSmbiosInfo(info);
+  // normalize some entries
+  info[sbiUuid] := LowerCase(info[sbiUuid]);
+  // some missing info may have retrieved at startup of this unit
+  if info[sbiCpuVersion] = '' then
+    info[sbiCpuVersion] := CpuInfoText;
+  // e.g. from mormot.core.os.mac
+  if Assigned(PosixInject.GetSmbios) then
+    PosixInjectSmbiosInfo(info);
+end;
+
+function RetrieveSystemTimes(out IdleTime, KernelTime, UserTime: Int64): boolean;
+begin
+  result := false; // should call e.g. RetrieveLoadAvg() instead
+end;
+
+function RetrieveProcessInfo(PID: cardinal; out KernelTime, UserTime: Int64;
+  out WorkKB, VirtualKB: cardinal): boolean;
+begin
+  result := false;
+end;
+
+function TProcessInfo.Init: boolean;
+begin
+  FillCharFast(self, SizeOf(self), 0);
+  result := false;
+end;
+
+function TProcessInfo.Start: boolean;
+begin
+  result := false;
+end;
+
+function TProcessInfo.PerProcess(PID: cardinal; Now: PDateTime;
+  out Data: TSystemUseData; var PrevKernel, PrevUser: Int64): boolean;
+begin
+  result := false;
+end;
+
+function TProcessInfo.PerSystem(out Idle, Kernel, User: single): boolean;
+var
+  P: PUtf8Char;
+  U, K, I, S: cardinal;
+begin
+  // see http://www.linuxhowtos.org/System/procstat.htm
+  result := false;
+  P := pointer(StringFromFile('/proc/stat', {nosize=}true));
+  if P = nil then
+    exit;
+  // e.g. 'cpu  3418147 18140 265232 6783435 12184 0 34219 0 0 0'
+  U := GetNextCardinal(P){=user} + GetNextCardinal(P){=nice};
+  K := GetNextCardinal(P){=system};
+  I := GetNextCardinal(P){=idle};
+  S := U + K + I;
+  result := S <> 0;
+  if not result then
+    exit;
+  Kernel := {%H-}SimpleRoundTo2Digits((K * 100) / S);
+  User   := {%H-}SimpleRoundTo2Digits((U * 100) / S);
+  Idle   := 100 - Kernel - User; // ensure sum is always 100%
+end; { TODO : use a diff approach for TProcessInfo.PerSystem on Linux? }
+
+
+function FillSystemRandom(Buffer: PByteArray; Len: integer;
+  AllowBlocking: boolean): boolean;
+var
+  rd, dev: integer;
+begin
+  result := false;
+  if Len <= 0 then
+    exit;
+  dev := FileOpenSequentialRead('/dev/urandom');  // non blocking on Linux + BSD
+  if (dev <= 0) and
+     AllowBlocking then
+    dev := FileOpenSequentialRead('/dev/random'); // may block until got entropy
+  if dev > 0 then
+    try
+      rd := 32; // read up to 256 bits - see "man urandom" Usage paragraph
+      if Len <= 32 then
+        rd := Len;
+      result := (FileRead(dev, Buffer[0], rd) = rd);
+      if result and
+         (Len > 32) then
+        RandomBytes(@Buffer[32], Len - 32); // simple gsl_rng_taus2 padding
+    finally
+      FileClose(dev);
+    end;
+  if not result then
+    // OS API call failed -> fallback to our Lecuyer's gsl_rng_taus2 generator
+    RandomBytes(pointer(Buffer), Len);
+end;
+
+function GetDiskInfo(var aDriveFolderOrFile: TFileName;
+  out aAvailableBytes, aFreeBytes, aTotalBytes: QWord): boolean;
+var
+  fs: tstatfs;
+begin
+  if aDriveFolderOrFile = '' then
+    aDriveFolderOrFile := '.';
+  FillCharFast(fs, SizeOf(fs), 0);
+  result := fpStatFS(aDriveFolderOrFile, @fs) = 0;
+  aAvailableBytes := QWord(fs.bavail) * QWord(fs.bsize);
+  aFreeBytes := aAvailableBytes; // no user Quota involved here
+  aTotalBytes := QWord(fs.blocks) * QWord(fs.bsize);
+end;
+
+function GetDiskPartitions: TDiskPartitions;
+var
+  mounts, fs, mnt, typ: RawUtf8;
+  p: PUtf8Char;
+  fn: TFileName;
+  n: integer;
+  av, fr, tot: QWord;
+begin
+  // see https://github.com/gagern/gnulib/blob/master/lib/mountlist.c
+  result := nil;
+  {$ifdef OSLINUXANDROID}
+  mounts := StringFromFile('/proc/self/mounts', {hasnosize=}true);
+  if mounts = '' then
+  {$endif OSLINUXANDROID}
+    mounts := StringFromFile('/etc/mtab', {hasnosize=}true);
+  n := 0;
+  p := pointer(mounts);
+  if p <> nil then // e.g. Darwin has no /etc/mtab :(
+  repeat
+    fs :=  GetNextItem(p);
+    mnt := GetNextItem(p);
+    typ := GetNextItem(p);
+    if (fs <> '') and
+       (fs <> 'rootfs') and
+       not IdemPChar(pointer(fs), '/DEV/LOOP') and
+       (mnt <> '') and
+       (mnt <> '/mnt') and
+       (typ <> '') and
+       not IdemPChars(mnt, ['/PROC/', '/SYS/', '/RUN/']) and
+       not IdemPChars(typ, ['AUTOFS', 'PROC', 'SUBFS', 'DEBUGFS', 'DEVPTS',
+        'FUSECTL', 'MQUEUE', 'RPC-PIPEFS', 'SYSFS', 'DEVFS', 'KERNFS',
+        'IGNORE', 'NONE', 'TMPFS', 'SECURITYFS', 'RAMFS', 'ROOTFS', 'DEVTMPFS',
+        'HUGETLBFS', 'ISO9660']) then
+    begin
+      fn := mnt;
+      if GetDiskInfo(fn, av, fr, tot) and
+         (tot > 1 shl 20) then
+      begin
+  //writeln('fs=',fs,' mnt=',mnt,' typ=',typ, ' av=',av,' fr=',fr,' tot=',tot);
+        if n = length(result) then
+          SetLength(result, NextGrow(n));
+        if length(fs) > 24 then
+          fs := copy(fs, 1, 24) + '..';
+        result[n].name := fs;
+        result[n].mounted := fn;
+        result[n].size := tot;
+        inc(n);
+      end;
+    end;
+    p := GotoNextLine(p);
+  until p = nil;
+  SetLength(result, n);
+end;
+
+{$ifdef OSBSDDARWIN}
+  {$define USEMPROTECT}
+{$else}
+  {$ifdef OSANDROID}
+    {$define USEMPROTECT}
+  {$endif OSANDROID}
+{$endif OSBSDDARWIN}
+
+{$ifdef USEMPROTECT}
+function mprotect(Addr: Pointer; Len: size_t; Prot: integer): integer;
+  cdecl external clib name 'mprotect';
+{$endif USEMPROTECT}
+
+function SynMProtect(addr: pointer; size: size_t; prot: integer): integer;
+begin
+  result := -1;
+  {$ifdef UNIX}
+    {$ifdef USEMPROTECT}
+    result := mprotect(addr, size, prot);
+    {$else}
+    if Do_SysCall(syscall_nr_mprotect, TSysParam(addr), size, prot) >= 0 then
+      result := 0;
+    {$endif USEMPROTECT}
+  {$endif UNIX}
+end;
+
+procedure PatchCode(Old, New: pointer; Size: PtrInt; Backup: pointer;
+  LeaveUnprotected: boolean);
+var
+  PageSize: PtrUInt;
+  AlignedAddr: pointer;
+  i: PtrInt;
+  ProtectedResult, ProtectedMemory: boolean;
+begin
+  if Backup <> nil then
+    for i := 0 to Size - 1 do // do not use Move() here
+      PByteArray(Backup)^[i] := PByteArray(Old)^[i];
+  PageSize := SystemInfo.dwPageSize;
+  AlignedAddr :=
+    Pointer((PtrUInt(Old) div SystemInfo.dwPageSize) * SystemInfo.dwPageSize);
+  while PtrUInt(Old) + PtrUInt(Size) >= PtrUInt(AlignedAddr) + PageSize do
+    inc(PageSize, SystemInfo.dwPageSize);
+  ProtectedResult := SynMProtect(
+    AlignedAddr, PageSize, PROT_READ or PROT_WRITE or PROT_EXEC) = 0;
+  ProtectedMemory := not ProtectedResult;
+  if ProtectedMemory then
+    ProtectedResult := SynMProtect(
+      AlignedAddr, PageSize, PROT_READ or PROT_WRITE) = 0;
+  if ProtectedResult then
+    try
+      for i := 0 to Size - 1 do // do not use Move() here
+        PByteArray(Old)^[i] := PByteArray(New)^[i];
+      if not LeaveUnprotected and
+         ProtectedMemory then
+        SynMProtect(AlignedAddr, PageSize, PROT_READ or PROT_EXEC);
+    except
+      // we ignore any exception here - it should work anyway
+    end;
+end;
+
+const
+  STUB_SIZE = 65536; // 16*4 KB (4 KB = memory granularity)
+  // on most platforms, Compute_FAKEVMT is run once with all JITted stubs
+  // on i386, it needs ArgsSizeInStack adjustement, but only 24 bytes per method
+
+{$ifdef CPUARM}
+
+var
+  StubCallAllocMemLastStart: PtrUInt; // avoid unneeded fpmmap() calls
+
+function StubCallAllocMem(const Size, flProtect: DWORD): pointer;
+const
+  STUB_RELJMP = {$ifdef CPUARM} $7fffff {$else} $7fffffff {$endif}; // rel jmp
+  STUB_INTERV = STUB_RELJMP + 1; // try to reserve in closed stub interval
+  STUB_ALIGN = QWord($ffffffffffff0000); // align to STUB_SIZE
+var
+  start, stop, stub, dist: PtrUInt;
+begin
+  stub := PtrUInt(ArmFakeStubAddr); // = @TInterfacedObjectFake.ArmFakeStub
+  if StubCallAllocMemLastStart <> 0 then
+    start := StubCallAllocMemLastStart
+  else
+  begin
+    start := stub - STUB_INTERV;
+    if start > stub then
+      start := 0; // avoid range overflow
+    start := start and STUB_ALIGN;
+  end;
+  stop := stub + STUB_INTERV;
+  if stop < stub then
+    stop := high(PtrUInt);
+  stop := stop and STUB_ALIGN;
+  while start < stop do
+  begin
+    // try whole -STUB_INTERV..+STUB_INTERV range
+    inc(start, STUB_SIZE);
+    result := fpmmap(pointer(start), STUB_SIZE,
+      flProtect, MAP_PRIVATE or MAP_ANONYMOUS, -1, 0);
+    if result <> MAP_FAILED then
+    begin
+      // close enough for a 24/32-bit relative jump?
+      dist := abs(stub - PtrUInt(result));
+      if dist < STUB_RELJMP then
+      begin
+        StubCallAllocMemLastStart := start;
+        exit;
+      end
+      else
+        fpmunmap(result, STUB_SIZE);
+    end;
+  end;
+  result := MAP_FAILED; // error
+end;
+
+{$else}
+
+// other platforms (Intel+Arm64) use plain Kernel call and PtrInt jump
+function StubCallAllocMem(const Size, flProtect: DWORD): pointer;
+begin
+  result := fpmmap(nil, STUB_SIZE,
+    flProtect, MAP_PRIVATE OR MAP_ANONYMOUS, -1, 0);
+end;
+
+{$endif CPUARM}
+
+
+{ ****************** Unix Daemon and Windows Service Support }
+
+// Linux/POSIX signal interception
+
+var
+  SynDaemonIntercepted: boolean;
+  SynDaemonInterceptLog: TSynLogProc;
+
+procedure DoShutDown(Sig: integer; Info: PSigInfo; Context: PSigContext); cdecl;
+var
+  level: TSynLogLevel;
+  si_code: integer;
+  text: string[4]; // code below has no memory allocation
+begin
+  if Assigned(SynDaemonInterceptLog) then
+  begin
+    case Sig of
+      SIGQUIT:
+        text := 'QUIT';
+      SIGTERM:
+        text := 'TERM';
+      SIGINT:
+        text := 'INT';
+      SIGABRT:
+        text := 'ABRT';
+    else
+      text := 'SIG';
+    end;
+    if Sig = SIGTERM then
+      // polite quit
+      level := sllInfo
+    else
+       // abort after panic
+      level := sllExceptionOS;
+    if Info = nil then
+      si_code := 0
+    else
+      si_code := Info^.si_code;
+    SynDaemonInterceptLog(level,
+      'SynDaemonIntercepted received SIG%=% si_code=%',
+      [text, Sig, si_code], nil);
+  end;
+  SynDaemonTerminated := Sig;
+end;
+
+procedure SynDaemonIntercept(const onlog: TSynLogProc);
+var
+  sa: SigactionRec;
+begin
+  // note: SIGFPE/SIGSEGV/SIGBUS/SIGILL are handled by the RTL
+  if SynDaemonIntercepted then
+    exit;
+  GlobalLock;
+  try
+    if SynDaemonIntercepted then
+      exit;
+    SynDaemonInterceptLog := onlog;
+    FillCharFast(sa, SizeOf(sa), 0);
+    sa.sa_handler := @DoShutDown;
+    fpSigaction(SIGQUIT, @sa, nil);
+    fpSigaction(SIGTERM, @sa, nil);
+    fpSigaction(SIGINT,  @sa, nil);
+    fpSigaction(SIGABRT, @sa, nil);
+    SynDaemonIntercepted := true; // flag set AFTER interception
+  finally
+    GlobalUnLock;
+  end;
+end;
+
+var
+  SigPipeDisabled: boolean; // process-wide thread-safe flag
+
+// TO INVESTIGATE: we may use per-thread signal masking instead
+// http://www.microhowto.info/howto/ignore_sigpipe_without_affecting_other_threads_in_a_process.html
+
+procedure DoNothing(Sig: integer; Info: PSigInfo; Context: PSigContext); cdecl;
+begin
+end;
+
+procedure SigPipeIntercept;
+var
+  sa: SigactionRec;
+begin
+  if SigPipeDisabled then
+    exit; // quickly return if already done
+  GlobalLock;
+  try
+    if SigPipeDisabled then
+      exit;
+    FillCharFast(sa, SizeOf(sa), 0);
+    sa.sa_handler := @DoNothing;
+    fpSigaction(SIGPIPE, @sa, nil);
+    SigPipeDisabled := true; // flag set AFTER disabling it
+  finally
+    GlobalUnLock;
+  end;
+end;
+
+type
+  TPasswd = record
+    pw_name: PAnsiChar;    // user name
+    pw_passwd: PAnsiChar;  // encrypted password
+    pw_uid: TUid;	   // user uid
+    pw_gid: TGid;	   // user gid
+    // following fields are not consistent on BSD or Linux, but not needed
+  end;
+  PPasswd  = ^TPasswd;
+
+// retrieve information of a given user by name
+function getpwnam(name: PAnsiChar): PPasswd;
+  cdecl external clib name 'getpwnam';
+
+// sets the supplementary group IDs for the calling process
+function setgroups(n: size_t; groups: PGid): integer;
+  cdecl external clib name 'setgroups';
+
+function setuid(uid: TUid): integer;
+  cdecl external clib name 'setuid';
+function setgid(gid: TGid): integer;
+  cdecl external clib name 'setgid';
+
+// changes the root directory of the calling process
+function chroot(rootpath: PAnsiChar): integer;
+  cdecl external clib name 'chroot';
+
+function DropPriviledges(const UserName: RawUtf8): boolean;
+var
+  pwnam: PPasswd;
+begin
+  result := false;
+  pwnam := getpwnam(pointer(UserName));
+  if (pwnam = nil) or
+     ((setgid(pwnam.pw_gid) <> 0) and
+      (fpgeterrno <> ESysEPERM)) or
+     ((setuid(pwnam.pw_uid) <> 0) and
+      (fpgeterrno <> ESysEPERM)) then
+    exit;
+  result := true;
+end;
+
+function ChangeRoot(const FolderName: RawUtf8): boolean;
+begin
+  result := (FolderName <> '') and
+            (FpChdir(pointer(FolderName)) = 0) and
+            (chroot('.') = 0);
+end;
+
+function RunUntilSigTerminatedPidFile(ensureWritable: boolean): TFileName;
+var
+  pidpath: TFileName;
+begin
+  pidpath := RunUntilSigTerminatedPidFilePath;
+  if pidpath = '' then
+    pidpath := Executable.ProgramFilePath;
+  if not ensureWritable then
+  begin
+    result := Format('%s.%s.pid', [pidpath, Executable.ProgramName]);
+    if FileExists(result) then
+      exit;
+  end;
+  if not IsDirectoryWritable(pidpath) then
+    // if the executable folder is not writable, use the temporary folder
+    pidpath := GetSystemPath(spTemp);
+  result := Format('%s.%s.pid', [pidpath, Executable.ProgramName]);
+end;
+
+function RunUntilSigTerminatedState: TServiceState;
+begin
+  if FileExists(RunUntilSigTerminatedPidFile(false)) then
+    result := ssRunning
+  else
+    result := ssStopped;
+end;
+
+function RunUntilSigTerminatedForKill(waitseconds: integer): boolean;
+var
+  pid: PtrInt;
+  pidfilename: TFileName;
+  tix: Int64;
+begin
+  result := false;
+  pidfilename := RunUntilSigTerminatedPidFile;
+  pid := GetInteger(pointer(StringFromFile(pidfilename)));
+  if pid <= 0 then
+    exit;
+  if fpkill(pid, SIGTERM) <> 0 then // polite quit
+    if fpgeterrno <> ESysESRCH then
+      exit
+    else
+      // ESysESRCH = no such process -> try to delete the .pid file
+      if DeleteFile(pidfilename) then
+      begin
+        result := true; // process crashed or hard reboot -> nothing to kill
+        exit;
+      end;
+  if waitseconds <= 0 then
+  begin
+    result := true;
+    exit;
+  end;
+  tix := GetTickCount64 + waitseconds * MilliSecsPerSec;
+  repeat
+    // RunUntilSigTerminated() below should delete the .pid file
+    sleep(10);
+    if not FileExists(pidfilename) then
+      result := true;
+  until result or
+        (GetTickCount64 > tix);
+  if not result then
+    fpkill(pid, SIGKILL); // murder with finesse
+end;
+
+procedure CleanAfterFork;
+begin
+  fpUMask(0); // reset file mask
+  chdir('/'); // avoid locking current directory
+  Close(input);
+  AssignFile(input, '/dev/null');
+  ReWrite(input);
+  Close(output);
+  AssignFile(output, '/dev/null');
+  ReWrite(output);
+  Close(stderr);
+end;
+
+procedure RunUntilSigTerminated(daemon: TObject; dofork: boolean;
+  const start, stop: TThreadMethod; const onlog: TSynLogProc;
+  const servicename: string);
+var
+  pid, sid: TPID;
+  pidfilename: TFileName;
+  s: AnsiString;
+const
+  TXT: array[boolean] of string[4] = ('run', 'fork');
+begin
+  SynDaemonIntercept(onlog);
+  if dofork then
+  begin
+    pidfilename := RunUntilSigTerminatedPidFile;
+    pid := GetInteger(pointer(StringFromFile(pidfilename)));
+    if pid > 0 then
+      if (fpkill(pid, 0) = 0) or
+         not DeleteFile(pidfilename) then
+        raise EOSException.CreateFmt(
+          '%s.CommandLine Fork failed: %s is already forked as pid=%d',
+          [ClassNameShort(daemon)^, Executable.ProgramName, PtrInt(pid)]);
+    pid := fpFork;
+    if pid < 0 then
+      raise EOSException.CreateFmt(
+        '%s.CommandLine Fork failed', [ClassNameShort(daemon)^]);
+    if pid > 0 then  // main program - just terminate
+      exit;
+    // clean forked instance
+    sid := fpSetSID;
+    if sid < 0 then // new session (process group) created?
+      raise EOSException.CreateFmt(
+        '%s.CommandLine SetSID failed', [ClassNameShort(daemon)^]);
+    CleanAfterFork;
+    // create local .[Executable.ProgramName].pid file
+    pid := fpgetpid;
+    str(pid, s);
+    FileFromString(s, pidfilename);
+  end;
+  try
+    if Assigned(onlog) then
+      onlog(sllNewRun, 'Start % /% %',
+        [servicename, TXT[dofork], Executable.Version.DetailedOrVoid], nil);
+    Start;
+    while SynDaemonTerminated = 0 do
+      if GetCurrentThreadID = MainThreadID then
+        CheckSynchronize(100)
+      else
+        Sleep(100);
+  finally
+    if Assigned(onlog) then
+      onlog(sllNewRun, 'Stop /% from Sig=%',
+        [TXT[dofork], SynDaemonTerminated], nil);
+    try
+      Stop;
+    finally
+      if dofork and
+         (pidfilename <> '') then
+      begin
+        DeleteFile(pidfilename);
+        if Assigned(onlog) then
+          onlog(sllTrace, 'RunUntilSigTerminated: deleted file %',
+            [pidfilename], nil);
+      end;
+    end;
+  end;
+end;
+
+function RunInternal(args: PPAnsiChar; waitfor: boolean; const env: TFileName;
+  options: TRunOptions): integer;
+var
+  pid: TPID;
+  e: array[0..511] of PAnsiChar; // max 512 environment variables
+  envpp: PPAnsiChar;
+  P: PAnsiChar;
+  n: PtrInt;
+begin
+  {$ifdef FPC}
+  {$if (defined(BSD) or defined(SUNOS)) and defined(FPC_USE_LIBC)}
+  pid := FpvFork;
+  {$else}
+  pid := FpFork;
+  {$ifend}
+  {$else}
+  'only FPC is supported yet';
+  {$endif FPC}
+  if pid < 0 then
+  begin
+    // fork failed
+    result := -1;
+    exit;
+  end;
+  if pid = 0 then
+  begin
+    // we are in child process -> switch to new executable
+    if not waitfor then
+      // don't share the same console
+      CleanAfterFork;
+    envpp := envp;
+    if env <> '' then
+    begin
+      n := 0;
+      result := -ESysE2BIG;
+      if (roEnvAddExisting in options) and
+         (envpp <> nil) then
+      begin
+        while envpp^ <> nil do
+        begin
+          if PosChar(envpp^, #10) = nil then
+          begin
+            // filter to add only single-line variables
+            if n = high(e) - 1 then
+              exit;
+            e[n] := envpp^;
+            inc(n);
+          end;
+          inc(envpp);
+        end;
+      end;
+      P := pointer(env); // env follows Windows layout 'n1=v1'#0'n2=v2'#0#0
+      while P^ <> #0 do
+      begin
+        if n = high(e) - 1 then
+          exit;
+        e[n] := P; // makes POSIX compatible
+        inc(n);
+        inc(P, StrLen(P) + 1);
+      end;
+      e[n] := nil; // end with null
+      envpp := @e;
+    end;
+    FpExecve(args^, args, envpp);
+    FpExit(127);
+  end;
+  if waitfor then
+  begin
+    result := WaitProcess(pid);
+    if result = 127 then
+      // execv() failed in child process
+      result := -result;
+  end
+  else
+    // fork success (don't wait for the child process to fail)
+    result := 0;
+end;
+
+function RunProcess(const path, arg1: TFileName; waitfor: boolean;
+  const arg2, arg3, arg4, arg5, env: TFileName;
+  options: TRunOptions): integer;
+var
+  a: array[0..6] of PAnsiChar; // assume no UNICODE on POSIX, i.e. as TFileName
+begin
+  a[0] := pointer(path);
+  a[1] := pointer(arg1);
+  a[2] := pointer(arg2);
+  a[3] := pointer(arg3);
+  a[4] := pointer(arg4);
+  a[5] := pointer(arg5);
+  a[6] := nil; // end pointer list with null
+  result := RunInternal(@a, waitfor, env, options);
+end;
+
+function RunCommand(const cmd: TFileName; waitfor: boolean;
+  const env: TFileName; options: TRunOptions; parsed: PParseCommands): integer;
+var
+  temp: RawUtf8;
+  err: TParseCommands;
+  a: TParseCommandsArgs;
+begin
+  err := ParseCommandArgs(cmd, @a, nil, @temp);
+  if parsed <> nil then
+    parsed^ := err;
+  if err = [] then
+    // no need to spawn the shell for simple commands
+    result := RunInternal(a, waitfor, env, options)
+  else if err * PARSECOMMAND_ERROR <> [] then
+    // no system call for clearly invalid command line
+    result := -ESysEPERM
+  else
+  begin
+    // execute complex commands via the shell
+    a[0] := '/bin/sh';
+    a[1] := '-c';
+    a[2] := pointer(cmd);
+    a[3] := nil;
+    result := RunInternal(@a, waitfor, env, options);
+  end;
+end;
+
+function RunRedirect(const cmd: TFileName; exitcode: PInteger;
+  const onoutput: TOnRedirect; waitfordelayms: cardinal;
+  setresult: boolean; const env, wrkdir: TFileName; options: TRunOptions): RawByteString;
+var
+  // notes: - FPC popen() allows access to the pid whereas clib popen() won't
+  //        - env and options params are not supported by popen() so are ignored
+  f: file;
+  fd: THandle;
+  pid, res, wr: cint;
+  n, l: TSsize;
+  wait: cardinal;
+  endtix: Int64;
+  tmp: array[word] of byte; // 64KB stack buffer
+
+  function RedirectOutput(flush: boolean; var redir: RawByteString): boolean;
+  var
+    u: RawUtf8;
+  begin
+    result := false; // return false on pipe closed
+    if WaitReadPending(fd, wait) then
+    begin
+      n := fpread(fd, tmp, SizeOf(tmp));
+      if n < 0 then
+        exit; // pipe closed = execution finished
+      if setresult and
+         (n <> 0) then
+      begin
+        if redir = '' then
+          FastSetString(RawUtf8(redir), @tmp, n) // assume CP_UTF8
+        else
+        begin
+          SetLength(redir, l + n); // append
+          MoveFast(tmp, PByteArray(redir)[l], n);
+        end;
+        inc(l, n);
+      end;
+      if Assigned(onoutput) then
+      begin
+        FastSetString(u, @tmp, n); // console output is likely UTF-8 on POSIX
+        if onoutput(u, pid) and
+           not flush then
+          endtix := 1; // returned true: force kill() on abort
+      end;
+    end
+    else if Assigned(onoutput) and // idle
+            onoutput('', pid) and
+            not flush then
+      endtix := 1; // returned true to abort -> kill()
+    result := true;
+  end;
+
+begin
+  result := '';
+  if wrkdir <> '' then
+    ChDir(wrkdir);
+  if popen(f, cmd, 'r') <> 0 then // fork and launch cmd - env is ignored by now
+    exit;
+  fd := TFileRec(f).Handle;
+  pid := pcint(@TFileRec(f).userdata[2])^; // see popen() from Unix.pp
+  if Assigned(onoutput) then
+    onoutput('', pid);
+  wait := 200;
+  if waitfordelayms = INFINITE then
+    endtix := 0
+  else
+  begin
+    endtix := GetTickCount64 + waitfordelayms;
+    if waitfordelayms < wait then
+      wait := waitfordelayms;
+  end;
+  l := 0;
+  repeat
+    if not RedirectOutput({flush=}false, result) then
+      break; // pipe closed = execution finished
+    if (endtix <> 0) and
+       (GetTickCount64 > endtix) then
+    begin
+      // abort process execution after timeout or onoutput()=true
+      if RunAbortTimeoutSecs > 0 then
+      begin
+        // try gracefull death
+        if (ramSigTerm in RunAbortMethods) and
+           (fpkill(pid, SIGTERM) = 0) then
+        begin
+          endtix := GetTickCount64 + RunAbortTimeoutSecs * 1000;
+          repeat
+            wr := FpWaitPid(pid, @res, WNOHANG);  // 0 = no state change
+            RedirectOutput({flush=}true, result); // continue redirection
+            if (wr <> 0) or
+               (GetTickCount64 > endtix) then
+              break;
+            SleepHiRes(5);
+          until false;
+          if wr = pid then // <0 for error
+            break; // gracefully ended
+        end;
+      end;
+      // force process termination
+      fpkill(pid, SIGKILL);
+      pid := 0;
+      break;
+    end;
+  until false;
+  res := pclose(f);
+  if exitcode <> nil then
+    if pid = 0 then
+      exitcode^ := -1
+    else
+      exitcode^ := res;
+end;
+
+
+{ ****************** Gather Operating System Information }
+
+{$ifdef OSANDROID}
+
+function GetSmbEfiMem: RawByteString;
+begin
+  result := '';
+end;
+
+const
+  getpagesize = 4096;
+
+{$else}
+function getpagesize: integer;
+  cdecl external clib name 'getpagesize';
+{$endif OSANDROID}
+
+{$ifdef OSLINUX}
+
+function get_nprocs: integer;
+  cdecl external clib name 'get_nprocs';
+
+procedure SetLinuxDistrib(const release: RawUtf8);
+var
+  distrib: TOperatingSystem;
+  rel, dist: RawUtf8;
+begin
+  rel := UpperCase(release);
+  for distrib := osArch to high(distrib) do
+  begin
+    dist := UpperCase(OS_NAME[distrib]);
+    if PosEx(dist, rel) > 0 then
+    begin
+      OS_KIND := distrib;
+      break;
+    end;
+  end;
+end;
+
+function clock_gettime_c(clk_id: clockid_t; tp: ptimespec): cint;
+begin
+  // FPC only knows the regular clocks: convert to the *_FAST version
+  case clk_id of
+    // 1 ms resolution is good enough for milliseconds-based RTL functions
+    CLOCK_REALTIME:
+      clk_id := CLOCK_REALTIME_FAST;
+    CLOCK_MONOTONIC:
+      clk_id := CLOCK_MONOTONIC_FAST;
+    // no CLOCK_MONOTONIC_RAW redirect because it doesn't match CLOCK_MONOTONIC
+    // and cthreads.pp forces pthread_condattr_setclock(CLOCK_MONOTONIC_RAW)
+  end;
+  // it is much faster to not use the Linux syscall but the libc vDSO call
+  result := clock_gettime(clk_id, tp);
+end;
+
+function gettimeofday_c(tp: ptimeval; tzp: ptimezone): cint;
+begin
+  // it is much faster to not use the Linux syscall but the libc vDSO call
+  result := gettimeofday(tp, tzp);
+end;
+
+function GetSmbEfiMem: RawByteString;
+var
+  efi, addr: RawUtf8;
+  xaddr: cardinal;
+begin
+  // retrieve raw EFI information from systab
+  result := '';
+  xaddr := 0;
+  efi := StringFromFile('/sys/firmware/efi/systab', {nosize=}true);
+  if efi = '' then
+    efi := StringFromFile('/proc/efi/systab', {nosize=}true); // old Linux<2.6.6
+  if efi = '' then
+    exit;
+  FindNameValue(efi, 'SMBIOS', addr);
+  xaddr := PosixParseHex32(pointer(addr));
+  if xaddr <> 0 then
+    result := ReadSystemMemory(xaddr, 32); // 32 bytes is enough
+end;
+
+// on Android, /sys/class/net is not readable from the standard user :(
+function _GetSystemMacAddress: TRawUtf8DynArray;
+var
+  SR: TSearchRec;
+  fn: TFileName;
+  f: RawUtf8;
+begin
+  result := nil;
+  if FindFirst('/sys/class/net/*', faDirectory, SR) <> 0 then
+    exit;
+  repeat
+    if (SR.Name <> 'lo') and
+       not IdemPChar(pointer(SR.Name), 'DOCKER') and
+       SearchRecValidFolder(SR) then
+    begin
+      fn := '/sys/class/net/' + SR.Name;
+      f := StringFromFile(fn + '/flags', {nosize=}true);
+      if (length(f) > 2) and // e.g. '0x40' or '0x1043'
+         (PosixParseHex32(pointer(f)) and {IFF_LOOPBACK:}8 = 0) then
+      begin
+        f := TrimU(StringFromFile(fn + '/address', {nosize=}true));
+        if f <> '' then
+        begin
+          SetLength(result, length(result) + 1);
+          result[high(result)] := f;
+        end;
+      end;
+    end;
+  until FindNext(SR) <> 0;
+  FindClose(SR);
+end;
+
+{$endif OSLINUX}
+
+{$ifdef CPUARM3264} // POSIX libc is faster than FPC RTL or our pascal code
+
+function libc_strlen(s: PAnsiChar): SizeInt;
+  cdecl external clib name 'strlen';
+
+function libc_memmove(dst, src: pointer; n: SizeInt): pointer;
+  cdecl external clib name 'memmove';
+
+function libc_memset(dst: pointer; c: integer; n: SizeInt): pointer;
+  cdecl external clib name 'memset';
+
+function StrLenLibc(s: PAnsiChar): SizeInt;
+begin
+  if s = nil then
+    result := PtrUInt(s)
+  else
+    result := libc_strlen(s);
+end;
+
+procedure MoveFastLibC(const source; var dest; count: SizeInt);
+begin
+  if (@dest <> @source) and
+     (count > 0) then
+    libc_memmove(@dest, @source, count);
+end;
+
+procedure FillCharLibC(var dest; count: PtrInt; value: byte);
+begin
+  if (@dest <> nil) and
+     (count > 0) then
+    libc_memset(@dest, value, count);
+end;
+
+{$ifdef OSLINUXANDROID}
+
+procedure RetrieveCpuInfoArm;
+begin
+  if CpuFeatures = [] then
+  begin
+    // fallback to /proc/cpuinfo "Features:" text
+    if PosEx(' aes', CpuInfoFeatures) >= 0 then
+      include(CpuFeatures, ahcAes);
+    if PosEx(' pmull', CpuInfoFeatures) >= 0 then
+      include(CpuFeatures, ahcPmull);
+    if PosEx(' sha1', CpuInfoFeatures) >= 0 then
+      include(CpuFeatures, ahcSha1);
+    if PosEx(' sha2', CpuInfoFeatures) >= 0 then
+      include(CpuFeatures, ahcSha2);
+    if PosEx(' crc32', CpuInfoFeatures) >= 0 then
+      include(CpuFeatures, ahcCrc32);
+  end;
+end;
+
+{$endif OSLINUXANDROID}
+
+{$endif CPUARM3264}
+
+function Hex2Dec(c: AnsiChar): integer; inline;
+begin
+  result := ord(c);
+  case c of
+    '0'..'9':
+      dec(result, ord('0'));
+    'A'..'Z':
+      dec(result, ord('A') - 10);
+    'a'..'z':
+      dec(result, ord('a') - 10);
+  else
+    result := -1;
+  end;
+end;
+
+// this function is published in interface section for mormot.net.sock.posix.inc
+function PosixParseHex32(p: PAnsiChar): integer;
+var
+  v0, v1: integer;
+begin
+  result := 0;
+  p := StrScan(p, 'x');
+  if p = nil then
+    exit;
+  repeat
+    inc(p); // points to trailing 'x' at start
+    v0 := Hex2Dec(p^);
+    if v0 < 0 then
+      break; // not in '0'..'9','a'..'f'
+    inc(p);
+    v1 := Hex2Dec(p^);
+    if v1 < 0 then
+    begin
+      result := (result shl 4) or v0; // only one char left
+      break;
+    end;
+    result := (result shl 8) or (v0 shl 4) or v1;
+  until false;
+end;
+
+procedure ParseHex(p: PAnsiChar; b: PByte; n: integer);
+var
+  v0, v1: integer;
+begin
+  repeat // caller ensured p<>nil and b<>nil and n>0
+    v0 := Hex2Dec(p^);
+    if v0 < 0 then
+      break; // not in '0'..'9','a'..'f'
+    inc(p);
+    v1 := Hex2Dec(p^);
+    if v1 < 0 then
+      break;
+    inc(p);
+    b^ := (v0 shl 4) or v1;
+    inc(b);
+    dec(n);
+  until n = 0;
+end;
+
+procedure ParseHex32Add(p: PAnsiChar; var result: TIntegerDynArray);
+var
+  v: integer;
+begin
+  v := PosixParseHex32(p);
+  if v <> 0 then
+    AddInteger(result, v, {nodup=}true);
+end;
+
+function ParseLine(P: PUtf8Char): PUtf8Char;
+begin
+  if P <> nil then
+    P := strscan(P, ':');
+  result := P;
+  if P = nil then
+    exit;
+  repeat
+    inc(P);
+  until (P^ = #0) or
+        (P^ > ' ');
+  result := P;
+  while not (ord(P^) in [0, 10, 13]) do
+  begin
+    if P^ < ' ' then
+      P^ := ' '; // change any tab into space
+    inc(P);
+  end;
+  P^ := #0; // make asciiz
+end;
+
+function ParseInt(P: PUtf8Char): integer;
+begin
+  P := ParseLine(P);
+  if (P <> nil) and
+     (P^ in ['0'..'9']) then
+    result := GetCardinal(P)
+  else
+    result := -1;
+end;
+
+{$ifdef CPUAARCH64}
+{$ifdef OSLINUXANDROID}
+// AARCH64 armv8.o is only validated on Linux
+// (it should work on other POSIX ABI, but was reported to fail)
+
+{$define ARMV8STATIC}
+{$L ..\..\static\aarch64-linux\armv8.o} // ARMv8 crc32c Linux code
+
+function crc32carm64(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; external;
+function crc32arm64(crc: cardinal; buf: PAnsiChar; len: cardinal): cardinal; external;
+function crc32cby4arm64(crc, value: cardinal): cardinal; external;
+procedure crc32blockarm64(crc128, data128: PBlock128); external;
+procedure crc32blocksarm64(crc128, data128: PBlock128; count: integer); external;
+
+{$endif OSLINUXANDROID}
+{$endif CPUAARCH64}
+
+procedure InitializeSpecificUnit;
+var
+  P: PAnsiChar;
+  modname, beg: PUtf8Char;
+  uts: UtsName;
+  {$ifndef NODIRECTTHREADMANAGER}
+  tm: TThreadManager;
+  {$endif NODIRECTTHREADMANAGER}
+  {$ifndef OSDARWIN}
+  {$ifdef CPUARM3264}
+  act, aci: TIntegerDynArray;
+  i: PtrInt;
+  {$endif CPUARM3264}
+  tp: timespec;
+  {$endif OSDARWIN}
+  {$ifdef OSBSDDARWIN}
+  temp1, temp2: ShortString;
+  {$else}
+  hw, cache, cpuinfo: PUtf8Char;
+  proccpuinfo, release, prod: RawUtf8;
+  procid, phyid, phyndx: integer;
+  phy: TIntegerDynArray;
+  {$ifdef OSLINUX}
+  prodver, dist: RawUtf8;
+  SR: TSearchRec;
+  si: TSysInfo;  // Linuxism
+
+  function GetSysFile(const fn: TFileName): RawUtf8;
+  begin
+    result := TrimU(StringFromFile(fn, true));
+    if result = 'Default string' then // e.g. on ProxMox containers or VMs
+      result := '';
+  end;
+  {$endif OSLINUX}
+  {$endif OSBSDDARWIN}
+begin
+  // retrieve Kernel and Hardware information
+  StdOutIsTTY := not IsDebuggerPresent and
+                 (IsATTY(StdOutputHandle) = 1) and
+                 IdemPChars(RawUtf8(GetEnvironmentVariable('TERM')), [
+                   'XTERM', 'SCREEN', 'TMUX', 'RXVT', 'LINUX', 'CYGWIN']);
+  modname := nil;
+  fpuname(uts);
+  {$ifdef OSBSDDARWIN}
+  // pure FreeBSD NetBSD MacOS branch
+  SystemInfo.dwNumberOfProcessors := fpsysctlhwint(HW_NCPU);
+  beg := fpsysctlhwstr(HW_MACHINE, temp1);
+  {$ifdef OSDARWIN}
+  if strscan(beg, ' ') = nil then // e.g. from a Parallels VM
+    beg := fpsysctlhwstr(HW_MODEL, temp1);
+  modname := fpsysctlbynamehwstr('machdep.cpu.brand_string', temp2);
+  {$endif OSDARWIN}
+  FastSetString(BiosInfoText, beg, StrLen(beg));
+  if modname = nil then
+    modname := fpsysctlhwstr(HW_MODEL, temp2);
+  with uts do
+    OSVersionText := sysname + '-' + release + ' ' + version;
+  {$ifdef OSDARWIN}
+  // pure MACOS branch
+  CpuCache[1].LineSize := fpsysctlhwint(HW_CACHELINE);
+  CpuCache[1].Size     := fpsysctlhwint(HW_L1DCACHESIZE);
+  CpuCache[2].LineSize := fpsysctlhwint(HW_CACHELINE);
+  CpuCache[2].Size     := fpsysctlhwint(HW_L2CACHESIZE);
+  CpuCache[3].LineSize := fpsysctlhwint(HW_CACHELINE);
+  CpuCache[3].Size     := fpsysctlhwint(HW_L3CACHESIZE);
+  CpuCacheSize := CpuCache[3].Size;
+  if CpuCacheSize = 0 then
+    CpuCacheSize := CpuCache[2].Size;
+  if CpuCacheSize = 0 then
+    CpuCacheSize := CpuCache[1].Size;
+  if CpuCacheSize <> 0 then
+    _fmt('L1=%s L2=%s L3=%s', [_oskb(CpuCache[1].Size),
+      _oskb(CpuCache[2].Size), _oskb(CpuCache[3].Size)], CpuCacheText);
+  SystemMemorySize := fpsysctlhwint(HW_MEMSIZE);
+  {$else}
+  SystemMemorySize := fpsysctlhwint(HW_PHYSMEM);
+  {$endif OSDARWIN}
+  {$else}
+  {$ifdef OSANDROID}
+  // pure ANDROID branch
+  release := GetSystemProperty('ro.build.version.release');
+  prod := TrimU(RawUtf8(GetSystemProperty('ro.product.brand') + ' ' +
+                        GetSystemProperty('ro.product.name') + ' ' +
+                        GetSystemProperty('ro.product.device')));
+  {$else}
+  // pure LINUX branch
+  GetSystemMacAddress := _GetSystemMacAddress;
+  if Sysinfo(@si) = 0 then
+    SystemMemorySize := si.totalram * si.mem_unit;
+  prod := TrimU(GetSysFile('/sys/class/dmi/id/sys_vendor') + ' ' +
+                GetSysFile('/sys/class/dmi/id/product_name'));
+  if prod <> '' then
+  begin // e.g. 'QEMU KVM Virtual Machine' or 'LENOVO 20HES23B0U'
+    prodver := GetSysFile('/sys/class/dmi/id/product_version');
+    if prodver <> '' then
+      prod := prod + ' ' + prodver;
+  end
+  else
+    // return e.g. 'Raspberry Pi 3 Model B Rev 1.2'
+    prod := GetSysFile('/proc/device-tree/model');
+  FindNameValue(StringFromFile('/etc/os-release', true),
+    'PRETTY_NAME=', release);
+  if (release <> '') and
+     (release[1] = '"') then
+    release := copy(release, 2, length(release) - 2);
+  TrimSelf(release);
+  if release = '' then
+  begin
+    FindNameValue(StringFromFile('/etc/lsb-release', true),
+      'DISTRIB_DESCRIPTION=', release);
+    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 := SR.Name; // 'redhat-release' 'SuSE-release'
+    if IdemPChar(pointer(release), 'LSB-') and
+       (FindNext(SR) = 0) then
+      release := SR.Name;
+    release := split(release, '-');
+    dist := split(StringFromFile('/etc/' + SR.Name, true), #10);
+    if (dist <> '') and
+       (PosExChar('=', dist) = 0) and
+       (PosExChar(' ', dist) > 0) then
+      // e.g. 'Red Hat Enterprise Linux Server release 6.7 (Santiago)'
+      SetLinuxDistrib(dist)
+    else
+      dist := '';
+    FindClose(SR);
+  end;
+  if (release <> '') and
+     (OS_KIND = osLinux) then
+  begin
+    SetLinuxDistrib(release);
+    if (OS_KIND = osLinux) and
+       ({%H-}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;
+  {$endif OSANDROID}
+  BiosInfoText := prod;
+  hw := nil;
+  cache := nil;
+  SystemInfo.dwNumberOfProcessors := 0;
+  proccpuinfo := StringFromFile('/proc/cpuinfo', true);
+  procid := -1;
+  cpuinfo := pointer(proccpuinfo);
+  while cpuinfo <> nil do
+  begin
+    beg := cpuinfo;
+    cpuinfo := GotoNextLine(cpuinfo);
+    if IdemPChar(beg, 'PROCESSOR') then
+      if beg^ = 'P' then
+        modname := ParseLine(beg) // Processor : ARMv7
+      else
+      begin
+        // loop over all "processor : 0 .. 1 .. 2" lines to count the CPUs
+        inc(SystemInfo.dwNumberOfProcessors);
+        procid := ParseInt(beg);
+        if procid >= integer(SystemInfo.dwNumberOfProcessors) then
+          procid := -1; // paranoid
+      end
+    else if IdemPChar(beg, 'MODEL NAME') then
+      modname := ParseLine(beg)
+    else if IdemPChar(beg, 'FEATURES') or
+            IdemPChar(beg, 'FLAGS') then
+      CpuInfoFeatures := ParseLine(beg)
+    else if IdemPChar(beg, 'HARDWARE') then
+      hw := ParseLine(beg)
+    else if IdemPChar(beg, 'CACHE SIZE') then
+      cache := ParseLine(beg)
+    {$ifdef CPUARM3264}
+    else if IdemPChar(beg, 'CPU IMPLEMENTER') then
+      ParseHex32Add(beg, aci)
+    else if IdemPChar(beg, 'CPU PART') then
+      ParseHex32Add(beg, act)
+    {$endif CPUARM3264}
+    else if IdemPChar(beg, 'PHYSICAL ID') then
+    begin
+      phyid := ParseInt(beg); // in practice, may be 0,3,... and not 0,1,...
+      if phyid < 0 then
+        continue;
+      phyndx := IntegerScanIndex(pointer(phy), CpuSockets, phyid);
+      if phyndx < 0 then
+      begin
+        AddInteger(phy, CpuSockets, phyid);
+        SetLength(CpuSocketsMask, CpuSockets);
+        phyndx := CpuSockets - 1;
+      end;
+      if (procid >= 0) and
+         (procid < SizeOf(TCpuSet) shl 3) then
+        SetBitPtr(@CpuSocketsMask[phyndx], procid);
+    end;
+  end;
+  {$ifdef CPUARM3264}
+  if act <> nil then // CPU part/implementer are more detailed than model name
+  begin
+    proccpuinfo := '';
+    for i := 0 to high(aci) do // there should be a single implementer
+      proccpuinfo := proccpuinfo +
+        ArmCpuImplementerName(ArmCpuImplementer(aci[i]), aci[i]) + ' ';
+    proccpuinfo := proccpuinfo + ArmCpuTypeName(ArmCpuType(act[0]), act[0]);
+    for i := 1 to high(act) do // but there may be several parts/models
+      proccpuinfo := proccpuinfo + ' / ' + ArmCpuTypeName(ArmCpuType(act[i]), act[i]);
+    modname := pointer(proccpuinfo);
+  end;
+  RetrieveCpuInfoArm;
+  {$endif CPUARM3264}
+  if hw <> nil then
+  begin
+    prod := hw;
+    if BiosInfoText = '' then
+      BiosInfoText := prod
+    else
+      BiosInfoText := BiosInfoText + ' (' + prod + ')';
+  end else if BiosInfoText = '' then
+    BiosInfoText := 'Generic ' + CPU_ARCH_TEXT + ' system'; // noname computer
+  if cache <> nil then
+  begin
+    CpuCacheText := TrimU(cache);
+    CpuCacheSize := GetNextCardinal(cache);
+    while cache^ = ' ' do
+      inc(cache);
+    case upcase(cache^) of
+      'K':
+        CpuCacheSize := CpuCacheSize shl 10;
+      'M':
+        CpuCacheSize := CpuCacheSize shl 20;
+      'G':
+        CpuCacheSize := CpuCacheSize shl 30;
+    end;
+  end;
+  SystemInfo.release := release;
+  {$endif OSBSDDARWIN}
+  SystemInfo.dwPageSize := getpagesize; // call libc API
+  if CpuCacheSize <> 0 then
+    _fmt('[%s]', [_oskb(CpuCacheSize)], CpuInfoText);
+  if CpuSockets = 0 then
+    CpuSockets := 1;
+  SystemInfo.uts.release := uts.Release;
+  SystemInfo.uts.sysname := uts.Sysname;
+  SystemInfo.uts.version := uts.Version;
+  P := @uts.release[0];
+  KernelRevision := GetNextCardinal(P) shl 16 +
+                    GetNextCardinal(P) shl 8 +
+                    GetNextCardinal(P);
+  OSVersion32.os := OS_KIND;
+  MoveByOne(@KernelRevision, @OSVersion32.utsrelease, 3); // 24-bit
+  with SystemInfo.uts do
+    OSVersionText := sysname + ' ' + release;
+  if SystemInfo.release <> '' then
+    OSVersionText := SystemInfo.release + ' - ' + OSVersionText;
+  {$ifdef OSANDROID}
+  OSVersionText := 'Android (' + OSVersionText + ')';
+  {$else}
+  {$ifdef OSLINUX}
+  if SystemInfo.dwNumberOfProcessors = 0 then // e.g. QEMU limited /proc/cpuinfo
+    SystemInfo.dwNumberOfProcessors := get_nprocs;
+  {$endif OSLINUX}
+  {$endif OSANDROID}
+  if SystemInfo.dwNumberOfProcessors = 0 then
+    SystemInfo.dwNumberOfProcessors := 1;
+  if modname = nil then
+    CpuInfoText := _fmt('%d x generic ' + CPU_ARCH_TEXT + ' cpu %s',
+      [SystemInfo.dwNumberOfProcessors, CpuInfoText])
+  else
+    CpuInfoText := _fmt('%d x %s %s (' + CPU_ARCH_TEXT + ')',
+      [SystemInfo.dwNumberOfProcessors, modname, CpuInfoText]);
+  // intialize supported APIs
+  TimeZoneLocalBias := -GetLocalTimeOffset;
+  {$ifndef NODIRECTTHREADMANAGER}
+  // for inlined RTL calls (avoid one level of redirection)
+  GetThreadManager(tm);
+  @GetCurrentThreadId      := @tm.GetCurrentThreadId;
+  @TryEnterCriticalSection := @tm.TryEnterCriticalSection;
+  @EnterCriticalSection    := @tm.EnterCriticalSection;
+  @LeaveCriticalSection    := @tm.LeaveCriticalSection;
+  {$endif NODIRECTTHREADMANAGER}
+  {$ifdef OSDARWIN}
+  OSVersionText := ToText(OSVersion32) + ' (' + OSVersionText + ')';
+  mach_timebase_info(mach_timeinfo);
+  mach_timecoeff := mach_timeinfo.Numer / mach_timeinfo.Denom;
+  mach_timenanosecond := (mach_timeinfo.Numer = 1) and
+                         (mach_timeinfo.Denom = 1);
+  {$else}
+  // try Linux kernel 2.6.32+ or FreeBSD 8.1+ fastest clocks
+  if clock_gettime(CLOCK_REALTIME_COARSE, @tp) = 0 then
+    CLOCK_REALTIME_FAST := CLOCK_REALTIME_COARSE;
+  if clock_gettime(CLOCK_MONOTONIC_COARSE, @tp) = 0 then
+    CLOCK_MONOTONIC_FAST := CLOCK_MONOTONIC_COARSE;
+  {$ifdef OSLINUX}
+  if clock_gettime(CLOCK_MONOTONIC_RAW, @tp) = 0 then
+    CLOCK_MONOTONIC_HIRES := CLOCK_MONOTONIC_RAW;
+  {$endif OSLINUX}
+  if clock_gettime(CLOCK_BOOTTIME, @tp) = 0 then
+    CLOCK_UPTIME := CLOCK_BOOTTIME;
+  if (clock_gettime(CLOCK_REALTIME_FAST, @tp) <> 0) or // paranoid check
+     (clock_gettime(CLOCK_MONOTONIC_FAST, @tp) <> 0) or
+     (clock_gettime(CLOCK_MONOTONIC_HIRES, @tp) <> 0) then
+    raise EOSException.CreateFmt(
+      'clock_gettime() not supported by %s kernel - errno=%d',
+      [PAnsiChar(@uts.release), fpgeterrno]);
+  // direct access to the pthread library if possible (Linux only)
+  {$ifdef OSPTHREADSLIB}
+  // mutex_lock() is blocking when dlopen run from a .so: cthreads uses both
+  // static and dynamic linking, which is really confusing to our code
+  // -> we don't open libpthread but we get its symbol
+  pthread := dlopen('libpthread.so.0', RTLD_LAZY);
+  if pthread <> nil then
+  begin
+    {$ifdef HAS_PTHREADSETNAMENP}
+    @pthread_setname_np := dlsym(pthread, 'pthread_setname_np');
+    {$endif HAS_PTHREADSETNAMENP}
+    {$ifdef HAS_PTHREADSETAFFINITY}
+    @pthread_setaffinity_np := dlsym(pthread, 'pthread_setaffinity_np');
+    {$endif HAS_PTHREADSETAFFINITY}
+    @pthread_cancel := dlsym(pthread, 'pthread_cancel');
+    @pthread_mutex_init := dlsym(pthread, 'pthread_mutex_init');
+    @pthread_mutex_destroy := dlsym(pthread, 'pthread_mutex_destroy');
+    @pthread_mutex_trylock := dlsym(pthread, 'pthread_mutex_trylock');
+    @pthread_mutex_lock    := dlsym(pthread, 'pthread_mutex_lock');
+    @pthread_mutex_unlock  := dlsym(pthread, 'pthread_mutex_unlock');
+  end;
+  {$endif OSPTHREADSLIB}
+  // some ARM/AARCH64 specific initialization
+  {$ifdef CPUARM3264}
+  StrLen := @StrLenLibc; // libc version is faster than plain pascal or RTL code
+  MoveFast := @MoveFastLibC;
+  FillCharFast := @FillCharLibC;
+  {$ifdef ARMV8STATIC}
+  if ahcCrc32 in CpuFeatures then
+    try
+      if (crc32cby4arm64(0, 1) = 3712330424) and
+         (crc32carm64(0, @SystemInfo, SizeOf(SystemInfo)) =
+           crc32cfast(0, @SystemInfo, SizeOf(SystemInfo))) then
+      begin
+        crc32c := @crc32carm64;
+        DefaultHasher := @crc32carm64;
+        InterningHasher := @crc32carm64;
+        crc32cby4 := @crc32cby4arm64;
+        crcblock := @crc32blockarm64;
+        crcblocks := @crc32blocksarm64;
+      end;
+      if crc32arm64(0, @SystemInfo, SizeOf(SystemInfo)) =
+          crc32fast(0, @SystemInfo, SizeOf(SystemInfo)) then
+        crc32 := @crc32arm64;
+    except
+      exclude(CpuFeatures, ahcCrc32); // crc32 was actually not supported
+    end;
+  {$endif ARMV8STATIC}
+  {$endif CPUARM3264}
+  {$ifdef CPUX64}
+  {$ifdef OSLINUX}
+  {$ifndef NOPATCHRTL}
+  // redirect some syscall FPC RTL functions to faster vDSO libc variant
+  {$ifndef FPC_USE_LIBC}
+  RedirectCode(@Linux.clock_gettime, @clock_gettime_c);
+  // will avoid syscall e.g. for events timeout in cthreads.pp
+  RedirectCode(@fpgettimeofday, @gettimeofday_c);
+  {$endif FPC_USE_LIBC}
+  {$endif NOPATCHRTL}
+  {$endif OSLINUX}
+  {$endif CPUX64}
+  {$endif OSDARWIN}
+end;
+
+procedure FinalizeSpecificUnit;
+begin
+  {$ifdef OSPTHREADSLIB}
+  if pthread <> nil then
+    dlclose(pthread);
+  {$endif OSPTHREADSLIB}
+  {$ifdef OSLINUX} // systemd API is Linux-specific
+  sd.Done;
+  {$endif OSLINUX}
+  icu.Done;
+  SynDaemonInterceptLog := nil;
+end;
+
+
diff --git a/lib/dmustache/mormot.core.os.windows.inc b/lib/dmustache/mormot.core.os.windows.inc
new file mode 100644
index 00000000..19411c7a
--- /dev/null
+++ b/lib/dmustache/mormot.core.os.windows.inc
@@ -0,0 +1,5614 @@
+{
+  This file is a part of the Open Source Synopse mORMot framework 2,
+  licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+
+  Windows API calls for FPC/Delphi, as used by mormot.core.os.pas
+}
+
+
+{ ****************** Unicode, Time, File process }
+
+const
+  /// Windows file APIs have hardcoded MAX_PATH = 260 :(
+  // - but more than 260 chars are possible with the \\?\..... prefix
+  // or by disabling the limitation in registry since Windows 10, version 1607
+  // https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation
+  // - extended-length path allows up to 32,767 widechars
+  // - but 2047 chars seems big enough in practice e.g. due to NTFS - POSIX uses 4096
+  W32_MAX = 2047;
+
+type
+  /// 4KB stack buffer for no heap allocation during UTF-16 encoding or
+  // switch to extended-length path
+  TW32Temp = array[0..W32_MAX] of WideChar;
+
+// W32() gets a PWideChar buffer from a TFileName using TW32Temp static buffer
+// W32Copy() forces a temporary copy - as used by GetFileVersionInfo()
+
+{$ifdef UNICODE}
+
+function W32Copy(const FileName: TFileName; var Temp: TW32Temp): PWideChar;
+var
+  len: PtrInt;
+begin
+  len := length(FileName) * 2 + 2; // +2 to include ending #0
+  if len > SizeOf(Temp) then
+    Temp[0] := #0 // avoid buffer overflow
+  else
+    MoveFast(pointer(FileName)^, Temp, len);
+  result := @Temp;
+end;
+
+// UnicodeString may need to be converted to extended-length path
+function W32(const FileName: TFileName; var Temp: TW32Temp): PWideChar;
+var
+  U: pointer; // hold a UnicodeString but with no try..finally
+begin
+  if (length(FileName) > MAX_PATH) and
+     (ord(FileName[1]) in [ord('A')..ord('Z'), ord('a')..ord('z')]) and
+     (FileName[2] = ':') then
+  begin
+    // convert to extended-length path
+    U := nil;
+    TFileName(U) := '\\?\' + FileName;
+    // move to TW32Temp stack buffer
+    result := W32Copy(TFileName(U), Temp);
+    // release temp memory and return the generated static buffer
+    TFileName(U) := '';
+  end
+  else
+    // no conversion nor allocation needed
+    result := pointer(FileName);
+end;
+
+{$else}
+
+// AnsiString is converted to UTF-16, potentially with extended-length path
+procedure W32Convert(const FileName: TFileName; var Temp: TW32Temp);
+var
+  U: SynUnicode;
+  len: PtrInt;
+begin
+  // identical to FPC RTL, which converts to UnicodeString before Wide API call 
+  U := SynUnicode(FileName); // let the RTL + OS do the conversion
+  // switch to extended-length path if needed, allowing up to 32,767 widechars
+  len := length(U);
+  if (len > MAX_PATH) and
+     (FileName[1] in ['A'..'Z', 'a'..'z']) and
+     (FileName[2] = ':') then
+    U := '\\?\' + U;
+  // move to TW32Temp stack buffer
+  len := length(U) * 2 + 2;  // +2 to include ending #0
+  if len > SizeOf(Temp) then
+    Temp[0] := #0 // avoid buffer overflow (rejected by Windows anyway)
+  else
+    MoveFast(pointer(U)^, Temp, len);
+end;
+
+function W32(const FileName: TFileName; var Temp: TW32Temp): PWideChar;
+var
+  i, len: PtrInt;
+begin
+  len := length(FileName);
+  if len = 0 then
+    result := nil
+  else
+  begin
+    if (len < MAX_PATH) and
+       IsAnsiCompatible(pointer(FileName), len) then
+      // most common cases do not need any Unicode conversion
+      for i := 0 to len do // include trailing #0
+        PWordArray(@Temp)[i] := PByteArray(FileName)[i]
+    else
+      // use a temporary SynUnicode variable for complex UTF-16 conversion
+      // or if MAX_PATH is reached and \\?\ prefix is needed for extended length
+      W32Convert(FileName, Temp);
+    result := @Temp;
+  end;
+end;
+
+function W32Copy(const FileName: TFileName; var Temp: TW32Temp): PWideChar;
+begin
+  result := W32(FileName, Temp); // from AnsiString: name is always copied
+end;
+
+{$endif UNICODE}
+
+function _fmt(const Fmt: string; const Args: array of const): RawUtf8; overload;
+begin
+  result := RawUtf8(format(Fmt, Args)); // good enough (seldom called)
+end;
+
+procedure _fmt(const Fmt: string; const Args: array of const;
+  var result: RawUtf8); overload;
+begin
+  result := RawUtf8(format(Fmt, Args)); // good enough (seldom called)
+end;
+
+procedure DoWin32PWideCharToUtf8(P: PWideChar; Len: PtrInt; var res: RawUtf8);
+var
+  tmp: TSynTempBuffer;
+begin
+  tmp.Init(Len * 3);
+  Len := UnicodeToUtf8(tmp.Buf, Len * 3, P, Len); // use RTL if complex
+  if Len > 0 then
+    dec(Len); // UnicodeToUtf8() result includes the null terminator
+  FastSetString(res, tmp.buf, Len);
+  tmp.Done;
+end;
+
+// local RTL wrapper functions to avoid linking mormot.core.unicode.pas
+procedure Win32PWideCharToUtf8(P: PWideChar; Len: PtrInt; out res: RawUtf8);
+var
+  i: PtrInt;
+begin
+  if Len > 0 then
+    if IsAnsiCompatibleW(P, Len) then
+    begin
+      FastSetString(res, Len);
+      for i := 0 to Len - 1 do
+        PByteArray(res)[i] := PWordArray(P)[i]; // fast direct conversion
+    end
+    else
+      DoWin32PWideCharToUtf8(P, Len, res);
+end;
+
+procedure Win32PWideCharToUtf8(P: PWideChar; out res: RawUtf8);
+begin
+  if P <> nil then
+    Win32PWideCharToUtf8(P, StrLenW(P), res);
+end;
+
+function Utf8ToWin32PWideChar(const Text: RawUtf8;
+  var dest: TSynTempBuffer): PWideChar;
+var
+  TextLen, i: PtrInt;
+begin
+  result := nil;
+  TextLen := length(Text);
+  dest.Init(TextLen * 2);
+  if dest.len = 0 then
+    exit;
+  result := dest.buf;
+  if IsAnsiCompatible(PAnsiChar(pointer(Text)), TextLen) then
+  begin
+    dest.len := TextLen;
+    for i := 0 to TextLen do // include trailing #0
+      PWordArray(result)[i] := PByteArray(Text)[i];
+  end
+  else
+  begin
+    dest.len := Utf8ToUnicode(result, dest.Len + 16, pointer(Text), TextLen);
+    if dest.len <= 0 then
+      dest.len := 0
+    else
+    begin
+      dec(dest.len); // Utf8ToUnicode() returned length includes trailing #0
+      result[dest.len] := #0; // missing on FPC
+    end;
+  end;
+end;
+
+const
+  DefaultCharVar: AnsiChar = '?';
+
+function Unicode_AnsiToWide(A: PAnsiChar; W: PWideChar; LA, LW, CodePage: PtrInt): integer;
+begin
+  result := MultiByteToWideChar(CodePage, MB_PRECOMPOSED, A, LA, W, LW);
+end;
+
+function Unicode_WideToAnsi(W: PWideChar; A: PAnsiChar; LW, LA, CodePage: PtrInt): integer;
+begin
+  result := WideCharToMultiByte(CodePage, 0, W, LW, A, LA, @DefaultCharVar, nil);
+end;
+
+function LibraryOpen(const LibraryName: TFileName): TLibHandle;
+var
+  tmp: TW32Temp;
+  err: DWord;
+  {$ifdef CPUX86}
+  x87cw: word;
+  {$endif CPUX86}
+begin
+  // note: GetErrorMode() is not available on XP
+  err := SetErrorMode(SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS);
+  {$ifdef CPUX86}
+  asm
+      fnstcw x87cw // save x87 flags
+  end;
+  {$endif CPUX86}
+  result := Windows.LoadLibraryW(W32(LibraryName, tmp));
+  {$ifdef CPUX86}
+  asm
+      fnclex       // clear pending x87 exceptions
+      fldcw x87cw  // restore flags (Visual C++ librairies usually change them)
+  end;
+  {$endif CPUX86}
+  SetErrorMode(err);
+end;
+
+procedure LibraryClose(Lib: TLibHandle);
+begin
+  if pointer(Lib) <> nil then
+    Windows.FreeLibrary(Lib);
+end;
+
+// Delphi Unicode has an ambiguous GetProcAddress() overload with PWideChar
+function LibraryResolve(Lib: TLibHandle; ProcName: PAnsiChar): pointer;
+  external kernel32 name 'GetProcAddress'; // this is an Ansi-only API
+
+function LibraryError: string;
+begin
+  result := IntToStr(GetLastError); // enough for basic troubleshouting
+end;
+
+procedure FileTimeToInt64(const FT: TFileTime; out I64: Int64);
+  {$ifdef HASINLINE} inline; {$endif} 
+begin
+  PInt64Rec(@I64)^.Lo := FT.dwLowDateTime; // Delphi 2007 bug with PInt64()
+  PInt64Rec(@I64)^.Hi := FT.dwHighDateTime;
+end;
+
+const
+  SecsPerFileTime = 10000000;
+  MilliSecsPerFileTime = 10000;
+
+procedure UnixTimeToFileTime(I64: TUnixTime; out FT: TFileTime);
+begin
+  I64 := (I64 * SecsPerFileTime) + UnixFileTimeDelta;
+  FT.dwLowDateTime  := PInt64Rec(@I64)^.Lo; // Delphi 2007 bug with PInt64()
+  FT.dwHighDateTime := PInt64Rec(@I64)^.Hi;
+end;
+
+procedure UnixMSTimeToFileTime(I64: TUnixMSTime; out FT: TFileTime);
+begin
+  I64 := (I64 * MilliSecsPerFileTime) + UnixFileTimeDelta;
+  FT.dwLowDateTime  := PInt64Rec(@I64)^.Lo; // Delphi 2007 bug with PInt64()
+  FT.dwHighDateTime := PInt64Rec(@I64)^.Hi;
+end;
+
+procedure UnixTimeToLocalTime(I64: TUnixTime; out Local: TSystemTime);
+var
+  ft, lt: TFileTime;
+begin
+  UnixTimeToFileTime(I64, ft);
+  FileTimeToLocalFileTime(ft, lt);
+  FileTimeToSystemTime(lt, Local);
+end;
+
+function FileTimeToUnixTime(const FT: TFileTime): TUnixTime;
+{$ifdef CPU64}
+var
+  nano100: Int64; // TFileTime is in 100 ns unit
+{$endif CPU64}
+begin
+  if PInt64(@FT)^ = 0 then
+  begin
+    result := 0;
+    exit;
+  end;
+  {$ifdef CPU64}
+  FileTimeToInt64(ft, nano100);
+  result := (nano100 - UnixFileTimeDelta) div SecsPerFileTime;
+  {$else} // use PInt64 to avoid URW699 with Delphi 6 / Kylix
+  result := (PInt64(@ft)^ - UnixFileTimeDelta) div SecsPerFileTime;
+  {$endif CPU64}
+end;
+
+function FileTimeToUnixMSTime(const FT: TFileTime): TUnixMSTime;
+{$ifdef CPU64}
+var
+  nano100: Int64; // TFileTime is in 100 ns unit
+{$endif CPU64}
+begin
+  if PInt64(@FT)^ = 0 then
+  begin
+    result := 0;
+    exit;
+  end;
+  {$ifdef CPU64}
+  FileTimeToInt64(ft, nano100);
+  result := (nano100 - UnixFileTimeDelta) div MilliSecsPerFileTime;
+  {$else} 
+  result := (PInt64(@ft)^ - UnixFileTimeDelta) div MilliSecsPerFileTime;
+  {$endif CPU64}
+end;
+
+function FileTimeToDateTime(const FT: TFileTime): TDateTime;
+begin
+  if PInt64(@FT)^ = 0 then
+    result := 0
+  else // inlined UnixTimeToDateTime()
+    result := FileTimeToUnixMSTime(FT) / MSecsPerDay + UnixDateDelta;
+end;
+
+procedure DateTimeToFileTime(dt: TDateTime; out FT: TFileTime);
+begin
+  if dt = 0 then
+    PInt64(@FT)^ := 0
+  else // inlined DateTimeToUnixTime()
+    UnixTimeToFileTime(Round((dt - UnixDateDelta) * SecsPerDay), FT);
+end;
+
+function UnixTimeUtc: TUnixTime;
+var
+  ft: TFileTime;
+begin
+  GetSystemTimeAsFileTime(ft); // fast (HW resolution is < TUnixTime second)
+  result := FileTimeToUnixTime(ft);
+end;
+
+var
+  // redirect to a slower but more accurate API available since Windows 8
+  // - points to GetSystemTimeAsFileTime() before Windows 8
+  GetSystemTimePreciseAsFileTime: procedure(var ft: TFILETIME); stdcall;
+
+function UnixMSTimeUtc: TUnixMSTime;
+var
+  ft: TFileTime;
+begin
+  GetSystemTimePreciseAsFileTime(ft); // slower, but try to achieve ms resolution
+  result := FileTimeToUnixMSTime(ft);
+end;
+
+function UnixMSTimeUtcFast: TUnixMSTime;
+var
+  ft: TFileTime;
+begin
+  GetSystemTimeAsFileTime(ft); // faster, but with HW interupt resolution
+  result := FileTimeToUnixMSTime(ft);
+end;
+
+procedure GetSystemTime;              external kernel32;
+procedure GetLocalTime;               external kernel32;
+procedure InitializeCriticalSection;  external kernel32;
+procedure EnterCriticalSection;       external kernel32;
+procedure LeaveCriticalSection;       external kernel32;
+procedure DeleteCriticalSection;      external kernel32;
+function  TryEnterCriticalSection;    external kernel32;
+function  CloseHandle;                external kernel32;
+procedure FileClose;                  external kernel32 name 'CloseHandle';
+function  GetCurrentThreadId;         external kernel32;
+procedure SwitchToThread;             external kernel32;
+function  GetCurrentProcessId;        external kernel32;
+function  GetCurrentProcess;          external kernel32;
+function  WaitForSingleObject;        external kernel32;
+function  GetEnvironmentStringsW;     external kernel32;
+function  FreeEnvironmentStringsW;    external kernel32;
+function  RtlCaptureStackBackTrace;   external kernel32;
+function  IsDebuggerPresent;          external kernel32;
+procedure SetEndOfFile;               external kernel32;
+procedure FlushFileBuffers;           external kernel32;
+function  GetLastError;               external kernel32;
+procedure SetLastError;               external kernel32;
+function  IocpCreate;                 external kernel32 name 'CreateIoCompletionPort';
+function  IocpGetQueuedStatus;        external kernel32 name 'GetQueuedCompletionStatus';
+function  IocpPostQueuedStatus;       external kernel32 name 'PostQueuedCompletionStatus';
+function  GetDesktopWindow;           external user32;
+function  Unicode_InPlaceUpper;       external user32 name 'CharUpperBuffW';
+function  Unicode_InPlaceLower;       external user32 name 'CharLowerBuffW';
+
+function HasConsole: boolean;
+begin
+  if StdOut = 0 then
+    StdOut := GetStdHandle(STD_OUTPUT_HANDLE);
+  result := (StdOut <> 0) and
+            (StdOut <> INVALID_HANDLE_VALUE);
+end;
+
+procedure AllocConsole;
+begin
+  Windows.AllocConsole;
+  if (StdOut = 0) or
+     (StdOut = INVALID_HANDLE_VALUE) then
+    // force setup StdOut global variable
+    StdOut := GetStdHandle(STD_OUTPUT_HANDLE);
+end;
+
+{$I-}
+procedure DisplayFatalError(const title, msg: RawUtf8);
+begin
+  // better than a MessageBox() especially for services
+  AllocConsole; // will create one black window console if none
+  if title <> '' then
+  begin
+    TextColor(ccWhite);
+    writeln(#13#10, title);
+    writeln(StringOfChar('-', length(title) + 1), #13#10);
+    TextColor(ccLightRed);
+    writeln(msg);
+    TextColor(ccLightGray);
+  end
+  else
+    writeln(msg);
+  ioresult;
+end;
+{$I+}
+
+function IsSharedViolation(ErrorCode: integer): boolean;
+begin
+  if ErrorCode = 0 then
+    ErrorCode := GetLastError;
+  result := ErrorCode in [ERROR_SHARING_VIOLATION, ERROR_LOCK_VIOLATION];
+end;
+
+function GetModuleHandle(lpModuleName: PChar): HMODULE;
+begin
+  result := Windows.GetModuleHandle(lpModuleName); // call either A or W API
+end;
+
+function SetSystemTime(const utctime: TSystemTime): boolean;
+var
+  privileges: TSynWindowsPrivileges;
+begin
+  try
+    privileges.Init;
+    try
+      privileges.Enable(wspSystemTime); // ensure has SE_SYSTEMTIME_NAME
+      result := Windows.SetSystemTime(PSystemTime(@utctime)^);
+    finally
+      privileges.Done;
+    end;
+    if result then
+      PostMessage(HWND_BROADCAST, WM_TIMECHANGE, 0, 0); // notify the apps
+  except
+    result := false;
+  end;
+end;
+
+const
+  // https://learn.microsoft.com/en-us/windows/win32/debug/system-error-codes
+  ERROR_STANDARD1: array[0..39] of PUtf8Char = (
+    'SUCCESS', 'INVALID_FUNCTION', 'FILE_NOT_FOUND', 'PATH_NOT_FOUND',
+    'TOO_MANY_OPEN_FILES', 'ACCESS_DENIED', 'INVALID_HANDLE', 'ARENA_TRASHED',
+    'NOT_ENOUGH_MEMORY', 'INVALID_BLOCK', 'BAD_ENVIRONMENT', 'BAD_FORMAT',
+    'INVALID_ACCESS', 'INVALID_DATA', 'OUTOFMEMORY', 'INVALID_DRIVE',
+    'CURRENT_DIRECTORY', 'NOT_SAME_DEVICE', 'NO_MORE_FILES', 'WRITE_PROTECT',
+    'BAD_UNIT', 'NOT_READY', 'BAD_COMMAND', 'CRC', 'BAD_LENGTH', 'SEEK',
+    'NOT_DOS_DISK', 'SECTOR_NOT_FOUND', 'OUT_OF_PAPER', 'WRITE_FAULT',
+    'READ_FAULT', 'GEN_FAILURE', 'SHARING_VIOLATION', 'LOCK_VIOLATION',
+    'WRONG_DISK', '35', 'SHARING_BUFFER_EXCEEDED', '37', 'HANDLE_EOF',
+    'HANDLE_DISK_FULL');
+  ERROR_STANDARD2: array[50..55] of PUtf8Char = (
+    'NOT_SUPPORTED', 'REM_NOT_LIST', 'DUP_NAME', 'BAD_NETPATH',
+    'NETWORK_BUSY', 'DEV_NOT_EXIST');
+  ERROR_STANDARD3: array[80..89] of PUtf8Char = (
+    'FILE_EXISTS', '81', 'CANNOT_MAKE', 'FAIL_I24', 'OUT_OF_STRUCTURES',
+    'ALREADY_ASSIGNED', 'INVALID_PASSWORD', 'INVALID_PARAMETER',
+    'NET_WRITE_FAULT', 'NO_PROC_SLOTS');
+  ERROR_STANDARD4: array[108..129] of PUtf8Char = (
+    'DRIVE_LOCKED', 'BROKEN_PIPE', 'OPEN_FAILED', 'BUFFER_OVERFLOW',
+    'DISK_FULL', 'NO_MORE_SEARCH_HANDLES', 'INVALID_TARGET_HANDLE', '115',
+    '116', 'INVALID_CATEGORY', 'INVALID_VERIFY_SWITCH', 'BAD_DRIVER_LEVEL',
+    'CALL_NOT_IMPLEMENTED', 'SEM_TIMEOUT', 'INSUFFICIENT_BUFFER',
+    'INVALID_NAME', 'INVALID_LEVEL', 'NO_VOLUME_LABEL', 'MOD_NOT_FOUND',
+    'PROC_NOT_FOUND', 'WAIT_NO_CHILDREN', 'CHILD_NOT_COMPLETE');
+  ERROR_STANDARD5: array[995..1013] of PUtf8Char = (
+    'OPERATION_ABORTED', 'IO_INCOMPLETE', 'IO_PENDING', 'NOACCESS', 'SWAPERROR',
+    '1000', 'STACK_OVERFLOW', 'INVALID_MESSAGE', 'CAN_NOT_COMPLETE',
+    'INVALID_FLAGS', 'UNRECOGNIZED_VOLUME', 'FILE_INVALID', 'FULLSCREEN_MODE',
+    'NO_TOKEN', 'BADDB', 'BADKEY', 'CANTOPEN', 'CANTREAD', 'CANTWRITE');
+  ERROR_STANDARD6: array[1051..1079] of PUtf8Char = (
+    'DEPENDENT_SERVICES_RUNNING', 'INVALID_SERVICE_CONTROL',
+    'SERVICE_REQUEST_TIMEOUT', 'SERVICE_NO_THREAD', 'SERVICE_DATABASE_LOCKED',
+    'SERVICE_ALREADY_RUNNING', 'INVALID_SERVICE_ACCOUNT', 'SERVICE_DISABLED',
+    'CIRCULAR_DEPENDENCY', 'SERVICE_DOES_NOT_EXIST', 'SERVICE_CANNOT_ACCEPT_CTRL',
+    'SERVICE_NOT_ACTIVE', 'FAILED_SERVICE_CONTROLLER_CONNECT',
+    'EXCEPTION_IN_SERVICE', 'DATABASE_DOES_NOT_EXIST', 'SERVICE_SPECIFIC_ERROR',
+    'PROCESS_ABORTED', 'SERVICE_DEPENDENCY_FAIL', 'SERVICE_LOGON_FAILED',
+    'SERVICE_START_HANG', 'INVALID_SERVICE_LOCK', 'SERVICE_MARKED_FOR_DELETE',
+    'SERVICE_EXISTS', 'ALREADY_RUNNING_LKG', 'SERVICE_DEPENDENCY_DELETED',
+    'BOOT_ALREADY_ACCEPTED', 'SERVICE_NEVER_STARTED', 'DUPLICATE_SERVICE_NAME',
+    'DIFFERENT_SERVICE_ACCOUNT');
+  ERROR_STANDARD7: array[1200..1246] of PUtf8Char = (
+    'BAD_DEVICE', 'CONNECTION_UNAVAIL', 'DEVICE_ALREADY_REMEMBERED',
+    'NO_NET_OR_BAD_PATH', 'BAD_PROVIDER', 'CANNOT_OPEN_PROFILE', 'BAD_PROFILE',
+    'NOT_CONTAINER', 'EXTENDED_ERROR', 'INVALID_GROUPNAME', 'INVALID_COMPUTERNAME',
+    'INVALID_EVENTNAME', 'INVALID_DOMAINNAME', 'INVALID_SERVICENAME',
+    'INVALID_NETNAME', 'INVALID_SHARENAME', 'INVALID_PASSWORDNAME',
+    'INVALID_MESSAGENAME', 'INVALID_MESSAGEDEST', 'SESSION_CREDENTIAL_CONFLICT',
+    'REMOTE_SESSION_LIMIT_EXCEEDED', 'DUP_DOMAINNAME', 'NO_NETWORK', 'CANCELLED',
+    'USER_MAPPED_FILE', 'CONNECTION_REFUSED', 'GRACEFUL_DISCONNECT',
+    'ADDRESS_ALREADY_ASSOCIATED', 'ADDRESS_NOT_ASSOCIATED', 'CONNECTION_INVALID',
+    'CONNECTION_ACTIVE', 'NETWORK_UNREACHABLE', 'HOST_UNREACHABLE',
+    'PROTOCOL_UNREACHABLE', 'PORT_UNREACHABLE', 'REQUEST_ABORTED',
+    'CONNECTION_ABORTED', 'RETRY', 'CONNECTION_COUNT_LIMIT',
+    'LOGIN_TIME_RESTRICTION', 'LOGIN_WKSTA_RESTRICTION', 'INCORRECT_ADDRESS',
+    'ALREADY_REGISTERED', 'SERVICE_NOT_FOUND', 'NOT_AUTHENTICATED',
+    'NOT_LOGGED_ON', 'CONTINUE');
+
+function WinErrorConstant(Code: cardinal): PUtf8Char;
+begin
+  if Code <= high(ERROR_STANDARD1) then
+    result := ERROR_STANDARD1[Code]
+  else if Code in [low(ERROR_STANDARD2)..high(ERROR_STANDARD2)] then
+    result := ERROR_STANDARD2[Code]
+  else if Code in [low(ERROR_STANDARD3)..high(ERROR_STANDARD3)] then
+    result := ERROR_STANDARD3[Code]
+  else if Code in [low(ERROR_STANDARD4)..high(ERROR_STANDARD4)] then
+    result := ERROR_STANDARD4[Code]
+  else if (Code >= low(ERROR_STANDARD5)) and
+          (Code <= high(ERROR_STANDARD5)) then
+    result := ERROR_STANDARD5[Code]
+  else if (Code >= low(ERROR_STANDARD6)) and
+          (Code <= high(ERROR_STANDARD6)) then
+    result := ERROR_STANDARD6[Code]
+  else if (Code >= low(ERROR_STANDARD7)) and
+          (Code <= high(ERROR_STANDARD7)) then
+    result := ERROR_STANDARD7[Code]
+  else
+    case Code of
+      ERROR_ALREADY_EXISTS:
+        result := 'ALREADY_EXISTS';
+      ERROR_MORE_DATA:
+        result := 'MORE_DATA';
+      ERROR_NO_SYSTEM_RESOURCES:
+        result := 'NO_SYSTEM_RESOURCES';
+      ERROR_WINHTTP_CANNOT_CONNECT:
+        result := 'WINHTTP_CANNOT_CONNECT';
+      ERROR_WINHTTP_TIMEOUT:
+        result := 'WINHTTP_TIMEOUT';
+      ERROR_WINHTTP_INVALID_SERVER_RESPONSE:
+        result := 'WINHTTP_INVALID_SERVER_RESPONSE';
+      10014:
+        result := 'WSAEFAULT';
+      10022:
+        result := 'WSAEINVAL';
+      10024:
+        result := 'WSAEMFILE';
+      10035:
+        result := 'WSAEWOULDBLOCK';
+      10038:
+        result := 'WSAENOTSOCK';
+      10053:
+        result := 'WSAECONNABORTED';
+      10054:
+        result := 'WSAECONNRESET';
+      10055:
+        result := 'WSAENOBUFS';
+      10060:
+        result := 'WSAETIMEDOUT';
+      10061:
+        result := 'WSAECONNREFUSED';
+      11003:
+        result := 'WSATRY_AGAIN';
+      else
+        result := nil;
+    end;
+end;
+
+function WinErrorText(Code: cardinal; ModuleName: PChar): RawUtf8;
+var
+  bak: integer;
+  flags, len: PtrUInt;
+  src: pointer;
+  cod: PUtf8Char;
+  tmp: array[0..511] of WideChar;
+begin
+  bak := GetLastError;
+  src := nil;
+  flags := FORMAT_MESSAGE_FROM_SYSTEM;
+  if ModuleName = nil then
+  begin
+    // system error codes
+    cod := WinErrorConstant(Code);
+    if cod <> nil then
+    begin
+      // we can return directly the standard system error code constant
+      _fmt('ERROR_%s', [cod], result);
+      exit;
+    end;
+  end
+  else
+  begin
+    // module specific error codes
+    src := pointer(GetModuleHandle(ModuleName));
+    if src <> nil then
+      flags := FORMAT_MESSAGE_FROM_HMODULE;
+  end;
+  // first try if there is an English message version of this error code
+  len := FormatMessageW(flags, src, Code, ENGLISH_LANGID, @tmp, SizeOf(tmp), nil);
+  if len = 0 then
+    // typically ERROR_RESOURCE_LANG_NOT_FOUND or ERROR_MUI_FILE_NOT_FOUND
+    len := FormatMessageW(flags, src, Code, 0, @tmp, SizeOf(tmp), nil);
+  if (len = 0) and
+     (src <> nil) then
+  begin
+    // fallback to the system error message if this module as no such code
+    SetLastError(bak);
+    result := WinErrorText(Code, nil);
+    exit;
+  end;
+  while (len > 0) and
+        (ord(tmp[len - 1]) in [0..32, ord('.')]) do
+    dec(len); // trim right
+  Win32PWideCharToUtf8(@tmp, len, result);
+  SetLastError(bak);
+end;
+
+function GetErrorText(error: integer): RawUtf8;
+begin
+  result := WinErrorText(error, nil);
+end;
+
+procedure RaiseLastModuleError(ModuleName: PChar; ModuleException: ExceptClass);
+var
+  code: integer;
+begin
+  code := GetLastError;
+  raise ModuleException.CreateFmt('%s error %x (%s)',
+    [ModuleName, code, string(WinErrorText(code, ModuleName))]);
+end;
+
+procedure RaiseLastError(const Context: shortstring; RaisedException: ExceptClass);
+var
+  code: integer;
+begin
+  code := GetLastError;
+  if RaisedException = nil then
+    RaisedException := EOSException;
+  raise RaisedException.CreateFmt('%s error %x (%s)',
+    [Context, code, string(WinErrorText(code, nil))])
+end;
+
+function PostMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL;
+begin
+  result := Windows.PostMessage(hWnd, Msg, wParam, lParam); // call either A or W API
+end;
+
+function ExpandEnvVars(const aStr: string): string;
+// adapted from http://delphidabbler.com/articles?article=6
+var
+  size: integer;
+begin
+  // Get required buffer size
+  size := ExpandEnvironmentStrings(pointer(aStr), nil, 0);
+  if size > 0 then
+  begin
+    // Read expanded string into result string
+    SetString(result, nil, size - 1);
+    ExpandEnvironmentStrings(pointer(aStr), pointer(result), size);
+  end
+  else
+    result := aStr; // return the original file name
+end;
+
+function IsInitializedCriticalSection(var cs: TRTLCriticalSection): boolean;
+begin
+  result := not IsZero(@cs, SizeOf(cs));
+end;
+
+var
+  // value is documented as stable after boot, so we get it at startup
+  _QueryPerformanceFrequency: QWord;
+  // from HyperV or if HPET disabled e.g. -> direct division
+  _QueryPerformanceFrequencyPer10: boolean;
+
+procedure QueryPerformanceMicroSeconds(out Value: Int64);
+var
+  v: Int64; // for proper alignment on some old Delphi revisions + Win32
+begin
+  QueryPerformanceCounter(v);
+  if _QueryPerformanceFrequencyPer10 then
+    Value := QWord(v) div 10 // faster div by a constant (especially on FPC_64)
+  else
+    Value := QWord((QWord(v) * 1000000) div _QueryPerformanceFrequency);
+end;
+
+var
+  shlwapiDll: THandle; // lazy loading (only by TNetClientProtocolFile)
+  PathCreateFromUrl: function(pszUrl, pszPath: PChar; var pcchPath: cardinal;
+    dwFlags: cardinal): HRESULT; stdcall;
+
+function GetFileNameFromUrl(const Uri: string): TFileName;
+var
+  len: DWORD;
+  tmp: array[0..MAX_PATH] of char;
+begin
+  result := '';
+  len := MAX_PATH;
+  if DelayedProc(PathCreateFromUrl, shlwapiDll, 'shlwapi.dll',
+       'PathCreateFromUrl' + _AW) and
+     (PathCreateFromUrl(pointer(Uri), @tmp, len, 0) = S_OK) then
+    result := tmp;
+end;
+
+const
+  faInvalidFile = faDirectory + faVolumeID{%H-} + faSysFile{%H-} + faHidden{%H-};
+  faDirectoryMask = faDirectory + faHidden{%H-};
+
+function FileDateToDateTime(const FileDate: TFileAge): TDateTime;
+begin
+  result := WindowsFileTimeToDateTime(FileDate);
+end;
+
+// some definitions missing on oldest Delphi
+const
+  FILE_ATTRIBUTE_REPARSE_POINT = $0000400;
+
+function FindFirstFileExW(lpfilename: PWideChar; fInfoLevelId: FINDEX_INFO_LEVELS;
+   lpFindFileData: pointer; fSearchOp: FINDEX_SEARCH_OPS;
+   lpSearchFilter: pointer = nil; dwAdditionalFlags: cardinal = 0): THandle;
+  stdcall; external kernel32;
+
+// an alternative to GetFileAttributesExW() with fallback to FindFirstFileEx API
+function GetFileAttributesRaw(fn: PWideChar;
+  out Attr: WIN32_FILE_ATTRIBUTE_DATA): boolean;
+var
+  h: THandle;
+  fd: TWin32FindDataW;
+begin
+  // this API is much faster than CreateFile/GetFileTime/GetFileSize/CloseHandle
+  result := GetFileAttributesExW(fn, GetFileExInfoStandard, @Attr);
+  if result or
+     (GetLastError in [ERROR_FILE_NOT_FOUND, ERROR_PATH_NOT_FOUND,
+        ERROR_INVALID_NAME, ERROR_INVALID_DRIVE, ERROR_NOT_READY,
+        ERROR_INVALID_PARAMETER, ERROR_BAD_PATHNAME, ERROR_BAD_NETPATH,
+        ERROR_BAD_NET_NAME]) then
+    exit;
+  // access denied, or locked file: fallback to slower but regular API
+  h := FindFirstFileExW(fn, FindExInfoStandard, @fd, FindExSearchNameMatch);
+  if not ValidHandle(h) then
+    exit;
+  windows.FindClose(h);
+  Attr.dwFileAttributes := fd.dwFileAttributes;
+  Attr.ftCreationTime   := fd.ftCreationTime;
+  Attr.ftLastAccessTime := fd.ftLastAccessTime;
+  Attr.ftLastWriteTime  := fd.ftLastWriteTime;
+  Attr.nFileSizeHigh    := fd.nFileSizeHigh;
+  Attr.nFileSizeLow     := fd.nFileSizeLow;
+  result := true;
+end;
+
+function GetFileAttributesInternal(const FileName: TFileName;
+  out Attr: WIN32_FILE_ATTRIBUTE_DATA; FollowLink: boolean = true): boolean;
+var
+  fn: PWideChar;
+  h: THandle;
+  f: cardinal;
+  lp: TByHandleFileInformation;
+  tmp: TW32Temp;
+begin
+  result := false;
+  if FileName = '' then
+    exit;
+  fn := W32(FileName, tmp);
+  result := GetFileAttributesRaw(fn, Attr);
+  if result and
+     FollowLink and
+     (Attr.dwFileAttributes and FILE_ATTRIBUTE_REPARSE_POINT <> 0) then
+  begin
+    // we need to follow a symbolic link
+    f := 0;
+    if Attr.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0 then
+      f := FILE_FLAG_BACKUP_SEMANTICS; // to access folder handle
+    FillCharFast(Attr, SizeOf(Attr), 0); // enough for FileExists()
+    // raw file access seems better than FileGetSymLinkTarget() in our case
+    // and it will be consistent on both FPC and Delphi (including pre-Unicode)
+    // - if we require file information, it is likely we would like to access it
+    // - note that FPC and Delphi RTL seems overcomplicated and non-consistent
+    // about symbolic links: mORMot will share this function everywhere
+    h := CreateFileW(fn, GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, f, 0);
+    if ValidHandle(h) then
+    begin
+      if GetFileInformationByHandle(h, lp) then
+      begin
+        Attr.dwFileAttributes := lp.dwFileAttributes;
+        Attr.ftCreationTime   := lp.ftCreationTime;
+        Attr.ftLastAccessTime := lp.ftLastAccessTime;
+        Attr.ftLastWriteTime  := lp.ftLastWriteTime;
+        Attr.nFileSizeHigh    := lp.nFileSizeHigh;
+        Attr.nFileSizeLow     := lp.nFileSizeLow;
+      end
+      else
+        result := false;
+      CloseHandle(h);
+    end
+    else
+      result := IsSharedViolation;
+  end;
+end;
+
+function FileAgeToDateTime(const FileName: TFileName): TDateTime;
+var
+  FA: WIN32_FILE_ATTRIBUTE_DATA;
+  ST, LT: TSystemTime;
+begin
+  if (FileName <> '') and
+     GetFileAttributesInternal(FileName, FA) and
+     FileTimeToSystemTime({%H-}FA.ftLastWriteTime, ST) and
+     SystemTimeToTzSpecificLocalTime(nil, ST, LT) then
+    result := SystemTimeToDateTime(LT)
+  else
+    result := 0;
+end;
+
+function FileAgeToUnixTimeUtc(const FileName: TFileName; AllowDir: boolean): TUnixTime;
+var
+  FA: WIN32_FILE_ATTRIBUTE_DATA;
+begin
+  if (FileName <> '') and
+     GetFileAttributesInternal(FileName, FA) and
+     (AllowDir or ({%H-}FA.dwFileAttributes and faDirectory = 0)) then
+    result := FileTimeToUnixTime(FA.ftLastWriteTime) // no local time conversion
+  else
+    result := 0;
+end;
+
+function FileAgeToWindowsTime(const FileName: TFileName): integer;
+var
+  FA: WIN32_FILE_ATTRIBUTE_DATA;
+  ft: TFileTime;
+begin
+  result := 0;
+  if (FileName <> '') and
+     GetFileAttributesInternal(FileName, FA) and
+     ({%H-}FA.dwFileAttributes and faDirectory = 0) and
+     FileTimeToLocalFileTime(FA.ftLastWriteTime, ft) and
+     not FileTimeToDosDateTime(ft, LongRec(result).Hi, LongRec(result).Lo) then
+    result := 0;
+end;
+
+function FileSetDateFromWindowsTime(const Dest: TFileName; WinTime: integer): boolean;
+begin
+  result := FileSetDate(Dest, WinTime) = 0; // we already are on Windows
+end;
+
+function FileSetDateFromUnixUtc(const Dest: TFileName; Time: TUnixTime): boolean;
+var
+  D: THandle;
+  ft: TFileTime;
+begin
+  result := false;
+  if (Dest = '') or
+     (Time = 0) then
+    exit;
+  D := FileOpen(Dest, fmOpenWrite);
+  if not ValidHandle(D) then
+    exit;
+  UnixTimeToFileTime(Time, ft);
+  result := SetFileTime(D, nil, nil, @ft);
+  FileClose(D);
+end;
+
+function SearchRecToWindowsTime(const F: TSearchRec): integer;
+begin
+  result := F.Time; // already in the expected legacy format
+end;
+
+function SearchRecToUnixTimeUtc(const F: TSearchRec): TUnixTime;
+begin // return the search record timestamp with no local time conversion
+  result := FileTimeToUnixTime(F.FindData.ftLastWriteTime);
+end;
+
+function FileInfoByHandle(aFileHandle: THandle; FileId, FileSize: PInt64;
+  LastWriteAccess, FileCreateDateTime: PUnixMSTime): boolean;
+var
+  mtime, atime, ctime: Int64;
+  lp: TByHandleFileInformation;
+begin
+  result := GetFileInformationByHandle(aFileHandle, lp);
+  if not result then
+    exit;
+  if FileId <> nil then
+  begin
+    PInt64Rec(FileId)^.lo := lp.nFileIndexLow;
+    PInt64Rec(FileId)^.hi := lp.nFileIndexHigh;
+  end;
+  if FileSize <> nil then
+  begin
+    PInt64Rec(FileSize)^.lo := lp.nFileSizeLow;
+    PInt64Rec(FileSize)^.hi := lp.nFileSizeHigh;
+  end;
+  if (LastWriteAccess = nil) and
+     (FileCreateDateTime = nil) then
+    exit;
+  mtime := FileTimeToUnixMSTime(lp.ftLastWriteTime);
+  if LastWriteAccess <> nil then
+    LastWriteAccess^ := mtime;
+  if FileCreateDateTime = nil then
+    exit;
+  atime := FileTimeToUnixMSTime(lp.ftLastAccessTime);
+  ctime := FileTimeToUnixMSTime(lp.ftCreationTime);
+  if mtime <> 0 then
+    if (ctime = 0) or
+       (ctime > mtime) then
+      ctime := mtime;
+  if atime <> 0 then
+    if (ctime = 0) or
+       (ctime > atime) then
+      ctime := atime;
+  FileCreateDateTime^ := ctime;
+end;
+
+function FileIsExecutable(const FileName: TFileName): boolean;
+var
+  h: THandle;
+  header: word;
+begin
+  result := false;
+  h := FileOpen(FileName, fmOpenReadShared);
+  if not ValidHandle(h) then
+    exit;
+  result := (FileRead(h, header, 2) = 2) and
+            (header = $5A4D); // DOS Magic Number
+  FileClose(h);
+end;
+
+function GetModuleHandleExA(dwFlags: cardinal; lpModuleName: pointer;
+ var phModule: HMODULE): BOOL; stdcall; external kernel32;
+
+const
+  GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT = $00000002;
+  GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS       = $00000004;
+
+function GetExecutableName(aAddress: pointer): TFileName;
+var
+  tmp: array[byte] of WideChar;
+  hm: HMODULE;
+begin
+  result := '';
+  FillcharFast(tmp, SizeOf(tmp), 0);
+  hm := 0;
+  if not GetModuleHandleExA(GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT or
+           GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, aAddress, hm) then
+    exit;
+  GetModuleFileNameW(hm, tmp, SizeOf(tmp));
+  result := string(SynUnicode(tmp));
+end;
+
+function FileIsWritable(const FileName: TFileName): boolean;
+var
+  FA: WIN32_FILE_ATTRIBUTE_DATA;
+begin
+  result := (FileName <> '') and
+            GetFileAttributesInternal(FileName, FA) and
+            (FA.dwFileAttributes and faReadOnly = 0);
+end;
+
+function FileExists(const FileName: TFileName; FollowLink, CheckAsDir: boolean): boolean;
+var
+  FA: WIN32_FILE_ATTRIBUTE_DATA;
+begin
+  result := (FileName <> '') and
+            GetFileAttributesInternal(FileName, FA, FollowLink) and
+            ((FA.dwFileAttributes and faDirectory <> 0) = CheckAsDir);
+end;
+
+function DirectoryExists(const FileName: TFileName; FollowLink: boolean): boolean;
+var
+  L: integer;
+begin
+  L := length(FileName);
+  if L = 0 then
+    result := false
+  else if (L = 1) and
+          (FileName[1] = '.') then
+    result := true
+  else if FileName[L] <> '\' then
+    result := FileExists(FileName, FollowLink, {checkasdir=}true)
+  else
+    result := FileExists(copy(FileName, 1, L - 1), FollowLink, true);
+end;
+
+function FileSize(const FileName: TFileName): Int64;
+var
+  FA: WIN32_FILE_ATTRIBUTE_DATA;
+begin
+  if (FileName <> '') and
+     GetFileAttributesInternal(FileName, FA) and
+     (FA.dwFileAttributes and faDirectory = 0) then
+    result := Qword(FA.nFileSizeHigh) shl 32 + FA.nFileSizeLow
+  else
+    result := 0;
+end;
+
+function FileInfoByName(const FileName: TFileName; out FileSize: Int64;
+  out FileTimestampUtc: TUnixMSTime): boolean;
+var
+  FA: WIN32_FILE_ATTRIBUTE_DATA;
+begin
+  result := (FileName <> '') and
+            GetFileAttributesInternal(FileName, FA);
+  if not result then
+    exit;
+  PInt64Rec(@FileSize)^.Lo := FA.nFileSizeLow;
+  PInt64Rec(@FileSize)^.Hi := FA.nFileSizeHigh;
+  FileTimestampUtc := FileTimeToUnixMSTime(FA.ftLastWriteTime) // no local time
+end;
+
+function GetFileSizeEx(hFile: THandle; var FileSize: Int64): BOOL;
+  stdcall; external kernel32;
+
+function FileSize(F: THandle): Int64;
+begin
+  if (PtrInt(F) <= 0) or
+     not GetFileSizeEx(F, result) then
+    result := 0;
+end;
+
+function FileSeek64(Handle: THandle; const Offset: Int64;
+  Origin: cardinal): Int64;
+var
+  r: TQWordRec;
+begin
+  r.V := Offset;
+  r.L := SetFilePointer(Handle, r.L, @r.H, Origin);
+  if (r.Li = -1) and
+     (GetLastError <> 0) then
+    result := -1
+  else
+    result := r.V;
+end;
+
+function DeleteFile(const aFileName: TFileName): boolean;
+var
+  tmp: TW32Temp;
+begin
+  if aFileName = '' then
+    result := false
+  else
+    result := DeleteFileW(W32(aFileName, tmp));
+end;
+
+function FileShare(aMode: integer): DWord;
+begin
+  case (aMode and $f0) of
+    fmShareRead:       // = fmShareDenyWrite
+      result := FILE_SHARE_READ;
+    fmShareWrite:      // = fmShareDenyRead
+      result := FILE_SHARE_WRITE;
+    fmShareReadWrite:  // = fmShareDenyNone
+      result := FILE_SHARE_READ or FILE_SHARE_WRITE;
+  else
+    result := 0;
+  end;
+end;
+
+function FileCreate(const aFileName: TFileName; aMode, aRights: integer): THandle;
+var
+  tmp: TW32Temp;
+begin
+  // aRights parameter is just ignored on Windows
+  if aFileName = '' then
+    result := 0
+  else
+    result := CreateFileW(W32(aFileName, tmp), GENERIC_READ or GENERIC_WRITE,
+      FileShare(aMode), nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
+end;
+
+const
+  FILE_WRITE_ATTRIBUTES = $0100; // not defined on oldest Delphi
+
+// W32() will support length > MAX_PATH even if aFileName is UnicodeString
+function FileOpen(const aFileName: TFileName; aMode: integer): THandle;
+const
+  ACCESS: array[0..2] of DWord = (
+    GENERIC_READ,   // fmOpenRead  = $0000
+    GENERIC_WRITE,  // fmOpenWrite = $0001
+    GENERIC_READ or GENERIC_WRITE or FILE_WRITE_ATTRIBUTES); // fmOpenReadWrite
+var
+  tmp: TW32Temp;
+begin
+  if aFileName = '' then
+    result := 0
+  else
+   result := CreateFileW(W32(aFileName, tmp), ACCESS[aMode and 3],
+      FileShare(aMode), nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
+end;
+
+function FileSetDateFrom(const Dest: TFileName; SourceHandle: THandle): boolean;
+var
+  FileTime: TFileTime;
+  D: THandle;
+begin
+  if (Dest = '') or
+     not ValidHandle(SourceHandle) then
+    result := false
+  else
+  begin
+    D := FileOpen(Dest, fmOpenWrite);
+    if ValidHandle(D) then
+    begin
+      result := GetFileTime(SourceHandle, nil, nil, @FileTime) and
+                SetFileTime(D, nil, nil, @FileTime);
+      FileClose(D);
+    end
+    else
+      result := false;
+  end;
+end;
+
+function FileSetDateFrom(const Dest, Source: TFileName): boolean;
+var
+  S: THandle;
+begin
+  result := false;
+  if (Dest = '') or
+     (Source = '') then
+    exit;
+  S := FileOpen(Source, fmOpenReadShared);
+  if not ValidHandle(S) then
+    exit;
+  result := FileSetDateFrom(Dest, S);
+  FileClose(S);
+end;
+
+procedure FileSetAttr(const FileName: TFileName; Attr: integer);
+var
+  tmp: TW32Temp;
+begin
+  if FileName <> '' then
+    SetFileAttributesW(W32(FileName, tmp), Attr);
+end;
+
+procedure FileSetHidden(const FileName: TFileName; ReadOnly: boolean);
+const
+  FLAGS: array[boolean] of integer = (
+    FILE_ATTRIBUTE_HIDDEN,
+    FILE_ATTRIBUTE_HIDDEN or FILE_ATTRIBUTE_READONLY);
+begin
+  FileSetAttr(FileName, FLAGS[ReadOnly]);
+end;
+
+procedure FileSetSticky(const FileName: TFileName);
+begin
+  FileSetAttr(FileName, FILE_ATTRIBUTE_HIDDEN or FILE_ATTRIBUTE_SYSTEM);
+end;
+
+function RenameFile(const OldName, NewName: TFileName): boolean;
+var
+  o, n: TW32Temp;
+begin
+  if (OldName = '') or
+     (NewName = '') then
+    result := false
+  else
+    result := MoveFileW(W32(OldName, o), W32(NewName, n));
+end;
+
+function FileSetTime(const FileName: TFileName;
+  const Created, Accessed, Written: Int64): boolean;
+var
+  tmp: TW32Temp;
+  h: THandle;
+  pct, pat, pwt: pointer;
+begin
+  result := false;
+  h := CreateFileW(W32(FileName, tmp), FILE_WRITE_ATTRIBUTES,
+    FILE_SHARE_READ, nil, OPEN_ALWAYS, 0, 0);
+  if ValidHandle(h) then
+    try
+      // some input code may not set all properties: use what we got
+      if Created <> 0 then
+        pct := @Created
+      else if Written <> 0 then
+        pct := @Written
+      else if Accessed <> 0 then
+        pct := @Accessed
+      else
+        exit;
+      if Accessed <> 0 then
+        pat := @Accessed
+      else if Written <> 0 then
+        pat := @Written
+      else
+        pat := @Created;
+      if Written <> 0 then
+        pwt := @Written
+      else if Created <> 0 then
+        pwt := @Created
+      else
+        pwt := @Accessed;
+      result := SetFileTime(h, pct, pat, pwt);
+    finally
+      CloseHandle(h);
+    end;
+end;
+
+function CopyFile(const Source, Target: TFileName; FailIfExists: boolean): boolean;
+var
+  s, t: TW32Temp;
+begin
+  if (Source = '') or
+     (Target = '') then
+    result := false
+  else
+    result := Windows.CopyFileW(W32(Source, s), W32(Target, t), FailIfExists);
+end;
+
+function ValidHandle(Handle: THandle): boolean;
+begin
+  result := PtrInt(Handle) > 0;
+end;
+
+function FileOpenSequentialRead(const FileName: TFileName): integer;
+var
+  tmp: TW32Temp;
+begin
+  result := CreateFileW(W32(FileName, tmp), GENERIC_READ,
+    FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
+    FILE_FLAG_SEQUENTIAL_SCAN, 0);
+end;
+
+function FileIsReadable(const aFileName: TFileName): boolean;
+var
+  tmp: TW32Temp;
+  h: THandle;
+begin
+  h := CreateFileW(W32(aFileName, tmp), GENERIC_READ,
+    FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
+  result := ValidHandle(h);
+  if result then
+    CloseHandle(h);
+end;
+
+threadvar // mandatory: GetTickCount seems per-thread on XP :(
+  LastTickXP: TQWordRec;
+
+function GetTickCount64ForXP: Int64; stdcall;
+var
+  t32: cardinal;
+  p: PQWordRec;
+begin
+  // warning: GetSystemTimeAsFileTime() is fast, but not monotonic!
+  t32 := Windows.GetTickCount; // we only have the 32-bit counter on XP
+  p := @LastTickXP;
+  inc(p^.H, ord(t32 < p^.L)); // wrap-up overflow after 49 days
+  p^.L := t32;
+  result := p^.V;
+end; // warning: FPC's GetTickCount64 doesn't handle 49 days wrap on XP :(
+
+procedure InitializeSRWLockForXP(var P: TOSLightMutex); stdcall;
+begin
+  TLightLock(P).Init; // TLightLock is good enough on XP
+end;
+
+procedure AcquireSRWLockExclusiveForXP(var P: TOSLightMutex); stdcall;
+begin
+  TLightLock(P).Lock;
+end;
+
+procedure ReleaseSRWLockExclusiveForXP(var P: TOSLightMutex); stdcall;
+begin
+  TLightLock(P).UnLock;
+end;
+
+function GetUptimeSec: cardinal;
+begin
+  result := GetTickCount64 div MSecsPerSec; // good enough
+end;
+
+procedure SleepHiRes(ms: cardinal);
+begin
+  if ms <> 0 then
+    Windows.Sleep(ms) // follow the HW timer: typically up to 16ms on Windows
+  else
+    SwitchToThread;
+end;
+
+
+{ TOSLightLock }
+
+procedure TOSLightLock.Init;
+begin
+  fMutex := nil;
+  InitializeSRWLock(fMutex); // fallback to TLightLock on XP
+end;
+
+procedure TOSLightLock.Done;
+begin // nothing needed
+end;
+
+procedure TOSLightLock.Lock;
+begin
+  AcquireSRWLockExclusive(fMutex);
+end;
+
+procedure TOSLightLock.UnLock;
+begin
+  ReleaseSRWLockExclusive(fMutex);
+end;
+
+
+{ TSynEvent }
+
+constructor TSynEvent.Create;
+begin
+  fHandle := pointer(CreateEvent(nil, false, false, nil));
+end;
+
+destructor TSynEvent.Destroy;
+begin
+  CloseHandle(THandle(fHandle));
+  inherited Destroy;
+end;
+
+procedure TSynEvent.ResetEvent;
+begin
+  Windows.ResetEvent(THandle(fHandle));
+end;
+
+procedure TSynEvent.SetEvent;
+begin
+  Windows.SetEvent(THandle(fHandle));
+end;
+
+procedure TSynEvent.WaitFor(TimeoutMS: integer);
+begin
+  WaitForSingleObject(THandle(fHandle), TimeoutMS);
+end;
+
+procedure TSynEvent.WaitForEver;
+begin
+  WaitForSingleObject(THandle(fHandle), INFINITE);
+end;
+
+
+{$ifdef FPC}
+  {$define NOSETTHREADNAME} // only tested and supported on Delphi
+{$endif FPC}
+
+const
+  // see http://msdn.microsoft.com/en-us/library/xcb2z8hs
+  cSetThreadNameException = $406D1388;
+
+{$ifdef NOSETTHREADNAME}
+
+procedure RawSetThreadName(ThreadID: TThreadID; const Name: RawUtf8);
+begin
+end;
+
+{$else}
+
+procedure RawSetThreadName(ThreadID: TThreadID; const Name: RawUtf8);
+var
+  s: AnsiString;
+  {$ifndef ISDELPHIXE2}
+  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 ISDELPHIXE2}
+begin
+  if not IsDebuggerPresent then
+    exit;
+  s := AnsiString(Name);
+  {$ifdef ISDELPHIXE2}
+  TThread.NameThreadForDebugging(s, ThreadID); // use
+  {$else}
+  info.FType := $1000;
+  info.FName := pointer(s);
+  info.FThreadID := ThreadID;
+  info.FFlags := 0;
+  try
+    RaiseException(
+      cSetThreadNameException, 0, SizeOf(info) div SizeOf(LongWord), @info);
+  except
+    {ignore}
+  end;
+  {$endif ISDELPHIXE2}
+end;
+
+{$endif NOSETTHREADNAME}
+
+function RawKillThread(Thread: TThread): boolean;
+begin
+  result := (Thread <> nil) and
+            Windows.TerminateThread(Thread.Handle, 777);
+end;
+
+procedure ResetCpuSet(out CpuSet: TCpuSet);
+begin
+  CpuSet := 0;
+end;
+
+function SetThreadMaskAffinity(Thread: TThread; const Mask: TCpuSet): boolean;
+begin
+  result := (Thread <> nil) and
+            (Windows.SetThreadAffinityMask(Thread.Handle, Mask) <> 0);
+end;
+
+function GetProcessAffinityMask(hProcess: THandle;
+  var lpProcessAffinityMask, lpSystemAffinityMask: TCpuSet): BOOL;
+    stdcall; external kernel32; // redefined for Delphi 7 compatibility
+
+function GetMaskAffinity(out CpuSet: TCpuSet): boolean;
+var
+  process, thread: TCpuSet;
+begin
+  result := GetProcessAffinityMask(GetCurrentProcess, process, thread);
+  if result then
+    CpuSet := process;
+end;
+
+type
+  // avoid linking of ComObj.pas just for EOleSysError
+  EOleSysError = class(Exception)
+  public
+    ErrorCode: cardinal;
+  end;
+
+{$ifndef NOEXCEPTIONINTERCEPT}
+
+const
+  // https://docs.microsoft.com/en-us/archive/blogs/yizhang/interpreting-hresults-returned-from-netclr-0x8013xxxx
+  // see also https://referencesource.microsoft.com/#mscorlib/system/__hresults.cs
+  DOTNET_EXCEPTIONNAME: array[0..91] of PUtf8Char = (
+    'Access',                            // $8013151A
+    'AmbiguousMatch',                    // $8000211D
+    'appdomainUnloaded',                 // $80131015
+    'Application',                       // $80131600
+    'Argument',                          // $80070057
+    'ArgumentNull',                      // $80004003
+    'ArgumentOutOfRange',                // $80131502
+    'Arithmetic',                        // $80070216
+    'ArrayTypeMismatch',                 // $80131503
+    'BadImageFormat',                    // $8007000B
+    'CannotUnloadappdomain',             // $80131015
+    'ContextMarshal',                    // $80090020
+    'Cryptographic',                     // $80004001
+    'CryptographicUnexpectedOperation',  // $80131431
+    'CustomAttributeFormat',             // $80131537
+    'DirectoryNotFound',                 // $80070003
+    'DirectoryNotFound',                 // $80030003
+    'DivideByZero',                      // $80020012
+    'DllNotFound',                       // $80131524
+    'DuplicateWaitObject',               // $80131529
+    'EndOfStream',                       // $00801338
+    'EntryPointNotFound',                // $80131522
+    '',                                  // $80131500 - name is plain Exception
+    'ExecutionEngine',                   // $80131506
+    'External',                          // $80004005
+    'FieldAccess',                       // $80131507
+    'FileLoad',                          // $80131621
+    'FileLoad',                          // $80131018
+    'FileNotFound',                      // $80070002
+    'Format',                            // $80131537
+    'IndexOutOfRange',                   // $80131508
+    'InvalidCast',                       // $80004002
+    'InvalidComObject',                  // $80131527
+    'InvalidFilterCriteria',             // $80131601
+    'InvalidOleVariantType',             // $80131531
+    'InvalidOperation',                  // $80131509
+    'InvalidProgram',                    // $8013153A
+    'IO',                                // $80131620
+    'IsolatedStorage',                   // $80131450
+    'MarshalDirective',                  // $80131535
+    'MethodAccess',                      // $80131510
+    'MissingField',                      // $80131511
+    'MissingManifestResource',           // $80131532
+    'MissingMember',                     // $80131512
+    'MissingMethod',                     // $80131513
+    'MulticastNotSupported',             // $80131514
+    'NotFiniteNumber',                   // $80131528
+    'NotImplemented',                    // $80004001
+    'NotSupported',                      // $80131515
+    'NullReference',                     // $80004003
+    'OutOfMemory',                       // $8007000E
+    'Overflow',                          // $80131516
+    'PlatformNotSupported',              // $80131539
+    'Policy',                            // $80131416
+    'Rank',                              // $80131517
+    'ReflectionTypeLoad',                // $80131602
+    'Remoting',                          // $8013150B
+    'RemotingTimeout',                   // $8013150B
+    'SafeArrayTypeMismatch',             // $80131533
+    'SafeArrayRankMismatch',             // $80131538
+    'Security',                          // $8013150A
+    'SEH',                               // $80004005
+    'Serialization',                     // $8013150C
+    'Server',                            // $8013150E
+    'StackOverflow',                     // $800703E9
+    'SUDSGenerator',                     // $80131500
+    'SUDSParser',                        // $80131500
+    'SynchronizationLock',               // $80131518
+    'System',                            // $80131501
+    'Target',                            // $80131603
+    'TargetInvocation',                  // $80131604
+    'TargetParameterCount',              // $80138002
+    'ThreadAbort',                       // $80131530
+    'ThreadInterrupted',                 // $80131519
+    'ThreadState',                       // $80131520
+    'ThreadStop',                        // $80131521
+    'TypeInitialization',                // $80131534
+    'TypeLoad',                          // $80131522
+    'TypeUnloaded',                      // $80131013
+    'UnauthorizedAccess',                // $80070005
+    'InClassConstructor',                // $80131543
+    'KeyNotFound',                       // $80131577
+    'InsufficientStack',                 // $80131578
+    'InsufficientMemory',                // $8013153D
+    'Verification',                      // $8013150D
+    'HostProtection',                    // $80131640
+    'MinGrantFailed',                    // $80131417
+    'Crypto',                            // $80131430
+    'CryptoUnexOper',                    // $80131431
+    'Overflow',                          // $8002000a
+    'InvalidName',                       // $80131047
+    'TypeMismatch');                     // $80028ca0
+
+  DOTNET_EXCEPTIONHRESULT: array[0..91] of cardinal = (
+    $8013151A,
+    $8000211D,
+    $80131015,
+    $80131600,
+    $80070057,
+    $80004003,
+    $80131502,
+    $80070216,
+    $80131503,
+    $8007000B,
+    $80131015,
+    $80090020,
+    $80004001,
+    $80131431,
+    $80131537,
+    $80070003,
+    $80030003,
+    $80020012,
+    $80131524,
+    $80131529,
+    $00801338,
+    $80131522,
+    $80131500,
+    $80131506,
+    $80004005,
+    $80131507,
+    $80131621,
+    $80131018,
+    $80070002,
+    $80131537,
+    $80131508,
+    $80004002,
+    $80131527,
+    $80131601,
+    $80131531,
+    $80131509,
+    $8013153A,
+    $80131620,
+    $80131450,
+    $80131535,
+    $80131510,
+    $80131511,
+    $80131532,
+    $80131512,
+    $80131513,
+    $80131514,
+    $80131528,
+    $80004001,
+    $80131515,
+    $80004003,
+    $8007000E,
+    $80131516,
+    $80131539,
+    $80131416,
+    $80131517,
+    $80131602,
+    $8013150B,
+    $8013150B,
+    $80131533,
+    $80131538,
+    $8013150A,
+    $80004005,
+    $8013150C,
+    $8013150E,
+    $800703E9,
+    $80131500,
+    $80131500,
+    $80131518,
+    $80131501,
+    $80131603,
+    $80131604,
+    $80138002,
+    $80131530,
+    $80131519,
+    $80131520,
+    $80131521,
+    $80131534,
+    $80131522,
+    $80131013,
+    $80070005,
+    $80131543,
+    $80131577,
+    $80131578,
+    $8013153D,
+    $8013150D,
+    $80131640,
+    $80131417,
+    $80131430,
+    $80131431,
+    $8002000a,
+    $80131047,
+    $80028ca0);
+
+function ExceptionInheritsFrom(E: TClass; const Name: ShortString): boolean;
+begin
+  result := true;
+  while (E <> nil) and
+        (E <> Exception) do
+    if PropNameEquals(PPointer(PtrInt(E) + vmtClassName)^, @Name) then
+      exit
+    else
+      E := GetClassParent(E);
+  result := false;
+end;
+
+function TSynLogExceptionContext.AdditionalInfo(
+  out ExceptionNames: TPUtf8CharDynArray): cardinal;
+var
+  i: PtrInt;
+begin
+  if ExceptionInheritsFrom(EClass, 'EOleSysError') then
+  begin
+    result := EOleSysError(EInstance).ErrorCode;
+    if result > $80000000 then
+      for i := 0 to high(DOTNET_EXCEPTIONHRESULT) do
+        // manual loop: the same error code can appear several times
+        if DOTNET_EXCEPTIONHRESULT[i] = result then
+          PtrArrayAdd(ExceptionNames, DOTNET_EXCEPTIONNAME[i]);
+  end
+  else
+    result := 0;
+end;
+
+var
+  _RawLogException: TOnRawLogException;
+
+{$ifdef FPC}
+  {$ifdef WIN64}
+    {$define WITH_VECTOREXCEPT} // use AddVectoredExceptionHandler Win64 API
+  {$else}
+    {$ifdef FPC_USE_WIN32_SEH}
+      {$define WITH_VECTOREXCEPT} // new since FPC 3.2
+    {$else}
+      // Win32, Linux: intercept via the RaiseProc global variable
+      {$define WITH_RAISEPROC} // RaiseProc is set in main mormot.core.os.pas
+    {$endif FPC_USE_WIN32_SEH}
+  {$endif WIN64}
+{$else}
+  {$ifdef CPU64}
+    {$define WITH_VECTOREXCEPT}
+  {$else}
+    {$define WITH_RTLUNWINDPROC} //  use x86_64 asm -> Win32 only
+  {$endif CPU64}
+{$endif FPC}
+
+{$ifndef WITH_RAISEPROC}
+
+type
+  PExceptionRecord = ^TExceptionRecord;
+  TExceptionRecord = record
+    ExceptionCode: DWord;
+    ExceptionFlags: DWord;
+    OuterException: PExceptionRecord;
+    ExceptionAddress: PtrUInt;
+    NumberParameters: integer;
+    case {IsOsException:} boolean of
+      true:
+        (ExceptionInformation: array[0..14] of PtrUInt);
+      false:
+        (ExceptAddr: PtrUInt;
+         ExceptObject: Exception);
+  end;
+  GetExceptionClass = function(const P: TExceptionRecord): ExceptClass;
+
+const
+  {$ifdef FPC}
+  cRtlException = $E0465043; // $E0 F P C
+  {$else}
+  cRtlException = $0EEDFADE; // Delphi exception
+  {$endif FPC}
+
+procedure LogExcept(stack: PPtrUInt; const Exc: TExceptionRecord);
+var
+  ctxt: TSynLogExceptionContext;
+  backuplasterror: DWord;
+  backuphandler: TOnRawLogException;
+begin
+  if Exc.ExceptionCode = cSetThreadNameException then
+    exit;
+  backuplasterror := GetLastError;
+  backuphandler := _RawLogException;
+  if Assigned(backuphandler) then // paranoid check (tested before calling)
+    try
+      _RawLogException := nil; // disable nested exception
+      ctxt.ECode := Exc.ExceptionCode;
+      if (Exc.ExceptionCode = cRtlException) and
+         (Exc.ExceptObject <> nil) then
+      begin
+        if Exc.ExceptObject.InheritsFrom(Exception) then
+          ctxt.EClass := PPointer(Exc.ExceptObject)^
+        else
+          ctxt.EClass := EExternalException;
+        ctxt.EInstance := Exc.ExceptObject;
+        ctxt.ELevel := sllException;
+        ctxt.EAddr := Exc.ExceptAddr;
+      end
+      else
+      begin
+        if Assigned(ExceptClsProc) then
+          ctxt.EClass := GetExceptionClass(ExceptClsProc)(Exc)
+        else
+          ctxt.EClass := EExternal;
+        ctxt.EInstance := nil;
+        ctxt.ELevel := sllExceptionOS;
+        ctxt.EAddr := Exc.ExceptionAddress;
+      end;
+      ctxt.EStack := pointer(stack);
+      ctxt.EStackCount := 0;
+      ctxt.ETimestamp := UnixTimeUtc; // fast API call
+      backuphandler(ctxt);
+    except
+      { ignore any nested exception }
+    end;
+  _RawLogException := backuphandler;
+  SetLastError(backuplasterror); // code above could have changed this
+end;
+
+{$ifdef WITH_VECTOREXCEPT}
+
+type
+  PExceptionInfo = ^TExceptionInfo;
+  TExceptionInfo = packed record
+    ExceptionRecord: PExceptionRecord;
+    ContextRecord: pointer;
+  end;
+
+var
+  AddVectoredExceptionHandler: function(FirstHandler: cardinal;
+    VectoredHandler: pointer): PtrInt; stdcall;
+
+function SynLogVectoredHandler(ExceptionInfo: PExceptionInfo): PtrInt; stdcall;
+const
+  EXCEPTION_CONTINUE_SEARCH = 0;
+begin
+  if Assigned(_RawLogException) then
+    LogExcept(nil, ExceptionInfo^.ExceptionRecord^);
+  result := EXCEPTION_CONTINUE_SEARCH;
+end;
+
+{$endif WITH_VECTOREXCEPT}
+
+{$ifdef WITH_RTLUNWINDPROC}
+
+var
+  OldUnWindProc: pointer;
+
+procedure SynRtlUnwind(TargetFrame, TargetIp: pointer;
+  ExceptionRecord: PExceptionRecord; ReturnValue: Pointer); stdcall;
+asm
+        cmp     dword ptr _RawLogException, 0
+        jz      @old
+        pushad
+        mov     eax, TargetFrame
+        mov     edx, ExceptionRecord
+        call    LogExcept
+        popad
+@old:   pop     ebp // hidden push ebp at asm level
+        jmp     OldUnWindProc
+end;
+
+{$endif WITH_RTLUNWINDPROC}
+
+{$endif WITH_RAISEPROC}
+
+{$endif NOEXCEPTIONINTERCEPT}
+
+{ TMemoryMap }
+
+function TMemoryMap.DoMap(aCustomOffset: Int64): boolean;
+begin
+  with PInt64Rec(@fFileSize)^ do
+    fMap := CreateFileMapping(fFile, nil, PAGE_READONLY, Hi, Lo, nil);
+  if fMap = 0 then
+    RaiseLastError('TMemoryMap.Map: CreateFileMapping');
+  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;
+  end;
+  result := fMap <> 0;
+end;
+
+procedure TMemoryMap.DoUnMap;
+begin
+  if fMap <> 0 then
+  begin
+    UnmapViewOfFile(fBuf);
+    CloseHandle(fMap);
+    fMap := 0;
+  end;
+end;
+
+const
+  STUB_SIZE = 65536; // 16*4 KB (4 KB = memory granularity)
+
+type
+  TProcessMemoryCounters = record
+    cb: DWord;
+    PageFaultCount: DWord;
+    PeakWorkingSetSize: PtrUInt;
+    WorkingSetSize: PtrUInt;
+    QuotaPeakPagedPoolUsage: PtrUInt;
+    QuotaPagedPoolUsage: PtrUInt;
+    QuotaPeakNonPagedPoolUsage: PtrUInt;
+    QuotaNonPagedPoolUsage: PtrUInt;
+    PagefileUsage: PtrUInt;
+    PeakPagefileUsage: PtrUInt;
+  end;
+
+const
+  PROCESS_QUERY_LIMITED_INFORMATION = $1000;
+
+var
+  // PROCESS_QUERY_INFORMATION (XP) / PROCESS_QUERY_LIMITED_INFORMATION (Vista+)
+  OpenProcessAccess: DWord;
+
+  // late-binding of Windows API entries not available on XP
+  GetSystemTimes: function(
+    var lpIdleTime, lpKernelTime, lpUserTime: TFileTime): BOOL; stdcall;
+  GetProcessTimes: function(hProcess: THandle;
+    var lpCreationTime, lpExitTime, lpKernelTime,
+        lpUserTime: TFileTime): BOOL; stdcall;
+  // Vista+/WS2008+ (use GetModuleFileNameEx on XP)
+  QueryFullProcessImageNameW: function(hProcess: THandle; dwFlags: DWord;
+    lpExeName: PWideChar; lpdwSize: PDWord): BOOL; stdcall;
+  // PSAPI API late-binding via DelayedProc()
+  GetProcessMemoryInfo: function(Process: THandle;
+    var ppsmemCounters: TProcessMemoryCounters; cb: DWord): BOOL; stdcall;
+  EnumProcesses: function(lpidProcess: PDWord; cb: DWord;
+    var cbNeeded: DWord): BOOL; stdcall;
+  GetModuleFileNameExW: function(hProcess: THandle; hModule: HMODULE;
+    lpBaseName: PWideChar; nSize: DWord): DWord; stdcall;
+
+function DelayedProc(var api; var lib: THandle;
+  libname: PChar; procname: PAnsiChar): boolean;
+var
+  proc: pointer;
+begin
+  if pointer(api) = nil then
+  begin
+    proc := nil;
+    GlobalLock; // avoid race condition
+    if lib = 0 then
+      lib := Windows.LoadLibrary(libname);
+    if lib >= 32 then
+      proc := Windows.GetProcAddress(lib, procname)
+    else
+      lib := 1; // try to load the library once
+    if proc = nil then
+      proc := pointer(1); // mark non available
+    pointer(api) := proc; // set it last
+    GlobalUnLock;
+  end;
+  result := pointer(api) <> pointer(1);
+end;
+
+
+function GetNextItem(var P: PAnsiChar): RawUtf8;
+var
+  S: PAnsiChar;
+begin
+  result := '';
+  while P^ <= ' ' do
+    if P^ = #0 then
+      exit
+    else
+      inc(P);
+  S := P;
+  repeat
+    inc(P);
+  until P^ <= ' ';
+  FastSetString(result, S, P - S);
+end;
+
+const
+  PAGE_GUARD = $0100;
+  PAGE_VALID = $00e6; // PAGE_READONLY or PAGE_READWRITE or PAGE_EXECUTE or
+      // PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE or PAGE_EXECUTE_WRITECOPY
+
+var
+  LastMemInfo: TMemoryBasicInformation; // simple cache
+
+function SeemsRealPointer(p: pointer): boolean;
+var
+  meminfo: TMemoryBasicInformation;
+begin
+  result := false;
+  if PtrUInt(p) <= 65535 then
+    exit; // first 64KB is not a valid pointer by definition
+  if (LastMemInfo.State <> 0) and
+     (PtrUInt(p) - PtrUInt(LastMemInfo.BaseAddress) <=
+       PtrUInt(LastMemInfo.RegionSize)) then
+    result := true // reuse last memory region information if we can
+  else
+  begin
+    // VirtualQuery API is slow but better than raising an exception
+    // see https://stackoverflow.com/a/37547837/458259
+    FillCharFast(meminfo, SizeOf(meminfo), 0);
+    result := (VirtualQuery(p, meminfo, SizeOf(meminfo)) = SizeOf(meminfo)) and
+              (meminfo.RegionSize >= SizeOf(pointer)) and
+              (meminfo.State = MEM_COMMIT) and
+              (meminfo.Protect and PAGE_VALID <> 0) and
+              (meminfo.Protect and PAGE_GUARD = 0);
+    if result then
+      LastMemInfo := meminfo;
+  end;
+end;
+
+var
+  PsapiDll: THandle;
+
+function EnumAllProcesses: TCardinalDynArray;
+var
+  n, count: cardinal;
+begin
+  result := nil;
+  if not DelayedProc(EnumProcesses, PsapiDll, 'Psapi.dll', 'EnumProcesses') then
+    exit;
+  count := 0;
+  n := 2048; // retrieve 2KB of IDs, i.e. 512 processes, by default
+  repeat
+    SetLength(result, n);
+    if EnumProcesses(pointer(result), n * 4, count) then
+      count := count shr 2 // from bytes to count
+    else
+      count := 0; // error
+    if count < n then
+      break;
+    // count=n if buffer was too small
+    inc(n, 1024);
+  until n > 8192;
+  if count = 0 then
+    result := nil // on error
+  else
+    DynArrayFakeLength(result, count); // no realloc
+end;
+
+function EnumProcessName(PID: cardinal): RawUtf8;
+var
+  h: THandle;
+  len: DWord;
+  name: array[0..4095] of WideChar;
+begin
+  result := '';
+  if PID = 0 then
+    exit;
+  h := OpenProcess(OpenProcessAccess, false, PID);
+  if h <> 0 then
+    try
+      if Assigned(QueryFullProcessImageNameW) then
+      begin
+        len := high(name);
+        if QueryFullProcessImageNameW(h, 0, name, @len) then
+          Win32PWideCharToUtf8(name, len, result);
+      end
+      else if DelayedProc(GetModuleFileNameExW, PsapiDll, 'Psapi.dll',
+                'GetModuleFileNameExW') and
+              (GetModuleFileNameExW(h, 0, name, high(name)) <> 0) then
+        Win32PWideCharToUtf8(name, result);
+    finally
+      CloseHandle(h);
+    end;
+end;
+
+// some definitions missing on Delphi and/or FPC
+type
+  TProcessEntry32 = record
+    dwSize: DWORD;
+    cntUsage: DWORD;
+    th32ProcessID: DWORD;          // this process
+    th32DefaultHeapID: PtrUInt;
+    th32ModuleID:DWORD;            // associated exe
+    cntThreads: DWORD;
+    th32ParentProcessID: DWORD;    // this process's parent process
+    pcPriClassBase: integer;          // Base priority of process's threads
+    dwFlags: DWORD;
+    szExeFile: array [0..MAX_PATH - 1] of WideChar;   // Path
+  end;
+
+  TThreadEntry32 = record
+    dwSize: DWord;
+    cntUsage: DWord;
+    th32ThreadID: DWord;       // this thread
+    th32OwnerProcessID: DWord; // Process this thread is associated with
+    tpBasePri: integer;
+    tpDeltaPri: integer;
+    dwFlags: DWord;
+  end;
+
+const
+  TH32CS_SNAPPROCESS  = $00000002;
+  TH32CS_SNAPTHREAD = $00000004;
+
+function AttachConsole(pid: cardinal): BOOL;
+  stdcall; external kernel32;
+function GetConsoleWindow: HWND;
+  stdcall; external kernel32;
+function CreateToolhelp32Snapshot(dwFlags, th32ProcessID: DWord): THandle;
+  stdcall; external kernel32;
+function Process32FirstW(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL;
+  stdcall; external kernel32;
+function Process32NextW(hSnapshot: THandle; var lppe: TProcessEntry32): BOOL;
+  stdcall; external kernel32;
+function Thread32First(hSnapshot: THandle; var lpte: TThreadEntry32): BOOL;
+  stdcall; external kernel32;
+function Thread32Next(hSnapshot: THandle; var lpte: TThreadEntry32): BOOL;
+  stdcall; external kernel32;
+
+function PostThreadMessage(idThread: DWord; Msg: UINT; wParam: WPARAM;
+    lParam: LPARAM): BOOL;
+  stdcall; external user32 name 'PostThreadMessageW';
+
+function RawProcessInfo(pid: cardinal; var e: TProcessEntry32): boolean;
+var
+  snap: THandle;
+begin
+  result := false;
+  if integer(pid) <= 0 then
+    pid := GetCurrentProcessId;
+  snap := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
+  if snap <= 0 then
+    exit;
+  FillCharFast(e, SizeOf(e), 0);
+  e.dwSize := SizeOf(e);
+  result := true;
+  if Process32FirstW(snap, e) then // loop over all processes of the system
+    repeat
+      if e.th32ProcessID = pid then
+        exit;
+    until not Process32NextW(snap, e);
+  CloseHandle(snap);
+  result := false;
+end;
+
+function GetParentProcess(PID: cardinal): cardinal;
+var
+  e: TProcessEntry32;
+begin
+  if RawProcessInfo(PID, e) then
+    result := e.th32ParentProcessID
+  else
+    result := 0;
+end;
+
+function RetrieveSystemTimes(out IdleTime, KernelTime, UserTime: Int64): boolean;
+var
+  ftidl, ftkrn, ftusr: TFileTime;
+begin
+  result := Assigned(GetSystemTimes) and
+            GetSystemTimes(ftidl, ftkrn, ftusr);
+  if not result then
+    exit;
+  FileTimeToInt64(ftidl, IdleTime);
+  FileTimeToInt64(ftkrn, KernelTime);
+  FileTimeToInt64(ftusr, UserTime);
+end;
+
+function RetrieveLoadAvg: RawUtf8;
+begin
+  result := ''; // call RetrieveSystemTimes() instead
+end;
+
+function DelayedGetProcessMemoryInfo: boolean;
+begin
+  result:= DelayedProc(GetProcessMemoryInfo, PsapiDll, 'Psapi.dll',
+    'GetProcessMemoryInfo');
+end;
+
+function RetrieveProcessInfo(PID: cardinal; out KernelTime, UserTime: Int64;
+  out WorkKB, VirtualKB: cardinal): boolean;
+var
+  h: THandle;
+  ftkrn, ftusr, ftp, fte: TFileTime;
+  mem: TProcessMemoryCounters;
+begin
+  result := false;
+  if (not Assigned(GetProcessTimes)) or
+     (not DelayedGetProcessMemoryInfo) then
+    exit;
+  h := OpenProcess(OpenProcessAccess, false, PID);
+  if h = 0 then
+    exit;
+  try
+    if GetProcessTimes(h, ftp, fte, ftkrn, ftusr) then
+    begin
+      FileTimeToInt64(ftkrn, KernelTime);
+      FileTimeToInt64(ftusr, UserTime);
+      FillCharFast(mem, SizeOf(mem), 0);
+      mem.cb := SizeOf(mem);
+      if GetProcessMemoryInfo(h, mem, SizeOf(mem)) then
+      begin
+        WorkKB := mem.WorkingSetSize shr 10;
+        VirtualKB := mem.PagefileUsage shr 10;
+      end;
+      result := true;
+    end;
+  finally
+    CloseHandle(h);
+  end;
+end;
+
+function CoCreateGuid(out guid: THash128Rec): HRESULT;
+  stdcall; external 'ole32.dll';
+
+procedure XorOSEntropy(var e: THash512Rec);
+var
+  h: THash128Rec;
+  ft: packed record
+    krn, usr, p, e: TFileTime;
+  end;
+  mem: TProcessMemoryCounters;
+begin
+  QueryPerformanceCounter(h.Lo); // e.h3 xored with raw timestamps
+  e.i[6] := e.i[6] xor h.Lo;
+  if Assigned(GetProcessTimes) then
+    GetProcessTimes(GetCurrentProcess, ft.p, ft.e, ft.krn, ft.usr);
+  DefaultHasher128(@e.h0, @ft, SizeOf(ft));
+  if Assigned(GetProcessMemoryInfo) then // may have been delayed
+  begin
+    mem.cb := SizeOf(mem);
+    GetProcessMemoryInfo(GetCurrentProcess, mem, SizeOf(mem));
+    DefaultHasher128(@e.h1, @mem, SizeOf(mem));
+  end;
+  if Assigned(GetSystemTimes) then
+    GetSystemTimes(ft.usr, ft.p, ft.e);
+  DefaultHasher128(@e.h2, @ft, SizeOf(ft));
+  CoCreateGuid(h); // very fast on Windows - used to obfuscate system info
+  e.i[0] := e.i[0] xor h.Lo;
+  e.i[1] := e.i[1] xor h.Hi;
+  CoCreateGuid(h);
+  e.i[2] := e.i[2] xor h.Lo;
+  e.i[3] := e.i[3] xor h.Hi;
+  CoCreateGuid(h);
+  e.i[4] := e.i[4] xor h.Lo;
+  e.i[5] := e.i[5] xor h.Hi;
+  CoCreateGuid(h);
+  e.i[6] := e.i[6] xor h.Lo;
+  e.i[7] := e.i[7] xor h.Hi;
+  QueryPerformanceCounter(h.Lo); // is likely to have changed in-between
+  e.i[7] := e.i[7] xor h.Lo;     // e.h3 xored with raw timestamps
+end;
+
+function FillSystemRandom(Buffer: PByteArray; Len: integer;
+  AllowBlocking: boolean): boolean;
+var
+  prov: HCRYPTPROV;
+begin
+  result := false;
+  if Len <= 0 then
+    exit;
+  // warning: on some Windows versions, this could take up to 30 ms!
+  if CryptoApi.Available then
+    if CryptoApi.AcquireContextA(prov, nil, nil,
+      PROV_RSA_FULL, CRYPT_VERIFYCONTEXT) then
+    begin
+      result := CryptoApi.GenRandom(prov, Len, Buffer);
+      CryptoApi.ReleaseContext(prov, 0);
+    end;
+  if not result then
+    // OS API call failed -> fallback to our Lecuyer's gsl_rng_taus2 generator
+    RandomBytes(pointer(Buffer), Len);
+end;
+
+function TProcessInfo.Init: boolean;
+begin
+  FillCharFast(self, SizeOf(self), 0);
+  // no monitoring API available under oldest Windows
+  result := Assigned(GetSystemTimes) and
+            Assigned(GetProcessTimes) and
+            DelayedGetProcessMemoryInfo;
+end;
+
+function TProcessInfo.Start: boolean;
+var
+  ftidl, ftkrn, ftusr: TFileTime;
+  sidl, skrn, susr: Int64;
+begin
+  result := Assigned(GetSystemTimes) and
+            GetSystemTimes(ftidl, ftkrn, ftusr);
+  if not result then
+    exit;
+  FileTimeToInt64(ftidl, sidl);
+  FileTimeToInt64(ftkrn, skrn);
+  FileTimeToInt64(ftusr, susr);
+  fDiffIdle := sidl - fSysPrevIdle;
+  fDiffKernel := skrn - fSysPrevKernel;
+  fDiffUser := susr - fSysPrevUser;
+  fDiffTotal := fDiffKernel + fDiffUser; // kernel time also includes idle time
+  dec(fDiffKernel, fDiffIdle);
+  fSysPrevIdle := sidl;
+  fSysPrevKernel := skrn;
+  fSysPrevUser := susr;
+end;
+
+function TProcessInfo.PerProcess(PID: cardinal; Now: PDateTime;
+  out Data: TSystemUseData; var PrevKernel, PrevUser: Int64): boolean;
+var
+  h: THandle;
+  ftkrn, ftusr, ftp, fte: TFileTime;
+  pkrn, pusr: Int64;
+  mem: TProcessMemoryCounters;
+begin
+  result := false;
+  FillCharFast(Data, SizeOf(Data), 0);
+  h := OpenProcess(OpenProcessAccess, false, PID);
+  if h <> 0 then
+  try
+    if GetProcessTimes(h, ftp, fte, ftkrn, ftusr) then
+    begin
+      if Now <> nil then
+        Data.Timestamp := Now^;
+      FileTimeToInt64(ftkrn, pkrn);
+      FileTimeToInt64(ftusr, pusr);
+      if (PrevKernel <> 0) and
+         (fDiffTotal > 0) then
+      begin
+        Data.Kernel := ((pkrn - PrevKernel) * 100) / fDiffTotal;
+        Data.User   := ((pusr - PrevUser)   * 100) / fDiffTotal;
+      end;
+      PrevKernel := pkrn;
+      PrevUser := pusr;
+      FillCharFast(mem, SizeOf(mem), 0);
+      mem.cb := SizeOf(mem);
+      if GetProcessMemoryInfo(h, mem, SizeOf(mem)) then
+      begin
+        Data.WorkKB    := mem.WorkingSetSize shr 10;
+        Data.VirtualKB := mem.PagefileUsage  shr 10;
+      end;
+      result := true;
+    end;
+  finally
+    CloseHandle(h);
+  end;
+end;
+
+function TProcessInfo.PerSystem(out Idle, Kernel, User: single): boolean;
+begin
+  if fDiffTotal <= 0 then
+  begin
+    Idle   := 0;
+    Kernel := 0;
+    User   := 0;
+    result := false;
+  end
+  else
+  begin
+    Kernel := {%H-}SimpleRoundTo2Digits((fDiffKernel * 100) / fDiffTotal);
+    User   := {%H-}SimpleRoundTo2Digits((fDiffUser * 100)   / fDiffTotal);
+    Idle   := 100 - Kernel - User; // ensure sum is always 100%
+    result := true;
+  end;
+end;
+
+{$ifndef UNICODE} // 64-bit aware Windows API missing on FPC and oldest Delphi
+
+type
+  TMemoryStatusEx = record
+    dwLength: DWord;
+    dwMemoryLoad: DWord;
+    ullTotalPhys: QWord;
+    ullAvailPhys: QWord;
+    ullTotalPageFile: QWord;
+    ullAvailPageFile: QWord;
+    ullTotalVirtual: QWord;
+    ullAvailVirtual: QWord;
+    ullAvailExtendedVirtual: QWord;
+  end;
+
+// information about the system's current usage of both physical and virtual memory
+function GlobalMemoryStatusEx(var lpBuffer: TMemoryStatusEx): BOOL;
+  stdcall; external kernel32;
+
+{$endif UNICODE}
+
+function GetMemoryInfo(out info: TMemoryInfo; withalloc: boolean): boolean;
+{$ifdef WITH_FASTMM4STATS}
+var
+  Heap: TMemoryManagerState;
+  sb: PtrInt;
+{$endif WITH_FASTMM4STATS}
+var
+  global: TMemoryStatusEx;
+  mem: TProcessMemoryCounters;
+begin
+  FillCharFast(global, SizeOf(global), 0);
+  global.dwLength := SizeOf(global);
+  result := GlobalMemoryStatusEx(global);
+  info.percent   := global.dwMemoryLoad;
+  info.memtotal  := global.ullTotalPhys;
+  info.memfree   := global.ullAvailPhys;
+  info.filetotal := global.ullTotalPageFile;
+  info.filefree  := global.ullAvailPageFile;
+  info.vmtotal   := global.ullTotalVirtual;
+  info.vmfree    := global.ullAvailVirtual;
+  info.allocreserved := 0;
+  info.allocused     := 0;
+  if not withalloc then
+    exit;
+  {$ifdef WITH_FASTMM4STATS} // override OS information by actual FastMM4
+  GetMemoryManagerState(Heap); // direct raw FastMM4 access
+  info.allocused := Heap.TotalAllocatedMediumBlockSize +
+                    Heap.TotalAllocatedLargeBlockSize;
+  info.allocreserved := Heap.ReservedMediumBlockAddressSpace +
+                        Heap.ReservedLargeBlockAddressSpace;
+  for sb := 0 to high(Heap.SmallBlockTypeStates) do
+    with Heap.SmallBlockTypeStates[sb] do
+    begin
+      inc(info.allocused, UseableBlockSize * AllocatedBlockCount);
+      inc(info.allocreserved, ReservedAddressSpace);
+    end;
+  {$else}
+  if not DelayedGetProcessMemoryInfo then
+    exit;
+  FillcharFast(mem, SizeOf(mem), 0);
+  mem.cb := SizeOf(mem);
+  GetProcessMemoryInfo(GetCurrentProcess, mem, SizeOf(mem));
+  info.allocreserved := mem.PeakWorkingSetSize;
+  info.allocused     := mem.WorkingSetSize;
+  {$endif WITH_FASTMM4STATS}
+end;
+
+function GetDiskFreeSpaceExW(lpDirectoryName: PWideChar;
+  var lpFreeBytesAvailableToCaller, lpTotalNumberOfBytes,
+  lpTotalNumberOfFreeBytes: QWord): LongBool;
+   stdcall; external kernel32;
+
+{
+// DeviceIoControl(IOCTL_DISK_GET_PARTITION_INFO) requires root -> not used
+function DeviceIoControl(hDevice: THandle; dwIoControlCode: DWord;
+  lpInBuffer: Pointer; nInBufferSize: DWord; lpOutBuffer: Pointer;
+  nOutBufferSize: DWord; var lpBytesReturned: DWord;
+  lpOverlapped: POverlapped): BOOL; stdcall; external kernel32;
+}
+
+function GetDiskInfo(var aDriveFolderOrFile: TFileName;
+  out aAvailableBytes, aFreeBytes, aTotalBytes: QWord;
+  aVolumeName: PSynUnicode): boolean;
+var
+  tmp: array[0..MAX_PATH - 1] of WideChar;
+  dummy, flags: DWord;
+  dn: SynUnicode;
+begin
+  if aDriveFolderOrFile = '' then
+    aDriveFolderOrFile := SysUtils.UpperCase(
+      ExtractFileDrive(Executable.ProgramFilePath));
+  dn := SynUnicode(aDriveFolderOrFile); // use RTL for UTF-16 conversion
+  if (dn <> '') and
+     (dn[2] = ':') and
+     (dn[3] = #0) then
+    dn := dn + '\';
+  if (aVolumeName <> nil) and
+     (aVolumeName^ = '') then
+  begin
+    tmp[0] := #0;
+    GetVolumeInformationW(pointer(dn), tmp, MAX_PATH, nil, dummy, flags, nil, 0);
+    aVolumeName^ := tmp;
+  end;
+  result := GetDiskFreeSpaceExW(pointer(dn),
+    aAvailableBytes, aTotalBytes, aFreeBytes);
+end;
+
+function GetDiskPartitions: TDiskPartitions;
+var
+  drives, drive, m, n: integer;
+  fn: TFileName;
+  volume: SynUnicode;
+  av, fr, tot: QWord;
+  p: ^TDiskPartition;
+begin
+  result := nil;
+  n := 0;
+  fn := '#:';
+  drives := GetLogicalDrives;
+  m := 1 shl 2; // bit 2 = drive C
+  for drive := 3 to 26 do
+  begin
+    // retrieve partitions mounted as C..Z drives
+    if drives and m <> 0 then
+    begin
+      fn[1] := char(64 + drive);
+      if GetDiskInfo(fn, av, fr, tot, @volume) then
+      begin
+        SetLength(result, n + 1);
+        p := @result[n];
+        Win32PWideCharToUtf8(pointer(volume), length(volume), p^.name);
+        p^.mounted := fn;
+        p^.size := tot;
+        volume := '';
+        inc(n);
+      end;
+    end;
+    m := m shl 1;
+  end;
+end;
+
+var
+  TextAttr: integer = ord(ccDarkGray);
+
+procedure TextColor(Color: TConsoleColor);
+var
+  oldAttr: integer;
+begin
+  if not HasConsole then
+    exit;
+  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
+  if not HasConsole then
+    exit;
+  oldAttr := TextAttr;
+  TextAttr := (TextAttr and $0F) or (ord(Color) shl 4);
+  if TextAttr <> oldAttr then
+    SetConsoleTextAttribute(StdOut, TextAttr);
+end;
+
+var
+  ConsoleCriticalSection: TOSLock;
+
+procedure ConsoleWrite(const Text: RawUtf8; Color: TConsoleColor;
+  NoLineFeed, NoColor: boolean);
+var
+  txt: RawByteString;
+  l: PtrInt;
+  written: cardinal;
+begin
+  if not HasConsole then
+    exit;
+  txt := Utf8ToConsole(Text);
+  l := length(txt);
+  if not NoLineFeed then
+  begin
+    SetLength(txt, l + 2); // faster to reallocate than WriteFile() twice
+    PWord(@PByteArray(txt)[l])^ := $0a0d; // CRLF
+    inc(l, 2);
+  end;
+  ConsoleCriticalSection.Lock;
+  try
+    if not NoColor then
+      TextColor(Color);
+    WriteFile(StdOut, pointer(txt)^, l, written, nil);
+    // FlushFileBuffers(StdOut); // don't: would block until read on the pipe
+  finally
+    ConsoleCriticalSection.UnLock;
+  end;
+end;
+
+function ConsoleKeyPressed(ExpectedKey: Word): boolean;
+var
+  events, read: DWord;
+  rec: TInputRecord;
+  h: THandle;
+begin
+  result := false;
+  h := GetStdHandle(STD_INPUT_HANDLE);
+  events := 0;
+  GetNumberOfConsoleInputEvents(h, events);
+  if events <> 0 then
+  begin
+    PeekConsoleInput(h, rec, 1, read);
+    if read <> 0 then
+      if rec.EventType = KEY_EVENT then
+        if rec.Event.KeyEvent.bKeyDown and
+           ((ExpectedKey = 0) or
+            (rec.Event.KeyEvent.wVirtualKeyCode = ExpectedKey)) then
+          result := true
+        else
+          FlushConsoleInputBuffer(h)
+      else
+        FlushConsoleInputBuffer(h);
+  end;
+end;
+
+type
+  TConsoleHandleCtrlC = class
+  private
+    class procedure HandleCtrlC;
+  end;
+var
+  ConsoleHandleCtrlCPressed: boolean;
+
+class procedure TConsoleHandleCtrlC.HandleCtrlC;
+begin
+  ConsoleHandleCtrlCPressed := true;
+end;
+
+procedure ConsoleWaitForEnterKey;
+var
+  msg: TMsg;
+begin
+  ConsoleHandleCtrlCPressed := false;
+  HandleCtrlC(TConsoleHandleCtrlC.HandleCtrlC);
+  try
+    if GetCurrentThreadID = MainThreadID then
+      // process the messages from the main thread while waiting
+      while not ConsoleKeyPressed(VK_RETURN) and
+            not ConsoleHandleCtrlCPressed do
+      begin
+        if IsMultiThread then
+          CheckSynchronize{$ifndef DELPHI6OROLDER}(100){$endif}
+        else
+          Sleep(100);
+        while PeekMessage(msg, 0, 0, 0, PM_REMOVE) do
+          if msg.Message = WM_QUIT then
+            exit // stop waiting when the process is gracefully closing
+          else
+          begin
+            TranslateMessage(msg);
+            DispatchMessage(msg);
+          end;
+      end
+    else
+      // just intercept any WM_QUIT message on this sub-thread
+      while not ConsoleKeyPressed(VK_RETURN) and
+            not ConsoleHandleCtrlCPressed do
+      begin
+        Sleep(100);
+        if PeekMessage(msg, 0, 0, 0, PM_REMOVE) then
+          if msg.Message = WM_QUIT then
+            exit; // nothing to dispatch with PostThreadMessage()
+      end;
+  finally
+    HandleCtrlC(nil);
+  end;
+end;
+{$I+}
+
+{$ifdef ISDELPHI}
+var
+  // Delphi doesn't define this global variable need by ConsoleReadBody
+  StdInputHandle: THandle;
+{$endif ISDELPHI}
+
+function ConsoleStdInputLen: integer;
+begin
+  if StdInputHandle = 0 then
+    StdInputHandle := GetStdHandle(STD_INPUT_HANDLE);
+  if not PeekNamedPipe(StdInputHandle, nil, 0, nil, @result, nil) then
+    result := 0;
+end;
+
+procedure Utf8ToConsoleDoConv(const Utf8: RawUtf8; var Console: RawByteString);
+var
+  tmp16, tmp: TSynTempBuffer;
+begin
+  Utf8ToWin32PWideChar(Utf8, tmp16);
+  if tmp16.len = 0 then
+  begin
+    Console := Utf8; // input is not valid UTF-8 -> return without conversion
+    exit;
+  end;
+  tmp.Init(tmp16.len * 3);
+  CharToOemBuffW(tmp16.buf, tmp.buf, tmp16.len + 1); // +1 = ending #0
+  tmp16.Done;
+  FastSetStringCP(Console, tmp.buf, StrLen(tmp.buf), CP_OEMCP);
+  tmp.Done;
+end;
+
+function Utf8ToConsole(const S: RawUtf8): RawByteString;
+begin
+  if IsAnsiCompatible(S) then
+    result := S // no conversion needed
+  else
+    Utf8ToConsoleDoConv(S, result);
+end;
+
+function TFileVersion.RetrieveInformationFromFileName: boolean;
+var
+  Size, Size2: DWord;
+  Pt: Pointer;
+  Trans: PWordArray;
+  LanguageInfo: RawUtf8;
+  Info: ^TVSFixedFileInfo;
+  FileTime: TFILETIME;
+  SystemTime: TSYSTEMTIME;
+  tmp: TW32Temp;
+
+  function ReadResourceByName(const From: RawUtf8): RawUtf8;
+  var
+    StrValPt: pointer;
+    sz: DWord;
+    u: SynUnicode;
+  begin
+    u := Utf8Decode('\StringFileInfo\' + LanguageInfo + '\' + From);
+    VerQueryValueW(Pt, pointer(u), StrValPt, sz);
+    if sz > 0 then
+      Win32PWideCharToUtf8(StrValPt, result)
+    else
+      result := '';
+  end;
+
+begin
+  result := false;
+  if fFileName = '' then
+    exit;
+  // GetFileVersionInfo() modifies the filename parameter data while parsing
+  // -> copy the FileName into local tmp buffer to create a writable copy
+  Size := GetFileVersionInfoSizeW(W32Copy(fFileName, tmp), Size2);
+  if Size > 0 then
+  begin
+    GetMem(Pt, Size);
+    try
+      if GetFileVersionInfoW(W32Copy(fFileName, tmp), 0, Size, Pt) then
+      begin
+        VerQueryValueW(Pt, '\', pointer(Info), Size2);
+        with Info^ do
+        begin
+          SetVersion({major=}   dwFileVersionMS shr 16,
+                     {minor=}   word(dwFileVersionMS),
+                     {release=} dwFileVersionLS shr 16,
+                     {build=}   word(dwFileVersionLS));
+          if (dwFileDateLS <> 0) and
+             (dwFileDateMS <> 0) then
+          begin
+            FileTime.dwLowDateTime := dwFileDateLS; // built date from version info
+            FileTime.dwHighDateTime := dwFileDateMS;
+            FileTimeToSystemTime(FileTime, SystemTime);
+            fBuildDateTime := EncodeDate(
+              SystemTime.wYear, SystemTime.wMonth, SystemTime.wDay);
+          end;
+        end;
+        VerQueryValueW(Pt, '\VarFileInfo\Translation', pointer(Trans), Size2);
+        if Size2 >= 4 then
+        begin
+          _fmt('%4.4x%4.4x', [Trans^[0], Trans^[1]], LanguageInfo);
+          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;
+        result := true;
+      end;
+    finally
+      Freemem(Pt);
+    end;
+  end;
+end;
+
+procedure GetUserHost(out User, Host: RawUtf8);
+var
+  tmp: array[byte] of WideChar;
+  tmpsize: cardinal;
+begin
+  tmpsize := SizeOf(tmp);
+  GetComputerNameW(tmp{%H-}, tmpsize);
+  Win32PWideCharToUtf8(@tmp, Host);
+  tmpsize := SizeOf(tmp);
+  GetUserNameW(tmp, tmpsize);
+  Win32PWideCharToUtf8(@tmp, User);
+end;
+
+var
+  SHFolderDll: THandle;
+  // avoid unneeded reference to ShlObj.pas
+  // - late binding is mandatory to be used on WinPE which does NOT have this dll
+  // - late binding also ensure that we load libraries only when needed
+  SHGetFolderPath: function(hwnd: hwnd; csidl: integer; hToken: THandle;
+    dwFlags: DWord; pszPath: PChar): HRESULT; stdcall;
+
+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 = (
+    CSIDL_COMMON_APPDATA,   // spCommonData
+                            // C:\ProgramData
+    CSIDL_LOCAL_APPDATA,    // spUserData
+                            // C:\Users\\AppData\Local
+    CSIDL_COMMON_DOCUMENTS, // spCommonDocuments
+                            // C:\Users\Public\Documents
+    CSIDL_PERSONAL,         // spUserDocuments
+                            // C:\Users\\Documents
+    0,                      // spTemp
+    0);                     // spLog
+  // note: for SYSTEM user, got C:\Windows\System32\config\systemprofile\AppData
+  // or C:\Windows\SysWOW64\config\systemprofile\AppData (on Win32 over Win64)
+
+procedure _ComputeSystemPath(kind: TSystemPath; var result: TFileName);
+const
+  _ENV: array[TSystemPath] of TFileName = (
+    'ALLUSERSAPPDATA', // spCommonData
+    'LOCALAPPDATA',    // spUserData
+    '',                // spCommonDocuments
+    '',                // spUserDocuments
+    'TEMP',            // spTemp
+    '');               // spLog
+var
+  tmp: array[0..MAX_PATH] of char;
+begin
+  result := '';
+  case kind of
+    spLog:
+      begin
+        // try \log - without [idwExcludeWinSys] (writable is enough)
+        result := Executable.ProgramFilePath;
+        if not IsDirectoryWritable(result) then
+          // fallback to 'C:\Users\\AppData\Local\-log'
+          result := format('%s%s-',
+                      [GetSystemPath(spUserData), Executable.ProgramName]);
+        result := EnsureDirectoryExists(result + 'log');
+        if IsDirectoryWritable(result) then
+          exit; // found a folder able to receive new logs
+        // 'C:\Users\\AppData\Local\Temp\-log'
+        result := EnsureDirectoryExists(format('%s%s-log',
+                    [GetSystemPath(spTemp), Executable.ProgramName]));
+      end;
+    spTemp:
+      begin
+        // typically 'C:\Users\\AppData\Local\Temp'
+        if GetTempPath(MAX_PATH, @tmp) <> 0 then
+          result := tmp; // retrieve from dedicated standard API
+        if result = '' then
+          result := GetEnvironmentVariable(_ENV[spTemp]); // fallback
+      end;
+  else
+    if (CSIDL[kind] <> 0) and
+       DelayedProc(SHGetFolderPath, SHFolderDll, 'SHFolder.dll',
+         'SHGetFolderPath' + _AW) and
+       (SHGetFolderPath(0, CSIDL[kind], 0, 0, @tmp) = S_OK) then
+      // retrieved from official CSIDL
+      result := tmp
+    else
+    begin
+      // fallback to environment variables (very unlikely)
+      result := GetEnvironmentVariable(_ENV[kind]);
+      if result = '' then
+      begin
+        result := GetEnvironmentVariable('APPDATA');
+        if result = '' then
+          result := Executable.ProgramFilePath;
+      end;
+    end;
+  end;
+  if result <> '' then
+    result := IncludeTrailingPathDelimiter(result); // no EnsureDirectoryExists
+end;
+
+procedure PatchCode(Old, New: pointer; Size: PtrInt; Backup: pointer;
+  LeaveUnprotected: boolean);
+var
+  RestoreProtection, Ignore: DWord;
+  i: PtrInt;
+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 Exception.Create('PatchCode?');
+  end;
+end;
+
+
+{ ****************** Operating System Specific Types (e.g. TWinRegistry) }
+
+{ TWinRegistry }
+
+const
+  _HKEY: array[TWinRegistryRoot] of HKEY = (
+    HKEY_CLASSES_ROOT,
+    HKEY_CURRENT_USER,
+    HKEY_LOCAL_MACHINE,
+    HKEY_USERS);
+
+function TWinRegistry.ReadOpen(root: TWinRegistryRoot; const keyname: RawUtf8;
+  closefirst: boolean): boolean;
+var
+  tmp: TSynTempBuffer;
+begin
+  if closefirst then
+    Close;
+  key := 0;
+  result := RegOpenKeyExW(
+    _HKEY[root], Utf8ToWin32PWideChar(keyname, tmp), 0, KEY_READ, key) = 0;
+  tmp.Done;
+end;
+
+procedure TWinRegistry.Close;
+begin
+  if key <> 0 then
+    RegCloseKey(key);
+end;
+
+function TWinRegistry.ReadString(const entry: SynUnicode; andtrim: boolean): RawUtf8;
+var
+  rtype, rsize, res: DWord;
+  tmp: TSynTempBuffer;
+begin
+  result := '';
+  rsize := {%H-}tmp.Init; // most of the time, a single call is enough
+  res := RegQueryValueExW(key, pointer(entry), nil, @rtype, tmp.buf, @rsize);
+  if res <> 0 then
+    if res = ERROR_MORE_DATA then
+    begin
+      tmp.Init(rsize); // more than 4KB of data (unlikely)
+      res := RegQueryValueExW(key, pointer(entry), nil, nil, tmp.buf, @rsize);
+    end
+    else
+      exit;
+  if res = 0 then
+  begin
+    case rtype of
+      REG_SZ,
+      REG_EXPAND_SZ,
+      REG_MULTI_SZ: // StrLen() will return the first value of REG_MULTI_SZ
+        Win32PWideCharToUtf8(tmp.buf, result);
+    end;
+    if andtrim then
+      TrimSelf(result);
+  end;
+  tmp.Done;
+end;
+
+function TWinRegistry.ReadData(const entry: SynUnicode): RawByteString;
+var
+  rsize: DWord;
+begin
+  result := '';
+  if RegQueryValueExW(key, pointer(entry), nil, nil, nil, @rsize) <> 0 then
+    exit;
+  SetLength(result, rsize);
+  if RegQueryValueExW(key, pointer(entry), nil, nil, pointer(result), @rsize) <> 0 then
+    result := '';
+end;
+
+function TWinRegistry.ReadDword(const entry: SynUnicode): cardinal;
+begin
+  if not ReadBuffer(entry, @result, SizeOf(result)) then
+    result := 0;
+end;
+
+function TWinRegistry.ReadQword(const entry: SynUnicode): QWord;
+begin
+  if not ReadBuffer(entry, @result, SizeOf(result)) then
+    result := 0;
+end;
+
+function TWinRegistry.ReadBuffer(const entry: SynUnicode;
+  Data: pointer; DataLen: DWord): boolean;
+begin
+  result := RegQueryValueExW(key, pointer(entry), nil, nil, Data, @DataLen) = 0;
+end;
+
+function TWinRegistry.ReadSize(const entry: SynUnicode): integer;
+begin
+  if RegQueryValueExW(key, pointer(entry), nil, nil, nil, @result) <> 0 then
+    result := -1;
+end;
+
+function TWinRegistry.ReadEnumEntries: TRawUtf8DynArray;
+var
+  count, maxlen, i, len: DWord;
+  tmp: TSynTempBuffer;
+begin
+  result := nil;
+  count := 0;
+  if (RegQueryInfoKeyW(key, nil, nil, nil, @count, @maxlen,
+       nil, nil, nil, nil, nil, nil) <> 0) or
+     (count = 0) then
+    exit;
+  SetLength(result, count);
+  inc(maxlen);
+  tmp.Init(maxlen * 2);
+  for i := 0 to count - 1 do
+  begin
+    len := maxlen;
+    if RegEnumKeyExW(key, i, tmp.buf, len, nil, nil, nil, nil) = 0 then
+      Win32PWideCharToUtf8(tmp.buf, len, result[i]);
+  end;
+  tmp.Done;
+end;
+
+
+const
+  _WSP: array[TWinSystemPrivilege] of string[32] = (
+    // note: string[32] to ensure there is a trailing #0 for all items
+    'SeCreateTokenPrivilege',          // wspCreateToken
+    'SeAssignPrimaryTokenPrivilege',   // wspAssignPrimaryToken
+    'SeLockMemoryPrivilege',           // wspLockMemory
+    'SeIncreaseQuotaPrivilege',        // wspIncreaseQuota
+    'SeUnsolicitedInputPrivilege',     // wspUnsolicitedInput
+    'SeMachineAccountPrivilege',       // wspMachineAccount
+    'SeTcbPrivilege',                  // wspTCP
+    'SeSecurityPrivilege',             // wspSecurity
+    'SeTakeOwnershipPrivilege',        // wspTakeOwnership
+    'SeLoadDriverPrivilege',           // wspLoadDriver
+    'SeSystemProfilePrivilege',        // wspSystemProfile
+    'SeSystemtimePrivilege',           // wspSystemTime
+    'SeProfileSingleProcessPrivilege', // wspProfSingleProcess
+    'SeIncreaseBasePriorityPrivilege', // wspIncBasePriority
+    'SeCreatePagefilePrivilege',       // wspCreatePageFile
+    'SeCreatePermanentPrivilege',      // wspCreatePermanent
+    'SeBackupPrivilege',               // wspBackup
+    'SeRestorePrivilege',              // wspRestore
+    'SeShutdownPrivilege',             // wspShutdown
+    'SeDebugPrivilege',                // wspDebug
+    'SeAuditPrivilege',                // wspAudit
+    'SeSystemEnvironmentPrivilege',    // wspSystemEnvironment
+    'SeChangeNotifyPrivilege',         // wspChangeNotify
+    'SeRemoteShutdownPrivilege',       // wspRemoteShutdown
+    'SeUndockPrivilege',               // wspUndock
+    'SeSyncAgentPrivilege',            // wspSyncAgent
+    'SeEnableDelegationPrivilege',     // wspEnableDelegation
+    'SeManageVolumePrivilege',         // wspManageVolume
+    'SeImpersonatePrivilege',          // wspImpersonate
+    'SeCreateGlobalPrivilege',         // wspCreateGlobal
+    'SeTrustedCredManAccessPrivilege', // wspTrustedCredmanAccess
+    'SeRelabelPrivilege',              // wspRelabel
+    'SeIncreaseWorkingSetPrivilege',   // wspIncWorkingSet
+    'SeTimeZonePrivilege',             // wspTimeZone
+    'SeCreateSymbolicLinkPrivilege');  // wspCreateSymbolicLink
+
+  _TokenVirtualizationEnabled = TTokenInformationClass(24); // for oldest Delphi
+
+type
+  TOKEN_PRIVILEGES = packed record
+    PrivilegeCount : DWord;
+    Privileges : array[0..0] of LUID_AND_ATTRIBUTES;
+  end;
+  PTOKEN_PRIVILEGES = ^TOKEN_PRIVILEGES;
+
+  TOKEN_USER = record
+    User: SID_AND_ATTRIBUTES;
+  end;
+  PTOKEN_USER = ^TOKEN_USER;
+
+  TOKEN_GROUPS = record
+    GroupCount: DWord;
+    Groups: array [0..0] of SID_AND_ATTRIBUTES;
+  end;
+  PTOKEN_GROUPS = ^TOKEN_GROUPS;
+
+function OpenProcessToken(ProcessHandle: THandle; DesiredAccess: DWord;
+  var TokenHandle: THandle): BOOL;
+    stdcall; external advapi32;
+
+function LookupPrivilegeValueA(lpSystemName, lpName: PAnsiChar;
+  var lpLuid: TLargeInteger): BOOL;
+    stdcall; external advapi32;
+
+function LookupPrivilegeNameA(lpSystemName: PAnsiChar; var lpLuid: TLargeInteger;
+  lpName: PAnsiChar; var cbName: DWord): BOOL;
+    stdcall; external advapi32;
+
+function LookupAccountSidW(lpSystemName: PWideChar; Sid: PSID; Name: PWideChar;
+  var cchName: DWord; ReferencedDomainName: PAnsiChar;
+  var cchReferencedDomainName: DWord; var peUse: DWord): BOOL;
+    stdcall; external advapi32;
+
+function AdjustTokenPrivileges(TokenHandle: THandle; DisableAllPrivileges: BOOL;
+  const NewState: TOKEN_PRIVILEGES; BufferLength: DWord;
+  PreviousState: PTokenPrivileges; ReturnLength: PDWord): BOOL;
+    stdcall; external advapi32;
+
+function IsSystemFolder(const Folder: TFileName): boolean;
+begin
+  if CompareText(copy(Folder, 2,  9), ':\windows') = 0 then
+    result := ord(Folder[11]) in [0, ord('\')]
+  else
+    result := (CompareText(copy(Folder, 2, 15), ':\program files') = 0) and
+              ((ord(Folder[17]) in [0, ord('\')]) or
+               (CompareText(copy(Folder, 17, 6), ' (x86)') = 0));
+end;
+
+{$ifdef CPU32}
+var
+  IsUacEnabled: (iueUntested, iueDisabled, iueEnabled);
+
+function IsUacVirtualizationEnabled: boolean;
+var
+  token: THandle;
+  enabled, len: DWORD;
+begin
+  if IsUacEnabled = iueUntested then
+    if OSVersion < wVista then
+      IsUacEnabled := iueDisabled // no UAC on Windows XP
+    else
+    begin
+      IsUacEnabled := iueEnabled; // enabled by default
+      if OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, token) then
+      begin
+        enabled := 1;
+        len := SizeOf(enabled);
+        if GetTokenInformation(token, _TokenVirtualizationEnabled,
+             @enabled, SizeOf(enabled), len) and
+           (enabled = 0) then
+          // returns enabled=0 if mormot.win.default.manifest.res is included
+          IsUacEnabled := iueDisabled;
+        CloseHandle(token);
+      end;
+    end;
+  result := IsUacEnabled = iueEnabled;
+end;
+
+function IsUacVirtualFolder(const Folder: TFileName): boolean;
+begin
+  // note: IsUacVirtualizationEnabled returns false if our manifest is included
+  result := (OSVersion >= wVista) and // no UAC on Windows XP
+            IsUacVirtualizationEnabled and
+            IsSystemFolder(Folder);
+end;
+
+{$else}
+
+function IsUacVirtualizationEnabled: boolean;
+begin
+  result := false; // never enabled for a Win64 process
+end;
+
+function IsUacVirtualFolder(const Folder: TFileName): boolean;
+begin
+  result := false; // never enabled for a Win64 process
+end;
+
+{$endif CPU32}
+
+function RawTokenOpen(wtt: TWinTokenType; access: cardinal): THandle;
+begin
+  if wtt = wttProcess then
+  begin
+    if not OpenProcessToken(GetCurrentProcess, access, result) then
+      RaiseLastError('OpenToken: OpenProcessToken');
+  end
+  else if not OpenThreadToken(GetCurrentThread, access, false, result) then
+    if GetLastError = ERROR_NO_TOKEN then
+    begin
+      // try to impersonate the thread
+      if not ImpersonateSelf(SecurityImpersonation) or
+         not OpenThreadToken(GetCurrentThread, access, false, result) then
+        RaiseLastError('OpenToken: ImpersonateSelf');
+    end
+    else
+      RaiseLastError('OpenToken: OpenThreadToken');
+end;
+
+function RawTokenGetInfo(tok: THandle; tic: TTokenInformationClass;
+  var buf: TSynTempBuffer): cardinal;
+begin
+  buf.Init; // stack-allocated buffer (always enough)
+  result := 0; // error
+  if (tok = INVALID_HANDLE_VALUE) or
+     (tok = 0) or
+     GetTokenInformation(tok, tic, buf.buf, buf.len, result) then
+    exit; // we directly store the output buffer on buf stack
+  if GetLastError <> ERROR_INSUFFICIENT_BUFFER then
+  begin
+    result := 0;
+    exit;
+  end;
+  buf.Done;
+  buf.Init(result); // we need a bigger buffer
+  if not GetTokenInformation(tok, tic, buf.buf, buf.len, result) then
+    result := 0;
+end;
+
+function RawTokenSid(tok: THandle; var buf: TSynTempBuffer): PSid;
+begin
+  if RawTokenGetInfo(tok, TokenUser, buf) >= SizeOf(TOKEN_USER) then
+    result := PSid(PTOKEN_USER(buf.buf)^.User.Sid) // within buf.buf/len
+  else
+    result := nil;
+end;
+
+function CurrentSid(wtt: TWinTokenType; name, domain: PRawUtf8): RawUtf8;
+var
+  sid: RawSid;
+begin
+  CurrentRawSid(sid, wtt, name, domain);
+  result := RawSidToText(sid);
+end;
+
+procedure CurrentRawSid(out sid: RawSid; wtt: TWinTokenType;
+  name, domain: PRawUtf8);
+var
+  h: THandle;
+  p: PSid;
+  n, d: RawUtf8;
+  tmp: TSynTempBuffer;
+begin
+  h := RawTokenOpen(wtt, TOKEN_QUERY);
+  p := RawTokenSid(h, tmp);
+  if p <> nil then
+  begin
+    ToRawSid(p, sid);
+    if (name <> nil) or
+       (domain <> nil) then
+    begin
+      LookupSid(p, n, d);
+      if name <> nil then
+        name^ := n;
+      if domain <> nil then
+        domain^ := d;
+    end;
+  end;
+  tmp.Done;
+  CloseHandle(h);
+end;
+
+function ToText(p: TWinSystemPrivilege): PShortString;
+begin
+  result := @_WSP[p];
+end;
+
+function RawTokenGroups(tok: THandle; var buf: TSynTempBuffer): PSids;
+var
+  nfo: PTokenGroups;
+  i: PtrInt;
+begin
+  result := nil;
+  if RawTokenGetInfo(tok, TokenGroups, buf) < SizeOf({%H-}nfo^) then
+    exit;
+  nfo := buf.buf;
+  if nfo.GroupCount = 0 then
+    exit;
+  SetLength(result, nfo.GroupCount);
+  for i := 0 to nfo.GroupCount - 1 do
+    result[i] := pointer(nfo.Groups[i].Sid); // within buf.buf/len
+end;
+
+function TokenGroupsText(tok: THandle): TRawUtf8DynArray;
+var
+  tmp: TSynTempBuffer;
+begin
+  result := SidsToText(RawTokenGroups(tok, tmp));
+  tmp.Done;
+end;
+
+function TokenHasGroup(tok: THandle; sid: PSid): boolean;
+var
+  tmp: TSynTempBuffer;
+  i: PtrInt;
+begin
+  result := false;
+  if (sid <> nil) and
+     (RawTokenGetInfo(tok, TokenGroups, tmp) <> 0) then
+    with PTokenGroups(tmp.buf)^ do
+      for i := 0 to GroupCount - 1 do
+        if SidCompare(pointer(Groups[i].Sid), sid) = 0 then
+        begin
+          result := true;
+          break;
+        end;
+  tmp.Done;
+end;
+
+function TokenHasAnyGroup(tok: THandle; const sid: RawSidDynArray): boolean;
+var
+  tmp: TSynTempBuffer;
+begin
+  result := HasAnySid(RawTokenGroups(tok, tmp), sid);
+  tmp.Done;
+end;
+
+function CurrentGroups(wtt: TWinTokenType; var tmp: TSynTempBuffer): PSids;
+var
+  h: THandle;
+begin
+  h := RawTokenOpen(wtt, TOKEN_QUERY);
+  result := RawTokenGroups(h, tmp);
+  CloseHandle(h);
+end;
+
+function CurrentGroupsSid(wtt: TWinTokenType): TRawUtf8DynArray;
+var
+  tmp: TSynTempBuffer;
+begin
+  result := SidsToText(CurrentGroups(wtt, tmp));
+  tmp.Done;
+end;
+
+function CurrentKnownGroups(wtt: TWinTokenType): TWellKnownSids;
+var
+  tmp: TSynTempBuffer;
+begin
+  result := SidToKnownGroups(CurrentGroups(wtt, tmp));
+  tmp.Done;
+end;
+
+function CurrentUserHasGroup(sid: PSid; wtt: TWinTokenType): boolean;
+var
+  h: THandle;
+begin
+  h := RawTokenOpen(wtt, TOKEN_QUERY);
+  result := TokenHasGroup(h, sid);
+  CloseHandle(h);
+end;
+
+function CurrentUserHasGroup(wks: TWellKnownSid; wtt: TWinTokenType): boolean;
+begin
+  result := (wks <> wksNull) and
+            CurrentUserHasGroup(pointer(KnownRawSid(wks)), wtt);
+end;
+
+function CurrentUserHasGroup(const sid: RawUtf8; wtt: TWinTokenType): boolean;
+var
+  s: TSid;
+begin
+  result := TextToSid(pointer(sid), s) and
+            CurrentUserHasGroup(@s, wtt);
+end;
+
+function CurrentUserHasAnyGroup(const sid: RawSidDynArray; wtt: TWinTokenType): boolean;
+var
+  tmp: TSynTempBuffer;
+begin
+  result := HasAnySid(CurrentGroups(wtt, tmp), sid);
+  tmp.Done;
+end;
+
+function CurrentUserHasGroup(const name, domain, server: RawUtf8;
+  wtt: TWinTokenType): boolean;
+var
+  i: PtrInt;
+  sids: PSids;
+  n, d: RawUtf8;
+  tmp: TSynTempBuffer;
+begin
+  result := false;
+  sids := CurrentGroups(wtt, tmp);
+  for i := 0 to length(sids) - 1 do
+    if (SidToKnown(sids[i]) = wksNull) and
+       (LookupSid(sids[i], n, d, server) = stTypeGroup) then
+      if PropNameEquals(n, name) and
+         ((domain = '') or
+          PropNameEquals(d, domain)) then
+      begin
+        result := true;
+        break;
+      end;
+  tmp.Done;
+end;
+
+function CurrentUserIsAdmin: boolean;
+begin
+  result := CurrentUserHasGroup(wksBuiltinAdministrators);
+end;
+
+function LookupSid(sid: PSid; out name, domain: RawUtf8;
+  const server: RawUtf8): TSidType;
+var
+  n, d: array[byte] of WideChar;
+  s: TSynTempBuffer;
+  nl, dl, use: cardinal;
+begin
+  result := stUndefined;
+  if sid = nil then
+    exit;
+  nl := SizeOf(n);
+  dl := SizeOf(d);
+  if LookupAccountSidW(Utf8ToWin32PWideChar(server, s), sid, @n, nl, @d, dl, use) then
+  begin
+    Win32PWideCharToUtf8(@n, name);
+    Win32PWideCharToUtf8(@d, domain);
+    if use <= byte(high(TSidType)) then
+      result := TSidType(use);
+  end;
+  s.Done;
+end;
+
+function LookupSid(const sid: RawUtf8; out name, domain: RawUtf8;
+  const server: RawUtf8): TSidType;
+var
+  s: TSid;
+begin
+  if TextToSid(pointer(sid), s) then
+    result := LookupSid(@s, name, domain, server)
+  else
+    result := stUndefined;
+end;
+
+function LookupToken(tok: THandle; out name, domain: RawUtf8;
+  const server: RawUtf8): boolean;
+var
+  tmp: TSynTempBuffer;
+begin
+  result := LookupSid(RawTokenSid(tok, tmp) ,name, domain, server) <> stUndefined;
+  tmp.Done;
+end;
+
+function LookupToken(tok: THandle; const server: RawUtf8): RawUtf8;
+var
+  name, domain: RawUtf8;
+begin
+  if LookupToken(tok, name, domain, server) then
+    result := domain + '\' + name
+  else
+    result := '';
+end;
+
+
+{ TSynWindowsPrivileges }
+
+procedure TSynWindowsPrivileges.Init(aTokenPrivilege: TWinTokenType;
+  aLoadPrivileges: boolean);
+begin
+  fAvailable := [];
+  fEnabled := [];
+  fDefEnabled := [];
+  fToken := RawTokenOpen(aTokenPrivilege, TOKEN_QUERY or TOKEN_ADJUST_PRIVILEGES);
+  if aLoadPrivileges then
+    LoadPrivileges;
+end;
+
+procedure TSynWindowsPrivileges.Done(aRestoreInitiallyEnabled: boolean);
+var
+  p: TWinSystemPrivilege;
+  new: TWinSystemPrivileges;
+begin
+  if aRestoreInitiallyEnabled then
+  begin
+    new := fEnabled - fDefEnabled;
+    for p := low(p) to high(p) do
+      if p in new then
+        Disable(p);
+  end;
+  CloseHandle(fToken);
+  fToken := 0;
+end;
+
+function TSynWindowsPrivileges.Enable(aPrivilege: TWinSystemPrivilege): boolean;
+begin
+  result := aPrivilege in fEnabled;
+  if result or
+     not (aPrivilege in fAvailable) or
+     not SetPrivilege(aPrivilege, true) then
+    exit;
+  Include(fEnabled, aPrivilege);
+  result := true;
+end;
+
+function TSynWindowsPrivileges.Disable(
+  aPrivilege: TWinSystemPrivilege): boolean;
+begin
+  result := not (aPrivilege in fEnabled);
+  if result or
+     not (aPrivilege in fAvailable) or
+     not SetPrivilege(aPrivilege, false) then
+    exit;
+  Exclude(fEnabled, aPrivilege);
+  result := true;
+end;
+
+procedure TSynWindowsPrivileges.LoadPrivileges;
+var
+  buf: TSynTempBuffer;
+  name: string[127];
+  tp: PTOKEN_PRIVILEGES;
+  i: PtrInt;
+  len: cardinal;
+  p: TWinSystemPrivilege;
+  priv: PLUIDANDATTRIBUTES;
+begin
+  if Token = 0 then
+    raise EOSException.Create('LoadPriviledges: no token');
+  fAvailable := [];
+  fEnabled := [];
+  fDefEnabled := [];
+  try
+    if RawTokenGetInfo(Token, TokenPrivileges, buf) = 0 then
+      RaiseLastError('LoadPriviledges: GetTokenInformation');
+    tp := buf.buf;
+    priv := @tp.Privileges;
+    for i := 1 to tp.PrivilegeCount do
+    begin
+      len := high(name);
+      if not LookupPrivilegeNameA(nil, priv.Luid, @name[1], len) or
+         (len = 0) then
+         RaiseLastError('LoadPriviledges: LookupPrivilegeNameA');
+      name[0] := AnsiChar(len);
+      for p := low(p) to high(p) do
+        if not (p in fAvailable) and
+           PropNameEquals(PShortString(@name), PShortString(@_WSP[p])) then
+        begin
+          include(fAvailable, p);
+          if priv.Attributes and SE_PRIVILEGE_ENABLED <> 0 then
+            include(fDefEnabled, p);
+          break;
+        end;
+      inc(priv);
+    end;
+    fEnabled := fDefEnabled;
+  finally
+    buf.Done;
+  end;
+end;
+
+function TSynWindowsPrivileges.SetPrivilege(
+  wsp: TWinSystemPrivilege; on: boolean): boolean;
+var
+  tp: TOKEN_PRIVILEGES;
+  id: TLargeInteger;
+  tpprev: TOKEN_PRIVILEGES;
+  cbprev: DWord;
+begin
+  result := false;
+  if not LookupPrivilegeValueA(nil, @_WSP[wsp][1], id) then
+    exit;
+  tp.PrivilegeCount := 1;
+  tp.Privileges[0].Luid := PInt64(@id)^;
+  tp.Privileges[0].Attributes := 0;
+  cbprev := SizeOf(TOKEN_PRIVILEGES);
+  AdjustTokenPrivileges(
+    Token, false, tp, SizeOf(TOKEN_PRIVILEGES), @tpprev, @cbprev);
+  if GetLastError <> ERROR_SUCCESS then
+    exit;
+  tpprev.PrivilegeCount := 1;
+  tpprev.Privileges[0].Luid := PInt64(@id)^;
+  with tpprev.Privileges[0] do
+    if on then
+      Attributes := Attributes or SE_PRIVILEGE_ENABLED
+    else
+      Attributes := Attributes xor (SE_PRIVILEGE_ENABLED and Attributes);
+  AdjustTokenPrivileges(
+    Token, false, tpprev, cbprev, nil, nil);
+  if GetLastError <> ERROR_SUCCESS then
+    exit;
+  result := true;
+end;
+
+const
+  ntdll = 'NTDLL.DLL';
+
+type
+  _PPS_POST_PROCESS_INIT_ROUTINE = ULONG;
+
+  PUNICODE_STRING = ^UNICODE_STRING;
+  UNICODE_STRING = packed record
+    Length: word;
+    MaximumLength: word;
+    {$ifdef CPUX64}
+    _align: array[0..3] of byte;
+    {$endif CPUX64}
+    Buffer: PWideChar;
+  end;
+
+  PMS_PEB_LDR_DATA = ^MS_PEB_LDR_DATA;
+  MS_PEB_LDR_DATA = packed record
+    Reserved1: array[0..7] of byte;
+    Reserved2: array[0..2] of pointer;
+    InMemoryOrderModuleList: LIST_ENTRY;
+  end;
+
+  PMS_RTL_USER_PROCESS_PARAMETERS = ^MS_RTL_USER_PROCESS_PARAMETERS;
+  MS_RTL_USER_PROCESS_PARAMETERS = packed record
+    Reserved1: array[0..15] of byte;
+    Reserved2: array[0..9] of pointer;
+    ImagePathName: UNICODE_STRING;
+    CommandLine: UNICODE_STRING ;
+  end;
+
+  PMS_PEB = ^MS_PEB;
+  MS_PEB = packed record
+    Reserved1: array[0..1] of byte;
+    BeingDebugged: BYTE;
+    Reserved2: array[0..0] of byte;
+    {$ifdef CPUX64}
+    _align1: array[0..3] of byte;
+    {$endif CPUX64}
+    Reserved3: array[0..1] of pointer;
+    Ldr: PMS_PEB_LDR_DATA;
+    ProcessParameters: PMS_RTL_USER_PROCESS_PARAMETERS;
+    Reserved4: array[0..103] of byte;
+    Reserved5: array[0..51] of pointer;
+    PostProcessInitRoutine: _PPS_POST_PROCESS_INIT_ROUTINE;
+    Reserved6: array[0..127] of byte;
+    {$ifdef CPUX64}
+    _align2: array[0..3] of byte;
+    {$endif CPUX64}
+    Reserved7: array[0..0] of pointer;
+    SessionId: ULONG;
+    {$ifdef CPUX64}
+    _align3: array[0..3] of byte;
+    {$endif CPUX64}
+  end;
+
+  PMS_PROCESS_BASIC_INFORMATION = ^MS_PROCESS_BASIC_INFORMATION;
+  MS_PROCESS_BASIC_INFORMATION = packed record
+    ExitStatus: integer;
+    {$ifdef CPUX64}
+    _align1: array[0..3] of byte;
+    {$endif CPUX64}
+    PebBaseAddress: PMS_PEB;
+    AffinityMask: PtrUInt;
+    BasePriority: integer;
+    {$ifdef CPUX64}
+    _align2: array[0..3] of byte;
+    {$endif CPUX64}
+    UniqueProcessId: PtrUInt;
+    InheritedFromUniqueProcessId: PtrUInt;
+  end;
+
+  {$Z4}
+  PROCESSINFOCLASS = (
+    ProcessBasicInformation = 0,
+    ProcessDebugPort = 7,
+    ProcessWow64Information = 26,
+    ProcessImageFileName = 27,
+    ProcessBreakOnTermination = 29,
+    ProcessSubsystemInformation = 75);
+  {$Z1}
+
+  NTSTATUS = integer;
+  PVOID = pointer;
+  PPVOID = ^PVOID;
+
+  OBJECT_ATTRIBUTES = record
+    Length: ULONG;
+    RootDirectory: THandle;
+    ObjectName: PUNICODE_STRING;
+    Attributes: ULONG;
+    SecurityDescriptor: Pointer;       // Points to type SECURITY_DESCRIPTOR
+    SecurityQualityOfService: Pointer; // Points to type SECURITY_QUALITY_OF_SERVICE
+  end;
+  POBJECT_ATTRIBUTES = ^OBJECT_ATTRIBUTES;
+
+var
+  // low-level (undocumented) ntdll.dll functions - accessed via late-binding
+  NtQueryInformationProcess: function(ProcessHandle: THandle;
+    ProcessInformationClass: PROCESSINFOCLASS; ProcessInformation: pointer;
+    ProcessInformationLength: ULONG; ReturnLength: PULONG): NTSTATUS; stdcall;
+  RtlInitUnicodeString: function(var DestinationString: UNICODE_STRING;
+    const SourceString: PWideChar): NTSTATUS; stdcall;
+  NtOpenSection: function (SectionHandle: PHANDLE; DesiredAccess: ACCESS_MASK;
+    ObjectAttributes: POBJECT_ATTRIBUTES): NTSTATUS; stdcall;
+  NtMapViewOfSection: function (SectionHandle, ProcessHandle: THandle;
+    BaseAddress: PPVOID; ZeroBits: ULONG; CommitSize: ULONG;
+    var SectionOffset: TLargeInteger; ViewSize: PULONG; InheritDisposition: DWord;
+    AllocationType: ULONG; Protect: ULONG): NTSTATUS; stdcall;
+  NtUnmapViewOfSection: function (ProcessHandle: THandle;
+    BaseAddress: PVOID): NTSTATUS; stdcall;
+
+function ReadSystemMemory(address, size: PtrUInt): RawByteString;
+var
+  memfile: UNICODE_STRING;
+  att: OBJECT_ATTRIBUTES;
+  mem: THandle;
+  add: TLargeInteger;
+  virt: pointer;
+begin
+  result := '';
+  if (size <= 4 shl 20) and // map up to 4MB
+     Assigned(RtlInitUnicodeString) and
+     Assigned(NtOpenSection) and
+     Assigned(NtMapViewOfSection) and
+     Assigned(NtUnmapViewOfSection) then
+  begin
+    RtlInitUnicodeString(memfile, '\device\physicalmemory');
+    FillCharFast(att, SizeOf(att), 0);
+    att.Length := SizeOf(att);
+    att.ObjectName := @memfile;
+    att.Attributes := $40; // OBJ_CASE_INSENSITIVE
+    if NtOpenSection(@mem, SECTION_MAP_READ, @att) <> 0 then
+      exit;
+    add := address;
+    virt := nil;
+    if NtMapViewOfSection(mem, INVALID_HANDLE_VALUE, @virt, 0, size, add, @size,
+         1, 0, PAGE_READONLY) = 0 then
+    begin
+      FastSetRawByteString(result, virt, size);
+      NtUnmapViewOfSection(INVALID_HANDLE_VALUE, virt);
+    end;
+    CloseHandle(mem);
+  end;
+end;
+
+function ReadProcessMemory(hProcess: THandle; const lpBaseAddress: Pointer;
+  lpBuffer: Pointer; nSize: PtrUInt; var lpNumberOfBytesRead: PtrUInt): BOOL;
+    stdcall; external kernel32;
+
+function InternalGetProcessInfo(aPID: DWord; out aInfo: TWinProcessInfo): boolean;
+var
+  bytesread: PtrUInt;
+  sizeneeded: DWord;
+  pbi: MS_PROCESS_BASIC_INFORMATION;
+  peb: MS_PEB;
+  peb_upp: MS_RTL_USER_PROCESS_PARAMETERS;
+  prochandle: THandle;
+begin
+  result := false;
+  Finalize(aInfo);
+  FillCharFast(aInfo, SizeOf(aInfo), 0);
+  if (APID = 0) and
+     Assigned(NtQueryInformationProcess) then
+    exit;
+  prochandle := OpenProcess(
+    PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, FALSE, aPid);
+  if prochandle = INVALID_HANDLE_VALUE then
+    exit;
+  Include(aInfo.AvailableInfo, wpaiPID);
+  aInfo.PID := aPid;
+  try
+    // read PBI (Process Basic Information)
+    sizeneeded := 0;
+    FillCharFast(pbi, SizeOf(pbi), 0);
+    if NtQueryInformationProcess(prochandle, ProcessBasicInformation,
+         @pbi, Sizeof(pbi), @sizeneeded) < 0 then
+      exit;
+    with aInfo do
+    begin
+      Include(AvailableInfo, wpaiBasic);
+      PID := pbi.UniqueProcessId;
+      ParentPID := pbi.InheritedFromUniqueProcessId;
+      BasePriority := pbi.BasePriority;
+      ExitStatus := pbi.ExitStatus;
+      PEBBaseAddress := pbi.PebBaseAddress;
+      AffinityMask := pbi.AffinityMask;
+    end;
+    // read PEB (Process Environment Block)
+    if not Assigned(pbi.PebBaseAddress) then
+      exit;
+    bytesread := 0;
+    FillCharFast(peb, SizeOf(peb), 0);
+    if not ReadProcessMemory(prochandle, pbi.PebBaseAddress,
+             @peb, SizeOf(peb), bytesread) then
+      exit;
+    Include(aInfo.AvailableInfo, wpaiPEB);
+    aInfo.SessionID := peb.SessionId;
+    aInfo.BeingDebugged := peb.BeingDebugged;
+    FillCharFast(peb_upp, SizeOf(MS_RTL_USER_PROCESS_PARAMETERS), 0);
+    bytesread := 0;
+    if not ReadProcessMemory(prochandle, peb.ProcessParameters,
+         @peb_upp, SizeOf(MS_RTL_USER_PROCESS_PARAMETERS), bytesread) then
+      exit;
+    // command line info
+    if peb_upp.CommandLine.Length > 0 then
+    begin
+      SetLength(aInfo.CommandLine, peb_upp.CommandLine.Length shr 1);
+      bytesread := 0;
+      if not ReadProcessMemory(prochandle, peb_upp.CommandLine.Buffer,
+           pointer(aInfo.CommandLine), peb_upp.CommandLine.Length, bytesread) then
+        exit;
+      Include(aInfo.AvailableInfo, wpaiCommandLine);
+    end;
+    // image info
+    if peb_upp.ImagePathName.Length > 0 then
+    begin
+      SetLength(aInfo.ImagePath, peb_upp.ImagePathName.Length shr 1);
+      bytesread := 0;
+      if not ReadProcessMemory(prochandle, peb_upp.ImagePathName.Buffer,
+           pointer(aInfo.ImagePath), peb_upp.ImagePathName.Length, bytesread) then
+        exit;
+      Include(aInfo.AvailableInfo, wpaiImagePath);
+    end;
+    result := true;
+  finally
+    CloseHandle(prochandle);
+  end;
+end;
+
+procedure GetProcessInfo(aPid: cardinal; out aInfo: TWinProcessInfo);
+var
+  privileges: TSynWindowsPrivileges;
+begin
+  privileges.Init(wttThread);
+  try
+    privileges.Enable(wspDebug);
+    InternalGetProcessInfo(aPid, aInfo);
+  finally
+    privileges.Done;
+  end;
+end;
+
+procedure GetProcessInfo(const aPidList: TCardinalDynArray;
+  out aInfo: TWinProcessInfoDynArray);
+var
+  privileges: TSynWindowsPrivileges;
+  i: PtrInt;
+begin
+  SetLength(aInfo, Length(aPidList));
+  privileges.Init(wttThread);
+  try
+    privileges.Enable(wspDebug);
+    for i := 0 to High(aPidList) do
+      InternalGetProcessInfo(aPidList[i], aInfo[i]);
+  finally
+    privileges.Done;
+  end;
+end;
+
+function ReadRegString(Key: THandle; const Path, Value: string): string;
+var
+  siz, typ: DWord;
+  tmp: array[byte] of char;
+  k: HKey;
+begin
+  result := '';
+  if RegOpenKeyEx(Key, pointer(Path), 0, KEY_QUERY_VALUE, k) <> ERROR_SUCCESS then
+    exit;
+  siz := 250;
+  typ := REG_SZ;
+  if RegQueryValueEx(k, pointer(Value), nil, @typ, @tmp, @siz) = ERROR_SUCCESS then
+    result := tmp;
+  RegCloseKey(k);
+end;
+
+
+{ TWinCryptoApi }
+
+function TWinCryptoApi.Available: boolean;
+begin
+  if not Tested then
+    Resolve;
+  result := Assigned(AcquireContextA);
+end;
+
+procedure TWinCryptoApi.Resolve;
+const
+  NAMES: array[0..7] of PAnsiChar = (
+    'CryptAcquireContextA',
+    'CryptReleaseContext',
+    'CryptImportKey',
+    'CryptSetKeyParam',
+    'CryptDestroyKey',
+    'CryptEncrypt',
+    'CryptDecrypt',
+    'CryptGenRandom');
+var
+  P: PPointer;
+  i: PtrInt;
+begin
+  Tested := true;
+  Handle := GetModuleHandle('advapi32.dll');
+  if Handle <> 0 then
+  begin
+    P := @@AcquireContextA;
+    for i := 0 to high(NAMES) do
+    begin
+      P^ := LibraryResolve(Handle, NAMES[i]);
+      if P^ = nil then
+      begin
+        PPointer(@@AcquireContextA)^ := nil;
+        break;
+      end;
+      inc(P);
+    end;
+  end;
+  // note: CryptSignMessage and CryptVerifyMessageSignature are in crypt32.dll
+end;
+
+type
+  {$ifdef FPC}
+  {$packrecords C} // mandatory under Win64
+  {$endif FPC}
+  DATA_BLOB = record
+    cbData: DWord;
+    pbData: PAnsiChar;
+  end;
+  PDATA_BLOB = ^DATA_BLOB;
+  {$ifdef FPC}
+  {$packrecords DEFAULT}
+  {$endif FPC}
+
+const
+  crypt32 = 'Crypt32.dll';
+  CRYPTPROTECT_UI_FORBIDDEN = 1;
+  CRYPT_STRING_BASE64HEADER = 0; // = PEM textual format
+
+function CryptProtectData(const DataIn: DATA_BLOB; szDataDescr: PWideChar;
+  OptionalEntropy: PDATA_BLOB; Reserved, PromptStruct: Pointer; dwFlags: DWord;
+  var DataOut: DATA_BLOB): BOOL;
+    stdcall; external crypt32;
+
+function CryptUnprotectData(const DataIn: DATA_BLOB; szDataDescr: PWideChar;
+  OptionalEntropy: PDATA_BLOB; Reserved, PromptStruct: Pointer; dwFlags: DWord;
+  var DataOut: DATA_BLOB): BOOL;
+    stdcall; external crypt32;
+
+function CryptDataForCurrentUserDPAPI(const Data, AppSecret: RawByteString;
+  Encrypt: boolean): RawByteString;
+var
+  src, dst, ent: DATA_BLOB;
+  e: PDATA_BLOB;
+  ok: boolean;
+begin
+  src.pbData := pointer(Data);
+  src.cbData := length(Data);
+  if AppSecret <> '' then
+  begin
+    ent.pbData := pointer(AppSecret);
+    ent.cbData := length(AppSecret);
+    e := @ent;
+  end
+  else
+    e := nil;
+  if Encrypt then
+    ok := CryptProtectData(
+      src, nil, e, nil, nil, CRYPTPROTECT_UI_FORBIDDEN, dst)
+  else
+    ok := CryptUnprotectData(
+      src, nil, e, nil, nil, CRYPTPROTECT_UI_FORBIDDEN, dst);
+  if ok then
+  begin
+    FastSetRawByteString(result, dst.pbData, dst.cbData);
+    LocalFree(HLOCAL(dst.pbData));
+  end
+  else
+    result := '';
+end;
+
+function CertOpenSystemStoreW(hProv: HCRYPTPROV;
+  szSubsystemProtocol: PWideChar): HCERTSTORE ;
+    stdcall; external crypt32;
+
+function CertEnumCertificatesInStore(hCertStore: HCERTSTORE;
+  pPrevCertContext: PCCERT_CONTEXT): PCCERT_CONTEXT;
+  stdcall; external crypt32;
+
+function CryptBinaryToStringA(pBinary: PByte; cbBinary, dwFlags: DWord;
+  pszString: PAnsiChar; var pchString: DWord): BOOL;
+    stdcall; external crypt32;
+
+function CertCloseStore(hCertStore: HCERTSTORE; dwFlags: DWord): BOOL;
+    stdcall; external crypt32;
+
+function _GetSystemStoreAsPem(CertStore: TSystemCertificateStore): RawUtf8;
+var
+  store: HCERTSTORE;
+  ctx: PCCERT_CONTEXT;
+  resultlen, certlen: DWord;
+  tmp: TSynTempBuffer;
+begin
+  // call the Windows API to retrieve the System certificates
+  result := '';
+  resultlen := 0;
+  store := CertOpenSystemStoreW(nil, WINDOWS_CERTSTORE[CertStore]);
+  try
+    ctx := CertEnumCertificatesInStore(store, nil);
+    while ctx <> nil do
+    begin
+      certlen := 0;
+      if not CryptBinaryToStringA(ctx^.pbCertEncoded, ctx^.cbCertEncoded,
+          CRYPT_STRING_BASE64HEADER, nil, certlen) then
+        break;
+      tmp.Init(certlen); // a PEM is very likely to be < 8KB so will be on stack
+      if CryptBinaryToStringA(ctx^.pbCertEncoded, ctx^.cbCertEncoded,
+          CRYPT_STRING_BASE64HEADER, tmp.buf, certlen) then
+      begin
+        SetLength(result, resultlen + certlen);
+        MoveFast(tmp.buf^, PByteArray(result)[resultlen], certlen);
+        inc(resultlen, certlen);
+      end;
+      tmp.Done;
+      ctx := CertEnumCertificatesInStore(store, ctx); // next certificate
+    end;
+  finally
+    CertCloseStore(store, 0);
+  end;
+end;
+
+function SearchSmbios(const mem: RawByteString; var info: TRawSmbiosInfo): PtrUInt;
+  forward; // implemented later in mormot.core.os.pas
+
+const
+  _RSMB_ = $52534D42;
+  // potential location of the SMBIOS buffer pointers within a 64KB fixed frame
+  SMB_START  = $000f0000;
+  SMB_STOP   = $00100000;
+
+function _GetRawSmbios(var info: TRawSmbiosInfo): boolean;
+var
+  siz: DWord;
+  tmp: RawByteString;
+  addr: PtrUInt;
+  get: function(sig, id: DWord; buf: pointer; siz: DWord): PtrUInt; stdcall;
+begin
+  // first try to use Vista+ API which supports EFI
+  get := GetProcAddress(GetModuleHandle(kernel32), 'GetSystemFirmwareTable');
+  if Assigned(get) then
+  begin
+    siz := get(_RSMB_, 0, nil, 0); // first call to retrieve the full size
+    if siz > SizeOf(info) then
+    begin
+      FastNewRawByteString(tmp, siz);
+      get(_RSMB_, 0, pointer(tmp), siz);
+      PInt64(@info)^ := PInt64(tmp)^; // header fields = 64-bit
+      FastSetRawByteString(info.data, @PInt64Array(tmp)[1], siz - SizeOf(Int64));
+      result := true;
+      exit;
+    end;
+  end;
+  // on XP, read directly from physical memory via ntdll.dll low-level API
+  result := false;
+  tmp := ReadSystemMemory(SMB_START, SMB_STOP - SMB_START);
+  if tmp = '' then
+    exit;
+  addr := SearchSmbios(tmp, info);
+  if addr = 0 then
+    exit;
+  info.data := ReadSystemMemory(addr, info.Length);
+  result := info.data <> '';
+end;
+
+procedure DirectSmbiosInfo(out info: TSmbiosBasicInfos);
+begin
+  // not needed - GetRawSmbios() is likely to work with no administrator rights
+end;
+
+threadvar // do not publish for compilation within Delphi packages
+  CoInitCounter: integer;
+
+// avoid including ActiveX unit
+function CoInitialize(_para1: pointer): HRESULT;
+  stdcall; external 'ole32.dll';
+procedure CoUninitialize;
+  stdcall; external 'ole32.dll';
+
+procedure CoInit;
+begin
+  inc(CoInitCounter); // is a threadvar: no InterlockedIncrement() needed
+  if CoInitCounter = 1 then
+    CoInitialize(nil);
+end;
+
+procedure CoUninit;
+begin
+  if CoInitCounter <= 0 then
+    raise EOleSysError.Create('You should call TOleDBConnection.Free from the same ' +
+      'thread which called its Create: i.e. call MyProps.EndCurrentThread from an ' +
+      'THttpServerGeneric.OnHttpThreadTerminate event - see ticket 213544b2f5');
+  dec(CoInitCounter);
+  if CoInitCounter = 0 then
+    CoUninitialize;
+end;
+
+
+{ ****************** Unix Daemon and Windows Service Support }
+
+function OpenServiceManager(const TargetComputer, DatabaseName: RawUtf8;
+  dwDesiredAccess: cardinal): SC_HANDLE;
+var
+  t1, t2: TSynTempBuffer;
+begin
+  result := OpenSCManagerW(
+    Utf8ToWin32PWideChar(TargetComputer, t1),
+    Utf8ToWin32PWideChar(DatabaseName, t2), dwDesiredAccess);
+  t1.Done;
+  t2.Done;
+end;
+
+function OpenServiceInstance(hSCManager: SC_HANDLE; const ServiceName: RawUtf8;
+  dwDesiredAccess: cardinal): SC_HANDLE;
+var
+  t: TSynTempBuffer;
+begin
+  result := OpenServiceW(
+    hSCManager, Utf8ToWin32PWideChar(ServiceName, t), dwDesiredAccess);
+  t.Done;
+end;
+
+
+{ TServiceController }
+
+type
+  EService = class(Exception);
+
+constructor TServiceController.CreateNewService(const TargetComputer,
+  DatabaseName, Name, DisplayName: RawUtf8; const Path: TFileName;
+  const OrderGroup: RawUtf8; const Dependencies: RawUtf8;
+  const Username: RawUtf8; const Password: RawUtf8; DesiredAccess: cardinal;
+  ServiceType: cardinal; StartType: cardinal; ErrorControl: cardinal);
+var
+  exeName: TFileName;
+  exeNameW: SynUnicode;
+  depW: PWideChar;
+  i: PtrInt;
+  t0, t1, t2, t3, t4, t5: TSynTempBuffer;
+begin
+  inherited Create;
+  if Path = '' then
+  begin
+    TService.DoLog(sllError,
+      'CreateNewService(''%'',''%'') with no Path', [Name, DisplayName], self);
+    exit;
+  end;
+  if TargetComputer = '' then
+    if GetDriveType(pointer(ExtractFileDrive(Path))) = DRIVE_REMOTE then
+    begin
+      exeName := ExpandUNCFileName(Path);
+      if (copy(exeName, 1, 12) <> '\\localhost\') or
+         (exeName[14] <> '$') then
+        raise EService.CreateFmt(
+          '%s.CreateNewService(''%s'',''%s'') on remote drive: Path=%s is %s',
+          [ClassNameShort(self)^, Name, DisplayName, Path, exeName]);
+      system.delete(exeName, 1, 12); // \\localhost\c$\... -> c:\...
+      exeName[2] := ':';
+    end
+    else
+      exeName := Path;
+  exeNameW := SynUnicode(exeName); // use RTL for TFileName to UTF-16
+  fName := Name;
+  fSCHandle := OpenServiceManager(
+    TargetComputer, DatabaseName, SC_MANAGER_ALL_ACCESS);
+  if fSCHandle = 0 then
+    RaiseLastError('TServiceController.CreateService: OpenServiceManager', EService);
+  depW := Utf8ToWin32PWideChar(Dependencies, t0);
+  if depW <> nil then
+  begin
+    for i := 0 to t0.len - 1 do
+      if depW[i] = ';' then
+        depW[i] := #0; // as expected by CreateServiceW() API
+    depW[t0.len + 1] := #0; // should end with #0#0
+  end;
+  fHandle := CreateServiceW(fSCHandle,
+    Utf8ToWin32PWideChar(Name, t1), Utf8ToWin32PWideChar(DisplayName, t2),
+    DesiredAccess, ServiceType, StartType,
+    ErrorControl, pointer(exeNameW), Utf8ToWin32PWideChar(OrderGroup, t3),
+    nil, depW, Utf8ToWin32PWideChar(Username, t4),
+    Utf8ToWin32PWideChar(Password, t5));
+  t0.Done;
+  t1.Done;
+  t2.Done;
+  t3.Done;
+  t4.Done;
+  t5.Done;
+  if fHandle = 0 then
+    RaiseLastError('TServiceController.CreateService:', EService);
+  TService.DoLog(sllInfo, 
+    'CreateService(''%'',''%'',''%'')', [Name, DisplayName, exeName], self);
+end;
+
+constructor TServiceController.CreateOpenService(
+  const TargetComputer, DataBaseName, Name: RawUtf8; DesiredAccess: cardinal);
+begin
+  inherited Create;
+  fName := RawUtf8(Name);
+  fSCHandle := OpenServiceManager(TargetComputer, DataBaseName, GENERIC_READ);
+  if fSCHandle = 0 then
+  begin
+    TService.DoLog(sllLastError, 'OpenSCManager(''%'',''%'') for [%]',
+      [TargetComputer, DataBaseName, fName], self);
+    exit;
+  end;
+  fHandle := OpenServiceInstance(fSCHandle, Name, DesiredAccess);
+  if fHandle = 0 then
+    TService.DoLog(sllLastError, 'OpenService(%)', [Name], self);
+end;
+
+function TServiceController.Delete: boolean;
+begin
+  result := false;
+  if fHandle <> 0 then
+    if DeleteService(fHandle) then
+    begin
+      result := CloseServiceHandle(fHandle);
+      fHandle := 0;
+    end
+    else
+      TService.DoLog(sllLastError, 'DeleteService(%)', [fName], self);
+end;
+
+destructor TServiceController.Destroy;
+begin
+  if fHandle <> 0 then
+  begin
+    CloseServiceHandle(fHandle);
+    fHandle := 0;
+  end;
+  if fSCHandle <> 0 then
+  begin
+    CloseServiceHandle(fSCHandle);
+    fSCHandle := 0;
+  end;
+  inherited;
+end;
+
+function TServiceController.GetState: TServiceState;
+begin
+  if (self = nil) or
+     (fSCHandle = 0) or
+     (fHandle = 0) then
+    result := ssNotInstalled
+  else
+    result := CurrentStateToServiceState(GetStatus.dwCurrentState);
+  TService.DoLog(sllTrace, 'GetState(%)=%', [fName, ToText(result)^], self);
+end;
+
+function TServiceController.GetStatus: TServiceStatus;
+begin
+  FillCharFast(fStatus, SizeOf(fStatus), 0);
+  QueryServiceStatus(fHandle, fStatus);
+  result := fStatus;
+end;
+
+function TServiceController.Pause: boolean;
+begin
+  if fHandle = 0 then
+    result := false
+  else
+    result := ControlService(fHandle, SERVICE_CONTROL_PAUSE, fStatus);
+end;
+
+function TServiceController.Refresh: boolean;
+begin
+  if fHandle = 0 then
+    result := false
+  else
+    result := ControlService(fHandle, SERVICE_CONTROL_INTERROGATE, fStatus);
+end;
+
+function TServiceController.Resume: boolean;
+begin
+  if fHandle = 0 then
+    result := false
+  else
+    result := ControlService(fHandle, SERVICE_CONTROL_CONTINUE, fStatus);
+end;
+
+function TServiceController.Shutdown: boolean;
+begin
+  if fHandle = 0 then
+    result := false
+  else
+    result := ControlService(fHandle, SERVICE_CONTROL_SHUTDOWN, fStatus);
+end;
+
+function TServiceController.Start(const Args: array of PWideChar): boolean;
+begin
+  TService.DoLog(sllDebug, 'Start(%) Args=% Handle=%',
+    [fName, length(Args), fHandle], self);
+  if fHandle = 0 then
+  begin
+    TService.DoLog(sllError, 'Start(%): no Service', [fName], self);
+    result := false;
+    exit;
+  end;
+  if length(Args) = 0 then
+    result := StartServiceW(fHandle, 0, nil)
+  else
+    result := StartServiceW(fHandle, length(Args), @Args[0]);
+  if not result then
+    TService.DoLog(sllLastError, 'Start(%) failed', [fName], self);
+end;
+
+function TServiceController.Stop: boolean;
+begin
+  if fHandle = 0 then
+    result := false
+  else
+    result := ControlService(fHandle, SERVICE_CONTROL_STOP, fStatus);
+end;
+
+function TServiceController.SetDescription(const Description: RawUtf8): boolean;
+var
+  sd: TServiceDescription;
+  t: TSynTempBuffer;
+begin
+  if Description = '' then
+  begin
+    result := false;
+    exit;
+  end;
+  sd.lpDestription := Utf8ToWin32PWideChar(Description, t);
+  result := ChangeServiceConfig2W(fHandle, SERVICE_CONFIG_DESCRIPTION, @sd);
+  t.Done;
+end;
+
+class procedure TServiceController.CheckParameters(
+  const ExeFileName: TFileName; const ServiceName, DisplayName,
+  Description: RawUtf8; const Dependencies: RawUtf8);
+var
+  param: string;
+  i: integer;
+
+  procedure ShowError(Msg: RawUtf8);
+  begin
+    Msg := _fmt('%s: "%s" failed for %s', [ServiceName, Msg, param]);
+    TService.DoLog(sllLastError, '%', [Msg], nil);
+    ConsoleWrite(Msg, ccLightRed);
+  end;
+
+begin
+  for i := 1 to ParamCount do
+  begin
+    param := SysUtils.LowerCase(paramstr(i));
+    TService.DoLog(sllInfo,
+      'Controling % with command [%]', [ServiceName, param], nil);
+    if param = '/install' then
+      TServiceController.Install(
+        ServiceName, DisplayName, Description, true, ExeFileName, Dependencies)
+    else
+      with TServiceController.CreateOpenService('', '', ServiceName) do
+      try
+        if State = ssErrorRetrievingState then
+          ShowError('State')
+        else if param = '/uninstall' then
+        begin
+          if not Stop then
+            ShowError('Stop');
+          if not Delete then
+            ShowError('Delete');
+        end
+        else if param = '/stop' then
+        begin
+          if not Stop then
+            ShowError('Stop');
+        end
+        else if param = '/start' then
+        begin
+          if not Start([]) then
+            ShowError('Start');
+        end;
+      finally
+        Free;
+      end;
+  end;
+end;
+
+class function TServiceController.Install(
+  const Name, DisplayName, Description: RawUtf8; AutoStart: boolean;
+  ExeName: TFileName; const Dependencies, Username, Password: RawUtf8): TServiceState;
+var
+  ctrl: TServiceController;
+  start: cardinal;
+begin
+  if AutoStart then
+    start := SERVICE_AUTO_START
+  else
+    start := SERVICE_DEMAND_START;
+  if ExeName = '' then
+    ExeName := Executable.ProgramFileName;
+  ctrl := TServiceController.CreateNewService(
+    '', '', Name, DisplayName, ExeName, '', Dependencies, UserName, Password,
+    SERVICE_ALL_ACCESS, SERVICE_WIN32_OWN_PROCESS, start);
+  try
+    result := ctrl.State;
+    if result <> ssNotInstalled then
+      ctrl.SetDescription(Description);
+    TService.DoLog(sllDebug,
+      'Install(%)=%', [Name, ToText(result)^], ctrl);
+  finally
+    ctrl.Free;
+  end;
+end;
+
+class function TServiceController.CurrentState(const Name: RawUtf8): TServiceState;
+begin
+  try
+    with CreateOpenService('', '', Name, SERVICE_QUERY_STATUS) do
+      try
+        result := GetState;
+      finally
+        Free;
+      end;
+  except
+    result := ssErrorRetrievingState;
+  end;
+end;
+
+
+{ TService }
+
+class procedure TService.DoLog(Level: TSynLogLevel; const Fmt: RawUtf8;
+  const Args: array of const; Instance: TObject);
+begin
+  if Assigned(WindowsServiceLog) then
+    WindowsServiceLog(Level, Fmt, Args, Instance);
+end;
+
+constructor TService.Create(const aServiceName, aDisplayName: RawUTf8);
+begin
+  fServiceName := aServiceName;
+  if aDisplayName = '' then
+    fDisplayName := aServiceName
+  else
+    fDisplayName := aDisplayName;
+  fServiceType := SERVICE_WIN32_OWN_PROCESS or SERVICE_INTERACTIVE_PROCESS;
+  fStartType := SERVICE_AUTO_START;
+  fStatusRec.dwServiceType := fServiceType;
+  fStatusRec.dwCurrentState := SERVICE_STOPPED;
+  fStatusRec.dwControlsAccepted := 31;
+  fStatusRec.dwWin32ExitCode := NO_ERROR;
+  DoLog(sllDebug, 'Create: % (%) running as [%]',
+    [ServiceName, aDisplayName, Executable.ProgramFullSpec], self);
+end;
+
+procedure TService.CtrlHandle(Code: cardinal);
+begin
+  DoCtrlHandle(Code);
+end;
+
+const
+  _CMD: array[0.. 5] of string[11] = (
+    'UNKNOWN', 'STOP', 'PAUSE', 'CONTINUE', 'INTERROGATE', 'SHUTDOWN');
+
+procedure TService.DoCtrlHandle(Code: cardinal);
+var
+  c: PShortString;
+begin
+  if Code <= high(_CMD) then
+    c := @_CMD[Code]
+  else
+    c := @_CMD[0];
+  DoLog(sllTrace, '% DoCtrlHandle(SERVICE_CONTROL_%=%)',
+    [ServiceName, c^, Code], self);
+  try
+    case Code of
+      SERVICE_CONTROL_STOP:
+        begin
+          ReportStatus(SERVICE_STOP_PENDING, NO_ERROR, 0);
+          try
+            if Assigned(fOnStop) then
+              fOnStop(Self);
+            ReportStatus(SERVICE_STOPPED, NO_ERROR, 0);
+          except
+            ReportStatus(SERVICE_STOPPED, ERROR_CAN_NOT_COMPLETE, 0);
+          end;
+        end;
+      SERVICE_CONTROL_PAUSE:
+        begin
+          ReportStatus(SERVICE_PAUSE_PENDING, NO_ERROR, 0);
+          try
+            if Assigned(fOnPause) then
+              fOnPause(Self);
+            ReportStatus(SERVICE_PAUSED, NO_ERROR, 0)
+          except
+            ReportStatus(SERVICE_PAUSED, ERROR_CAN_NOT_COMPLETE, 0)
+          end;
+        end;
+      SERVICE_CONTROL_CONTINUE:
+        begin
+          ReportStatus(SERVICE_CONTINUE_PENDING, NO_ERROR, 0);
+          try
+            if Assigned(fOnResume) then
+              fOnResume(Self);
+            ReportStatus(SERVICE_RUNNING, NO_ERROR, 0);
+          except
+            ReportStatus(SERVICE_RUNNING, ERROR_CAN_NOT_COMPLETE, 0);
+          end;
+        end;
+      SERVICE_CONTROL_SHUTDOWN:
+        begin
+          if Assigned(fOnShutdown) then
+            fOnShutdown(Self);
+          Code := 0;
+        end;
+      SERVICE_CONTROL_INTERROGATE:
+        begin
+          SetServiceStatus(fStatusHandle, fStatusRec);
+          if Assigned(fOnInterrogate) then
+            fOnInterrogate(Self);
+        end;
+    end;
+    if Assigned(fOnControl) then
+      fOnControl(Self, Code);
+  except
+  end;
+  DoLog(sllTrace, '% DoCtrlHandle(SERVICE_CONTROL_%=%) finished',
+    [ServiceName, c^, Code], self);
+end;
+
+procedure TService.Execute;
+begin
+  try
+    if Assigned(fOnStart) then
+      fOnStart(Self);
+    ReportStatus(SERVICE_RUNNING, NO_ERROR, 0);
+    if Assigned(fOnExecute) then
+      fOnExecute(Self);
+  except
+    ReportStatus(SERVICE_RUNNING, ERROR_CAN_NOT_COMPLETE, 0);
+  end;
+  DoLog(sllTrace, '% Execute finished', [ServiceName], self);
+end;
+
+function TService.GetArgCount: Integer;
+begin
+  result := length(fArgsList);
+end;
+
+function TService.GetArgs(Idx: Integer): RawUtf8;
+begin
+  if cardinal(Idx) > cardinal(high(fArgsList)) then
+    result := ''
+  else
+    // avoid GPF
+    result := fArgsList[Idx];
+end;
+
+function TService.GetControlHandler: TServiceControlHandler;
+begin
+  result := fControlHandler;
+  if not Assigned(result) then
+    DoLog(sllError, '% GetControlHandler=nil: use TServiceSingle or ' +
+      'assign a custom ControlHandler', [ServiceName], self);
+end;
+
+function TService.GetInstalled: boolean;
+begin
+  with TServiceController.CreateOpenService(
+    '', '', fServiceName, SERVICE_QUERY_STATUS) do
+  try
+    result := Handle <> 0;
+  finally
+    Free;
+  end;
+end;
+
+function TService.Install(const Params: TFileName): boolean;
+var
+  schService: SC_HANDLE;
+  schSCManager: SC_HANDLE;
+  ServicePath: TFileName;
+  p: SynUnicode;
+  t1, t2: TSynTempBuffer;
+begin
+  result := false;
+  if installed then
+    exit;
+  ServicePath := Executable.ProgramFileName;
+  if Params <> '' then
+    ServicePath := ServicePath + ' ' + Params;
+  p := SynUnicode(ServicePath); // use RTL for TFileName to UTF-16 conversion
+  schSCManager := OpenSCManagerW(nil, nil, SC_MANAGER_ALL_ACCESS);
+  if schSCManager <= 0 then
+    exit;
+  schService := CreateServiceW(schSCManager,
+    Utf8ToWin32PWideChar(fServiceName, t1),
+    Utf8ToWin32PWideChar(fDisplayName, t2),
+    SERVICE_ALL_ACCESS, fServiceType, fStartType, SERVICE_ERROR_NORMAL,
+    pointer(p), nil, nil, nil, nil, nil);
+  t1.Done;
+  t2.Done;
+  if schService > 0 then
+  begin
+    result := true;
+    CloseServiceHandle(schService);
+  end;
+  CloseServiceHandle(schSCManager);
+end;
+
+procedure TService.Remove;
+begin
+  with TServiceController.CreateOpenService(
+    '', '', fServiceName, SERVICE_ALL_ACCESS) do
+  try
+    if Handle = 0 then
+      exit;
+    Stop;
+    Delete;
+  finally
+    Free;
+  end;
+end;
+
+function TService.ReportStatus(dwState, dwExitCode, dwWait: cardinal): BOOL;
+var
+  status: PShortString;
+begin
+  status := ToText(CurrentStateToServiceState(dwState));
+  DoLog(sllTrace, '% ReportStatus(%=%,%)=%', [ServiceName,
+    WinErrorConstant(dwExitCode), dwExitCode, dwWait, status^], self);
+  if dwState = SERVICE_START_PENDING then
+    fStatusRec.dwControlsAccepted := 0
+  else
+    fStatusRec.dwControlsAccepted := 31;
+  fStatusRec.dwCurrentState := dwState;
+  fStatusRec.dwWin32ExitCode := dwExitCode;
+  fStatusRec.dwWaitHint := dwWait;
+  if (dwState = SERVICE_RUNNING) or
+     (dwState = SERVICE_STOPPED) then
+    fStatusRec.dwCheckPoint := 0
+  else
+    inc(fStatusRec.dwCheckPoint);
+  result := SetServiceStatus(fStatusHandle, fStatusRec);
+  if not result then
+    DoLog(sllLastError, '% ReportStatus(%,%)=% SetServiceStatus() failed',
+      [ServiceName, dwExitCode, dwWait, status^], self);
+end;
+
+procedure TService.SetControlHandler(const Value: TServiceControlHandler);
+begin
+  fControlHandler := Value;
+end;
+
+procedure TService.SetStatus(const Value: TServiceStatus);
+begin
+  fStatusRec := Value;
+  if fStatusHandle <> 0 then
+    SetServiceStatus(fStatusHandle, fStatusRec);
+end;
+
+procedure TService.Start;
+begin
+  with TServiceController.CreateOpenService(
+    '', '', fServiceName, SERVICE_ALL_ACCESS) do
+  try
+    Start([]);
+  finally
+    Free;
+  end;
+end;
+
+procedure TService.Stop;
+begin
+  with TServiceController.CreateOpenService(
+    '', '', fServiceName, SERVICE_ALL_ACCESS) do
+  try
+    Stop;
+  finally
+    Free;
+  end;
+end;
+
+procedure TService.ServiceProc(ArgCount: integer; Args: PPWideChar);
+var
+  i: PtrInt;
+  t: TSynTempBuffer;
+begin
+  SetCurrentThreadName('ServiceProc');
+  DoLog(sllTrace, 'ServiceProc: ArgCount=% ServiceSingle=%',
+    [ArgCount, self], self);
+  if self = nil then
+    exit;
+  dec(ArgCount); // first argument is the service name to be ignored
+  if (Args = nil) or
+     (ArgCount <= 0) then
+    fArgsList := nil // no argument
+  else
+  begin
+    SetLength(fArgsList, ArgCount);
+    for i := 0 to ArgCount - 1 do
+    begin
+      inc(Args); // first was service name
+      Win32PWideCharToUtf8(Args^, fArgsList[i]); // to string
+    end;
+  end;
+  fStatusHandle := RegisterServiceCtrlHandlerW(
+    Utf8ToWin32PWideChar(fServiceName, t), @ControlHandler);
+  t.Done;
+  if fStatusHandle = 0 then
+  begin
+    ReportStatus(SERVICE_STOPPED, GetLastError, 0);
+    exit;
+  end;
+  ReportStatus(SERVICE_START_PENDING, 0, 0);
+  Execute;
+end;
+
+
+function CurrentStateToServiceState(CurrentState: cardinal): TServiceState;
+begin
+  case CurrentState of
+    SERVICE_STOPPED:
+      result := ssStopped;
+    SERVICE_START_PENDING:
+      result := ssStarting;
+    SERVICE_STOP_PENDING:
+      result := ssStopping;
+    SERVICE_RUNNING:
+      result := ssRunning;
+    SERVICE_CONTINUE_PENDING:
+      result := ssResuming;
+    SERVICE_PAUSE_PENDING:
+      result := ssPausing;
+    SERVICE_PAUSED:
+      result := ssPaused;
+  else
+    // e.g. SERVICE_CONTROL_SHUTDOWN
+    result := ssNotInstalled;
+  end;
+end;
+
+function GetServicePid(const aServiceName: RawUtf8;
+  aServiceState: PServiceState): cardinal;
+var
+  ss: TServiceState;
+  st: TServiceStatus;
+  ssp: TServiceStatusProcess;
+  scm: THandle;
+  svc: THandle;
+  size: cardinal;
+begin
+  result := 0;
+  ss := ssErrorRetrievingState;
+  scm := OpenSCManagerW(nil, nil, SC_MANAGER_CONNECT);
+  if scm <> 0 then
+  try
+    svc := OpenServiceInstance(scm, aServiceName, SERVICE_QUERY_STATUS);
+    if svc <> 0 then
+    try
+      if QueryServiceStatusEx(svc, SC_STATUS_PROCESS_INFO,
+          @ssp, SizeOf(TServiceStatusProcess), size) then
+      begin
+        result := ssp.dwProcessId;
+        if aServiceState <> nil then
+        begin
+          FillCharFast(st, SizeOf(st), 0);
+          QueryServiceStatus(svc, st);
+          ss := CurrentStateToServiceState(st.dwCurrentState);
+        end;
+      end
+      else
+        TService.DoLog(sllLastError, 'GetServicePid(%)', [aServiceName], nil);
+    finally
+      CloseServiceHandle(svc);
+    end
+    else
+      ss := ssNotInstalled;
+  finally
+    CloseServiceHandle(scm);
+  end;
+  if aServiceState <> nil then
+    aServiceState^ := ss;
+end;
+
+{  function that a service process specifies as the entry point function
+   of a particular service. The function can have any application-defined name
+  - Args points to an array of pointers that point to null-terminated
+    argument strings. The first argument in the array is the name of the service,
+    and subsequent arguments are any strings passed to the service by the process
+    that called the StartService function to start the service. Args can
+    be nil if there are no arguments. }
+
+procedure ServiceProc(ArgCount: cardinal; Args: PPWideChar); stdcall;
+begin
+  ServiceSingle.ServiceProc(ArgCount, Args);
+end;
+
+function ServiceSingleRun: boolean;
+var
+  S: array[0..1] of TServiceTableEntry;
+  t: TSynTempBuffer;
+begin
+  if ServiceSingle = nil then
+  begin
+    result := false;
+    exit;
+  end;
+  S[0].lpServiceName := Utf8ToWin32PWideChar(ServiceSingle.ServiceName, t);
+  S[0].lpServiceProc := ServiceProc;
+  S[1].lpServiceName := nil;
+  S[1].lpServiceProc := nil;
+  { TODO : disable EExternal exception logging in ServicesSingleRun? }
+  result := StartServiceCtrlDispatcherW(@S);
+  t.Done;
+end;
+
+
+{ TServiceSingle }
+
+procedure SingleServiceControlHandler(Opcode: LongWord); stdcall;
+begin
+  if ServiceSingle <> nil then
+    ServiceSingle.DoCtrlHandle(Opcode);
+end;
+
+constructor TServiceSingle.Create(const aServiceName, aDisplayName: RawUtf8);
+begin
+  if ServiceSingle <> nil then
+    raise EOSException.Create('Only one TServiceSingle is allowed at a time');
+  inherited Create(aServiceName, aDisplayName);
+  ServiceSingle := self;
+  SetControlHandler(SingleServiceControlHandler);
+end;
+
+destructor TServiceSingle.Destroy;
+begin
+  try
+    inherited;
+  finally
+    if ServiceSingle = self then
+      ServiceSingle := nil;
+  end;
+end;
+
+
+function WaitProcess(pid: cardinal; waitseconds: integer): boolean;
+var
+  ph: THandle;
+begin
+  result := false;
+  ph := OpenProcess(SYNCHRONIZE, false, pid);
+  if ph = 0 then
+    exit;
+  result := WaitForSingleObject(ph, waitseconds * 1000) = WAIT_OBJECT_0;
+  CloseHandle(ph);
+end;
+
+function CancelProcess(pid: cardinal; waitseconds: integer): boolean;
+begin
+  result := false;
+  if integer(pid) <= 0 then
+    exit;
+  if GetConsoleWindow <> 0 then              // can attach to a single console
+    FreeConsole;
+  if not AttachConsole(pid) then             // attach to the pid console
+    exit;
+  SetConsoleCtrlHandler(nil, true);          // nil=ignore the event ourself
+  GenerateConsoleCtrlEvent(CTRL_C_EVENT, 0); // send Ctrl+C event
+  FreeConsole;                               // detach
+  SetConsoleCtrlHandler(nil, false);         // remove our nil=ignore handler
+  result := WaitProcess(pid, waitseconds);
+end;
+
+function QuitProcess(pid: cardinal; waitseconds: integer): boolean;
+var
+  snap: THandle;
+  e: TThreadEntry32;
+begin
+  result := false;
+  if integer(pid) <= 0 then
+    exit;
+  snap := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);
+  if snap <= 0 then
+    exit;
+  FillCharFast(e, SizeOf(e), 0);
+  e.dwSize := SizeOf(e);
+  if Thread32First(snap, e) then // loop over all threads of the system
+    repeat
+      if e.th32OwnerProcessID = pid then
+        if PostThreadMessage(e.th32ThreadID, WM_QUIT, 0, 0) then
+          result := true; // at least one thread found
+    until not Thread32Next(snap, e);
+  CloseHandle(snap);
+  if result and
+     (waitseconds <> 0) then
+    result := WaitProcess(pid, waitseconds);
+end;
+
+function KillProcess(pid: cardinal; waitseconds: integer): boolean;
+var
+  ph: THandle;
+begin
+  result := false;
+  if integer(pid) <= 0 then
+    exit;
+  ph := OpenProcess(PROCESS_TERMINATE or SYNCHRONIZE, false, pid);
+  if ph = 0 then
+    exit;
+  result := TerminateProcess(ph, 0) and
+            (WaitForSingleObject(ph, waitseconds * 1000) <> WAIT_TIMEOUT);
+  CloseHandle(ph);
+end;
+
+var
+  OnHandleCtrlC: TThreadMethod;
+
+function ConsoleCtrlHandler(typ : dword) : BOOL; stdcall;
+begin
+  result := false;
+  if Assigned(OnHandleCtrlC) then
+    case typ of
+      CTRL_C_EVENT,
+      CTRL_CLOSE_EVENT,
+      CTRL_LOGOFF_EVENT,
+      CTRL_SHUTDOWN_EVENT:
+        begin
+          OnHandleCtrlC();
+          result := true;
+        end;
+    end;
+end;
+
+function HandleCtrlC(const OnClose: TThreadMethod): boolean;
+begin
+  result := SetConsoleCtrlHandler(@ConsoleCtrlHandler, Assigned(OnClose));
+  if result then
+    OnHandleCtrlC := OnClose;
+end;
+
+function DropPriviledges(const UserName: RawUtf8): boolean;
+begin
+  result := false;
+end;
+
+function ChangeRoot(const FolderName: RawUtf8): boolean;
+begin
+  result := false;
+end;
+
+type
+  TJobObjectInfoClass = (
+    BasicLimitInformation = 2,
+    JobObjectBasicProcessIdList = 3,
+    BasicUIRestrictions = 4,
+    SecurityLimitInformation = 5,
+    EndOfJobTimeInformation = 6,
+    AssociateCompletionPortInformation = 7,
+    ExtendedLimitInformation = 9,
+    GroupInformation = 11);
+
+  TJobObjectBasicLimitInformation = record
+    PerProcessUserTimeLimit: LARGE_INTEGER;
+    PerJobUserTimeLimit: LARGE_INTEGER;
+    LimitFlags: DWord;
+    MinimumWorkingSetSize: PtrUInt;
+    MaximumWorkingSetSize: PtrUInt;
+    ActiveProcessLimit: DWord;
+    Affinity: PtrUInt;
+    PriorityClass: DWord;
+    SchedulingClass: DWord;
+  end;
+
+  TIOCounter = record
+    ReadOperationCount: QWord;
+    WriteOperationCount: QWord;
+    OtherOperationCount: QWord;
+    ReadTransferCount: QWord;
+    WriteTransferCount: QWord;
+    OtherTransferCount: QWord;
+  end;
+
+  TJobObjectExtendedLimitInformation = record
+    BasicLimitInformation: TJobObjectBasicLimitInformation;
+    IoInfo: TIOCounter;
+    ProcessMemoryLimit: PtrUInt;
+    JobMemoryLimit: PtrUInt;
+    PeakProcessMemoryUsed: PtrUInt;
+    PeakJobMemoryUsed: PtrUInt;
+  end;
+
+const
+  // to create a child process in a new job object
+  // https://learn.microsoft.com/en-us/windows/win32/procthread/job-objects
+  CREATE_BREAKAWAY_FROM_JOB =  $1000000;
+
+  JOB_OBJECT_LIMIT_PROCESS_MEMORY             = $00000100;
+  JOB_OBJECT_LIMIT_JOB_MEMORY                 = $00000200;
+  JOB_OBJECT_LIMIT_DIE_ON_UNHANDLED_EXCEPTION = $00000400;
+  JOB_OBJECT_LIMIT_BREAKAWAY_OK               = $00000800;
+  JOB_OBJECT_LIMIT_SILENT_BREAKAWAY_OK        = $00001000;
+  JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE          = $00002000;
+
+function CreateJobObjectA(lpJobAttributes: PSecurityAttributes;
+   lpName: PWideChar): THandle;
+  stdcall; external kernel32;
+function SetInformationJobObject(hJob: THandle;
+   JobObjectInformationClass: TJobObjectInfoClass; lpJobObjectInformation: pointer;
+   cbJobObjectInformationLength: DWord): BOOL;
+  stdcall; external kernel32;
+function AssignProcessToJobObject(hJob, hProcess: THandle): BOOL;
+  stdcall; external kernel32;
+
+// redefined here so that we can share code with FPC and Delphi
+function CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar;
+   lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
+   bInheritHandles: BOOL; dwCreationFlags: cardinal; lpEnvironment: Pointer;
+   lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfo;
+   out lpProcessInformation: TProcessInformation): BOOL;
+  stdcall; external kernel32;
+
+function GetExitCodeProcess(hProcess: THandle; out lpExitCode: cardinal): BOOL;
+  stdcall; external kernel32;
+
+function CreateJobToClose(parentpid: cardinal): THandle;
+var
+  security: TSecurityAttributes;
+  limits: TJobObjectExtendedLimitInformation;
+  jobname: RawUtf8;
+begin
+  security.nLength := SizeOf(security);
+  security.bInheritHandle := false; // should be false
+  security.lpSecurityDescriptor := nil;
+  _fmt('AutoCloseChild%d', [parentpid], jobname);
+  result := CreateJobObjectA(@security, pointer(jobname));
+  if result = 0 then
+    exit;
+  FillCharFast(limits, SizeOf(limits), 0);
+  limits.BasicLimitInformation.LimitFlags :=
+    JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE or
+    JOB_OBJECT_LIMIT_BREAKAWAY_OK;
+  if SetInformationJobObject(result, ExtendedLimitInformation,
+       @limits, SizeOf(limits)) then
+    exit;
+  CloseHandle(result); // error initializing the job (too old or too new OS?)
+  result := 0;
+end;
+
+function AssignJobToProcess(job, process: THandle; const ctxt: ShortString): boolean;
+begin
+  result := (job <> 0) and
+            AssignProcessToJobObject(job, process);
+  if result then
+    TService.DoLog(sllTrace, 'RunCommand: % AssignProcessToJobObject success',
+      [ctxt], nil)
+  else
+    TService.DoLog(sllDebug, 'RunCommand: % AssignProcessToJobObject failed % %',
+      [ctxt, GetLastError, WinErrorConstant(GetLastError)], nil);
+end;
+
+function RunProcess(const path, arg1: TFileName; waitfor: boolean;
+  const arg2, arg3, arg4, arg5, env: TFileName; options: TRunOptions): integer;
+begin
+  result := RunCommand(Format('"%s" %s %s %s %s %s',
+    [path, arg1, arg2, arg3, arg4, arg5]), waitfor, env, options);
+end;
+
+var
+  EnvironmentCache: SynUnicode;
+  EnvironmentCacheLock: TLightLock; // just set once
+
+procedure GetEnvironmentCache;
+var
+  e, p: PWideChar;
+begin
+  EnvironmentCacheLock.Lock;
+  if EnvironmentCache = '' then
+  begin
+    e := GetEnvironmentStringsW;
+    p := e;
+    while p^ <> #0 do
+      inc(p, StrLenW(p) + 1); // go to name=value#0 pairs end
+    SetString(EnvironmentCache, e, (PtrUInt(p) - PtrUInt(e)) shr 1);
+    FreeEnvironmentStringsW(e);
+  end;
+  EnvironmentCacheLock.UnLock;
+end;
+
+function RunCommand(const cmd: TFileName; waitfor: boolean; const env: TFileName;
+  options: TRunOptions; waitfordelayms: cardinal; processhandle: PHandle;
+  redirected: PRawByteString; const onoutput: TOnRedirect;
+  const wrkdir: TFileName): integer;
+var
+  startupinfo: TStartupInfo; // _STARTUPINFOW or _STARTUPINFOA is equal here
+  processinfo: TProcessInformation;
+  security: TSecurityAttributes;
+  exe, path: TFileName;
+  rd, wr, job: THandle;
+  // CreateProcess can alter the strings -> use local SynUnicode temp variables
+  wcmd, wenv, wpath: SynUnicode;
+  endtix: Int64;
+  flags, exitcode, res: cardinal;
+  ram: TRunAbortMethods;
+  created, terminated: boolean;
+  i, l: PtrInt;
+
+  procedure RedirectOutput(flush: boolean);
+  var
+    new: RawByteString;
+    pending, n: cardinal;
+    tmp: TSynTempBuffer;
+  begin
+    repeat
+      pending := 0;
+      if not PeekNamedPipe(rd, nil, 0, nil, @pending, nil) or
+         (pending = 0) then
+      begin
+        if (not flush) and
+           Assigned(onoutput) and
+           onoutput('', processinfo.dwProcessId) then
+            exitcode := WAIT_OBJECT_0; // onoutput() returned true to abort
+        break;
+      end;
+      if pending > SizeOf(tmp) then
+        pending := SizeOf(tmp);
+      n := 0;
+      Win32Check(ReadFile(rd, tmp, pending, n, nil));
+      if n <= 0 then
+        break;
+      if redirected <> nil then
+      begin
+        SetLength(redirected^, l + PtrInt(n));
+        MoveFast(tmp, PByteArray(redirected^)[l], n); // append without convert
+        inc(l, n);
+      end;
+      if Assigned(onoutput) then
+      begin
+        SetString(new, PAnsiChar(@tmp), n);
+        if onoutput(new, processinfo.dwProcessId) then // notify new content
+          // onoutput() callback returned true to stop the execution
+          if not flush then
+          begin
+            exitcode := WAIT_OBJECT_0;
+            break;
+          end;
+      end;
+    until false;
+  end;
+
+begin
+  // https://support.microsoft.com/en-us/help/175986/info-understanding-createprocess-and-command-line-arguments
+  result := -1;
+  // extract path and exe from cmd input
+  if cmd = '' then
+    exit;
+  if cmd[1] = '"' then
+  begin
+    exe := copy(cmd, 2, maxInt);
+    i := Pos('"', exe);
+    if i = 0 then
+      exit;
+    SetLength(exe, i - 1); // unquote "exe" string
+  end
+  else
+  begin
+    i := Pos(' ', cmd);
+    if i = 0 then
+      exe := cmd // no parameter
+    else
+      exe := copy(cmd, 1, i - 1); // split exe and parameter(s)
+  end;
+  path := wrkdir;
+  if (path = '') and
+     (exe <> '') then
+    path := ExtractFilePath(ExpandFileName(exe));
+  if (path = '') and
+     FileExists(Executable.ProgramFilePath + exe) then
+    path := Executable.ProgramFilePath; // prefers the current folder
+  // prepare the CreateProcess arguments
+  wcmd := SynUnicode(cmd);
+  UniqueString(wcmd);
+  wpath := SynUnicode(path);
+  if env <> '' then
+  begin
+    wenv := SynUnicode(env);
+    if roEnvAddExisting in options then
+    begin
+      if EnvironmentCache = '' then
+        GetEnvironmentCache;
+      wenv := EnvironmentCache + wenv;
+    end
+    else
+      UniqueString(wenv);
+  end;
+  security.nLength := SizeOf(security);
+  security.bInheritHandle := true;
+  security.lpSecurityDescriptor := nil;
+  // launch the process
+  FillCharFast(startupinfo, SizeOf(startupinfo), 0);
+  startupinfo.cb := SizeOf(startupinfo);
+  ram := RunAbortMethods;
+  l := 0;
+  rd := 0;
+  job := 0;
+  if Assigned(onoutput) or
+     (redirected <> nil) then
+    if CreatePipe(rd, wr, @security, 0) then
+    begin
+      SetHandleInformation(rd, HANDLE_FLAG_INHERIT, 0);
+      startupinfo.wShowWindow := SW_HIDE;
+      startupinfo.hStdInput := GetStdHandle(STD_INPUT_HANDLE);
+      startupinfo.hStdOutput := wr;
+      startupinfo.hStdError := wr;
+      startupinfo.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
+      if redirected <> nil then
+        redirected^ := '';
+      exclude(ram, ramCtrlC); // not compatible with redirection
+    end
+    else
+      rd := 0;
+  // https://docs.microsoft.com/en-en/windows/desktop/ProcThread/process-creation-flags
+  FillCharFast(processinfo, SizeOf(processinfo), 0);
+  flags := CREATE_UNICODE_ENVIRONMENT or CREATE_DEFAULT_ERROR_MODE;
+  if not (roWinNoProcessDetach in options) then
+    flags := flags or (DETACHED_PROCESS or CREATE_NEW_PROCESS_GROUP);
+  if roWinJobCloseChildren in options then
+    // create the child process in a new job object
+    flags := flags or CREATE_BREAKAWAY_FROM_JOB;
+  // actually create the new process
+  created := CreateProcessW(nil, pointer(wcmd), @security, @security, true,
+    flags, pointer({%H-}wenv), pointer(wpath), startupinfo, processinfo);
+  if (not created) and
+     (flags and CREATE_BREAKAWAY_FROM_JOB <> 0) then
+  begin
+    TService.DoLog(sllTrace,
+      'RunCommand: unsupported CREATE_BREAKAWAY_FROM_JOB = % %',
+      [GetLastError, WinErrorConstant(GetLastError)], nil);
+    flags := flags and (not CREATE_BREAKAWAY_FROM_JOB);
+    wcmd := SynUnicode(cmd); // CreateProcesW() modified wcmd content: recreate
+    UniqueString(wcmd);
+    created := CreateProcessW(nil, pointer(wcmd), @security, @security, true,
+      flags, pointer({%H-}wenv), pointer(wpath), startupinfo, processinfo);
+  end;
+  if not created then
+  begin
+    result := -GetLastError; // returns CreateProcessW() error as negative
+    TService.DoLog(sllTrace,  'RunCommand: CreateProcess = % %',
+      [-result, WinErrorConstant(-result)], nil);
+    exit;
+  end;
+  // setup the newly created process
+  if processhandle <> nil then
+    processhandle^ := processinfo.hProcess;
+  if flags and CREATE_BREAKAWAY_FROM_JOB <> 0 then
+  begin
+    job := CreateJobToClose(processinfo.dwProcessID);
+    if (job <> 0) and
+       not AssignJobToProcess(job, processinfo.hProcess, 'CloseChildren') then
+    begin
+      CloseHandle(job);
+      job := 0;
+    end;
+  end;
+  if Assigned(onoutput) then
+    onoutput('', processinfo.dwProcessId);
+  // main wait (and redirect) until the process is finished (or not)
+  if rd <> 0 then
+  begin
+    // wait and redirect - see https://stackoverflow.com/a/25725197/458259
+    CloseHandle(wr);
+    if waitfordelayms = INFINITE then
+      endtix := 0
+    else
+      endtix := GetTickCount64 + waitfordelayms;
+    repeat
+      exitcode := WaitForSingleObject(processinfo.hProcess, 50);
+      // note: WaitForMultipleObjects() with rd burns 100% of one core :(
+      Win32Check(exitcode <> WAIT_FAILED);
+      RedirectOutput({flush=}false);
+    until (exitcode = WAIT_OBJECT_0) or
+          ((endtix <> 0) and
+           (GetTickCount64 > endtix));
+    if GetExitCodeProcess(processinfo.hProcess, exitcode) and
+       (exitcode <> STILL_ACTIVE) then
+      result := exitcode // process ended from natural death -> return code
+    else
+    begin
+      result := -GetLastError; // not able to retrieve exit code
+      // e.g. -STILL_ACTIVE if aborted by onoutput()=true above
+      terminated := false;
+      if RunAbortTimeoutSecs > 0 then
+      begin
+        if ramCtrlC in ram then  // try Ctrl+C (disabled above)
+        begin
+          terminated := CancelProcess(processinfo.dwProcessId, RunAbortTimeoutSecs);
+          TService.DoLog(sllTrace, 'RunCommand: CancelProcess(%)=%',
+            [processinfo.dwProcessId, ord(terminated)], nil);
+        end;
+        if (not terminated) and
+           (ramQuit in ram) then
+        begin // try WM_QUIT
+          terminated := QuitProcess(processinfo.dwProcessId, 0);
+          TService.DoLog(sllTrace, 'RunCommand: QuitProcess(%)=%',
+            [processinfo.dwProcessId, ord(terminated)], nil);
+          if terminated then
+          begin
+            endtix := GetTickCount64 + RunAbortTimeoutSecs * 1000; // wait ended
+            repeat
+              res := WaitForSingleObject(processinfo.hProcess, 10);
+              RedirectOutput({flush=}true); // mandatory to unlock pipe
+            until (res <> WAIT_TIMEOUT) or
+                  (GetTickCount64 > endtix);
+            terminated := res = WAIT_OBJECT_0;
+          end;
+        end;
+      end;
+      RedirectOutput({flush=}true); // ensure there is no pending data
+      if terminated and
+         // gracefully ended -> try to retrieve the exit code
+         GetExitCodeProcess(processinfo.hProcess, exitcode) then
+        result := exitcode
+      else
+      begin
+        TerminateProcess(processinfo.hProcess, result); // forced kill
+        TService.DoLog(sllTrace, 'RunCommand: TerminateProcess(%)=%',
+          [processinfo.dwProcessId, result], nil);
+      end;
+    end;
+  end
+  else if waitfor then
+    if WaitForSingleObject(processinfo.hProcess, waitfordelayms) = WAIT_FAILED then
+      if waitfordelayms <> INFINITE then
+        result := -1 // still runing after waitfordelayms
+      else
+        result := -GetLastError // failed to wait
+    else if GetExitCodeProcess(processinfo.hProcess, exitcode) then
+        result := exitcode      // waited for process to end -> return code
+      else
+        result := -GetLastError // was not able to retrieve exit code
+  else
+    // waitfor is false: asynchronous process launch
+    result := 0;
+  // release the handles created for this process
+  CloseHandle(processinfo.hProcess);
+  CloseHandle(processinfo.hThread);
+  if rd <> 0 then // CloseHandle(wr) has already be done
+    CloseHandle(rd);
+  if job <> 0 then
+    CloseHandle(job);
+end;
+
+function RunRedirect(const cmd: TFileName; exitcode: PInteger;
+  const onoutput: TOnRedirect; waitfordelayms: cardinal; setresult: boolean;
+  const env, wrkdir: TFileName; options: TRunOptions): RawByteString;
+var
+  res: integer;
+  redir: PRawByteString;
+begin
+  result := '';
+  if setresult then
+    redir := @result
+  else
+    redir := nil;
+  res := RunCommand(cmd, true, env, options, waitfordelayms, nil,
+    redir, onoutput, wrkdir);
+  if exitcode <> nil then
+    exitcode^ := res;
+end;
+
+
+{ ****************** Gather Operating System Information }
+
+const
+  // lpMinimumApplicationAddress retrieved from Windows is very low ($10000)
+  // - i.e. maximum number of ID per table would be 65536 in TOrm.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;
+
+type
+  TSystemLogicalProcessorRelation = (
+    RelationProcessorCore,
+    RelationNumaNode,
+    RelationCache,
+    RelationProcessorPackage,
+    RelationGroup);
+  TSystemLogicalProcessorCache = (
+    CacheUnified,
+    CacheInstruction,
+    CacheData,
+    CacheTrace);
+
+  {$ifdef CPU64}
+  {$A8}
+  {$else}
+  {$A4}
+  {$endif CPU64}
+  TSystemLogicalProcessorInformation = record
+    ProcessorMask: PtrUInt;
+    case Relationship: TSystemLogicalProcessorRelation of
+      RelationProcessorCore: (
+        ProcessorCoreFlags: BYTE);
+      RelationNumaNode: (
+        NumaNodeNumber: DWord);
+      RelationCache: (
+        Cache: record
+          Level: BYTE;
+          Associativity: BYTE;
+          LineSize: WORD;
+          Size: DWord;
+          CacheType: TSystemLogicalProcessorCache;
+        end);
+      RelationGroup: (
+        Reserved: array [0..1] of QWord); // to define the actual struct size
+  end;
+  {$A+}
+
+
+{$ifndef UNICODE}
+function GetVersionEx(var lpVersionInformation: TOSVersionInfoEx): BOOL;
+  stdcall; external kernel32 name 'GetVersionExA';
+{$endif UNICODE}
+
+function GetLocalTimeOffset: Integer; // not defined in oldest Delphi
+var
+  tzi: TTimeZoneInformation;
+begin
+   case GetTimeZoneInformation(tzi) of
+     TIME_ZONE_ID_UNKNOWN:
+       result := tzi.Bias;
+     TIME_ZONE_ID_STANDARD:
+       result := tzi.Bias + tzi.StandardBias;
+     TIME_ZONE_ID_DAYLIGHT:
+       result := tzi.Bias + tzi.DaylightBias;
+   else
+     result := 0;
+   end;
+end;
+
+function UUID_CACHE: TFileName;
+begin // where to cache our computed UUID as a local file
+  result := GetSystemPath(spCommonData) + 'synopse.uuid';
+end;
+
+procedure InitializeSpecificUnit;
+var
+  h: THandle;
+  IsWow64Process: function(Handle: THandle; var Res: BOOL): BOOL; stdcall;
+  GetNativeSystemInfo: procedure(var SystemInfo: TSystemInfo); stdcall;
+  GetLogicalProcessorInformation: function(
+   var Info: TSystemLogicalProcessorInformation; Len: PDWord): BOOL; stdcall;
+  wine_get_version: function: PAnsiChar; stdcall;
+  mem: TMemoryStatusEx;
+  Res: BOOL;
+  P: pointer;
+  Vers: TWindowsVersion;
+  cpu, manuf, prod, prodver: RawUtf8;
+  reg: TWinRegistry;
+  proc: array of TSystemLogicalProcessorInformation;
+  i: integer;
+  siz: DWord;
+begin
+  {$ifdef ASMX86}
+  {$ifndef HASNOSSE2}
+  if not (cfSSE2 in CpuFeatures) then
+  begin
+    // avoid illegal opcode in MoveFast() and SynLZ functions
+    {$ifdef ISDELPHI} // FPC_X86 already redirect to FastCode RTL Move()
+    RedirectCode(@MoveFast, @System.Move);
+    {$endif ISDELPHI}
+    RedirectCode(@SynLZcompress1, @SynLZcompress1Pas);
+    RedirectCode(@SynLZdecompress1, @SynLZdecompress1Pas);
+    ConsoleWrite('WARNING: too old CPU - recompile with HASNOSSE2', ccLightRed);
+    // note: FillCharFast is handled by mormot.core.base via ERMSB
+    // and Byte/Word/IntegerScanIndex() are likely to GPF at runtime
+  end;
+  {$endif HASNOSSE2}
+  {$endif ASMX86}
+  // late-binding of newest Windows APIs
+  h := GetModuleHandle(kernel32);
+  GetTickCount64 := GetProcAddress(h, 'GetTickCount64');
+  if not Assigned(GetTickCount64) then // WinXP+
+    GetTickCount64 := @GetTickCount64ForXP;
+  GetSystemTimePreciseAsFileTime :=
+    GetProcAddress(h, 'GetSystemTimePreciseAsFileTime');
+  if not Assigned(GetSystemTimePreciseAsFileTime) then // Win8+
+    GetSystemTimePreciseAsFileTime := @GetSystemTimeAsFileTime;
+  {$ifdef WITH_VECTOREXCEPT}
+  AddVectoredExceptionHandler :=
+    GetProcAddress(h, 'AddVectoredExceptionHandler');
+  {$endif WITH_VECTOREXCEPT}
+  QueryPerformanceFrequency(PInt64(@_QueryPerformanceFrequency)^);
+  if _QueryPerformanceFrequency = 0 then
+    raise Exception.Create('QueryPerformanceFrequency=0'); // paranoid
+  _QueryPerformanceFrequencyPer10 := _QueryPerformanceFrequency = 10000000;
+  IsWow64Process := GetProcAddress(h, 'IsWow64Process');
+  Res := false;
+  IsWow64 := Assigned(IsWow64Process) and
+             IsWow64Process(GetCurrentProcess, Res) and
+             Res;
+  if IsWow64 then
+    // see http://msdn.microsoft.com/en-us/library/ms724381(v=VS.85).aspx
+    GetNativeSystemInfo := GetProcAddress(h, 'GetNativeSystemInfo')
+  else
+    @GetNativeSystemInfo := nil;
+  GetSystemTimes := GetProcAddress(h, 'GetSystemTimes');
+  GetProcessTimes := GetProcAddress(h, 'GetProcessTimes');
+  QueryFullProcessImageNameW := GetProcAddress(h, 'QueryFullProcessImageNameW');
+  GetLogicalProcessorInformation := GetProcAddress(h, 'GetLogicalProcessorInformation');
+  InitializeSRWLock := GetProcAddress(h, 'InitializeSRWLock');
+  AcquireSRWLockExclusive := GetProcAddress(h, 'AcquireSRWLockExclusive');
+  ReleaseSRWLockExclusive := GetProcAddress(h, 'ReleaseSRWLockExclusive');
+  if not Assigned(InitializeSRWLock) or
+     not Assigned(AcquireSRWLockExclusive) or
+     not Assigned(ReleaseSRWLockExclusive) then
+  begin // SRW was introduced with Vista: on XP, fallback to our TLightLock
+    InitializeSRWLock := @InitializeSRWLockForXP;
+    AcquireSRWLockExclusive := @AcquireSRWLockExclusiveForXP;
+    ReleaseSRWLockExclusive := @ReleaseSRWLockExclusiveForXP;
+  end;
+  // retrieve system information
+  TimeZoneLocalBias := -GetLocalTimeOffset;
+  FillcharFast(SystemInfo, SizeOf(SystemInfo), 0);
+  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);
+  FillCharFast(mem, SizeOf(mem), 0);
+  mem.dwLength := SizeOf(mem);
+  if GlobalMemoryStatusEx(mem) then
+    SystemMemorySize := mem.ullTotalPhys;
+  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
+    // see https://en.wikipedia.org/wiki/List_of_Microsoft_Windows_versions
+    if OSVersionInfo.wProductType <> VER_NT_WORKSTATION then
+    begin
+      // Server edition
+      inc(Vers, 2); // e.g. wEight -> wServer2012
+      if Vers = wServer2016 then
+        // we identify only LTSC server versions
+        if OSVersionInfo.dwBuildNumber >= 17763 then
+          if OSVersionInfo.dwBuildNumber >= 20285 then // released as 20348
+            Vers := wServer2022_64
+          else
+            Vers := wServer2019_64;
+    end
+    else if (Vers = wTen) and
+            (OSVersionInfo.dwBuildNumber >= 22000) then
+      // Windows 11 has always 22000.###
+      Vers := wEleven;
+    if (SystemInfo.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_AMD64) and
+       (Vers < wServer2019_64) then
+      inc(Vers);   // e.g. wEight -> wEight64
+  end;
+  OSVersion := Vers;
+  OpenProcessAccess := PROCESS_QUERY_LIMITED_INFORMATION;
+  if Vers < wVista then
+    OpenProcessAccess := PROCESS_QUERY_INFORMATION or PROCESS_VM_READ;
+  OSVersion32.os := osWindows;
+  OSVersion32.win := Vers;
+  OSVersion32.winbuild := OSVersionInfo.dwBuildNumber;
+  h := GetModuleHandle(ntdll);
+  if h > 0 then
+  begin
+    wine_get_version := GetProcAddress(h, 'wine_get_version');
+    if Assigned(wine_get_version) then
+    begin
+      OSVersionInfoEx := wine_get_version;
+      OSVersionInfoEx := TrimU('Wine ' + TrimU(OSVersionInfoEx));
+    end;
+    NtQueryInformationProcess := GetProcAddress(h, 'NtQueryInformationProcess');
+    RtlInitUnicodeString      := GetProcAddress(h, 'RtlInitUnicodeString');
+    NtOpenSection             := GetProcAddress(h, 'NtOpenSection');
+    NtMapViewOfSection        := GetProcAddress(h, 'NtMapViewOfSection');
+    NtUnmapViewOfSection      := GetProcAddress(h, 'NtUnmapViewOfSection');
+  end;
+  // retrieve Software/Hardware information from Registry
+  if reg.ReadOpen(wrLocalMachine, 'Software\Microsoft\Windows NT\CurrentVersion') then
+  begin
+    WindowsUbr := reg.ReadDword('UBR');
+    WindowsProductName := reg.ReadString('ProductName');
+    WindowsDisplayVersion := reg.ReadString('DisplayVersion');
+  end;
+  with OSVersionInfo do
+  begin
+    _fmt('Windows %s (%d.%d.%d)', [WINDOWS_NAME[Vers],
+      dwMajorVersion, dwMinorVersion, dwBuildNumber], OSVersionText);
+    if wServicePackMajor <> 0 then
+      insert(_fmt('SP%d ', [wServicePackMajor]), OSVersionText, PosExChar('(', OSVersionText));
+  end;
+  if WindowsUbr <> 0 then
+    insert(_fmt('.%d', [WindowsUbr]), OSVersionText, length(OSVersionText));
+  if WindowsDisplayVersion <> '' then
+    insert(WindowsDisplayVersion + ' ', OSVersionText, PosExChar('(', OSVersionText));
+  if OSVersionInfoEx <> '' then
+    OSVersionText := OSVersionText + ' - ' + OSVersionInfoEx;
+  if reg.ReadOpen(wrLocalMachine, 'Hardware\Description\System\CentralProcessor\0', true) then
+  begin
+    cpu := reg.ReadString('ProcessorNameString');
+    if cpu = '' then
+      cpu := reg.ReadString('Identifier');
+  end;
+  if reg.ReadOpen(wrLocalMachine, 'Hardware\Description\System\BIOS', true) then
+  begin
+    manuf := reg.ReadString('SystemManufacturer');
+    if manuf <> '' then
+      manuf := manuf + ' ';
+    prod := reg.ReadString('SystemProductName');
+    prodver := reg.ReadString('SystemVersion');
+    if prodver = '' then
+      prodver := reg.ReadString('BIOSVersion');
+  end;
+  if ({%H-}prod = '') or
+     ({%H-}prodver = '') then
+  begin
+    if reg.ReadOpen(wrLocalMachine, 'Hardware\Description\System', true) then
+    begin
+      if prod = '' then
+        prod := reg.ReadString('SystemBiosVersion');
+      if prodver = '' then
+        prodver := reg.ReadString('VideoBiosVersion');
+    end;
+  end;
+  reg.Close;
+  BiosInfoText := manuf{%H-} + prod;
+  if prodver <> '' then
+    BiosInfoText := BiosInfoText + ' ' + prodver;
+  if {%H-}cpu = '' then
+    cpu := RawUtf8(GetEnvironmentVariable('PROCESSOR_IDENTIFIER'));
+  if Assigned(GetLogicalProcessorInformation) then
+  begin
+    SetLength(proc, 1024);
+    siz := SizeOf(proc[0]) * length(proc);
+    if GetLogicalProcessorInformation(proc[0], @siz) then
+    begin
+      for i := 0 to (siz div SizeOf(proc[0])) - 1 do
+        with proc[i] do
+          case Relationship of
+            RelationProcessorPackage: // physical processor socket
+              AddPtrUInt(TPtrUIntDynArray(CpuSocketsMask), CpuSockets, ProcessorMask);
+            RelationCache:            // raw cache information
+              if Cache.CacheType in [CacheUnified, CacheData] then
+                if (Cache.Level >= low(CpuCache)) and
+                   (Cache.Level <= high(CpuCache)) then
+                  with CpuCache[Cache.Level] do
+                    if (Count = 0) or
+                       (Cache.CacheType <> CacheUnified) then
+                    begin
+                      inc(Count);
+                      Size := Cache.Size;
+                      LineSize := Cache.LineSize;
+                    end;
+          end;
+      for i := high(CpuCache) downto low(CpuCache) do
+      begin
+        CpuCacheSize := CpuCache[i].Size;
+        if CpuCacheSize <> 0 then // append the biggest level Cache size
+        begin
+          cpu := _fmt('%s [%s]', [cpu, _oskb(CpuCacheSize)]);
+          break;
+        end;
+      end;
+      for i := low(CpuCache) to high(CpuCache) do
+        with CpuCache[i] do
+          if Count <> 0 then
+            if Count = 1 then
+              CpuCacheText :=
+                _fmt('%s L%d=%s ', [CpuCacheText, i, _oskb(Size)])
+            else
+              CpuCacheText :=
+                _fmt('%s L%d=%d*%s ', [CpuCacheText, i, Count, _oskb(Size)]);
+      TrimSelf(CpuCacheText);
+    end;
+  end;
+  if CpuSockets = 0 then
+    CpuSockets := 1; // e.g. on XP prior to SP3
+  _fmt('%d x %s (' + CPU_ARCH_TEXT + ')',
+    [SystemInfo.dwNumberOfProcessors, cpu], CpuInfoText);
+  // writeln(CpuInfoText); writeln(CpuCacheText);
+end;
+
+procedure FinalizeSpecificUnit;
+begin
+  if CryptoApi.Handle <> 0 then
+    Windows.FreeLibrary(CryptoApi.Handle);
+  if CoInitCounter <> 0 then
+    ConsoleWrite('Missing CoUninit (e.g. TOleDBConnection.Destroy call)');
+end;
+
+
diff --git a/lib/dmustache/mormot.core.rtti.delphi.inc b/lib/dmustache/mormot.core.rtti.delphi.inc
new file mode 100644
index 00000000..0f729c47
--- /dev/null
+++ b/lib/dmustache/mormot.core.rtti.delphi.inc
@@ -0,0 +1,788 @@
+{
+  This file is a part of the Open Source Synopse mORMot framework 2,
+  licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+
+   Delphi specific definitions used by mormot.core.rtti.pas implementation
+}
+
+type
+  AlignToPtr = Pointer;
+
+{$ifdef HASINLINE} // Delphi RTL TypInfo.GetTypeData() is awful on x86_64
+
+function GetTypeData(TypeInfo: pointer): PTypeData;
+begin
+  // weird code which compiles and inlines best on Delphi Win32 and Win64
+  {$ifdef CPU64}
+  result := pointer(PtrInt(TypeInfo) + ord(PRttiInfo(TypeInfo)^.RawName[0]) + 2);
+  {$else}
+  result := TypeInfo;
+  inc(PByte(result), ord(PRttiInfo(result)^.RawName[0]) + 2);
+  {$endif CPU64}
+end;
+
+{$else}
+
+function GetTypeData(TypeInfo: pointer): PTypeData;
+asm
+        // faster code for oldest Delphi
+        movzx   edx, byte ptr [eax].TTypeInfo.Name
+        lea     eax, [eax + edx].TTypeInfo.Name[1]
+end;
+
+{$endif HASINLINE}
+
+function TRttiInfo.RttiClass: PRttiClass; // for proper inlining below
+begin
+  if @self <> nil then
+    result := pointer(GetTypeData(@self))
+  else
+    result := nil;
+end;
+
+function TRttiInfo.RttiNonVoidClass: PRttiClass;
+begin
+  result := pointer(GetTypeData(@self))
+end;
+
+function TRttiClass.PropCount: integer;
+begin
+  result := PTypeData(@self)^.PropCount;
+end;
+
+function TRttiClass.ParentInfo: PRttiInfo;
+begin
+  result := pointer(PTypeData(@self)^.ParentInfo);
+  if result <> nil then
+    result := PPointer(result)^;
+end;
+
+function TRttiClass.RttiProps: PRttiProps;
+begin
+  result := @self;
+  if result <> nil then
+    with PTypeData(result)^ do
+      result := @UnitName[ord(UnitName[0]) + 1];
+end;
+
+function GetRttiProps(RttiClass: TClass): PRttiProps;
+var
+  p: PTypeInfo;
+begin
+  // code is a bit abstract, but compiles very well
+  p := PPointer(PtrInt(RttiClass) + vmtTypeInfo)^;
+  if p <> nil then // avoid GPF if no RTTI available for this class
+    with PTypeData(@p^.Name[ord(p^.Name[0]) + 1])^ do
+      result := @UnitName[ord(UnitName[0]) + 1]
+    else
+      result := nil;
+end;
+
+function TRttiProps.PropCount: integer;
+begin
+  result := PPropData(@self)^.PropCount;
+end;
+
+function TRttiProps.PropList: PRttiProp;
+begin
+  result := pointer(@PPropData(@self)^.PropList);
+end;
+
+function GetRttiProp(C: TClass; out PropInfo: PRttiProp): integer;
+var
+  p: PTypeInfo;
+begin
+  if C <> nil then
+  begin
+    p := PPointer(PtrInt(C) + vmtTypeInfo)^;
+    if p <> nil then // avoid GPF if no RTTI available
+      with PTypeData(@p^.Name[ord(p^.Name[0]) + 1])^,
+           PPropData(@UnitName[ord(UnitName[0]) + 1])^ do
+      begin
+        PropInfo := @PropList;
+        result := PropCount;
+        exit;
+      end;
+  end;
+  result := 0;
+end;
+
+function TRttiEnumType.EnumBaseType: PRttiEnumType;
+begin
+  with PTypeData(@self).BaseType^^ do
+    result := @Name[ord(Name[0]) + 1];
+end;
+
+function TRttiEnumType.SetBaseType: PRttiEnumType;
+begin
+  with PTypeData(@self).CompType^^ do
+    result := @Name[ord(Name[0]) + 1];
+end;
+
+function TRttiEnumType.GetEnumNameOrd(Value: cardinal): PShortString;
+begin
+  if Value <= cardinal(PTypeData(@self).MaxValue) then
+  begin
+    result := @PTypeData(@self).NameList;
+    if Value > 0 then
+      repeat
+        inc(PByte(result), PByte(result)^ + 1);  // next
+        dec(Value);
+        if Value = 0 then
+          break;
+        inc(PByte(result), PByte(result)^ + 1);  // unrolled twice
+        dec(Value);
+      until Value = 0;
+  end
+  else
+    result := @NULCHAR;
+end;
+
+{$ifdef CPUX86} // Delphi is not efficient when inlining code :(
+
+function GetEnumName(aTypeInfo: PRttiInfo; aIndex: integer): PShortString;
+asm     // eax=aTypeInfo edx=aIndex
+        test    eax, eax
+        jz      @0
+        cmp     byte ptr [eax], tkEnumeration
+        jnz     @0
+        movzx   ecx, byte ptr [eax + TTypeInfo.Name]
+        mov     eax, [eax + ecx + TTypeData.BaseType + 2]
+        mov     eax, [eax]
+        movzx   ecx, byte ptr [eax + TTypeInfo.Name]
+        cmp     edx, [eax + ecx + TTypeData.MaxValue + 2]
+        ja      @0
+        lea     eax, [eax + ecx + TTypeData.NameList + 2]
+        test    edx, edx
+        jz      @z
+        push    edx
+        shr     edx, 2 // fast by-four scanning
+        jz      @1
+@4:     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]
+        dec     edx
+        jnz     @4
+        pop     edx
+        and     edx, 3
+        jnz     @s
+        ret
+@1:     pop     edx
+@s:     movzx   ecx, byte ptr [eax]
+        lea     eax, [eax + ecx + 1] // last 1..3 iterations
+        dec     edx
+        jnz     @s
+@z:     ret
+@void:  db      0
+@0:     lea     eax, @void
+end;
+
+{$else}
+
+function GetEnumName(aTypeInfo: PRttiInfo; aIndex: integer): PShortString;
+begin
+  if PRttiKind(aTypeInfo)^ = rkEnumeration then
+    with GetTypeData(aTypeInfo).BaseType^^ do
+      result := PRttiEnumType(@Name[ord(Name[0]) + 1])^.GetEnumNameOrd(aIndex)
+  else
+    result := @NULCHAR;
+end;
+
+{$endif ASMX86}
+
+
+function TRttiInterfaceTypeData.IntfGuid: PGuid;
+begin
+  {$ifdef ISDELPHI102} // adapt to latest TypInfo.pas changes
+  result := @PTypeData(@self)^.IntfGuid;
+  {$else}
+  result := @PTypeData(@self)^.Guid;
+  {$endif ISDELPHI102}
+end;
+
+function TRttiInterfaceTypeData.IntfParent: PRttiInfo;
+begin
+  result := Pointer(PTypeData(@self)^.IntfParent^);
+end;
+
+function InterfaceEntryIsStandard(Entry: PInterfaceEntry): boolean;
+begin
+  result := Entry^.IOffset <> 0;
+end;
+
+function TRttiProp.TypeInfo: PRttiInfo;
+begin
+  result := pointer(PPropInfo(@self)^.PropType^);
+end;
+
+function TRttiProp.GetterIsField: boolean;
+begin
+  result := PropWrap(PPropInfo(@self)^.GetProc).Kind = ptField;
+end;
+
+function TRttiProp.SetterIsField: boolean;
+begin
+  result := PropWrap(PPropInfo(@self)^.SetProc).Kind = ptField;
+end;
+
+function TRttiProp.WriteIsDefined: boolean;
+begin
+  result := PtrUInt(PPropInfo(@self)^.SetProc) <> 0;
+end;
+
+function TRttiProp.IsStored(Instance: TObject): boolean;
+begin
+  if (PtrUInt(PPropInfo(@self)^.StoredProc) and
+     (not PtrUInt($ff))) = 0 then
+    result := boolean(PtrUInt(PPropInfo(@self)^.StoredProc))
+  else
+    result := IsStoredGetter(Instance);
+end;
+
+function TRttiProp.IsStoredKind: TRttiPropStored;
+begin
+  if (PtrUInt(PPropInfo(@self)^.StoredProc) and
+     (not PtrUInt($ff))) = 0 then
+    if boolean(PtrUInt(PPropInfo(@self)^.StoredProc)) then
+      result := rpsTrue
+    else
+      result := rpsFalse
+  else
+    result := rpsGetter;
+end;
+
+function TRttiProp.IsStoredGetter(Instance: TObject): boolean;
+type
+  TGetProc = function: boolean of object;
+  TGetIndexed = function(Index: integer): boolean of object;
+var
+  call: TMethod;
+begin
+  if @self = nil then
+    result := true
+  else
+    with PPropInfo(@self)^ do
+    if (PtrUInt(StoredProc) and
+       (not PtrUInt($ff))) = 0 then
+      result := boolean(PtrUInt(StoredProc))
+    else
+    begin
+      case PropWrap(StoredProc).Kind of
+        ptField:
+          begin
+            result := PBoolean(
+              PtrUInt(Instance) + PtrUInt(StoredProc) and $00ffffff)^;
+            exit;
+          end;
+        ptVirtual:
+          call.Code := PPointer(
+            PPtrUInt(Instance)^ + PtrUInt(StoredProc) and $00ffffff)^;
+        else
+          call.Code := pointer(StoredProc);
+      end;
+      call.Data := Instance;
+      if Index <> NO_INDEX then
+        result := TGetIndexed(call)(Index)
+      else
+        result := TGetProc(call);
+    end;
+end;
+
+function TRttiProp.Getter(Instance: TObject; Call: PMethod): TRttiPropCall;
+begin
+  with PPropInfo(@self)^ do
+  begin
+    if GetProc = nil then
+    begin
+      // no 'read' was defined -> try from 'write' field
+      if (SetProc <> nil) and
+         (PropWrap(SetProc).Kind = ptField) then
+      begin
+        Call.Data := pointer(
+          PtrUInt(Instance) + PtrUInt(SetProc) and $00ffffff);
+        result := rpcField;
+      end
+      else
+        result := rpcNone;
+      exit;
+    end
+    else
+    case PropWrap(GetProc).Kind of
+      ptField:
+        begin
+          // GetProc is an offset to the instance fields
+          Call.Data := pointer(
+            PtrUInt(Instance) + PtrUInt(GetProc) and $00ffffff);
+          result := rpcField;
+          exit;
+        end;
+      ptVirtual:
+        // GetProc is an offset to the class VMT
+        if Instance <> nil then // e.g. from GetterCall()
+          Call.Code := PPointer(
+            PPtrUInt(Instance)^ + PtrUInt(GetProc) and $00ffffff)^;
+    else
+      // ptStatic: GetProc is the method code itself
+      Call.Code := pointer(GetProc);
+    end;
+    Call.Data := Instance;
+    result := rpcMethod;
+    if Index <> NO_INDEX then
+      result := rpcIndexed;
+  end;
+end;
+
+function TRttiProp.Setter(Instance: TObject; Call: PMethod): TRttiPropCall;
+begin
+  with PPropInfo(@self)^ do
+  begin
+    if SetProc = nil then
+    begin
+      // no 'write' was defined -> try from 'read' field
+      if (GetProc <> nil) and
+         (PropWrap(GetProc).Kind = ptField) then
+      begin
+        Call.Data := pointer(
+          PtrUInt(Instance) + PtrUInt(GetProc) and $00ffffff);
+        result := rpcField;
+      end
+      else
+        result := rpcNone;
+      exit;
+    end
+    else
+    case PropWrap(SetProc).Kind of
+      ptField:
+        begin
+          // SetProc is an offset to the instance fields
+          Call.Data := pointer(
+            PtrUInt(Instance) + PtrUInt(SetProc) and $00ffffff);
+          result := rpcField;
+          exit;
+        end;
+      ptVirtual:
+        // SetProc is an offset to the class VMT
+        if Instance <> nil then // e.g. from SetterCall()
+          Call.Code := PPointer(
+            PPtrUInt(Instance)^ + PtrUInt(SetProc) and $00ffffff)^;
+    else
+      // ptStatic: SetProc is the method code itself
+      Call.Code := pointer(SetProc);
+    end;
+    Call.Data := Instance;
+    result := rpcMethod;
+    if Index <> NO_INDEX then
+      result := rpcIndexed;
+  end;
+end;
+
+const
+  // RawUtf8 is defined as weak system.UTF8String type in mormot.core.base
+  UTF8_NAME: string[7] = 'RawUtf8';
+
+function TRttiInfo.Name: PShortString;
+begin
+  result := pointer(@self);
+  if result <> nil then
+    if result <> TypeInfo(RawUtf8) then
+      result := @RawName   // as stored in RTTI
+    else
+      result := @UTF8_NAME // instead of 'UTF8String'
+  else
+    result := @NULCHAR;
+end;
+
+function TRttiInfo.RecordSize: PtrInt;
+begin
+  result := PRecordInfo(GetTypeData(@self))^.RecSize;
+end;
+
+procedure TRttiInfo.RecordManagedFields(out Fields: TRttiRecordManagedFields);
+var
+  nfo: PRecordInfo;
+begin
+  nfo := pointer(GetTypeData(@self));
+  Fields.Size := nfo^.RecSize;
+  Fields.Count := nfo^.ManagedFldCount;
+  Fields.Fields := @PIntegerArray(@nfo^.ManagedFldCount)[1];
+end;
+
+function TRttiInfo.RecordManagedFieldsCount: integer;
+begin
+  result := PRecordInfo(GetTypeData(@self))^.ManagedFldCount;
+end;
+
+{$ifdef HASEXTRECORDRTTI} // read enhanced RTTI available since Delphi 2010
+
+type
+  /// map Delphi tkRecord TypeInfo with enhanced RTTI
+  TRecordEnhancedTypeData = packed record
+    RecSize: cardinal;
+    ManagedCount: integer;
+    // ManagedFields: array[0..0] of TManagedField;
+    NumOps: byte;
+    // RecOps: array[0..0] of pointer;
+    AllCount: integer; // !!!! may need $RTTI EXPLICIT FIELDS([vcPublic])
+    AllFields: array[0..0] of TRecordTypeField; // as defined in TypInfo.pas
+  end;
+
+function TRttiInfo.RecordAllFields(out RecSize: PtrInt): TRttiRecordAllFields;
+var
+  info: ^TRecordEnhancedTypeData;
+  p: PRecordTypeField;
+  f: PtrInt;
+begin
+  result := nil; // don't reallocate previous answer
+  info := pointer(GetTypeData(@self));
+  RecSize := info^.RecSize;
+  inc(PByte(info), info^.ManagedCount * SizeOf(TManagedField));
+  inc(PByte(info), info^.NumOps * SizeOf(pointer));
+  SetLength(result, info^.AllCount);
+  p := @info^.AllFields[0];
+  for f := 0 to info^.AllCount - 1 do
+    begin
+      with result[f] do
+      begin
+        TypeInfo := pointer(p^.Field.TypeRef);
+        if TypeInfo = nil then
+        begin
+          // this field has no RTTI -> we can't trust it for serialization
+          result := nil;
+          exit;
+        end;
+        TypeInfo := PPointer(TypeInfo)^;
+        Offset := p^.Field.FldOffset;
+        Name := @p^.Name;
+      end;
+      p := pointer(PtrInt(@p^.Name[1]) + ord(p^.Name[0]));
+      inc(PByte(p), PWord(p)^); // jump attributes
+    end;
+end;
+
+{$else}
+
+function TRttiInfo.RecordAllFields(out RecSize: PtrInt): TRttiRecordAllFields;
+begin
+  RecSize := self.RecordSize;
+  result := nil; // extended record information not available before Delphi 2010
+end;
+
+{$endif HASEXTRECORDRTTI}
+
+function TRttiInfo.IsQWord: boolean;
+begin
+  if @self = TypeInfo(QWord) then
+    result := true
+  else
+    {$ifdef UNICODE}
+    if Kind = rkInt64 then
+      with PHash128Rec(PAnsiChar(@RawName[1]) + ord(RawName[0]))^ do
+        result := Lo > Hi // check MinInt64Value>MaxInt64Value
+    else
+    {$endif UNICODE}
+      result := false;
+end;
+
+function TRttiInfo.IsBoolean: boolean;
+begin
+  result := (@self = TypeInfo(boolean)) or
+            (@self = TypeInfo(wordbool));
+end;
+
+function TRttiInfo.EnumBaseType: PRttiEnumType;
+begin
+  result := pointer(GetTypeData(@self));
+  result := result^.EnumBaseType;
+end;
+
+function TRttiInfo.DynArrayItemType: PRttiInfo;
+begin
+  result := pointer(GetTypeData(@self)^.elType);
+  if result <> nil then // nil e.g. for TIntegerDynArray or T*ObjArray
+    result := PPointer(result)^;
+end;
+
+function TRttiInfo.DynArrayItemTypeExtended: PRttiInfo;
+begin
+  with GetTypeData(@self)^ do
+  begin
+    result := pointer(elType);
+    if result <> nil then // nil e.g. for TIntegerDynArray or T*ObjArray
+      result := PPointer(result)^;
+    {$ifdef HASDYNARRAYTYPE}
+    if result = nil then
+    begin
+      // try the second slot, which may be set even for unmanaged types
+      result := pointer(elType2);
+      if result <> nil then
+        result := PPointer(result)^;
+    end;
+    {$endif HASDYNARRAYTYPE}
+  end;
+end;
+
+function TRttiInfo.DynArrayItemType(out aDataSize: PtrInt): PRttiInfo;
+begin
+  with GetTypeData(@self)^ do
+  begin
+    aDataSize := elSize;
+    result := pointer(elType);
+    if result <> nil then
+      result := PPointer(result)^;
+  end;
+end;
+
+function TRttiInfo.ArrayItemType(out aDataCount, aDataSize: PtrInt): PRttiInfo;
+var
+  nfo: PArrayInfo;
+begin
+  // nfo^.DimCount=1 is not tested explicitly -> assume single dimension array
+  nfo := pointer(GetTypeData(@self));
+  aDataCount := nfo^.ElCount;
+  aDataSize := nfo^.ArraySize;
+  result := pointer(nfo^.ArrayType);
+  if result <> nil then
+    result := PPointer(result)^;
+end;
+
+function TRttiInfo.ArraySize: PtrInt;
+begin
+  result := PArrayInfo(GetTypeData(@self))^.ArraySize;
+end;
+
+function GetPublishedMethods(Instance: TObject;
+  out Methods: TPublishedMethodInfoDynArray; aClass: TClass): integer;
+
+  procedure AddParentsFirst(C: TClass);
+  type
+    TMethodInfo = packed record
+      Len: Word;
+      Addr: Pointer;
+      Name: ShortString;
+    end;
+  var
+    Table: PWordArray;
+    M: ^TMethodInfo;
+    i: integer;
+  begin
+    if C = nil then
+      exit;
+    AddParentsFirst(GetClassParent(C)); // put children published methods afterward
+    Table := PPointer(PtrUInt(C) + PtrUInt(vmtMethodTable))^;
+    if Table = nil then
+      exit;
+    SetLength(Methods, result + Table^[0]);
+    M := @Table^[1];
+    for i := 1 to Table^[0] do  // Table^[0] = methods count
+      with Methods[result] do
+      begin
+        ShortStringToAnsi7String(M^.Name, Name);
+        Method.Data := Instance;
+        Method.Code := M^.Addr;
+        inc(PByte(M), M^.Len);
+        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;
+
+{$ifndef ISDELPHI2010} // not defined on Delphi 7/2007/2009
+type
+  TCallConv = (ccReg, ccCdecl, ccPascal, ccStdCall, ccSafeCall);
+{$endif ISDELPHI2010}
+
+/// fake TTypeInfo RTTI used for TGuid/THash128... on Delphi 7/2007
+{$ifdef HASNOSTATICRTTI}
+                       
+type
+  // enough Delphi RTTI for TRttiInfo.RecordManagedFields
+  TFakeTypeInfo = packed record
+    Kind: TTypeKind;
+    case integer of
+      5: (
+        Name5: string[5];
+        RecSize5: cardinal;
+        ManagedCount5: integer);
+      8: (
+        Name8: string[8];
+        RecSize8: cardinal;
+        ManagedCount8: integer);
+      9: (
+        Name9: string[9];
+        RecSize9: cardinal;
+        ManagedCount9: integer);
+  end;
+const
+  _TGUID: TFakeTypeInfo = (    // stored in PT_INFO[ptGuid]
+    Kind: tkRecord;
+    Name5: 'TGUID';
+    RecSize5: SizeOf(TGUID);
+    ManagedCount5: 0);
+
+  _THASH128: TFakeTypeInfo = ( // stored in PT_INFO[ptHash128]
+    Kind: tkRecord; // note: is a tkArray when HASNOSTATICRTTI
+    Name8: 'THash128';
+    RecSize8: SizeOf(THash128);
+    ManagedCount8: 0);
+
+  _THASH256: TFakeTypeInfo = ( // stored in PT_INFO[ptHash256]
+    Kind: tkRecord;
+    Name8: 'THash256';
+    RecSize8: SizeOf(THash256);
+    ManagedCount8: 0);
+
+  _THASH512: TFakeTypeInfo = ( // stored in PT_INFO[ptHash512]
+    Kind: tkRecord;
+    Name8: 'THash512';
+    RecSize8: SizeOf(THash512);
+    ManagedCount8: 0);
+
+  _PUTF8CHAR: TFakeTypeInfo = ( // stored in PT_INFO[ptPUtf8Char]
+    Kind: tkRecord;  // don't mess with ordinals - just a record with a pointer
+    Name9: 'PUtf8Char';
+    RecSize9: SizeOf(pointer);
+    ManagedCount9: 0);
+
+{$endif HASNOSTATICRTTI}
+
+
+procedure TGetRttiInterface.AddMethodsFromTypeInfo(aInterface: PTypeInfo);
+var
+  mn, an: integer;
+  ancestor: PTypeInfo;
+  kind: TMethodKind;
+  cc: TCallConv;
+  flags: ^TParamFlags;
+  name: PShortString;
+  p: PByte;
+  pw: PWord absolute p;
+  pi: PTypeData absolute p;
+  ps: PShortString absolute p;
+
+  procedure AddArgFromRtti;
+  var
+    pp: ^PPRttiInfo absolute p;
+    argtypnfo: PRttiInfo;
+    argtypnam: PShortString;
+    {$ifdef HASNOSTATICRTTI}
+    rc: TRttiCustom;
+    {$endif HASNOSTATICRTTI}
+  begin
+    argtypnam := ps;
+    ps := @ps^[ord(ps^[0]) + 1];
+    argtypnfo := pp^^;
+    if pp^ = nil then
+    begin
+      {$ifdef HASNOSTATICRTTI} // detect e.g. TGuid/THash128 -> fake TypeInfo()
+      rc := Rtti.FindName(argtypnam^, []);
+      if rc <> nil then
+        argtypnfo := rc.Info
+      else
+      {$endif HASNOSTATICRTTI}
+        RaiseError('"%: %" parameter has no RTTI', [name^, argtypnam^]);
+    end;
+    inc(pp);
+    AddArgument(name, argtypnam, argtypnfo, flags^);
+  end;
+
+begin
+  pi := GetTypeData(aInterface);
+  if IdemPropName(pi^.IntfUnit, 'System') then
+    exit;
+  if Definition.Name = '' then
+  begin
+    ShortStringToAnsi7String(aInterface^.Name, Definition.Name);
+    ShortStringToAnsi7String(pi^.IntfUnit, Definition.UnitName);
+    Definition.Guid := pi^.Guid;
+  end;
+  ancestor := pi^.IntfParent^;
+  if ancestor <> nil then
+  begin
+    AddMethodsFromTypeInfo(ancestor); // recursive call of parents
+    inc(Level);
+  end;
+  p := @pi^.IntfUnit[ord(pi^.IntfUnit[0]) + 1];
+  mn := pw^;
+  inc(pw);
+  if (pw^ = $ffff) or
+     (mn = 0) then
+    exit; // no method
+  inc(pw);
+  SetLength(Definition.Methods, MethodCount + mn);
+  repeat
+    name := ps;
+    ps := @ps^[ord(ps^[0]) + 1];
+    kind := TMethodKind(p^);
+    inc(p);
+    cc := TCallConv(p^);
+    inc(p);
+    an := p^;
+    inc(p);
+    AddMethod(name^, an, kind);
+    if cc <> ccReg then
+      RaiseError('unsupported %', [GetEnumName(TypeInfo(TCallConv), ord(cc))^]);
+    while an > 0 do
+    begin
+      flags := pointer(p);
+      inc(p, SizeOf(flags^));
+      name := ps;
+      ps := @ps^[ord(ps^[0]) + 1];
+      AddArgFromRtti;
+      {$ifdef ISDELPHIXE}
+      inc(p, pw^); // skip custom attributes
+      {$endif ISDELPHIXE}
+      dec(an);
+    end;
+    name := nil;
+    if kind = mkFunction then
+      AddArgFromRtti;
+    {$ifdef ISDELPHIXE}
+    inc(p, pw^); // skip custom attributes
+    {$endif ISDELPHIXE}
+    dec(mn);
+  until mn = 0;
+  CurrentMethod := nil;
+end;
+
+
+const
+  // gather rk* to reduce number of TRttiCustomListPairs hash slots in memory
+  RK_TOSLOT_MAX = 12;
+  RK_TOSLOT: array[TRttiKind] of byte = (
+    0,  // rkUnknown
+    1,  // rkInteger
+    2,  // rkChar
+    3,  // rkEnumeration
+    4,  // rkFloat
+    0,  // rkSString
+    5,  // rkSet
+    6,  // rkClass
+    0,  // rkMethod
+    7,  // rkWChar
+    8,  // rkLString
+    7,  // rkWString
+    9,  // rkVariant
+    2,  // rkArray
+    10, // rkRecord
+    9,  // rkInterface
+    11, // rkInt64
+    12  // rkDynArray
+    {$ifdef UNICODE} ,
+    7,  // rkUString
+    0,  // rkClassRef
+    0,  // rkPointer
+    0,  // rkProcedure
+    0   // rkMRecord
+    {$endif UNICODE});
+
diff --git a/lib/dmustache/mormot.core.rtti.pas b/lib/dmustache/mormot.core.rtti.pas
new file mode 100644
index 00000000..e25ea302
--- /dev/null
+++ b/lib/dmustache/mormot.core.rtti.pas
@@ -0,0 +1,9888 @@
+/// Framework Core Low-Level Cross-Compiler RTTI Definitions
+// - this unit is a part of the Open Source Synopse mORMot framework 2,
+// licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+unit mormot.core.rtti;
+
+{
+  *****************************************************************************
+
+   Cross-Compiler RTTI Definitions shared by all framework units
+    - Low-Level Cross-Compiler RTTI Definitions
+    - Enumerations RTTI
+    - Published Class Properties and Methods RTTI
+    - IInvokable Interface RTTI
+    - Efficient Dynamic Arrays and Records Process
+    - Managed Types Finalization, Random or Copy
+    - RTTI Value Types used for JSON Parsing
+    - RTTI-based Registration for Custom JSON Parsing
+    - High Level TObjectWithID and TObjectWithCustomCreate Class Types
+    - Redirect Most Used FPC RTL Functions to Optimized x86_64 Assembly
+
+     Purpose of this unit is to avoid any direct use of TypInfo.pas RTL unit,
+    which is not exactly compatible between compilers, and lack of direct
+    RTTI access with no memory allocation. We define pointers to RTTI
+    record/object to access TypeInfo() via a set of explicit methods.
+     Here fake record/objects are just wrappers around pointers defined in
+    Delphi/FPC RTL's TypInfo.pas with the magic of inlining.
+     We redefined all RTTI definitions as TRtti* types to avoid confusion
+    with type names as published by the TypInfo unit.
+     TRttiCustom class is the main cached entry of our customizable RTTI,
+    accessible from the global Rtti.* methods.
+
+    See mormot.core.rtti.fpc.inc and mormot.core.rtti.delphi.inc for
+    compiler-specific code.
+
+  *****************************************************************************
+}
+
+
+interface
+
+{$I mormot.defines.inc}
+
+uses
+  sysutils,
+  classes,
+  contnrs,
+  typinfo,  // use official RTL for accurate layouts (especially FPC unaligned)
+  mormot.core.base,
+  mormot.core.os,
+  mormot.core.unicode,
+  mormot.core.text; // ESynException, and text process (e.g. for enums)
+
+
+{ ************* Low-Level Cross-Compiler RTTI Definitions }
+
+type
+  /// the kind of Exception raised by this unit
+  ERttiException = class(ESynException);
+
+  /// map TOrdType, to specify ordinal (rkInteger and rkEnumeration) storage size and sign
+  // - note: on FPC, Int64 is stored as its own TRttiKind, not as rkInteger
+  TRttiOrd = (
+    roSByte,
+    roUByte,
+    roSWord,
+    roUWord,
+    roSLong,
+    roULong
+    {$ifdef FPC_NEWRTTI} ,
+    roSQWord,
+    roUQWord
+    {$endif FPC_NEWRTTI});
+
+  /// map TFloatType, to specify floating point (ftFloat) storage size and precision
+  TRttiFloat = (
+    rfSingle,
+    rfDouble,
+    rfExtended,
+    rfComp,
+    rfCurr);
+
+{$ifdef FPC}
+
+  /// map TTypeKind, to specify available type families for FPC RTTI values
+  // - FPC types differs from Delphi, and are taken from FPC typinfo.pp unit
+  // - here below,  we defined rkLString instead of rkAString to match Delphi -
+  // see https://lists.freepascal.org/pipermail/fpc-devel/2013-June/032360.html
+  // "Compiler uses internally some LongStrings which is not possible to use
+  // for variable declarations" so rkLStringOld seems never used in practice
+  TRttiKind = (
+    rkUnknown,
+    rkInteger,
+    rkChar,
+    rkEnumeration,
+    rkFloat,
+    rkSet,
+    rkMethod,
+    rkSString,
+    rkLStringOld {=rkLString},
+    rkLString    {=rkAString},
+    rkWString,
+    rkVariant,
+    rkArray,
+    rkRecord,
+    rkInterface,
+    rkClass,
+    rkObject,
+    rkWChar,
+    rkBool,
+    rkInt64,
+    rkQWord,
+    rkDynArray,
+    rkInterfaceRaw,
+    rkProcVar,
+    rkUString,
+    rkUChar,
+    rkHelper,
+    rkFile,
+    rkClassRef,
+    rkPointer);
+
+const
+  /// potentially managed types in TRttiKind enumerates
+  rkManagedTypes = [rkLStringOld,
+                    rkLString,
+                    rkWString,
+                    rkUString,
+                    rkArray,
+                    rkObject,
+                    rkRecord,
+                    rkDynArray,
+                    rkInterface,
+                    rkVariant];
+
+  /// maps record or object in TRttiKind enumerates
+  rkRecordTypes = [rkObject,
+                   rkRecord];
+
+type
+  ///  TTypeKind enumerate as defined in Delphi 6 and up
+  // - dkUString and following appear only since Delphi 2009
+  TDelphiType = (
+    dkUnknown,
+    dkInteger,
+    dkChar,
+    dkEnumeration,
+    dkFloat,
+    dkString,
+    dkSet,
+    dkClass,
+    dkMethod,
+    dkWChar,
+    dkLString,
+    dkWString,
+    dkVariant,
+    dkArray,
+    dkRecord,
+    dkInterface,
+    dkInt64,
+    dkDynArray,
+    dkUString,
+    dkClassRef,
+    dkPointer,
+    dkProcedure,
+    dkMRecord);
+
+const
+  /// convert our TRttiKind to Delphi's TTypeKind enumerate
+  // - used internally for cross-compiler TDynArray binary serialization
+  FPCTODELPHI: array[TRttiKind] of TDelphiType = (
+    dkUnknown,
+    dkInteger,
+    dkChar,
+    dkEnumeration,
+    dkFloat,
+    dkSet,
+    dkMethod,
+    dkString,
+    dkLString,
+    dkLString,
+    dkWString,
+    dkVariant,
+    dkArray,
+    dkRecord,
+    dkInterface,
+    dkClass,
+    dkRecord,
+    dkWChar,
+    dkEnumeration,
+    dkInt64,
+    dkInt64,
+    dkDynArray,
+    dkInterface,
+    dkProcedure,
+    dkUString,
+    dkWChar,
+    dkPointer,
+    dkPointer,
+    dkClassRef,
+    dkPointer);
+
+  /// convert Delphi's TTypeKind to our TRttiKind enumerate
+  DELPHITOFPC: array[TDelphiType] of TRttiKind = (
+    rkUnknown,     //  dkUnknown
+    rkInteger,     //  dkInteger
+    rkChar,        //  dkChar
+    rkEnumeration, //  dkEnumeration
+    rkFloat,       //  dkFloat
+    rkSString,     //  dkString
+    rkSet,         //  dkSet
+    rkClass,       //  dkClass
+    rkMethod,      //  dkMethod
+    rkWChar,       //  dkWChar
+    rkLString,     //  dkLString
+    rkWString,     //  dkWString
+    rkVariant,     //  dkVariant
+    rkArray,       //  dkArray
+    rkRecord,      //  dkRecord
+    rkInterface,   //  dkInterface
+    rkInt64,       //  dkInt64
+    rkDynArray,    //  dkDynArray
+    rkUString,     //  dkUString
+    rkClassRef,    //  dkClassRef
+    rkPointer,     //  dkPointer
+    rkProcVar,     //  dkProcedure
+    rkRecord);     //  dkMRecord
+
+{$else}
+
+  /// available type families for Delphi 6 and up, similar to typinfo.pas
+  // - redefined here to leverage FPC and Delphi compatibility as much as possible
+  TRttiKind = (
+    rkUnknown,
+    rkInteger,
+    rkChar,
+    rkEnumeration,
+    rkFloat,
+    rkSString,
+    rkSet,
+    rkClass,
+    rkMethod,
+    rkWChar,
+    rkLString,
+    rkWString,
+    rkVariant,
+    rkArray,
+    rkRecord,
+    rkInterface,
+    rkInt64,
+    rkDynArray
+    {$ifdef UNICODE},
+    rkUString,
+    rkClassRef,
+    rkPointer,
+    rkProcedure,
+    rkMRecord // managed records from newest Delphi are partially supported
+    {$endif UNICODE});
+
+const
+  /// potentially managed types in TRttiKind enumerates
+  rkManagedTypes = [rkLString,
+                    rkWstring,
+                    {$ifdef UNICODE}
+                    rkUstring,
+                    rkMRecord,
+                    {$endif UNICODE}
+                    rkArray,
+                    rkRecord,
+                    rkDynArray,
+                    rkInterface,
+                    rkVariant
+                   ];
+  /// maps record or object in TTypeKind RTTI enumerates
+  rkRecordTypes = [rkRecord
+                   {$ifdef UNICODE},
+                   rkMRecord
+                   {$endif UNICODE}];
+
+{$endif FPC}
+
+  /// maps string/text types in TRttiKind RTTI enumerates, excluding shortstring
+  rkStringTypes =
+    [rkLString,
+     {$ifdef FPC}
+     rkLStringOld,
+     {$endif FPC}
+     {$ifdef HASVARUSTRING}
+     rkUString,
+     {$endif HASVARUSTRING}
+     rkWString
+    ];
+
+  /// maps UTF-16 string in TRttiKind RTTI enumerates
+  rkWideStringTypes =
+    [{$ifdef HASVARUSTRING}
+     rkUString,
+     {$endif HASVARUSTRING}
+     rkWString
+    ];
+
+  /// maps types with proper TRttiProp.RttiOrd field
+  // - i.e. rkOrdinalTypes excluding the 64-bit values
+  rkHasRttiOrdTypes =
+    [rkInteger,
+     rkChar,
+     rkWChar,
+     {$ifdef FPC}
+     rkBool,
+     rkUChar,
+     {$endif FPC}
+     rkEnumeration,
+     rkSet
+    ];
+
+  /// types which are considerated as non-simple values
+  rkComplexTypes = [rkClass, rkDynArray, rkInterface];
+
+  /// types which are stored as pointers so are always accessed by reference
+  rkPerReference = rkStringTypes + rkComplexTypes;
+
+  /// maps 1, 8, 16, 32 and 64-bit ordinal in TRttiKind RTTI enumerates
+  rkOrdinalTypes =
+    rkHasRttiOrdTypes + [ {$ifdef FPC} rkQWord, {$endif} rkInt64 ];
+
+  /// maps integer and floating point types in TRttiKind RTTI enumerates
+  rkNumberTypes = rkOrdinalTypes + [ rkFloat ];
+
+  /// maps enumeration types in TRttiKind RTTI
+  rkEnumerationTypes = [rkEnumeration {$ifdef FPC}, rkBool {$endif}];
+
+  /// maps values which expect TRttiProp.GetOrdProp/SetOrdProp
+  // - includes 32-bit ordinals and pointers
+  rkGetOrdPropTypes = rkHasRttiOrdTypes + rkComplexTypes;
+
+  /// maps ordinal values which expect TRttiProp.GetInt64Prop/SetInt64Prop
+  // - includes 64-bit ordinals
+  rkGetInt64PropTypes =
+     [rkInt64 {$ifdef FPC} , rkQWord {$endif} ];
+
+  /// maps value which are integer or Int64/QWord, but not ordinal char/enum/set
+  rkGetIntegerPropTypes = rkGetInt64PropTypes + [rkInteger];
+
+  /// maps records or dynamic arrays
+  rkRecordOrDynArrayTypes = rkRecordTypes + [rkDynArray];
+
+  /// maps records or static arrays
+  rkRecordOrArrayTypes = rkRecordTypes + [rkArray];
+
+  /// all recognized TRttiKind enumerates, i.e. all but rkUnknown
+  rkAllTypes = [succ(low(TRttiKind))..high(TRttiKind)];
+
+  /// quick retrieve how many bytes an ordinal consist in
+  ORDTYPE_SIZE: array[TRttiOrd] of byte = (
+    1,                                      // roSByte
+    1,                                      // roUByte
+    2,                                      // roSWord
+    2,                                      // roUWord
+    4,                                      // roSLong
+    4                                       // roULong
+    {$ifdef FPC_NEWRTTI} , 8, 8 {$endif} ); // roSQWord, roUQWord
+
+  /// quick retrieve how many bytes a floating-point consist in
+  FLOATTYPE_SIZE: array[TRttiFloat] of byte = (
+    4,                                             // rfSingle
+    8,                                             // rfDouble
+    {$ifdef TSYNEXTENDED80} 10 {$else} 8 {$endif}, // rfExtended
+    8,                                             // rfComp
+    8 );                                           // rfCurr
+
+
+type
+  PRttiKind = ^TRttiKind;
+  TRttiKinds = set of TRttiKind;
+  PRttiOrd = ^TRttiOrd;
+  PRttiFloat = ^TRttiFloat;
+
+type
+  /// pointer to low-level RTTI of a type definition, as returned by TypeInfo()
+  // system function
+  // - equivalency to PTypeInfo as defined in TypInfo RTL unit and old mORMot.pas
+  // - this is the main entry point of all the information exposed by this unit
+  PRttiInfo = ^TRttiInfo;
+
+  /// double-reference to RTTI type definition
+  // - Delphi and newer FPC do store all nested TTypeInfo as pointer to pointer,
+  // to ease linking of the executable
+  PPRttiInfo = ^PRttiInfo;
+
+  /// dynamic array of low-level RTTI type definitions
+  PRttiInfoDynArray = array of PRttiInfo;
+
+  /// pointer to a RTTI class property definition as stored in PRttiProps.PropList
+  // - equivalency to PPropInfo as defined in TypInfo RTL unit and old mORMot.pas
+  PRttiProp = ^TRttiProp;
+
+  /// used to store a chain of properties RTTI
+  // - could be used e.g. by TOrmPropInfo to handled flattened properties
+  PRttiPropDynArray = array of PRttiProp;
+
+  /// pointer to all RTTI class properties definitions
+  // - as returned by PRttiInfo.RttiProps() or GetRttiProps()
+  PRttiProps = ^TRttiProps;
+
+  /// a wrapper to published properties of a class, as defined by compiler RTTI
+  // - access properties for only a given class level, not inherited properties
+  // - start enumeration by getting a PRttiProps with PRttiInfo.RttiProps(), then
+  // use P := PropList to get the first PRttiProp, and iterate with P^.Next
+  // - this enumeration is very fast and doesn't require any temporary memory,
+  //  as in the TypInfo.GetPropInfos() PPropList usage
+  // - for TOrm, you should better use the Properties.Fields[] array,
+  // which is faster and contains the properties published in parent classes
+  {$ifdef USERECORDWITHMETHODS}
+  TRttiProps = record
+  {$else}
+  TRttiProps = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// number of published properties in this object
+    function PropCount: integer;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// point to a TPropInfo packed array
+    // - layout is as such, with variable TPropInfo storage size:
+    // ! PropList: array[1..PropCount] of TPropInfo
+    // - use TPropInfo.Next to get the next one:
+    // ! P := PropList;
+    // ! for i := 1 to PropCount do
+    // ! begin
+    // !   // ... do something with P
+    // !   P := P^.Next;
+    // ! end;
+    function PropList: PRttiProp;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// retrieve a Field property RTTI information from a Property Name
+    function FieldProp(const PropName: ShortString): PRttiProp;
+  end;
+
+  /// pointer to TClassType, as returned by PRttiInfo.RttiClass()
+  // - as returned by PRttiInfo.RttiClass() or GetRttiClass()
+  // - equivalency to PClassData/PClassType as defined in old mORMot.pas
+  PRttiClass = ^TRttiClass;
+
+  /// a wrapper to class type information, as defined by the compiler RTTI
+  // - get a PRttiClass with PRttiInfo.RttiClass() or GetRttiClass()
+  {$ifdef USERECORDWITHMETHODS}
+  TRttiClass = record
+  {$else}
+  TRttiClass = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// the class type
+    function RttiClass: TClass;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// the parent class type information
+    function ParentInfo: PRttiInfo;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// the number of published properties of this class and all parents
+    // - use RttiProps if you want to properties only published in this class 
+    function PropCount: integer;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// the name (without .pas extension) of the unit were the class was defined
+    // - then the PRttiProps information follows: use the method
+    // RttiProps to retrieve its address
+    function UnitName: PShortString;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// get the information about the published properties of this class
+    // - stored after UnitName memory
+    function RttiProps: PRttiProps;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// fast and easy find if this class inherits from a specific class type
+    // - you should rather consider using TRttiInfo.InheritsFrom directly
+    function InheritsFrom(AClass: TClass): boolean;
+  end;
+
+  /// pointer to TEnumType, as returned by PRttiInfo.EnumBaseType/SetEnumType
+  // - equivalency to PEnumType as defined in old mORMot.pas
+  PRttiEnumType = ^TRttiEnumType;
+
+  /// a wrapper to enumeration type information, as defined by the compiler RTTI
+  // and returned by PRttiInfo.EnumBaseType/SetEnumType
+  // - we use this to store the enumeration values as integer, but easily provide
+  // a text equivalent, translated if necessary, from the enumeration type
+  // definition itself
+  {$ifdef USERECORDWITHMETHODS}
+  TRttiEnumType = record
+  {$else}
+  TRttiEnumType = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    // as used by TRttiInfo.EnumBaseType/SetBaseType
+    function EnumBaseType: PRttiEnumType;
+      {$ifdef HASINLINE}inline;{$endif}
+    function SetBaseType: PRttiEnumType;
+      {$ifdef HASINLINE}inline;{$endif}
+  public
+    /// specify ordinal storage size and sign
+    // - is prefered to MaxValue to identify the number of stored bytes
+    function RttiOrd: TRttiOrd;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// first value of enumeration type, typicaly 0
+    // - may be < 0 e.g. for boolean
+    function MinValue: PtrInt;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// same as ord(high(type)): not the enumeration count, but the highest index
+    function MaxValue: PtrInt;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// a concatenation of shortstrings, containing the enumeration names
+    // - those shortstrings are not aligned whatsoever (even if
+    // FPC_REQUIRES_PROPER_ALIGNMENT is set)
+    function NameList: PShortString;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// get the corresponding enumeration name
+    // - return a void '' ShortString if Value is invalid (>MaxValue)
+    function GetEnumNameOrd(Value: cardinal): PShortString;
+      {$ifdef FPC} inline; {$endif}
+    /// get the corresponding enumeration name
+    // - return the first one if Value is invalid (>MaxValue)
+    // - Value will be converted to the matching ordinal value (byte or word)
+    function GetEnumName(const Value): PShortString;
+    /// get the caption text corresponding to a enumeration name
+    // - return the first one if Value is invalid (>MaxValue)
+    // - Value will be converted to the matching ordinal value (byte or word)
+    function GetCaption(const Value): string;
+    /// get all caption names, ready to be display, as lines separated by #13#10
+    // - return "string" type, i.e. UnicodeString for Delphi 2009+
+    // - if UsedValuesBits is not nil, only the corresponding bits set are added
+    function GetCaptionStrings(UsedValuesBits: pointer = nil): string;
+    /// add caption names, ready to be display, to a TStrings class
+    // - add pointer(ord(element)) as Objects[] value
+    // - if UsedValuesBits is not nil, only the corresponding bits set are added
+    // - can be used e.g. to populate a combo box as such:
+    // ! PTypeInfo(TypeInfo(TMyEnum))^.EnumBaseType^.AddCaptionStrings(ComboBox.Items);
+    procedure AddCaptionStrings(Strings: TStrings;
+      UsedValuesBits: pointer = nil);
+    /// retrieve all element names as a dynamic array of RawUtf8
+    // - names could be optionally trimmed left from their initial lower chars
+    procedure GetEnumNameAll(var result: TRawUtf8DynArray;
+      TrimLeftLowerCase: boolean); overload;
+    /// retrieve all element names as CSV, with optional quotes
+    procedure GetEnumNameAll(out result: RawUtf8; const Prefix: RawUtf8 = '';
+      quotedValues: boolean = false; const Suffix: RawUtf8 = '';
+      trimedValues: boolean = false; unCamelCased: boolean = false); overload;
+    /// retrieve all trimed element names as CSV
+    procedure GetEnumNameTrimedAll(var result: RawUtf8; const Prefix: RawUtf8 = '';
+      quotedValues: boolean = false; const Suffix: RawUtf8 = '');
+    /// get all enumeration names as a JSON array of strings
+    function GetEnumNameAllAsJsonArray(TrimLeftLowerCase: boolean;
+      UnCamelCased: boolean = false): RawUtf8;
+    /// get the corresponding enumeration ordinal value, from its name
+    // - if EnumName does start with lowercases 'a'..'z', they will be searched:
+    // e.g. GetEnumNameValue('sllWarning') will find sllWarning item
+    // - if Value does not start with lowercases 'a'..'z', they will be ignored:
+    // e.g. GetEnumNameValue('Warning') will find sllWarning item
+    // - return -1 if not found (don't use directly this value to avoid any GPF)
+    function GetEnumNameValue(const EnumName: ShortString): integer; overload;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// get the corresponding enumeration ordinal value, from its name
+    // - if Value does start with lowercases 'a'..'z', they will be searched:
+    // e.g. GetEnumNameValue('sllWarning') will find sllWarning item
+    // - if Value does not start with lowercases 'a'..'z', they will be ignored:
+    // e.g. GetEnumNameValue('Warning') will find sllWarning item
+    // - return -1 if not found (don't use directly this value to avoid any GPF)
+    function GetEnumNameValue(Value: PUtf8Char): integer; overload;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// get the corresponding enumeration ordinal value, from its name
+    // - if Value does start with lowercases 'a'..'z', they will be searched:
+    // e.g. GetEnumNameValue('sllWarning') will find sllWarning item
+    // - if AlsoTrimLowerCase is TRUE, and EnumName does not start with
+    // lowercases 'a'..'z', they will be ignored: e.g. GetEnumNameValue('Warning')
+    // will find sllWarning item
+    // - return -1 if not found, or if RTTI's MinValue is not 0
+    function GetEnumNameValue(Value: PUtf8Char; ValueLen: integer;
+      AlsoTrimLowerCase: boolean = true): integer; overload;
+    /// get the corresponding enumeration ordinal value, from its trimmed name
+    function GetEnumNameValueTrimmed(Value: PUtf8Char; ValueLen: integer;
+      CaseSensitive: boolean): integer;
+    /// get the corresponding enumeration name, without the first lowercase chars
+    // (otDone -> 'Done')
+    // - Value will be converted to the matching ordinal value (byte or word)
+    function GetEnumNameTrimed(const Value): RawUtf8;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// get the enumeration names corresponding to a set value as CSV
+    function GetSetName(const value; trimmed: boolean = false;
+      const sep: RawUtf8 = ','): RawUtf8;
+    /// get the enumeration names corresponding to a set value as JSON array
+    function GetSetNameJsonArray(Value: cardinal; SepChar: AnsiChar = ',';
+      FullSetsAsStar: boolean = false): RawUtf8; overload;
+    /// write the enumeration names corresponding to a set value as a JSON array
+    procedure GetSetNameJsonArray(W: TTextWriter; Value: cardinal;
+      SepChar: AnsiChar = ','; QuoteChar: AnsiChar = #0;
+      FullSetsAsStar: boolean = false; ForceTrim: boolean = false); overload;
+    /// get the corresponding enumeration ordinal value, from its name without
+    // its first lowercase chars ('Done' will find otDone e.g.)
+    // - return -1 if not found, or if RTTI's MinValue is not 0
+    function GetEnumNameTrimedValue(const EnumName: ShortString): integer; overload;
+    /// get the corresponding enumeration ordinal value, from its name without
+    // its first lowercase chars ('Done' will find otDone e.g.)
+    // - return -1 if not found, or if RTTI's MinValue is not 0
+    function GetEnumNameTrimedValue(Value: PUtf8Char; ValueLen: integer = 0): integer; overload;
+    /// compute how many bytes this type will use to be stored as a enumerate
+    function SizeInStorageAsEnum: integer;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// compute how many bytes (1, 2, 4) this type will use to be stored as a set
+    // - consider using TRttiInfo.SetEnumSize if ISFPC32 conditional is defined
+    function SizeInStorageAsSet: integer;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// store an enumeration value from its ordinal representation
+    procedure SetEnumFromOrdinal(out Value; Ordinal: PtrUInt);
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+  end;
+
+  /// RTTI of a record/object type definition (managed) field
+  // - defined here since this structure is not available in oldest
+  // Delphi's TypInfo.pas
+  // - maps TRecordElement in FPC rtti.inc or TManagedField in TypInfo
+  TRttiRecordField = record
+    /// the RTTI of this managed field
+    {$ifdef HASDIRECTTYPEINFO}
+    TypeInfo: PRttiInfo;
+    {$else}
+    TypeInfoRef: PPRttiInfo;
+    {$endif HASDIRECTTYPEINFO}
+    /// where this managed field starts in the record memory layout
+    Offset: PtrUInt;
+  end;
+  /// pointer to the RTTI of a record/object type definition (managed) field
+  PRttiRecordField = ^TRttiRecordField;
+
+  /// define the interface abilities
+  TRttiIntfFlag = (
+    ifHasGuid,
+    ifDispInterface,
+    ifDispatch
+    {$ifdef FPC} ,
+    ifHasStrGUID {$endif});
+
+  /// define the set of interface abilities
+  TRttiIntfFlags = set of TRttiIntfFlag;
+
+  /// a wrapper to interface type information, as defined by the the compiler RTTI
+  {$ifdef USERECORDWITHMETHODS}
+  TRttiInterfaceTypeData = record
+  {$else}
+  TRttiInterfaceTypeData = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// ancestor interface type
+    function IntfParent: PRttiInfo;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// interface abilities - not inlined to avoid random trouble on FPC trunk
+    function IntfFlags: TRttiIntfFlags;
+    /// interface 128-bit Guid
+    function IntfGuid: PGuid;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// where the interface has been defined
+    function IntfUnit: PShortString;
+      {$ifdef HASINLINE}inline;{$endif}
+  end;
+
+  /// pointer to a wrapper to interface type information
+  PRttiInterfaceTypeData = ^TRttiInterfaceTypeData;
+
+  /// record RTTI as returned by TRttiInfo.RecordManagedFields
+  TRttiRecordManagedFields = record
+    /// the record size in bytes
+    Size: PtrInt;
+    /// how many managed Fields[] are defined in this record
+    Count: PtrInt;
+    /// points to the first field RTTI
+    // - use inc(Fields) to go to the next one
+    Fields: PRttiRecordField;
+  end;
+
+  /// enhanced RTTI of a record/object type definition
+  // - as returned by TRttiInfo.RecordAllFields on Delphi 2010+
+  TRttiRecordAllField = record
+    /// the field RTTI definition
+    TypeInfo: PRttiInfo;
+    /// the field offset in the record
+    Offset: PtrUInt;
+    /// the field property name
+    Name: PShortString;
+  end;
+  PRttiRecordAllField = ^TRttiRecordAllField;
+
+  /// as returned by TRttiInfo.RecordAllFields
+  TRttiRecordAllFields = array of TRttiRecordAllField;
+
+  /// quick identification of some RTTI value types
+  TRttiCacheFlag = (
+    rcfQWord,
+    rcfBoolean,
+    rcfHasRttiOrd,
+    rcfGetOrdProp,
+    rcfGetInt64Prop,
+    rcfIsRawBlob,
+    rcfIsNumber);
+
+  /// as used by TRttiCache.Flags
+  // - rcfQWord/rcfBoolean map Info^.IsQWord/IsBoolean
+  // - rcfIsRawBlob maps Info^.IsRawBlob
+  // - rcfIsNumber is set if Info^.Kind is in rkNumberTypes
+  // - set rcfHasRttiOrd/rcfGetOrdProp/rcfGetInt64Prop to access the value
+  TRttiCacheFlags = set of TRttiCacheFlag;
+
+  /// convenient wrapper about PRttiInfo content and its more precise information
+  // - is cached within TRttiCustom instances for more efficient process
+  TRttiCache = record
+    /// the associated RTTI TypeInfo()
+    Info: PRttiInfo;
+    /// the size in bytes of a value of this type - equals Info^.RttiSize
+    Size: integer;
+    /// equals Info^.Kind
+    Kind: TRttiKind;
+    /// quick identification of specific types, e.g. rkOrdinalTypes
+    Flags: TRttiCacheFlags;
+    /// for rkHasRttiOrdTypes/rcfHasRttiOrd, equals Info^.RttiOrd
+    RttiOrd: TRttiOrd;
+    /// corresponding TRttiVarData.VType
+    // - rkEnumeration,rkSet,rkDynArray,rkClass,rkInterface,rkRecord,rkArray are
+    // identified as varAny with TVarData.VAny pointing to the actual value, and
+    // will be handled as expected by TJsonWriter.AddRttiVarData
+    RttiVarDataVType: word;
+    /// corresponding TVarData.VType
+    // - in respect to RttiVarDataVType, rkEnumeration and rkSet are varInt64
+    // since we don't need the RTTI information as for TRttiVarData
+    VarDataVType: word;
+    /// type-specific information
+    case TRttiKind of
+      rkFloat: (
+        RttiFloat: TRttiFloat;
+        IsDateTime: boolean);
+      rkLString: ( // from TypeInfo() on older Delphi with no CP RTTI
+        CodePage: cardinal; // RawBlob=CP_RAWBYTESTRING not CP_RAWBLOB
+        Engine: TSynAnsiConvert);
+      rkEnumeration,
+      rkSet: (
+        EnumMin,
+        EnumMax:  cardinal;
+        EnumInfo: PRttiEnumType;
+        EnumList: PShortString);
+      rkDynArray,
+      rkArray: (
+        ItemInfo: PRttiInfo; // = nil for unmanaged types
+        ItemSize: integer;
+        ItemCount: integer;  // rkArray only
+      );
+      rkClass: (
+        SerializableInterface: pointer; // = TRttiCustom of the rkInterface
+      );
+      rkInterface: (
+        InterfaceGuid: PGuid;
+        SerializableClass: TClass; // = TInterfacedSerializable
+        SerializableInterfaceEntryOffset: integer; // resolve once
+      );
+  end;
+
+  /// map extended PRttiInfo content
+  PRttiCache = ^TRttiCache;
+
+  {$A-}
+
+  /// main entry-point wrapper to access RTTI for a given pascal type
+  // - as returned by the TypeInfo() low-level compiler function
+  // - other RTTI objects can be computed from a pointer to this structure
+  // - user types defined as an alias don't have this type information:
+  // ! type
+  // !   TNewType = TOldType;
+  // here TypeInfo(TNewType) = TypeInfo(TOldType)
+  // - user types defined as new types have this type information:
+  // ! type
+  // !   TNewType = type TOldType;
+  // here TypeInfo(TNewType) <> TypeInfo(TOldType)
+  {$ifdef USERECORDWITHMETHODS}
+  TRttiInfo = record
+  {$else}
+  TRttiInfo = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// the value type family
+    // - not defined as an inlined function, since first field is always aligned
+    Kind: TRttiKind;
+    /// the declared name of the type ('String','Word','RawUnicode'...)
+    // - won't adjust internal/cardinal names on FPC as with Name method
+    RawName: ShortString;
+    /// the declared name of the type ('String','Word','RawUnicode'...)
+    // - will return '' if @self is nil
+    // - on FPC, will adjust 'integer'/'cardinal' from 'longint'/'longword' RTTI
+    // - on Delphi and FPC, will adjust weak RawUtf8 = UTF8String as 'RawUtf8'
+    function Name: PShortString;
+    /// efficiently finalize any (managed) type value
+    // - do nothing for unmanaged types (e.g. integer)
+    // - if you are sure that your type is managed, you may call directly
+    // $ RTTI_FINALIZE[Info^.Kind](Data, Info);
+    procedure Clear(Data: pointer);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// efficiently copy any (managed) type value
+    // - do nothing for unmanaged types (e.g. integer)
+    // - if you are sure that your type is managed, you may call directly
+    // $ RTTI_MANAGEDCOPY[Info^.Kind](Dest, Source, Info);
+    procedure Copy(Dest, Source: pointer);
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// compute extended information about this RTTI type
+    procedure ComputeCache(var Cache: TRttiCache);
+    /// for ordinal types, get the storage size and sign
+    function RttiOrd: TRttiOrd;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// return TRUE if the property is an unsigned 64-bit field (QWord/UInt64)
+    function IsQWord: boolean;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// return TRUE if the property is a boolean field
+    function IsBoolean: boolean;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// return TRUE if the property is a currency field
+    function IsCurrency: boolean;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// return TRUE if the property is a TDateTime/TDateTimeMS/TDate
+    function IsDate: boolean;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// return true if this property is a BLOB (RawBlob)
+    function IsRawBlob: boolean;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// for rkFloat: get the storage size and precision
+    // - will also properly detect our currency internal type as rfCurr
+    function RttiFloat: TRttiFloat;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// for rkEnumeration: get the enumeration type information
+    function EnumBaseType: PRttiEnumType; overload;
+      {$ifdef FPC}inline;{$endif} { on Delphi, inline would require typinfo }
+    /// for rkEnumeration: get the enumeration values information
+    function EnumBaseType(out NameList: PShortString;
+      out Min, Max: integer): PRttiEnumType; overload;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// for rkSet: get the type information of its associated enumeration
+    function SetEnumType: PRttiEnumType; overload;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// for rkSet: get the associated enumeration values information
+    function SetEnumType(out NameList: PShortString;
+      out Min, Max: integer): PRttiEnumType; overload;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// for rkSet: in how many bytes this type is stored
+    // - is very efficient on latest FPC only - i.e. ifdef ISFPC32
+    function SetEnumSize: PtrInt; {$ifdef ISFPC32} inline; {$endif}
+    /// compute in how many bytes this type is stored
+    // - will use Kind (and RttiOrd/RttiFloat) to return the exact value
+    function RttiSize: PtrInt;
+    /// check if this type is a managed type, or has any managed field
+    // - will also check for the nested fields e.g. for rkRecordTypes
+    function IsManaged: boolean;
+    /// for rkRecordTypes: get the record size
+    // - returns 0 if the type is not a record/object
+    function RecordSize: PtrInt;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// for rkRecordTypes: retrieve RTTI information about all managed fields
+    // of this record
+    // - non managed fields (e.g. integers, double...) are not listed here
+    // - also includes the total record size in bytes
+    // - caller should ensure the type is indeed a record/object
+    // - note: if FPC_OLDRTTI is defined, unmanaged fields are included
+    procedure RecordManagedFields(out Fields: TRttiRecordManagedFields);
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// for rkRecordTypes: check if this record as any managed fields
+    function RecordManagedFieldsCount: integer;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// for rkRecordTypes: retrieve enhanced RTTI information about all fields
+    // of this record, for JSON serialization without text definition
+    // - this information is currently only available since Delphi 2010
+    // - if any field has no RTTI (e.g. a static array of unmanaged type), then
+    // it will ignore this uncomplete, therefore non-useful RTTI
+    // - in practice, it may be a good habit to always define the records used
+    // within the SOA (e.g. as DTOs) calling RegisterFromText, and don't rely on
+    // this RTTI, since it will be more cross-platform, and more customizable
+    function RecordAllFields(out RecSize: PtrInt): TRttiRecordAllFields;
+    /// for rkDynArray: get the dynamic array standard RTTI of the stored item
+    // - returns nil if the item has no managed field
+    // - caller should ensure the type is indeed a dynamic array
+    function DynArrayItemType: PRttiInfo; overload;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// for rkDynArray: get the dynamic array deep RTTI of the stored item
+    // - works for both managed and unmanaged types, on FPC and Delphi 2010+
+    // - caller should ensure the type is indeed a dynamic array
+    function DynArrayItemTypeExtended: PRttiInfo;
+    /// for rkDynArray: get the dynamic array type information of the stored item
+    // - this overloaded method will also return the item size in bytes
+    // - caller should ensure the type is indeed a dynamic array
+    function DynArrayItemType(out aDataSize: PtrInt): PRttiInfo; overload;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// for rkDynArray: get the dynamic array size (in bytes) of the stored item
+    function DynArrayItemSize: PtrInt;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// for rkArray: get the static array type information of the stored item
+    // - returns nil if the array type is unmanaged (i.e. behave like Delphi)
+    // - aDataSize is the size in bytes of all aDataCount static items (not
+    // the size of each item)
+    // - caller should ensure the type is indeed a static array
+    function ArrayItemType(out aDataCount, aDataSize: PtrInt): PRttiInfo;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// for rkArray: get the size in bytes of all the static array items
+    // - caller should ensure the type is indeed a static array
+    function ArraySize: PtrInt;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// recognize most used string types, returning their code page
+    // - will return the exact code page on FPC and since Delphi 2009, from RTTI
+    // - for non Unicode versions of Delphi, will recognize WinAnsiString as
+    // CP_WINANSI, RawUnicode as CP_UTF16, RawByteString/RawBlob as
+    // CP_RAWBYTESTRING, AnsiString as CP_ACP=0, and any other type as RawUtf8
+    // - it will also recognize RawBlob as the fake CP_RAWBLOB codepage
+    function AnsiStringCodePage: integer;
+      {$ifdef HASCODEPAGE}{$ifdef HASSAFEINLINE}inline;{$endif}{$endif}
+    {$ifdef HASCODEPAGE}
+    /// returning the code page stored in the RTTI
+    // - without recognizing e.g. RawBlob
+    // - caller should ensure the type is indeed a rkLString
+    function AnsiStringCodePageStored: integer;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    {$endif HASCODEPAGE}
+    /// retrieve rkLString, rkSString, rkUString, rkWString, rkChar, rkWChar
+    // values as RawUtf8, from a pointer to its memory storage
+    // - makes heap allocations and encoding conversion, so may be slow
+    procedure StringToUtf8(Data: pointer; var Value: RawUtf8);
+    /// for rkClass: get the class type information
+    function RttiClass: PRttiClass;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// for rkClass: get the class type information
+    function RttiNonVoidClass: PRttiClass;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// for rkClass: return the number of published properties in this class
+    // - you can count the plain fields without any getter function, if you
+    // do need only the published properties corresponding to some value
+    // actually stored, and ignore e.g. any textual conversion
+    function ClassFieldCount(onlyWithoutGetter: boolean): integer;
+    /// for rkClass: fast and easy check if a class inherits from this RTTI
+    function InheritsFrom(AClass: TClass): boolean;
+    /// for rkInterface: get the interface type information
+    function InterfaceType: PRttiInterfaceTypeData;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// for rkInterface: get the TGuid of a given interface type information
+    // - returns nil if this type is not an interface
+    function InterfaceGuid: PGuid;
+    /// for rkInterface: get the unit name of a given interface type information
+    // - returns '' if this type is not an interface
+    function InterfaceUnitName: PShortString;
+    /// for rkInterface: get the ancestor/parent of a given interface type information
+    // - returns nil if this type has no parent
+    function InterfaceAncestor: PRttiInfo;
+    /// for rkInterface: get all ancestors/parents of a given interface type information
+    // - only ancestors with an associated TGuid will be added
+    // - if OnlyImplementedBy is not nil, only the interface explicitly
+    // implemented by this class will be added, and AncestorsImplementedEntry[]
+    // will contain the corresponding PInterfaceEntry values
+    procedure InterfaceAncestors(out Ancestors: PRttiInfoDynArray;
+      OnlyImplementedBy: TInterfacedObjectClass;
+      out AncestorsImplementedEntry: TPointerDynArray);
+    /// for rkInterface: check if this type (or ancestor) implements a TGuid
+    function InterfaceImplements(const AGuid: TGuid): boolean;
+  end;
+
+  {$A+}
+
+  /// how a RTTI property definition access its value
+  // - as returned by TPropInfo.Getter/Setter/GetterIs/SetterIs methods
+  TRttiPropCall = (
+    rpcNone,
+    rpcField,
+    rpcMethod,
+    rpcIndexed);
+
+  /// TRttiProp.IsStoredKind response - default is "stored true"
+  TRttiPropStored = (
+    rpsTrue,
+    rpsFalse,
+    rpsGetter);
+
+  /// a wrapper containing a RTTI class property definition
+  // - used for direct Delphi / UTF-8 SQL type mapping/conversion
+  // - doesn't depend on RTL's TypInfo unit, to enhance cross-compiler support
+  {$ifdef USERECORDWITHMETHODS}
+  TRttiProp = record
+  {$else}
+  TRttiProp = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// raw retrieval of the property read access definition
+    // - note: 'var Call' generated incorrect code on Delphi XE4 -> use PMethod
+    function Getter(Instance: TObject; Call: PMethod): TRttiPropCall;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// raw retrieval of the property access definition
+    function Setter(Instance: TObject; Call: PMethod): TRttiPropCall;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// raw retrieval of rkInteger,rkEnumeration,rkSet,rkChar,rkWChar,rkBool
+    // - rather call GetOrdValue/GetInt64Value
+    // - returns an Int64 to properly support cardinal values
+    function GetOrdProp(Instance: TObject): Int64;
+    /// raw assignment of rkInteger,rkEnumeration,rkSet,rkChar,rkWChar,rkBool
+    // - rather call SetOrdValue/SetInt64Value
+    procedure SetOrdProp(Instance: TObject; Value: PtrInt);
+    /// raw retrieval of rkClass
+    function GetObjProp(Instance: TObject): TObject;
+    /// raw retrieval of rkDynArray getter as a pointer
+    // - caller should then release the instance using e.g. FastDynArrayClear()
+    // - do nothing if the property is a field with no getter
+    function GetDynArrayPropGetter(Instance: TObject): pointer;
+    /// raw retrieval of rkInt64, rkQWord
+    // - rather call GetInt64Value
+    function GetInt64Prop(Instance: TObject): Int64;
+    /// raw assignment of rkInt64, rkQWord
+    // - rather call SetInt64Value
+    procedure SetInt64Prop(Instance: TObject; const Value: Int64);
+    /// raw retrieval of rkLString
+    procedure GetLongStrProp(Instance: TObject; var Value: RawByteString);
+    /// raw assignment of rkLString
+    procedure SetLongStrProp(Instance: TObject; const Value: RawByteString);
+    /// raw copy of rkLString
+    procedure CopyLongStrProp(Source, Dest: TObject);
+    /// raw retrieval of rkString into an Ansi7String
+    procedure GetShortStrProp(Instance: TObject; var Value: RawUtf8);
+    /// raw retrieval of rkWString
+    procedure GetWideStrProp(Instance: TObject; var Value: WideString);
+    /// raw assignment of rkWString
+    procedure SetWideStrProp(Instance: TObject; const Value: WideString);
+    {$ifdef HASVARUSTRING}
+    /// raw retrieval of rkUString
+    procedure GetUnicodeStrProp(Instance: TObject; var Value: UnicodeString);
+    /// raw assignment of rkUString
+    procedure SetUnicodeStrProp(Instance: TObject; const Value: UnicodeString);
+    {$endif HASVARUSTRING}
+    /// raw retrieval of rkFloat/currency
+    // - use instead GetCurrencyValue
+    procedure GetCurrencyProp(Instance: TObject; var Value: currency);
+    /// raw assignment of rkFloat/currency
+    procedure SetCurrencyProp(Instance: TObject; const Value: currency);
+    /// raw retrieval of rkFloat/double
+    function GetDoubleProp(Instance: TObject): double;
+    /// raw assignment of rkFloat/double
+    procedure SetDoubleProp(Instance: TObject; Value: Double);
+    /// raw retrieval of rkFloat - with conversion to 64-bit double
+    // - use instead GetDoubleProp if you know the property is a rkFloat/double
+    function GetFloatProp(Instance: TObject): double;
+    /// raw assignment of rkFloat
+    // - use instead SetDoubleProp if you know the property is a rkFloat/double
+    procedure SetFloatProp(Instance: TObject; Value: TSynExtended);
+    /// raw retrieval of rkVariant
+    // - will use varByRef from the field address if SetByRef is true
+    procedure GetVariantProp(Instance: TObject; var Result: Variant; SetByRef: boolean);
+    /// raw assignment of rkVariant
+    procedure SetVariantProp(Instance: TObject; const Value: Variant);
+  public
+    /// contains the index value of an indexed class data property
+    // - outside SQLite3, this can be used to define a VARCHAR() length value
+    // for the textual field definition (sftUtf8Text/sftAnsiText); e.g.
+    // the following will create a NAME VARCHAR(40) field:
+    // ! Name: RawUtf8 index 40 read fName write fName;
+    // - is used by a dynamic array property for fast usage of the
+    // TOrm.DynArray(DynArrayFieldIndex) method
+    function Index: integer;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// contains the default value for an ordinal or set property
+    // - NO_DEFAULT=$80000000 indicates none was defined in source code
+    // - see also TPropInfo.DefaultOr0
+    function Default: integer;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// return the Default RTTI value defined for this property, or 0 if not set
+    function DefaultOr0: integer;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// index of the property in the current inherited class definition
+    // - first name index at a given class level is 0
+    // - index is reset to 0 at every inherited class level
+    function NameIndex: integer;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// the property Name, directly returned from RTTI
+    function Name: PShortString;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// the property Name, converted as a RawUtf8
+    function NameUtf8: RawUtf8;
+    /// the type information of this property
+    // - will de-reference the PropType pointer on Delphi and newer FPC compilers
+    function TypeInfo: PRttiInfo;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// get the next property information
+    // - no range check: use RttiProps()^.PropCount to determine the properties count
+    // - get the first PRttiProp with RttiProps()^.PropList
+    function Next: PRttiProp;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// returns rpsTrue/rpsFalse if was marked as "stored true/false" or
+    // rpsGetter if IsStoredGetter(Instance) is to be called at runtime
+    function IsStoredKind: TRttiPropStored;
+    /// raw retrieval of the 'stored' flag using getter
+    /// - called by IsStored or for TRttiPropStored = rpsGetter
+    function IsStoredGetter(Instance: TObject): boolean;
+    /// return the "stored true/false/method/field" value for a class property
+    // - not used internally: for backward compatibility only
+    function IsStored(Instance: TObject): boolean;
+    /// return true if this property is a BLOB (RawBlob)
+    function IsRawBlob: boolean;
+      {$ifdef FPC} inline; {$endif}
+    /// compute in how many bytes this property is stored
+    function FieldSize: PtrInt;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// return TRUE if the property has no getter but direct field read
+    // - returns FALSE if no "read" attribute was specified: use GetterCall
+    // if you want to mimic how Get*() methods could use the "write" field
+    function GetterIsField: boolean;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// return TRUE if the property has no setter but direct field write
+    // - returns FALSE if no "write" attribute is specified: use SetterCall
+    // if you want to mimic how Set*() methods could use the "read" field
+    function SetterIsField: boolean;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// returns how a property should be retrieved
+    // - no "read" attribute specified will return rpcField if "write" is a
+    // direct field access - just like any Get*() method would do
+    function GetterCall: TRttiPropCall;
+    /// returns how a property should be set
+    // - no "write" attribute specified will return rpcField if "read" is a
+    // direct field access - just like any Set*() method would do
+    function SetterCall: TRttiPropCall;
+    /// return TRUE if the property has a write setter or direct field
+    function WriteIsDefined: boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// returns the low-level field read address, if GetterIsField is TRUE
+    function GetterAddr(Instance: pointer): pointer;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// returns the low-level field write address, if SetterIsField is TRUE
+    function SetterAddr(Instance: pointer): pointer;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// low-level getter of the field value memory pointer
+    // - return NIL if both getter and setter are methods
+    function GetFieldAddr(Instance: TObject): pointer;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+
+    /// low-level getter of the ordinal property value of a given instance
+    // - this method will check if the corresponding property is ordinal
+    // - returns an Int64 to properly support cardinal values
+    // - return -1 on any error
+    function GetOrdValue(Instance: TObject): Int64;
+      {$ifdef FPC}inline;{$endif}
+    /// low-level getter of the ordinal property value of a given instance
+    // - this method will check if the corresponding property is ordinal
+    // - ordinal properties smaller than rkInt64 will return an Int64-converted
+    // value (e.g. rkInteger)
+    // - return 0 on any error
+    function GetInt64Value(Instance: TObject): Int64;
+    /// low-level getter of the currency property value of a given instance
+    // - this method will check if the corresponding property is exactly currency
+    // - return 0 on any error
+    procedure GetCurrencyValue(Instance: TObject; var Value: currency);
+    /// low-level getter of the floating-point property value of a given instance
+    // - this method will check if the corresponding property is floating-point
+    // - return 0 on any error
+    function GetDoubleValue(Instance: TObject): double;
+    /// low-level setter of the floating-point property value of a given instance
+    // - this method will check if the corresponding property is floating-point
+    procedure SetDoubleValue(Instance: TObject; const Value: double);
+    /// low-level getter of the long string property content of a given instance
+    // - just a wrapper around low-level GetLongStrProp() function
+    // - call GetLongStrValue() method if you want a conversion into RawUtf8
+    // - will work only for Kind=rkLString
+    procedure GetRawByteStringValue(Instance: TObject; var Value: RawByteString);
+    /// low-level setter of the ordinal property value of a given instance
+    // - this method will check if the corresponding property is ordinal
+    procedure SetOrdValue(Instance: TObject; Value: PtrInt);
+    /// low-level setter of the ordinal property value of a given instance
+    // - this method will check if the corresponding property is ordinal
+    procedure SetInt64Value(Instance: TObject; Value: Int64);
+    {$ifdef HASVARUSTRING}
+    /// low-level setter of the Unicode string property value of a given instance
+    // - this method will check if the corresponding property is a Unicode String
+    procedure SetUnicodeStrValue(Instance: TObject; const Value: UnicodeString);
+    /// low-level getter of the Unicode string property value of a given instance
+    // - this method will check if the corresponding property is a Unicode String
+    function GetUnicodeStrValue(Instance: TObject): UnicodeString;
+    {$endif HASVARUSTRING}
+    /// retrieve rkLString, rkSString, rkUString, rkWString, rkChar, rkWChar as RawUtf8
+    // - this would make heap allocations and encoding conversion, so may be slow
+    function GetAsString(Instance: TObject; var Value: RawUtf8): boolean; overload;
+    /// retrieve rkLString, rkSString, rkUString, rkWString, rkChar, rkWChar as RawUtf8
+    // - just a wrapper around the overloaded GetAsString() function
+    function GetAsString(Instance: TObject): RawUtf8; overload;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// get a property value into text
+    // - handle all kind of fields, e.g. converting ordinal or floats into text
+    function GetValueText(Instance: TObject): RawUtf8;
+    /// set rkLString, rkSString, rkUString, rkWString, rkChar, rkWChar from
+    // a RawUtf8 value
+    // - this would make heap allocations and encoding conversion, so may be slow
+    function SetAsString(Instance: TObject; const Value: RawUtf8): boolean;
+    /// set a property value from a variant value
+    // - to be called when a setter is involved - not very fast, but safe
+    function SetValue(Instance: TObject; const Value: variant): boolean;
+    /// set a property value from a text value
+    // - handle simple kind of fields, e.g. converting from text into ordinals
+    // or floats, and also enumerates or sets; but won't support complex types
+    // like class instances, dynamic arrays or variants
+    function SetValueText(Instance: TObject; const Value: RawUtf8): boolean;
+  end;
+
+const
+  NO_DEFAULT = integer($80000000);
+
+/// retrieve the text name of one TRttiKind enumerate
+function ToText(k: TRttiKind): PShortString; overload;
+
+var
+  /// convert an ordinal value from its (signed) pointer-sized integer representation
+  RTTI_FROM_ORD: array[TRttiOrd] of function(P: pointer): Int64;
+
+  /// convert an ordinal value into its RTTI-defined binary buffer
+  RTTI_TO_ORD: array[TRttiOrd] of procedure(P: pointer; Value: PtrInt);
+
+  /// convert a float value into its RTTI-defined binary buffer
+  RTTI_TO_FLOAT: array[TRttiFloat] of procedure(P: pointer; Value: TSynExtended);
+
+
+{$ifdef HASINLINE}
+// some functions which should be defined here for proper inlining
+
+{$ifdef FPC}
+
+{$ifndef HASDIRECTTYPEINFO}
+function Deref(Info: pointer): pointer; inline;
+{$endif HASDIRECTTYPEINFO}
+
+{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+function AlignToPtr(p: pointer): pointer; inline;
+{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+
+{$endif FPC}
+
+type
+  // redefined here for proper Delphi inlining
+  PTypeData = type typinfo.PTypeData;
+  TPropInfo = type typinfo.TPropInfo;
+  PPropInfo = type typinfo.PPropInfo;
+
+/// efficiently inlined low-level function to retrieve raw RTTI structure
+function GetTypeData(TypeInfo: pointer): PTypeData; inline;
+
+{$endif HASINLINE}
+
+{$ifdef ISDELPHI}// Delphi requires those definitions for proper inlining
+
+const
+  NO_INDEX = integer($80000000);
+
+  ptField = $ff;
+  ptVirtual = $fe;
+
+type
+  /// used to map a TPropInfo.GetProc/SetProc and retrieve its kind
+  // - defined here for proper Delphi inlining
+  PropWrap = packed record
+    FillBytes: array [0 .. SizeOf(Pointer) - 2] of byte;
+    /// =$ff for a ptField address, or =$fe for a ptVirtual method
+    Kind: byte;
+  end;
+
+  /// PPropData not defined in Delphi 7/2007 TypInfo
+  // - defined here for proper Delphi inlining
+  TPropData = packed record
+    PropCount: word;
+    PropList: record end;
+  end;
+  PPropData = ^TPropData;
+
+  /// rkRecord RTTI is not defined in Delphi 7/2007 TTypeData
+  // - defined here for proper Delphi inlining
+  TRecordInfo = packed record
+    RecSize: integer;
+    ManagedFldCount: integer;
+  end;
+  PRecordInfo = ^TRecordInfo;
+
+  /// rkArray RTTI not defined in Delphi 7/2007 TTypeData
+  // - defined here for proper Delphi inlining
+  TArrayInfo = packed record
+    ArraySize: integer;
+    ElCount: integer;
+    ArrayType: PPRttiInfo;
+    DimCount: byte;
+    Dims: array[0..255 {DimCount-1}] of PPRttiInfo;
+  end;
+  PArrayInfo = ^TArrayInfo;
+
+{$endif ISDELPHI}
+
+
+{ **************** Published Class Properties and Methods RTTI }
+
+/// retrieve the class RTTI information for a specific class
+function GetRttiClass(RttiClass: TClass): PRttiClass;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// retrieve the class property RTTI information for a specific class
+function GetRttiProps(RttiClass: TClass): PRttiProps;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// retrieve the class property RTTI information for a specific class
+// - will return the number of published properties
+// - and set the PropInfo variable to point to the first property
+// - typical use to enumerate all published properties could be:
+//  !  var i: integer;
+//  !      CT: TClass;
+//  !      P: PRttiProp;
+//  !  begin
+//  !    CT := ..;
+//  !    repeat
+//  !      for i := 1 to GetRttiProp(CT,P) do
+// !       begin
+//  !        // use P^
+//  !        P := P^.Next;
+//  !      end;
+//  !      CT := GetClassParent(CT);
+//  !    until CT=nil;
+//  !  end;
+// such a loop is much faster than using the RTL's TypeInfo or RTTI units
+function GetRttiProp(C: TClass; out PropInfo: PRttiProp): integer;
+
+/// retrieve a Field property RTTI information from a Property Name
+function ClassFieldProp(ClassType: TClass; const PropName: ShortString): PRttiProp;
+
+/// retrieve a Field property RTTI information from a Property Name
+// - this special version also searches into parent properties
+// (TRttiProp search scope is only inside the current class level)
+function ClassFieldPropWithParents(aClassType: TClass; const aPropName: ShortString;
+  aCaseSensitive: boolean = false): PRttiProp;
+
+/// retrieve an integer/Int64 Field propery value from a Property Name
+// - this special version also searches into parent properties
+// (TRttiProp search scope is only inside the current class level)
+// - returns TRUE and set PropValue if a matching property was found
+function ClassFieldInt64(Instance: TObject; const PropName: ShortString;
+  out PropValue: Int64): boolean;
+
+/// retrieve a class Field property instance from a Property Name
+// - this special version also searches into parent properties
+// (TRttiProp search scope is only inside the current class level)
+// - returns TRUE and set PropInstance if a matching property was found
+function ClassFieldInstance(Instance: TObject; const PropName: ShortString;
+  PropClassType: TClass; out PropInstance): boolean; overload;
+
+/// retrieve a Field property RTTI information from a Property Name
+// - this special version also searches into parent properties
+// (TRttiProp search scope is only inside the current class level)
+function ClassFieldPropWithParentsFromUtf8(aClassType: TClass; PropName: PUtf8Char;
+  PropNameLen: integer; aCaseSensitive: boolean = false): PRttiProp;
+
+/// retrieve a Field property RTTI information searching for an exact
+// Property class type
+// - this special version also searches into parent properties
+function ClassFieldPropWithParentsFromClassType(aClassType,
+  aSearchedClassType: TClass): PRttiProp;
+
+/// retrieve a Field property RTTI information searching for an inherited
+// Property class type
+// - this special version also searches into parent properties
+function ClassFieldPropWithParentsInheritsFromClassType(aClassType,
+  aSearchedClassType: TClass): PRttiProp;
+
+/// retrieve a Field property RTTI information searching for an exact
+// Property offset address
+// - this special version also searches into parent properties
+function ClassFieldPropWithParentsFromClassOffset(aClassType: TClass;
+  aSearchedOffset: pointer): PRttiProp;
+
+/// retrieve a class Field property instance from a Property class type
+// - this version also searches into parent properties
+// - returns TRUE and set PropInstance if a matching property was found
+function ClassFieldInstance(Instance: TObject; PropClassType: TClass;
+  out PropInstance): boolean; overload;
+
+/// retrieve all class Field property instances from a Property class type
+// - this version also searches into parent properties
+// - returns all matching property instances found
+function ClassFieldInstances(Instance: TObject;
+  PropClassType: TClass): TObjectDynArray;
+
+/// retrieve a class instance property value matching a class type
+// - if aSearchedInstance is aSearchedClassType, will return aSearchedInstance
+// - if aSearchedInstance is not aSearchedClassType, it will try all nested
+// properties of aSearchedInstance for a matching aSearchedClassType: if no
+// exact match is found, will return aSearchedInstance
+function ClassFieldPropInstanceMatchingClass(aSearchedInstance: TObject;
+  aSearchedClassType: TClass): TObject;
+
+/// retrieve the total number of properties for a class, including its parents
+function ClassFieldCountWithParents(ClassType: TClass;
+  onlyWithoutGetter: boolean = false): integer;
+
+/// returns TRUE if the class has some published fields, including its parents
+function ClassHasPublishedFields(ClassType: TClass): boolean;
+
+/// retrieve all class hierachy types which have some published properties
+function ClassHierarchyWithField(ClassType: TClass): TClassDynArray;
+
+/// retrieve the PRttiProp values of all published properties of a class
+// - you could select which property types should be included in the list
+function ClassFieldAllProps(ClassType: TClass;
+  Types: TRttiKinds = [low(TRttiKind)..high(TRttiKind)]): PRttiPropDynArray;
+
+/// retrieve the field names of all published properties of a class
+// - will optionally append the property type to the name, e.g 'Age: integer'
+// - you could select which property types should be included in the list
+function ClassFieldNamesAllProps(
+  ClassType: TClass; IncludePropType: boolean = false;
+  Types: TRttiKinds = [low(TRttiKind)..high(TRttiKind)]): TRawUtf8DynArray;
+
+/// retrieve the field names of all published properties of a class
+// - will optionally append the property type to the name, e.g 'Age: integer'
+// - you could select which property types should be included in the list
+function ClassFieldNamesAllPropsAsText(
+  ClassType: TClass; IncludePropType: boolean = false;
+  Types: TRttiKinds = [low(TRttiKind)..high(TRttiKind)]): RawUtf8;
+
+
+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;
+
+
+/// copy object properties
+// - copy integer, Int64, enumerates (including boolean), variant, records,
+// dynamic arrays, classes and any string properties (excluding ShortString)
+// - TCollection items can be copied also, if they are of the same exact class
+// - object properties instances are created in aTo if the objects are not
+// TOrm children (in this case, these are not class instances, but
+// INTEGER reference to records, so only the integer value is copied), that is
+// for regular classes
+procedure CopyObject(aFrom, aTo: TObject); overload;
+
+/// create a new object instance, from an existing one
+// - will create a new instance of the same class, then call the overloaded
+// CopyObject() procedure to copy its values
+function CopyObject(aFrom: TObject): TObject; overload;
+
+/// copy two TStrings instances
+// - will just call Dest.Assign(Source) in practice
+procedure CopyStrings(Source, Dest: TStrings);
+
+/// copy two TCollection instances
+// - will call CopyObject() in loop to repopulate the Dest collection,
+// which will work even if Assign() method was not overriden
+procedure CopyCollection(Source, Dest: TCollection);
+
+/// set any default integer or enumerates (including boolean) published
+// properties values for a TPersistent/TSynPersistent
+// - set only the values set as "property ... default ..." at class type level
+// - will also reset the published properties of the nested classes
+procedure SetDefaultValuesObject(Instance: TObject);
+
+/// set any (potentially nested) object property by path
+// - see also GetValueObject() from mormot.core.json
+function SetValueObject(Instance: TObject; const Path: RawUtf8;
+  const Value: variant): boolean;
+
+/// returns TRUE on a nil instance or if all its published properties are default/0
+// - check nested TRttiCustom.Props and TRttiCustom.ValueIterateCount
+function IsObjectDefaultOrVoid(Value: TObject): boolean;
+
+/// will reset all the object properties to their default
+// - strings will be set to '', numbers to 0
+// - if FreeAndNilNestedObjects is the default FALSE, will recursively reset
+// all nested class properties values
+// - if FreeAndNilNestedObjects is TRUE, will FreeAndNil() all the nested
+// class properties
+// - for a TOrm, use its ClearProperties method instead, which will
+// handle the ID property, and any nested JOINed instances
+procedure ClearObject(Value: TObject; FreeAndNilNestedObjects: boolean = false);
+
+/// release all low-level managed fields of this instance
+// - just a wrapper around Value.CleanupInstance
+procedure FinalizeObject(Value: TObject);
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// fill a class instance properties from command line switches
+// - SwitchPrefix + property name will be searched in CommandLine.Names[]
+// - is typically used to fill a settings class instance
+// - won't include any nested class or dynamic array properties
+function SetObjectFromExecutableCommandLine(Value: TObject;
+  const SwitchPrefix, DescriptionSuffix: RawUtf8;
+  CommandLine: TExecutableCommandLine = nil): boolean;
+
+
+{ *************** Enumerations RTTI }
+
+/// helper to retrieve low-level RTTI information of an enumeration type
+// - just a wrapper around
+// $ aTypeInfo^.EnumBaseType(List, result);
+function GetEnumType(aTypeInfo: PRttiInfo; out List: PShortString): integer;
+
+/// helper to retrieve the text of an enumerate item
+// - just a wrapper around
+// $ aTypeInfo^.EnumBaseType.GetEnumNameOrd(aIndex)
+function GetEnumName(aTypeInfo: PRttiInfo; aIndex: integer): PShortString;
+
+/// get the corresponding enumeration name, without the first lowercase chars
+// - e.g. otDone -> 'Done'
+// - this will return the code-based English text; use GetEnumCaption() to
+// retrieve the enumeration display text
+function GetEnumNameTrimed(aTypeInfo: PRttiInfo; aIndex: integer): RawUtf8;
+
+/// get the enumeration name, without the first lowercase chars, and uncamelcased
+// - e.g. otProcessDone -> 'Process done'
+function GetEnumNameUnCamelCase(aTypeInfo: PRttiInfo; aIndex: integer): RawUtf8;
+
+/// helper to retrieve all texts of an enumerate
+// - may be used as cache for overloaded ToText() content
+procedure GetEnumNames(aTypeInfo: PRttiInfo; 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: PRttiInfo; aDest: PRawUtf8); overload;
+
+/// helper to retrieve all trimmed texts of an enumerate as UTF-8 strings
+// - typical usage is the following:
+// ! var
+// !   TXT: array[TBenchmark] of RawUtf8;
+// ! ...
+// !   GetEnumTrimmedNames(TypeInfo(TBenchmark), @TXT);
+function GetEnumTrimmedNames(aTypeInfo: PRttiInfo): TRawUtf8DynArray; overload;
+
+/// 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
+function GetEnumNameValue(aTypeInfo: PRttiInfo; aValue: PUtf8Char; aValueLen: PtrInt;
+  AlsoTrimLowerCase: boolean = false): integer; overload;
+
+/// retrieve the index of an enumerate item from its left-trimmed text
+// - text comparison is case-insensitive for A-Z characters
+// - will trim the lowercase 'a'..'z' chars on left side of the supplied aValue text
+// - returns -1 if aValue was not found
+function GetEnumNameValueTrimmed(aTypeInfo: PRttiInfo;
+  aValue: PUtf8Char; aValueLen: PtrInt): integer;
+
+/// retrieve the index of an enumerate item from its left-trimmed text
+// - text comparison is case-sensitive for A-Z characters
+// - will trim the lowercase 'a'..'z' chars on left side of the supplied aValue text
+// - returns -1 if aValue was not found
+function GetEnumNameValueTrimmedExact(aTypeInfo: PRttiInfo;
+  aValue: PUtf8Char; aValueLen: PtrInt): integer;
+
+/// helper to retrieve the index of an enumerate item from its text
+function GetEnumNameValue(aTypeInfo: PRttiInfo; const aValue: RawUtf8;
+  AlsoTrimLowerCase: boolean = false): integer; overload;
+
+/// store an enumeration value from its ordinal representation
+procedure SetEnumFromOrdinal(aTypeInfo: PRttiInfo; out Value; Ordinal: PtrUInt);
+
+/// helper to retrieve the CSV text of all enumerate items defined in a set
+function GetSetName(aTypeInfo: PRttiInfo; const value): RawUtf8;
+
+/// helper to retrieve the CSV text of all enumerate items defined in a set
+procedure GetSetNameShort(aTypeInfo: PRttiInfo; const value;
+  out result: ShortString; trimlowercase: boolean = false);
+
+/// low-level function parsing Value/ValueLen into a set, returned as 64-bit
+procedure SetNamesValue(SetNames: PShortString; MinValue, MaxValue: integer;
+  Value: PUtf8Char; ValueLen: PtrInt; var Result: QWord);
+
+/// helper to parse some CSV values into a set, returned as 64-bit
+// - see also GetSetNameValue() in mormot.core.json.pas for parsing a JSON array
+function GetSetCsvValue(aTypeInfo: PRttiInfo; Csv: PUtf8Char;
+  Sep: AnsiChar = ','): QWord;
+
+/// helper to retrieve all (translated) caption texts of an enumerate
+// - may be used as cache for overloaded ToCaption() content
+procedure GetEnumCaptions(aTypeInfo: PRttiInfo; aDest: PString);
+
+/// UnCamelCase and translate the enumeration item
+function GetCaptionFromEnum(aTypeInfo: PRttiInfo; 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);
+
+/// will get a class name as UTF-8
+// - will trim 'T', 'TSyn' or 'TOrm' 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 TOrm class
+function GetDisplayNameFromClass(C: TClass): RawUtf8;
+
+/// UnCamelCase and translate the class name, triming any left 'T' 'TSyn' 'TOrm'
+// - return RTL string type, i.e. UnicodeString for Delphi 2009+
+function GetCaptionFromClass(C: TClass): string;
+
+/// defined here to avoid circular dependency in mormot.core.os.pas
+function ToText(cmd: TParseCommands): ShortString; overload;
+
+/// defined here to avoid circular dependency in mormot.core.os.pas
+function ToText(w: TWellKnownSid): PShortString; overload;
+
+
+{ ***************** IInvokable Interface RTTI }
+
+type
+  /// handled kind of parameters direction for an interface method
+  // - IN, IN/OUT, OUT directions can be applied to arguments, e.g. to be
+  // available through our JSON-serialized remote access: rmdVar and rmdOut
+  // kind of parameters will be returned within the "result": JSON array
+  // - rmdResult is used for a function method, to handle the returned value
+  TRttiMethodArgDirection = (
+    rmdConst,
+    rmdVar,
+    rmdOut,
+    rmdResult);
+
+  /// set of parameter directions e.g. for an interface-based service method
+  TRttiMethodArgDirections = set of TRttiMethodArgDirection;
+
+  TRttiMethodArg = record
+    /// the argument name, as declared in pascal code
+    ParamName: PShortString;
+    /// the type name, as declared in pascal code
+    TypeName: PShortString;
+    /// the low-level RTTI information of this argument
+    TypeInfo: PRttiInfo;
+    /// how the parameter has been defined (const/var/out/result)
+    Direction: TRttiMethodArgDirection;
+  end;
+  PRttiMethodArg = ^TRttiMethodArg;
+
+  /// store IInvokable method information
+  TRttiMethod = record
+    /// the method name, e.g. 'Add' for ICalculator.Add
+    Name: RawUtf8;
+    /// 0 for the root interface, >0 for inherited interfaces
+    HierarchyLevel: integer;
+    /// the method arguments
+    Args: array of TRttiMethodArg;
+    /// if this method is a function, i.e. expects a result
+    IsFunction: boolean;
+  end;
+  PRttiMethod = ^TRttiMethod;
+
+  /// store IInvokable methods information
+  TRttiInterface = record
+    /// the interface name, e.g. 'ICalculator'
+    Name: RawUtf8;
+    /// the unit where the interface was defined
+    UnitName: RawUtf8;
+    /// the associated GUID of this interface
+    Guid: TGuid;
+    /// the interface methods
+    Methods: array of TRttiMethod;
+  end;
+  PRttiInterface = ^TRttiInterface;
+
+/// retrieve methods information of a given IInvokable
+// - all methods will be added, also from inherited interface definitions
+// - returns the number of methods detected
+function GetRttiInterface(aTypeInfo: PRttiInfo;
+  out aDefinition: TRttiInterface): integer;
+
+/// check if a pre-computed PInterfaceEntry has a direct IOffset information
+function InterfaceEntryIsStandard(Entry: PInterfaceEntry): boolean;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// execute an instance method from its RTTI per-interface information
+// - calling this function with a pre-computed PInterfaceEntry value is faster
+// than calling the TObject.GetInterface() method, especially when the class
+// implements several interfaces, since it avoid a slow GUID lookup
+// - if the interface is retrieved using a getter, will fallback to
+// the regular TObject.GetInterface RTL method
+function GetInterfaceFromEntry(Instance: TObject; Entry: PInterfaceEntry;
+  out Obj): boolean;
+
+/// returns all TGuid implemented by a given class
+// - TObject.GetInterfaceTable is not consistent on Delphi and FPC
+function GetRttiClassGuid(aClass: TClass): PGuidDynArray;
+
+const
+  PSEUDO_RESULT_NAME: string[6] = 'Result';
+  PSEUDO_SELF_NAME:   string[4] = 'Self';
+
+
+
+{ ************* Efficient Dynamic Arrays and Records Process }
+
+/// faster alternative to Finalize(aVariantDynArray)
+// - this function will take account and optimize the release of a dynamic
+// array of custom variant types values
+// - for instance, an array of TDocVariant will be optimized for speed
+procedure VariantDynArrayClear(var Value: TVariantDynArray);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// low-level finalization of a dynamic array of any kind
+// - faster than RTL Finalize() or setting nil, when you know ElemInfo
+// - see also TRttiInfo.Clear if you want to finalize any type
+procedure FastDynArrayClear(Value: PPointer; ElemInfo: PRttiInfo);
+
+/// low-level finalization of all dynamic array items of any kind
+// - as called by FastDynArrayClear(), after dec(RefCnt) reached 0
+procedure FastFinalizeArray(Value: PPointer; ElemTypeInfo: PRttiInfo;
+  Count: integer);
+
+/// clear the managed fields of a record content
+// - won't reset all values to zero, only managed fields - see RecordZero()
+// - caller should ensure the type is indeed a record/object
+// - see also TRttiInfo.Clear if you want to finalize any type
+// - same as RTTI_FINALIZE[rkRecord]()
+function FastRecordClear(Value: pointer; Info: PRttiInfo): PtrInt;
+
+/// efficient finalization of successive record items from a (dynamic) array
+procedure RecordClearSeveral(v: PAnsiChar; info: PRttiInfo; n: integer);
+
+/// efficient finalization of successive RawUtf8 items from a (dynamic) array
+procedure StringClearSeveral(v: PPointer; n: PtrInt);
+
+/// low-level finalization of a dynamic array of RawUtf8
+// - faster than RTL Finalize() or setting nil
+procedure RawUtf8DynArrayClear(var Value: TRawUtf8DynArray);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// check if the TypeInfo() points to an "array of RawUtf8"
+// - e.g. returns true for TypeInfo(TRawUtf8DynArray) or other sub-types
+// defined as "type aNewType = type TRawUtf8DynArray"
+function IsRawUtf8DynArray(Info: PRttiInfo): boolean;
+
+/// initialize a record content
+// - calls FastRecordClear() and FillCharFast() with 0
+// - do nothing if the TypeInfo is not from a record/object
+procedure RecordZero(Dest: pointer; Info: PRttiInfo);
+
+/// copy a record content from source to Dest
+procedure RecordCopy(var Dest; const Source; Info: PRttiInfo);
+  {$ifdef FPC}inline;{$endif}
+
+/// efficiently copy several (dynamic) array items
+// - faster than the RTL CopyArray() function
+procedure CopySeveral(Dest, Source: PByte; SourceCount: PtrInt;
+  ItemInfo: PRttiInfo; ItemSize: PtrInt);
+
+/// low-level initialization of a dynamic array
+// - faster than System.DynArraySetLength() function on a void dynamic array,
+// when the RTTI is known
+// - caller should ensure that Dest is not nil, but Dest^ = nil (i.e. a
+// clear/void dynamic array)
+function DynArrayNew(Dest: PPointer; Count, ItemSize: PtrInt): pointer;
+
+/// low-level size up of a dynamic array
+// - faster than System.DynArraySetLength() function dynamic array with RefCnt=1
+// - caller should ensure that Dest is not nil
+// - DataBytes is expected to be Count * ItemSize
+function DynArrayGrow(Dest: PPointer; Count, ItemSize: PtrInt): PAnsiChar;
+
+/// create a dynamic array from another one
+// - same as RTTI_MANAGEDCOPY[rkDynArray] but with an optional external source count
+procedure DynArrayCopy(Dest, Source: PPointer; Info: PRttiInfo;
+  SourceExtCount: PInteger = nil);
+
+/// same as Value := copy(Value) but faster and with no temporary variable
+procedure DynArrayEnsureUnique(Value: PPointer; Info: PRttiInfo);
+
+/// same as Value := copy(Value) but faster and with no temporary variable
+procedure EnsureUnique(var Value: TIntegerDynArray); overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// same as Value := copy(Value) but faster and with no temporary variable
+procedure EnsureUnique(var Value: TRawUtf8DynArray); overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// same as Value := copy(Value) but faster and with no temporary variable
+procedure EnsureUnique(var Value: TVariantDynArray); overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+
+{ ************* Managed Types Finalization, Random or Copy }
+
+type
+  /// internal function handler for finalizing a managed type value
+  // - i.e. the kind of functions called via RTTI_FINALIZE[] lookup table
+  // - as used by TRttiInfo.Clear() inlined method
+  TRttiFinalizer = function(Data: pointer; Info: PRttiInfo): PtrInt;
+
+  /// the type of RTTI_FINALIZE[] efficient lookup table
+  TRttiFinalizers = array[TRttiKind] of TRttiFinalizer;
+  PRttiFinalizers = ^TRttiFinalizers;
+
+  /// internal function handler for copying a managed type value
+  // - i.e. the kind of functions called via RTTI_MANAGEDCOPY[] lookup table
+  TRttiCopier = function(Dest, Source: pointer; Info: PRttiInfo): PtrInt;
+
+  /// the type of RTTI_MANAGEDCOPY[] efficient lookup table
+  TRttiCopiers = array[TRttiKind] of TRttiCopier;
+  PRttiCopiers = ^TRttiCopiers;
+
+  /// internal function handler for copying a class instance
+  // - use TRttiCustom.Props.CopyProperties but may be overriden e.g. for TOrm
+  TRttiClassCopier = procedure(Dest, Source: TObject);
+
+
+var
+  /// lookup table of finalization functions for managed types
+  // - as used by TRttiInfo.Clear() inlined method
+  // - RTTI_FINALIZE[...]=nil for unmanaged types (e.g. rkOrdinalTypes)
+  RTTI_FINALIZE: TRttiFinalizers;
+
+  /// lookup table of copy function for managed types
+  // - as used by TRttiInfo.Copy() inlined method
+  // - RTTI_MANAGEDCOPY[...]=nil for unmanaged types (e.g. rkOrdinalTypes)
+  RTTI_MANAGEDCOPY: TRttiCopiers;
+
+/// fill all sensitive fields of this class or record with zeros
+// - RawByteString/TBytes with refcount=1 will be zeroed before freed
+procedure FillZeroRtti(Info: PRttiInfo; var Value);
+
+
+
+{ ************** RTTI Value Types used for JSON Parsing }
+
+type
+  /// the kind of variables handled by our RTTI/JSON parser
+  // - the last item should be ptCustom, for non simple types
+  // - ptOrm is recognized from TID, T*ID, TRecordReference,
+  // TRecordReferenceToBeDeleted and TRecordVersion type names
+  // - ptTimeLog is recognized from TTimeLog, TCreateTime and TModTime
+  // - other types (not ptComplexTypes) are recognized by their genuine type name
+  // - ptUnicodeString is defined even if not available prior to Delphi 2009
+  // - replace deprecated TJsonCustomParserRTTIType type from old mORMot 1.18
+  // - TDynArrayKind is now an alias to this genuine enumerate
+  TRttiParserType = (
+    ptNone,
+    ptArray,
+    ptBoolean,
+    ptByte,
+    ptCardinal,
+    ptCurrency,
+    ptDouble,
+    ptExtended,
+    ptInt64,
+    ptInteger,
+    ptQWord,
+    ptRawByteString,
+    ptRawJson,
+    ptRawUtf8,
+    ptRecord,
+    ptSingle,
+    ptString,
+    ptSynUnicode,
+    ptDateTime,
+    ptDateTimeMS,
+    ptGuid,
+    ptHash128,
+    ptHash256,
+    ptHash512,
+    ptOrm,
+    ptTimeLog,
+    ptUnicodeString,
+    ptUnixTime,
+    ptUnixMSTime,
+    ptVariant,
+    ptWideString,
+    ptWinAnsi,
+    ptWord,
+    ptEnumeration,
+    ptSet,
+    ptClass,
+    ptDynArray,
+    ptInterface,
+    ptPUtf8Char,
+    ptCustom);
+
+  /// the complex kind of variables for ptTimeLog and ptOrm TRttiParserType
+  TRttiParserComplexType = (
+    pctNone,
+    pctTimeLog,
+    pctCreateTime,
+    pctModTime,
+    pctID,
+    pctSpecificClassID,
+    pctRecordReference,
+    pctRecordReferenceToBeDeleted,
+    pctRecordVersion);
+
+  PRttiParserType = ^TRttiParserType;
+  TRttiParserTypes = set of TRttiParserType;
+  PRttiParserComplexType = ^TRttiParserComplexType;
+  TRttiParserComplexTypes = set of TRttiParserComplexType;
+
+const
+  /// map a PtrInt type to the TRttiParserType set
+  ptPtrInt  = {$ifdef CPU64} ptInt64 {$else} ptInteger {$endif};
+
+  /// map a PtrUInt type to the TRttiParserType set
+  ptPtrUInt = {$ifdef CPU64} ptQWord {$else} ptCardinal {$endif};
+
+  /// which TRttiParserType are not simple types
+  // - ptTimeLog and ptOrm are complex, since more than one TypeInfo() may
+  // map to their TRttiParserType - see also TRttiParserComplexType
+  ptComplexTypes =
+    [ptArray,
+     ptRecord,
+     ptCustom,
+     ptTimeLog,
+     ptOrm,
+     ptDynArray,
+     ptEnumeration,
+     ptSet,
+     ptClass,
+     ptInterface];
+
+  /// which TRttiParserType types don't need memory management
+  ptUnmanagedTypes =
+    [ptBoolean..ptQWord,
+     ptSingle,
+     ptDateTime..ptTimeLog,
+     ptUnixTime,
+     ptUnixMSTime,
+     ptWord..ptClass];
+
+  /// which TRttiParserType types are (usually) serialized as JSON "text"
+  // - actual serialization may depend e.g. on TTextWriterWriteObjectOptions
+  ptStringTypes =
+    [ptRawByteString .. ptRawUtf8,
+     ptString .. ptHash512,
+     ptTimeLog,
+     ptUnicodeString,
+     ptWideString,
+     ptWinAnsi,
+     ptPUtf8Char];
+
+  /// which TRttiParserType types could be serialized as multi-line JSON "text"
+  // - e.g. plain RawUtf8 which may include \n line feeds but not RawByteString,
+  // TTimeLog or THash128, which never include line breaks within their "value"
+  ptMultiLineStringTypes =
+    [ptRawUtf8,
+     ptString,
+     ptSynUnicode,
+     ptUnicodeString,
+     ptWideString,
+     ptWinAnsi];
+
+var
+  /// simple lookup to the plain RTTI type of most simple managed types
+  // - nil for unmanaged types (e.g. rkOrdinals) or for more complex types
+  // requering additional PRttiInfo (rkRecord, rkDynArray, rkArray...)
+  // - you can use PT_INFO[] for types with no RTTI before Delphi 2010, for
+  // instance PT_INFO[ptGuid], PT_INFO[ptHash128], PT_INFO[ptHash256] and
+  // PT_INFO[ptHash512] since oldest compilers refuse to compile TypeInfo(TGuid),
+  // TypeInfo(THash128), TypeInfo(THash256) and TypeInfo(THash512)
+  PT_INFO: array[TRttiParserType] of PRttiInfo;
+
+  /// simple lookup to the plain RTTI type of most simple managed types
+  // - nil if the complex type is not known
+  // - mormot.orm.base may set the exact TypeInfo(TRecordReference) value - this
+  // unit set plain TypeInfo(QWord) which is enough for JSON Serialization
+  PTC_INFO: array[TRttiParserComplexType] of PRttiInfo;
+
+const
+  /// simple lookup to the TRttiParserType of a complex type
+  PTC_PT: array[TRttiParserComplexType] of TRttiParserType = (
+    ptNone,      // pctNone
+    ptTimeLog,   // pctTimeLog
+    ptTimeLog,   // pctCreateTime
+    ptTimeLog,   // pctModTime
+    ptOrm,       // pctID
+    ptNone,      // pctSpecificClassID
+    ptOrm,       // pctRecordReference
+    ptOrm,       // pctRecordReferenceToBeDeleted
+    ptOrm );     // pctRecordVersion
+
+  /// simple lookup to the size in bytes of TRttiParserType values
+  PT_SIZE: array[TRttiParserType] of byte = (
+    0,                //  ptNone
+    0,                //  ptArray
+    1,                //  ptBoolean
+    1,                //  ptByte
+    4,                //  ptCardinal
+    8,                //  ptCurrency
+    8,                //  ptDouble
+    8,                //  ptExtended
+    8,                //  ptInt64
+    4,                //  ptInteger
+    8,                //  ptQWord
+    SizeOf(pointer),  //  ptRawByteString
+    SizeOf(pointer),  //  ptRawJson
+    SizeOf(pointer),  //  ptRawUtf8
+    0,                //  ptRecord
+    4,                //  ptSingle
+    SizeOf(pointer),  //  ptString
+    SizeOf(pointer),  //  ptSynUnicode
+    8,                //  ptDateTime
+    8,                //  ptDateTimeMS
+    16,               //  ptGuid
+    16,               //  ptHash128
+    32,               //  ptHash256
+    64,               //  ptHash512
+    8,                //  ptOrm
+    8,                //  ptTimeLog
+    SizeOf(pointer),  //  ptUnicodeString
+    8,                //  ptUnixTime
+    8,                //  ptUnixMSTime
+    SizeOf(variant),  //  ptVariant
+    SizeOf(pointer),  //  ptWideString
+    SizeOf(pointer),  //  ptWinAnsi
+    2,                //  ptWord
+    0,                //  ptEnumeration
+    0,                //  ptSet
+    SizeOf(pointer),  //  ptClass
+    SizeOf(pointer),  //  ptDynArray
+    SizeOf(pointer),  //  ptInterface
+    SizeOf(pointer),  //  ptPUtf8Char
+    0 );              //  ptCustom
+
+  /// type definition name lookup to the TRttiParserType values
+  // - ptComplexTypes types should see PTC_NAME[] constant
+  PT_NAME: array[TRttiParserType] of RawUtf8 = (
+    '',               //  ptNone
+    '',               //  ptArray
+    'boolean',        //  ptBoolean
+    'byte',           //  ptByte
+    'cardinal',       //  ptCardinal
+    'currency',       //  ptCurrency
+    'double',         //  ptDouble
+    'extended',       //  ptExtended
+    'Int64',          //  ptInt64
+    'integer',        //  ptInteger
+    'QWord',          //  ptQWord
+    'RawByteString',  //  ptRawByteString
+    'RawJson',        //  ptRawJson
+    'RawUtf8',        //  ptRawUtf8
+    '',               //  ptRecord
+    'single',         //  ptSingle
+    'string',         //  ptString
+    'SynUnicode',     //  ptSynUnicode
+    'TDateTime',      //  ptDateTime
+    'TDateTimeMS',    //  ptDateTimeMS
+    'TGuid',          //  ptGuid
+    'THash128',       //  ptHash128
+    'THash256',       //  ptHash256
+    'THash512',       //  ptHash512
+    '',               //  ptOrm
+    '',               //  ptTimeLog
+    'UnicodeString',  //  ptUnicodeString
+    'TUnixTime',      //  ptUnixTime
+    'TUnixMSTime',    //  ptUnixMSTime
+    'variant',        //  ptVariant
+    'WideString',     //  ptWideString
+    'WinAnsi',        //  ptWinAnsi
+    'word',           //  ptWord
+    '',               //  ptEnumeration
+    '',               //  ptSet
+    '',               //  ptClass
+    '',               //  ptDynArray
+    '',               //  ptInterface
+    'PUtf8Char',      //  ptPUtf8Char
+    '');              //  ptCustom
+
+  /// type definition name lookup to the TRttiParserComplexType values
+  // - for ptComplexTypes types, with PT_NAME[]=''
+  // - ptcSpecificClassID returns '' since T....ID types are variable
+  PTC_NAME: array[TRttiParserComplexType] of RawUtf8 = (
+    '',                            // pctNone
+    'TTimeLog',                    // pctTimeLog
+    'TCreateTime',                 // pctCreateTime
+    'TModTime',                    // pctModTime
+    'TID',                         // pctID
+    '',                            // pctSpecificClassID
+    'TRecordReference',            // pctRecordReference
+    'TRecordReferenceToBeDeleted', // pctRecordReferenceToBeDeleted
+    'TRecordVersion');             // pctRecordVersion
+
+/// retrieve the text name of one TRttiParserType enumerate
+function ToText(t: TRttiParserType): PShortString; overload;
+
+/// retrieve the TypeInfo() from PT_INFO[] PTC_INFO[] constant arrays
+function ParserTypeToTypeInfo(pt: TRttiParserType;
+  pct: TRttiParserComplexType): PRttiInfo;
+
+/// recognize most simple types and return their known dynamic array RTTI
+// - returns nil if we don't know any dynamic array for this type
+// - ExpectExactElemInfo=true ensure that result's ArrayRtti.Info = ElemInfo
+// - currently not called: IList and IKeyValue just use TypeInfo(T)
+function TypeInfoToDynArrayTypeInfo(ElemInfo: PRttiInfo;
+  ExpectExactElemInfo: boolean; ParserType: PRttiParserType = nil): PRttiInfo;
+
+
+
+{ ************** RTTI-based Registration for Custom JSON Parsing }
+
+const
+  /// TRttiCustomList stores its TypeInfo() by Kind + PRttiInfo/Name
+  // - optimized "hash table of the poor" (tm) for FindType() and Find(Name)
+  // - should be a bit mask (i.e. power of two minus 1)
+  RTTIHASH_MAX = {$ifdef NOPATCHVMT} 63 {$else} 31 {$endif};
+
+type
+  TRttiCustom = class;
+
+  PRttiCustomProp = ^TRttiCustomProp;
+  PPRttiCustomProp = ^PRttiCustomProp;
+
+  /// variant-like value as returned by TRttiCustomProp.GetValueDirect and
+  // GetValueGetter methods
+  // - simple values (integers, floats, strings or variant) are set into Data
+  // - rkEnumeration, rkSet, rkDynArray, rkClass, rkInterface, rkRecord and
+  // rkObject are stored as varAny/PropValue pointer to the field value (for
+  // GetValueDirect) or Instance (for GetValueGetter if PropValueIsInstance=true),
+  // and Prop to the corresponding property RTTI
+  // - will be properly handled by TJsonWriter.AddVariant/AddRttiVarData
+  // - can be casted as a variant value, but contains RTTI and clear flag:
+  // ! if rvd.NeedsClear then VarClearProc(rvd.Data);
+  TRttiVarData = packed record
+    case integer of
+    varUnknown: (
+      VType: cardinal);    // maps DataType + NeedsClear + PropValueIsInstance
+    varVariant: (
+      Data: TVarData);
+    varAny: (
+      DataType: word;      // matches TVarData.VType
+      NeedsClear: boolean;
+      PropValueIsInstance: boolean;
+      // Assert(@PropValue=@VAny) is done in initialization section below
+      {$ifdef CPU32}
+      Prop: PRttiCustomProp;
+      PropValue: pointer; // TObject if PropValueIsInstance=true, or field addr
+      {$else}
+      Padding4: cardinal;
+      PropValue: pointer; // TObject if PropValueIsInstance=true, or field addr
+      Prop: PRttiCustomProp;
+      {$endif CPU32});
+  end;
+  PRttiVarData = ^TRttiVarData;
+
+  /// define specific behavior for a given TypeInfo/PRttIinfo
+  // - rcfIsManaged is set if a value of this type expects finalization
+  // - rcfObjArray is for T*ObjArray dynamic arrays
+  // - rcfBinary is for hexadecimal serialization of integers
+  // - rcfJsonString when is to be serialized as text and properly JSON-escaped
+  // (ptStringTypes or rcfBinary, but excluding ptRawJson)
+  // - rcfWithoutRtti is set if was created purely by text, and uses fake RTTI
+  // - rcfSpi identifies types containing Sensitive Personal Information
+  // (e.g. a bank card number or a plain password) which should be hidden
+  // - rcfHookWrite, rcfHookWriteProperty, rcfHookRead, rcfHookReadProperty for
+  // TObjectWithCustomCreate kind of class, to customize JSON serialization
+  // calling the set of TObjectWithCustomCreate protected virtual methods -
+  // disabled by default not to slow down the serialization process
+  // - rcfHasNestedProperties is set e.g. for rkClass or rcfWithoutRtti records,
+  // rcfHasNestedManagedProperties if any of the property/field is rcfIsManaged
+  // - rcfHasOffsetSetJsonLoadProperties is set if all nested properties can be
+  // directly written, i.e. have OffsetSet >= 0 and Assigned(JsonLoad)
+  // - rcfArrayItemManaged maps rcfIsManaged flag in ArrayRtti.Flags
+  // - rcfReadIgnoreUnknownFields will let JSON unserialization ignore unknown
+  // fields for this class/record
+  // - rcfAutoCreateFields is defined when AutoCreateFields() has been called
+  // - rcfDisableStored is set for TOrm, where "stored AS_UNIQUE" does not mean
+  // "not stored" for serialization but "UNIQUE SQL"
+  // - rcfClassMayBeID is set e.g. for TOrm classes, which may be storing
+  // not instances but IDs in published properties PtrInt
+  TRttiCustomFlag = (
+    rcfIsManaged,
+    rcfObjArray,
+    rcfBinary,
+    rcfJsonString,
+    rcfWithoutRtti,
+    rcfSpi,
+    rcfHookWrite,
+    rcfHookWriteProperty,
+    rcfHookRead,
+    rcfHookReadProperty,
+    rcfHasNestedProperties,
+    rcfHasNestedManagedProperties,
+    rcfHasOffsetSetJsonLoadProperties,
+    rcfArrayItemManaged,
+    rcfReadIgnoreUnknownFields,
+    rcfAutoCreateFields,
+    rcfDisableStored,
+    rcfClassMayBeID);
+
+  /// define specific behaviors for a given TypeInfo/PRttIinfo
+  // - as stored in TRttiCustom.Flags
+  TRttiCustomFlags = set of TRttiCustomFlag;
+
+  /// store information about one property/field of a given TypeInfo/PRttIinfo
+  // - used by both rkClass for published properties, and rkRecord/rkObject
+  // for nested fields
+  {$ifdef USERECORDWITHMETHODS}
+  TRttiCustomProp = record
+  {$else}
+  TRttiCustomProp = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    fOrigName: RawUtf8; // as set by InternalAdd()
+    function InitFrom(RttiProp: PRttiProp): PtrInt;
+    function ValueIsVoidGetter(Data: pointer): boolean;
+    procedure GetValueDirect(Data: PByte; out RVD: TRttiVarData);
+    procedure GetValueGetter(Instance: TObject; out RVD: TRttiVarData);
+    function CompareValueComplex(Data, Other: pointer;
+      OtherRtti: PRttiCustomProp; CaseInsensitive: boolean): integer;
+  public
+    /// contains standard TypeInfo/PRttiInfo of this field/property
+    // - for instance, Value.Size contains its memory size in bytes
+    Value: TRttiCustom;
+    /// read field/property offset in the record/class instance memory
+    // - equals -1 if Prop has a getter
+    OffsetGet: PtrInt;
+    /// write field/property offset in the record/class instance memory
+    // - equals -1 if Prop has a setter
+    OffsetSet: PtrInt;
+    /// contains Prop^.Name or a customized field/property name
+    // - equals '' if Props.NameChange() was set to New='', meaning this field
+    // should not be part of the serialized JSON object
+    Name: RawUtf8;
+    /// store standard RTTI of this published property
+    // - equals nil for rkRecord/rkObject nested field
+    Prop: PRttiProp;
+    /// equals NO_DEFAULT or the default integer value of this property
+    OrdinalDefault: integer;
+    /// reflect the "stored" property attribute as defined in the source
+    Stored: TRttiPropStored;
+    /// case-insensitive compare the supplied name/len with the Name property
+    function NameMatch(P: PUtf8Char; Len: PtrInt): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// very fast retrieval of any field value into a TVarData-like mapping
+    // - works if Prop is defined or not, calling any getter method if needed
+    // - complex TRttiVarData with varAny pointer will be properly handled by
+    // TJsonWriter.AddVariant/AddRttiVarData (e.g. rkEnumeration or rkDynArray)
+    // - rvd can be casted to a variant, but contains RTTI Info and clear flag:
+    // ! if rvd.NeedsClear then VarClearProc(rvd.Data);
+    procedure GetValue(Data: pointer; out RVD: TRttiVarData);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// set a field value to a given TVarData-like content
+    // - optionally check and apply RVD.NeedsClear flag (leave it as true if
+    // RVD comes from GetValue)
+    // - not implemented for Prop = nil (i.e. rkRecord/rkObject nested field)
+    procedure SetValue(Data: pointer; var RVD: TRttiVarData;
+      andclear: boolean = true);
+    /// retrieve any field vlaue as a variant instance
+    // - will generate a stand-alone variant value, not an internal TRttiVarData
+    // - complex values can be returned as TDocVariant after JSON conversion,
+    // using e.g. @JSON_[mFastFloat] as optional Options parameter
+    procedure GetValueVariant(Data: pointer; out Dest: TVarData;
+      Options: pointer{PDocVariantOptions} = nil);
+    /// set a field value from its UTF-8 text
+    // - will convert the Text into proper ordinal or float if needed
+    // - also implemented for Prop = nil (i.e. rkRecord/rkObject nested field)
+    // - use Prop^.SetValueText() if you want to support enumerates and sets
+    function SetValueText(Data: pointer; const Text: RawUtf8): boolean;
+    /// check if the Value equals the default property set in source code
+    // - caller should have checked that PropDefault <> NO_DEFAULT
+    function ValueIsDefault(Data: pointer): boolean;
+    /// check if the Value is void (0 / '' / null)
+    // - less restrictive function than VarIsVoid() from mormot.core.variants
+    function ValueIsVoid(Data: pointer): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// compare two properties values with proper getter method call
+    // - is likely to call Value.ValueCompare() which requires mormot.core.json
+    function CompareValue(Data, Other: pointer; const OtherRtti: TRttiCustomProp;
+      CaseInsensitive: boolean): integer;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append the field value as JSON with proper getter method call
+    // - wrap GetValue() + AddVariant() over a temp TRttiVarData
+    procedure AddValueJson(W: TTextWriter; Data: pointer;
+      Options: TTextWriterWriteObjectOptions; K: TTextWriterKind = twNone);
+    /// a wrapper calling AddValueJson()
+    procedure GetValueJson(Data: pointer; out Result: RawUtf8);
+  end;
+
+  /// store information about the properties/fields of a given TypeInfo/PRttiInfo
+  TRttiCustomPropDynArray = array of TRttiCustomProp;
+
+  PRttiCustomPropDynArray = array of PRttiCustomProp;
+
+  /// store information about all properties/fields of a given TypeInfo/PRttIinfo
+  // - includes parent properties when filled by AddFromClass(IncludeParents=true)
+  {$ifdef USERECORDWITHMETHODS}
+  TRttiCustomProps = record
+  {$else}
+  TRttiCustomProps = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// one List[] item per property/field
+    List: TRttiCustomPropDynArray;
+    /// how many properties/fields are in List[]
+    Count: integer;
+    /// how many properties/fields with Name <> '' are in List[]
+    CountNonVoid: integer;
+    /// total size, in bytes, of all properties/fields
+    // - equals the sum of List[].Value.Size
+    Size: integer;
+    /// List[NotInheritedIndex]..List[Count-1] store the last level of properties
+    NotInheritedIndex: integer;
+    /// contains List[].Name as a JSON array including a trailing ,
+    // - as used by _JS_DynArray() for efficient twoNonExpandedArrays generation
+    NamesAsJsonArray: RawUtf8;
+    /// points to List[] items which are managed
+    Managed: PRttiCustomPropDynArray;
+    /// locate a property/field by name
+    // - just redirect to FindCustomProp() low-level function
+    function Find(const PropName: RawUtf8): PRttiCustomProp; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// locate a property/field by name
+    // - just redirect to FindCustomProp() low-level function
+    function Find(PropName: PUtf8Char; PropNameLen: PtrInt): PRttiCustomProp; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// locate a property/field index by name
+    function FindIndex(PropName: PUtf8Char; PropNameLen: PtrInt): PtrInt;
+    /// customize a property/field name
+    // - New is expected to be only plain pascal identifier, i.e.
+    // A-Z a-z 0-9 and _ characters, up to 63 in length
+    // - if New equals '', this published property will be excluded from
+    // the JSON serialized object
+    function NameChange(const Old, New: RawUtf8): PRttiCustomProp;
+    /// customize property/field name, specified as old/new pairs
+    // - will first restore all field names from RTTI, then each Old[] field
+    // name will be replaced by the corresponding New[] name
+    // - so setting both Old=New=[] just set back the default names from RTTI
+    // - New[] is expected to be only plain pascal identifier, i.e.
+    // A-Z a-z 0-9 and _ characters, up to 63 in length
+    // - if any New[] equals '', this published property will be excluded from
+    // the JSON serialized object
+    // - Rtti.ByClass[TMyClass].Props.NameChanges() replaces deprecated
+    // TJsonSerializer.RegisterCustomSerializerFieldNames(TMyClass, ...)
+    procedure NameChanges(const Old, New: array of RawUtf8);
+    /// reset all properties
+    procedure InternalClear;
+    /// manual adding of a property/field definition
+    // - append as last field, unless AddFirst is set to true
+    procedure InternalAdd(Info: PRttiInfo; Offset: PtrInt; const PropName: RawUtf8;
+      AddFirst: boolean = false);
+    /// register the published properties of a given class
+    // - is called recursively if IncludeParents is true
+    procedure InternalAddFromClass(ClassInfo: PRttiInfo; IncludeParents: boolean);
+    /// prepare List[result].Name from TRttiCustom.SetPropsFromText
+    function FromTextPrepare(const PropName: RawUtf8): integer;
+    /// register the properties specified from extended RTTI (Delphi 2010+ only)
+    // - do nothing on FPC or Delphi 2009 and older
+    procedure SetFromRecordExtendedRtti(RecordInfo: PRttiInfo);
+    /// called once List[] and Size have been defined
+    // - compute the Managed[] internal list and return the matching flags
+    function AdjustAfterAdded: TRttiCustomFlags;
+    /// retrieve all List[] items as text
+    procedure AsText(out Result: RawUtf8; IncludePropType: boolean;
+      const Prefix, Suffix: RawUtf8);
+    /// finalize and fill with zero all properties of this class instance
+    // - it will individually fill the properties, not the whole memory
+    // as TRttiCustom.FinalizeAndClear would on a record
+    procedure FinalizeAndClearPublishedProperties(Instance: TObject);
+    /// finalize the managed properties of this instance
+    // - called e.g. when no RTTI is available, i.e. text serialization
+    procedure FinalizeManaged(Data: PAnsiChar);
+    /// copy the fields of a rkRecordTypes instance
+    // - called e.g. when no RTTI is available, i.e. text serialization
+    // - will move() all bytes between managed fields
+    procedure CopyRecord(Dest, Source: PAnsiChar);
+    /// copy the properties of a rkClass instance
+    // - called e.g. when no RTTI is available, i.e. text serialization
+    // - will copy all published properties one-by-one
+    procedure CopyProperties(Dest, Source: PAnsiChar);
+  end;
+
+  PRttiCustomProps = ^TRttiCustomProps;
+
+  /// used internally for fast allocation of a rkClass/rkInterface instance
+  // - member is properly initialized by TRttiJson from mormot.core.json.pas
+  TRttiCustomNewInstance = function(Rtti: TRttiCustom): pointer;
+
+  /// internal function handler for filling a value with some randomness
+  TRttiCustomRandom = procedure(Data: pointer; Rtti: TRttiCustom);
+
+  /// used internally by our RTTI text definition
+  TRttiCustomFromTextExpectedEnd = (
+    eeNothing,
+    eeSquare,
+    eeCurly,
+    eeEndKeyWord);
+
+  /// the recognized raw RTL classes as identified in TRttiCustom.ValueRtlClass
+  TRttiValueClass = (
+    vcNone,
+    vcCollection,
+    vcStrings,
+    vcObjectList,
+    vcList,
+    vcSynList,
+    vcRawUtf8List,
+    vcESynException,
+    vcException,
+    vcObjectWithID);
+
+
+  /// allow to customize the process of a given TypeInfo/PRttiInfo
+  // - a global list of TRttiCustom instances mapping TypeInfo() is maintained
+  // in Rtti: TRttiCustomList
+  // - never instantiate this class directly, but call RttiCustom methods
+  TRttiCustom = class
+  protected
+    fCache: TRttiCache;
+    fParser: TRttiParserType;
+    fParserComplex: TRttiParserComplexType;
+    fValueRtlClass: TRttiValueClass;
+    fArrayFirstField: TRttiParserType;
+    fFlags: TRttiCustomFlags;
+    fPrivateSlot: pointer;
+    fArrayRtti: TRttiCustom;
+    fFinalize: TRttiFinalizer;
+    fCopy: TRttiCopier;
+    fName: RawUtf8;
+    fProps: TRttiCustomProps;
+    fOwnedRtti: array of TRttiCustom; // for SetPropsFromText(NoRegister=true)
+    fSetRandom: TRttiCustomRandom;
+    fPrivateSlots: TObjectDynArray;
+    fPrivateSlotsSafe: TLightLock;
+    // used by mormot.core.json.pas
+    fBinarySize: integer;
+    fJsonLoad: pointer; // contains a TRttiJsonLoad - used if fJsonReader=nil
+    fJsonSave: pointer; // contains a TRttiJsonSave - used if fJsonWriter=nil
+    fJsonReader, fJsonWriter: TMethod; // TOnRttiJsonRead/TOnRttiJsonWrite
+    fNewInstance: TRttiCustomNewInstance; // mormot.core.json implemented
+    fAutoCreateInstances, // some lists made by RegisterAutoCreateFieldsClass
+    fAutoDestroyClasses,
+    fAutoCreateObjArrays,
+    fAutoResolveInterfaces: PRttiCustomPropDynArray;
+    // used by NoRttiSetAndRegister()
+    fNoRttiInfo: TByteDynArray;
+    // customize class process
+    fValueClass: TClass;
+    fObjArrayClass: TClass;
+    fCollectionItem: TCollectionItemClass;
+    fCollectionItemRtti: TRttiCustom;
+    fCopyObject: TRttiClassCopier;
+    procedure SetValueClass(aClass: TClass; aInfo: PRttiInfo); virtual;
+    // for TRttiCustomList.RegisterObjArray/RegisterBinaryType/RegisterFromText
+    function SetObjArray(Item: TClass): TRttiCustom;
+    function SetBinaryType(BinarySize: integer): TRttiCustom;
+    procedure SetPropsFromText(var P: PUtf8Char;
+      ExpectedEnd: TRttiCustomFromTextExpectedEnd; NoRegister: boolean);
+    // initialize from fProps, with no associated RTTI - and calls DoRegister()
+    // - will create a "fake" rkRecord/rkDynArray PRttiInfo (TypeName may be '')
+    procedure NoRttiSetAndRegister(ParserType: TRttiParserType;
+      const TypeName: RawUtf8; DynArrayElemType: TRttiCustom = nil;
+      NoRegister: boolean = false);
+    // called by ValueFinalize() for dynamic array defined from text
+    procedure NoRttiArrayFinalize(Data: PAnsiChar);
+    /// initialize this Value process for Parser and Parser Complex kinds
+    // - this default method will set Name and Flags according to Props[]
+    // - overriden in mormot.core.json for proper JSON process setup
+    // - returns self to allow cascaded calls as a fluent interface
+    function SetParserType(aParser: TRttiParserType;
+      aParserComplex: TRttiParserComplexType): TRttiCustom; virtual;
+  public
+    /// initialize the customizer class from known RTTI
+    // - is called just after Create
+    procedure FromRtti(aInfo: PRttiInfo); virtual;
+    /// initialize abstract custom serialization for a given record
+    // - not registered in the main TRttiCustomList: caller should free it
+    // - in practice, is used only by test.core.data.pas regression tests
+    constructor CreateFromText(const RttiDefinition: RawUtf8);
+    /// finalize this instance
+    destructor Destroy; override;
+    /// efficiently finalize a stored value of this type
+    // - if rcfObjArray is defined in Flags, will release all nested TObject
+    procedure ValueFinalize(Data: pointer);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// efficiently finalize a stored value of this type, and fill it with zeros
+    // - if rcfObjArray is defined in Flags, will release all nested TObject
+    procedure ValueFinalizeAndClear(Data: pointer);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// efficiently copy of a stored value of this type
+    // - same behavior as Dest := Source for all types
+    procedure ValueCopy(Dest, Source: pointer);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// return TRUE if the Value is 0 / nil / '' / null
+    // - less restrictive function than VarIsVoid() from mormot.core.variants
+    function ValueIsVoid(Data: PAnsiChar): boolean;
+     // {$ifdef HASINLINE}inline;{$endif}
+    /// compare two stored values of this type
+    // - not implemented in this class (raise an ERttiException)
+    // but in TRttiJson, so that it will use mormot.core.data comparison
+    function ValueCompare(Data, Other: pointer;
+      CaseInsensitive: boolean): integer; virtual;
+    /// fill a variant with a stored value of this type
+    // - not implemented in this class (raise an ERttiException)
+    // but in TRttiJson, so that it will use mormot.core.variants process
+    // - complex values can be returned as TDocVariant after JSON conversion,
+    // using e.g. @JSON_[mFast] as optional Options parameter
+    // - returns the size of the Data in bytes, i.e. Cache.ItemSize
+    function ValueToVariant(Data: pointer; out Dest: TVarData;
+      Options: pointer{PDocVariantOptions} = nil): PtrInt; virtual;
+    /// fill a value from random - including strings and nested types
+    procedure ValueRandom(Data: pointer);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// TOnDynArrayHashOne callback used as fallback for unsupported items
+    // - here DefaultHasher() is always used over Size bytes
+    function ValueFullHash(const Elem): cardinal;
+    /// TOnDynArraySortCompare callback used as fallback for unsupported items
+    // - simple per-byte comparison over Size bytes
+    function ValueFullCompare(const A, B): integer;
+    /// how many iterations could be done one a given value
+    // - returns -1 if the value is not iterable, or length(DynArray) or
+    // TRawUtf8List.Count or TList.Count or TSynList.Count
+    // - implemented in TRttiJson for proper knowledge of TSynList/TRawUtf8List
+    function ValueIterateCount(Data: pointer): integer; virtual;
+    /// iterate over one sub-item of a given value
+    // - returns nil if the value is not iterable or Index is out of range
+    // - returns a pointer to the value, rkClass/rkLString kinds being already
+    // resolved (as the TList/TSynList/TRawUtf8List items are returned),
+    // so you can directly trans-type the result to TObject() or RawUtf8()
+    // - ResultRtti holds the type of the resolved result pointer
+    // - note that TStrings values are not supported, because they require a
+    // temporary string variable for their getter method
+    // - implemented in TRttiJson for proper knowledge of TSynList/TRawUtf8List
+    function ValueIterate(Data: pointer; Index: PtrUInt;
+      out ResultRtti: TRttiCustom): pointer; virtual;
+    /// lookup a value by a path name e.g. 'one.two.three' nested values
+    // - for a record/class, will search for a property name
+    // - for a TDocVariant/TBsonVariant, calls TSynInvokeableVariantType.IntGet
+    // - for an enumeration or set, will return true/false about the enum name
+    // - for a string, Data^ will be compared to the name
+    // - implemented in TRttiJson for proper knowledge of our variants
+    function ValueByPath(var Data: pointer; Path: PUtf8Char; var Temp: TVarData;
+      PathDelim: AnsiChar = '.'): TRttiCustom; virtual;
+    /// set a property value from a text value
+    // - handle all kind of fields, e.g. converting from text into ordinal or floats
+    function ValueSetText(Data: pointer; const Text: RawUtf8): boolean;
+    /// create a new TObject instance of this rkClass
+    // - not implemented here (raise an ERttiException) but in TRttiJson,
+    // so that mormot.core.rtti has no dependency to TSynPersistent and such
+    function ClassNewInstance: pointer;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// allow low-level customization of the fClassNewInstance pointer
+    procedure SetClassNewInstance(FactoryMethod: TRttiCustomNewInstance);
+    /// check if this type has ClassNewInstance information
+    function HasClassNewInstance: boolean;
+    /// reset all stored Props[] and associated flags
+    procedure PropsClear;
+    /// recursively search for 'one.two.three' nested properties
+    // - returns nil if not found
+    // - returns the property information and let Data point to its associated
+    // rkClass or rkRecord/rkObject owner
+    function PropFindByPath(var Data: pointer; FullName: PUtf8Char;
+      PathDelim: AnsiChar = '.'): PRttiCustomProp;
+    /// register once an instance of a given class per RTTI
+    // - thread-safe returns aObject, or an existing object (freeing aObject)
+    // - just like PrivateSlot property, but for as many class as needed
+    function SetPrivateSlot(aObject: TObject): pointer;
+    /// retrieve an instance of a given class per RTTI
+    // - previously registered by SetPrivateSlot
+    function GetPrivateSlot(aClass: TClass): pointer;
+    /// create a fake TRttiCustom clone with an overloaded ArrayRtti/ObjArrayClass
+    function ComputeFakeObjArrayRtti(aItemClass: TClass): TBytes;
+    /// low-level RTTI kind, taken from Rtti property
+    property Kind: TRttiKind
+      read fCache.Kind;
+    /// direct access to the low-level RTTI TypeInfo() pointer, from Rtti property
+    property Info: PRttiInfo
+      read fCache.Info;
+    /// the known type name
+    // - may be an hexadecimal value of self, if rcfWithoutRtti is in Flags
+    property Name: RawUtf8
+      read fName;
+    /// direct access to the low-level size in bytes used to store a value
+    // of this type, as taken from Rtti property
+    // - warning: for rkArray/rkDynArray, equals SizeOf(pointer), not the item
+    // size, which is hold in Cache.ItemSize
+    property Size: integer
+      read fCache.Size;
+    /// direct access to the ready-to-use RTTI
+    property Cache: TRttiCache
+      read fCache;
+    /// define specific behavior for this type
+    property Flags: TRttiCustomFlags
+      read fFlags write fFlags;
+    /// high-level Parser kind
+    property Parser: TRttiParserType
+      read fParser;
+    /// high-level Parser Complex kind
+    property ParserComplex: TRttiParserComplexType
+      read fParserComplex;
+    /// store information about the properties/fields of this type
+    // - only set for rkClass and rkRecord/rkObject
+    property Props: TRttiCustomProps
+      read fProps;
+    /// shortcut to the TRttiCustom of the item of a (dynamic) array
+    // - only set for rkArray and rkDynArray
+    // - may be set also for unmanaged types - use Cache.ItemInfo if you want
+    // the raw PRttiInfo TypeInfo() pointer for rkManagedTypes only
+    property ArrayRtti: TRttiCustom
+      read fArrayRtti;
+    /// best guess of first field type for a rkDynArray
+    // - equals ArrayRtti.Parser if ArrayRtti.Kind is not rkRecordTypes
+    property ArrayFirstField: TRttiParserType
+      read fArrayFirstField;
+    /// store the number of bytes for hexadecimal serialization for rcfBinary
+    // - used when rcfBinary is defined in Flags; equals 0 if disabled (default)
+    property BinarySize: integer
+      read fBinarySize;
+    /// store the class of this type, i.e. contains Cache.Info.RttiClass.RttiClass
+    property ValueClass: TClass
+      read fValueClass;
+    /// identify most common RTL inherited classes for special handling
+    // - recognize TCollection TStrings TObjectList TList parents
+    // - TRttiValueClass enumerate is faster than InheritsFrom() call
+    property ValueRtlClass: TRttiValueClass
+      read fValueRtlClass;
+    /// store the class of a T*ObjArray dynamic array
+    // - shortcut to ArrayRtti.Info.RttiClass.RttiClass
+    // - used when rcfObjArray is defined in Flags
+    property ObjArrayClass: TClass
+      read fObjArrayClass;
+    /// store the Item class for a given TCollection
+    // - as previously registered by Rtti.RegisterCollection()
+    property CollectionItem: TCollectionItemClass
+      read fCollectionItem;
+    /// opaque private instance used by mormot.orm.base.pas or mormot.core.log.pas
+    // - stores e.g. the TOrmProperties ORM information of a TOrm,
+    // or the TSynLogFamily of a TSynLog instance
+    // - is owned, as TObject, by this TRttiCustom
+    // - assignment is usually protected by the Rtti.RegisterSafe
+    property PrivateSlot: pointer
+      read fPrivateSlot write fPrivateSlot;
+    /// redirect to the low-level value copy - use rather ValueCopy()
+    property Copy: TRttiCopier
+      read fCopy;
+    /// redirect to the low-level class instance copy
+    // - nil by default, to use Props.CopyProperties()
+    // - is overwritten e.g. by TOrm.RttiCustomSetParser
+    property CopyObject: TRttiClassCopier
+      read fCopyObject write fCopyObject;
+    /// opaque TRttiJsonLoad callback used by mormot.core.json.pas
+    property JsonLoad: pointer
+      read fJsonLoad write fJsonLoad;
+    /// opaque TRttiJsonSave callback used by mormot.core.json.pas
+    property JsonSave: pointer
+      read fJsonSave write fJsonSave;
+    /// opaque TOnRttiJsonRead callback used by mormot.core.json.pas
+    property JsonReader: TMethod
+      read fJsonReader write fJsonReader;
+    /// opaque TOnRttiJsonWrite callback used by mormot.core.json.pas
+    property JsonWriter: TMethod
+      read fJsonWriter write fJsonWriter;
+  end;
+
+  PRttiCustom = ^TRttiCustom;
+
+  /// meta-class of TRttiCustom
+  // - is usually a TRttiJson class type once mormot.core.json.pas is linked
+  TRttiCustomClass = class of TRttiCustom;
+
+  /// efficient PRttiInfo/TRttiCustom pairs for TRttiCustomList hash table
+  // - as stored in TRttiCustomList.fHashTable[RK_TOSLOT[TRttiKind]]
+  // - contains hash tables by TypeInfo() and by case-insensitive name
+  TRttiCustomListPairs = record
+    /// efficient HashInfo/HashName[] pairs thread-safety during Find/AddToPairs
+    Safe: TRWLightLock;
+    /// speedup search by name e.g. from a loop
+    LastName: TRttiCustom;
+    /// thread-safe speedup search by PRttiInfo e.g. from a loop
+    LastInfo: TRttiCustom;
+    /// thread-safe speedup search by PRttiInfo e.g. from a loop
+    LastHash: array[0..RTTIHASH_MAX] of TRttiCustom;
+    /// CPU L1 cache efficient PRttiInfo/TRttiCustom pairs hashed by PRttiInfo
+    HashInfo: array[0..RTTIHASH_MAX] of TPointerDynArray;
+    /// CPU L1 cache efficient PRttiInfo/TRttiCustom pairs hashed by Name
+    HashName: array[0..RTTIHASH_MAX] of TPointerDynArray;
+  end;
+  PRttiCustomListPairs = ^TRttiCustomListPairs;
+
+  /// maintain a thread-safe list of PRttiInfo/TRttiCustom/TRttiJson registration
+  TRttiCustomList = class
+  private
+    // store PRttiInfo/TRttiCustom pairs by TRttiKind.Kind+PRttiInfo/Name
+    fHashTable: array of TRttiCustomListPairs;
+    // used to release memory used by registered customizations
+    fInstances: array of TRttiCustom;
+    fGlobalClass: TRttiCustomClass;
+    function GetByClass(ObjectClass: TClass): TRttiCustom;
+      {$ifdef HASINLINE}inline;{$endif}
+    // called by FindOrRegister() for proper inlining
+    function DoRegister(Info: PRttiInfo): TRttiCustom; overload;
+    function DoRegister(ObjectClass: TClass; ToDo: TRttiCustomFlags): TRttiCustom; overload;
+    procedure AddToPairs(Instance: TRttiCustom; Info: PRttiInfo);
+    procedure SetGlobalClass(RttiClass: TRttiCustomClass); // ensure Count=0
+  public
+    /// how many TRttiCustom instances have been registered
+    Count: integer;
+    /// a global lock shared for high-level RTTI registration process
+    // - is used e.g. to protect DoRegister() or TRttiCustom.PrivateSlot
+    // - should be a reentrant lock, even if seldom called
+    RegisterSafe: TOSLock;
+    /// how many TRttiCustom instances have been registered for a given type
+    // - we include rkUnknown for safety
+    Counts: array[TRttiKind] of integer;
+    /// initialize the RTTI list
+    constructor Create;
+    /// finalize the RTTI list
+    destructor Destroy; override;
+    /// efficient search of TRttiCustom from a given RTTI TypeInfo()
+    // - returns nil if Info is not known
+    // - call RegisterType() if you want to initialize the type via its RTTI
+    // - not inlined since less efficient code is generated
+    function FindType(Info: PRttiInfo): TRttiCustom;
+    /// efficient search of TRttiCustom from a given TObject class
+    // - returns nil if Info is not known
+    // - will use the ObjectClass vmtAutoTable slot for very fast O(1) lookup,
+    // or use our "hash table of the poor" (tm) if NOPATCHVMT conditional is set
+    {$ifdef NOPATCHVMT}
+    function FindClass(ObjectClass: TClass): TRttiCustom;
+      {$ifdef HASINLINE}inline;{$endif}
+    {$else}
+    class function FindClass(ObjectClass: TClass): TRttiCustom;
+      {$ifdef HASINLINE}static; inline;{$endif}
+    {$endif NOPATCHVMT}
+    /// efficient search of TRttiCustom from a given type name
+    function FindName(Name: PUtf8Char; NameLen: PtrInt;
+      Kind: TRttiKind): TRttiCustom; overload;
+    /// efficient search of TRttiCustom from a given type name
+    function FindName(Name: PUtf8Char; NameLen: PtrInt;
+      Kinds: TRttiKinds = []): TRttiCustom; overload;
+    /// efficient search of TRttiCustom from a given type name
+    function FindName(const Name: ShortString; Kinds: TRttiKinds = []): TRttiCustom;
+       overload; {$ifdef HASINLINE}inline;{$endif}
+    /// manual search of any matching TRttiCustom.ArrayRtti type
+    // - currently not called: IList and IKeyValue just use TypeInfo(T)
+    function FindByArrayRtti(ElemInfo: PRttiInfo): TRttiCustom;
+    /// register a given RTTI TypeInfo()
+    // - returns a new (or existing if it was already registered) TRttiCustom
+    // - if Info.Kind is rkDynArray, it will also register the nested rkRecord
+    // - match mORMot 1.18 TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType
+    function RegisterType(Info: PRttiInfo): TRttiCustom;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// register one or several RTTI TypeInfo()
+    // - to ensure that those types will be recognized by text definition
+    // - will just call RegisterType() for each Info[]
+    // - match mORMot 1.18 TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType
+    procedure RegisterTypes(const Info: array of PRttiInfo);
+    /// recognize (and register if needed) a standard simple type
+    // - calls Find() to return already registered TRttiCustom instance, and
+    // also recognize "array" or "record" keywords as expected by our parser
+    // - returns nil if nothing was found
+    // - will truncate any 'unitname.typename' into plain 'typename' before Find()
+    function RegisterTypeFromName(Name: PUtf8Char; NameLen: PtrInt;
+      ParserType: PRttiParserType = nil): TRttiCustom; overload;
+    /// recognize (and register if needed) a standard simple type
+    // - calls Find() to return already registered TRttiCustom instance, and
+    // also recognize "array" or "record" keywords as expected by our parser
+    // - returns nil if nothing was found
+    // - will truncate any 'unitname.typename' into plain 'typename' before Find()
+    function RegisterTypeFromName(const Name: RawUtf8;
+      ParserType: PRttiParserType = nil): TRttiCustom; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// register a given class type, using its RTTI
+    // - returns existing or new TRttiCustom
+    // - please call RegisterCollection for TCollection
+    function RegisterClass(ObjectClass: TClass): TRttiCustom; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// register a given class type, using its RTTI
+    // - returns existing or new TRttiCustom
+    // - please call RegisterCollection for TCollection
+    function RegisterClass(aObject: TObject): TRttiCustom; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// low-level registration function called from RegisterClass()
+    // - is sometimes called after manual vmtAutoTable slot lookup
+    function DoRegister(ObjectClass: TClass): TRttiCustom; overload;
+    /// register a given class type, using its RTTI, to auto-create/free its
+    // class and dynamic array published fields
+    function RegisterAutoCreateFieldsClass(ObjectClass: TClass): TRttiCustom;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// register one or several RTTI TypeInfo()
+    // - to ensure that those classes will be recognized by text definition
+    // - will just call RegisterClass() for each ObjectClass[]
+    procedure RegisterClasses(const ObjectClass: array of TClass);
+    /// define how a given TCollectionClass should instantiate its items
+    // - we need to know the CollectionItem to propertly initialize a TCollection
+    // - not thread-safe: should be called once from the main thread, at startup,
+    // e.g. in the initialization section of your collection definition unit
+    function RegisterCollection(Collection: TCollectionClass;
+      CollectionItem: TCollectionItemClass): TRttiCustom;
+    /// register some TypeInfo() containing unsafe parameter values
+    // - i.e. any RTTI type containing Sensitive Personal Information, e.g.
+    // a bank card number or a plain password
+    // - such values will force associated values to be ignored during loging,
+    // as a more tuned alternative to optNoLogInput or optNoLogOutput
+    // - not thread-safe: should be called once from the main thread, at startup,
+    // e.g. in the initialization section of your types definition unit
+    procedure RegisterUnsafeSpiType(const Types: array of PRttiInfo);
+    /// register one RTTI TypeInfo() to be serialized as hexadecimal
+    // - data will be serialized as BinToHexDisplayLower() JSON hexadecimal
+    // string, using BinarySize bytes of the value, i.e. BinarySize*2 hexa chars
+    // - you can truncate the original data size (e.g. if all bits of an integer
+    // are not used) by specifying the aFieldSize optional parameter
+    // - will also ensure that those types will be recognized by text definition
+    // - leave BinarySize=0 to write all bytes as hexadecimal
+    // - set BinarySize=-1 to unregister the binary serialization for the type
+    // - not thread-safe: should be called once from the main thread, at startup,
+    // e.g. in the initialization section of your types definition unit
+    // - match mORMot 1.18 TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType
+    function RegisterBinaryType(Info: PRttiInfo; BinarySize: integer = 0): TRttiCustom;
+    /// register one or several RTTI TypeInfo() to be serialized as hexadecimal
+    // - TypeInfo() and associated size information will here be defined by pairs:
+    // ([TypeInfo(TType1),TYPE1_BYTES,TypeInfo(TType2),TYPE2_BYTES])
+    // - a wrapper around the RegisterBinaryType() method
+    // - not thread-safe: should be called once from the main thread, at startup,
+    // e.g. in the initialization section of your types definition unit
+    // - match mORMot 1.18 TTextWriter.RegisterCustomJSONSerializerFromTextBinaryType
+    procedure RegisterBinaryTypes(const InfoBinarySize: array of const);
+    /// register one dynamic array RTTI TypeInfo() to be serialized as T*ObjArray
+    // - not needed on FPC and Delphi 2010+ since "array of TSomeClass" will be
+    // recognized directly - see HASDYNARRAYTYPE conditional
+    // - allow JSON serialization and unserialization of the registered dynamic
+    // array property defined in any TPersistent or TOrm for oldest Delphi
+    // - could be used as such (note the T*ObjArray type naming convention):
+    // ! TUserObjArray = array of TUser;
+    // ! ...
+    // ! Rtti.RegisterObjArray(TypeInfo(TUserObjArray), TUser);
+    // - then you can use ObjArrayAdd/ObjArrayFind/ObjArrayDelete to manage
+    // the stored items, and never forget to call ObjArrayClear to release
+    // the memory
+    // - set Item=nil to unregister the type as a T*ObjArray - may be needed
+    // to bypass the FPC and Delphi 2010+ automatic recognition
+    // - may return nil if DynArray is not a rkDynArray
+    // - replace deprecated TJsonSerializer.RegisterObjArrayForJson() method
+    // - not thread-safe: should be called once from the main thread, at startup,
+    // e.g. in the initialization section of your T*ObjArray definition unit
+    function RegisterObjArray(DynArray: PRttiInfo; Item: TClass): TRttiCustom;
+    /// register one or several dynamic array RTTI TypeInfo() to be serialized
+    // as T*ObjArray
+    // - not needed on FPC and Delphi 2010+ since "array of TSomeClass" will be
+    // recognized directly - see HASDYNARRAYTYPE conditional
+    // - will call the RegisterObjArray() class method by pair:
+    // ! Rtti.RegisterObjArrays([
+    // !   TypeInfo(TAddressObjArray), TAddress,
+    // !   TypeInfo(TUserObjArray), TUser]);
+    // - not thread-safe: should be called once from the main thread, at startup,
+    // e.g. in the initialization section of your T*ObjArray definition unit
+    procedure RegisterObjArrays(const DynArrayItem: array of const);
+    /// register TypeInfo() custom serialization for a given dynamic array or record
+    // - DynArrayOrRecord should be valid TypeInfo() - use overloaded
+    // RegisterFromText(TypeName) if the record has no TypeInfo()
+    // - the RTTI information will here be defined as plain text
+    // - since Delphi 2010, you can call directly RegisterType()
+    // - 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 RttiDefinition='' to return back to the default
+    // serialization, i.e. binary + Base64 or Delphi 2010+ extended RTTI
+    // - RTTI textual information shall be supplied as text, with the
+    // same format as any 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 TRttiCustom instance corresponding to the
+    // supplied RTTI text definition - i.e. the rkRecord if TypeInfo(SomeArray)
+    // - match mORMot 1.18 TTextWriter.RegisterCustomJSONSerializerFromText()
+    function RegisterFromText(DynArrayOrRecord: PRttiInfo;
+      const RttiDefinition: RawUtf8): TRttiCustom; 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 RegisterFromText() method
+    // - match mORMot 1.18 TTextWriter.RegisterCustomJSONSerializerFromText()
+    procedure RegisterFromText(
+      const TypeInfoTextDefinitionPairs: array of const); overload;
+    /// register by name a custom serialization for a given dynamic array or record
+    // - use overloaded RegisterFromText(TypeName) if the record has TypeInfo()
+    // - the RTTI information will here be defined as plain text
+    function RegisterFromText(const TypeName: RawUtf8;
+      const RttiDefinition: RawUtf8): TRttiCustom; overload;
+    /// default property to access a given RTTI TypeInfo() customization
+    // - you can access or register one type by using this default property:
+    // ! Rtti[TypeInfo(TMyClass)].Props.NameChange('old', 'new')
+    property ByTypeInfo[P: PRttiInfo]: TRttiCustom
+      read RegisterType; default;
+    /// default property to access a given RTTI customization of a class
+    // - you can access or register one type by using this default property:
+    // ! Rtti.ByClass[TMyClass].Props.NameChanges(['old', 'new'])
+    property ByClass[C: TClass]: TRttiCustom
+      read GetByClass;
+    /// which kind of TRttiCustom class is to be used for registration
+    // - properly set e.g. by mormot.core.json.pas to TRttiJson for JSON support
+    property GlobalClass: TRttiCustomClass
+      read fGlobalClass write SetGlobalClass;
+  end;
+
+
+/// low-level internal function use when inlining TRttiCustomProps.Find()
+// - caller should ensure that namelen <> 0
+function FindCustomProp(p: PRttiCustomProp; name: pointer; namelen: TStrLen;
+  count: integer): PRttiCustomProp;
+
+/// low-level internal function used e.g. by TRttiCustom.GetPrivateSlot()
+// - caller should ensure that slot <> nil
+function FindPrivateSlot(c: TClass; slot: PPointer): pointer;
+
+/// retrieve a (possibly nested) class property RTTI and instance by path
+// - as used e.g. by GetValueObject/SetValueObject wrapper functions
+function GetInstanceByPath(var Instance: TObject; const Path: RawUtf8;
+  out Prop: PRttiCustomProp; PathDelim: AnsiChar = '.'): boolean;
+
+var
+  /// low-level access to the list of registered PRttiInfo/TRttiCustom/TRttiJson
+  Rtti: TRttiCustomList;
+
+  /// direct lookup to the TRttiCustom of TRttiParserType values
+  PT_RTTI: array[TRttiParserType] of TRttiCustom;
+
+  /// direct lookup to the TRttiCustom of TRttiParserComplexType values
+  PTC_RTTI: array[TRttiParserComplexType] of TRttiCustom;
+
+
+{ *********** High Level TObjectWithID and TObjectWithCustomCreate Class Types }
+
+type
+  {$M+}
+  /// abstract parent class with published properties and a virtual constructor
+  // - is the parent of both TSynPersistent and TOrm classes
+  // - will ensure the class type is registered to the Rtti global list
+  // - also features some protected virtual methods for custom RTTI/JSON process
+  TObjectWithCustomCreate = class(TObject)
+  protected
+    /// called by TRttiJson.SetParserType when this class is registered
+    // - used e.g. to register TOrm.ID field which is not published as RTTI
+    // - in TSynPersistent descendants, can change the Rtti.JsonSave callback
+    // if needed, or e.g. set rcfHookWrite flag to call RttiBeforeWriteObject
+    // and RttiAfterWriteObject, rcfHookWriteProperty for RttiWritePropertyValue
+    // and/or rcfHookRead for RttiBeforeReadObject or RttiAfterReadObject methods
+    // (disabled by default not to slow down the serialization process)
+    class procedure RttiCustomSetParser(Rtti: TRttiCustom); virtual;
+    // called before TJsonWriter.WriteObject() serialize this instance as JSON
+    // - triggered if RttiCustomSetParser defined the rcfHookWrite flag
+    // - you can return true if your method made the serialization
+    // - this default implementation just returns false, to continue serializing
+    // - TSynMonitor will change the serialization Options for this instance
+    function RttiBeforeWriteObject(W: TTextWriter;
+      var Options: TTextWriterWriteObjectOptions): boolean; virtual;
+    // called by TJsonWriter.WriteObject() to serialize one published property value
+    // - triggered if RttiCustomSetParser defined the rcfHookWriteProperty flag
+    // - is e.g. overriden in TOrm/TOrmMany to detect "fake" instances
+    // - should return true if a property has been written, false (which is the
+    // default) if the property is to be serialized as usual
+    function RttiWritePropertyValue(W: TTextWriter; Prop: PRttiCustomProp;
+      Options: TTextWriterWriteObjectOptions): boolean; virtual;
+    /// called after TJsonWriter.WriteObject() serialized this instance as JSON
+    // - triggered if RttiCustomSetParser defined the rcfHookWrite flag
+    // - execute just before W.BlockEnd('}')
+    procedure RttiAfterWriteObject(W: TTextWriter;
+      Options: TTextWriterWriteObjectOptions); virtual;
+    /// called to unserialize this instance from JSON
+    // - triggered if RttiCustomSetParser defined the rcfHookRead flag
+    // - you can return true if your method made the instance unserialization
+    // - this default implementation just returns false, to continue processing
+    // - opaque Ctxt is a PJsonParserContext instance
+    function RttiBeforeReadObject(Ctxt: pointer): boolean; virtual;
+    /// called to unserialize of property of this instance from JSON
+    // - triggered if RttiCustomSetParser defined the rcfHookReadProperty flag
+    // - you can return true if your method made the property unserialization
+    // - this default implementation just returns false, to continue processing
+    // - opaque Ctxt is a PJsonParserContext instance
+    function RttiBeforeReadPropertyValue(Ctxt: pointer;
+      Prop: PRttiCustomProp): boolean; virtual;
+    /// called after this instance has been unserialized from JSON
+    // - triggered if RttiCustomSetParser defined the rcfHookRead flag
+    procedure RttiAfterReadObject; virtual;
+  public
+    /// virtual constructor called at instance creation
+    // - is declared as virtual so that inherited classes may have a root
+    // constructor to override
+    // - is recognized by our RTTI serialization/initialization process
+    constructor Create; virtual;
+    /// optimized initialization code
+    // - will also register the class type to the Rtti global list
+    // - somewhat faster than the regular RTL implementation
+    // - 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;
+    /// very efficiently retrieve the TRttiCustom associated with this class
+    // - since Create did register it, just return the first vmtAutoTable slot
+    class function RttiCustom: TRttiCustom;
+      {$ifdef HASINLINE}inline;{$endif}
+  end;
+  {$M-}
+
+  /// used to determine the exact class type of a TObjectWithCustomCreate
+  // - allow to create instances using its virtual constructor
+  TObjectWithCustomCreateClass = class of TObjectWithCustomCreate;
+
+  /// root class of an object with a 64-bit ID primary key
+  // - is the parent of mormot.orm.core's TOrm, but you could use it e.g. on
+  // client side to avoid a dependency to all ORM process, but still have the
+  // proper published fields and use it in SOA - with a single conditional over
+  // your class definition to inherit either from TOrm or from TObjectWithID
+  TObjectWithID = class(TObjectWithCustomCreate)
+  protected
+    fID: TID;
+    /// will register the "ID":... field value for proper JSON serialization
+    class procedure RttiCustomSetParser(Rtti: TRttiCustom); override;
+  public
+    /// this constructor initializes the instance with a given ID
+    constructor CreateWithID(aID: TID);
+    /// this property gives direct access to the class instance ID
+    // - not defined as "published" since RttiCustomSetParser did register it
+    property IDValue: TID
+      read fID write fID;
+  end;
+
+  /// used to determine the exact class type of a TObjectWithID
+  TObjectWithIDClass = class of TObjectWithID;
+
+/// internal wrapper to protected TObjectWithCustomCreate.RttiCustomSetParser()
+// - a local TCCHook was reported to have issues on FPC with class methods
+procedure TObjectWithCustomCreateRttiCustomSetParser(
+  O: TObjectWithCustomCreateClass; Rtti: TRttiCustom);
+
+/// TDynArraySortCompare compatible function, sorting by TObjectWithID/TOrm.ID
+function TObjectWithIDDynArrayCompare(const Item1, Item2): integer;
+
+/// TDynArrayHashOne compatible function, hashing TObjectWithID/TOrm.ID
+function TObjectWithIDDynArrayHashOne(const Elem; Hasher: THasher): cardinal;
+
+
+
+implementation
+
+
+{ some inlined definitions which should be declared before $include code }
+
+type
+  // local wrapper to retrieve IInvokable Interface RTTI via GetRttiInterface()
+  TGetRttiInterface = class
+  public
+    Level: integer;
+    MethodCount, ArgCount: integer;
+    CurrentMethod: PRttiMethod;
+    Definition: TRttiInterface;
+    procedure AddMethod(const aMethodName: ShortString; aParamCount: integer;
+      aKind: TMethodKind);
+    procedure AddArgument(aParamName, aTypeName: PShortString; aInfo: PRttiInfo;
+      aFlags: TParamFlags);
+    procedure RaiseError(const Format: RawUtf8; const Args: array of const);
+    // this method will be implemented in mormot.core.rtti.fpc/delphi.inc
+    procedure AddMethodsFromTypeInfo(aInterface: PTypeInfo);
+  end;
+
+{$ifdef FPC}
+  {$include mormot.core.rtti.fpc.inc}      // FPC specific RTTI access
+{$else}
+  {$include mormot.core.rtti.delphi.inc}   // Delphi specific RTTI access
+{$endif FPC}
+
+
+{ ************* Low-Level Cross-Compiler RTTI Definitions }
+
+{ TRttiClass }
+
+function TRttiClass.RttiClass: TClass;
+begin
+  result := PTypeData(@self)^.ClassType;
+end;
+
+function TRttiClass.UnitName: PShortString;
+begin
+  result := @PTypeData(@self)^.UnitName;
+end;
+
+function _ClassUnit(C: TClass): PShortString;
+var
+  P: PRttiInfo;
+begin
+  P := PPointer(PAnsiChar(C) + vmtTypeInfo)^;
+  if P <> nil then
+    result := P^.RttiNonVoidClass^.UnitName
+  else
+    result := @NULCHAR;
+end;
+
+function TRttiClass.InheritsFrom(AClass: TClass): boolean;
+var
+  P: PRttiInfo;
+begin
+  result := true;
+  if RttiClass = AClass then
+    exit;
+  P := ParentInfo;
+  while P <> nil do
+    with P^.RttiNonVoidClass^ do
+      if RttiClass = AClass then
+        exit
+      else
+        P := ParentInfo;
+  result := false;
+end;
+
+
+{ TRttiProp }
+
+function TRttiProp.Name: PShortString;
+begin
+  result := @PPropInfo(@self)^.Name;
+end;
+
+function TRttiProp.NameUtf8: RawUtf8;
+begin
+  ShortStringToAnsi7String(PPropInfo(@self)^.Name, result);
+end;
+
+function TRttiProp.Next: PRttiProp;
+begin
+  // this abstract code compiles into 2 asm lines under FPC :)
+  with PPropInfo(@self)^ do
+    result := AlignToPtr(@PByteArray(@self)[
+      (PtrUInt(@PPropInfo(nil).Name) + SizeOf(Name[0])) + Length(Name)]);
+end;
+
+
+{ TRttiProps = TPropData in TypInfo }
+
+function TRttiProps.FieldProp(const PropName: ShortString): PRttiProp;
+var
+  i: integer;
+begin
+  if @self<>nil then
+  begin
+    result := PropList;
+    for i := 1 to PropCount do
+      if PropNameEquals(result^.Name, @PropName) then
+        exit
+      else
+        result := result^.Next;
+  end;
+  result := nil;
+end;
+
+
+{ TRttiEnumType }
+
+function TRttiEnumType.RttiOrd: TRttiOrd;
+begin
+  result := TRttiOrd(PTypeData(@self)^.OrdType);
+end;
+
+function TRttiEnumType.MinValue: PtrInt;
+begin
+  result := PTypeData(@self).MinValue;
+end;
+
+function TRttiEnumType.MaxValue: PtrInt;
+begin
+  result := PTypeData(@self).MaxValue;
+end;
+
+function TRttiEnumType.NameList: PShortString;
+begin
+  result := @PTypeData(@self).NameList;
+end;
+
+function TRttiEnumType.SizeInStorageAsEnum: integer;
+begin
+  if @self = nil then
+    result := 0
+  else
+    result := ORDTYPE_SIZE[RttiOrd]; // MaxValue is wrong e.g. with WordBool
+end;
+
+function TRttiEnumType.SizeInStorageAsSet: integer;
+begin
+  if @self <> nil then
+  begin
+    result := MaxValue;
+    if result < 8 then
+      result := SizeOf(byte)
+    else if result < 16 then
+      result := SizeOf(word)
+    else if result < 32 then
+      result := SizeOf(cardinal)
+    else if result < 64 then
+      result := SizeOf(QWord)
+    else
+      result := 0;
+  end
+  else
+    result := 0;
+end;
+
+function TRttiEnumType.GetEnumName(const Value): PShortString;
+begin
+  if @Value = nil then
+    result := @NULCHAR
+  else
+    result := GetEnumNameOrd(RTTI_FROM_ORD[RttiOrd](@Value));
+end;
+
+function TRttiEnumType.GetCaption(const Value): string;
+begin
+  GetCaptionFromTrimmed(GetEnumNameOrd(RTTI_FROM_ORD[RttiOrd](@Value)), result);
+end;
+
+procedure TRttiEnumType.AddCaptionStrings(Strings: TStrings;
+  UsedValuesBits: Pointer);
+var
+  i, L: PtrInt;
+  Line: array[byte] of AnsiChar;
+  P: PAnsiChar;
+  V: PShortString;
+  s: string;
+begin
+  if @self = nil then
+    exit;
+  Strings.BeginUpdate;
+  try
+    V := NameList;
+    for i := MinValue to MaxValue do
+    begin
+      if (UsedValuesBits = nil) or
+         GetBitPtr(UsedValuesBits, i) then
+      begin
+        L := ord(V^[0]);
+        P := @V^[1];
+        while (L > 0) and
+              (P^ in ['a'..'z']) do
+        begin
+          // ignore left lowercase chars
+          inc(P);
+          dec(L);
+        end;
+        if L = 0 then
+        begin
+          L := ord(V^[0]);
+          P := @V^[1];
+        end;
+        Line[L] := #0; // GetCaptionFromPCharLen() expect it as ASCIIZ
+        MoveFast(P^, Line, L);
+        GetCaptionFromPCharLen(Line, s);
+        Strings.AddObject(s, pointer(i));
+      end;
+      inc(PByte(V), length(V^)+1);
+    end;
+  finally
+    Strings.EndUpdate;
+  end;
+end;
+
+function TRttiEnumType.GetCaptionStrings(UsedValuesBits: pointer): string;
+var
+  List: TStringList;
+begin
+  List := TStringList.Create;
+  try
+    AddCaptionStrings(List, UsedValuesBits);
+    result := List.Text;
+  finally
+    List.Free;
+  end;
+end;
+
+procedure TRttiEnumType.GetEnumNameAll(var result: TRawUtf8DynArray;
+  TrimLeftLowerCase: boolean);
+var
+  max, i: PtrInt;
+  V: PShortString;
+begin
+  Finalize(result);
+  max := MaxValue - MinValue;
+  SetLength(result, max + 1);
+  V := NameList;
+  for i := 0 to max do
+  begin
+    if TrimLeftLowerCase then
+      result[i] := TrimLeftLowerCaseShort(V)
+    else
+      ShortStringToAnsi7String(V^, result[i]);
+    inc(PByte(V), length(V^) + 1);
+  end;
+end;
+
+procedure TRttiEnumType.GetEnumNameAll(out result: RawUtf8; const Prefix: RawUtf8;
+  quotedValues: boolean; const Suffix: RawUtf8; trimedValues, unCamelCased: boolean);
+var
+  i: integer;
+  V: PShortString;
+  uncamel: ShortString;
+  temp: TTextWriterStackBuffer;
+begin
+  with TTextWriter.CreateOwnedStream(temp) do
+  try
+    AddString(Prefix);
+    V := NameList;
+    for i := MinValue to MaxValue do
+    begin
+      if quotedValues then
+        AddDirect('"');
+      if unCamelCased then
+      begin
+        TrimLeftLowerCaseToShort(V, uncamel);
+        AddShort(uncamel);
+      end
+      else if trimedValues then
+        AddTrimLeftLowerCase(V)
+      else
+        AddShort(V^);
+      if quotedValues then
+        AddDirect('"');
+      AddComma;
+      inc(PByte(V), length(V^) + 1);
+    end;
+    CancelLastComma;
+    AddString(Suffix);
+    SetText(result);
+  finally
+    Free;
+  end;
+end;
+
+procedure TRttiEnumType.GetEnumNameTrimedAll(var result: RawUtf8;
+  const Prefix: RawUtf8; quotedValues: boolean; const Suffix: RawUtf8);
+begin
+  GetEnumNameAll(result, Prefix, quotedValues, Suffix, {trimed=}true);
+end;
+
+function TRttiEnumType.GetEnumNameAllAsJsonArray(TrimLeftLowerCase: boolean;
+  UnCamelCased: boolean): RawUtf8;
+begin
+  GetEnumNameAll(result, '[', {quoted=}true, ']', TrimLeftLowerCase, UnCamelCased);
+end;
+
+function TRttiEnumType.GetEnumNameValue(const EnumName: ShortString): integer;
+begin
+  result := GetEnumNameValue(@EnumName[1], ord(EnumName[0]));
+end;
+
+function TRttiEnumType.GetEnumNameValue(Value: PUtf8Char): integer;
+begin
+  result := GetEnumNameValue(Value, StrLen(Value));
+end;
+
+function TRttiEnumType.GetEnumNameValue(Value: PUtf8Char; ValueLen: integer;
+  AlsoTrimLowerCase: boolean): integer;
+begin
+  if (Value <> nil) and
+     (ValueLen > 0) and
+     (MinValue = 0) then
+  begin
+    result := FindShortStringListExact(NameList, MaxValue, Value, ValueLen);
+    if (result < 0) and
+       AlsoTrimLowerCase then
+      result := FindShortStringListTrimLowerCase(NameList, MaxValue, Value, ValueLen);
+  end
+  else
+    result := -1;
+end;
+
+function TRttiEnumType.GetEnumNameValueTrimmed(Value: PUtf8Char; ValueLen: integer;
+  CaseSensitive: boolean): integer;
+begin
+  if (Value <> nil) and
+     (ValueLen > 0) and
+     (MinValue = 0) then
+    if CaseSensitive then
+      result := FindShortStringListTrimLowerCaseExact(NameList, MaxValue, Value, ValueLen)
+    else
+      result := FindShortStringListTrimLowerCase(NameList, MaxValue, Value, ValueLen)
+  else
+    result := -1;
+end;
+
+function TRttiEnumType.GetEnumNameTrimed(const Value): RawUtf8;
+begin
+  result := TrimLeftLowerCaseShort(GetEnumName(Value));
+end;
+
+function TRttiEnumType.GetSetName(const value; trimmed: boolean;
+  const sep: RawUtf8): RawUtf8;
+var
+  j: PtrInt;
+  PS, v: PShortString;
+  tmp: shortstring;
+begin
+  result := '';
+  if (@self = nil) or
+     (@value = nil) then
+    exit;
+  PS := NameList;
+  for j := MinValue to MaxValue do
+  begin
+    if GetBitPtr(@value, j) then
+    begin
+      v := @tmp;
+      if trimmed then
+        TrimLeftLowerCaseToShort(PS, tmp)
+      else
+        v := PS;
+      Append(result, [v^, sep]);
+    end;
+    inc(PByte(PS), PByte(PS)^ + 1); // next
+  end;
+  if result <> '' then
+    FakeLength(result, length(result) - length(sep)); // trim last separator
+end;
+
+procedure TRttiEnumType.GetSetNameJsonArray(W: TTextWriter; Value: cardinal;
+  SepChar, QuoteChar: AnsiChar; FullSetsAsStar, ForceTrim: boolean);
+var
+  j, max: PtrInt;
+  PS: PShortString;
+begin
+  W.Add('[');
+  if FullSetsAsStar and
+     (MinValue = 0) and
+     GetAllBits(Value, MaxValue + 1) then
+    W.AddShorter('"*"')
+  else
+  begin
+    PS := NameList;
+    if twoTrimLeftEnumSets in W.CustomOptions then
+      ForceTrim := true;
+    max := MaxValue;
+    if max >= 32 then
+      max := 31; // avoid buffer overflow on 32-bit cardinal Value
+    for j := MinValue to max do
+    begin
+      if GetBitPtr(@Value, j) then
+      begin
+        if QuoteChar <> #0 then
+          W.Add(QuoteChar);
+        if ForceTrim then
+          W.AddTrimLeftLowerCase(PS)
+        else
+          W.AddShort(PS^);
+        if QuoteChar <> #0 then
+          W.AddDirect(QuoteChar);
+        W.AddDirect(SepChar);
+      end;
+      inc(PByte(PS), ord(PS^[0]) + 1); // next item
+    end;
+  end;
+  W.CancelLastComma(']');
+end;
+
+function TRttiEnumType.GetSetNameJsonArray(Value: cardinal; SepChar: AnsiChar;
+  FullSetsAsStar: boolean): RawUtf8;
+var
+  W: TTextWriter;
+  temp: TTextWriterStackBuffer;
+begin
+  W := TTextWriter.CreateOwnedStream(temp);
+  try
+    GetSetNameJsonArray(W, Value, SepChar, '"', FullSetsAsStar, {forcetrim=}false);
+    W.SetText(result);
+  finally
+    W.Free;
+  end;
+end;
+
+function TRttiEnumType.GetEnumNameTrimedValue(const EnumName: ShortString): integer;
+begin
+  result := GetEnumNameTrimedValue(@EnumName[1], ord(EnumName[0]));
+end;
+
+function TRttiEnumType.GetEnumNameTrimedValue(Value: PUtf8Char; ValueLen: integer): integer;
+begin
+  if (Value = nil) or
+     (MinValue <> 0) then
+    result := -1
+  else
+  begin
+    if ValueLen = 0 then
+      ValueLen := StrLen(Value);
+    result := FindShortStringListTrimLowerCase(NameList, MaxValue, Value, ValueLen);
+    if result < 0 then
+      result := FindShortStringListExact(NameList, MaxValue, Value, ValueLen);
+  end;
+end;
+
+procedure TRttiEnumType.SetEnumFromOrdinal(out Value; Ordinal: PtrUInt);
+begin
+  RTTI_TO_ORD[RttiOrd](@Value, Ordinal);
+end;
+
+
+
+{ TRttiInterfaceTypeData }
+
+function TRttiInterfaceTypeData.IntfFlags: TRttiIntfFlags;
+begin
+  result := TRttiIntfFlags(PTypeData(@self)^.IntfFlags);
+end;
+
+function TRttiInterfaceTypeData.IntfUnit: PShortString;
+begin
+  result := @PTypeData(@self)^.IntfUnit;
+end;
+
+
+{ TRttiInfo }
+
+procedure TRttiInfo.Clear(Data: pointer);
+var
+  fin: TRttiFinalizer;
+begin
+  fin := RTTI_FINALIZE[Kind];
+  if Assigned(fin) then
+    fin(Data, @self);
+end;
+
+procedure TRttiInfo.Copy(Dest, Source: pointer);
+var
+  cop: TRttiCopier;
+begin
+  cop := RTTI_MANAGEDCOPY[Kind];
+  if Assigned(cop) then
+    cop(Dest, Source, @self);
+end;
+
+function TRttiInfo.RttiOrd: TRttiOrd;
+begin
+  result := TRttiOrd(GetTypeData(@self)^.OrdType);
+end;
+
+function TRttiInfo.IsCurrency: boolean;
+begin
+  result := TRttiFloat(GetTypeData(@self)^.FloatType) = rfCurr;
+end;
+
+function TRttiInfo.IsDate: boolean;
+begin
+  result := (@self = TypeInfo(TDate)) or
+            (@self = TypeInfo(TDateTime)) or
+            (@self = TypeInfo(TDateTimeMS));
+end;
+
+function TRttiInfo.IsRawBlob: boolean;
+begin
+  result := @self = TypeInfo(RawBlob);
+end;
+
+function TRttiInfo.RttiFloat: TRttiFloat;
+begin
+  result := TRttiFloat(GetTypeData(@self)^.FloatType);
+end;
+
+{$ifndef ISFPC32}
+function TRttiInfo.SetEnumSize: PtrInt;
+begin
+  result := SetEnumType^.SizeInStorageAsSet;
+end;
+{$endif ISFPC32}
+
+function TRttiInfo.DynArrayItemSize: PtrInt;
+begin
+  DynArrayItemType(result); // fast enough (not used internally)
+end;
+
+function TRttiInfo.RttiSize: PtrInt;
+begin
+  case Kind of
+    {$ifdef FPC}
+    rkBool,
+    rkUChar,
+    {$endif FPC}
+    rkInteger,
+    rkEnumeration,
+    rkChar,
+    rkWChar:
+      result := ORDTYPE_SIZE[TRttiOrd(GetTypeData(@self)^.OrdType)];
+    rkSet:
+      result := SetEnumSize;
+    rkFloat:
+      result := FLOATTYPE_SIZE[TRttiFloat(GetTypeData(@self)^.FloatType)];
+    rkLString,
+    {$ifdef FPC}
+    rkLStringOld,
+    rkInterfaceRaw,
+    {$endif FPC}
+    {$ifdef HASVARUSTRING}
+    rkUString,
+    {$endif HASVARUSTRING}
+    {$ifdef FPC_OR_UNICODE}
+    rkClassRef,
+    rkPointer,
+    {$endif FPC_OR_UNICODE}
+    rkWString,
+    rkClass,
+    rkInterface,
+    rkDynArray:
+      result := SizeOf(pointer);
+    {$ifdef FPC}
+    rkQWord,
+    {$endif FPC}
+    rkInt64:
+      result := 8;
+    rkVariant:
+      result := SizeOf(variant);
+    rkArray:
+      result := ArraySize;
+    {$ifdef FPC}rkObject,{$else}{$ifdef UNICODE}rkMRecord,{$endif}{$endif}
+    rkRecord:
+      result := RecordSize;
+    rkSString:
+      result := GetTypeData(@self)^.MaxLength + 1;
+  else
+    result := 0;
+  end;
+end;
+
+function TRttiInfo.IsManaged: boolean;
+begin
+  if Kind in rkRecordTypes then
+    result := RecordManagedFieldsCount > 0
+  else
+    result := Kind in rkManagedTypes;
+  // note: rkArray should be handled specificically: we return true here by now
+end;
+
+function TRttiInfo.ClassFieldCount(onlyWithoutGetter: boolean): integer;
+begin
+  result := ClassFieldCountWithParents(RttiClass^.RttiClass, onlyWithoutGetter);
+end;
+
+function TRttiInfo.InheritsFrom(AClass: TClass): boolean;
+begin
+  result := RttiNonVoidClass^.InheritsFrom(AClass);
+end;
+
+function TRttiInfo.EnumBaseType(out NameList: PShortString;
+  out Min, Max: integer): PRttiEnumType;
+begin
+  result := EnumBaseType;
+  NameList := result^.NameList;
+  Min := result^.MinValue;
+  Max := result^.MaxValue;
+end;
+
+function TRttiInfo.SetEnumType: PRttiEnumType;
+begin
+  if (@self = nil) or
+     (Kind <> rkSet) then
+    result := nil
+  else
+    result := PRttiEnumType(GetTypeData(@self))^.SetBaseType;
+end;
+
+function TRttiInfo.SetEnumType(out NameList: PShortString;
+  out Min, Max: integer): PRttiEnumType;
+begin
+  result := SetEnumType;
+  if result <> nil then
+  begin
+    NameList := result^.EnumBaseType.NameList; // EnumBaseType for partial sets
+    Min := result^.MinValue;
+    Max := result^.MaxValue;
+  end;
+end;
+
+
+var
+  /// conversion table from TRttiKind to TRttiVarData.VType
+  // - rkEnumeration,rkSet,rkDynArray,rkClass,rkInterface,rkRecord,rkArray are
+  // identified as varAny with TVarData.VAny pointing to the actual value
+  // - rkChar,rkWChar,rkSString converted into temporary RawUtf8 as varUnknown
+  RTTI_TO_VARTYPE: array[TRttiKind] of word;
+
+procedure TRttiInfo.ComputeCache(var Cache: TRttiCache);
+var
+  enum: PRttiEnumType;
+  siz, cnt: PtrInt;
+begin
+  // caller ensured Cache is filled with zeros (e.g. TRttiCustom.fCache prop)
+  FillCharFast(Cache, SizeOf(Cache), 0); // paranoid
+  Cache.Info := @self;
+  Cache.Size := RttiSize;
+  Cache.Kind := Kind;
+  if Kind in rkOrdinalTypes then
+  begin
+    if Kind in rkHasRttiOrdTypes then
+    begin
+      include(Cache.Flags, rcfHasRttiOrd);
+      Cache.RttiOrd := RttiOrd;
+    end;
+    if IsQWord then
+      include(Cache.Flags, rcfQword);
+    if IsBoolean then
+    begin
+      Cache.RttiVarDataVType := varBoolean; // no rkBool on Delphi
+      include(Cache.Flags, rcfBoolean);
+    end;
+  end;
+  if Kind in rkNumberTypes then
+    include(Cache.Flags, rcfIsNumber);
+  if Kind in rkGetOrdPropTypes then
+    include(Cache.Flags, rcfGetOrdProp)
+  else if Kind in rkGetInt64PropTypes then
+    include(Cache.Flags, rcfGetInt64Prop);
+  Cache.RttiVarDataVType := RTTI_TO_VARTYPE[Kind];
+  Cache.VarDataVType := Cache.RttiVarDataVType;
+  case Kind of
+    rkFloat:
+      begin
+        Cache.RttiFloat := RttiFloat;
+        if IsCurrency then
+        begin
+          Cache.RttiVarDataVType := varCurrency;
+          Cache.VarDataVType := varCurrency;
+        end
+        else if IsDate then
+        begin
+          Cache.RttiVarDataVType := varDate;
+          Cache.VarDataVType := varDate;
+          Cache.IsDateTime := true;
+        end
+        else if Cache.RttiFloat = rfSingle then
+        begin
+          Cache.RttiVarDataVType := varSingle;
+          Cache.VarDataVType := varSingle;
+        end;
+      end;
+    rkEnumeration,
+    rkSet:
+      begin
+        Cache.VarDataVType := varInt64; // no need of the varAny TypeInfo marker
+        if Kind = rkEnumeration then
+          enum := Cache.Info.EnumBaseType
+        else
+          enum := Cache.Info.SetEnumType;
+        Cache.EnumMin := enum.MinValue;
+        Cache.EnumMax := enum.MaxValue;
+        // EnumBaseType^ is required for partial sets on Delphi
+        enum := enum.EnumBaseType;
+        Cache.EnumInfo := enum;
+        Cache.EnumList := enum.NameList;
+      end;
+    rkDynArray:
+      begin
+        Cache.ItemInfo := DynArrayItemType(siz); // nil for unmanaged items
+        Cache.ItemSize := siz;
+      end;
+    rkArray:
+      begin
+        Cache.ItemInfo := ArrayItemType(cnt, siz);
+        if (cnt = 0) or
+           (siz mod cnt <> 0) then
+          raise ERttiException.CreateUtf8('ComputeCache(%): array siz=% cnt=%',
+            [RawName, siz, cnt]);
+        Cache.ItemSize := siz div cnt;
+        Cache.ItemCount := cnt;
+      end;
+    rkLString:
+      if IsRawBlob then
+      begin
+        include(Cache.Flags, rcfIsRawBlob);
+        Cache.CodePage := CP_RAWBYTESTRING; // CP_RAWBLOB is internal
+        Cache.Engine := TSynAnsiConvert.Engine(CP_RAWBYTESTRING);
+      end
+      else
+      begin
+        Cache.CodePage := AnsiStringCodePage; // use TypeInfo() on old Delphi
+        Cache.Engine := TSynAnsiConvert.Engine(Cache.CodePage);
+      end;
+    rkInterface:
+      Cache.InterfaceGuid := InterfaceGuid;
+  end;
+end;
+
+function TRttiInfo.InterfaceType: PRttiInterfaceTypeData;
+begin
+  result := pointer(GetTypeData(@self));
+end;
+
+function TRttiInfo.AnsiStringCodePage: integer;
+begin
+  if @self = TypeInfo(RawBlob) then
+    result := CP_RAWBLOB
+  else
+  {$ifdef HASCODEPAGE}
+  if Kind = rkLString then
+    // has rkLStringOld any codepage? don't think so -> UTF-8
+    result := GetTypeData(@self)^.CodePage
+  else
+    result := CP_UTF8; // default is UTF-8
+  {$else}
+  if @self = TypeInfo(RawUtf8) then
+    result := CP_UTF8
+  else if @self = TypeInfo(WinAnsiString) then
+    result := CP_WINANSI
+  {$ifndef PUREMORMOT2}
+  else if @self = TypeInfo(RawUnicode) then
+    result := CP_UTF16
+  {$endif PUREMORMOT2}
+  else if @self = TypeInfo(RawByteString) then
+    result := CP_RAWBYTESTRING // RawBlob has same internal code page
+  else if @self = TypeInfo(AnsiString) then
+    result := CP_ACP
+  else
+    result := CP_UTF8; // default is UTF-8
+  {$endif HASCODEPAGE}
+end;
+
+{$ifdef HASCODEPAGE}
+
+function TRttiInfo.AnsiStringCodePageStored: integer;
+begin
+  result := GetTypeData(@self)^.CodePage;
+end;
+
+{$endif HASCODEPAGE}
+
+procedure TRttiInfo.StringToUtf8(Data: pointer; var Value: RawUtf8);
+begin
+  case Kind of
+    rkChar:
+      FastSetString(Value, Data, {ansicharcount=}1);
+    rkWChar:
+      RawUnicodeToUtf8(Data, {widecharcount=}1, Value);
+    rkSString:
+      ShortStringToAnsi7String(PShortString(Data)^, Value);
+    rkLString:
+      Value := PRawUtf8(Data)^;
+    rkWString:
+      RawUnicodeToUtf8(Data, length(PWideString(Data)^), Value);
+    {$ifdef HASVARUSTRING}
+    rkUString:
+      RawUnicodeToUtf8(Data, length(PUnicodeString(Data)^), Value);
+    {$endif HASVARUSTRING}
+  else
+    Value := '';
+  end;
+end;
+
+function TRttiInfo.InterfaceGuid: PGuid;
+begin
+  if (@self = nil) or
+     (Kind <> rkInterface) then
+    result := nil
+  else
+    result := InterfaceType^.IntfGuid;
+end;
+
+function TRttiInfo.InterfaceUnitName: PShortString;
+begin
+  if (@self = nil) or
+     (Kind <> rkInterface) then
+    result := @NULCHAR
+  else
+    result := InterfaceType^.IntfUnit;
+end;
+
+function TRttiInfo.InterfaceAncestor: PRttiInfo;
+begin
+  if (@self = nil) or
+     (Kind <> rkInterface) then
+    result := nil
+  else
+    result := InterfaceType^.IntfParent;
+end;
+
+procedure TRttiInfo.InterfaceAncestors(out Ancestors: PRttiInfoDynArray;
+  OnlyImplementedBy: TInterfacedObjectClass;
+  out AncestorsImplementedEntry: TPointerDynArray);
+var
+  n: PtrInt;
+  nfo: PRttiInfo;
+  typ: PRttiInterfaceTypeData;
+  entry: pointer;
+begin
+  if (@self = nil) or
+     (Kind <> rkInterface) then
+    exit;
+  n := 0;
+  typ := InterfaceType;
+  repeat
+    nfo := typ^.IntfParent;
+    if (nfo = nil) or
+       (nfo = TypeInfo(IInterface)) then
+      exit;
+    typ := nfo^.InterfaceType;
+    if ifHasGuid in typ^.IntfFlags then
+    begin
+      if OnlyImplementedBy <> nil then
+      begin
+        entry := OnlyImplementedBy.GetInterfaceEntry(typ^.IntfGuid^);
+        if entry = nil then
+          continue;
+        SetLength(AncestorsImplementedEntry, n + 1);
+        AncestorsImplementedEntry[n] := entry;
+      end;
+      SetLength(Ancestors, n + 1);
+      Ancestors[n] := nfo;
+      inc(n);
+    end;
+  until false;
+end;
+
+function TRttiInfo.InterfaceImplements(const AGuid: TGuid): boolean;
+var
+  nfo: PRttiInfo;
+  typ: PRttiInterfaceTypeData;
+begin
+  result := false;
+  if (@self = nil) or
+     IsNullGuid(AGuid) or
+     (Kind <> rkInterface) then
+    exit;
+  typ := InterfaceType;
+  repeat
+    nfo := typ^.IntfParent;
+    if (nfo = nil) or
+       (nfo = TypeInfo(IInterface)) then
+      exit;
+    typ := nfo^.InterfaceType;
+  until (ifHasGuid in typ^.IntfFlags) and
+        IsEqualGuid(AGuid, typ^.IntfGuid^);
+  result := true; // found
+end;
+
+
+{ TRttiProp }
+
+function TRttiProp.Index: integer;
+begin
+  result := PPropInfo(@self)^.Index;
+end;
+
+function TRttiProp.Default: integer;
+begin
+  result := PPropInfo(@self)^.Default;
+end;
+
+function TRttiProp.NameIndex: integer;
+begin
+  result := PPropInfo(@self)^.NameIndex;
+end;
+
+function TRttiProp.FieldSize: PtrInt;
+begin
+  result := TypeInfo^.RttiSize;
+end;
+
+function TRttiProp.GetterAddr(Instance: pointer): pointer;
+begin
+  result := Pointer(PtrUInt(Instance) +
+    PtrUInt(PPropInfo(@self)^.GetProc) {$ifdef ISDELPHI} and $00ffffff {$endif} );
+end;
+
+function TRttiProp.SetterAddr(Instance: pointer): pointer;
+begin
+  result := Pointer(PtrUInt(Instance) +
+    PtrUInt(PPropInfo(@self)^.SetProc) {$ifdef ISDELPHI} and $00ffffff {$endif} );
+end;
+
+function TRttiProp.GetFieldAddr(Instance: TObject): pointer;
+begin
+  if not GetterIsField then
+    if not SetterIsField then
+      // both are methods -> returns nil
+      result := nil
+    else
+      // field - Setter is the field offset in the instance data
+      result := SetterAddr(Instance)
+  else
+    // field - Getter is the field offset in the instance data
+    result := GetterAddr(Instance);
+end;
+
+function TRttiProp.GetterCall: TRttiPropCall;
+var
+  call: TMethod;
+begin
+  result := Getter(nil, @call);
+end;
+
+function TRttiProp.SetterCall: TRttiPropCall;
+var
+  call: TMethod;
+begin
+  result := Setter(nil, @call);
+end;
+
+function TRttiProp.DefaultOr0: integer;
+begin
+  result := PPropInfo(@self)^.Default;
+  if result = NO_DEFAULT then
+    result := 0;
+end;
+
+function TRttiProp.IsRawBlob: boolean;
+begin
+  result := TypeInfo = system.TypeInfo(RawBlob);
+end;
+
+function TRttiProp.SetValue(Instance: TObject; const Value: variant): boolean;
+var
+  k: TRttiKind;
+  v: Int64;
+  f: double;
+  u: RawUtf8;
+begin
+  result := false; // invalid or unsupported type
+  if (@self = nil) or
+     (Instance = nil) then
+    exit;
+  k := TypeInfo^.Kind;
+  if k in rkOrdinalTypes then
+    if VariantToInt64(Value, v) then
+      SetInt64Value(Instance, v)
+    else if (k = rkEnumeration) and
+            VariantToText(Value, u) and
+            SetValueText(Instance, u) then
+      // value found from GetEnumNameValue()
+    else
+      exit
+  else if k in rkStringTypes then
+    if VarIsEmptyOrNull(Value) then // otherwise would set 'null' text
+      SetAsString(Instance, '')
+    else if VariantToUtf8(Value, u) then
+      SetAsString(Instance, u)
+    else
+      exit
+  else if k = rkFloat then
+  begin
+    if not VariantToDouble(Value, f) then
+      if Assigned(_Iso8601ToDateTime) and
+         VariantToText(Value, u) then
+        if u = '' then
+          f := 0
+        else
+        begin
+          f := _Iso8601ToDateTime(u);
+          if f = 0 then
+            exit; // not a date
+        end
+      else
+        exit;
+    SetFloatProp(Instance, f);
+  end
+  else if k = rkVariant then
+    SetVariantProp(Instance, Value)
+  else
+    exit;
+  result := true;
+end;
+
+function TRttiProp.SetValueText(Instance: TObject; const Value: RawUtf8): boolean;
+var
+  k: TRttiKind;
+  v: Int64;
+  f: double;
+begin
+  result := false; // invalid or unsupported type
+  if (@self = nil) or
+     (Instance = nil) then
+    exit;
+  k := TypeInfo^.Kind;
+  if k in rkOrdinalTypes then
+    if ToInt64(Value, v) or // ordinal field from number
+       (TypeInfo^.IsBoolean and
+        GetInt64Bool(pointer(Value), v)) then // boolean from true/false/yes/no
+      SetInt64Value(Instance, v)
+    else if Value = '' then
+      exit
+    else if k = rkEnumeration then // enumertate field from text
+    begin
+      v := GetEnumNameValue(TypeInfo, Value, {trimlowcase=}true);
+      if v < 0 then
+        exit; // not a text enum
+      SetOrdProp(Instance, v);
+    end
+    else if k = rkSet then // set field from CSV text
+      SetOrdProp(Instance, GetSetCsvValue(TypeInfo, pointer(Value)))
+    else
+      exit
+  else if k in rkStringTypes then
+    SetAsString(Instance, Value)
+  else if k = rkFloat then
+  begin
+    if not ToDouble(Value, f) then
+      if Value = '' then
+        f := 0
+      else if Assigned(_Iso8601ToDateTime) then
+      begin
+        f := _Iso8601ToDateTime(Value);
+        if f = 0 then
+          exit; // not a date
+      end
+      else
+        exit;
+    SetFloatProp(Instance, f);
+  end
+  else if k = rkVariant then
+    SetVariantProp(Instance, Value) // store as text
+  else
+    exit;
+  result := true;
+end;
+
+function TRttiProp.GetValueText(Instance: TObject): RawUtf8;
+var
+  k: TRttiKind;
+  v: TRttiVarData;
+begin
+  result := '';
+  if (@self = nil) or
+     (Instance = nil) then
+    exit;
+  k := TypeInfo^.Kind;
+  if k in rkOrdinalTypes then
+    Int64ToUtf8(GetInt64Value(Instance), result)
+  else if k in rkStringTypes then
+    GetAsString(Instance, result)
+  else if k = rkFloat then
+    DoubleToStr(GetFloatProp(Instance), result)
+  else if k = rkVariant then
+  begin
+    v.VType := 0;
+    GetVariantProp(Instance, variant(v), {byref=}true);
+    VariantToUtf8(variant(v), result);
+    VarClearProc(v.Data);
+  end;
+end;
+
+function TRttiProp.GetOrdProp(Instance: TObject): Int64;
+type
+  TGetProc = function: Pointer of object; // pointer result is a PtrInt register
+  TGetIndexed = function(Index: integer): Pointer of object;
+var
+  rpc: TRttiPropCall;
+  call: TMethod;
+begin
+  rpc := Getter(Instance, @call);
+  if rpc = rpcField then
+    call.Code := PPointer({%H-}call.Data)^
+  else if TypeInfo^.Kind in [rkDynArray, rkInterface] then
+    raise ERttiException.CreateUtf8(
+      'TRttiProp.GetOrdProp(%) does not support a getter for %',
+      [Instance.ClassType, ToText(TypeInfo^.Kind)^])
+  else if rpc = rpcMethod then
+    call.Code := TGetProc(call)
+  else if rpc = rpcIndexed then
+    call.Code := TGetIndexed(call)(Index)
+  else
+    call.Code := nil; // call.Code is used to store the raw value
+  with TypeInfo^ do
+    if (Kind = rkClass) or
+       (Kind = rkDynArray) or
+       (Kind = rkInterface) then
+      result := PtrInt(call.Code)
+    else
+      result := RTTI_FROM_ORD[RttiOrd](@call.Code);
+end;
+
+procedure TRttiProp.SetOrdProp(Instance: TObject; Value: PtrInt);
+type
+  // on all targets, Value is a register for any RttiOrd size
+  TSetProc = procedure(Value: PtrInt) of object;
+  TSetIndexed = procedure(Index: integer; Value: PtrInt) of object;
+var
+  call: TMethod;
+begin
+  case Setter(Instance, @call) of
+    rpcField:
+      with TypeInfo^ do
+        if (Kind = rkClass) or
+           (Kind = rkDynArray) or
+           (Kind = rkInterface) then
+          PPtrInt({%H-}call.Data)^ := Value
+        else
+          RTTI_TO_ORD[RttiOrd](call.Data, Value);
+    rpcMethod:
+      TSetProc(call)(Value);
+    rpcIndexed:
+      TSetIndexed(call)(Index, Value);
+  end;
+end;
+
+function TRttiProp.GetObjProp(Instance: TObject): TObject;
+type
+  TGetProc = function: TObject of object;
+  TGetIndexed = function(Index: integer): TObject of object;
+var
+  call: TMethod;
+begin
+  case Getter(Instance, @call) of
+    rpcField:
+      result := PObject({%H-}call.Data)^;
+    rpcMethod:
+      result := TGetProc(call);
+    rpcIndexed:
+      result := TGetIndexed(call)(Index);
+  else
+    result := nil;
+  end;
+end;
+
+function TRttiProp.GetDynArrayPropGetter(Instance: TObject): pointer;
+type
+  TGetProc = function: TBytes of object;
+  TGetIndexed = function(Index: integer): TBytes of object;
+var
+  call: TMethod;
+  tmp: TBytes; // we use TBytes but any dynamic array will do
+begin
+  case Getter(Instance, @call) of
+    rpcMethod:
+      tmp := TGetProc({%H-}call);
+    rpcIndexed:
+      tmp := TGetIndexed(call)(Index);
+  end;
+  result := pointer(tmp); // weak copy
+  pointer(tmp) := nil;    // no dec(refcnt)
+end;
+
+function TRttiProp.GetInt64Prop(Instance: TObject): Int64;
+type
+  TGetProc = function: Int64 of object;
+  TGetIndexed = function(Index: integer): Int64 of object;
+var
+  call: TMethod;
+begin
+  case Getter(Instance, @call) of
+    rpcField:
+      result := PInt64({%H-}call.Data)^;
+    rpcMethod:
+      result := TGetProc(call);
+    rpcIndexed:
+      result := TGetIndexed(call)(Index);
+  else
+    result := 0;
+  end;
+end;
+
+procedure TRttiProp.SetInt64Prop(Instance: TObject; const Value: Int64);
+type
+  TSetProc = procedure(Value: Int64) of object;
+  TSetIndexed = procedure(Index: integer; Value: Int64) of object;
+var
+  call: TMethod;
+begin
+  case Setter(Instance, @call) of
+    rpcField:
+      PInt64({%H-}call.Data)^ := Value;
+    rpcMethod:
+      TSetProc(call)(Value);
+    rpcIndexed:
+      TSetIndexed(call)(Index, Value);
+  end;
+end;
+
+procedure TRttiProp.GetLongStrProp(Instance: TObject; var Value: RawByteString);
+var
+  rpc: TRttiPropCall;
+  call: TMethod;
+
+    procedure SubProc(rpc: TRttiPropCall); // avoid try..finally
+    type
+      TGetProc = function: RawByteString of object;
+      TGetIndexed = function(Index: integer): RawByteString of object;
+    begin
+      case rpc of
+        rpcMethod:
+          Value := TGetProc(call);
+        rpcIndexed:
+          Value := TGetIndexed(call)(Index);
+      else
+        Value := '';
+      end;
+    end;
+
+begin
+  rpc := Getter(Instance, @call);
+  if rpc = rpcField then
+    Value := PRawByteString(call.Data)^
+  else
+    SubProc(rpc);
+end;
+
+procedure TRttiProp.SetLongStrProp(Instance: TObject; const Value: RawByteString);
+type
+  TSetProc = procedure(const Value: RawByteString) of object;
+  TSetIndexed = procedure(Index: integer; const Value: RawByteString) of object;
+var
+  call: TMethod;
+begin
+  case Setter(Instance, @call) of
+    rpcField:
+      PRawByteString({%H-}call.Data)^ := Value;
+    rpcMethod:
+      TSetProc(call)(Value);
+    rpcIndexed:
+      TSetIndexed(call)(Index, Value);
+  end;
+end;
+
+procedure TRttiProp.CopyLongStrProp(Source, Dest: TObject);
+var
+  tmp: RawByteString;
+begin
+  GetLongStrProp(Source, tmp);
+  SetLongStrProp(Dest, tmp);
+end;
+
+procedure TRttiProp.GetShortStrProp(Instance: TObject; var Value: RawUtf8);
+type
+  TGetProc = function: ShortString of object;
+  TGetIndexed = function(Index: integer): ShortString of object;
+var
+  call: TMethod;
+  tmp: ShortString;
+begin
+  case Getter(Instance, @call) of
+    rpcField:
+      tmp := PShortString({%H-}call.Data)^;
+    rpcMethod:
+      tmp := TGetProc(call);
+    rpcIndexed:
+      tmp := TGetIndexed(call)(Index);
+  else
+    tmp := '';
+  end;
+  ShortStringToAnsi7String(tmp, Value);
+end; // no SetShortStrProp() by now
+
+procedure TRttiProp.GetWideStrProp(Instance: TObject; var Value: WideString);
+type
+  TGetProc = function: WideString of object;
+  TGetIndexed = function(Index: integer): WideString of object;
+var
+  call: TMethod;
+begin
+  case Getter(Instance, @call) of
+    rpcField:
+      Value := PWideString({%H-}call.Data)^;
+    rpcMethod:
+      Value := TGetProc(call);
+    rpcIndexed:
+      Value := TGetIndexed(call)(Index);
+  else
+    Value := '';
+  end;
+end;
+
+procedure TRttiProp.SetWideStrProp(Instance: TObject; const Value: WideString);
+type
+  TSetProc = procedure(const Value: WideString) of object;
+  TSetIndexed = procedure(Index: integer; const Value: WideString) of object;
+var
+  call: TMethod;
+begin
+  case Setter(Instance, @call) of
+    rpcField:
+      PWideString({%H-}call.Data)^ := Value;
+    rpcMethod:
+      TSetProc(call)(Value);
+    rpcIndexed:
+      TSetIndexed(call)(Index, Value);
+  end;
+end;
+
+{$ifdef HASVARUSTRING}
+
+procedure TRttiProp.GetUnicodeStrProp(Instance: TObject; var Value: UnicodeString);
+var
+  rpc: TRttiPropCall;
+  call: TMethod;
+
+    procedure SubProc(rpc: TRttiPropCall); // avoid try..finally
+    type
+      TGetProc = function: UnicodeString of object;
+      TGetIndexed = function(Index: integer): UnicodeString of object;
+    begin
+      case rpc of
+        rpcMethod:
+          Value := TGetProc(call);
+        rpcIndexed:
+          Value := TGetIndexed(call)(Index);
+      else
+        Value := '';
+      end;
+    end;
+
+begin
+  rpc := Getter(Instance, @call);
+  if rpc = rpcField then
+    Value := PUnicodeString(call.Data)^
+  else
+    SubProc(rpc);
+end;
+
+procedure TRttiProp.SetUnicodeStrProp(Instance: TObject; const Value: UnicodeString);
+type
+  TSetProc = procedure(const Value: UnicodeString) of object;
+  TSetIndexed = procedure(Index: integer; const Value: UnicodeString) of object;
+var
+  call: TMethod;
+begin
+  case Setter(Instance, @call) of
+    rpcField:
+      PUnicodeString({%H-}call.Data)^ := Value;
+    rpcMethod:
+      TSetProc(call)(Value);
+    rpcIndexed:
+      TSetIndexed(call)(Index, Value);
+  end;
+end;
+
+{$endif HASVARUSTRING}
+
+procedure TRttiProp.GetCurrencyProp(Instance: TObject; var Value: currency);
+type
+  TGetProc = function: currency of object;
+  TGetIndexed = function(Index: integer): currency of object;
+var
+  call: TMethod;
+begin
+  case Getter(Instance, @call) of
+    rpcField:
+      Value := PCurrency({%H-}call.Data)^;
+    rpcMethod:
+      Value := TGetProc(call);
+    rpcIndexed:
+      Value := TGetIndexed(call)(Index);
+  else
+    PInt64(@Value)^ := 0;
+  end;
+end;
+
+procedure TRttiProp.SetCurrencyProp(Instance: TObject; const Value: currency);
+type
+  TSetProc = procedure(const Value: currency) of object;
+  TSetIndexed = procedure(Index: integer; const Value: currency) of object;
+var
+  call: TMethod;
+begin
+  case Setter(Instance, @call) of
+    rpcField:
+      PCurrency({%H-}call.Data)^ := Value;
+    rpcMethod:
+      TSetProc(call)(Value);
+    rpcIndexed:
+      TSetIndexed(call)(Index, Value);
+  end;
+end;
+
+function TRttiProp.GetDoubleProp(Instance: TObject): double;
+type
+  TGetProc = function: double of object;
+  TGetIndexed = function(Index: integer): double of object;
+var
+  call: TMethod;
+begin
+  case Getter(Instance, @call) of
+    rpcField:
+      result := unaligned(PDouble({%H-}call.Data)^);
+    rpcMethod:
+      result := TGetProc(call);
+    rpcIndexed:
+      result := TGetIndexed(call)(Index);
+  else
+    result := 0;
+  end;
+end;
+
+procedure TRttiProp.SetDoubleProp(Instance: TObject; Value: Double);
+type
+  TSetProc = procedure(const Value: double) of object;
+  TSetIndexed = procedure(Index: integer; const Value: double) of object;
+var
+  call: TMethod;
+begin
+  case Setter(Instance, @call) of
+    rpcField:
+      unaligned(PDouble({%H-}call.Data)^) := Value;
+    rpcMethod:
+      TSetProc(call)(Value);
+    rpcIndexed:
+      TSetIndexed(call)(Index, Value);
+  end;
+end;
+
+function TRttiProp.GetFloatProp(Instance: TObject): double;
+type
+  TSingleProc = function: Single of object;
+  TSingleIndexed = function(Index: integer): Single of object;
+  TDoubleProc = function: Double of object;
+  TDoubleIndexed = function(Index: integer): Double of object;
+  TExtendedProc = function: Extended of object;
+  TExtendedIndexed = function(Index: integer): Extended of object;
+  TCurrencyProc = function: currency of object;
+  TCurrencyIndexed = function(Index: integer): currency of object;
+var
+  call: TMethod;
+  rf: TRttiFloat;
+begin
+  result := 0;
+  rf := TypeInfo^.RttiFloat;
+  case Getter(Instance, @call) of
+    rpcField:
+      case rf of
+        rfSingle:
+          result := PSingle({%H-}call.Data)^;
+        rfDouble:
+          result := unaligned(PDouble(call.Data)^);
+        rfExtended:
+          result := PExtended(call.Data)^;
+        rfCurr:
+          CurrencyToDouble(PCurrency(call.Data), result);
+      end;
+    rpcMethod:
+      case rf of
+        rfSingle:
+          result := TSingleProc(call);
+        rfDouble:
+          result := TDoubleProc(call);
+        rfExtended:
+          result := TExtendedProc(call);
+        rfCurr:
+          CurrencyToDouble(TCurrencyProc(call), result);
+      end;
+    rpcIndexed:
+      case rf of
+        rfSingle:
+          result := TSingleIndexed(call)(Index);
+        rfDouble:
+          result := TDoubleIndexed(call)(Index);
+        rfExtended:
+          result := TExtendedIndexed(call)(Index);
+        rfCurr:
+          CurrencyToDouble(TCurrencyIndexed(call)(Index), result);
+      end;
+  end;
+end;
+
+procedure TRttiProp.SetFloatProp(Instance: TObject; Value: TSynExtended);
+type
+  TSingleProc = procedure(const Value: Single) of object;
+  TSingleIndexed = procedure(Index: integer; const Value: Single) of object;
+  TDoubleProc = procedure(const Value: double) of object;
+  TDoubleIndexed = procedure(Index: integer; const Value: double) of object;
+  TExtendedProc = procedure(const Value: Extended) of object;
+  TExtendedIndexed = procedure(Index: integer; const Value: Extended) of object;
+  TCurrencyProc = procedure(const Value: currency) of object;
+  TCurrencyIndexed = procedure(Index: integer; const Value: currency) of object;
+var
+  call: TMethod;
+  rf: TRttiFloat;
+begin
+  rf := TypeInfo^.RttiFloat;
+  case Setter(Instance, @call) of
+    rpcField:
+      RTTI_TO_FLOAT[rf]({%H-}call.Data, Value);
+    rpcMethod:
+      case rf of
+        rfSingle:
+          TSingleProc(call)(Value);
+        rfDouble:
+          TDoubleProc(call)(Value);
+        rfExtended:
+          TExtendedProc(call)(Value);
+        rfCurr:
+          TCurrencyProc(call)(DoubleToCurrency(Value));
+      end;
+    rpcIndexed:
+      case rf of
+        rfSingle:
+          TSingleIndexed(call)(Index, Value);
+        rfDouble:
+          TDoubleIndexed(call)(Index, Value);
+        rfExtended:
+          TExtendedIndexed(call)(Index, Value);
+        rfCurr:
+          TCurrencyIndexed(call)(Index, DoubleToCurrency(Value));
+      end;
+  end;
+end;
+
+procedure TRttiProp.GetVariantProp(Instance: TObject; var Result: Variant;
+  SetByRef: boolean);
+var
+  rpc: TRttiPropCall;
+  call: TMethod;
+
+  procedure SubProc(rpc: TRttiPropCall); // avoid try..finally
+  type
+    TGetProc = function: variant of object;
+    TGetIndexed = function(Index: integer): variant of object;
+  begin
+    case rpc of
+      rpcMethod:
+        Result := TGetProc(call);
+      rpcIndexed:
+        Result := TGetIndexed(call)(Index);
+    else
+      SetVariantNull(result);
+    end;
+  end;
+
+begin
+  rpc := Getter(Instance, @call);
+  if rpc <> rpcField then
+    SubProc(rpc)
+  else if not SetVariantUnRefSimpleValue(PVariant(call.Data)^, PVarData(@Result)^) then
+    if SetByRef then
+    begin
+      VarClearAndSetType(Result, varVariantByRef);
+      TVarData(Result).VPointer := call.Data;
+    end
+    else
+      result := PVariant(call.Data)^;
+end;
+
+procedure TRttiProp.SetVariantProp(Instance: TObject; const Value: Variant);
+type
+  TSetProc = procedure(const Value: variant) of object;
+  TSetIndexed = procedure(Index: integer; const Value: variant) of object;
+var
+  call: TMethod;
+  v: PVarData;
+begin
+  v := VarDataFromVariant(Value); // de-reference any varByRef
+  case Setter(Instance, @call) of
+    rpcField:
+      PVariant({%H-}call.Data)^ := PVariant(v)^;
+    rpcMethod:
+      TSetProc(call)(PVariant(v)^);
+    rpcIndexed:
+      TSetIndexed(call)(Index, PVariant(v)^);
+  end;
+end;
+
+function TRttiProp.GetOrdValue(Instance: TObject): Int64;
+begin
+  if (Instance <> nil) and
+     (@self <> nil) and
+     (TypeInfo^.Kind in [rkInteger,
+                         rkEnumeration,
+                         rkSet,
+                         {$ifdef FPC}
+                         rkBool,
+                         {$endif FPC}
+                         rkClass]) then
+    result := GetOrdProp(Instance)
+  else
+    result := -1;
+end;
+
+function TRttiProp.GetInt64Value(Instance: TObject): Int64;
+begin
+  if (Instance <> nil) and
+     (@self <> nil) then
+    case TypeInfo^.Kind of
+      rkInteger,
+      rkEnumeration,
+      {$ifdef FPC}
+      rkBool,
+      {$endif FPC}
+      rkSet,
+      rkChar,
+      rkWChar,
+      rkClass:
+        result := GetOrdProp(Instance);
+      {$ifdef FPC}
+      rkQWord,
+      {$endif FPC}
+      rkInt64:
+        result := GetInt64Prop(Instance);
+    else
+      result := 0;
+    end
+  else
+    result := 0;
+end;
+
+procedure TRttiProp.GetCurrencyValue(Instance: TObject; var Value: currency);
+begin
+  if (Instance <> nil) and
+     (@self <> nil) then
+    with TypeInfo^ do
+      if Kind = rkFloat then
+        if RttiFloat = rfCurr then
+          GetCurrencyProp(Instance, Value)
+        else
+          DoubleToCurrency(GetFloatProp(Instance), Value)
+      else
+        PInt64(@Value)^ := 0
+  else
+    PInt64(@Value)^ := 0;
+end;
+
+function TRttiProp.GetDoubleValue(Instance: TObject): double;
+begin
+  if (Instance <> nil) and
+     (@self <> nil) and
+     (TypeInfo^.Kind = rkFloat) then
+    result := GetFloatProp(Instance)
+  else
+    result := 0;
+end;
+
+procedure TRttiProp.SetDoubleValue(Instance: TObject; const Value: double);
+begin
+  if (Instance <> nil) and
+     (@self <> nil) and
+     (TypeInfo^.Kind = rkFloat) then
+    SetFloatProp(Instance, Value);
+end;
+
+procedure TRttiProp.GetRawByteStringValue(Instance: TObject; var Value: RawByteString);
+begin
+  if (Instance <> nil) and
+     (@self <> nil) and
+     (TypeInfo^.Kind in [{$ifdef FPC}rkLStringOld, {$endif} rkLString]) then
+    GetLongStrProp(Instance, Value)
+  else
+    FastAssignNew(Value, nil);
+end;
+
+procedure TRttiProp.SetOrdValue(Instance: TObject; Value: PtrInt);
+begin
+  if (Instance <> nil) and
+     (@self <> nil) and
+     (TypeInfo^.Kind in [rkInteger, rkEnumeration, rkSet,
+                         {$ifdef FPC} rkBool, {$endif} rkClass]) then
+    SetOrdProp(Instance, Value);
+end;
+
+procedure TRttiProp.SetInt64Value(Instance: TObject; Value: Int64);
+begin
+  if (Instance <> nil) and
+     (@self <> nil) then
+    case TypeInfo^.Kind of
+      rkInteger,
+      rkEnumeration,
+      {$ifdef FPC}
+      rkBool,
+      {$endif FPC}
+      rkSet,
+      rkChar,
+      rkWChar,
+      rkClass:
+        SetOrdProp(Instance, Value);
+      {$ifdef FPC}
+      rkQWord,
+      {$endif FPC}
+      rkInt64:
+        SetInt64Prop(Instance, Value);
+    end;
+end;
+
+{$ifdef HASVARUSTRING}
+
+function TRttiProp.GetUnicodeStrValue(Instance: TObject): UnicodeString;
+begin
+  if (Instance <> nil) and
+     (@self <> nil) and
+     (TypeInfo^.Kind = rkUString) then
+    GetUnicodeStrProp(Instance, result{%H-})
+  else
+    result := '';
+end;
+
+procedure TRttiProp.SetUnicodeStrValue(Instance: TObject; const Value: UnicodeString);
+begin
+  if (Instance <> nil) and
+     (@self <> nil) and
+     (TypeInfo^.Kind = rkUString) then
+    SetUnicodeStrProp(Instance, Value);
+end;
+
+{$endif HASVARUSTRING}
+
+function TRttiProp.GetAsString(Instance: TObject): RawUtf8;
+begin
+  GetAsString(Instance, result);
+end;
+
+function TRttiProp.GetAsString(Instance: TObject; var Value: RawUtf8): boolean;
+var
+  v: PtrInt;
+  WS: WideString;
+  {$ifdef HASVARUSTRING}
+  US: UnicodeString;
+  {$endif HASVARUSTRING}
+begin
+  result := true;
+  case TypeInfo^.Kind of
+    rkChar,
+    rkWChar:
+      begin
+        v := GetOrdProp(Instance);
+        if TypeInfo^.Kind = rkChar then
+          FastSetString(Value, @v, {ansicharcount=}1)
+        else
+          RawUnicodeToUtf8(@v, {widecharcount=}1, Value);
+      end;
+    rkSString:
+      GetShortStrProp(Instance, Value);
+    rkLString:
+      GetLongStrProp(Instance, RawByteString(Value));
+    rkWString:
+      begin
+        GetWideStrProp(Instance, WS);
+        RawUnicodeToUtf8(pointer(WS), length(WS), Value);
+      end;
+    {$ifdef HASVARUSTRING}
+    rkUString:
+      begin
+        GetUnicodeStrProp(Instance, US);
+        RawUnicodeToUtf8(pointer(US), length(US), Value);
+      end;
+    {$endif HASVARUSTRING}
+  else
+    begin
+      Value := '';
+      result := false; // unsupported property
+    end;
+  end;
+end;
+
+function TRttiProp.SetAsString(Instance: TObject; const Value: RawUtf8): boolean;
+var
+  v: PtrInt;
+  P: PUtf8Char;
+  u: pointer; // to avoid a global hidden try..finally
+begin
+  result := true;
+  case TypeInfo^.Kind of
+    rkChar,
+    rkWChar:
+      begin
+        if Value = '' then
+          v := 0
+        else if TypeInfo^.Kind = rkChar then
+          v := ord(Value[1])
+        else
+        begin
+          P := pointer(Value);
+          v := NextUtf8Ucs4(P);
+        end;
+        SetOrdProp(Instance, v);
+      end;
+    rkLString:
+      SetLongStrProp(Instance, Value);
+    rkWString:
+      begin
+        u := nil;
+        try
+          Utf8ToWideString(pointer(Value), length(Value), WideString(u));
+          SetWideStrProp(Instance, WideString(u));
+        finally
+          WideString(u) := '';
+        end;
+      end;
+    {$ifdef HASVARUSTRING}
+    rkUString:
+      begin
+        u := nil;
+        try
+          Utf8DecodeToUnicodeString(pointer(Value), length(Value), UnicodeString(u));
+          SetUnicodeStrProp(Instance, UnicodeString(u));
+        finally
+          UnicodeString(u) := '';
+        end;
+      end;
+    {$endif HASVARUSTRING}
+  else
+    result := false; // unsupported type
+  end;
+end;
+
+function ToText(k: TRttiKind): PShortString;
+begin
+  result := GetEnumName(TypeInfo(TRttiKind), ord(k));
+end;
+
+function ToText(t: TRttiParserType): PShortString;
+begin
+  result := GetEnumName(TypeInfo(TRttiParserType), ord(t));
+end;
+
+function ToText(w: TWellKnownSid): PShortString;
+begin
+  result := GetEnumName(TypeInfo(TWellKnownSid), ord(w));
+end;
+
+
+{ **************** Published Class Properties and Methods RTTI }
+
+function GetRttiClass(RttiClass: TClass): PRttiClass;
+begin
+  result := PRttiInfo(PPointer(PAnsiChar(RttiClass) + vmtTypeInfo)^)^.RttiClass;
+end;
+
+function ClassHasPublishedFields(ClassType: TClass): boolean;
+var
+  cp: PRttiProps;
+begin
+  result := true;
+  while ClassType <> nil do
+  begin
+    cp := GetRttiProps(ClassType);
+    if cp = nil then
+      break; // no RTTI information (e.g. reached TObject level)
+    if cp^.PropCount > 0 then
+      exit;
+    ClassType := GetClassParent(ClassType);
+  end;
+  result := false;
+end;
+
+function ClassHierarchyWithField(ClassType: TClass): TClassDynArray;
+
+  procedure InternalAdd(C: TClass; var list: TClassDynArray);
+  var
+    P: PRttiProps;
+  begin
+    if C = nil then
+      exit;
+    InternalAdd(GetClassParent(C), list);
+    P := GetRttiProps(C);
+    if (P <> nil) and
+       (P^.PropCount > 0) then
+      PtrArrayAdd(list, pointer(C));
+  end;
+
+begin
+  result := nil;
+  InternalAdd(ClassType, result);
+end;
+
+function ClassFieldAllProps(ClassType: TClass; Types: TRttiKinds): PRttiPropDynArray;
+var
+  CP: PRttiProps;
+  P: PRttiProp;
+  i, n: integer;
+begin
+  n := 0;
+  result := nil;
+  while ClassType <> nil do
+  begin
+    CP := GetRttiProps(ClassType);
+    if CP = nil then
+      break; // no RTTI information (e.g. reached TObject level)
+    if CP^.PropCount > 0 then
+    begin
+      SetLength(result, n + CP^.PropCount);
+      P := CP^.PropList;
+      for i := 1 to CP^.PropCount do
+      begin
+        if P^.TypeInfo^.Kind in Types then
+        begin
+          result[n] := P;
+          inc(n);
+        end;
+        P := P^.Next
+      end;
+    end;
+    ClassType := GetClassParent(ClassType);
+  end;
+  SetLength(result,n);
+end;
+
+function ClassFieldNamesAllProps(ClassType: TClass; IncludePropType: boolean;
+  Types: TRttiKinds): TRawUtf8DynArray;
+var
+  props: PRttiPropDynArray;
+  n, i: PtrInt;
+begin
+  result := nil;
+  props := ClassFieldAllProps(ClassType, Types); // recursive in-order list
+  n := length(props);
+  SetLength(result, n);
+  for i := 0 to n - 1 do
+    with props[i]^ do
+      if IncludePropType then
+        FormatUtf8('%: %', [Name^, TypeInfo^.Name^], result[i])
+      else
+        ShortStringToAnsi7String(Name^, result[i]);
+end;
+
+function ClassFieldNamesAllPropsAsText(ClassType: TClass; IncludePropType: boolean;
+  Types: TRttiKinds): RawUtf8;
+begin
+  result := RawUtf8ArrayToCsv(
+    ClassFieldNamesAllProps(ClassType, IncludePropType, Types), ', ');
+end;
+
+function ClassFieldProp(ClassType: TClass; const PropName: ShortString): PRttiProp;
+begin
+  if ClassType <> nil then
+    result := GetRttiProps(ClassType)^.FieldProp(PropName)
+  else
+    result := nil;
+end;
+
+function ClassFieldPropWithParents(aClassType: TClass; const aPropName: ShortString;
+  aCaseSensitive: boolean): PRttiProp;
+var
+  n, i: integer;
+begin
+  while aClassType <> nil do
+  begin
+    n := GetRttiProp(aClassType, result);
+    if n <> 0 then
+      if aCaseSensitive then
+        for i := 1 to n do
+          if result^.Name^ = aPropName then
+            exit
+          else
+            result := result^.Next
+      else
+        for i := 1 to n do
+          if IdemPropName(result^.Name^, @aPropName[1], ord(aPropName[0])) then
+            exit
+          else
+            result := result^.Next;
+    aClassType := GetClassParent(aClassType);
+  end;
+  result := nil;
+end;
+
+function ClassFieldPropWithParentsFromUtf8(aClassType: TClass; PropName: PUtf8Char;
+  PropNameLen: integer; aCaseSensitive: boolean): PRttiProp;
+var
+  n, i: integer;
+begin
+  if PropNameLen <> 0 then
+    while aClassType <> nil do
+    begin
+      n := GetRttiProp(aClassType, result);
+      if n <> 0 then
+        if aCaseSensitive then
+          for i := 1 to n do
+            if (result^.Name^[0] = AnsiChar(PropNameLen)) and
+               CompareMemFixed(@result^.Name^[1], PropName, PropNameLen) then
+              exit
+            else
+              result := result^.Next
+        else
+          for i := 1 to n do
+            if IdemPropName(result^.Name^, PropName, PropNameLen) then
+              exit
+            else
+              result := result^.Next;
+      aClassType := GetClassParent(aClassType);
+    end;
+  result := nil;
+end;
+
+function ClassFieldPropWithParentsFromClassType(aClassType,
+  aSearchedClassType: TClass): PRttiProp;
+var
+  i: integer;
+begin
+  if aSearchedClassType <> nil then
+    while aClassType <> nil do
+    begin
+      for i := 1 to GetRttiProp(aClassType, result) do
+        with result^.TypeInfo^ do
+          if (Kind = rkClass) and
+             (RttiNonVoidClass^.RttiClass = aSearchedClassType) then
+            exit
+          else
+            result := result^.Next;
+      aClassType := GetClassParent(aClassType);
+    end;
+  result := nil;
+end;
+
+function ClassFieldPropWithParentsInheritsFromClassType(aClassType,
+  aSearchedClassType: TClass): PRttiProp;
+var
+  i: integer;
+begin
+  if aSearchedClassType <> nil then
+    while aClassType <> nil do
+    begin
+      for i := 1 to GetRttiProp(aClassType, result) do
+        with result^.TypeInfo^ do
+          if (Kind = rkClass) and
+             InheritsFrom(aSearchedClassType) then
+            exit
+          else
+            result := result^.Next;
+      aClassType := GetClassParent(aClassType);
+    end;
+  result := nil;
+end;
+
+function ClassFieldPropWithParentsFromClassOffset(aClassType: TClass;
+  aSearchedOffset: pointer): PRttiProp;
+var
+  i: integer;
+begin
+  if aSearchedOffset <> nil then
+    while aClassType <> nil do
+    begin
+      for i := 1 to GetRttiProp(aClassType, result) do
+        if result^.GetFieldAddr(nil) = aSearchedOffset then
+          exit
+        else
+          result := result^.Next;
+      aClassType := GetClassParent(aClassType);
+    end;
+  result := nil;
+end;
+
+function ClassFieldInstance(Instance: TObject; const PropName: ShortString;
+  PropClassType: TClass; out PropInstance): boolean;
+var
+  P: PRttiProp;
+begin
+  result := false;
+  if Instance = nil then
+    exit;
+  P := ClassFieldPropWithParents(PPointer(Instance)^, PropName);
+  if P = nil then
+    exit;
+  with P^.TypeInfo^ do
+    if (Kind <> rkClass) or
+       not InheritsFrom(PropClassType) then
+      exit;
+  TObject(PropInstance) := P^.GetObjProp(Instance);
+  result := true;
+end;
+
+function ClassFieldInstance(Instance: TObject; PropClassType: TClass;
+  out PropInstance): boolean;
+var
+  P: PRttiProp;
+begin
+  result := false;
+  if (Instance = nil) or
+     (PropClassType = nil) then
+    exit;
+  P := ClassFieldPropWithParentsFromClassType(PPointer(Instance)^, PropClassType);
+  if P = nil then
+    exit;
+  TObject(PropInstance) := P^.GetObjProp(Instance);
+  result := true;
+end;
+
+function ClassFieldInt64(Instance: TObject; const PropName: ShortString;
+  out PropValue: Int64): boolean;
+var
+  P: PRttiProp;
+begin
+  result := false;
+  if Instance = nil then
+    exit;
+  P := ClassFieldPropWithParents(PPointer(Instance)^, PropName);
+  if P = nil then
+    exit;
+  PropValue := P^.GetInt64Value(Instance);
+  result := true;
+end;
+
+function ClassFieldInstances(Instance: TObject; PropClassType: TClass): TObjectDynArray;
+var
+  nested: PRttiPropDynArray;
+  i: PtrInt;
+begin
+  result := nil;
+  if (Instance = nil) or
+     (PropClassType = nil) then
+    exit;
+  nested := ClassFieldAllProps(PPointer(Instance)^, [rkClass]);
+  for i := 0 to high(nested) do
+    with nested[i]^ do
+      if TypeInfo^.InheritsFrom(PropClassType) then
+        ObjArrayAdd(result, GetObjProp(Instance));
+end;
+
+function ClassFieldPropInstanceMatchingClass(
+  aSearchedInstance: TObject; aSearchedClassType: TClass): TObject;
+var
+  P: PRttiProp;
+begin
+  result := aSearchedInstance;
+  if (aSearchedInstance = nil) or
+     aSearchedInstance.InheritsFrom(aSearchedClassType) then
+    exit;
+  P := ClassFieldPropWithParentsFromClassType(
+    PPointer(aSearchedInstance)^, aSearchedClassType);
+  if P <> nil then
+  begin
+    result := P^.GetObjProp(aSearchedInstance);
+    if result = nil then
+      result := aSearchedInstance;
+  end;
+end;
+
+function ClassFieldCountWithParents(ClassType: TClass; onlyWithoutGetter: boolean): integer;
+var
+  cp: PRttiProps;
+  p: PRttiProp;
+  i: integer;
+begin
+  result := 0;
+  while ClassType <> nil do
+  begin
+    cp := GetRttiProps(ClassType);
+    if cp = nil then
+      break; // no RTTI information (e.g. reached TObject level)
+    p := cp^.PropList;
+    for i := 1 to cp^.PropCount do
+    begin
+      if (not onlyWithoutGetter) or
+         p^.GetterIsField then
+        inc(result);
+      p := p^.Next;
+    end;
+    ClassType := GetClassParent(ClassType);
+  end;
+end;
+
+
+{ *************** Enumerations RTTI }
+
+function GetEnumType(aTypeInfo: PRttiInfo; out List: PShortString): integer;
+begin
+  with aTypeInfo^.EnumBaseType^ do
+  begin
+    List := NameList;
+    result := MaxValue;
+  end;
+end;
+
+function GetEnumNameTrimed(aTypeInfo: PRttiInfo; aIndex: integer): RawUtf8;
+begin
+  result := TrimLeftLowerCaseShort(GetEnumName(aTypeInfo, aIndex));
+end;
+
+function GetEnumNameUnCamelCase(aTypeInfo: PRttiInfo; aIndex: integer): RawUtf8;
+begin
+  result := UnCamelCase(GetEnumNameTrimed(aTypeInfo, aIndex));
+end;
+
+procedure GetEnumNames(aTypeInfo: PRttiInfo; aDest: PPShortString);
+var
+  info: PRttiEnumType;
+  p: PShortString;
+  i: PtrInt;
+begin
+  info := aTypeInfo^.EnumBaseType;
+  if info <> nil then
+  begin
+    p := info^.NameList;
+    for i := info^.MinValue to info^.MaxValue do
+    begin
+      aDest^ := p;
+      p := @PByteArray(p)^[ord(p^[0]) + 1];
+      inc(aDest);
+    end;
+  end;
+end;
+
+procedure GetEnumTrimmedNames(aTypeInfo: PRttiInfo; aDest: PRawUtf8);
+var
+  info: PRttiEnumType;
+  p: PShortString;
+  i: PtrInt;
+begin
+  info := aTypeInfo^.EnumBaseType;
+  if info <> nil then
+  begin
+    p := info^.NameList;
+    for i := info^.MinValue to info^.MaxValue do
+    begin
+      aDest^ := TrimLeftLowerCaseShort(p);
+      p := @PByteArray(p)^[ord(p^[0]) + 1];
+      inc(aDest);
+    end;
+  end;
+end;
+
+function GetEnumTrimmedNames(aTypeInfo: PRttiInfo): TRawUtf8DynArray;
+begin
+  aTypeInfo^.EnumBaseType^.GetEnumNameAll(result{%H-}, {trim=}true);
+end;
+
+function GetEnumNameValue(aTypeInfo: PRttiInfo; aValue: PUtf8Char;
+  aValueLen: PtrInt; AlsoTrimLowerCase: boolean): integer;
+begin
+  result := aTypeInfo^.EnumBaseType^.
+    GetEnumNameValue(aValue, aValueLen, AlsoTrimLowerCase);
+end;
+
+function GetEnumNameValueTrimmed(aTypeInfo: PRttiInfo; aValue: PUtf8Char;
+  aValueLen: PtrInt): integer;
+begin
+  result := aTypeInfo^.EnumBaseType^.
+    GetEnumNameValueTrimmed(aValue, aValueLen, {casesensitive=}false);
+end;
+
+function GetEnumNameValueTrimmedExact(aTypeInfo: PRttiInfo; aValue: PUtf8Char;
+  aValueLen: PtrInt): integer;
+begin
+  result := aTypeInfo^.EnumBaseType^.
+    GetEnumNameValueTrimmed(aValue, aValueLen, {casesensitive=}true);
+end;
+
+function GetEnumNameValue(aTypeInfo: PRttiInfo; const aValue: RawUtf8;
+  AlsoTrimLowerCase: boolean): integer;
+begin
+  result := aTypeInfo^.EnumBaseType^.
+    GetEnumNameValue(pointer(aValue), length(aValue), AlsoTrimLowerCase);
+end;
+
+procedure SetEnumFromOrdinal(aTypeInfo: PRttiInfo; out Value; Ordinal: PtrUInt);
+begin
+  aTypeInfo^.EnumBaseType^.SetEnumFromOrdinal(Value, Ordinal);
+end;
+
+function GetSetName(aTypeInfo: PRttiInfo; const value): RawUtf8;
+begin
+  result := aTypeInfo^.SetEnumType^.EnumBaseType.GetSetName(value);
+end;
+
+procedure GetSetNameShort(aTypeInfo: PRttiInfo; const value;
+  out result: ShortString; trimlowercase: boolean);
+var
+  info: PRttiEnumType;
+  PS: PShortString;
+  i: PtrInt;
+begin
+  result := '';
+  info := aTypeInfo^.SetEnumType;
+  if (info = nil) or
+     (@value = nil) then
+    exit;
+  PS := info^.EnumBaseType.NameList;
+  for i := info^.MinValue to info^.MaxValue do
+  begin
+    if GetBitPtr(@value, i) then
+      AppendShortComma(@PS^[1], PByte(PS)^, result, trimlowercase);
+    inc(PByte(PS), PByte(PS)^ + 1); // next
+  end;
+  if result[0] <> #0 then
+    dec(result[0]);
+end;
+
+procedure SetNamesValue(SetNames: PShortString; MinValue, MaxValue: integer;
+  Value: PUtf8Char; ValueLen: PtrInt; var Result: QWord);
+var
+  i: integer;
+begin
+  if (Value = nil) or
+     (ValueLen = 0) then
+    exit;
+  if Value^ = '*' then
+  begin
+    if MaxValue < 32 then
+      Result := ALLBITS_CARDINAL[MaxValue + 1]
+    else
+      Result := QWord(-1);
+    exit;
+  end;
+  if MaxValue > 63 then
+    MaxValue := 63; // no need to search more than the Result number of bits
+  if Value^ in ['a'..'z'] then
+    i := FindShortStringListExact(SetNames, MaxValue, Value, ValueLen)
+  else
+    i := -1;
+  if i < 0 then
+    i := FindShortStringListTrimLowerCase(SetNames, MaxValue, Value, ValueLen);
+  if i >= MinValue then
+    SetBitPtr(@Result, i);
+  // unknown enum names (i=-1) would just be ignored
+end;
+
+function GetSetCsvValue(aTypeInfo: PRttiInfo; Csv: PUtf8Char;
+  Sep: AnsiChar): QWord;
+var
+  v: shortstring;
+  names: PShortString;
+  min, max: integer;
+begin
+  result := 0;
+  if (aTypeInfo <> nil) and
+     (aTypeInfo^.Kind = rkSet) and
+     (aTypeInfo^.SetEnumType(names, min, max) <> nil) then
+    while Csv <> nil do
+    begin
+      GetNextItemShortString(Csv, @v, Sep);
+      SetNamesValue(names, min, max, @v[1], ord(v[0]), result);
+    end;
+end;
+
+procedure GetCaptionFromTrimmed(PS: PShortString; var result: string);
+var
+  tmp: array[byte] of AnsiChar;
+  L: integer;
+begin
+  L := ord(PS^[0]);
+  inc(PByte(PS));
+  while (L > 0) and
+        (PS^[0] in ['a'..'z']) do
+  begin
+    inc(PByte(PS));
+    dec(L);
+  end;
+  tmp[L] := #0; // as expected by GetCaptionFromPCharLen/UnCamelCase
+  if L > 0 then
+    MoveFast(PS^, tmp, L);
+  GetCaptionFromPCharLen(tmp, result);
+end;
+
+procedure GetEnumCaptions(aTypeInfo: PRttiInfo; aDest: PString);
+var
+  MinValue, MaxValue, i: integer;
+  res: PShortString;
+begin
+  aTypeInfo^.EnumBaseType(res, MinValue, MaxValue);
+  if res <> nil then
+    for i := MinValue to MaxValue do
+    begin
+      GetCaptionFromTrimmed(res, aDest^);
+      inc(PByte(res), PByte(res)^ + 1); // next
+      inc(aDest);
+    end;
+end;
+
+function GetCaptionFromEnum(aTypeInfo: PRttiInfo; aIndex: integer): string;
+begin
+  GetCaptionFromTrimmed(GetEnumName(aTypeInfo, aIndex), result{%H-});
+end;
+
+function GetDisplayNameFromClass(C: TClass): RawUtf8;
+var
+  name: PShortString;
+  totrim: integer;
+begin
+  if C = nil then
+  begin
+    result := '';
+    exit;
+  end;
+  name := ClassNameShort(C);
+  totrim := 0;
+  if name^[0] > #4 then
+    // fast case-insensitive compare
+    case PInteger(@name^[1])^ and $DFDFDFDF of
+      {$ifndef PUREMORMOT2}
+      // backward compatibility trim of left-sided TSql* or TSqlRecord*
+      ord('T') + ord('S') shl 8 + ord('Q') shl 16 + ord('L') shl 24:
+        if (name^[0] <= #10) or
+           (PInteger(@name^[5])^ and $DFDFDFDF <>
+            ord('R') + ord('E') shl 8 + ord('C') shl 16 + ord('O') shl 24) or
+           (PWord(@name^[9])^ and $DFDF <> ord('R') + ord('D')shl 8) then
+          totrim := 4
+        else
+          totrim := 10;
+      {$endif PUREMORMOT2}
+      // trim left-sided TOrm* and TSyn* naming conventions
+      ord('T') + ord('O') shl 8 + ord('R') shl 16 + ord('M') shl 24,
+      ord('T') + ord('S') shl 8 + ord('Y') shl 16 + ord('N') shl 24:
+        totrim := 4;
+    end;
+  if (totrim = 0) and
+     (name^[1] = 'T') then
+    // trim left-sided T* from regular Delphi/FPC type
+    totrim := 1;
+  FastSetString(result, @name^[totrim + 1], ord(name^[0]) - totrim);
+end;
+
+function GetCaptionFromClass(C: TClass): string;
+var
+  tmp: RawUtf8;
+  P: PUtf8Char;
+begin
+  if C = nil then
+    result := ''
+  else
+  begin
+    tmp := ToText(C);
+    P := pointer(tmp);
+    if IdemPChar(P, 'TSQL') or
+       IdemPChar(P, 'TORM') or
+       IdemPChar(P, 'TSYN') then
+      inc(P, 4)
+    else if P^ = 'T' then
+       inc(P);
+    GetCaptionFromPCharLen(P, result);
+  end;
+end;
+
+function ToText(cmd: TParseCommands): ShortString;
+begin
+  if cmd = [] then
+    result[0] := #0
+  else
+    GetSetNameShort(TypeInfo(TParseCommands), cmd, result, {trim=}true);
+end;
+
+
+{ ***************** IInvokable Interface RTTI }
+
+procedure TGetRttiInterface.AddMethod(const aMethodName: ShortString;
+  aParamCount: integer; aKind: TMethodKind);
+var
+  i: PtrInt;
+begin
+  CurrentMethod := @Definition.Methods[MethodCount];
+  ShortStringToAnsi7String(aMethodName, CurrentMethod^.Name);
+  for i := 0 to MethodCount - 1 do
+    if PropNameEquals(Definition.Methods[i].Name, CurrentMethod^.Name) then
+      RaiseError('duplicated method name', []);
+  CurrentMethod^.HierarchyLevel := Level;
+  if aKind = mkFunction then
+    inc(aParamCount);
+  SetLength(CurrentMethod^.Args, aParamCount);
+  CurrentMethod^.IsFunction := aKind = mkFunction;
+  inc(MethodCount);
+  ArgCount := 0;
+end;
+
+procedure TGetRttiInterface.AddArgument(aParamName, aTypeName: PShortString;
+  aInfo: PRttiInfo; aFlags: TParamFlags);
+var
+  a: PRttiMethodArg;
+begin
+  a := @CurrentMethod^.Args[ArgCount];
+  inc(ArgCount);
+  if {$ifdef FPC} pfSelf in aFlags {$else} ArgCount = 1 {$endif} then
+    a^.ParamName := @PSEUDO_SELF_NAME
+  else if aParamName = nil then
+  begin
+    a^.ParamName := @PSEUDO_RESULT_NAME;
+    include(aFlags, pfOut); // result is an "out"
+  end
+  else
+    a^.ParamName := aParamName;
+  a^.TypeInfo := aInfo;
+  if aTypeName = nil then
+    aTypeName := aInfo^.Name;
+  a^.TypeName := aTypeName;
+  if ArgCount > 1 then
+    if aInfo^.Kind in rkRecordOrDynArrayTypes then
+    begin
+      if aFlags * [pfConst, pfVar, pfOut] = [] then
+        RaiseError('%: % parameter should be declared as const, var or out',
+          [a^.ParamName^, aTypeName^]);
+    end
+    else if aInfo^.Kind = rkInterface then
+      if Rtti.FindType(aInfo).HasClassNewInstance then
+      begin // e.g. IDocList/IDocDict with custom JSON serialization
+        if aFlags * [pfConst, pfVar, pfOut] = [] then
+          RaiseError('%: % parameter should be declared as const, var or out',
+            [a^.ParamName^, aTypeName^])
+      end
+      else if not (pfConst in aFlags) then
+        RaiseError('%: % parameter should be declared as const',
+          [a^.ParamName^, aTypeName^]);
+  if aParamName = nil then
+    a^.Direction := rmdResult
+  else if pfVar in aFlags then
+    a^.Direction := rmdVar
+  else if pfOut in aFlags then
+    a^.Direction := rmdOut;
+end;
+
+procedure TGetRttiInterface.RaiseError(const Format: RawUtf8;
+  const Args: array of const);
+var
+  m: RawUtf8;
+begin
+  if CurrentMethod <> nil then
+    m := '.' + CurrentMethod^.Name;
+  raise ERttiException.CreateUtf8('GetRttiInterface(%%) failed - %',
+    [Definition.Name, {%H-}m, FormatUtf8(Format, Args)]);
+end;
+
+function GetRttiInterface(aTypeInfo: PRttiInfo;
+  out aDefinition: TRttiInterface): integer;
+var
+  getter: TGetRttiInterface;
+begin
+  getter := TGetRttiInterface.Create;
+  try
+    getter.AddMethodsFromTypeInfo(pointer(aTypeInfo));
+    aDefinition := getter.Definition;
+  finally
+    getter.Free;
+  end;
+  result := length(aDefinition.Methods);
+end;
+
+function GetInterfaceFromEntry(Instance: TObject; Entry: PInterfaceEntry;
+  out Obj): boolean;
+begin
+  result := false;
+  pointer(Obj) := nil;
+  if Entry <> nil then
+    if InterfaceEntryIsStandard(Entry) then
+    begin
+      // fast interface retrieval from the interface field instance
+      pointer(Obj) := pointer(PAnsiChar(Instance) + Entry^.IOffset);
+      if pointer(Obj) = nil then
+         exit;
+      IInterface(Obj)._AddRef;
+      result := true;
+    end
+    else
+      // there is a getter method -> use slower but safe RTL method
+      result := Instance.GetInterface(Entry^.IID{$ifdef FPC}^{$endif}, Obj);
+end;
+
+function GetRttiClassGuid(aClass: TClass): PGuidDynArray;
+var
+  T: PInterfaceTable;
+  n, i: PtrInt;
+begin
+  result := nil;
+  n := 0;
+  while aClass <> nil do
+  begin
+    T := aClass.GetInterfaceTable;
+    if (T <> nil) and
+       (T^.EntryCount > 0) then
+    begin
+      SetLength(result, length(result) + PtrInt(T^.EntryCount));
+      for i := 0 to T^.EntryCount - 1 do
+      begin
+        result[n] := {$ifdef ISDELPHI}@{$endif}T^.Entries[i].IID;
+        inc(n);
+      end;
+    end;
+    aClass := GetClassParent(aClass);
+  end;
+end;
+
+
+{ ************* Efficient Dynamic Arrays and Records Process }
+
+// defined here for proper inlining in code below
+function TRttiCustomList.RegisterType(Info: PRttiInfo): TRttiCustom;
+begin
+  if Info <> nil then
+  begin
+    result := FindType(Info);
+    if result = nil then
+      result := DoRegister(Info);
+  end
+  else
+    result := nil;
+end;
+
+procedure VariantDynArrayClear(var Value: TVariantDynArray);
+begin
+  FastDynArrayClear(@Value, TypeInfo(variant));
+end;
+
+procedure RawUtf8DynArrayClear(var Value: TRawUtf8DynArray);
+begin
+  FastDynArrayClear(@Value, TypeInfo(RawUtf8));
+end;
+
+function IsRawUtf8DynArray(Info: PRttiInfo): boolean;
+var
+  r: TRttiCustom;
+begin
+  r := Rtti.RegisterType(Info);
+  if r <> nil then
+    r := r.ArrayRtti;
+  result := (r <> nil) and
+            (r.Parser = ptRawUtf8) and
+            (r.Cache.CodePage = CP_UTF8); // properly detected on Delphi 7/2007
+end;
+
+procedure RecordClearSeveral(v: PAnsiChar; info: PRttiInfo; n: integer);
+var
+  fields: TRttiRecordManagedFields;
+  f: PRttiRecordField;
+  p: PRttiInfo;
+  i: PtrInt;
+  fin: PRttiFinalizers;
+begin
+  info.RecordManagedFields(fields); // retrieve RTTI once for n items
+  if fields.Count = 0 then
+    exit;
+  fin := @RTTI_FINALIZE;
+  repeat
+    f := fields.Fields;
+    i := fields.Count;
+    repeat
+      p := f^.{$ifdef HASDIRECTTYPEINFO}TypeInfo{$else}TypeInfoRef^{$endif};
+      {$ifdef FPC_OLDRTTI}
+      if Assigned(fin[p^.Kind]) then
+      {$endif FPC_OLDRTTI}
+        fin[p^.Kind](v + f^.Offset, p);
+      inc(f);
+      dec(i);
+    until i = 0;
+    inc(v, fields.Size);
+    dec(n);
+  until n = 0;
+end;
+
+procedure StringClearSeveral(v: PPointer; n: PtrInt);
+var
+  p: PStrRec;
+begin
+  repeat
+    p := v^;
+    if p <> nil then
+    begin
+      v^ := nil;
+      dec(p);
+      if (p^.refCnt >= 0) and
+         StrCntDecFree(p^.refCnt) then
+        Freemem(p); // works for both rkLString + rkUString
+    end;
+    inc(v);
+    dec(n);
+  until n = 0;
+end;
+
+procedure FastFinalizeArray(Value: PPointer; ElemTypeInfo: PRttiInfo;
+  Count: integer);
+var
+  fin: TRttiFinalizer;
+begin
+  // caller ensured ElemTypeInfo<>nil and Count>0
+  case ElemTypeInfo^.Kind of
+    {$ifdef FPC}rkObject,{$else}{$ifdef UNICODE}rkMRecord,{$endif}{$endif}
+    rkRecord:
+      // retrieve ElemTypeInfo.RecordManagedFields once
+      RecordClearSeveral(pointer(Value), ElemTypeInfo, Count);
+    {$ifdef FPC}
+    rkLStringOld,
+    {$endif FPC}
+    {$ifdef HASVARUSTRING}
+    rkUString,
+    {$endif HASVARUSTRING}
+    rkLString:
+      // optimized loop for AnsiString / UnicodeString (PStrRec header)
+      StringClearSeveral(pointer(Value), Count);
+    rkVariant:
+      // from mormot.core.variants - supporting custom variants
+      // or at least from mormot.core.base calling inlined VarClear()
+      VariantClearSeveral(pointer(Value), Count);
+    else
+      begin
+        // regular finalization
+        fin := RTTI_FINALIZE[ElemTypeInfo^.Kind];
+        if Assigned(fin) then  // e.g. rkWString, rkArray, rkDynArray
+          repeat
+            inc(PByte(Value), fin(PByte(Value), ElemTypeInfo));
+            dec(Count);
+          until Count = 0;
+      end;
+  end;
+end;
+
+procedure FastDynArrayClear(Value: PPointer; ElemInfo: PRttiInfo);
+var
+  p: PDynArrayRec;
+begin
+  if Value = nil then
+    exit;
+  p := Value^;
+  if p = nil then
+    exit;
+  dec(p);
+  if (p^.refCnt >= 0) and
+     DACntDecFree(p^.refCnt) then
+  begin
+    if ElemInfo <> nil then
+      FastFinalizeArray(Value^, ElemInfo, p^.length);
+    Freemem(p);
+  end;
+  Value^ := nil;
+end;
+
+function FastRecordClear(Value: pointer; Info: PRttiInfo): PtrInt;
+var
+  fields: TRttiRecordManagedFields;
+  f: PRttiRecordField;
+  p: PRttiInfo;
+  n: PtrInt;
+  fin: PRttiFinalizers;
+begin
+  // caller ensured Info is indeed a record/object
+  Info.RecordManagedFields(fields);
+  n := fields.Count;
+  if n > 0 then
+  begin
+    fin := @RTTI_FINALIZE;
+    f := fields.Fields;
+    repeat
+      p := f^.{$ifdef HASDIRECTTYPEINFO}TypeInfo{$else}TypeInfoRef^{$endif};
+      {$ifdef FPC_OLDRTTI}
+      if Assigned(fin[p^.Kind]) then
+      {$endif FPC_OLDRTTI}
+        fin[p^.Kind](PAnsiChar(Value) + f^.Offset, p);
+      inc(f);
+      dec(n);
+    until n = 0;
+  end;
+  result := fields.Size;
+end;
+
+procedure RecordZero(Dest: pointer; Info: PRttiInfo);
+begin
+  if Info^.Kind in rkRecordTypes then
+    FillCharFast(Dest^, FastRecordClear(Dest, Info), 0);
+end;
+
+procedure RecordCopy(var Dest; const Source; Info: PRttiInfo);
+begin
+  if Info^.Kind in rkRecordTypes then
+    RTTI_MANAGEDCOPY[rkRecord](@Dest, @Source, Info);
+end;
+
+procedure _RecordCopySeveral(Dest, Source: PAnsiChar; n: PtrInt; Info: PRttiInfo);
+var
+  fields: TRttiRecordManagedFields;
+  f: PRttiRecordField;
+  p: PRttiInfo;
+  i, offset: PtrUInt;
+begin
+  Info^.RecordManagedFields(fields); // retrieve RTTI once for all items
+  repeat
+    i := fields.Count;
+    offset := 0;
+    if i > 0 then
+    begin
+      f := fields.Fields;
+      repeat
+        p := f^.{$ifdef HASDIRECTTYPEINFO}TypeInfo{$else}TypeInfoRef^{$endif};
+        {$ifdef FPC_OLDRTTI}
+        if p^.Kind in rkManagedTypes then
+        {$endif FPC_OLDRTTI}
+        begin
+          offset := f^.Offset - offset;
+          if offset <> 0 then
+          begin
+            MoveFast(Source^, Dest^, offset);
+            inc(Source, offset);
+            inc(Dest, offset);
+          end;
+          offset := RTTI_MANAGEDCOPY[p^.Kind](Dest, Source, p);
+          inc(Source, offset);
+          inc(Dest, offset);
+          inc(offset, f^.Offset);
+        end;
+        inc(f);
+        dec(i);
+      until i = 0;
+    end;
+    offset := PtrUInt(fields.Size) - offset;
+    if offset <> 0 then
+    begin
+      MoveFast(Source^, Dest^, offset);
+      inc(Source, offset);
+      inc(Dest, offset);
+    end;
+    dec(n);
+  until n = 0;
+end;
+
+procedure CopySeveral(Dest, Source: PByte; SourceCount: PtrInt;
+  ItemInfo: PRttiInfo; ItemSize: PtrInt);
+var
+  cop: TRttiCopier;
+  elemsize: PtrInt;
+label
+  raw;
+begin
+  if SourceCount > 0 then
+    if ItemInfo = nil then // unmanaged items
+raw:  MoveFast(Source^, Dest^, ItemSize * SourceCount)
+    else if ItemInfo^.Kind in rkRecordTypes then
+      // retrieve record/object RTTI once for all items
+      _RecordCopySeveral(pointer(Dest), pointer(Source), SourceCount, ItemInfo)
+    else
+    begin
+      // loop the TRttiCopier function over all items
+      cop := RTTI_MANAGEDCOPY[ItemInfo^.Kind];
+      if Assigned(cop) then
+        repeat
+          elemsize := cop(Dest, Source, ItemInfo);
+          inc(Source, elemsize);
+          inc(Dest, elemsize);
+          dec(SourceCount);
+        until SourceCount = 0
+      else
+        goto raw;
+    end;
+end;
+
+function DynArrayNew(Dest: PPointer; Count, ItemSize: PtrInt): pointer;
+begin
+  result := AllocMem(Count * ItemSize +  SizeOf(TDynArrayRec));
+  PDynArrayRec(result)^.refCnt := 1;
+  PDynArrayRec(result)^.length := Count;
+  inc(PDynArrayRec(result));
+  Dest^ := result;
+end;
+
+function DynArrayGrow(Dest: PPointer; Count, ItemSize: PtrInt): PAnsiChar;
+var
+  old: PtrInt;
+begin
+  result := Dest^;
+  dec(PDynArrayRec(result));
+  ReallocMem(result, (Count * ItemSize) + SizeOf(TDynArrayRec));
+  old := PDynArrayRec(result)^.length;
+  PDynArrayRec(result)^.length := Count;
+  inc(PDynArrayRec(result));
+  FillCharFast(result[old * ItemSize], (Count - old) * ItemSize, 0);
+  Dest^ := result;
+end;
+
+procedure DynArrayCopy(Dest, Source: PPointer; Info: PRttiInfo;
+  SourceExtCount: PInteger);
+var
+  n, itemsize: PtrInt;
+  iteminfo: PRttiInfo;
+begin
+  iteminfo := Info^.DynArrayItemType(itemsize); // nil for unmanaged items
+  if Dest^ <> nil then
+    FastDynArrayClear(Dest, iteminfo);
+  Source := Source^;
+  if Source <> nil then
+  begin
+    if SourceExtCount <> nil then
+      n := SourceExtCount^
+    else
+      n := PDALen(PAnsiChar(Source) - _DALEN)^ + _DAOFF;
+    DynArrayNew(Dest, n, itemsize); // allocate zeroed memory
+    CopySeveral(Dest^, pointer(Source), n, iteminfo, itemsize);
+  end;
+end;
+
+procedure DynArrayEnsureUnique(Value: PPointer; Info: PRttiInfo);
+var
+  p: PDynArrayRec;
+  n, elemsize: PtrInt;
+begin
+  p := Value^;
+  Value^ := nil;
+  dec(p);
+  if (p^.refCnt >= 0) and
+     ((p^.refCnt <= 1) or
+      DACntDecFree(p^.refCnt)) then
+    exit;
+  n := p^.length;
+  Info := Info^.DynArrayItemType(elemsize);
+  DynArrayNew(Value, n, elemsize); // allocate zeroed memory
+  inc(p);
+  CopySeveral(Value^, pointer(p), n, Info, elemsize);
+end;
+
+procedure EnsureUnique(var Value: TIntegerDynArray);
+begin
+  if (Value <> nil) and
+     (PDACnt(PAnsiChar(Value) - _DACNT)^ > 1) then
+    DynArrayEnsureUnique(@Value, TypeInfo(TIntegerDynArray));
+end;
+
+procedure EnsureUnique(var Value: TRawUtf8DynArray); overload;
+begin
+  if (Value <> nil) and
+     (PDACnt(PAnsiChar(Value) - _DACNT)^ > 1) then
+    DynArrayEnsureUnique(@Value, TypeInfo(TRawUtf8DynArray));
+end;
+
+procedure EnsureUnique(var Value: TVariantDynArray); overload;
+begin
+  if (Value <> nil) and
+     (PDACnt(PAnsiChar(Value) - _DACNT)^ > 1) then
+    DynArrayEnsureUnique(@Value, TypeInfo(TVariantDynArray));
+end;
+
+
+{ ************* Managed Types Finalization, Random or Copy }
+
+{ RTTI_FINALIZE[] implementation functions }
+
+function _StringClear(V: PPointer; Info: PRttiInfo): PtrInt;
+var
+  p: PStrRec;
+begin
+  p := V^;
+  if p <> nil then // works for both rkLString + rkUString
+  begin
+    V^ := nil;
+    dec(p);
+    if (p^.refCnt >= 0) and
+       StrCntDecFree(p^.refCnt) then
+      Freemem(p);
+  end;
+  result := SizeOf(V^);
+end;
+
+function _WStringClear(V: PWideString; Info: PRttiInfo): PtrInt;
+begin
+  if V^ <> '' then
+    {$ifdef FPC}
+    Finalize(V^);
+    {$else}
+    V^ := '';
+    {$endif FPC}
+  result := SizeOf(V^);
+end;
+
+function _VariantClear(V: PVarData; Info: PRttiInfo): PtrInt;
+begin
+  VarClear(Variant(V^));
+  result := SizeOf(V^);
+end;
+
+function _InterfaceClear(V: PInterface; Info: PRttiInfo): PtrInt;
+begin
+  if V^ <> nil then
+    {$ifdef FPC}
+    Finalize(V^);
+    {$else}
+    V^ := nil;
+    {$endif FPC}
+  result := SizeOf(V^);
+end;
+
+function _DynArrayClear(V: PPointer; Info: PRttiInfo): PtrInt;
+var
+  p: PDynArrayRec;
+begin
+  p := V^;
+  if p <> nil then
+  begin
+    dec(p);
+    if (p^.refCnt >= 0) and
+       DACntDecFree(p^.refCnt) then
+    begin
+      Info := Info^.DynArrayItemType;
+      if Info <> nil then
+        FastFinalizeArray(V^, Info, p^.length);
+      Freemem(p);
+    end;
+    V^ := nil;
+  end;
+  result := SizeOf(V^);
+end;
+
+function _ArrayClear(V: PByte; Info: PRttiInfo): PtrInt;
+var
+  n: PtrInt;
+  fin: TRttiFinalizer;
+begin
+  Info := Info^.ArrayItemType(n, result);
+  if Info = nil then
+    FillCharFast(V^, result, 0)
+  else
+  begin
+    fin := RTTI_FINALIZE[Info^.Kind];
+    if Assigned(fin) then
+      repeat
+        inc(V, fin(V, Info));
+        dec(n);
+      until n = 0;
+  end;
+end;
+
+function _ObjClear(V: PObject; Info: PRttiInfo): PtrInt;
+begin
+  if V^ <> nil then
+  begin
+    V^.Destroy;
+    V^ := nil;
+  end;
+  result := SizeOf(V^);
+end;
+
+function _ObjArrayClear(V: PPointer; Info: PRttiInfo): PtrInt;
+begin
+  if V^ <> nil then
+  begin
+    RawObjectsClear(V^, PDALen(PAnsiChar(V^) - _DALEN)^ + _DAOFF);
+    _DynArrayClear(V, Info);
+  end;
+  result := SizeOf(V^);
+end;
+
+
+{ PT_RANDOM[] implementation functions }
+
+procedure _NoRandom(V: PPointer; RC: TRttiCustom);
+begin
+end;
+
+// we use SharedRandom since TLightLock may be faster than a threadvar
+
+procedure _FillRandom(V: PByte; RC: TRttiCustom);
+begin
+  SharedRandom.Fill(V, RC.Cache.Size);
+end;
+
+procedure _StringRandom(V: PPointer; RC: TRttiCustom);
+var
+  tmp: TShort31;
+begin
+  SharedRandom.FillShort31(tmp);
+  FastSetStringCP(V^, @tmp[1], ord(tmp[0]), RC.Cache.CodePage);
+end;
+
+procedure _WStringRandom(V: PWideString; RC: TRttiCustom);
+var
+  tmp: TShort31;
+  i: PtrInt;
+  W: PWordArray;
+begin
+  SharedRandom.FillShort31(tmp);
+  SetString(V^, PWideChar(nil), ord(tmp[0]));
+  W := pointer(V^);
+  for i := 1 to ord(tmp[0]) do
+    W[i - 1] := cardinal(PByteArray(@tmp)[i]);
+end;
+
+{$ifdef HASVARUSTRING}
+procedure _UStringRandom(V: PUnicodeString; RC: TRttiCustom);
+var
+  tmp: TShort31;
+  i: PtrInt;
+  W: PWordArray;
+begin
+  SharedRandom.FillShort31(tmp);
+  SetString(V^, PWideChar(nil), ord(tmp[0]));
+  W := pointer(V^);
+  for i := 1 to ord(tmp[0]) do
+    W[i - 1] := cardinal(PByteArray(@tmp)[i]);
+end;
+{$endif HASVARUSTRING}
+
+procedure _VariantRandom(V: PRttiVarData; RC: TRttiCustom);
+begin
+  VarClearAndSetType(Variant(V^), varEmpty);
+  V^.Data.VInt64 := SharedRandom.Next;
+  // generate some 8-bit 32-bit 64-bit integers or a RawUtf8 varString
+  case V^.Data.VInteger and 3 of
+    0:
+      V^.VType := varInteger;
+    1:
+      V^.VType := varInt64;
+    2:
+      V^.VType := varByte;
+    3:
+      begin
+        V^.VType := varString;
+        V^.Data.VAny := nil;
+        _StringRandom(@V^.Data.VAny, RC);
+      end;
+  end;
+end;
+
+procedure _DoubleRandom(V: PDouble; RC: TRttiCustom);
+begin
+  V^ := SharedRandom.NextDouble;
+end;
+
+procedure _DateTimeRandom(V: PDouble; RC: TRttiCustom);
+begin
+  V^ := 38000 + Int64(SharedRandom.Next) / (maxInt shr 12);
+end;
+
+procedure _SingleRandom(V: PSingle; RC: TRttiCustom);
+begin
+  V^ := SharedRandom.NextDouble;
+end;
+
+var
+  PT_RANDOM: array[TRttiParserType] of pointer = (
+    @_NoRandom,       //  ptNone
+    @_NoRandom,       //  ptArray
+    @_FillRandom,     //  ptBoolean
+    @_FillRandom,     //  ptByte
+    @_FillRandom,     //  ptCardinal
+    @_FillRandom,     //  ptCurrency
+    @_DoubleRandom,   //  ptDouble
+    @_NoRandom,       //  ptExtended
+    @_FillRandom,     //  ptInt64
+    @_FillRandom,     //  ptInteger
+    @_FillRandom,     //  ptQWord
+    @_StringRandom,   //  ptRawByteString
+    @_NoRandom,       //  ptRawJson
+    @_StringRandom,   //  ptRawUtf8
+    @_NoRandom,       //  ptRecord
+    @_SingleRandom,   //  ptSingle
+    {$ifdef UNICODE}
+    @_UStringRandom,
+    {$else}           //  ptString
+    @_StringRandom,
+    {$endif UNICODE}
+    {$ifdef HASVARUSTRING}
+    @_UStringRandom,
+    {$else}           //  ptSynUnicode
+    @_WStringRandom,
+    {$endif HASVARUSTRING}
+    @_DateTimeRandom, //  ptDateTime
+    @_DateTimeRandom, //  ptDateTimeMS
+    @_FillRandom,     //  ptGuid
+    @_FillRandom,     //  ptHash128
+    @_FillRandom,     //  ptHash256
+    @_FillRandom,     //  ptHash512
+    @_NoRandom,       //  ptOrm
+    @_FillRandom,     //  ptTimeLog
+    {$ifdef HASVARUSTRING}
+    @_UStringRandom,
+    {$else}           //  ptUnicodeString
+    @_NoRandom,
+    {$endif HASVARUSTRING}
+    @_FillRandom,     //  ptUnixTime
+    @_FillRandom,     //  ptUnixMSTime
+    @_VariantRandom,  //  ptVariant
+    @_WStringRandom,  //  ptWideString
+    @_StringRandom,   //  ptWinAnsi
+    @_FillRandom,     //  ptWord
+    @_FillRandom,     //  ptEnumeration
+    @_FillRandom,     //  ptSet
+    @_NoRandom,       //  ptClass
+    @_NoRandom,       //  ptDynArray
+    @_NoRandom,       //  ptInterface
+    @_NoRandom,       //  ptPUtf8Char is read-only
+    @_NoRandom);      //  ptCustom
+
+
+{ RTTI_MANAGEDCOPY[] implementation functions }
+
+function _LStringCopy(Dest, Source: PRawByteString; Info: PRttiInfo): PtrInt;
+begin
+  if (Source^ <> '') or
+     (Dest^ <> '') then
+    Dest^ := Source^;
+  result := SizeOf(Source^);
+end;
+
+{$ifdef HASVARUSTRING}
+function _UStringCopy(Dest, Source: PUnicodeString; Info: PRttiInfo): PtrInt;
+begin
+  if (Source^ <> '') or
+     (Dest^ <> '') then
+    Dest^ := Source^;
+  result := SizeOf(Source^);
+end;
+{$endif HASVARUSTRING}
+
+function _WStringCopy(Dest, Source: PWideString; Info: PRttiInfo): PtrInt;
+begin
+  if (Source^ <> '') or
+     (Dest^ <> '') then
+    Dest^ := Source^;
+  result := SizeOf(Source^);
+end;
+
+function _VariantCopy(Dest, Source: PVarData; Info: PRttiInfo): PtrInt;
+var
+  vt: cardinal;
+label
+  rtl, raw;
+begin
+  vt := Source^.VType;
+  VarClearAndSetType(Variant(Dest^), vt);
+  if vt > varNull then
+    // varEmpty,varNull need no copy
+    if vt <= varWord64 then
+      // most used types
+      if (vt < varOleStr) or
+         (vt > varError) then
+raw:    // copy any simple value (e.g. ordinal, varByRef)
+        Dest^.VInt64 := Source^.VInt64
+      else if vt = varOleStr then
+      begin
+        // copy WideString with reference counting
+        Dest^.VAny := nil;
+        WideString(Dest^.VAny) := WideString(Source^.VAny)
+      end
+      else
+        // varError, varDispatch
+        goto rtl
+    else if vt = varString then
+    begin
+      // copy AnsiString with reference counting
+      Dest^.VAny := nil;
+      RawByteString(Dest^.VAny) := RawByteString(Source^.VAny)
+    end
+    else if vt >= varByRef then
+      // varByRef has no refcount -> copy VPointer
+      goto raw
+    {$ifdef HASVARUSTRING}
+    else if vt = varUString then
+    begin
+      // copy UnicodeString with reference counting
+      Dest^.VAny := nil;
+      UnicodeString(Dest^.VAny) := UnicodeString(Source^.VAny)
+    end
+    {$endif HASVARUSTRING}
+    else
+rtl:  // copy any complex type via the RTL function of the variants unit
+      VarCopyProc(Dest^, Source^);
+  result := SizeOf(Source^);
+end;
+
+function _Per1Copy(Dest, Source: PByte; Info: PRttiInfo): PtrInt;
+begin
+  Dest^ := Source^;
+  result := 0; // only called from TRttiCustom.ValueCopy which ignore this
+end;
+
+function _Per2Copy(Dest, Source: PWord; Info: PRttiInfo): PtrInt;
+begin
+  Dest^ := Source^;
+  result := 0; // ignored
+end;
+
+function _Per4Copy(Dest, Source: PInteger; Info: PRttiInfo): PtrInt;
+begin
+  Dest^ := Source^;
+  result := 0; // ignored
+end;
+
+function _Per8Copy(Dest, Source: PInt64; Info: PRttiInfo): PtrInt;
+begin
+  Dest^ := Source^;
+  result := 0; // ignored
+end;
+
+function _Per16Copy(Dest, Source: PHash128; Info: PRttiInfo): PtrInt;
+begin
+  Dest^ := Source^;
+  result := 0; // ignored
+end;
+
+function _Per32Copy(Dest, Source: PHash256; Info: PRttiInfo): PtrInt;
+begin
+  Dest^ := Source^;
+  result := 0; // ignored
+end;
+
+function _InterfaceCopy(Dest, Source: PInterface; Info: PRttiInfo): PtrInt;
+begin
+  Dest^ := Source^;
+  result := SizeOf(Source^);
+end;
+
+function _RecordCopy(Dest, Source: PByte; Info: PRttiInfo): PtrInt;
+var
+  fields: TRttiRecordManagedFields; // Size/Count/Fields
+  offset: PtrUInt;
+  f: PRttiRecordField;
+  cop: PRttiCopiers;
+begin
+  Info^.RecordManagedFields(fields);
+  f := fields.Fields;
+  cop := @RTTI_MANAGEDCOPY;
+  offset := 0;
+  while fields.Count <> 0 do
+  begin
+    dec(fields.Count);
+    Info := f^.{$ifdef HASDIRECTTYPEINFO}TypeInfo{$else}TypeInfoRef^{$endif};
+    {$ifdef FPC_OLDRTTI}
+    if Info^.Kind in rkManagedTypes then
+    {$endif FPC_OLDRTTI}
+    begin
+      offset := f^.Offset - offset;
+      if offset <> 0 then
+      begin
+        MoveFast(Source^, Dest^, offset);
+        inc(Source, offset);
+        inc(Dest, offset);
+      end;
+      offset := cop[Info^.Kind](Dest, Source, Info);
+      inc(Source, offset);
+      inc(Dest, offset);
+      inc(offset, f^.Offset);
+    end;
+    inc(f);
+  end;
+  offset := PtrUInt(fields.Size) - offset;
+  if offset > 0 then
+    MoveFast(Source^, Dest^, offset);
+  result := fields.Size;
+end;
+
+function _DynArrayCopy(Dest, Source: PPointer; Info: PRttiInfo): PtrInt;
+begin
+  DynArrayCopy(Dest, Source, Info, {extcount=}nil);
+  result := SizeOf(Source^);
+end;
+
+function _ArrayCopy(Dest, Source: PByte; Info: PRttiInfo): PtrInt;
+var
+  n, itemsize: PtrInt;
+  cop: TRttiCopier;
+label
+  raw;
+begin
+  Info := Info^.ArrayItemType(n, result);
+  if Info = nil then
+raw:MoveFast(Source^, Dest^, result)
+  else
+  begin
+    cop := RTTI_MANAGEDCOPY[Info^.Kind];
+    if Assigned(cop) then
+      repeat
+        itemsize := cop(Dest ,Source, Info);
+        inc(Source, itemsize);
+        inc(Dest, itemsize);
+        dec(n);
+      until n = 0
+    else
+      goto raw;
+  end;
+end;
+
+
+{ RTTI-based FillZero() }
+
+procedure FillZeroRtti(Info: PRttiInfo; var Value);
+var
+  nfo: TRttiCustom;
+  fin: TRttiFinalizer;
+  da: PDynArrayRec;
+  i, siz: PtrInt;
+  v: PAnsiChar;
+  p: PRttiCustomProp;
+begin
+  if Info = nil then
+    exit;
+  nfo := nil; // is set below for rkClass/rkRecord
+  case Info^.Kind of
+    {$ifdef FPC}rkObject,{$else}{$ifdef UNICODE}rkMRecord,{$endif}{$endif}
+    rkRecord:
+      nfo := Rtti.RegisterType(Info);
+    {$ifdef FPC}
+    rkLStringOld,
+    {$endif FPC}
+    rkLString:
+      FillZero(RawByteString(Value));
+    {$ifdef HASVARUSTRING}
+    rkUString:
+      FillZero(UnicodeString(Value));
+    {$endif HASVARUSTRING}
+    rkVariant:
+      if TVarData(Value).VType = varString then
+        FillZero(RawByteString(TVarData(Value).VAny));
+    rkClass:
+      if TObject(Value) <> nil then
+        nfo := Rtti.RegisterClass(TObject(Value));
+    rkDynArray:
+      begin
+        da := PPointer(Value)^;
+        if da <> nil then
+        begin
+          dec(da);
+          if (da^.refCnt >= 0) and
+             DACntDecFree(da^.refCnt) then
+          begin
+            Info := Info^.DynArrayItemType(siz);
+            v := PPointer(Value)^;
+            if Info <> nil then
+              for i := 1 to da^.length do
+              begin
+                FillZeroRtti(Info, v^); // process nested items
+                inc(v, siz);
+              end
+            else
+              FillCharFast(v^, da^.length * siz, 0); // e.g. for TBytes
+            Freemem(da);
+          end;
+          PPointer(Value)^ := nil;
+        end;
+        exit;
+      end;
+  end;
+  if nfo <> nil then
+  begin
+    p := pointer(nfo.Props.List); // for both records and classes
+    if Info^.Kind = rkClass then
+      v := PPointer(Value)^ // classes are passed by reference
+    else
+      v := @Value;          // records are passed by value
+    for i := 1 to nfo.Props.Count do
+    begin
+      if (p^.OffsetSet >= 0) and
+         (p^.Value <> nil) and
+         (p^.Value.Info <> nil) and
+         not (rcfIsNumber in p^.Value.Cache.Flags) then
+        FillZeroRtti(p^.Value.Info, v[p^.OffsetSet]); // process nested fields
+      inc(p);
+    end;
+  end;
+  fin := RTTI_FINALIZE[Info^.Kind];
+  if Assigned(fin) then
+    fin(@Value, Info);
+end;
+
+
+{ ************** RTTI Value Types used for JSON Parsing }
+
+function ParserTypeToTypeInfo(pt: TRttiParserType;
+  pct: TRttiParserComplexType): PRttiInfo;
+begin
+  result := PTC_INFO[pct];
+  if result = nil then
+    result := PT_INFO[pt];
+end;
+
+// called from TRttiCustomList.RegisterTypeFromName and TRttiCustom.Create
+// if Rtti.Find(Name, NameLen) did not have any match
+// -> detect array/record keywords, integer/cardinal types, T*ID pattern
+function AlternateTypeNameToRttiParserType(Name: PUtf8Char; NameLen: integer;
+  Complex: PRttiParserComplexType = nil; Kind: TRttiKind = rkUnknown): TRttiParserType;
+begin
+  result := ptNone;
+  if Complex <> nil then
+    Complex^ := pctNone;
+  case NameLen of
+    5:
+      if IdemPropNameUSameLenNotNull(Name, 'array', 5) then
+        result := ptArray;
+    6:
+      {$ifdef FPC}
+      // TypeInfo(string)=TypeInfo(AnsiString) on FPC
+      if IdemPropNameUSameLenNotNull(Name, 'string', 6) then
+        result := ptString
+      else
+      {$endif FPC}
+      if IdemPropNameUSameLenNotNull(Name, 'record', 6) then
+        result := ptRecord;
+    // TypeInfo(integer/cardinal)=TypeInfo(LongInt/LongWord) on FPC
+    7:
+      if IdemPropNameUSameLenNotNull(Name,
+          {$ifdef FPC}'integer'{$else}'longint'{$endif}, 7) then
+        result := ptInteger;
+    8:
+      if IdemPropNameUSameLenNotNull(Name,
+           {$ifdef FPC}'cardinal'{$else}'longword'{$endif}, 8) then
+        result := ptCardinal;
+  end;
+  if (result = ptNone) and
+     (Complex <> nil) and
+     (Kind = rkInt64) and
+     (NameLen < 200) and
+     (Name[0] = 'T') and // T...ID pattern in name?
+     (PWord(@Name[NameLen - 2])^ and $dfdf = ord('I') + ord('D') shl 8) then
+  begin
+    result := ptOrm;
+    Complex^ := pctSpecificClassID;
+  end;
+end;
+
+// called internally by TRttiCustom.Create - can't use Rtti.RegisterType()
+function GuessTypeInfoToStandardParserType(Info: PRttiInfo;
+  Complex: PRttiParserComplexType): TRttiParserType;
+var
+  c: TRttiParserComplexType;
+  ndx: PtrInt;
+  cp: integer;
+begin                                            
+  result := ptNone;
+  if Complex <> nil then
+    Complex^ := pctNone;
+  if Info = nil then
+    exit;
+  // search if it is a known standard type from PT_INFO[]/PTC_INFO[]
+  ndx := PtrUIntScanIndex(@PT_INFO, length(PT_INFO), PtrUInt(Info));
+  if ndx >= 0 then
+  begin
+    result := TRttiParserType(ndx);
+    if not (result in ptComplexTypes) then
+      exit;
+  end;
+  for c := succ(low(c)) to high(c) do
+    if PTC_INFO[c] = Info then // complex ORM types as set by mormot.orm.base
+      if PTC_PT[c] <> ptNone then
+      begin
+        result := PTC_PT[c];
+        if Complex <> nil then
+          Complex^ := c;
+        exit;
+      end
+      else
+        break;
+  // array/record keywords, integer/cardinal FPC types, T*ID pattern
+  result := AlternateTypeNameToRttiParserType(
+    @Info^.RawName[1], ord(Info^.RawName[0]), Complex, Info^.Kind);
+  if result <> ptNone then
+    exit; // found by name
+  // fallback to the closed known type, using RTTI
+  case Info^.Kind of
+    // FPC and Delphi will use a fast jmp table
+  {$ifdef FPC}
+    rkLStringOld,
+  {$endif FPC}
+    rkLString: // PT_INFO[ptRawUtf8/ptRawJson] have been found above
+      begin
+        cp := Info^.AnsiStringCodePage;
+        if cp = CP_UTF8 then
+          result := ptRawUtf8
+        else if cp = CP_WINANSI then
+          result := ptWinAnsi
+        else if cp >= CP_RAWBLOB then
+          result := ptRawByteString
+        {$ifndef UNICODE}
+        else if (cp = CP_ACP) or
+                (cp = Unicode_CodePage) then
+          result := ptString
+        {$endif UNICODE}
+        else
+          result := ptRawUtf8; // fallback to UTF-8 string
+      end;
+    rkWString:
+      result := ptWideString;
+  {$ifdef HASVARUSTRING}
+    rkUString:
+      result := ptUnicodeString;
+  {$endif HASVARUSTRING}
+  {$ifdef FPC_OR_UNICODE}
+    {$ifdef UNICODE}
+    rkProcedure,
+    {$endif UNICODE}
+    rkClassRef,
+    rkPointer:
+      result := ptPtrInt;
+  {$endif FPC_OR_UNICODE}
+    rkVariant:
+      result := ptVariant;
+    rkArray:
+      result := ptArray;
+    rkDynArray:
+      result := ptDynArray;
+    {$ifdef FPC}rkObject,{$else}{$ifdef UNICODE}rkMRecord,{$endif}{$endif}
+    rkRecord:
+      result := ptRecord;
+    rkChar:
+      result := ptByte;
+    rkWChar:
+      result := ptWord;
+    rkMethod:
+      result := ptPtrInt;
+    rkInterface:
+      result := ptInterface;
+    rkInteger:
+      case Info^.RttiOrd of
+        roSByte,
+        roUByte:
+          result := ptByte;
+        roSWord,
+        roUWord:
+          result := ptWord;
+        roSLong:
+          result := ptInteger;
+        roULong:
+          result := ptCardinal;
+      {$ifdef FPC_NEWRTTI}
+        roSQWord:
+          result := ptInt64;
+        roUQWord:
+          result := ptQWord;
+      {$endif FPC_NEWRTTI}
+      end;
+    rkInt64:
+    {$ifdef ISDELPHI}
+      if Info^.IsQWord then
+        result := ptQWord
+      else
+    {$endif ISDELPHI}
+      // PT_INFO[ptOrm/ptTimeLog/ptUnixTime] have been found above
+      result := ptInt64;
+  {$ifdef FPC}
+    rkQWord:
+      result := ptQWord;
+    rkBool:
+      result := ptBoolean;
+  {$endif FPC}
+    rkEnumeration:
+    {$ifdef ISDELPHI}
+      if Info^.IsBoolean then
+        result := ptBoolean
+      else
+    {$endif ISDELPHI}
+        result := ptEnumeration;
+    rkSet:
+      result := ptSet;
+    rkClass:
+      result := ptClass;
+    rkFloat:
+      case Info^.RttiFloat of
+        rfSingle:
+          result := ptSingle;
+        rfDouble:
+          // PT_INFO[ptDateTime/ptDateTimeMS] have been found above
+          result := ptDouble;
+        rfCurr:
+          result := ptCurrency;
+        rfExtended:
+          result := ptExtended;
+        // rfComp: not implemented yet
+      end;
+  end;
+end;
+
+function SizeToDynArrayKind(size: integer): TRttiParserType;
+  {$ifdef HASINLINE}inline;{$endif}
+begin  // rough estimation
+  case size of
+    1:
+      result := ptByte;
+    2:
+      result := ptWord;
+    4:
+      result := ptInteger;
+    8:
+      result := ptInt64;
+    16:
+      result := ptHash128;
+    32:
+      result := ptHash256;
+    64:
+      result := ptHash512;
+  else
+    result := ptNone;
+  end;
+end;
+
+var
+  PT_DYNARRAY: array[TRttiParserType] of pointer; // most simple dynamic arrays
+
+function TypeInfoToDynArrayTypeInfo(ElemInfo: PRttiInfo;
+  ExpectExactElemInfo: boolean; ParserType: PRttiParserType): PRttiInfo;
+var
+  rc: TRttiCustom;
+begin
+  // search using item RTTI and PT_DYNARRAY[] known arrays
+  rc := Rtti.RegisterType(ElemInfo);
+  if rc = nil then
+  begin
+    result := nil; // paranoid
+    exit;
+  end;
+  result := PT_DYNARRAY[rc.parser];
+  if result <> nil then
+  begin
+    if ParserType <> nil then
+      ParserType^ := rc.Parser;
+    if (not ExpectExactElemInfo) or
+       (PT_INFO[rc.parser] = ElemInfo) then
+      exit;
+    rc := Rtti.RegisterType(result);
+    if (rc.ArrayRtti <> nil) and
+       (rc.ArrayRtti.Info = ElemInfo) then
+      exit;
+  end;
+  // search in registered rkDynArray for complex types (e.g. ptRecord)
+  rc := Rtti.FindByArrayRtti(ElemInfo);
+  if rc <> nil then
+  begin
+    if ParserType <> nil then
+      ParserType^ := rc.ArrayRtti.Parser;
+    result := rc.Info;
+  end;
+end;
+
+// call from TRttiCustom.Create (maybe via GuessItemTypeFromDynArrayInfo)
+function GuessItemTypeFromDynArrayInfo(DynArrayInfo, ElemInfo: PRttiInfo;
+  ElemSize: integer; ExactType: boolean; out FieldSize: integer;
+  Complex: PRttiParserComplexType = nil): TRttiParserType;
+// warning: we can't use TRttiInfo.RecordAllFields since it would break
+// backward compatibility and code expectations
+var
+  fields: TRttiRecordManagedFields;
+  offset: integer;
+  pt: TRttiParserType;
+begin
+  result := ptNone;
+  if Complex <> nil then
+    Complex^ := pctNone;
+  FieldSize := 0;
+  // fast guess of most known ArrayType
+  if (DynArrayInfo <> nil) and
+     ((ElemInfo = nil) or
+      not(ElemInfo^.Kind in [rkEnumeration, rkSet, rkDynArray, rkClass])) then
+    for pt := ptBoolean to ptWord do
+      if PT_DYNARRAY[pt] = DynArrayInfo then
+      begin
+        result := pt;
+        break;
+      end;
+  if result = ptNone then
+    repeat
+      // guess from RTTI of nested record(s)
+      if ElemInfo = nil then
+      begin
+        result := SizeToDynArrayKind(ElemSize);
+        if result = ptNone then
+          FieldSize := ElemSize;
+      end
+      else
+      // try to guess from 1st record/object field
+      if not exactType and
+         (ElemInfo^.Kind in rkRecordTypes) then
+      begin
+        ElemInfo.RecordManagedFields(fields);
+        if fields.Count = 0 then
+        begin
+          ElemInfo := nil;
+          continue;
+        end;
+        offset := fields.Fields^.Offset;
+        if offset <> 0 then
+        begin
+          result := SizeToDynArrayKind(offset);
+          if result = ptNone then
+            FieldSize := offset;
+        end
+        else
+        begin
+          ElemInfo := fields.Fields^.
+            {$ifdef HASDIRECTTYPEINFO}TypeInfo{$else}TypeInfoRef^{$endif};
+          if (ElemInfo = nil) or
+             (ElemInfo^.Kind in rkRecordTypes) then
+            continue; // nested records
+          result := GuessTypeInfoToStandardParserType(ElemInfo, Complex);
+          if result = ptNone then
+          begin
+            ElemInfo := nil;
+            continue;
+          end;
+        end;
+      end;
+      break;
+    until false;
+  if result = ptNone then
+    // will recognize simple arrays from TypeName and ElemType
+    result := GuessTypeInfoToStandardParserType(ElemInfo, Complex);
+  if PT_SIZE[result] <> 0 then
+    FieldSize := PT_SIZE[result];
+end;
+
+
+
+{ ************** RTTI-based Registration for Custom JSON Parsing }
+
+{ TRttiCustomProp }
+
+function TRttiCustomProp.InitFrom(RttiProp: PRttiProp): PtrInt;
+var
+  addr: PtrInt;
+begin
+  Value := Rtti.RegisterType(RttiProp^.TypeInfo);
+  if Value = nil then
+    raise ERttiException.CreateUtf8('TRttiCustom: % property has no RTTI',
+      [RttiProp^.Name^]);
+  addr := PtrInt(RttiProp^.GetFieldAddr(nil));
+  // GetterCall/SetterCall will handle void "read"/"write" attributes
+  OffsetGet := -1;
+  OffsetSet := -1;
+  if RttiProp^.GetterCall = rpcField then
+    OffsetGet := addr;
+  if RttiProp^.SetterCall = rpcField then
+    OffsetSet := addr;
+  Name := ToUtf8(RttiProp^.Name^);
+  fOrigName := Name;
+  Prop := RttiProp;
+  OrdinalDefault := NO_DEFAULT;
+  if rcfHasRttiOrd in Value.Cache.Flags then
+    OrdinalDefault := RttiProp.Default;
+  Stored := RttiProp^.IsStoredKind;
+  result := Value.Size;
+end;
+
+function TRttiCustomProp.NameMatch(P: PUtf8Char; Len: PtrInt): boolean;
+var
+  n: PUtf8Char;
+begin // inlined IdemPropNameUSameLenNotNull()
+  result := false;
+  n := pointer(Name);
+  if (n = nil) or // Name='' after NameChange()
+     (PStrLen(n - _STRLEN)^ <> Len) then
+    exit;
+  pointer(Len) := @PUtf8Char(n)[Len - SizeOf(cardinal)];
+  dec(PtrUInt(P), PtrUInt(n));
+  while PtrUInt(n) < PtrUInt(Len) do
+    // compare 4 Bytes per loop
+    if (PCardinal(n)^ xor PCardinal(P + PtrUInt(n))^) and $dfdfdfdf <> 0 then
+      exit
+    else
+      inc(PCardinal(n));
+  inc(Len, SizeOf(cardinal));
+  while PtrUInt(n) < PtrUInt(Len) do
+    if (ord(n^) xor ord(P[PtrUInt(n)])) and $df <> 0 then
+      exit
+    else
+      inc(PByte(n));
+  result := true;
+end;
+
+procedure TRttiCustomProp.GetValue(Data: pointer; out RVD: TRttiVarData);
+begin
+  if (Prop = nil) or
+     (OffsetGet >= 0 ) then
+    // direct memory access of the value (classes and records)
+    GetValueDirect(Data, RVD)
+  else
+    // need a class property getter
+    GetValueGetter(Data, RVD);
+end;
+
+procedure TRttiCustomProp.GetValueVariant(Data: pointer; out Dest: TVarData;
+  Options: pointer{PDocVariantOptions});
+var
+  a: pointer;
+begin
+  if (Prop = nil) or
+     (OffsetGet >= 0) then
+    Value.ValueToVariant(PAnsiChar(Data) + OffsetGet, Dest, Options)
+  else if Value.Cache.RttiVarDataVType <> varAny then
+    GetValueGetter(Data, TRttiVarData(Dest)) // not TRttiVarData specific
+  else if Value.Cache.VarDataVType = varInt64 then // rkEnumeration, rkSet
+  begin
+    Dest.VType := varInt64;
+    Dest.VInt64 := Prop^.GetInt64Value(Data);
+  end
+  else if Value.Kind = rkDynArray then
+  begin
+    a := nil;
+    try
+      a := Prop^.GetDynArrayPropGetter(Data);
+      Value.ValueToVariant(@a, Dest, Options); // will create a TDocVariant
+    finally
+      FastDynArrayClear(@a, Value.ArrayRtti.Info);
+    end;
+  end;
+end;
+
+procedure TRttiCustomProp.SetValue(Data: pointer; var RVD: TRttiVarData;
+  andclear: boolean);
+begin
+  if Prop <> nil then
+    Prop.SetValue(TObject(Data), variant(RVD));
+  if andclear and
+     RVD.NeedsClear then
+    VarClearProc(RVD.Data);
+  if Prop = nil then // raise exception after NeedsClear to avoid memory leak
+    raise ERttiException.Create('TRttiCustomProp.SetValue: with Prop=nil');
+end;
+
+function TRttiCustomProp.SetValueText(Data: pointer; const Text: RawUtf8): boolean;
+begin
+  if (Prop = nil) or
+     (OffsetSet >= 0) then
+    // direct fill value in memory (classes and records)
+    result := Value.ValueSetText(PAnsiChar(Data) + OffsetSet, Text)
+  else
+    // need a class property setter
+    result := Prop.SetValueText(Data, Text);
+end;
+
+procedure TRttiCustomProp.AddValueJson(W: TTextWriter; Data: pointer;
+  Options: TTextWriterWriteObjectOptions; K: TTextWriterKind);
+var
+  rvd: TRttiVarData;
+begin
+  GetValue(Data, rvd);
+  if K <> twOnSameLine then
+    if Value.Parser = ptRawJson then
+      K := twNone
+    else
+      K := twJsonEscape;
+  W.AddVariant(variant(rvd), K, Options);
+  if rvd.NeedsClear then
+    VarClearProc(rvd.Data);
+end;
+
+procedure TRttiCustomProp.GetValueJson(Data: pointer; out Result: RawUtf8);
+var
+  w: TTextWriter;
+  tmp: TTextWriterStackBuffer;
+begin
+  w := DefaultJsonWriter.CreateOwnedStream(tmp);
+  try
+    AddValueJson(w, Data, []);
+    w.SetText(Result);
+  finally
+    w.Free;
+  end;
+end;
+
+function TRttiCustomProp.ValueIsDefault(Data: pointer): boolean;
+begin
+  if rcfHasRttiOrd in Value.Cache.Flags then
+    if OffsetGet >= 0 then
+      result := RTTI_FROM_ORD[Value.Cache.RttiOrd](
+                  PAnsiChar(Data) + OffsetGet) = OrdinalDefault
+    else
+      result := Prop.GetOrdProp(Data) = OrdinalDefault
+  else if rcfGetInt64Prop in Value.Cache.Flags then
+    if OffsetGet >= 0 then
+      result := PInt64(PAnsiChar(Data) + OffsetGet)^ = OrdinalDefault
+    else
+      result := Prop.GetInt64Prop(Data) = OrdinalDefault
+  else
+    // only ordinals have default values
+    result := false;
+end;
+
+function TRttiCustomProp.ValueIsVoid(Data: pointer): boolean;
+begin
+  // we assume the caller ensured Data<>nil
+  if OffsetGet >= 0 then
+    // direct check value from field in memory
+    result := Value.ValueIsVoid(PAnsiChar(Data) + OffsetGet)
+  else
+    // slightly slower method using a getter
+    result := ValueIsVoidGetter(Data);
+end;
+
+function TRttiCustomProp.ValueIsVoidGetter(Data: pointer): boolean;
+var
+  rvd: TRttiVarData;
+begin
+  if Prop = nil then
+    result := true
+  else if Value.Kind = rkClass then
+    result := IsObjectDefaultOrVoid(Prop.GetObjProp(Data))
+  else
+  begin
+    GetValueGetter(Data, rvd);
+    case rvd.DataType of
+      varEmpty,
+      varNull:
+        result := true;
+      varAny,
+      varUnknown,
+      varString,
+      varOleStr
+      {$ifdef HASVARUSTRING}, varUString {$endif}:
+        result := rvd.Data.VAny = nil;
+      varSingle,
+      varInteger,
+      varLongWord:
+        result := rvd.Data.VInteger = 0;
+      varInt64,
+      varWord64,
+      varDate,
+      varDouble,
+      varCurrency,
+      varBoolean:
+        result := rvd.Data.VInt64 = 0;
+    else
+      result := false;
+    end;
+    if rvd.NeedsClear then
+      VarClearProc(rvd.Data);
+  end;
+end;
+
+procedure TRttiCustomProp.GetValueDirect(Data: PByte; out RVD: TRttiVarData);
+begin
+  inc(Data, OffsetGet);
+  RVD.VType := Value.Cache.RttiVarDataVType; // reset NeedsClear/ValueIsInstance
+  case RVD.VType of
+  varEmpty:
+    // void Data or unsupported TRttiKind
+    exit;
+  varInt64,
+  varBoolean:
+    // rkInteger, rkBool using VInt64 for proper cardinal support
+    RVD.Data.VInt64 := RTTI_FROM_ORD[Value.Cache.RttiOrd](Data);
+  varWord64:
+    // rkInt64, rkQWord
+    begin
+      if not (rcfQWord in Value.Cache.Flags) then
+        RVD.VType := varInt64;
+      RVD.Data.VInt64 := PInt64(Data)^;
+    end;
+  varSingle:
+    // copy this 32-bit type at binary level
+    RVD.Data.VInteger := PInteger(Data)^;
+  varDate,
+  varDouble,
+  varCurrency:
+    // copy those 64-bit types at binary level
+    RVD.Data.VInt64 := PInt64(Data)^;
+  varAny:
+    begin
+      // rkEnumeration,rkSet,rkDynArray,rkClass,rkInterface,rkRecord,rkObject
+      RVD.PropValue := Data; // keeping RVD.PropValueIsInstance=false
+      RVD.Prop := @self;
+      // varAny/Value handled by TJsonWriter.AddVariant/AddRttiVarData
+    end;
+  varUnknown:
+    // rkChar, rkWChar, rkSString converted into temporary RawUtf8
+    begin
+      RVD.VType := varString;
+      RVD.NeedsClear := true;
+      RVD.Data.VAny := nil; // avoid GPF
+      Value.Info.StringToUtf8(Data, RawUtf8(RVD.Data.VAny));
+    end;
+  else
+    // varString, varVariant, varOleStr, varUString are returned by reference
+    begin
+      RVD.Data.VAny := Data; // return the pointer to the value
+      RVD.VType := RVD.VType or varByRef // and access it by reference
+    end;
+  end;
+end;
+
+procedure TRttiCustomProp.GetValueGetter(Instance: TObject;
+  out RVD: TRttiVarData);
+begin
+  RVD.VType := Value.Cache.RttiVarDataVType; // reset NeedsClear/ValueIsInstance
+  case RVD.VType of
+  varEmpty:
+    // unsupported TRttiKind
+    exit;
+  varInt64,
+  varBoolean:
+    // rkInteger, rkBool
+    RVD.Data.VInt64 := Prop.GetOrdProp(Instance); // VInt64 for cardinal
+  varWord64:
+    // rkInt64, rkQWord
+    begin
+      if not (rcfQWord in Value.Cache.Flags) then
+        RVD.VType := varInt64;
+      RVD.Data.VInt64 := Prop.GetInt64Prop(Instance);
+    end;
+  varCurrency:
+    Prop.GetCurrencyProp(Instance, RVD.Data.VCurrency);
+  varSingle:
+    RVD.Data.VSingle := Prop.GetFloatProp(Instance);
+  varDate,
+  varDouble:
+    RVD.Data.VDouble := Prop.GetFloatProp(Instance);
+  varAny:
+    begin
+      // rkEnumeration,rkSet,rkDynArray,rkClass,rkInterface,rkRecord,rkObject
+      RVD.PropValueIsInstance := true;
+      RVD.PropValue := Instance;
+      RVD.Prop := @self;
+      // varAny/Value/Prop handled by TJsonWriter.AddVariant/AddRttiVarData
+    end;
+  varUnknown:
+    // rkChar, rkWChar, rkSString converted into temporary RawUtf8
+    begin
+      RVD.VType := varString;
+      RVD.Data.VAny := nil; // avoid GPF
+      Prop.GetAsString(Instance, RawUtf8(RVD.Data.VAny));
+      RVD.NeedsClear := RVD.Data.VAny <> nil; // if a RawUtf8 was allocated
+    end
+  else
+    // varString/varOleStr/varUString or varVariant
+    begin
+      RVD.Data.VAny := nil; // avoid GPF below
+      case Value.Kind of
+        rkLString:
+          Prop.GetLongStrProp(Instance, RawByteString(RVD.Data.VAny));
+        rkWString:
+          Prop.GetWideStrProp(Instance, WideString(RVD.Data.VAny));
+        {$ifdef HASVARUSTRING}
+        rkUString:
+          Prop.GetUnicodeStrProp(Instance, UnicodeString(RVD.Data.VAny));
+        {$endif HASVARUSTRING}
+        rkVariant:
+          begin
+            RVD.VType := varEmpty; // to fill as variant
+            Prop.GetVariantProp(Instance, variant(RVD), {byref=}false);
+            RVD.NeedsClear := true; // we allocated a RVD for the getter result
+            exit;
+          end;
+      end;
+      RVD.NeedsClear := RVD.Data.VAny <> nil;
+    end;
+  end;
+end;
+
+function TRttiCustomProp.CompareValueComplex(Data, Other: pointer;
+  OtherRtti: PRttiCustomProp; CaseInsensitive: boolean): integer;
+var
+  v1, v2: TRttiVarData;
+begin
+  // direct comparison of ordinal values (rkClass is handled below)
+  if (rcfHasRttiOrd in Value.Cache.Flags) and
+     (rcfHasRttiOrd in OtherRtti.Value.Cache.Flags) then
+  begin
+    if OffsetGet >= 0 then
+      v1.Data.VInt64 := RTTI_FROM_ORD[Value.Cache.RttiOrd](
+                          PAnsiChar(Data) + OffsetGet)
+    else
+      v1.Data.VInt64 := Prop.GetOrdProp(Data);
+    if OtherRtti.OffsetGet >= 0 then
+      v2.Data.VInt64 := RTTI_FROM_ORD[OtherRtti.Value.Cache.RttiOrd](
+                          PAnsiChar(Other) + OtherRtti.OffsetGet)
+    else
+      v2.Data.VInt64 := OtherRtti.Prop.GetOrdProp(Other);
+  end
+  else if (rcfGetInt64Prop in Value.Cache.Flags) and
+          (rcfGetInt64Prop in OtherRtti.Value.Cache.Flags) then
+  begin
+    if OffsetGet >= 0 then
+      v1.Data.VInt64 := PInt64(PAnsiChar(Data) + OffsetGet)^
+    else
+      v1.Data.VInt64 := Prop.GetInt64Prop(Data);
+    if OtherRtti.OffsetGet >= 0 then
+      v2.Data.VInt64 := PInt64(PAnsiChar(Other) + OtherRtti.OffsetGet)^
+    else
+      v2.Data.VInt64 := OtherRtti.Prop.GetInt64Prop(Other);
+  end
+  else
+  // comparison using temporary TRttiVarData (using varByRef if possible)
+  begin
+    GetValue(Data, v1);
+    OtherRtti.GetValue(Other, v2);
+    if (v1.Data.VType <> varAny) and
+       (v2.Data.VType <> varAny) then
+      // standard variant comparison function (from mormot.core.variants)
+      result := SortDynArrayVariantComp(v1.Data, v2.Data, CaseInsensitive)
+    else if (v1.Data.VType = v2.Data.VType) and
+            (OtherRtti.Value = Value) then
+      // v1 and v2 are both varAny, with the very same RTTI type -> use
+      // mormot.core.json efficient comparison (also handle rkClass/TObject)
+      result := Value.ValueCompare(v1.PropValue, v2.PropValue, CaseInsensitive)
+    else
+      // we don't know much about those fields: just compare the pointers
+      result := ComparePointer(v1.PropValue, v2.PropValue);
+    if v1.NeedsClear then
+      VarClearProc(v1.Data);
+    if v2.NeedsClear then
+      VarClearProc(v2.Data);
+    exit;
+  end;
+  result := CompareInt64(v1.Data.VInt64, v2.Data.VInt64);
+end;
+
+function TRttiCustomProp.CompareValue(Data, Other: pointer;
+  const OtherRtti: TRttiCustomProp; CaseInsensitive: boolean): integer;
+begin
+  if (OtherRtti.Value = Value) and
+     (OffsetGet >= 0) and
+     (OtherRtti.OffsetGet >= 0) then
+    // two direct fields of the same type (this most common case is inlined)
+    result := Value.ValueCompare(PAnsiChar(Data) + OffsetGet,
+                PAnsiChar(Other) + OtherRtti.OffsetGet, CaseInsensitive)
+  else
+    // more complex properties comparison (not inlined)
+    result := CompareValueComplex(Data, Other, @OtherRtti, CaseInsensitive);
+end;
+
+
+{ TRttiCustomProps }
+
+function FindCustomProp(p: PRttiCustomProp; name: pointer; namelen: TStrLen;
+  count: integer): PRttiCustomProp;
+var
+  p1, p2, l: PUtf8Char;
+label
+  no;
+begin
+  result := p;
+  if result = nil then
+    exit;
+  p2 := name;
+  repeat
+    // inlined IdemPropNameUSameLenNotNull(p, name, namelen)
+    p1 := pointer(result^.Name);
+    if (p1 <> nil) and // Name may be '' after NameChange()
+       (PStrLen(p1 - _STRLEN)^ = namelen) then
+    begin
+      l := @p1[namelen - SizeOf(cardinal)];
+      dec(p2, PtrUInt(p1));
+      while PtrUInt(l) >= PtrUInt(p1) do
+        // compare 4 Bytes per loop
+        if (PCardinal(p1)^ xor PCardinal(@p2[PtrUInt(p1)])^) and $dfdfdfdf <> 0 then
+          goto no
+        else
+          inc(PCardinal(p1));
+      inc(PCardinal(l));
+      while PtrUInt(p1) < PtrUInt(l) do
+        // remaining bytes
+        if (ord(p1^) xor ord(p2[PtrUInt(p1)])) and $df <> 0 then
+          goto no
+        else
+          inc(PByte(p1));
+      exit; // match found
+no:   p2 := name;
+    end;
+    inc(result);
+    dec(count);
+  until count = 0;
+  result := nil;
+end;
+
+function TRttiCustomProps.Find(const PropName: RawUtf8): PRttiCustomProp;
+begin
+  result := pointer(PropName);
+  if result <> nil then
+    result := FindCustomProp(pointer(List), pointer(PropName),
+      PStrLen(PAnsiChar(result) - _STRLEN)^, Count);
+end;
+
+function TRttiCustomProps.Find(PropName: PUtf8Char; PropNameLen: PtrInt): PRttiCustomProp;
+begin
+  result := pointer(PropName);
+  if result <> nil then
+    result := FindCustomProp(pointer(List), PropName, PropNameLen, Count);
+end;
+
+function TRttiCustomProps.FindIndex(PropName: PUtf8Char; PropNameLen: PtrInt): PtrInt;
+var
+  p: PRttiCustomProp;
+begin
+  if PropNameLen <> 0 then
+  begin
+    p := pointer(List);
+    for result := 0 to Count - 1 do
+      if p^.NameMatch(PropName, PropNameLen) then
+        exit
+      else
+        inc(p);
+  end;
+  result := -1;
+end;
+
+function FromNames(p: PRttiCustomProp; n: integer; out names: RawUtf8): integer;
+begin
+  result := 0;
+  if n <> 0 then
+    repeat
+      if p^.Name <> '' then
+      begin
+        inc(result);
+        names := {%H-}names + '"' + p^.Name + '",';  // include trailing ,
+      end;
+      inc(p);
+      dec(n);
+    until n = 0;
+end;
+
+function TRttiCustomProps.NameChange(const Old, New: RawUtf8): PRttiCustomProp;
+begin
+  result := Find(Old);
+  if result = nil then
+    exit;
+  result^.Name := New;
+  CountNonVoid := FromNames(pointer(List), Count, NamesAsJsonArray);
+end;
+
+procedure TRttiCustomProps.NameChanges(const Old, New: array of RawUtf8);
+var
+  i: PtrInt;
+  p: PRttiCustomProp;
+begin
+  if high(Old) <> high(New) then
+    raise ERttiException.CreateUtf8(
+      'NameChanges(%,%) fields count', [high(Old), high(New)]);
+  // first reset the names
+  p := pointer(List);
+  for i := 1 to Count do
+  begin
+    p^.Name := p^.fOrigName; // back to original
+    inc(p);
+  end;
+  // customize field names
+  for i := 0 to high(Old) do
+  begin
+    p := Find(Old[i]);
+    if p = nil then
+      raise ERttiException.CreateUtf8('NameChanges(%) unknown', [Old[i]]);
+    p^.Name := New[i];
+  end;
+  CountNonVoid := FromNames(pointer(List), Count, NamesAsJsonArray);
+end;
+
+procedure TRttiCustomProps.InternalAdd(Info: PRttiInfo; Offset: PtrInt;
+  const PropName: RawUtf8; AddFirst: boolean);
+var
+  n: PtrInt;
+begin
+  if (Info = nil) or
+     (Offset < 0) or
+     (PropName = '') or
+     (Find(PropName) <> nil) then // don't register if already existing
+    exit;
+  SetLength(List, Count + 1);
+  if AddFirst then
+  begin
+    if Count > 0 then
+    begin
+      MoveFast(List[0], List[1], SizeOf(List[0]) * Count);
+      pointer(List[0].Name) := nil; // avoid GPF below
+      pointer(List[0].fOrigName) := nil;
+    end;
+    NamesAsJsonArray := '"' + PropName + '",' + NamesAsJsonArray;
+    n := 0;
+  end
+  else
+  begin
+    NamesAsJsonArray := NamesAsJsonArray + '"' + PropName + '",';
+    n := Count;
+  end;
+  inc(Count);
+  inc(CountNonVoid);
+  with List[n] do
+  begin
+    Value := Rtti.RegisterType(Info);
+    OffsetGet := Offset;
+    OffsetSet := Offset;
+    Name := PropName;
+    fOrigName := PropName;
+    Prop := nil;
+    OrdinalDefault := NO_DEFAULT;
+    Stored := rpsTrue;
+    inc(Size, Value.Size);
+  end;
+end;
+
+function TRttiCustomProps.FromTextPrepare(const PropName: RawUtf8): integer;
+begin
+  if PropName = '' then
+    raise ERttiException.Create('FromTextPrepare: Void property name');
+  if Find(PropName) <> nil then
+    raise ERttiException.CreateUtf8('Duplicated % property name', [PropName]);
+  result := Count;
+  inc(Count);
+  SetLength(List, Count);
+  with List[result] do
+  begin
+    Name := PropName;
+    fOrigName := PropName;
+  end;
+end;
+
+function TRttiCustomProps.AdjustAfterAdded: TRttiCustomFlags;
+var
+  i, n: PtrInt;
+  p: PRttiCustomProp;
+begin
+  CountNonVoid := FromNames(pointer(List), Count, NamesAsJsonArray);
+  if Count = 0 then
+  begin
+    result := [];
+    Managed := nil;
+    exit;
+  end;
+  result := [rcfHasNestedProperties, rcfHasOffsetSetJsonLoadProperties];
+  SetLength(Managed, Count);
+  n := 0;
+  p := pointer(List);
+  for i := 1 to Count do
+  begin
+    if (rcfIsManaged in p^.Value.Flags) and
+       (p^.OffsetGet >= 0) then
+    begin
+      if not Assigned(p^.Value.fCopy) then
+        raise ERttiException.Create('Paranoid managed Value.Copy');
+      include(result, rcfHasNestedManagedProperties);
+      Managed[n] := p;
+      inc(n);
+    end;
+    if (p^.OffsetSet < 0) or
+       (not Assigned(p^.Value.fJsonLoad)) then
+      exclude(result, rcfHasOffsetSetJsonLoadProperties);
+    inc(p);
+  end;
+  SetLength(Managed, n);
+end;
+
+procedure TRttiCustomProps.AsText(out Result: RawUtf8; IncludePropType: boolean;
+  const Prefix, Suffix: RawUtf8);
+var
+  tmp: TTextWriterStackBuffer;
+  i: PtrInt;
+begin
+  if Count > 0 then
+    with TTextWriter.CreateOwnedStream(tmp) do
+    try
+      AddString(Prefix);
+      for i := 0 to Count - 1 do
+        with List[i] do
+        begin
+          if i > 0 then
+            Add(',', ' ');
+          AddNoJsonEscapeUtf8(Name);
+          if IncludePropType then
+          begin
+            Add(':', ' ');
+            AddString(Value.Name);
+          end;
+        end;
+      AddString(Suffix);
+      SetText(Result);
+    finally
+      Free;
+    end;
+end;
+
+procedure TRttiCustomProps.InternalClear;
+begin
+  List := nil;
+  Count := 0;
+  Size := 0;
+  NotInheritedIndex := 0;
+  Managed := nil;
+end;
+
+procedure TRttiCustomProps.InternalAddFromClass(ClassInfo: PRttiInfo;
+  IncludeParents: boolean);
+var
+  rc: PRttiClass;
+  rp: PRttiProp;
+  rs: PRttiProps;
+  p: PRttiCustomProp;
+  n, c: PtrInt;
+begin
+  if (ClassInfo = nil) or
+     (ClassInfo^.Kind <> rkClass) then
+    exit;
+  rc := ClassInfo^.RttiNonVoidClass;
+  if IncludeParents then
+    // put parent properties first
+    InternalAddFromClass(rc^.ParentInfo, true);
+  rs := rc^.RttiProps;
+  n := rs^.PropCount;
+  if n = 0 then
+    exit;
+  c := Count;
+  NotInheritedIndex := c;
+  SetLength(List, c + n);
+  rp := rs^.PropList;
+  repeat
+    if c = 0 then
+      p := nil
+    else
+      p := FindCustomProp(pointer(List), @rp^.Name^[1], ord(rp^.Name^[0]), c);
+    if p = nil then
+    begin // first time we encounter this property
+      inc(Size, List[c].InitFrom(rp));
+      inc(c)
+    end
+    else // this property has been redefined in a sub-class
+      p^.InitFrom(rp);
+    rp := rp^.Next;
+    dec(n);
+  until n = 0;
+  if c = Count then
+    exit;
+  Count := c;
+  DynArrayFakeLength(List, c);
+end;
+
+procedure TRttiCustomProps.SetFromRecordExtendedRtti(RecordInfo: PRttiInfo);
+var
+  dummy: PtrInt;
+  all: TRttiRecordAllFields;
+  f: PRttiRecordAllField;
+  i: PtrInt;
+begin
+  if (RecordInfo = nil) or
+     not (RecordInfo^.Kind in rkRecordTypes) then
+    exit;
+  all := RecordInfo^.RecordAllFields(dummy);
+  InternalClear;
+  if all = nil then
+    // enhanced RTTI is available since Delphi 2010
+    exit;
+  Count := length(all);
+  SetLength(List, Count);
+  f := pointer(all);
+  for i := 0 to Count - 1 do
+    with List[i] do
+    begin
+      Value := Rtti.RegisterType(f^.TypeInfo);
+      inc(Size, Value.Size);
+      OffsetGet := f^.Offset;
+      OffsetSet := f^.Offset;
+      Name := ToUtf8(f^.Name^);
+      fOrigName := Name;
+      OrdinalDefault := NO_DEFAULT;
+      Stored := rpsTrue;
+      inc(f);
+    end;
+end;
+
+// TRttiCustom method defined here for proper inlining
+procedure TRttiCustom.ValueFinalize(Data: pointer);
+begin
+  if Assigned(fFinalize) then
+    // handle any kind of value from RTTI, including T*ObjArray
+    fFinalize(Data, fCache.Info)
+  else if rcfWithoutRtti in fFlags then
+    // was defined from text
+    if ArrayRtti <> nil then
+      // static or dynamic array (not T*ObjArray)
+      NoRttiArrayFinalize(Data)
+    else if rcfHasNestedManagedProperties in fFlags then
+      // rcfWithoutRtti records
+      fProps.FinalizeManaged(Data);
+end;
+
+procedure TRttiCustomProps.FinalizeManaged(Data: PAnsiChar);
+var
+  pp: PPRttiCustomProp;
+  p: PRttiCustomProp;
+  n: integer;
+begin
+  pp := pointer(Managed);
+  if pp <> nil then
+  begin
+    n := PDALen(PAnsiChar(pp) - _DALEN)^ + _DAOFF;
+    repeat
+      p := pp^;
+      p.Value.ValueFinalize(Data + p.OffsetSet);
+      inc(pp);
+      dec(n);
+    until n = 0;
+  end;
+end;
+
+procedure TRttiCustomProps.FinalizeAndClearPublishedProperties(Instance: TObject);
+var
+  pp: PRttiCustomProp;
+  p: PtrInt;
+  n: integer;
+  rtti: TRttiCustom;
+  empty: TVarData;
+begin
+  PInteger(@empty)^ := 0;
+  n := Count;
+  pp := pointer(List);
+  if pp <> nil then
+    repeat
+      p := pp^.OffsetSet;
+      if p >= 0 then
+      begin
+        inc(p, PtrInt(Instance));
+        rtti := pp^.Value;
+        rtti.ValueFinalize(pointer(p));
+        if pp^.OrdinalDefault <> NO_DEFAULT then
+          MoveByOne(@pp^.OrdinalDefault, pointer(p), rtti.Size)
+        else
+          FillZeroSmall(pointer(p), rtti.Size);
+      end
+      else
+        pp^.Prop^.SetValue(Instance, PVariant(@empty)^);
+      inc(pp);
+      dec(n);
+    until n = 0;
+end;
+
+// TRttiCustom method defined here for proper inlining
+procedure TRttiCustom.ValueCopy(Dest, Source: pointer);
+begin
+  if Assigned(fCopy) then
+    fCopy(Dest, Source, fCache.Info)
+  else
+    MoveFast(Source^, Dest^, fCache.Size);
+end;
+
+procedure TRttiCustomProps.CopyRecord(Dest, Source: PAnsiChar);
+var
+  pp: PPRttiCustomProp;
+  n: integer;
+  offset: PtrInt;
+begin
+  offset := 0;
+  pp := pointer(Managed);
+  if pp <> nil then
+  begin
+    n := PDALen(PAnsiChar(pp) - _DALEN)^ + _DAOFF;
+    repeat
+      offset := pp^.OffsetGet - offset;
+      if offset <> 0 then
+      begin
+        MoveFast(Source^, Dest^, offset); // fast copy unmanaged field
+        inc(Source, offset);
+        inc(Dest, offset);
+      end;
+      pp^.Value.fCopy(Dest, Source, pp^.Value.Info); // copy managed field
+      offset := pp^.Value.Size;
+      inc(Source, offset);
+      inc(Dest, offset);
+      inc(offset, pp^.OffsetGet);
+      inc(pp);
+      dec(n);
+    until n = 0;
+  end;
+  offset := Size - offset;
+  if offset > 0 then
+    MoveFast(Source^, Dest^, offset);
+end;
+
+procedure TRttiCustomProps.CopyProperties(Dest, Source: PAnsiChar);
+var
+  p: PRttiCustomProp;
+  n: integer;
+  v: TRttiVarData;
+  d, s: pointer;
+begin
+  if (Dest = nil) or
+     (Source = nil) then
+    exit; // avoid GPF
+  p := pointer(List); // all published properties, not only Managed[]
+  if p <> nil then
+  begin
+    n := PDALen(PAnsiChar(p) - _DALEN)^ + _DAOFF;
+    repeat
+      with p^ do
+        if (OffsetGet < 0) or
+           (OffsetSet < 0) then
+        begin
+          // there is a getter or a setter -> use local temporary value
+          GetValue(Source, v);
+          SetValue(Dest, v, {andclear=}true);
+        end
+        else
+        begin
+          d := Dest + OffsetSet;
+          s := Source + OffsetGet;
+          if p^.Value.Kind = rkClass then
+            if Assigned(Value.CopyObject) then
+              Value.CopyObject(PPointer(d)^, PPointer(s)^)
+            else
+              Value.Props.CopyProperties(PPointer(d)^, PPointer(s)^)
+          else
+            // direct content copy from the fields memory buffers
+            Value.ValueCopy(d, s);
+        end;
+      inc(p);
+      dec(n);
+    until n = 0;
+  end;
+end;
+
+
+{ TRttiCustom }
+
+type
+  EHook = class(Exception) // to access @Message private field offset
+  public
+    function MessageOffset: PtrInt; // for Delphi
+  end;
+
+function EHook.MessageOffset: PtrInt;
+begin
+  result := PtrInt(@Message);
+end;
+
+// since "var class" are not available in Delphi 6-7, and is inherited by
+// the children classes under latest Delphi versions (i.e. the "var class" is
+// shared by all inherited classes, whereas we want one var per class), we
+// reused one of the magic VMT slots, i.e. vmtAutoTable as filled for automated
+// methods, a relic from Delphi 2 that is not used  - see
+// http://hallvards.blogspot.com/2007/05/hack17-virtual-class-variables-part-ii.html
+// [you can define the NOPATCHVMT conditional to rely on our Rtti.FindType()
+//  internal hash table instead, for a slower but more conservative approach]
+
+procedure TRttiCustom.SetValueClass(aClass: TClass; aInfo: PRttiInfo);
+{$ifndef NOPATCHVMT}
+var
+  vmt: PPointer;
+{$endif NOPATCHVMT}
+begin
+  fValueClass := aClass;
+  // we need to register this class ASAP into RTTI list to avoid infinite calls
+  {$ifdef NOPATCHVMT}
+  Rtti.fHashTable[RK_TOSLOT[rkClass]].LastInfo := self; // faster FindType()
+  {$else}
+  // set vmtAutoTable slot for efficient Find(TClass) - to be done asap
+  vmt := Pointer(PAnsiChar(aClass) + vmtAutoTable);
+  if vmt^ = nil then
+    PatchCodePtrUInt(pointer(vmt), PtrUInt(self), {leaveunprotected=}true);
+  if vmt^ <> self then
+    raise ERttiException.CreateUtf8(
+      '%.SetValueClass(%): vmtAutoTable set to %', [self, aClass, vmt^]);
+  {$endif NOPATCHVMT}
+  // identify the most known class types - see also overriden mormot.core.json
+  if aClass.InheritsFrom(TCollection) then
+    fValueRtlClass := vcCollection
+  else if aClass.InheritsFrom(TStrings) then
+    fValueRtlClass := vcStrings
+  else if aClass.InheritsFrom(TObjectList) then
+    fValueRtlClass := vcObjectList
+  else if aClass.InheritsFrom(TList) then
+    fValueRtlClass := vcList
+  else if aClass.InheritsFrom(ESynException) then
+    fValueRtlClass := vcESynException
+  else if aClass.InheritsFrom(Exception) then
+    fValueRtlClass := vcException
+  else if aClass.InheritsFrom(TObjectWithID) then
+    fValueRtlClass := vcObjectWithID;
+  // register the published properties of this class using RTTI
+  fProps.InternalAddFromClass(aInfo, {includeparents=}true);
+  if fValueRtlClass = vcException then
+    // manual registration of the Exception.Message property
+    fProps.InternalAdd(TypeInfo(string), EHook(nil).MessageOffset, 'Message');
+end;
+
+procedure TRttiCustom.FromRtti(aInfo: PRttiInfo);
+var
+  dummy: integer;
+  pt: TRttiParserType;
+  pct: TRttiParserComplexType;
+  item: PRttiInfo;
+begin
+  if aInfo = nil then
+  begin
+    include(fFlags, rcfWithoutRtti);
+    exit; // will call NoRttiSetAndRegister() later on
+  end;
+  // retrieve RTTI into ready-to-be-consummed cache
+  aInfo^.ComputeCache(fCache);
+  if aInfo^.IsManaged then
+    // also check nested record fields
+    include(fFlags, rcfIsManaged);
+  case fCache.Kind of
+    rkClass:
+      SetValueClass(aInfo.RttiClass.RttiClass, aInfo);
+    {$ifdef FPC}rkObject,{$else}{$ifdef UNICODE}rkMRecord,{$endif}{$endif}
+    rkRecord:
+      fProps.SetFromRecordExtendedRtti(aInfo); // only for Delphi 2010+
+    rkLString:
+      if aInfo = TypeInfo(SpiUtf8) then
+        include(fFlags, rcfSpi);
+    rkDynArray:
+      begin
+        item := fCache.ItemInfo;
+        if item = nil then // unmanaged types
+        begin
+          // try to guess the actual type, e.g. a TGuid or an integer
+          item := aInfo^.DynArrayItemTypeExtended; // FPC or Delphi 2010+
+          if item = nil then
+          begin
+            // on Delphi 7-2009, recognize at least the most common types
+            pt := GuessItemTypeFromDynArrayInfo(aInfo, nil,
+              fCache.ItemSize, {exacttype=}true, dummy, @pct);
+            item := ParserTypeToTypeInfo(pt, pct);
+          end
+          else if item.Kind = rkClass then
+          begin
+            // no need to call RegisterObjArray() on FPC and Delphi 2010+ :)
+            include(fFlags, rcfObjArray);
+            fObjArrayClass := item.RttiClass^.RttiClass;
+          end;
+        end;
+        fArrayRtti := Rtti.RegisterType(item);
+        if (fArrayRtti <> nil) and
+           (fArrayFirstField = ptNone) then
+          if fArrayRtti.Kind in rkRecordOrDynArrayTypes then
+            // guess first field (using fProps[0] would break compatibility)
+            fArrayFirstField := GuessItemTypeFromDynArrayInfo(
+              aInfo, fCache.ItemInfo, fCache.ItemSize, {exacttype=}false, dummy)
+          else
+            fArrayFirstField := fArrayRtti.Parser;
+      end;
+    rkArray:
+      begin
+        fArrayRtti := Rtti.RegisterType(fCache.ItemInfo);
+        if (fArrayRtti = nil) or
+           not (rcfIsManaged in fArrayRtti.Flags) then
+          // a static array is as managed as its nested items
+          exclude(fFlags, rcfIsManaged);
+      end;
+  end;
+  // initialize processing callbacks
+  fFinalize := RTTI_FINALIZE[fCache.Kind];
+  fCopy := RTTI_MANAGEDCOPY[fCache.Kind];
+  if not Assigned(fCopy) then
+    case fCache.Size of // direct copy of most sizes, including class/pointer
+      1:
+        fCopy := @_Per1Copy;
+      2:
+        fCopy := @_Per2Copy;
+      4:
+        fCopy := @_Per4Copy;
+      8:
+        fCopy := @_Per8Copy;
+      16:
+        fCopy := @_Per16Copy;
+      32:
+        fCopy := @_Per32Copy;
+    end; // ItemCopy() will fallback to MoveFast() otherwise
+  pt := GuessTypeInfoToStandardParserType(aInfo, @pct);
+  SetParserType(pt, pct);
+end;
+
+destructor TRttiCustom.Destroy;
+begin
+  inherited Destroy;
+  ObjArrayClear(fOwnedRtti);
+  TObject(fPrivateSlot).Free;
+  ObjArrayClear(fPrivateSlots);
+end;
+
+constructor TRttiCustom.CreateFromText(const RttiDefinition: RawUtf8);
+var
+  P: PUtf8Char;
+begin
+  FromRtti(nil); // no associated RTTI
+  P := pointer(RttiDefinition);
+  SetPropsFromText(P, eeNothing, {NoRegister=}true);
+end;
+
+procedure TRttiCustom.NoRttiSetAndRegister(ParserType: TRttiParserType;
+  const TypeName: RawUtf8; DynArrayElemType: TRttiCustom; NoRegister: boolean);
+begin
+  if (fNoRttiInfo <> nil) or
+     not (rcfWithoutRtti in fFlags) then
+    raise ERttiException.CreateUtf8('Unexpected %.NoRttiSetAndRegister(%)',
+      [self, TypeName]);
+  // validate record/dynarray only supported types
+  case ParserType of
+    ptRecord:
+      begin
+        fCache.Kind := rkRecord;
+        fCache.Size := Props.Size; // as computed by caller
+      end;
+    ptDynArray:
+      begin
+        fCache.Kind := rkDynArray;
+        fCache.Size := SizeOf(pointer);
+        fArrayRtti := DynArrayElemType;
+        if (DynArrayElemType.Info <> nil) and
+           DynArrayElemType.Info.IsManaged then
+          fCache.ItemInfo := DynArrayElemType.Info; // as regular dynarray RTTI
+        fCache.ItemSize := DynArrayElemType.Size;
+      end;
+    ptClass:
+      begin
+        fCache.Kind := rkClass;
+        fCache.Size := SizeOf(pointer);
+      end;
+  else
+    raise ERttiException.CreateUtf8('Unexpected %.CreateWithoutRtti(%)',
+      [self, ToText(ParserType)^]);
+  end;
+  if NoRegister then
+  begin
+    // initialize the instance, but don't register to TRttiCustomList
+    SetParserType(ParserType, pctNone);
+    exit;
+  end;
+  // create fake RTTI which should be enough for our purpose
+  SetLength(fNoRttiInfo, length(TypeName) + 64); // all filled with zeros
+  fCache.Info := pointer(fNoRttiInfo);
+  fCache.Info.Kind := fCache.Kind;
+  if TypeName = '' then // we need some name to search for
+    fCache.Info.RawName := BinToHexDisplayLowerShort(@self, SizeOf(pointer))
+  else
+    fCache.Info.RawName := TypeName;
+  case ParserType of
+    ptRecord:
+      PRecordInfo(GetTypeData(fCache.Info))^.RecSize := fCache.Size;
+    ptDynArray:
+      GetTypeData(fCache.Info)^.elSize := fCache.ItemSize;
+  end;
+  // initialize process
+  SetParserType(ParserType, pctNone);
+  // register to the internal list
+  Rtti.AddToPairs(self, fCache.Info);
+end;
+
+function {%H-}_New_NotImplemented(Rtti: TRttiCustom): pointer;
+begin
+  raise ERttiException.CreateUtf8('%.ClassNewInstance(%:%) not implemented -> ' +
+    'please include mormot.core.json unit to register TRttiJson',
+    [Rtti, Rtti.Name, ToText(Rtti.Kind)^]);
+end;
+
+function TRttiCustom.SetParserType(aParser: TRttiParserType;
+  aParserComplex: TRttiParserComplexType): TRttiCustom;
+begin
+  fParser := aParser;
+  fParserComplex := aParserComplex;
+  fSetRandom := PT_RANDOM[aParser];
+  if fCache.Info <> nil then
+    ShortStringToAnsi7String(fCache.Info.Name^, fName);
+  fFlags := fFlags + fProps.AdjustAfterAdded;
+  if (fArrayRtti <> nil) and
+     (rcfIsManaged in fArrayRtti.Flags) then
+    include(fFlags, rcfArrayItemManaged);
+  if aParser in (ptStringTypes - [ptRawJson]) then
+    include(fFlags, rcfJsonString);
+  fNewInstance := @_New_NotImplemented; // raise ERttiException by default
+  result := self;
+end;
+
+procedure TRttiCustom.NoRttiArrayFinalize(Data: PAnsiChar);
+var
+  n: integer;
+  mem: PDynArrayRec;
+begin
+  if Kind = rkArray then
+  begin
+    // static array has fixed number of items
+    n := fCache.ItemCount;
+    mem := nil;
+  end
+  else
+  begin
+    // dereference rkDynArray pointer and retrieve length
+    mem := PPointer(Data)^;
+    if mem = nil then
+      exit;
+    PPointer(Data)^ := nil;
+    Data := pointer(mem);
+    dec(mem);
+    if mem.refCnt > 1 then
+      raise ERttiException.CreateUtf8('%.ArrayFinalize: % has refcnt=%',
+        [self, ArrayRtti.Name, mem.refCnt]);
+    n := mem.length;
+  end;
+  // release memory (T*ObjArray would never occur here)
+  repeat
+    ArrayRtti.ValueFinalize(Data);
+    inc(Data, ArrayRtti.Size);
+    dec(n);
+  until n = 0;
+  if mem <> nil then
+    FreeMem(mem);
+end;
+
+procedure TRttiCustom.ValueFinalizeAndClear(Data: pointer);
+begin
+  ValueFinalize(Data);
+  if not (rcfIsManaged in fFlags) then // managed fields are already set to nil
+    FillCharFast(Data^, fCache.Size, 0);
+end;
+
+function TRttiCustom.ValueIsVoid(Data: PAnsiChar): boolean;
+var
+  s: PtrInt;
+begin
+  case Kind of
+    rkVariant:
+      result := cardinal(PVarData(Data).VType) <= varNull;
+    rkClass:
+      result := IsObjectDefaultOrVoid(PObject(Data)^);
+    else
+      // work fast for ordinal types and also any pointer/managed values
+      begin
+        result := false;
+        s := fCache.Size;
+        if s >= 4 then
+          repeat
+            dec(s, 4);
+            if PInteger(Data + s)^ <> 0 then
+              exit;
+          until s < 4;
+        if s > 0 then
+          repeat
+            if Data[s - 1] <> #0 then
+              exit;
+            dec(s);
+          until s = 0;
+        result := true;
+      end;
+  end;
+end;
+
+function TRttiCustom.{%H-}ValueCompare(Data, Other: pointer;
+  CaseInsensitive: boolean): integer;
+begin
+  raise ERttiException.CreateUtf8('%.ValueCompare not implemented -> ' +
+    'please include mormot.core.json unit to register TRttiJson', [self]);
+end;
+
+function TRttiCustom.{%H-}ValueToVariant(Data: pointer;
+  out Dest: TVarData; Options: pointer): PtrInt;
+begin
+  raise ERttiException.CreateUtf8('%.ValueToVariant not implemented -> ' +
+    'please include mormot.core.json unit to register TRttiJson', [self]);
+end;
+
+procedure TRttiCustom.ValueRandom(Data: pointer);
+begin
+  fSetRandom(Data, self); // handle most simple kind of values from RTTI
+end;
+
+function TRttiCustom.ValueFullHash(const Elem): cardinal;
+begin
+  result := DefaultHasher(0, @Elem, fCache.ItemSize);
+end;
+
+function TRttiCustom.ValueFullCompare(const A, B): integer;
+begin
+  result := MemCmp(@A, @B, fCache.ItemSize); // use SSE2 asm on Intel/AMD
+end;
+
+function TRttiCustom.ValueIterateCount(Data: pointer): integer;
+begin
+  result := -1; // unsupported
+end;
+
+function TRttiCustom.ValueIterate(Data: pointer; Index: PtrUInt;
+  out ResultRtti: TRttiCustom): pointer;
+begin
+  result := nil;
+end;
+
+function TRttiCustom.ValueByPath(var Data: pointer; Path: PUtf8Char;
+  var Temp: TVarData; PathDelim: AnsiChar): TRttiCustom;
+begin
+  result := nil;
+end;
+
+function TRttiCustom.ValueSetText(Data: pointer; const Text: RawUtf8): boolean;
+var
+  v: Int64;
+  f: double;
+begin
+  result := true;
+  case Cache.Kind of
+    rkLString:
+      PRawUtf8(Data)^ := Text;
+    rkWString:
+      Utf8ToWideString(pointer(Text), length(Text), PWideString(Data)^);
+    {$ifdef HASVARUSTRING}
+    rkUString:
+      Utf8DecodeToUnicodeString(pointer(Text), length(Text), PUnicodeString(Data)^);
+    {$endif HASVARUSTRING}
+    rkFloat:
+      if ToDouble(Text, f) then
+        RTTI_TO_FLOAT[Cache.RttiFloat](Data, f)
+      else
+        result := false;
+    rkVariant:
+      RawUtf8ToVariant(Text, PVariant(Data)^);
+  else
+    if rcfHasRttiOrd in Cache.Flags then
+      if ToInt64(Text, v) then
+        RTTI_TO_ORD[Cache.RttiOrd](Data, v)
+      else
+        result := false
+    else if rcfGetInt64Prop in Cache.Flags then
+      result := ToInt64(Text, PInt64(Data)^)
+    else
+      result := false;
+  end;
+end;
+
+function TRttiCustom.ClassNewInstance: pointer;
+begin
+  result := fNewInstance(self);
+end;
+
+procedure TRttiCustom.SetClassNewInstance(FactoryMethod: TRttiCustomNewInstance);
+begin
+  fNewInstance := FactoryMethod;
+end;
+
+function TRttiCustom.HasClassNewInstance: boolean;
+begin
+  result := (self <> nil) and
+            (@fNewInstance <> @_New_NotImplemented);
+end;
+
+procedure TRttiCustom.PropsClear;
+begin
+  Props.InternalClear;
+  fFlags := fFlags - [rcfHasNestedProperties, rcfHasNestedManagedProperties];
+end;
+
+function TRttiCustom.PropFindByPath(var Data: pointer; FullName: PUtf8Char;
+  PathDelim: AnsiChar): PRttiCustomProp;
+var
+  rc: TRttiCustom;
+  n: ShortString;
+begin
+  rc := self;
+  repeat
+    result := nil;
+    if (rc = nil) or
+       (Data = nil) or
+       (rc.Props.CountNonVoid = 0) then
+      exit;
+    GetNextItemShortString(FullName, @n, PathDelim);
+    if n[0] = #0 then
+      exit;
+    result := FindCustomProp(
+      pointer(rc.Props.List), @n[1], ord(n[0]), rc.Props.Count);
+    if (result = nil) or
+       (FullName = nil) then
+      exit;
+    // search next path level
+    rc := result.Value;
+    if result.OffsetGet < 0 then
+      Data := nil
+    else if rc.Kind in rkRecordTypes then
+      inc(PAnsiChar(Data), result.OffsetGet)
+    else if rc.Kind = rkClass then
+      Data := PPointer(PAnsiChar(Data) + result.OffsetGet)^
+    else
+      Data := nil;
+  until false;
+end;
+
+function TRttiCustom.SetObjArray(Item: TClass): TRttiCustom;
+begin
+  if (self <> nil) and
+     (Kind = rkDynArray) and
+     (fCache.ItemSize = SizeOf(pointer)) and
+     (fCache.ItemInfo = nil) then
+  begin
+    fObjArrayClass := Item;
+    if Item = nil then
+    begin
+      // unregister
+      exclude(fFlags, rcfObjArray);
+      fArrayRtti := nil;
+      fFinalize := @_DynArrayClear;
+    end
+    else
+    begin
+      // register
+      include(fFlags, rcfObjArray);
+      fArrayRtti := Rtti.RegisterClass(Item); // will call _ObjClear()
+      fFinalize := @_ObjArrayClear; // calls RawObjectsClear()
+    end;
+  end;
+  SetParserType(Parser, ParserComplex); // notify format change
+  result := self;
+end;
+
+var
+  RttiArrayCount: integer;
+
+function TRttiCustom.SetBinaryType(BinarySize: integer): TRttiCustom;
+begin
+  if self <> nil then
+  begin
+    if BinarySize < 0 then
+    begin
+      BinarySize := 0;
+      exclude(fFlags, rcfBinary);
+      if not (Kind in rkStringTypes) then
+        exclude(fFlags, rcfJsonString);
+    end
+    else
+    begin
+      if BinarySize = 0 then
+        BinarySize := fCache.Size;
+      fFlags := fFlags + [rcfBinary, rcfJsonString];
+    end;
+    fBinarySize := BinarySize;
+    SetParserType(Parser, ParserComplex); // notify format change (e.g. for json)
+  end;
+  result := self;
+end;
+
+procedure TRttiCustom.SetPropsFromText(var P: PUtf8Char;
+  ExpectedEnd: TRttiCustomFromTextExpectedEnd; NoRegister: boolean);
+var
+  prop: TIntegerDynArray;
+  propcount: integer;
+  propname, typname, atypname: RawUtf8;
+  aname: PUtf8Char;
+  ee: TRttiCustomFromTextExpectedEnd;
+  alen, i: PtrInt;
+  pt, apt: TRttiParserType;
+  c, ac, nested: TRttiCustom;
+  cp: PRttiCustomProp;
+begin
+  PropsClear;
+  fCache.Size := 0;
+  propcount := 0;
+  while (P <> nil) and
+        (P^ <> #0) do
+  begin
+    // fill prop[] from new properties, and set associated type
+    if P^ = ',' then
+      inc(P);
+    if P^ in ['''', '"'] then
+    begin
+      // parse identifier as SQL string (e.g. "@field0")
+      P := UnQuoteSqlStringVar(P, propname);
+      if P = nil then
+        break;
+    end
+    else if not GetNextFieldProp(P, propname) then
+      // expect regular object pascal identifier (i.e. 0..9,a..z,A..Z,_)
+      break;
+    if P^ = ',' then
+    begin
+      // a,'b,b',c: integer
+      inc(P);
+      AddInteger(prop{%H-}, propcount, Props.FromTextPrepare(propname));
+      continue; // several properties defined with the same type
+    end;
+    AddInteger(prop, propcount, Props.FromTextPrepare(propname));
+    if P^ = ':' then
+      P := GotoNextNotSpace(P + 1);
+    // identify type for prop[]
+    typname := '';
+    atypname := '';
+    c := nil;
+    ac := nil;
+    pt := ptNone;
+    ee := eeNothing;
+    if P^ = '{' then
+    begin
+      // rec: { a,b: integer }
+      pt := ptRecord;
+      ee := eeCurly;
+      repeat
+        inc(P)
+      until (P^ > ' ') or
+            (P^ = #0);
+    end
+    else if P^ = '[' then
+    begin
+      // arr: [ a,b:integer ]
+      pt := ptDynArray;
+      ee := eeSquare;
+      repeat
+        inc(P)
+      until (P^ > ' ') or
+            (P^ = #0);
+    end
+    else
+    begin
+      if not GetNextFieldProp(P, typname) then
+        ERttiException.CreateUtf8('Missing field type for %', [propname]);
+      c := Rtti.RegisterTypeFromName(typname, @pt);
+      if c = nil then
+      case pt of
+        ptArray:
+          // array of ...
+          begin
+            if IdemPChar(P, 'OF') then
+            begin
+              // array of ....   or   array of record ... end
+              P := GotoNextNotSpace(P + 2);
+              if not GetNextFieldProp(P, atypname) or
+                 (P = nil) then
+                ERttiException.Create('Missing array field type');
+              FormatUtf8('[%%]', [atypname, RttiArrayCount], typname);
+              LockedInc32(@RttiArrayCount); // ensure genuine type name
+              ac := Rtti.RegisterTypeFromName(atypname, @apt);
+              if ac = nil then
+                if apt = ptRecord then
+                  // array of record ... end
+                  ee := eeEndKeyWord
+                else
+                  P := nil;
+            end
+            else
+              P := nil;
+            if P = nil then
+              raise ERttiException.CreateUtf8('Expected text definition syntax is ' +
+                '"array of record" or "array of KnownType" for %', [propname]);
+            pt := ptDynArray;
+          end;
+        ptRecord:
+          // record ... end
+          ee := eeEndKeyWord;
+        ptNone:
+          // unknown type name -> try from TArray<*>/T*DynArray/T*s patterns
+          begin
+            if PropNameEquals(typname, 'TArray') and
+               (P^ = '<') then
+            begin
+              // try generic syntax TArray<##>
+              inc(P);
+              if GetNextFieldProp(P, typname) and
+                 (P^ = '>') then
+              begin
+                inc(P);
+                ac := Rtti.RegisterTypeFromName(typname);
+              end;
+            end
+            else
+            begin
+              // try T##DynArray/T##s patterns
+              aname := pointer(typname);
+              alen := length(typname);
+              if (alen > 10) and
+                 (IdemPropName('DynArray', aname + alen - 8, 8) or
+                  IdemPropName('ObjArray', aname + alen - 8, 8)) then
+                dec(alen, 8)
+              else if (alen > 3) and
+                      (aname[aLen] in ['s', 'S']) then
+                dec(alen)
+              else
+                alen := 0;
+              if alen > 0 then
+              begin
+                // try TIntegerDynArray/TIntegers -> integer
+                ac := Rtti.RegisterTypeFromName(@PByteArray(typname)[1], alen - 1);
+                if ac = nil then
+                  // try TMyTypeObjArray/TMyTypes -> TMyType
+                  ac := Rtti.RegisterTypeFromName(pointer(typname), alen);
+              end;
+            end;
+            if ac = nil then
+              raise ERttiException.CreateUtf8(
+                'Unknown type %: %', [propname, typname]);
+            pt := ptDynArray;
+          end;
+      end;
+    end;
+    // retrieve nested type information
+    if ee <> eeNothing then
+    begin
+      if (c <> nil) or
+         (ac <> nil) or
+         not (pt in [ptRecord, ptDynArray]) then
+        raise ERttiException.CreateUtf8(
+          'Unexpected nested % %', [c, ToText(pt)^]);
+      nested := Rtti.GlobalClass.Create;
+      nested.FromRtti(nil);
+      nested.SetPropsFromText(P, ee, NoRegister);
+      nested.NoRttiSetAndRegister(ptRecord, '', nil, NoRegister);
+      if NoRegister then
+        ObjArrayAdd(fOwnedRtti, nested);
+      if pt = ptRecord then
+        // rec: record .. end  or  rec: { ... }
+        c := nested
+      else
+        // arr: [ ... ]   or  arr: array of record .. end
+        ac := nested;
+    end;
+    if ac <> nil then
+    begin
+      if (c <> nil) or
+         (pt <> ptDynArray) then // paranoid
+        raise ERttiException.CreateUtf8(
+          'Unexpected array % %', [c, ToText(pt)^]);
+      c := Rtti.GlobalClass.Create;
+      c.FromRtti(nil);
+      c.NoRttiSetAndRegister(ptDynArray, typname, ac, NoRegister);
+      if NoRegister then
+        ObjArrayAdd(fOwnedRtti, c);
+    end;
+    // set type for all prop[]
+    for i := 0 to propcount - 1 do
+    begin
+      cp := @Props.List[prop[i]];
+      cp^.Value := c;
+      cp^.OffsetGet := fCache.Size;
+      cp^.OffsetSet := fCache.Size;
+      cp^.OrdinalDefault := NO_DEFAULT;
+      cp^.Stored := rpsTrue;
+      inc(fCache.Size, c.fCache.Size);
+    end;
+    // continue until we reach end of buffer or ExpectedEnd
+    while P^ in [#1..' ', ';'] do
+      inc(P);
+    case ExpectedEnd 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;
+    propcount := 0;
+  end;
+  // set whole size and managed fields/properties
+  fProps.Size := fCache.Size;
+  fFlags := fFlags + Props.AdjustAfterAdded;
+end;
+
+function FindPrivateSlot(c: TClass; slot: PPointer): pointer;
+var
+  n: integer;
+begin
+  result := slot^;
+  if PClass(result)^ = c then // if fPrivateSlots[0].ClassType = c then
+    exit;
+  n := PDALen(PAnsiChar(slot) - _DALEN)^ + (_DAOFF - 1);
+  if n <> 0 then
+    repeat
+      inc(slot);
+      result := slot^;
+      if PClass(result)^ = c then
+        exit;
+      dec(n);
+    until n = 0;
+  result := nil;
+end;
+
+function TRttiCustom.GetPrivateSlot(aClass: TClass): pointer;
+begin
+  // is used by GetWeakZero() so benefits from a per-class lock
+  fPrivateSlotsSafe.Lock;
+  result := pointer(fPrivateSlots);
+  if result <> nil then
+    result := FindPrivateSlot(aClass, result);
+  fPrivateSlotsSafe.UnLock;
+end;
+
+function TRttiCustom.SetPrivateSlot(aObject: TObject): pointer;
+begin
+  fPrivateSlotsSafe.Lock;
+  try
+    result := pointer(fPrivateSlots);
+    if result <> nil then
+      result := FindPrivateSlot(PClass(aObject)^, result); // search again
+    if result = nil then
+    begin
+      ObjArrayAdd(fPrivateSlots, aObject);
+      result := aObject;
+    end
+    else
+      aObject.Free;
+  finally
+    fPrivateSlotsSafe.UnLock;
+  end;
+end;
+
+function TRttiCustom.ComputeFakeObjArrayRtti(aItemClass: TClass): TBytes;
+begin
+  if Kind <> rkDynArray then
+    raise ERttiException.CreateUtf8('ComputeFakeArrayRtti %?', [Name]);
+  SetLength(result, InstanceSize);
+  MoveFast(pointer(self)^, pointer(result)^, InstanceSize);  // weak copy
+  TRttiCustom(pointer(result)).fObjArrayClass := aItemClass; // overwrite class
+  TRttiCustom(pointer(result)).fArrayRtti := Rtti.RegisterClass(aItemClass);
+end; // no need to set other fields like Name
+
+
+{ TRttiCustomList }
+
+constructor TRttiCustomList.Create;
+begin
+  SetLength(fHashTable, RK_TOSLOT_MAX + 1); // 6-12KB zeroed allocation
+  fGlobalClass := TRttiCustom;
+  RegisterSafe.Init;
+end;
+
+destructor TRttiCustomList.Destroy;
+var
+  i: PtrInt;
+begin
+  for i := Count - 1 downto 0 do
+    fInstances[i].Free;
+  inherited Destroy;
+  RegisterSafe.Done;
+end;
+
+function LockedFind(Pairs, PEnd: PPointerArray; Info: PRttiInfo): TRttiCustom;
+  {$ifdef HASINLINE}inline;{$endif}
+begin
+  repeat
+    if Pairs[0] <> Info then
+    begin
+      Pairs := @Pairs[2]; // PRttiInfo/TRttiCustom pairs
+      if PAnsiChar(Pairs) >= PAnsiChar(PEnd) then
+        break;
+      continue;
+    end;
+    result := Pairs[1]; // found
+    exit;
+  until false;
+  result := nil; // not found
+end;
+
+function TRttiCustomList.FindType(Info: PRttiInfo): TRttiCustom;
+var
+  k: PRttiCustomListPairs;
+  h: PtrUInt;
+  p: PPointerArray; // ^TPointerDynArray
+begin
+  {$ifndef NOPATCHVMT}
+  if Info^.Kind <> rkClass then
+  begin
+  {$endif NOPATCHVMT}
+    // our dedicated "hash table of the poor" (tm) lookup
+    k := @fHashTable[RK_TOSLOT[Info^.Kind]];
+    // try latest found RTTI for this kind of type definition (naive but works)
+    result := k^.LastInfo;
+    if (result <> nil) and
+       (result.Info = Info) then
+      exit;
+    // O(1) hash of the PRttiInfo pointer using inlined xxHash32 shuffle stage
+    h := xxHash32Mixup(PtrUInt(Info)) and RTTIHASH_MAX;
+    // Knuth's magic number had more collision (even more with KNUTH_HASHPTR_MUL)
+    // h := cardinal(Info * KNUTH_HASH32_MUL) shr (32 - RTTIHASH_BITS);
+    // h := crc32cBy4(0, Info) and RTTICUSTOMTYPEINFOMAX; // slower, not better
+    // try latest found RTTI for this hash slot
+    result := k^.LastHash[h];
+    if (result <> nil) and
+       (result.Info = Info) then
+    begin
+      k^.LastInfo := result; // for faster lookup next time
+      exit; // avoid most ReadLock/ReadUnLock and LockedFind() search
+    end;
+    // thread-safe O(n) search in CPU L1 cache
+    k^.Safe.ReadLock;
+    p := pointer(k^.HashInfo[h]); // read TPointerDynArray within the lock
+    if p <> nil then
+      result := LockedFind(p, @p[PDALen(PAnsiChar(p) - _DALEN)^ + _DAOFF], Info);
+    k^.Safe.ReadUnLock;
+    if result <> nil then
+    begin
+      k^.LastInfo := result;   // aligned pointers are atomically accessed
+      k^.LastHash[h] := result;
+    end;
+  {$ifndef NOPATCHVMT}
+  end
+  else
+    // direct O(1) lookup of the vmtAutoTable slot for classes
+    result := PPointer(PAnsiChar(Info.RttiNonVoidClass.RttiClass) + vmtAutoTable)^;
+  {$endif NOPATCHVMT}
+end;
+
+{$ifdef NOPATCHVMT}
+function TRttiCustomList.FindClass(ObjectClass: TClass): TRttiCustom;
+begin
+  result := FindType(PPointer(PAnsiChar(ObjectClass) + vmtTypeInfo)^);
+end;
+{$else}
+class function TRttiCustomList.FindClass(ObjectClass: TClass): TRttiCustom;
+begin
+  result := PPointer(PAnsiChar(ObjectClass) + vmtAutoTable)^;
+end;
+{$endif NOPATCHVMT}
+
+function LockedFindNameInPairs(Pairs, PEnd: PPointerArray;
+  Name: PUtf8Char; NameLen: PtrInt): TRttiCustom;
+var
+  nfo: PRttiInfo;
+  p1, p2: PUtf8Char;
+label
+  no;
+begin
+  repeat
+    nfo := Pairs[0];
+    if ord(nfo^.RawName[0]) <> NameLen then
+    begin
+no:   Pairs := @Pairs[2]; // PRttiInfo/TRttiCustom pairs
+      if PAnsiChar(Pairs) >= PAnsiChar(PEnd) then
+        break;
+      continue;
+    end;
+    // inlined IdemPropNameUSameLenNotNull
+    p1 := @nfo^.RawName[1];
+    p2 := Name;
+    nfo := pointer(@p1[NameLen - SizeOf(cardinal)]);
+    dec(p2, PtrUInt(p1));
+    while PtrUInt(nfo) >= PtrUInt(p1) do
+      // compare 4 Bytes per loop
+      if (PCardinal(p1)^ xor PCardinal(@p2[PtrUInt(p1)])^) and $dfdfdfdf <> 0 then
+        goto no
+      else
+        inc(PCardinal(p1));
+    inc(PCardinal(nfo));
+    while PtrUInt(p1) < PtrUInt(nfo) do
+      // remaining bytes
+      if (ord(p1^) xor ord(p2[PtrUInt(p1)])) and $df <> 0 then
+        goto no
+      else
+        inc(PByte(p1));
+    result := Pairs[1];  // found
+    exit;
+  until false;
+  result := nil; // not found
+end;
+
+function RttiHashName(Name: PByteArray; Len: PtrUInt): byte;
+  {$ifdef HASINLINE}inline;{$endif}
+begin
+  result := Len;
+  repeat
+    dec(Len);
+    if Len = 0 then
+      break;
+    inc(result, Name[Len] and $df); // simple case-insensitive hash
+  until false;
+  result := result and RTTIHASH_MAX;
+end;
+
+function TRttiCustomList.FindName(Name: PUtf8Char; NameLen: PtrInt;
+  Kind: TRttiKind): TRttiCustom;
+var
+  k: PRttiCustomListPairs;
+  p: PPointer; // ^TPointerDynArray
+begin
+  if (Kind <> rkUnknown) and
+     (Name <> nil) and
+     (NameLen > 0) then
+  begin
+    k := @fHashTable[RK_TOSLOT[Kind]];
+    // try latest found name e.g. calling from JsonRetrieveObjectRttiCustom()
+    result := k^.LastName;
+    if (result <> nil) and
+       (PStrLen(PAnsiChar(pointer(result.Name)) - _STRLEN)^ = NameLen) and
+       IdemPropNameUSameLenNotNull(pointer(result.Name), Name, NameLen) then
+      exit;
+    // our dedicated "hash table of the poor" (tm) lookup
+    p := @k^.HashName[RttiHashName(pointer(Name), NameLen)];
+    k^.Safe.ReadLock;
+    result := p^; // read TPointerDynArray within the lock
+    if result <> nil then
+      result := LockedFindNameInPairs(@PPointerArray(result)[0],
+        @PPointerArray(result)[PDALen(PAnsiChar(result) - _DALEN)^ + _DAOFF],
+        Name, NameLen);
+    k^.Safe.ReadUnLock;
+    if result <> nil then
+      k^.LastName := result;
+  end
+  else
+    result := nil;
+end;
+
+function TRttiCustomList.FindName(Name: PUtf8Char; NameLen: PtrInt;
+  Kinds: TRttiKinds): TRttiCustom;
+var
+  k: TRttiKind;
+begin
+  // not very optimized, but called only at startup from Rtti.RegisterFromText()
+  if (Name <> nil) and
+     (NameLen > 0) then
+  begin
+    if Kinds = [] then
+      Kinds := rkAllTypes;
+    for k := succ(low(k)) to high(k) do
+      if k in Kinds then
+      begin
+        result := FindName(Name, NameLen, k);
+        if result <> nil then
+          exit;
+      end;
+  end;
+  result := nil;
+end;
+
+function TRttiCustomList.FindName(const Name: ShortString; Kinds: TRttiKinds): TRttiCustom;
+begin
+  result := FindName(@Name[1], ord(Name[0]), Kinds);
+end;
+
+function FindNameInArray(Pairs, PEnd: PPointerArray; ElemInfo: PRttiInfo): TRttiCustom;
+  {$ifdef HASINLINE} inline; {$endif}
+begin
+  repeat
+    result := Pairs[1]; // PRttiInfo/TRttiCustom pairs
+    if (result.ArrayRtti <> nil) and
+       (result.ArrayRtti.Info = ElemInfo) then
+      exit;
+    Pairs := @Pairs[2];
+  until Pairs = PEnd;
+  result := nil;
+end;
+
+function TRttiCustomList.FindByArrayRtti(ElemInfo: PRttiInfo): TRttiCustom;
+var
+  n: integer;
+  k: PRttiCustomListPairs;
+  p: PPointer; // TPointerDynArray
+begin
+  if ElemInfo = nil then
+  begin
+    result := nil;
+    exit;
+  end;
+  k := @fHashTable[RK_TOSLOT[rkDynArray]];
+  k^.Safe.ReadLock;
+  p := @k^.HashInfo;
+  n := length(k^.HashInfo);
+  repeat
+    result := p^;
+    if result <> nil then
+    begin
+      result := FindNameInArray(@PPointerArray(result)[1],
+        @PPointerArray(result)[PDALen(PAnsiChar(result) - _DALEN)^ + _DAOFF], ElemInfo);
+      if result <> nil then
+        break;
+    end;
+    inc(p);
+    dec(n);
+  until n = 0;
+  k^.Safe.ReadUnLock;
+end;
+
+function TRttiCustomList.DoRegister(Info: PRttiInfo): TRttiCustom;
+begin
+  if Info = nil then
+  begin
+    result := nil;
+    exit;
+  end;
+  RegisterSafe.Lock;
+  try
+    result := FindType(Info);  // search again (within RegisterSafe context)
+    if result <> nil then
+      exit; // already registered in the background
+    // initialize a new TRttiCustom/TRttiJson instance for this type
+    result := GlobalClass.Create;
+    // register ASAP to avoid endless recursion in FromRtti
+    AddToPairs(result, Info);
+    // now we can parse and process the RTTI
+    result.FromRtti(Info);
+  finally
+    RegisterSafe.UnLock;
+  end;
+  if FindType(Info) <> result then // paranoid check
+    raise ERttiException.CreateUtf8('%.DoRegister(%)?', [self, Info.RawName]);
+end;
+
+function TRttiCustomList.DoRegister(ObjectClass: TClass): TRttiCustom;
+var
+  info: PRttiInfo;
+begin
+  info := PPointer(PAnsiChar(ObjectClass) + vmtTypeInfo)^;
+  if info <> nil then
+    result := DoRegister(info)
+  else
+  begin
+    // generate fake RTTI for classes without {$M+}, e.g. TObject or Exception
+    RegisterSafe.Lock;
+    try
+      result := FindClass(ObjectClass); // search again (for thread safety)
+      if result <> nil then
+        exit; // already registered in the background
+      result := GlobalClass.Create;
+      result.FromRtti(nil);
+      result.SetValueClass(ObjectClass, nil);
+      result.NoRttiSetAndRegister(ptClass, ToText(ObjectClass));
+      GetTypeData(result.fCache.Info)^.ClassType := ObjectClass;
+    finally
+      RegisterSafe.UnLock;
+    end;
+  end;
+end;
+
+function TRttiCustomList.DoRegister(ObjectClass: TClass; ToDo: TRttiCustomFlags): TRttiCustom;
+var
+  i: integer;
+  p: PRttiCustomProp;
+begin
+  RegisterSafe.Lock;
+  try
+    result := DoRegister(ObjectClass);
+    if (rcfAutoCreateFields in ToDo) and
+       not (rcfAutoCreateFields in result.fFlags) then
+    begin
+      // detect T*AutoCreate fields
+      p := pointer(result.Props.List);
+      for i := 1 to result.Props.Count do
+      begin
+        case p^.Value.Kind of
+          rkClass:
+            if (p^.OffsetGet >= 0) and
+               (p^.OffsetSet >= 0) then
+            begin
+              PtrArrayAdd(result.fAutoCreateInstances, p);
+              PtrArrayAdd(result.fAutoDestroyClasses, p);
+            end;
+          rkDynArray:
+            if (rcfObjArray in p^.Value.Flags) and
+               (p^.OffsetGet >= 0) then
+              PtrArrayAdd(result.fAutoCreateObjArrays, p);
+          rkInterface:
+            if (p^.OffsetGet >= 0) and
+               (p^.OffsetSet >= 0) then
+              if p^.Value.HasClassNewInstance then
+                PtrArrayAdd(result.fAutoCreateInstances, p)
+              else
+                PtrArrayAdd(result.fAutoResolveInterfaces, p);
+        end;
+        inc(p);
+      end;
+      include(result.fFlags, rcfAutoCreateFields); // should be set once defined
+    end;
+  finally
+    RegisterSafe.UnLock;
+  end;
+end;
+
+
+procedure TRttiCustomList.AddToPairs(Instance: TRttiCustom; Info: PRttiInfo);
+
+  procedure AddPair(var List: TPointerDynArray);
+  var
+    n: PtrInt;
+  begin
+    n := length(List);
+    SetLength(List, n + 2);
+    List[n] := Info;
+    List[n + 1] := Instance;
+  end;
+
+var
+  k: PRttiCustomListPairs;
+begin
+  k := @fHashTable[RK_TOSLOT[Info^.Kind]];
+  k^.Safe.WriteLock; // needed when resizing k^.HashInfo/HashName[]
+  try
+    AddPair(k^.HashInfo[xxHash32Mixup(PtrUInt(Info)) and RTTIHASH_MAX]);
+    AddPair(k^.HashName[RttiHashName(@Info.RawName[1], ord(Info.RawName[0]))]);
+    ObjArrayAddCount(fInstances, Instance, Count); // to release memory
+    inc(Counts[Info^.Kind]); // Instance.Kind is not available from DoRegister
+  finally
+    k^.Safe.WriteUnLock;
+  end;
+end;
+
+procedure TRttiCustomList.SetGlobalClass(RttiClass: TRttiCustomClass);
+var
+  i: PtrInt;
+  pt: TRttiParserType;
+  ptc: TRttiParserComplexType;
+  regtypes: RawUtf8;
+  newunit: PShortString;
+begin
+  // ensure registration is done once for all
+  if Count <> 0 then
+  begin
+    for i := 0 to Count - 1 do
+      regtypes := {%H-}regtypes + fInstances[i].Name + ' ';
+    newunit := _ClassUnit(RttiClass);
+    raise ERttiException.CreateUtf8('Rtti.Count=% at Rtti.GlobalClass := % : ' +
+      'some types have been registered as % before % has been loaded and ' +
+      'initialized - please put % in the uses clause where you register '+
+      'your [ %] types, in addition to mormot.core.rtti',
+      [Count, RttiClass, fGlobalClass, newunit^, newunit^, regtypes]);
+  end;
+  fGlobalClass := RttiClass;
+  // now we can register all the known types to be found by name
+  for pt := succ(low(pt)) to high(pt) do    // standard types
+    PT_RTTI[pt] := Rtti.RegisterType(PT_INFO[pt]);
+  for ptc := succ(low(ptc)) to high(ptc) do // done as final in mormot.orm.base
+    PTC_RTTI[ptc] := Rtti.RegisterType(PTC_INFO[ptc]);
+  Rtti.RegisterTypes([
+    TypeInfo(SpiUtf8), TypeInfo(RawBlob), TypeInfo(TFileName)]);
+end;
+
+procedure TRttiCustomList.RegisterTypes(const Info: array of PRttiInfo);
+var
+  i: PtrInt;
+begin
+  for i := 0 to high(Info) do
+    RegisterType(Info[i]);
+end;
+
+function TRttiCustomList.RegisterTypeFromName(Name: PUtf8Char;
+  NameLen: PtrInt; ParserType: PRttiParserType): TRttiCustom;
+var
+  pt: TRttiParserType;
+  i: PtrInt;
+begin
+  if ParserType <> nil then
+    ParserType^ := ptNone;
+  if (Name = nil) or
+     (NameLen <= 0) then
+  begin
+    result := nil;
+    exit;
+  end;
+  repeat
+    i := ByteScanIndex(pointer(Name), NameLen, ord('.'));
+    if i < 0 then
+      break;
+    inc(i); // truncate 'unitname.typename' into 'typename'
+    inc(Name, i);
+    dec(NameLen, i);
+  until false;
+  result := FindName(Name, NameLen);
+  if result = nil then
+  begin
+    // array/record keywords, integer/cardinal FPC types not available by Find()
+    pt := AlternateTypeNameToRttiParserType(Name, NameLen);
+    if ParserType <> nil then
+      ParserType^ := pt;
+    result := PT_RTTI[pt];
+  end
+  else if ParserType <> nil then
+    ParserType^ := result.Parser;
+end;
+
+function TRttiCustomList.RegisterTypeFromName(const Name: RawUtf8;
+  ParserType: PRttiParserType): TRttiCustom;
+begin
+  result := RegisterTypeFromName(pointer(Name), length(Name), ParserType);
+end;
+
+function TRttiCustomList.RegisterClass(ObjectClass: TClass): TRttiCustom;
+begin
+  {$ifdef NOPATCHVMT}
+  result := FindType(PPointer(PAnsiChar(ObjectClass) + vmtTypeInfo)^);
+  {$else}
+  result := PPointer(PAnsiChar(ObjectClass) + vmtAutoTable)^;
+  {$endif NOPATCHVMT}
+  if result = nil then
+    result := DoRegister(ObjectClass);
+end;
+
+function TRttiCustomList.GetByClass(ObjectClass: TClass): TRttiCustom;
+begin
+  result := RegisterClass(ObjectClass);
+end;
+
+function TRttiCustomList.RegisterClass(aObject: TObject): TRttiCustom;
+begin
+  {$ifdef NOPATCHVMT}
+  result := FindType(PPointer(PPAnsiChar(aObject)^ + vmtTypeInfo)^);
+  {$else}
+  result := PPointer(PPAnsiChar(aObject)^ + vmtAutoTable)^;
+  {$endif NOPATCHVMT}
+  if result = nil then
+    result := DoRegister(PClass(aObject)^);
+end;
+
+function TRttiCustomList.RegisterAutoCreateFieldsClass(ObjectClass: TClass): TRttiCustom;
+begin
+  {$ifdef NOPATCHVMT}
+  result := FindType(PPointer(PAnsiChar(ObjectClass) + vmtTypeInfo)^);
+  {$else}
+  result := PPointer(PAnsiChar(ObjectClass) + vmtAutoTable)^;
+  {$endif NOPATCHVMT}
+  if (result = nil) or // caller should have checked it - paranoiac we are
+     not (rcfAutoCreateFields in result.Flags) then
+    result := DoRegister(ObjectClass, [rcfAutoCreateFields]);
+end;
+
+procedure TRttiCustomList.RegisterClasses(const ObjectClass: array of TClass);
+var
+  i: PtrInt;
+begin
+  for i := 0 to high(ObjectClass) do
+  begin
+    if ObjectClass[i].InheritsFrom(TCollection) then
+      raise ERttiException.CreateUtf8(
+        'RegisterClasses(%): please call RegisterCollection() instead',
+        [ObjectClass[i]]);
+    RegisterClass(ObjectClass[i]);
+  end;
+end;
+
+function TRttiCustomList.RegisterCollection(Collection: TCollectionClass;
+  CollectionItem: TCollectionItemClass): TRttiCustom;
+begin
+  result := RegisterClass(Collection);
+  if result <> nil then
+  begin
+    result.fCollectionItem := CollectionItem;
+    result.fCollectionItemRtti := RegisterClass(CollectionItem);
+  end;
+end;
+
+procedure TRttiCustomList.RegisterUnsafeSpiType(const Types: array of PRttiInfo);
+var
+  i: PtrInt;
+begin
+  for i := 0 to high(Types) do
+    include(RegisterType(Types[i]).fFlags, rcfSpi);
+end;
+
+function TRttiCustomList.RegisterBinaryType(Info: PRttiInfo;
+  BinarySize: integer): TRttiCustom;
+begin
+  result := RegisterType(Info).SetBinaryType(BinarySize);
+end;
+
+procedure TRttiCustomList.RegisterBinaryTypes(const InfoBinarySize: array of const);
+var
+  i, n: PtrInt;
+begin
+  n := length(InfoBinarySize);
+  if (n <> 0) and
+     (n and 1 = 0) then
+    for i := 0 to (n shr 1) - 1 do
+      if (InfoBinarySize[i * 2].VType <> vtPointer) or
+         not(InfoBinarySize[i * 2 + 1].VType {%H-}in [vtInteger, vtInt64]) then
+        raise ERttiException.Create('Rtti.RegisterBinaryTypes(?)')
+      else if RegisterType(InfoBinarySize[i * 2].VPointer).
+         SetBinaryType(InfoBinarySize[i * 2 + 1].VInteger) = nil then
+        raise ERttiException.CreateUtf8('Rtti.RegisterBinaryTypes: %?',
+           [PRttiInfo(InfoBinarySize[i * 2].VPointer)^.Name]);
+end;
+
+function TRttiCustomList.RegisterObjArray(DynArray: PRttiInfo;
+  Item: TClass): TRttiCustom;
+begin
+  if DynArray^.Kind = rkDynArray then
+    result := RegisterType(DynArray).SetObjArray(Item)
+  else
+    result := nil;
+end;
+
+procedure TRttiCustomList.RegisterObjArrays(const DynArrayItem: array of const);
+var
+  i, n: PtrInt;
+begin
+  n := length(DynArrayItem);
+  if (n <> 0) and
+     (n and 1 = 0) then
+    for i := 0 to (n shr 1) - 1 do
+      if (DynArrayItem[i * 2].VType <> vtPointer) or
+         (DynArrayItem[i * 2 + 1].VType <> vtClass) then
+        raise ERttiException.Create('Rtti.RegisterObjArrays([?])')
+      else
+        RegisterObjArray(DynArrayItem[i * 2].VPointer,
+          DynArrayItem[i * 2 + 1].VClass);
+end;
+
+function TRttiCustomList.RegisterFromText(DynArrayOrRecord: PRttiInfo;
+  const RttiDefinition: RawUtf8): TRttiCustom;
+var
+  P: PUtf8Char;
+  rttisize: integer;
+begin
+  if (DynArrayOrRecord = nil) or
+     not (DynArrayOrRecord^.Kind in rkRecordOrDynArrayTypes) then
+    raise ERttiException.Create('Rtti.RegisterFromText(DynArrayOrRecord?)');
+  RegisterSafe.Lock;
+  try
+    result := RegisterType(DynArrayOrRecord);
+    if result.Kind = rkDynArray then
+      if result.ArrayRtti = nil then
+      begin
+        result.fArrayRtti := RegisterFromText('', RttiDefinition);
+        result := result.fArrayRtti;
+        exit;
+      end
+      else
+        result := result.ArrayRtti;
+    result.PropsClear; // reset to the Base64 serialization if RttiDefinition=''
+    P := pointer(RttiDefinition);
+    if P <> nil then
+    begin
+      rttisize := result.Size; // was taken from RTTI
+      result.SetPropsFromText(P, eeNothing, {NoRegister=}false);
+      if result.Props.Size <> rttisize then
+        raise ERttiException.CreateUtf8('Rtti.RegisterFromText(%): text ' +
+          'definition  covers % bytes, but RTTI defined %',
+          [DynArrayOrRecord^.RawName, result.Props.Size, rttisize]);
+    end
+    else if result.Kind in rkRecordTypes then
+      result.Props.SetFromRecordExtendedRtti(result.Info); // only for Delphi 2010+
+    result.SetParserType(result.Parser, result.ParserComplex);
+  finally
+    RegisterSafe.UnLock;
+  end;
+end;
+
+function TRttiCustomList.RegisterFromText(const TypeName: RawUtf8;
+  const RttiDefinition: RawUtf8): TRttiCustom;
+var
+  P: PUtf8Char;
+  new: boolean;
+begin
+  RegisterSafe.Lock;
+  try
+    result := FindName(pointer(TypeName), length(TypeName));
+    new := result = nil;
+    if new then
+    begin
+      result := GlobalClass.Create;
+      result.FromRtti(nil);
+    end
+    else if not (result.Kind in rkRecordTypes) then
+      raise ERttiException.CreateUtf8('Rtti.RegisterFromText: existing % is a %',
+        [TypeName, ToText(result.Kind)^]);
+    result.PropsClear;
+    P := pointer(RttiDefinition);
+    result.SetPropsFromText(P, eeNothing, {NoRegister=}false);
+    if new then
+      result.NoRttiSetAndRegister(ptRecord, TypeName);
+  finally
+    RegisterSafe.UnLock;
+  end;
+end;
+
+procedure TRttiCustomList.RegisterFromText(
+  const TypeInfoTextDefinitionPairs: array of const);
+var
+  i, n: PtrInt;
+  d: RawUtf8;
+begin
+  n := length(TypeInfoTextDefinitionPairs);
+  if (n <> 0) and
+     (n and 1 = 0) then
+    for i := 0 to (n shr 1) - 1 do
+      if (TypeInfoTextDefinitionPairs[i * 2].VType <> vtPointer) or
+         not VarRecToUtf8IsString(TypeInfoTextDefinitionPairs[i * 2 + 1], d) then
+        raise ERttiException.Create('Rtti.RegisterFromText[?]')
+      else
+         RegisterFromText(TypeInfoTextDefinitionPairs[i * 2].VPointer, d);
+end;
+
+
+procedure CopyCollection(Source, Dest: TCollection);
+var
+  i: integer; // Items[] uses an integer
+begin
+  if (Source = nil) or
+     (Dest = nil) or
+     (Source.ClassType <> Dest.ClassType) then
+    exit;
+  Dest.BeginUpdate;
+  try
+    Dest.Clear;
+    for i := 0 to Source.Count - 1 do
+      CopyObject(Source.Items[i], Dest.Add); // Assign() fails for most objects
+  finally
+    Dest.EndUpdate;
+  end;
+end;
+
+procedure CopyStrings(Source, Dest: TStrings);
+begin
+  if (Source <> nil) and
+     (Dest <> nil) then
+    Dest.Assign(Source); // will do the copy RTL-style
+end;
+
+procedure CopyObject(aFrom, aTo: TObject);
+var
+  cf: TRttiCustom;
+  rf, rt: PRttiCustomProps;
+  pf, pt: PRttiCustomProp;
+  i: integer;
+  rvd: TRttiVarData;
+begin
+  if (aFrom <> nil) and
+     (aTo <> nil) then
+  begin
+    cf := Rtti.RegisterClass(PClass(aFrom)^);
+    if (cf.ValueRtlClass = vcCollection) and
+       (PClass(aFrom)^ = PClass(aTo)^)  then
+      // specific process of TCollection items
+      CopyCollection(TCollection(aFrom), TCollection(aTo))
+    else if (cf.ValueRtlClass = vcStrings) and
+            PClass(aTo)^.InheritsFrom(TStrings) then
+      // specific process of TStrings items using RTL-style copy
+      TStrings(aTo).Assign(TStrings(aFrom))
+    else if PClass(aTo)^.InheritsFrom(PClass(aFrom)^) then
+      // fast copy from RTTI properties of the common (or same) hierarchy
+      if Assigned(cf.CopyObject) then
+        cf.CopyObject(aTo, aFrom) // overriden e.g. for TOrm
+      else
+        cf.Props.CopyProperties(pointer(aTo), pointer(aFrom))
+    else
+    begin
+      // no common inheritance -> slower lookup by property name
+      rf := @cf.Props;
+      rt := @Rtti.RegisterClass(PClass(aTo)^).Props;
+      pf := pointer(rf.List);
+      for i := 1 to rf.Count do
+      begin
+        if pf^.Name <> '' then
+        begin
+          pt := rt.Find(pf^.Name);
+          if pt <> nil then
+          begin
+            pf^.GetValue(pointer(aFrom), rvd);
+            pt^.SetValue(pointer(aTo), rvd, {andclear=}true);
+          end;
+        end;
+        inc(pf);
+      end;
+    end;
+  end;
+end;
+
+function CopyObject(aFrom: TObject): TObject;
+begin
+  if aFrom = nil then
+    result := nil
+  else
+  begin
+    result := Rtti.RegisterClass(aFrom.ClassType).ClassNewInstance;
+    CopyObject(aFrom, result);
+  end;
+end;
+
+procedure SetDefaultValuesObject(Instance: TObject);
+var
+  rc: TRttiCustom;
+  p: PRttiCustomProp;
+  i: integer;
+begin
+  if Instance = nil then
+    exit;
+  rc := Rtti.RegisterClass(Instance);
+  p := pointer(rc.Props.List);
+  for i := 1 to rc.Props.Count do
+  begin
+    if p^.Value.Kind = rkClass then
+      SetDefaultValuesObject(p^.Prop.GetObjProp(Instance))
+    else if p^.OrdinalDefault <> NO_DEFAULT then
+      p^.Prop.SetInt64Value(Instance, p^.OrdinalDefault);
+    inc(p);
+  end;
+end;
+
+function GetInstanceByPath(var Instance: TObject; const Path: RawUtf8;
+  out Prop: PRttiCustomProp; PathDelim: AnsiChar): boolean;
+begin
+  result := false;
+  if (Instance = nil) or
+     (Path = '') then
+    exit;
+  Prop := Rtti.RegisterClass(Instance).
+    PropFindByPath(pointer(Instance), pointer(Path), PathDelim);
+  result := (Prop <> nil) and
+            (Instance <> nil);
+end;
+
+function SetValueObject(Instance: TObject; const Path: RawUtf8;
+  const Value: variant): boolean;
+var
+  p: PRttiCustomProp;
+begin
+  result := GetInstanceByPath(Instance, Path, p) and
+            p^.Prop^.SetValue(Instance, Value);
+end;
+
+procedure ClearObject(Value: TObject; FreeAndNilNestedObjects: boolean);
+var
+  rc: TRttiCustom;
+  p: PRttiCustomProp;
+  i: integer;
+begin
+  if Value = nil then
+    exit;
+  rc := Rtti.RegisterClass(Value.ClassType);
+  p := pointer(rc.Props.List);
+  for i := 1 to rc.Props.Count do
+  begin
+    if not FreeAndNilNestedObjects and
+       (p^.Value.Kind = rkClass) then
+      ClearObject(p^.Prop.GetObjProp(Value), false)
+    else if p^.OffsetSet >= 0 then
+      // for rkClass, _ObjClear() mimics FreeAndNil()
+      p^.Value.ValueFinalizeAndClear(PAnsiChar(Value) + p^.OffsetSet)
+    else
+      p^.SetValue(pointer(Value), PRttiVarData(@NullVarData)^, {andclear=}false);
+    inc(p);
+  end;
+end;
+
+procedure FinalizeObject(Value: TObject);
+begin
+  if Value <> nil then
+    Value.CleanupInstance;
+end;
+
+function IsObjectDefaultOrVoid(Value: TObject): boolean;
+var
+  rc: TRttiCustom;
+  p: PRttiCustomProp;
+  i: integer;
+begin
+  if Value <> nil then
+  begin
+    result := false;
+    rc := Rtti.RegisterClass(Value.ClassType);
+    if (rc.ValueRtlClass <> vcNone) and
+       (rc.ValueIterateCount(@Value) > 0) then
+      exit; // e.g. TObjectList.Count or TCollection.Count
+    p := pointer(rc.Props.List);
+    for i := 1 to rc.Props.Count do
+      if p^.ValueIsVoid(Value) then
+        inc(p)
+      else
+        exit;
+  end;
+  result := true;
+end;
+
+function SetObjectFromExecutableCommandLine(Value: TObject;
+  const SwitchPrefix, DescriptionSuffix: RawUtf8;
+  CommandLine: TExecutableCommandLine): boolean;
+var
+  rc: TRttiCustom;
+  p: PRttiCustomProp;
+  v, desc, def, typ: RawUtf8;
+  dolower: boolean;
+  i: integer;
+  v64: QWord;
+begin
+  result := false;
+  if Value = nil then
+    exit;
+  if CommandLine = nil then
+    CommandLine := Executable.Command;
+  rc := Rtti.RegisterClass(Value.ClassType);
+  p := pointer(rc.Props.List);
+  for i := 1 to rc.Props.Count do
+  begin
+    if (p^.Name <> '') and
+       not (p^.Value.Kind in rkComplexTypes) then
+    begin
+      desc := '';
+      dolower := false;
+      if p^.Value.Kind in [rkEnumeration, rkSet] then
+      begin
+        p^.Value.Cache.EnumInfo^.GetEnumNameTrimedAll(desc);
+        desc := StringReplaceChars(desc, ',', '|');
+        if UpperCaseU(desc) = desc then
+        begin
+          dolower := true;
+          desc := LowerCaseU(desc); // cosmetic
+        end;
+        if p^.Value.Kind = rkSet then // see TExecutableCommandLine.Describe
+          desc := ' - values: set of ' + desc
+        else
+          desc := ' - values: ' + desc;
+      end;
+      desc := FormatUtf8('%%%', [UnCamelCase(p^.Name), DescriptionSuffix, desc]);
+      if not p.ValueIsDefault(Value) then
+      begin
+        def := '';
+        typ := '';
+        if p^.Value.Kind in rkOrdinalTypes then
+        begin
+          v64 := p^.Prop^.GetInt64Value(Value);
+          case p^.Value.Kind of
+            rkEnumeration:
+              def := p^.Value.Cache.EnumInfo.GetEnumNameTrimed(v64);
+            rkSet:
+              if v64 <> 0 then
+                def := p^.Value.Cache.EnumInfo.GetSetName(v64, {trim=}true, '|');
+          else
+            begin
+              UInt64ToUtf8(v64, def);
+              typ := 'integer';
+            end;
+          end;
+          if dolower then
+            def := LowerCaseU(def);
+        end
+        else
+        begin
+          def := p^.Prop^.GetValueText(Value);
+          if p^.Value.Name = 'TFileName' then
+            if (PosEx('Folder', p^.Prop^.NameUtf8) <> 0) or
+               (PosEx('Path', p^.Prop^.NameUtf8) <> 0) then
+            typ := 'folder'
+          else
+            typ := 'filename'
+          else if (p^.Value.Kind = rkLString) and
+                  (p^.Value.Cache.CodePage <> CP_RAWBYTESTRING) then
+            typ := 'text';
+        end;
+        if typ <> '' then
+          desc := FormatUtf8('##% %', [typ, desc]); // ##typename to be trimmed
+        if def <> '' then
+          desc := FormatUtf8('% (default: %)', [desc, def]);
+      end;
+      if CommandLine.Get([SwitchPrefix + p^.Name], v, desc) and
+         p^.Prop^.SetValueText(Value, v) then // supports also enums and sets
+        result := true;
+    end;
+    inc(p);
+  end;
+end;
+
+
+{ *********** High Level TObjectWithID and TObjectWithCustomCreate Class Types }
+
+{ TObjectWithCustomCreate }
+
+constructor TObjectWithCustomCreate.Create;
+begin // do nothing by default but may be overriden
+end;
+
+class function TObjectWithCustomCreate.RttiCustom: TRttiCustom;
+begin
+  // inlined Rtti.Find(ClassType): we know it is the first slot
+  {$ifdef NOPATCHVMT}
+  result := Rtti.FindType(PPointer(PAnsiChar(self) + vmtTypeInfo)^);
+  {$else}
+  result := PPointer(PAnsiChar(self) + vmtAutoTable)^;
+  {$endif NOPATCHVMT}
+  // assert(result.InheritsFrom(TRttiCustom));
+end;
+
+class function TObjectWithCustomCreate.NewInstance: TObject;
+begin
+  {$ifndef NOPATCHVMT}
+  // register the class to the RTTI cache
+  if PPointer(PAnsiChar(self) + vmtAutoTable)^ = nil then
+    Rtti.DoRegister(self); // ensure TRttiCustom is set
+  {$endif NOPATCHVMT}
+  // bypass vmtIntfTable and vmt^.vInitTable (FPC management operators)
+  GetMem(pointer(result), InstanceSize); // InstanceSize is inlined
+  FillCharFast(pointer(result)^, InstanceSize, 0);
+  PPointer(result)^ := pointer(self); // store VMT
+end; // no benefit of rewriting FreeInstance/CleanupInstance
+
+class procedure TObjectWithCustomCreate.RttiCustomSetParser(Rtti: TRttiCustom);
+begin
+  // do nothing by default
+end;
+
+function TObjectWithCustomCreate.RttiBeforeWriteObject(W: TTextWriter;
+  var Options: TTextWriterWriteObjectOptions): boolean;
+begin
+  result := false; // default JSON serialization
+end;
+
+function TObjectWithCustomCreate.RttiWritePropertyValue(W: TTextWriter;
+  Prop: PRttiCustomProp; Options: TTextWriterWriteObjectOptions): boolean;
+begin
+  result := false; // default JSON serializaiton
+end;
+
+procedure TObjectWithCustomCreate.RttiAfterWriteObject(W: TTextWriter;
+  Options: TTextWriterWriteObjectOptions);
+begin
+  // nothing to do
+end;
+
+function TObjectWithCustomCreate.RttiBeforeReadObject(Ctxt: pointer): boolean;
+begin
+  result := false; // default JSON unserialization
+end;
+
+function TObjectWithCustomCreate.RttiBeforeReadPropertyValue(
+  Ctxt: pointer; Prop: PRttiCustomProp): boolean;
+begin
+  result := false; // default JSON unserialization
+end;
+
+procedure TObjectWithCustomCreate.RttiAfterReadObject;
+begin
+  // nothing to do
+end;
+
+procedure TObjectWithCustomCreateRttiCustomSetParser(
+  O: TObjectWithCustomCreateClass; Rtti: TRttiCustom);
+begin
+  O.RttiCustomSetParser(Rtti); // to circumvent some compiler issue
+end;
+
+
+{ TObjectWithID }
+
+constructor TObjectWithID.CreateWithID(aID: TID);
+begin
+  Create; // may have be overriden
+  fID := aID;
+end;
+
+class procedure TObjectWithID.RttiCustomSetParser(Rtti: TRttiCustom);
+begin
+  Rtti.Props.InternalAdd(
+    TypeInfo(TID), PtrInt(@TObjectWithID(nil).fID), 'ID', {first=}true);
+end;
+
+
+{$ifdef CPUX64}
+
+// very efficient branchless asm - rcx/rdi=Item1 rdx/rsi=Item2
+function TObjectWithIDDynArrayCompare(const Item1, Item2): integer;
+{$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe {$endif FPC}
+        mov     rcx, qword ptr [Item1]
+        mov     rdx, qword ptr [Item2]
+        mov     rcx, qword ptr [rcx + TObjectWithID.fID]
+        mov     rdx, qword ptr [rdx + TObjectWithID.fID]
+        xor     eax, eax
+        cmp     rcx, rdx
+        seta    al
+        sbb     eax, 0
+end;
+
+{$else}
+
+function TObjectWithIDDynArrayCompare(const Item1,Item2): integer;
+begin
+  // we assume Item1<>nil and Item2<>nil
+  result := CompareQWord(TObjectWithID(Item1).fID, TObjectWithID(Item2).fID);
+  // inlined branchless comparison or correct x86 asm for older Delphi
+end;
+
+{$endif CPUX64}
+
+function TObjectWithIDDynArrayHashOne(const Elem; Hasher: THasher): cardinal;
+begin
+  result := Hasher(0, pointer(@TObjectWithID(Elem).fID), SizeOf(TID));
+end;
+
+
+// ------ some integer conversion wrapper functions
+
+function FromRttiOrdSByte(P: PShortInt): Int64;
+begin
+  result := P^;
+end;
+
+function FromRttiOrdSWord(P: PSmallInt): Int64;
+begin
+  result := P^;
+end;
+
+function FromRttiOrdSLong(P: PInteger): Int64;
+begin
+  result := P^;
+end;
+
+function FromRttiOrdUByte(P: PByte): Int64;
+begin
+  result := P^;
+end;
+
+function FromRttiOrdUWord(P: PWord): Int64;
+begin
+  result := P^;
+end;
+
+function FromRttiOrdULong(P: PCardinal): Int64;
+begin
+  result := P^;
+end;
+
+procedure ToRttiOrd1(P: PByte; Value: PtrUInt);
+begin
+  P^ := Value;
+end;
+
+procedure ToRttiOrd2(P: PWord; Value: PtrUInt);
+begin
+  P^ := Value;
+end;
+
+procedure ToRttiOrd4(P: PCardinal; Value: PtrUInt);
+begin
+  P^ := Value;
+end;
+
+{$ifdef FPC_NEWRTTI}
+function FromRttiOrdInt64(P: PInt64): Int64;
+begin
+  result := P^;
+end;
+
+procedure ToRttiOrd8(P: PInt64; Value: PtrInt);
+begin
+  P^ := Value;
+end;
+{$endif FPC_NEWRTTI}
+
+procedure ToRttiFloat32(P: PSingle; Value: TSynExtended);
+begin
+  P^ := Value;
+end;
+
+procedure ToRttiFloat64(P: PDouble; Value: TSynExtended);
+begin
+  unaligned(P^) := Value;
+end;
+
+procedure ToRttiFloat80(P: PExtended; Value: TSynExtended);
+begin
+  P^ := Value;
+end;
+
+procedure ToRttiFloatCurr(P: PCurrency; Value: TSynExtended);
+begin
+  DoubleToCurrency(Value, P);
+end;
+
+
+procedure InitializeUnit;
+var
+  k: TRttiKind;
+  t: TRttiParserType;
+begin
+  RTTI_FROM_ORD[roSByte] := @FromRttiOrdSByte;
+  RTTI_FROM_ORD[roSWord] := @FromRttiOrdSWord;
+  RTTI_FROM_ORD[roSLong] := @FromRttiOrdSLong;
+  RTTI_FROM_ORD[roUByte] := @FromRttiOrdUByte;
+  RTTI_FROM_ORD[roUWord] := @FromRttiOrdUWord;
+  RTTI_FROM_ORD[roULong] := @FromRttiOrdULong;
+  RTTI_TO_ORD[roSByte] := @ToRttiOrd1;
+  RTTI_TO_ORD[roSWord] := @ToRttiOrd2;
+  RTTI_TO_ORD[roSLong] := @ToRttiOrd4;
+  RTTI_TO_ORD[roUByte] := @ToRttiOrd1;
+  RTTI_TO_ORD[roUWord] := @ToRttiOrd2;
+  RTTI_TO_ORD[roULong] := @ToRttiOrd4;
+  {$ifdef FPC_NEWRTTI}
+  RTTI_FROM_ORD[roSQWord] := @FromRttiOrdInt64;
+  RTTI_FROM_ORD[roUQWord] := @FromRttiOrdInt64;
+  RTTI_TO_ORD[roSQWord]   := @ToRttiOrd8;
+  RTTI_TO_ORD[roUQWord]   := @ToRttiOrd8;
+  {$endif FPC_NEWRTTI}
+  RTTI_TO_FLOAT[rfSingle]   := @ToRttiFloat32;
+  RTTI_TO_FLOAT[rfDouble]   := @ToRttiFloat64;
+  RTTI_TO_FLOAT[rfExtended] := @ToRttiFloat80;
+  RTTI_TO_FLOAT[rfCurr]     := @ToRttiFloatCurr;
+  RTTI_FINALIZE[rkLString]   := @_StringClear;
+  RTTI_FINALIZE[rkWString]   := @_WStringClear;
+  RTTI_FINALIZE[rkVariant]   := @_VariantClear;
+  RTTI_FINALIZE[rkArray]     := @_ArrayClear;
+  RTTI_FINALIZE[rkRecord]    := @FastRecordClear;
+  RTTI_FINALIZE[rkInterface] := @_InterfaceClear;
+  RTTI_FINALIZE[rkDynArray]  := @_DynArrayClear;
+  RTTI_TO_VARTYPE[rkInteger] := varInt64;
+  RTTI_TO_VARTYPE[rkInt64]   := varWord64;
+  RTTI_TO_VARTYPE[rkFloat]   := varDouble;
+  RTTI_TO_VARTYPE[rkLString] := varString;
+  RTTI_TO_VARTYPE[rkWString] := varOleStr;
+  RTTI_TO_VARTYPE[rkVariant] := varVariant;
+  RTTI_TO_VARTYPE[rkChar]    := varUnknown; // to use temp RawUtf8 -> varString
+  RTTI_TO_VARTYPE[rkWChar]   := varUnknown;
+  RTTI_TO_VARTYPE[rkSString] := varUnknown;
+  RTTI_MANAGEDCOPY[rkLString]   := @_LStringCopy;
+  RTTI_MANAGEDCOPY[rkWString]   := @_WStringCopy;
+  RTTI_MANAGEDCOPY[rkVariant]   := @_VariantCopy;
+  RTTI_MANAGEDCOPY[rkArray]     := @_ArrayCopy;
+  RTTI_MANAGEDCOPY[rkRecord]    := @_RecordCopy;
+  RTTI_MANAGEDCOPY[rkInterface] := @_InterfaceCopy;
+  RTTI_MANAGEDCOPY[rkDynArray]  := @_DynArrayCopy;
+  {$ifdef HASVARUSTRING}
+  RTTI_FINALIZE[rkUString]      := @_StringClear; // share same PStrRec layout
+  RTTI_TO_VARTYPE[rkUString]    := varUString;
+  RTTI_MANAGEDCOPY[rkUString]   := @_UStringCopy;
+  {$endif HASVARUSTRING}
+  {$ifdef FPC}
+  RTTI_FINALIZE[rkLStringOld]    := @_StringClear;
+  RTTI_FINALIZE[rkObject]        := @FastRecordClear;
+  RTTI_TO_VARTYPE[rkBool]        := varBoolean;
+  RTTI_TO_VARTYPE[rkQWord]       := varWord64;
+  RTTI_TO_VARTYPE[rkLStringOld]  := varString;
+  RTTI_TO_VARTYPE[rkObject]      := varAny;
+  RTTI_MANAGEDCOPY[rkLStringOld] := @_LStringCopy;
+  RTTI_MANAGEDCOPY[rkObject]     := @_RecordCopy;
+  {$else}
+  {$ifdef UNICODE}
+  RTTI_FINALIZE[rkMRecord]       := @FastRecordClear;
+  RTTI_TO_VARTYPE[rkMRecord]     := varAny;
+  RTTI_MANAGEDCOPY[rkMRecord]    := @_RecordCopy;
+  {$endif UNICODE}
+  {$endif FPC}
+  for k := low(k) to high(k) do
+  begin
+    // paranoid checks
+    if Assigned(RTTI_FINALIZE[k]) <> (k in rkManagedTypes) then
+      raise ERttiException.CreateUtf8('Unexpected RTTI_FINALIZE[%]', [ToText(k)^]);
+    if Assigned(RTTI_MANAGEDCOPY[k]) <> (k in rkManagedTypes) then
+      raise ERttiException.CreateUtf8('Unexpected RTTI_MANAGEDCOPY[%]', [ToText(k)^]);
+    // TJsonWriter.AddRttiVarData for TRttiCustomProp.GetValueDirect/GetValueGetter
+    case k of
+      rkEnumeration,
+      rkSet,
+      rkDynArray,
+      rkClass,
+      rkInterface,
+      {$ifdef FPC}rkObject,{$else}{$ifdef UNICODE}rkMRecord,{$endif}{$endif}
+      rkRecord,
+      rkArray:
+        RTTI_TO_VARTYPE[k] := varAny; // TVarData.VAny pointing to the value
+    end;
+  end;
+  RTTI_FINALIZE[rkClass]   := @_ObjClear;
+  PT_INFO[ptBoolean]       := TypeInfo(boolean);
+  PT_INFO[ptByte]          := TypeInfo(byte);
+  PT_INFO[ptCardinal]      := TypeInfo(cardinal);
+  PT_INFO[ptCurrency]      := TypeInfo(Currency);
+  PT_INFO[ptDouble]        := TypeInfo(Double);
+  PT_INFO[ptExtended]      := TypeInfo(Extended);
+  PT_INFO[ptInt64]         := TypeInfo(Int64);
+  PT_INFO[ptInteger]       := TypeInfo(integer);
+  PT_INFO[ptQWord]         := TypeInfo(QWord);
+  PT_INFO[ptRawByteString] := TypeInfo(RawByteString);
+  PT_INFO[ptRawJson]       := TypeInfo(RawJson);
+  PT_INFO[ptRawUtf8]       := TypeInfo(RawUtf8);
+  PT_INFO[ptSingle]        := TypeInfo(Single);
+  PT_INFO[ptString]        := TypeInfo(String);
+  PT_INFO[ptSynUnicode]    := TypeInfo(SynUnicode);
+  PT_INFO[ptDateTime]      := TypeInfo(TDateTime);
+  PT_INFO[ptDateTimeMS]    := TypeInfo(TDateTimeMS);
+  {$ifdef HASNOSTATICRTTI} // for Delphi 7/2007: use fake TypeInfo()
+  PT_INFO[ptGuid]          := @_TGUID;
+  PT_INFO[ptHash128]       := @_THASH128;
+  PT_INFO[ptHash256]       := @_THASH256;
+  PT_INFO[ptHash512]       := @_THASH512;
+  PT_INFO[ptPUtf8Char]     := @_PUTF8CHAR;
+  {$else}
+  PT_INFO[ptGuid]          := TypeInfo(TGuid);
+  PT_INFO[ptHash128]       := TypeInfo(THash128);
+  PT_INFO[ptHash256]       := TypeInfo(THash256);
+  PT_INFO[ptHash512]       := TypeInfo(THash512);
+  PT_INFO[ptPUtf8Char]     := TypeInfo(PUtf8Char);
+  {$endif HASNOSTATICRTTI}
+  {$ifdef HASVARUSTRING}
+  PT_INFO[ptUnicodeString]     := TypeInfo(UnicodeString);
+  PT_DYNARRAY[ptUnicodeString] := TypeInfo(TUnicodeStringDynArray);
+  {$else}
+  PT_INFO[ptUnicodeString]     := TypeInfo(SynUnicode);
+  PT_DYNARRAY[ptUnicodeString] := TypeInfo(TSynUnicodeDynArray);
+  {$endif HASVARUSTRING}
+  PT_INFO[ptUnixTime]      := TypeInfo(TUnixTime);
+  PT_INFO[ptUnixMSTime]    := TypeInfo(TUnixMSTime);
+  PT_INFO[ptVariant]       := TypeInfo(Variant);
+  PT_INFO[ptWideString]    := TypeInfo(WideString);
+  PT_INFO[ptWinAnsi]       := TypeInfo(WinAnsiString);
+  PT_INFO[ptWord]          := TypeInfo(Word);
+  // ptComplexTypes may have several matching TypeInfo() -> put generic
+  PT_INFO[ptOrm]           := TypeInfo(TID);
+  PT_INFO[ptTimeLog]       := TypeInfo(TTimeLog);
+  for t := succ(low(t)) to high(t) do
+    if Assigned(PT_INFO[t]) = (t in (ptComplexTypes - [ptOrm, ptTimeLog])) then
+      raise ERttiException.CreateUtf8('Unexpected PT_INFO[%]', [ToText(t)^]);
+  PTC_INFO[pctTimeLog]     := TypeInfo(TTimeLog);
+  PTC_INFO[pctID]          := TypeInfo(TID);
+  PTC_INFO[pctCreateTime]  := TypeInfo(TTimeLog);
+  PTC_INFO[pctModTime]     := TypeInfo(TTimeLog);
+  // may be overriden to the exact TRecordReference/TRecordVersion TypeInfo()
+  PTC_INFO[pctSpecificClassID] := TypeInfo(QWord);
+  PTC_INFO[pctRecordReference] := TypeInfo(QWord);
+  PTC_INFO[pctRecordVersion]   := TypeInfo(QWord);
+  PTC_INFO[pctRecordReferenceToBeDeleted] := TypeInfo(QWord);
+  PT_DYNARRAY[ptBoolean]       := TypeInfo(TBooleanDynArray);
+  PT_DYNARRAY[ptByte]          := TypeInfo(TByteDynArray);
+  PT_DYNARRAY[ptCardinal]      := TypeInfo(TCardinalDynArray);
+  PT_DYNARRAY[ptCurrency]      := TypeInfo(TCurrencyDynArray);
+  PT_DYNARRAY[ptDouble]        := TypeInfo(TDoubleDynArray);
+  PT_DYNARRAY[ptExtended]      := TypeInfo(TExtendedDynArray);
+  PT_DYNARRAY[ptInt64]         := TypeInfo(TInt64DynArray);
+  PT_DYNARRAY[ptInteger]       := TypeInfo(TIntegerDynArray);
+  PT_DYNARRAY[ptQWord]         := TypeInfo(TQWordDynArray);
+  PT_DYNARRAY[ptRawByteString] := TypeInfo(TRawByteStringDynArray);
+  PT_DYNARRAY[ptRawJson]       := TypeInfo(TRawJsonDynArray);
+  PT_DYNARRAY[ptRawUtf8]       := TypeInfo(TRawUtf8DynArray);
+  PT_DYNARRAY[ptSingle]        := TypeInfo(TSingleDynArray);
+  PT_DYNARRAY[ptString]        := TypeInfo(TStringDynArray);
+  PT_DYNARRAY[ptSynUnicode]    := TypeInfo(TSynUnicodeDynArray);
+  PT_DYNARRAY[ptDateTime]      := TypeInfo(TDateTimeDynArray);
+  PT_DYNARRAY[ptDateTimeMS]    := TypeInfo(TDateTimeMSDynArray);
+  PT_DYNARRAY[ptGuid]          := TypeInfo(TGuidDynArray);
+  PT_DYNARRAY[ptHash128]       := TypeInfo(THash128DynArray);
+  PT_DYNARRAY[ptHash256]       := TypeInfo(THash256DynArray);
+  PT_DYNARRAY[ptHash512]       := TypeInfo(THash512DynArray);
+  PT_DYNARRAY[ptOrm]           := TypeInfo(TIDDynArray);
+  PT_DYNARRAY[ptTimeLog]       := TypeInfo(TTimeLogDynArray);
+  PT_DYNARRAY[ptUnixTime]      := TypeInfo(TUnixTimeDynArray);
+  PT_DYNARRAY[ptUnixMSTime]    := TypeInfo(TUnixMSTimeDynArray);
+  PT_DYNARRAY[ptVariant]       := TypeInfo(TVariantDynArray);
+  PT_DYNARRAY[ptWideString]    := TypeInfo(TWideStringDynArray);
+  PT_DYNARRAY[ptWinAnsi]       := TypeInfo(TWinAnsiDynArray);
+  PT_DYNARRAY[ptWord]          := TypeInfo(TWordDynArray);
+  PT_DYNARRAY[ptPUtf8Char]     := TypeInfo(TPUtf8CharDynArray);
+  // prepare global thread-safe TRttiCustomList
+  Rtti := RegisterGlobalShutdownRelease(TRttiCustomList.Create);
+  ClassUnit := _ClassUnit;
+  // redirect most used FPC RTL functions to optimized x86_64 assembly
+  {$ifdef FPC_CPUX64}
+  RedirectRtl;
+  {$endif FPC_CPUX64}
+  // validate some redefined RTTI structures with compiler definitions
+  assert(SizeOf(TRttiVarData) = SizeOf(TVarData));
+  assert(@PRttiVarData(nil)^.PropValue = @PVarData(nil)^.VAny);
+  {$ifdef FPC_OR_UNICODE}
+  assert(SizeOf(TRttiRecordField) = SizeOf(TManagedField));
+  {$endif FPC_OR_UNICODE}
+end;
+
+
+initialization
+  InitializeUnit;
+
+
+end.
+
diff --git a/lib/dmustache/mormot.core.search.pas b/lib/dmustache/mormot.core.search.pas
new file mode 100644
index 00000000..9295af67
--- /dev/null
+++ b/lib/dmustache/mormot.core.search.pas
@@ -0,0 +1,6328 @@
+/// Framework Core Text, Binary and Time Search Engines
+// - this unit is a part of the Open Source Synopse mORMot framework 2,
+// licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+unit mormot.core.search;
+
+{
+  *****************************************************************************
+
+   Several Indexing and Search Engines, as used by other parts of the framework
+    - Files Search in Folders
+    - ScanUtf8, GLOB and SOUNDEX Text Search
+    - Efficient CSV Parsing using RTTI
+    - Versatile Expression Search Engine
+    - Bloom Filter Probabilistic Index
+    - Binary Buffers Delta Compression
+    - TDynArray Low-Level Binary Search and Iteration
+    - TSynFilter and TSynValidate Processing Classes
+    - Cross-Platform TSynTimeZone Time Zones
+
+  *****************************************************************************
+}
+
+interface
+
+{$I mormot.defines.inc}
+
+uses
+  classes,
+  sysutils,
+  mormot.core.base,
+  mormot.core.os,
+  mormot.core.rtti,
+  mormot.core.unicode,
+  mormot.core.text,
+  mormot.core.buffers,
+  mormot.core.datetime,
+  mormot.core.data,
+  mormot.core.json;
+
+
+{ ****************** Files Search in Folders }
+
+type
+  {$A-}
+  /// define one file found result item, as returned by FindFiles()
+  // - Delphi "object" is buggy on stack -> also defined as record with methods
+  {$ifdef USERECORDWITHMETHODS}
+  TFindFiles = record
+  {$else}
+  TFindFiles = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    /// the matching file name
+    // - including its folder name unless ffoExcludesDir is set
+    Name: TFileName;
+    /// the matching file attributes
+    Attr: integer;
+    /// the matching file size
+    Size: Int64;
+    /// the matching file local 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;
+
+  /// one optional feature of FindFiles()
+  // - ffoSortByName will sort the result files by extension then name
+  // - ffoExcludesDir won't include the path in TFindFiles.Name
+  // - ffoSubFolder will search within nested folders
+  TFindFilesOption = (
+    ffoSortByName,
+    ffoExcludesDir,
+    ffoSubFolder);
+  /// the optional features of FindFiles()
+  TFindFilesOptions = set of TFindFilesOption;
+
+/// search for matching files by names
+// - just an enhanced wrapper around FindFirst/FindNext with some options
+// - you may specify several masks in Mask, e.g. as '*.jpg;*.jpeg'
+function FindFiles(const Directory: TFileName;
+  const Mask: TFileName = FILES_ALL; const IgnoreFileName: TFileName = '';
+  Options: TFindFilesOptions = []): TFindFilesDynArray;
+
+/// search for matching file names
+// - just a wrapper around FindFilesDynArrayToFileNames(FindFiles())
+function FileNames(const Directory: TFileName;
+  const Mask: TFileName = FILES_ALL; Options: TFindFilesOptions = [];
+  const IgnoreFileName: TFileName = ''): TFileNameDynArray; overload;
+
+/// search for matching file names from path-delimited content
+// - is a wrapper around FindFileNames(MakePath())
+function FileNames(const Path: array of const; const Mask: TFileName = FILES_ALL;
+  Options: TFindFilesOptions = []): TFileNameDynArray; overload;
+
+/// convert a result list, as returned by FindFiles(), into an array of Files[].Name
+function FindFilesDynArrayToFileNames(const Files: TFindFilesDynArray): TFileNameDynArray;
+
+/// sort a FindFiles() result list by its TFindFiles[].Timestamp field
+procedure FindFilesSortByTimestamp(var Files: TFindFilesDynArray);
+
+type
+  /// one optional feature of SynchFolders()
+  // - process recursively nested folders if sfoSubFolder is included
+  // - use file content instead of file date check if sfoByContent is included
+  // - display synched file name on console if sfoWriteFileNameToConsole is included
+  TSynchFoldersOption = (
+    sfoSubFolder,
+    sfoByContent,
+    sfoWriteFileNameToConsole);
+  /// the optional features of SynchFolders()
+  TSynchFoldersOptions = set of TSynchFoldersOption;
+
+/// ensure all files in Dest folder(s) do match the one in Reference
+// - won't copy all files from Reference folders, but will update files already
+// existing in Dest, which did change since last synchronization
+// - file copy will use in-memory loading, so won't work well with huge files
+// - returns the number of files copied during the process
+function SynchFolders(const Reference, Dest: TFileName;
+  Options: TSynchFoldersOptions = []): integer;
+
+/// copy all files from a source folder to a destination folder
+// - will copy only new or changed files, keeping existing identical files
+// - file copy will use stream loading, so would cope with huge files
+// - returns the number of fields copied during the process, -1 on error
+function CopyFolder(const Source, Dest: TFileName;
+  Options: TSynchFoldersOptions = []): integer;
+
+
+{ ****************** ScanUtf8, GLOB and SOUNDEX Text Search }
+
+/// 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[] dynamic array
+function ScanUtf8(const text, fmt: RawUtf8; const values: array of pointer;
+  ident: PRawUtf8DynArray = nil): integer; overload;
+
+/// read text from P/PLen and store it into values[] according to fmt specifiers
+function ScanUtf8(P: PUtf8Char; PLen: PtrInt; const fmt: RawUtf8;
+  const values: array of pointer; ident: PRawUtf8DynArray): integer; overload;
+
+
+type
+  PMatch = ^TMatch;
+
+  // used when inlining TMatch.Match
+  TMatchSearchFunction = function(aMatch: PMatch;
+    aText: PUtf8Char; aTextLen: PtrInt): boolean;
+
+  /// low-level structure used by IsMatch() for actual GLOB search
+  // - you can use this object to prepare a given pattern, e.g. in a loop
+  // - implemented as a fast brute-force state-machine without any heap allocation
+  // - some common patterns ('exactmatch', 'startwith*', '*endwith', '*contained*')
+  // are handled with dedicated code, optionally with case-insensitive search
+  // - PrepareContains() is the most efficient method for '*contained*' search
+  // - consider using TMatchs (or SetMatchs/TMatchDynArray) if you expect to
+  // search for several patterns, or even TExprParserMatch for expression search
+  {$ifdef USERECORDWITHMETHODS}
+  TMatch = record
+  {$else}
+  TMatch = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    Pattern, Text: PUtf8Char;
+    P, T, PMax, TMax: PtrInt;
+    Upper: PNormTable;
+    State: (sNONE, sABORT, sEND, sLITERAL, sPATTERN, sRANGE, sVALID);
+    procedure MatchAfterStar;
+    procedure MatchMain;
+  public
+    /// published for proper inlining
+    Search: TMatchSearchFunction;
+    /// initialize the internal fields for a given glob search pattern
+    // - note that the aPattern instance should remain in memory, since it will
+    // be pointed to by the PatternText private field of this object
+    procedure Prepare(const aPattern: RawUtf8;
+      aCaseInsensitive, aReuse: boolean); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// initialize the internal fields for a given glob search pattern
+    // - note that the aPattern buffer should remain in memory, since it will
+    // be pointed to by the PatternText private field of this object
+    procedure Prepare(aPattern: PUtf8Char; aPatternLen: integer;
+      aCaseInsensitive, aReuse: boolean); overload;
+    /// initialize low-level internal fields for'*aPattern*' search
+    // - this method is faster than a regular Prepare('*' + aPattern + '*'),
+    // since it may use the SBNDMQ2 algorithm for patterns of length 2..31
+    // - warning: the supplied aPattern variable may be modified in-place to be
+    // filled with some lookup buffer, when SBNDMQ2 is triggered
+    procedure PrepareContains(var aPattern: RawUtf8;
+      aCaseInsensitive: boolean); overload;
+    /// initialize low-level internal fields for a custom search algorithm
+    procedure PrepareRaw(aPattern: PUtf8Char; aPatternLen: integer;
+      aSearch: TMatchSearchFunction);
+    /// returns TRUE if the supplied content matches the prepared glob pattern
+    // - this method is not thread-safe
+    function Match(const aText: RawUtf8): boolean; overload;
+      {$ifdef FPC} inline;{$endif}
+    /// returns TRUE if the supplied content matches the prepared glob pattern
+    // - this method is not thread-safe
+    function Match(aText: PUtf8Char; aTextLen: PtrInt): boolean; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// returns TRUE if the supplied content matches the prepared glob pattern
+    // - this method IS thread-safe, and won't lock
+    function MatchThreadSafe(const aText: RawUtf8): boolean;
+    /// returns TRUE if the supplied VCL/LCL content matches the prepared glob pattern
+    // - this method IS thread-safe, will use on-stack UTF-8 temporary conversion
+    // if possible, and won't lock
+    function MatchString(const aText: string): boolean;
+    /// returns TRUE if this search pattern matches another
+    function Equals(const aAnother: TMatch): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// access to the pattern length as stored in PMax + 1
+    function PatternLength: integer;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// access to the pattern text as stored in Pattern
+    function PatternText: PUtf8Char;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// check if the pattern search was defined as case-insensitive
+    function CaseInsensitive: boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+  end;
+
+  /// stores an array of GLOB search engines
+  // - use SetMatchs() to initialize such an array from a CSV pattern text
+  TMatchDynArray = array of TMatch;
+
+  /// TMatch descendant owning a copy of the Pattern string to avoid GPF issues
+  TMatchStore = record
+    /// access to the research criteria
+    // - defined as a nested record (and not an object) to circumvent Delphi bug
+    Pattern: TMatch;
+    /// Pattern.Pattern PUtf8Char will point to this instance
+    PatternInstance: RawUtf8;
+  end;
+
+  TMatchStoreDynArray = array of TMatchStore;
+
+  /// stores several TMatch instances, from a set of glob patterns
+  TMatchs = class(TSynPersistent)
+  protected
+    fMatch: TMatchStoreDynArray;
+    fMatchCount: integer;
+  public
+    /// add once some glob patterns to the internal TMach list
+    // - aPatterns[] follows the IsMatch() syntax
+    constructor Create(const aPatterns: TRawUtf8DynArray;
+      CaseInsensitive: boolean); reintroduce; overload;
+    /// add once some glob patterns to the internal TMach list
+    // - aPatterns[] follows the IsMatch() syntax
+    procedure Subscribe(const aPatterns: TRawUtf8DynArray;
+      CaseInsensitive: boolean); overload; virtual;
+    /// add once some glob patterns to the internal TMach list
+    // - each CSV item in aPatterns follows the IsMatch() syntax
+    procedure Subscribe(const aPatternsCsv: RawUtf8;
+      CaseInsensitive: boolean); overload;
+    /// search patterns in the supplied UTF-8 text
+    // - returns -1 if no filter has been subscribed
+    // - returns -2 if there is no match on any previous pattern subscription
+    // - returns fMatch[] index, i.e. >= 0 number on first matching pattern
+    // - this method is thread-safe
+    function Match(const aText: RawUtf8): integer; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// search patterns in the supplied UTF-8 text buffer
+    function Match(aText: PUtf8Char; aLen: integer): integer; overload;
+    /// search patterns in the supplied RTL string text
+    // - could be used on a TFileName for instance
+    // - will avoid any memory allocation if aText is small enough
+    function MatchString(const aText: string): integer;
+  end;
+
+  /// store a decoded URI as full path and file/resource name
+  {$ifdef USERECORDWITHMETHODS}
+  TUriMatchName = record
+  {$else}
+  TUriMatchName = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    Path, Name: TValuePUtf8Char;
+    /// to be called once Path has been populated to compute Name
+    procedure ParsePath;
+  end;
+
+  /// efficient GLOB path or resource name lockup for an URI
+  // - using mORMot fast TMatch engine
+  {$ifdef USERECORDWITHMETHODS}
+  TUriMatch = record
+  {$else}
+  TUriMatch = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    Init: TLightLock;
+    Names, Paths: TMatchDynArray;
+    procedure DoInit(csv: PUtf8Char; caseinsensitive: boolean);
+  public
+    /// main entry point of the GLOB resource/path URI pattern matching
+    // - will thread-safe initialize the internal TMatch instances if necessary
+    function Check(const csv: RawUtf8; const uri: TUriMatchName;
+      caseinsensitive: boolean): boolean;
+  end;
+
+
+
+/// fill the Match[] dynamic array with all glob patterns supplied as CSV
+// - returns how many patterns have been set in Match[|]
+// - note that the CsvPattern instance should remain in memory, since it will
+// be pointed to by the Match[].Pattern private field
+function SetMatchs(const CsvPattern: RawUtf8; CaseInsensitive: boolean;
+  out Match: TMatchDynArray; CsvSep: AnsiChar = ','): integer; overload;
+
+/// fill the Match[0..MatchMax] static array with all glob patterns supplied as CSV
+// - note that the CsvPattern instance should remain in memory, since it will
+// be pointed to by the Match[].Pattern private field
+function SetMatchs(CsvPattern: PUtf8Char; CaseInsensitive: boolean;
+  Match: PMatch; MatchMax: integer; CsvSep: AnsiChar = ','): integer; overload;
+
+/// fill a TMatch instance with the next glob pattern supplied as CSV
+function SetNextMatch(P: PUtf8Char; var Dest: TMatch;
+  CaseInsensitive, Reuse: boolean; CsvSep: AnsiChar): PUtf8Char;
+
+/// search if one TMach is already registered in the Several[] dynamic array
+function MatchExists(const One: TMatch; const Several: TMatchDynArray): boolean;
+
+/// add one TMach if not already registered in the Several[] dynamic array
+function MatchAdd(const One: TMatch; var Several: TMatchDynArray): boolean;
+
+/// allocate one TMach in the Several[] dynamic array
+function MatchNew(var Several: TMatchDynArray): PMatch;
+
+/// returns TRUE if Match=nil or if any Match[].Match(Text) is TRUE
+function MatchAny(const Match: TMatchDynArray; const Text: RawUtf8): boolean; overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// returns TRUE if Match=nil or if any Match[].Match(Text, TextLen) is TRUE
+function MatchAny(Match: PMatch; Text: PUtf8Char; TextLen: PtrInt): boolean; overload;
+
+/// apply the CSV-supplied glob patterns to an array of RawUtf8
+// - any text not matching the pattern will be deleted from the array
+// - the patterns are specified as CSV, separated by ','
+procedure FilterMatchs(const CsvPattern: RawUtf8; CaseInsensitive: boolean;
+  var Values: TRawUtf8DynArray; CsvSep: AnsiChar = ','); overload;
+
+/// apply the CSV-supplied glob patterns to an array of string
+// - any text not matching the pattern will be deleted from the array
+// - the patterns are specified as CSV, separated by ','
+procedure FilterMatchs(const CsvPattern: RawUtf8; CaseInsensitive: boolean;
+  var Values: TStringDynArray; CsvSep: AnsiChar = ','); overload;
+
+/// return TRUE if the supplied content matches a glob pattern
+// - ?  Matches any single character
+// - *	Matches any contiguous characters
+// - [abc]  Matches a or b or c at that position
+// - [^abc]	Matches anything but a or b or c at that position
+// - [!abc]	Matches anything but a or b or c at that position
+// - [a-e]  Matches a through e at that position
+// - [abcx-z]  Matches a or b or c or x or y or or z, as does [a-cx-z]
+// - 'ma?ch.*'	would match match.exe, mavch.dat, march.on, etc..
+// - 'this [e-n]s a [!zy]est' would match 'this is a test', but would not
+// match 'this as a test' nor 'this is a zest'
+// - consider using TMatch or TMatchs if you expect to reuse the pattern
+function IsMatch(const Pattern, Text: RawUtf8;
+  CaseInsensitive: boolean = false): boolean;
+
+/// return TRUE if the supplied content matches a glob pattern, using RTL strings
+// - is a wrapper around IsMatch() with fast UTF-8 conversion
+function IsMatchString(const Pattern, Text: string;
+  CaseInsensitive: boolean = false): boolean;
+
+/// return TRUE if the supplied content matches one or several glob patterns
+// - the patterns are specified as CSV, separated by ','
+function IsMatchs(const CsvPattern, Text: RawUtf8;
+  CaseInsensitive: boolean = false; CsvSep: AnsiChar = ','): boolean; overload;
+
+/// return TRUE if the supplied content matches one or several glob patterns
+// - the patterns are specified as CSV, separated by ','
+function IsMatchs(CsvPattern, Text: PUtf8Char; TextLen: PtrInt;
+  CaseInsensitive: boolean = false; CsvSep: AnsiChar = ','): boolean; overload;
+
+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 USERECORDWITHMETHODS}
+  TSynSoundEx = record
+  {$else}
+  TSynSoundEx = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    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 interesting soundex char
+  // - default is to use 8-bit, i.e. 4 soundex chars, which is the
+  // standard approach
+  // - for a more detailed soundex, use 4 bits resolution, which will
+  // compute up to 7 soundex chars in a cardinal (that's our choice)
+  SOUNDEX_BITS = 4;
+
+
+{ ******************  Efficient CSV Parsing using RTTI }
+
+/// parse a CSV buffer into a TDynArray of records using its RTTI fields
+// - TypeInfo should have proper fields description, e.g. from Delphi 2010
+// extended RTTI or mormot.core.rtti.pas' Rtti.RegisterFromText()
+// - first CSV line has headers matching the needed case-insensitive field names
+// - following CSV lines will be read and parsed into the dynamic array records
+// - any unknown header name within the RTTI fields will be ignored
+// - you can optionally intern all RawUtf8 values to reduce memory consumption
+function TDynArrayLoadCsv(var Value: TDynArray; Csv: PUtf8Char;
+  Intern: TRawUtf8Interning = nil): boolean;
+
+/// parse a CSV UTF-8 string into a dynamic array of records using its RTTI fields
+// - just a wrapper around DynArrayLoadCsv() with a temporary TDynArray
+function DynArrayLoadCsv(var Value; const Csv: RawUtf8; TypeInfo: PRttiInfo;
+  Intern: TRawUtf8Interning = nil): boolean;
+
+
+{ ****************** Versatile Expression Search Engine }
+
+type
+  /// exception type used by TExprParser
+  EExprParser = class(ESynException);
+
+  /// identify an expression search engine node type, as used by TExprParser
+  TExprNodeType = (
+    entWord,
+    entNot,
+    entOr,
+    entAnd);
+
+  /// results returned by TExprParserAbstract.Parse method
+  TExprParserResult = (
+    eprSuccess,
+    eprNoExpression,
+    eprMissingParenthesis,
+    eprTooManyParenthesis,
+    eprMissingFinalWord,
+    eprInvalidExpression,
+    eprUnknownVariable,
+    eprUnsupportedOperator,
+    eprInvalidConstantOrVariable);
+
+  TParserAbstract = class;
+
+  /// stores an expression search engine node, as used by TExprParser
+  TExprNode = class(TSynPersistent)
+  protected
+    fNext: TExprNode;
+    fNodeType: TExprNodeType;
+    function Append(node: TExprNode): boolean;
+  public
+    /// initialize a node for the search engine
+    constructor Create(nodeType: TExprNodeType); reintroduce;
+    /// recursively destroys the linked list of nodes (i.e. Next)
+    destructor Destroy; override;
+    /// browse all nodes until Next = nil
+    function Last: TExprNode;
+    /// points to the next node in the parsed tree
+    property Next: TExprNode
+      read fNext;
+    /// what is actually stored in this node
+    property NodeType: TExprNodeType
+      read fNodeType;
+  end;
+
+  /// abstract class to handle word search, as used by TExprParser
+  TExprNodeWordAbstract = class(TExprNode)
+  protected
+    fOwner: TParserAbstract;
+    fWord: RawUtf8;
+    /// should be set from actual data before TExprParser.Found is called
+    fFound: boolean;
+    function ParseWord: TExprParserResult; virtual; abstract;
+  public
+    /// you should override this virtual constructor for proper initialization
+    constructor Create(aOwner: TParserAbstract; const aWord: RawUtf8); reintroduce; virtual;
+  end;
+
+  /// class-reference type (metaclass) for a TExprNode
+  // - allow to customize the actual searching process for entWord
+  TExprNodeWordClass = class of TExprNodeWordAbstract;
+
+  /// parent class of TExprParserAbstract
+  TParserAbstract = class(TSynPersistent)
+  protected
+    fExpression, fCurrentWord, fAndWord, fOrWord, fNotWord: RawUtf8;
+    fCurrent: PUtf8Char;
+    fCurrentError: TExprParserResult;
+    fFirstNode: TExprNode;
+    fWordClass: TExprNodeWordClass;
+    fWords: array of TExprNodeWordAbstract;
+    fWordCount: integer;
+    fNoWordIsAnd: boolean;
+    fFoundStack: array[byte] of boolean; // simple stack-based virtual machine
+    procedure ParseNextCurrentWord; virtual; abstract;
+    function ParseExpr: TExprNode;
+    function ParseFactor: TExprNode;
+    function ParseTerm: TExprNode;
+    procedure Clear; virtual;
+    // override this method to initialize fWordClass and fAnd/Or/NotWord
+    procedure Initialize; virtual; abstract;
+    /// perform the expression search over TExprNodeWord.fFound flags
+    // - warning: caller should check that fFirstNode<>nil (e.g. WordCount>0)
+    function Execute: boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+  public
+    /// initialize an expression parser
+    constructor Create; override;
+    /// finalize the expression parser
+    destructor Destroy; override;
+    /// initialize the parser from a given text expression
+    function Parse(const aExpression: RawUtf8): TExprParserResult;
+    /// try this parser class on a given text expression
+    // - returns '' on success, or an explicit error message (e.g.
+    // 'Missing parenthesis')
+    class function ParseError(const aExpression: RawUtf8): RawUtf8;
+    /// the associated text expression used to define the search
+    property Expression: RawUtf8
+      read fExpression;
+    /// how many words did appear in the search expression
+    property WordCount: integer
+      read fWordCount;
+  end;
+
+  /// abstract class to parse a text expression into nodes
+  // - you should inherit this class to provide actual text search
+  // - searched expressions can use parenthesis and &=AND -=WITHOUT +=OR operators,
+  // e.g. '((w1 & w2) - w3) + w4' means ((w1 and w2) without w3) or w4
+  // - no operator is handled like a AND, e.g. 'w1 w2' = 'w1 & w2'
+  TExprParserAbstract = class(TParserAbstract)
+  protected
+    procedure ParseNextCurrentWord; override;
+    // may be overridden to provide custom words escaping (e.g. handle quotes)
+    procedure ParseNextWord; virtual;
+    procedure Initialize; override;
+  end;
+
+  /// search expression engine using TMatch for the actual word searches
+  TExprParserMatch = class(TExprParserAbstract)
+  protected
+    fCaseSensitive: boolean;
+    fMatchedLastSet: integer;
+    procedure Initialize; override;
+  public
+    /// initialize the search engine
+    constructor Create(aCaseSensitive: boolean = true); reintroduce;
+    /// returns TRUE if the expression is within the text buffer
+    function Search(aText: PUtf8Char; aTextLen: PtrInt): boolean; overload;
+    /// returns TRUE if the expression is within the text buffer
+    function Search(const aText: RawUtf8): boolean; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+  end;
+
+
+const
+  /// may be used when overriding TExprParserAbstract.ParseNextWord method
+  PARSER_STOPCHAR = ['&', '+', '-', '(', ')'];
+
+function ToText(r: TExprParserResult): PShortString; overload;
+function ToUtf8(r: TExprParserResult): RawUtf8; overload;
+
+
+
+{ ****************** Bloom Filter Probabilistic Index }
+
+type
+  /// implements a thread-safe Bloom Filter storage
+  // - a "Bloom Filter" is a space-efficient probabilistic data structure,
+  // that is used to test whether an element is a member of a set. False positive
+  // matches are possible, but false negatives are not. Elements can be added to
+  // the set, but not removed. Typical use cases are to avoid unnecessary
+  // slow disk or network access if possible, when a lot of items are involved.
+  // - memory use is very low, when compared to storage of all values: fewer
+  // than 10 bits per element are required for a 1% false positive probability,
+  // independent of the size or number of elements in the set - for instance,
+  // storing 10,000,000 items presence with 1% of false positive ratio
+  // would consume only 11.5 MB of memory, using 7 hash functions
+  // - use Insert() methods to add an item to the internal bits array, and
+  // Reset() to clear all bits array, if needed
+  // - MayExist() function would check if the supplied item was probably set
+  // - SaveTo() and LoadFrom() methods allow transmission of the bits array,
+  // for a disk/database storage or transmission over a network
+  // - internally, several (hardware-accelerated) crc32c hash functions will be
+  // used, with some random seed values, to simulate several hashing functions;
+  // you can customize the hash function if needed
+  // - all methods are thread-safe, and MayExist can be concurrent (via a TRWLock)
+  TSynBloomFilter = class(TSynPersistent)
+  private
+    fSafe: TRWLock; // need an upgradable lock for TSynBloomFilterDiff
+    fHasher: THasher;
+    fSize: cardinal;
+    fBits: cardinal;
+    fHashFunctions: cardinal;
+    fInserted: cardinal;
+    fFalsePositivePercent: double;
+    fStore: RawByteString;
+  public
+    /// don't call this raw constructor, but its overloads
+    constructor Create; overload; override;
+    /// initialize the internal bits storage for a given number of items
+    // - by default, internal bits array size will be guess from a 1 % false
+    // positive rate - but you may specify another value, to reduce memory use
+    // - this constructor would compute and initialize Bits and HashFunctions
+    // corresponding to the expected false positive ratio
+    // - you can specify a custom hash function if you find that the default
+    // crc32c() has too many collisions: but SaveTo/LoadFrom will be tied to it;
+    // see e.g. CryptCrc32(caMd5/caSha1) from mormot.crypt.secure
+    constructor Create(aSize: integer; aFalsePositivePercent: double = 1;
+      aHasher: THasher = nil); reintroduce; overload;
+    /// initialize the internal bits storage from a SaveTo() binary buffer
+    // - this constructor will initialize the internal bits array calling LoadFrom()
+    // - you can specify a custom hash function to match with the one used before
+    constructor Create(const aSaved: RawByteString; aMagic: cardinal = $B1003F11;
+      aHasher: THasher = nil); reintroduce; overload;
+    /// add an item in the internal bits array storage
+    // - this method is thread-safe
+    procedure Insert(const aValue: RawByteString); overload;
+    /// add an item in the internal bits array storage
+    // - this method is thread-safe
+    procedure Insert(aValue: pointer; aValueLen: integer); overload; virtual;
+    /// clear the internal bits array storage
+    // - you may call this method after some time, if some items may have
+    // been removed, to reduce false positives
+    // - this method is thread-safe
+    procedure Reset; virtual;
+    /// returns TRUE if the supplied items was probably set via Insert()
+    // - some false positive may occur, but not much than FalsePositivePercent
+    // - this method is thread-safe, and allow concurrent calls (via a TRWLock)
+    function MayExist(const aValue: RawByteString): boolean; overload;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// returns TRUE if the supplied items was probably set via Insert()
+    // - some false positive may occur, but not much than FalsePositivePercent
+    // - this method is thread-safe, and allow concurrent calls (via a TRWLock)
+    function MayExist(aValue: pointer; aValueLen: integer): boolean; overload;
+    /// store the internal bits array into a binary buffer
+    // - may be used to transmit or store the state of a dataset, avoiding
+    // to recompute all Insert() at program startup, or to synchronize
+    // networks nodes information and reduce the number of remote requests
+    // - this method is thread-safe, and won't block MayExist (via a TRWLock)
+    function SaveTo(aMagic: cardinal = $B1003F11): RawByteString; overload;
+    /// store the internal bits array into a binary buffer
+    // - may be used to transmit or store the state of a dataset, avoiding
+    // to recompute all Insert() at program startup, or to synchronize
+    // networks nodes information and reduce the number of remote requests
+    // - this method is thread-safe, and won't block MayExist (via a TRWLock)
+    procedure SaveTo(aDest: TBufferWriter;
+      aMagic: cardinal = $B1003F11); overload;
+    /// read the internal bits array from a binary buffer
+    // - as previously serialized by the SaveTo method
+    // - may be used to transmit or store the state of a dataset
+    function LoadFrom(const aSaved: RawByteString;
+      aMagic: cardinal = $B1003F11): boolean; overload;
+    /// read the internal bits array from a binary buffer
+    // - as previously serialized by the SaveTo method
+    // - may be used to transmit or store the state of a dataset
+    function LoadFrom(P: PByte; PLen: integer;
+      aMagic: cardinal = $B1003F11): boolean; overload; virtual;
+  published
+    /// maximum number of items which are expected to be inserted
+    property Size: cardinal
+      read fSize;
+    /// expected percentage (1..100) of false positive results for MayExists()
+    property FalsePositivePercent: double
+      read fFalsePositivePercent;
+    /// number of bits stored in the internal bits array
+    property Bits: cardinal
+      read fBits;
+    /// how many hash functions would be applied for each Insert()
+    property HashFunctions: cardinal
+      read fHashFunctions;
+    /// how many times the Insert() method has been called
+    property Inserted: cardinal
+      read fInserted;
+  end;
+
+  /// implements a thread-safe differential Bloom Filter storage
+  // - this inherited class is able to compute incremental serialization of
+  // its internal bits array, to reduce network use
+  // - an obfuscated revision counter is used to identify storage history
+  TSynBloomFilterDiff = class(TSynBloomFilter)
+  protected
+    fRevision: Int64;
+    fSnapShotAfterMinutes: cardinal;
+    fSnapshotAfterInsertCount: cardinal;
+    fSnapshotTimestamp: Int64;
+    fSnapshotInsertCount: cardinal;
+    fKnownRevision: Int64;
+    fKnownStore: RawByteString;
+  public
+    /// add an item in the internal bits array storage
+    // - this overloaded thread-safe method would compute fRevision
+    procedure Insert(aValue: pointer; aValueLen: integer); override;
+    /// clear the internal bits array storage
+    // - this overloaded thread-safe method would reset fRevision
+    procedure Reset; override;
+    /// store the internal bits array into an incremental binary buffer
+    // - here the difference from a previous SaveToDiff revision will be computed
+    // - if aKnownRevision is outdated (e.g. if equals 0), the whole bits array
+    // would be returned, and around 10 bits per item would be transmitted
+    // (for 1% false positive ratio)
+    // - incremental retrieval would then return around 10 bytes per newly added
+    // item since the last snapshot reference state (with 1% ratio, i.e. 7 hash
+    // functions)
+    function SaveToDiff(const aKnownRevision: Int64): RawByteString;
+    /// use the current internal bits array state as known revision
+    // - is done the first time SaveToDiff() is called, then after 1/32th of
+    // the filter size has been inserted (see SnapshotAfterInsertCount property),
+    // or after SnapShotAfterMinutes property timeout period
+    procedure DiffSnapshot;
+    /// retrieve the revision number from an incremental binary buffer
+    // - returns 0 if the supplied binary buffer does not match this bloom filter
+    function DiffKnownRevision(const aDiff: RawByteString): Int64;
+    /// read the internal bits array from an incremental binary buffer
+    // - as previously serialized by the SaveToDiff() method
+    // - may be used to transmit or store the state of a dataset
+    // - returns false if the supplied content is incorrect, e.g. if the known
+    // revision is deprecated
+    function LoadFromDiff(const aDiff: RawByteString): boolean;
+    /// the opaque revision number of this internal storage
+    // - is in fact the Unix timestamp shifted by 31 bits, and an incremental
+    // counter: this pattern will allow consistent IDs over several ServPanels
+    property Revision: Int64
+      read fRevision;
+    /// after how many Insert() the internal bits array storage should be
+    // promoted as known revision
+    // - equals Size div 32 by default
+    property SnapshotAfterInsertCount: cardinal
+      read fSnapshotAfterInsertCount write fSnapshotAfterInsertCount;
+    /// after how many time the internal bits array storage should be
+    // promoted as known revision
+    // - equals 30 minutes by default
+    property SnapShotAfterMinutes: cardinal
+      read fSnapShotAfterMinutes write fSnapShotAfterMinutes;
+  end;
+
+
+/// RLE compression of a memory buffer containing mostly zeros
+// - will store the number of consecutive zeros instead of plain zero bytes
+// - used for spare bit sets, e.g. TSynBloomFilter serialization
+// - will also compute the crc32c of the supplied content
+// - use ZeroDecompress() to expand the compressed result
+// - resulting content would be at most 14 bytes bigger than the input
+// - you may use this function before SynLZ compression
+procedure ZeroCompress(P: PAnsiChar; Len: integer; Dest: TBufferWriter);
+
+/// RLE uncompression of a memory buffer containing mostly zeros
+// - returns Dest='' if P^ is not a valid ZeroCompress() function result
+// - used for spare bit sets, e.g. TSynBloomFilter serialization
+// - will also check the crc32c of the supplied content
+procedure ZeroDecompress(P: PByte; Len: integer; var Dest: RawByteString);
+
+/// RLE compression of XORed memory buffers resulting in mostly zeros
+// - will perform ZeroCompress(Dest^ := New^ xor Old^) without any temporary
+// memory allocation
+// - is used  e.g. by TSynBloomFilterDiff.SaveToDiff() in incremental mode
+// - will also compute the crc32c of the supplied content
+procedure ZeroCompressXor(New, Old: PAnsiChar; Len: cardinal;
+  Dest: TBufferWriter);
+
+/// RLE uncompression and ORing of a memory buffer containing mostly zeros
+// - will perform Dest^ := Dest^ or ZeroDecompress(P^) without any temporary
+// memory allocation
+// - is used  e.g. by TSynBloomFilterDiff.LoadFromDiff() in incremental mode
+// - returns false if P^ is not a valid ZeroCompress/ZeroCompressXor() result
+// - will also check the crc32c of the supplied content
+function ZeroDecompressOr(P, Dest: PAnsiChar; Len, DestLen: integer): boolean;
+
+
+{ ****************** Binary Buffers Delta Compression }
+
+const
+  /// normal pattern search depth for DeltaCompress()
+  // - gives good results on most content
+  DELTA_LEVEL_FAST = 100;
+  /// brutal pattern search depth for DeltaCompress()
+  // - may become very slow, with minor benefit, on huge content
+  DELTA_LEVEL_BEST = 500;
+  /// 2MB as internal chunks/window default size for DeltaCompress()
+  // - will use up to 9 MB of RAM during DeltaCompress() - none in DeltaExtract()
+  DELTA_BUF_DEFAULT = 2 shl 20;
+
+/// compute difference of two binary buffers
+// - returns '=' for equal buffers, or an optimized binary delta
+// - DeltaExtract() could be used later on to compute New from Old + Delta
+function DeltaCompress(const New, Old: RawByteString;
+  Level: integer = DELTA_LEVEL_FAST;
+  BufSize: integer = DELTA_BUF_DEFAULT): RawByteString; overload;
+
+/// compute difference of two binary buffers
+// - returns '=' for equal buffers, or an optimized binary delta
+// - DeltaExtract() could be used later on to compute New from Old
+function DeltaCompress(New, Old: PAnsiChar; NewSize, OldSize: integer;
+  Level: integer = DELTA_LEVEL_FAST;
+  BufSize: integer = DELTA_BUF_DEFAULT): RawByteString; overload;
+
+/// compute difference of two binary buffers
+// - returns '=' for equal buffers, or an optimized binary delta
+// - DeltaExtract() could be used later on to compute New from Old + Delta
+// - caller should call Freemem(Delta) once finished with the output buffer
+function DeltaCompress(New, Old: PAnsiChar; NewSize, OldSize: integer;
+  out Delta: PAnsiChar; Level: integer = DELTA_LEVEL_FAST;
+  BufSize: integer = DELTA_BUF_DEFAULT): integer; overload;
+
+type
+  /// result of function DeltaExtract()
+  TDeltaError = (
+    dsSuccess,
+    dsCrcCopy,
+    dsCrcComp,
+    dsCrcBegin,
+    dsCrcEnd,
+    dsCrcExtract,
+    dsFlag,
+    dsLen);
+
+/// returns how many bytes a DeltaCompress() result will expand to
+function DeltaExtractSize(const Delta: RawByteString): integer; overload;
+
+/// returns how many bytes a DeltaCompress() result will expand to
+function DeltaExtractSize(Delta: PAnsiChar): integer; overload;
+
+/// apply the delta binary as computed by DeltaCompress()
+// - decompression don't use any RAM, will perform crc32c check, and is very fast
+// - return dsSuccess if was uncompressed to aOutUpd as expected
+function DeltaExtract(const Delta, Old: RawByteString;
+  out New: RawByteString): TDeltaError; overload;
+
+/// low-level apply the delta binary as computed by DeltaCompress()
+// - New should already be allocated with DeltaExtractSize(Delta) bytes
+// - as such, expect Delta, Old and New to be <> nil, and Delta <> '='
+// - return dsSuccess if was uncompressed to aOutUpd as expected
+function DeltaExtract(Delta, Old, New: PAnsiChar): TDeltaError; overload;
+
+function ToText(err: TDeltaError): PShortString; overload;
+
+
+{ ****************** TDynArray Low-Level Binary Search and Iteration }
+
+/// 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)
+// - note: mORMot 1.18 Hash32 is not stored any more
+function SimpleDynArrayLoadFrom(Source: PAnsiChar; aTypeInfo: PRttiInfo;
+  out Count, ElemSize: PtrInt): 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
+// - slightly faster than SimpleDynArrayLoadFrom(Source,TypeInfo(TIntegerDynArray),Count)
+function IntegerDynArrayLoadFrom(Source: PAnsiChar; var Count: integer): PIntegerArray;
+
+/// search in a RawUtf8 dynamic array BLOB content as stored by TDynArray.SaveTo
+// - same as search within TDynArray.LoadFrom() with no memory allocation nor
+// memory copy: so is much faster
+// - will return -1 if no match or invalid data, or the matched entry index
+function RawUtf8DynArrayLoadFromContains(Source: PAnsiChar;
+  Value: PUtf8Char; ValueLen: PtrInt; CaseSensitive: boolean): PtrInt;
+
+type
+  /// 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 USERECORDWITHMETHODS}
+  TDynArrayLoadFrom = record
+  {$else}
+  TDynArrayLoadFrom = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    ArrayLoad: TRttiBinaryLoad;
+  public
+    /// how many items were saved in the TDynArray.SaveTo binary buffer
+    // - equals -1 if Init() failed to deserialize its header
+    Count: integer;
+    /// the zero-based index of the current item pointed by next Step() call
+    // - is in range 0..Count-1 until Step() returns false
+    Current: integer;
+    /// current read position in the TDynArray.SaveTo binary buffer
+    // - after Step() returned false, points just after the binary buffer,
+    // like a regular TDynArray.LoadFrom
+    Reader: TFastReader;
+    /// RTTI information of the deserialized dynamic array
+    ArrayRtti: TRttiCustom;
+    /// initialize iteration over a TDynArray.SaveTo binary buffer
+    // - returns true on success, with Count and Position being set
+    // - returns false if the supplied binary buffer is not correct
+    // - you should specify SourceMaxLen to avoid any buffer overflow
+    function Init(ArrayTypeInfo: PRttiInfo; Source: PAnsiChar;
+      SourceMaxLen: PtrInt): boolean; overload;
+    /// initialize iteration over a TDynArray.SaveTo binary buffer
+    // - returns true on success, with Count and Position being set
+    // - returns false if the supplied binary buffer is not correct
+    function Init(ArrayTypeInfo: PRttiInfo;
+      const Source: RawByteString): boolean; overload;
+    /// iterate over the current stored item
+    // - Item should point to a variable of the exact item type stored in this
+    // dynamic array
+    // - returns true if Item was filled with one value, or false if all
+    // items were read, and Position contains the end of the binary buffer
+    function Step(Item: pointer): boolean;
+    /// extract the first field value of the current stored item
+    // - this function won't increase the internal Current pointer
+    // - 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
+    // - Field is expected to be of ArrayRtti.ArrayFirstField type
+    // - could be called before Step(), to pre-allocate a new item instance,
+    // or update an existing instance
+    function FirstField(Field: pointer): boolean;
+  end;
+
+
+{ ****************** TSynFilter and TSynValidate Processing Classes }
+
+type
+  TSynFilterOrValidate = class;
+
+  TSynFilterOrValidateObjArray = array of TSynFilterOrValidate;
+  TSynFilterOrValidateObjArrayArray = array of TSynFilterOrValidateObjArray;
+
+  /// will define a filter (transformation) or a validation process to be
+  // applied to a database Record content (typically a TOrm)
+  // - the optional associated parameters are to be supplied JSON-encoded
+  TSynFilterOrValidate = class
+  protected
+    fParameters: RawUtf8;
+    /// children must override this method in order to parse the JSON-encoded
+    // parameters, and store it in protected field values
+    procedure SetParameters(const Value: RawUtf8); virtual;
+  public
+    /// add the filter or validation process to a list, checking if not present
+    // - if an instance with the same class type and parameters is already
+    // registered, will call aInstance.Free and return the exising instance
+    // - if there is no similar instance, will add it to the list and return it
+    function AddOnce(var aObjArray: TSynFilterOrValidateObjArray;
+      aFreeIfAlreadyThere: boolean = true): TSynFilterOrValidate;
+  public
+    /// initialize the filter (transformation) or validation instance
+    // - most of the time, optional parameters may be specified as JSON,
+    // possibly with the extended MongoDB syntax
+    constructor Create(const aParameters: RawUtf8 = ''); overload; virtual;
+    /// initialize the filter or validation instance
+    /// - this overloaded constructor will allow to easily set the parameters
+    constructor CreateUtf8(const Format: RawUtf8; const Args, Params: array of const); overload;
+    /// the optional associated parameters, supplied as JSON-encoded
+    property Parameters: RawUtf8
+      read fParameters write SetParameters;
+  end;
+
+  /// will define a validation to be applied to a Record (typically a TOrm)
+  // field content
+  // - a typical usage is to validate an email or IP address e.g.
+  // - the optional associated parameters are to be supplied JSON-encoded
+  TSynValidate = class(TSynFilterOrValidate)
+  public
+    /// perform the validation action to the specified value
+    // - the value is expected by be UTF-8 text, as generated by
+    // TPropInfo.GetValue e.g.
+    // - if the validation failed, must return FALSE and put some message in
+    // ErrorMsg (translated into the current language: you could e.g. use
+    // a resourcestring and a SysUtils.Format() call for automatic translation
+    // via the mORMoti18n unit - you can leave ErrorMsg='' to trigger a
+    // generic error message from clas name ('"Validate email" rule failed'
+    // for TSynValidateEmail class e.g.)
+    // - if the validation passed, will return TRUE
+    function Process(aFieldIndex: integer; const Value: RawUtf8; var ErrorMsg: string): boolean;
+      virtual; abstract;
+  end;
+
+  /// points to a TSynValidate variable
+  // - used e.g. as optional parameter to TOrm.Validate/FilterAndValidate
+  PSynValidate = ^TSynValidate;
+
+  /// IP v4 address validation to be applied to a Record field content
+  // (typically a TOrm)
+  // - this versions expect no parameter
+  TSynValidateIPAddress = class(TSynValidate)
+  protected
+  public
+    /// perform the IP Address validation action to the specified value
+    function Process(aFieldIndex: integer; const Value: RawUtf8;
+      var ErrorMsg: string): boolean; override;
+  end;
+
+  /// IP address validation to be applied to a Record field content
+  // (typically a TOrm)
+  // - optional JSON encoded parameters are "AllowedTLD" or "ForbiddenTLD",
+  // expecting a CSV lis of Top-Level-Domain (TLD) names, e.g.
+  // $ '{"AllowedTLD":"com,org,net","ForbiddenTLD":"fr"}'
+  // $ '{AnyTLD:true,ForbiddenDomains:"mailinator.com,yopmail.com"}'
+  // - this will process a validation according to RFC 822 (calling the
+  // IsValidEmail() function) then will check for the TLD to be in one of
+  // the Top-Level domains ('.com' and such) or a two-char country, and
+  // then will check the TLD according to AllowedTLD and ForbiddenTLD
+  TSynValidateEmail = class(TSynValidate)
+  private
+    fAllowedTLD: RawUtf8;
+    fForbiddenTLD: RawUtf8;
+    fForbiddenDomains: RawUtf8;
+    fAnyTLD: boolean;
+  protected
+    /// decode all published properties from their JSON representation
+    procedure SetParameters(const Value: RawUtf8); override;
+  public
+    /// perform the Email Address validation action to the specified value
+    // - call IsValidEmail() function and check for the supplied TLD
+    function Process(aFieldIndex: integer; const Value: RawUtf8; var ErrorMsg: string): boolean; override;
+    /// allow any TLD to be allowed, even if not a generic TLD (.com,.net ...)
+    // - this may be mandatory since already over 1,300 new gTLD names or
+    // "strings" could become available in the next few years: there is a
+    // growing list of new gTLDs available at
+    // @http://newgtlds.icann.org/en/program-status/delegated-strings
+    // - the only restriction is that it should be ascii characters
+    property AnyTLD: boolean
+      read fAnyTLD write fAnyTLD;
+    /// a CSV list of allowed TLD
+    // - if accessed directly, should be set as lower case values
+    // - e.g. 'com,org,net'
+    property AllowedTLD: RawUtf8
+      read fAllowedTLD write fAllowedTLD;
+    /// a CSV list of forbidden TLD
+    // - if accessed directly, should be set as lower case values
+    // - e.g. 'fr'
+    property ForbiddenTLD: RawUtf8
+      read fForbiddenTLD write fForbiddenTLD;
+    /// a CSV list of forbidden domain names
+    // - if accessed directly, should be set as lower case values
+    // - not only the TLD, but whole domains like 'cracks.ru,hotmail.com' or such
+    property ForbiddenDomains: RawUtf8
+      read fForbiddenDomains write fForbiddenDomains;
+  end;
+
+  /// glob case-sensitive pattern validation of a Record field content
+  // - parameter is NOT JSON encoded, but is some basic TMatch glob pattern
+  // - ?	   	Matches any single character
+  // - *	   	Matches any contiguous characters
+  // - [abc]  Matches a or b or c at that position
+  // - [^abc]	Matches anything but a or b or c at that position
+  // - [!abc]	Matches anything but a or b or c at that position
+  // - [a-e]  Matches a through e at that position
+  // - [abcx-z] Matches a or b or c or x or y or or z, as does [a-cx-z]
+  // - 'ma?ch.*'	would match match.exe, mavch.dat, march.on, etc..
+  // - 'this [e-n]s a [!zy]est' would match 'this is a test', but would not
+  //   match 'this as a test' nor 'this is a zest'
+  // - pattern check IS case sensitive (TSynValidatePatternI is not)
+  // - this class is not as complete as PCRE regex for example,
+  // but code overhead is very small, and speed good enough in practice
+  TSynValidatePattern = class(TSynValidate)
+  protected
+    fMatch: TMatch;
+    procedure SetParameters(const Value: RawUtf8); override;
+  public
+    /// perform the pattern validation to the specified value
+    // - pattern can be e.g. '[0-9][0-9]:[0-9][0-9]:[0-9][0-9]'
+    // - this method will implement both TSynValidatePattern and
+    // TSynValidatePatternI, checking the current class
+    function Process(aFieldIndex: integer; const Value: RawUtf8;
+      var ErrorMsg: string): boolean; override;
+  end;
+
+  /// glob case-insensitive pattern validation of a text field content
+  // (typically a TOrm)
+  // - parameter is NOT JSON encoded, but is some basic TMatch glob pattern
+  // - same as TSynValidatePattern, but is NOT case sensitive
+  TSynValidatePatternI = class(TSynValidatePattern);
+
+  /// text validation to ensure that to any text field would not be ''
+  TSynValidateNonVoidText = class(TSynValidate)
+  public
+    /// perform the non void text validation action to the specified value
+    function Process(aFieldIndex: integer; const Value: RawUtf8;
+      var ErrorMsg: string): boolean; override;
+  end;
+
+  TSynValidateTextProps = array[0..15] of cardinal;
+
+{$M+} // to have existing RTTI for published properties
+  /// text validation to be applied to any Record field content
+  // - default MinLength value is 1, MaxLength is maxInt: so a blank
+  // TSynValidateText.Create('') is the same as TSynValidateNonVoidText
+  // - MinAlphaCount, MinDigitCount, MinPunctCount, MinLowerCount and
+  // MinUpperCount allow you to specify the minimal count of respectively
+  // alphabetical [a-zA-Z], digit [0-9], punctuation [_!;.,/:?%$="#@(){}+-*],
+  // lower case or upper case characters
+  // - expects optional JSON parameters of the allowed text length range as
+  // $ '{"MinLength":5,"MaxLength":10,"MinAlphaCount":1,"MinDigitCount":1,
+  // $ "MinPunctCount":1,"MinLowerCount":1,"MinUpperCount":1}
+  TSynValidateText = class(TSynValidate)
+  private
+    /// used to store all associated validation properties by index
+    fProps: TSynValidateTextProps;
+    fUtf8Length: boolean;
+  protected
+    /// use sInvalidTextChar resourcestring to create a translated error message
+    procedure SetErrorMsg(fPropsIndex, InvalidTextIndex, MainIndex: integer;
+      var result: string);
+    /// decode "MinLength", "MaxLength", and other parameters into fProps[]
+    procedure SetParameters(const Value: RawUtf8); override;
+  public
+    /// perform the text length validation action to the specified value
+    function Process(aFieldIndex: integer; const Value: RawUtf8;
+      var ErrorMsg: string): boolean; override;
+  published
+    /// Minimal length value allowed for the text content
+    // - the length is calculated with UTF-16 Unicode codepoints, unless
+    // Utf8Length has been set to TRUE so that the UTF-8 byte count is checked
+    // - default is 1, i.e. a void text will not pass the validation
+    property MinLength: cardinal
+      read fProps[0] write fProps[0];
+    /// Maximal length value allowed for the text content
+    // - the length is calculated with UTF-16 Unicode codepoints, unless
+    // Utf8Length has been set to TRUE so that the UTF-8 byte count is checked
+    // - default is maxInt, i.e. no maximum length is set
+    property MaxLength: cardinal
+      read fProps[1] write fProps[1];
+    /// Minimal alphabetical character [a-zA-Z] count
+    // - default is 0, i.e. no minimum set
+    property MinAlphaCount: cardinal
+      read fProps[2] write fProps[2];
+    /// Maximal alphabetical character [a-zA-Z] count
+    // - default is maxInt, i.e. no Maximum set
+    property MaxAlphaCount: cardinal
+      read fProps[10] write fProps[10];
+    /// Minimal digit character [0-9] count
+    // - default is 0, i.e. no minimum set
+    property MinDigitCount: cardinal
+      read fProps[3] write fProps[3];
+    /// Maximal digit character [0-9] count
+    // - default is maxInt, i.e. no Maximum set
+    property MaxDigitCount: cardinal
+      read fProps[11] write fProps[11];
+    /// Minimal punctuation sign [_!;.,/:?%$="#@(){}+-*] count
+    // - default is 0, i.e. no minimum set
+    property MinPunctCount: cardinal
+      read fProps[4] write fProps[4];
+    /// Maximal punctuation sign [_!;.,/:?%$="#@(){}+-*] count
+    // - default is maxInt, i.e. no Maximum set
+    property MaxPunctCount: cardinal
+      read fProps[12] write fProps[12];
+    /// Minimal alphabetical lower case character [a-z] count
+    // - default is 0, i.e. no minimum set
+    property MinLowerCount: cardinal
+      read fProps[5] write fProps[5];
+    /// Maximal alphabetical lower case character [a-z] count
+    // - default is maxInt, i.e. no Maximum set
+    property MaxLowerCount: cardinal
+      read fProps[13] write fProps[13];
+    /// Minimal alphabetical upper case character [A-Z] count
+    // - default is 0, i.e. no minimum set
+    property MinUpperCount: cardinal
+      read fProps[6] write fProps[6];
+    /// Maximal alphabetical upper case character [A-Z] count
+    // - default is maxInt, i.e. no Maximum set
+    property MaxUpperCount: cardinal
+      read fProps[14] write fProps[14];
+    /// Minimal space count inside the value text
+    // - default is 0, i.e. any space number allowed
+    property MinSpaceCount: cardinal
+      read fProps[7] write fProps[7];
+    /// Maximal space count inside the value text
+    // - default is maxInt, i.e. any space number allowed
+    property MaxSpaceCount: cardinal
+      read fProps[15] write fProps[15];
+    /// Maximal space count allowed on the Left side
+    // - default is maxInt, i.e. any Left space allowed
+    property MaxLeftTrimCount: cardinal
+      read fProps[8] write fProps[8];
+    /// Maximal space count allowed on the Right side
+    // - default is maxInt, i.e. any Right space allowed
+    property MaxRightTrimCount: cardinal
+      read fProps[9] write fProps[9];
+    /// defines if lengths parameters expects UTF-8 or UTF-16 codepoints number
+    // - with default FALSE, the length is calculated with UTF-16 Unicode
+    // codepoints - MaxLength may not match the UCS4 CodePoint, in case of
+    // UTF-16 surrogates
+    // - you can set this property to TRUE so that the UTF-8 byte count would
+    // be used for truncation against the MaxLength parameter
+    property Utf8Length: boolean
+      read fUtf8Length write fUtf8Length;
+  end;
+{$M-}
+
+  /// strong password validation for a Record field content (typically a TOrm)
+  // - the following parameters are set by default to
+  // $ '{"MinLength":5,"MaxLength":20,"MinAlphaCount":1,"MinDigitCount":1,
+  // $ "MinPunctCount":1,"MinLowerCount":1,"MinUpperCount":1,"MaxSpaceCount":0}'
+  // - you can specify some JSON encoded parameters to change this default
+  // values, which will validate the text field only if it contains from 5 to 10
+  // characters, with at least one digit, one upper case letter, one lower case
+  // letter, and one punctuation sign, with no space allowed inside
+  TSynValidatePassWord = class(TSynValidateText)
+  protected
+    /// set password specific parameters
+    procedure SetParameters(const Value: RawUtf8); override;
+  end;
+
+  { C++Builder doesn't support array elements as properties (RSP-12595).
+    For now, simply exclude the relevant classes from C++Builder. }
+  {$NODEFINE TSynValidateTextProps}
+  {$NODEFINE TSynValidateText }
+  {$NODEFINE TSynValidatePassWord }
+
+  /// will define a transformation to be applied to a Record field content
+  // (typically a TOrm)
+  // - here "filter" means that content would be transformed according to a
+  // set of defined rules
+  // - a typical usage is to convert to lower or upper case, or
+  // trim any time or date value in a TDateTime field
+  // - the optional associated parameters are to be supplied JSON-encoded
+  TSynFilter = class(TSynFilterOrValidate)
+  protected
+  public
+    /// perform the transformation to the specified value
+    // - the value is converted into UTF-8 text, as expected by
+    // TPropInfo.GetValue / TPropInfo.SetValue e.g.
+    procedure Process(aFieldIndex: integer; var Value: RawUtf8); virtual; abstract;
+  end;
+
+  /// class-reference type (metaclass) for a TSynFilter or a TSynValidate
+  TSynFilterOrValidateClass = class of TSynFilterOrValidate;
+
+  /// class-reference type (metaclass) of a record filter (transformation)
+  TSynFilterClass = class of TSynFilter;
+
+  /// convert the value into ASCII Upper Case characters
+  // - UpperCase conversion is made for ASCII-7 only, i.e. 'a'..'z' characters
+  // - this version expects no parameter
+  TSynFilterUpperCase = class(TSynFilter)
+  public
+    /// perform the case conversion to the specified value
+    procedure Process(aFieldIndex: integer; var Value: RawUtf8); override;
+  end;
+
+  /// convert the value into WinAnsi Upper Case characters
+  // - UpperCase conversion is made for all latin characters in the WinAnsi
+  // code page only, e.g. 'e' acute will be converted to 'E'
+  // - this version expects no parameter
+  TSynFilterUpperCaseU = class(TSynFilter)
+  public
+    /// perform the case conversion to the specified value
+    procedure Process(aFieldIndex: integer; var Value: RawUtf8); override;
+  end;
+
+  /// convert the value into ASCII Lower Case characters
+  // - LowerCase conversion is made for ASCII-7 only, i.e. 'A'..'Z' characters
+  // - this version expects no parameter
+  TSynFilterLowerCase = class(TSynFilter)
+  public
+    /// perform the case conversion to the specified value
+    procedure Process(aFieldIndex: integer; var Value: RawUtf8); override;
+  end;
+
+  /// convert the value into WinAnsi Lower Case characters
+  // - LowerCase conversion is made for all latin characters in the WinAnsi
+  // code page only, e.g. 'E' acute will be converted to 'e'
+  // - this version expects no parameter
+  TSynFilterLowerCaseU = class(TSynFilter)
+  public
+    /// perform the case conversion to the specified value
+    procedure Process(aFieldIndex: integer; var Value: RawUtf8); override;
+  end;
+
+  /// trim any space character left or right to the value
+  // - this versions expect no parameter
+  TSynFilterTrim = class(TSynFilter)
+  public
+    /// perform the space trimming conversion to the specified value
+    procedure Process(aFieldIndex: integer; var Value: RawUtf8); override;
+  end;
+
+  /// truncate a text above a given maximum length
+  // - expects optional JSON parameters of the allowed text length range as
+  // $ '{MaxLength":10}
+  TSynFilterTruncate = class(TSynFilter)
+  protected
+    fMaxLength: cardinal;
+    fUtf8Length: boolean;
+    /// decode the MaxLength: and Utf8Length: parameters
+    procedure SetParameters(const Value: RawUtf8); override;
+  public
+    /// perform the length truncation of the specified value
+    procedure Process(aFieldIndex: integer; var Value: RawUtf8); override;
+    /// Maximal length value allowed for the text content
+    // - the length is calculated with UTF-16 Unicode codepoints, unless
+    // Utf8Length has been set to TRUE so that the UTF-8 byte count is checked
+    // - default is 0, i.e. no maximum length is forced
+    property MaxLength: cardinal
+      read fMaxLength write fMaxLength;
+    /// defines if MaxLength is stored as UTF-8 or UTF-16 codepoints number
+    // - with default FALSE, the length is calculated with UTF-16 Unicode
+    // codepoints - MaxLength may not match the UCS4 CodePoint, in case of
+    // UTF-16 surrogates
+    // - you can set this property to TRUE so that the UTF-8 byte count would
+    // be used for truncation against the MaxLength parameter
+    property Utf8Length: boolean
+      read fUtf8Length write fUtf8Length;
+  end;
+
+{$ifdef ISDELPHI}
+resourcestring
+{$else}
+const
+{$endif ISDELPHI}
+  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';
+
+
+/// return TRUE if the supplied content is a valid IP v4 address
+function IsValidIP4Address(P: PUtf8Char): boolean;
+
+/// return TRUE if the supplied content is a valid email address
+// - follows RFC 822, to validate local-part@domain email format
+function IsValidEmail(P: PUtf8Char): boolean;
+
+
+{ ***************** Cross-Platform TSynTimeZone Time Zones }
+
+type
+  {$A-} { make all records packed for cross-platform binary serialization }
+
+  /// 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
+  // - Delphi "object" is buggy on stack -> also defined as record with methods
+  {$ifdef USERECORDWITHMETHODS}
+  TTimeZoneData = record
+  {$else}
+  TTimeZoneData = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    id: TTimeZoneID;
+    display: RawUtf8;
+    tzi: TTimeZoneInfo;
+    dyn: array of packed record
+      year: integer;
+      tzi: TTimeZoneInfo;
+    end;
+    /// search for the TTimeZoneInfo of a given year
+    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)
+  // - for Linux/POSIX our mORMot 2 repository supplies a ready-to-use
+  // ! {$R mormot.tz.res}
+  // - each time zone will be identified by its TzId string, as defined by
+  // Microsoft for its Windows Operating system
+  // - note that each instance is thread-safe
+  TSynTimeZone = class
+  protected
+    fSafe: TRWLightLock;
+    fZone: TTimeZoneDataDynArray;
+    fZoneCount: integer;
+    fZones: TDynArrayHashed;
+    fLastZone: TTimeZoneID;
+    fLastIndex: integer;
+    fIds: TStringList;
+    fDisplays: TStringList;
+    function LockedFindZoneIndex(const TzId: TTimeZoneID): PtrInt;
+  public
+    /// 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
+    // - "dummycpp" parameter exists only to disambiguate constructors for C++
+    constructor CreateDefault(dummycpp: integer = 0);
+    /// finalize the instance
+    destructor Destroy; override;
+    /// will retrieve the default shared TSynTimeZone instance
+    // - locally created via the CreateDefault constructor
+    // - see also the NowToLocal/LocalToUtc/UtcToLocal global functions
+    class function Default: TSynTimeZone;
+    {$ifdef OSWINDOWS}
+    /// read time zone information from the Windows registry
+    procedure LoadFromRegistry;
+    {$endif OSWINDOWS}
+    /// 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
+    // - for Linux/POSIX our mORMot 2 repository supplies a ready-to-use
+    // ! {$R mormot.tz.res}
+    procedure LoadFromResource(Instance: TLibHandle = 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; ValueIsUtc: boolean = false): boolean;
+    /// retrieve the display text corresponding to a TzId
+    // - returns '' if the supplied TzId is not recognized
+    function GetDisplay(const TzId: TTimeZoneID): RawUtf8;
+    /// 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 bias 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 UI 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 UI component to select the time zone
+    // - order in Displays[] array follows the Zone[].display information
+    function Displays: TStrings;
+  end;
+
+/// retrieve the time bias (in minutes) for a given date/time on a TzId
+// - will use a global shared thread-safe TSynTimeZone instance for the request
+function GetBiasForDateTime(const Value: TDateTime; const TzId: TTimeZoneID;
+  out Bias: integer; out HaveDaylight: boolean; ValueIsUtc: boolean = false): boolean;
+
+/// retrieve the display text corresponding to a TzId
+// - returns '' if the supplied TzId is not recognized
+// - will use a global shared thread-safe TSynTimeZone instance for the request
+function GetDisplay(const TzId: TTimeZoneID): RawUtf8;
+
+/// compute the UTC date/time corrected for a given TzId
+// - will use a global shared thread-safe TSynTimeZone instance for the request
+function UtcToLocal(const UtcDateTime: TDateTime; const TzId: TTimeZoneID): TDateTime;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// compute the current date/time corrected for a given TzId
+// - will use a global shared thread-safe TSynTimeZone instance for the request
+function NowToLocal(const TzId: TTimeZoneID): TDateTime;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// 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 bias period, so the returned value is informative only, and any
+// stored value should be following UTC
+// - will use a global shared thread-safe TSynTimeZone instance for the request
+function LocalToUtc(const LocalDateTime: TDateTime; const TzID: TTimeZoneID): TDateTime;
+  {$ifdef HASINLINE} inline; {$endif}
+
+
+implementation
+
+
+{ ****************** Files Search in Folders }
+
+procedure TFindFiles.FromSearchRec(const Directory: TFileName; const F: TSearchRec);
+begin
+  Name := Directory + TFileName(F.Name);
+  {$ifdef OSWINDOWS}
+  {$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 HASINLINE}
+  {$else}
+  Size := F.Size;
+  {$endif OSWINDOWS}
+  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;
+  Options: TFindFilesOptions): TFindFilesDynArray;
+var
+  m, count: integer;
+  dir: TFileName;
+  da: TDynArray;
+  masks: TRawUtf8DynArray;
+  masked: TFindFilesDynArray;
+
+  procedure SearchFolder(const folder: TFileName);
+  var
+    F: TSearchRec;
+    ff: TFindFiles;
+    fold, name: TFileName; // FPC requires these implicit local variables :(
+  begin
+    fold := dir + folder;
+    name := fold + Mask;
+    if FindFirst(name, faAnyfile - faDirectory, F) = 0 then
+    begin
+      repeat
+        if SearchRecValidFile(F) and
+           ((IgnoreFileName = '') or
+            (AnsiCompareFileName(F.Name, IgnoreFileName) <> 0)) then
+        begin
+          if ffoExcludesDir in Options then
+            ff.FromSearchRec(folder, F)
+          else
+            ff.FromSearchRec(fold, F);
+          da.Add(ff);
+        end;
+      until FindNext(F) <> 0;
+      FindClose(F);
+    end;
+    if (ffoSubFolder in Options) and
+       (FindFirst(fold + '*', faDirectory, F) = 0) then
+    begin
+      // recursive SearchFolder() call for nested directories
+      repeat
+        if SearchRecValidFolder(F) and
+           ((IgnoreFileName = '') or
+            (AnsiCompareFileName(F.Name, IgnoreFileName) <> 0)) then
+          SearchFolder(IncludeTrailingPathDelimiter(folder + F.Name));
+      until FindNext(F) <> 0;
+      FindClose(F);
+    end;
+  end;
+
+begin
+  Finalize(result);
+  da.Init(TypeInfo(TFindFilesDynArray), result, @count);
+  if Pos(';', Mask) > 0 then
+    CsvToRawUtf8DynArray(pointer(StringToUtf8(Mask)), masks, ';');
+  if masks <> nil then
+  begin
+    // recursive calls for each masks[]
+    if ffoSortByName in Options then
+      QuickSortRawUtf8(masks, length(masks), nil,
+        {$ifdef OSWINDOWS} @StrIComp {$else} @StrComp {$endif});
+    for m := 0 to length(masks) - 1 do
+    begin
+      masked := FindFiles(
+        Directory, Utf8ToString(masks[m]), IgnoreFileName, Options);
+      da.AddArray(masked);
+    end;
+  end
+  else
+  begin
+    // single mask search
+    if Directory <> '' then
+      dir := IncludeTrailingPathDelimiter(Directory);
+    SearchFolder('');
+    if (ffoSortByName in Options) and
+       (da.Count > 1) then
+      da.Sort(SortDynArrayFileName);
+  end;
+  if count <> 0 then
+    DynArrayFakeLength(result, count);
+end;
+
+function FileNames(const Directory, Mask: TFileName;
+  Options: TFindFilesOptions; const IgnoreFileName: TFileName): TFileNameDynArray;
+begin
+  result := FindFilesDynArrayToFileNames(
+    FindFiles(Directory, Mask, IgnoreFileName, Options));
+end;
+
+function FileNames(const Path: array of const; const Mask: TFileName;
+  Options: TFindFilesOptions): TFileNameDynArray;
+var
+  dir: TFileName;
+begin
+  dir := MakePath(Path, {endwithdelim=}true);
+  result := FileNames(dir, Mask, Options);
+end;
+
+function FindFilesDynArrayToFileNames(const Files: TFindFilesDynArray): TFileNameDynArray;
+var
+  i, n: PtrInt;
+begin
+  Finalize(result);
+  if Files = nil then
+    exit;
+  n := length(Files);
+  SetLength(result, n);
+  for i := 0 to n - 1 do
+    result[i] := Files[i].Name;
+end;
+
+function SortFindFileTimestamp(const A, B): integer;
+begin
+  result := CompareFloat(TFindFiles(A).Timestamp, TFindFiles(B).Timestamp);
+end;
+
+procedure FindFilesSortByTimestamp(var Files: TFindFilesDynArray);
+begin
+  DynArray(TypeInfo(TFindFilesDynArray), Files).Sort(SortFindFileTimestamp);
+end;
+
+function SynchFolders(const Reference, Dest: TFileName;
+  Options: TSynchFoldersOptions): integer;
+var
+  ref, dst, reffn, dstfn: TFileName;
+  fdst: TSearchRec;
+  refsize: Int64;
+  reftime: TUnixMSTime;
+  s: RawByteString;
+begin
+  result := 0;
+  ref := IncludeTrailingPathDelimiter(Reference);
+  dst := IncludeTrailingPathDelimiter(Dest);
+  if DirectoryExists(ref) and
+     (FindFirst(dst + FILES_ALL, faAnyFile, fdst) = 0) then
+  begin
+    repeat
+      if SearchRecValidFile(fdst) then
+      begin
+        reffn := ref + fdst.Name;
+        if not FileInfoByName(reffn, refsize, reftime) then
+          continue; // only update existing files
+        if not (sfoByContent in Options) then
+          if (refsize = fdst.Size) and
+             (reftime = SearchRecToUnixTimeUtc(fdst)) then
+            continue;
+        dstfn := dst + fdst.Name;
+        s := StringFromFile(reffn);
+        if (s = '') or
+           ((sfoByContent in Options) and
+            (length(s) = fdst.Size) and
+            (DefaultHasher(0, pointer(s), fdst.Size) = HashFile(dstfn))) then
+          continue;
+        FileFromString(s, dstfn);
+        FileSetDateFromUnixUtc(dstfn, reftime div MSecsPerSec);
+        inc(result);
+        if sfoWriteFileNameToConsole in Options then
+          ConsoleWrite('synched %', [dstfn]);
+      end
+      else if (sfoSubFolder in Options) and
+              SearchRecValidFolder(fdst) then
+        inc(result, SynchFolders(ref + fdst.Name, dst + fdst.Name, Options));
+    until FindNext(fdst) <> 0;
+    FindClose(fdst);
+  end;
+end;
+
+function CopyFolder(const Source, Dest: TFileName;
+  Options: TSynchFoldersOptions): integer;
+var
+  src, dst, reffn, dstfn: TFileName;
+  sr: TSearchRec;
+  dsize: Int64;
+  dtime: TUnixMSTime;
+  nested: integer;
+begin
+  result := 0;
+  src := IncludeTrailingPathDelimiter(Source);
+  if not DirectoryExists(src) then
+    exit;
+  dst := EnsureDirectoryExists(Dest);
+  if (dst = '') or
+     (FindFirst(src + FILES_ALL, faAnyFile, sr) <> 0) then
+    exit;
+  repeat
+    reffn := src + sr.Name;
+    dstfn := dst + sr.Name;
+    if SearchRecValidFile(sr) then
+    begin
+      if FileInfoByName(dstfn, dsize, dtime) and // fast single syscall
+         (sr.Size = dsize) then
+        if sfoByContent in Options then
+        begin
+          if SameFileContent(reffn, dstfn) then
+            continue;
+        end
+        else if abs(SearchRecToUnixTimeUtc(sr) * 1000 - dtime) < 1000 then
+          continue; // allow error of 1 second timestamp resolution
+      if not CopyFile(reffn, dstfn, {failsifexists=}false) then
+        result := -1;
+    end
+    else if not SearchRecValidFolder(sr) then
+      continue
+    else if sfoSubFolder in Options then
+    begin
+      nested := CopyFolder(reffn, dstfn, Options);
+      if nested < 0 then
+        result := nested
+      else
+        inc(result, nested);
+    end;
+    if result < 0 then
+      break;
+    inc(result);
+    if sfoWriteFileNameToConsole in Options then
+      ConsoleWrite('copied %', [reffn]);
+  until (FindNext(sr) <> 0);
+  FindClose(sr);
+end;
+
+
+{ ****************** ScanUtf8, GLOB and SOUNDEX Text Search }
+
+function ScanUtf8(P: PUtf8Char; PLen: PtrInt; const fmt: RawUtf8;
+  const values:  array of pointer; ident: PRawUtf8DynArray): integer;
+var
+  v, w: PtrInt;
+  F, FEnd, PEnd: PUtf8Char;
+  tab: PTextCharSet;
+label
+  next;
+begin
+  result := 0;
+  if (fmt = '') or
+     (P = nil) or
+     (PLen <= 0) or
+     (high(values) < 0) then
+    exit;
+  if ident <> nil then
+    SetLength(ident^, length(values));
+  F := pointer(fmt);
+  FEnd := F + length(fmt);
+  PEnd := P + PLen;
+  for v := 0 to high(values) do
+    repeat
+      if (P^ <= ' ') and
+         (P^ <> #0) then
+        // ignore any whitespace char in text
+        repeat
+          inc(P);
+          if P = PEnd then
+            exit;
+        until (P^ > ' ') or
+              (P^ = #0);
+      while (F^ <= ' ') and
+            (F^ <> #0) do
+      begin
+        // ignore any whitespace char in fmt
+        inc(F);
+        if F = FEnd then
+          exit;
+      end;
+      if F^ = '%' then
+      begin
+        // handle format specifier
+        inc(F);
+        if F = FEnd then
+          exit;
+        case F^ of
+          'd':
+            PInteger(values[v])^ := GetNextItemInteger(P, #0);
+          'D':
+            PInt64(values[v])^ := GetNextItemInt64(P, #0);
+          'u':
+            PCardinal(values[v])^ := GetNextItemCardinal(P, #0);
+          'U':
+            PQword(values[v])^ := GetNextItemQword(P, #0);
+          'f':
+            unaligned(PDouble(values[v])^) := GetNextItemDouble(P, #0);
+          'F':
+            GetNextItemCurrency(P, PCurrency(values[v])^, #0);
+          'x':
+            if not GetNextItemHexDisplayToBin(P, values[v], 4, #0) then
+              exit;
+          'X':
+            if not GetNextItemHexDisplayToBin(P, values[v], 8, #0) then
+              exit;
+          's', 'S':
+            begin
+              w := 0;
+              while (P[w] > ' ') and
+                    (P + w <= PEnd) do
+                inc(w);
+              if F^ = 's' then
+                SetString(PShortString(values[v])^, PAnsiChar(P), w)
+              else
+                FastSetString(PRawUtf8(values[v])^, P, w);
+              inc(P, w);
+              while (P^ <= ' ') and
+                    (P^ <> #0) and
+                    (P <= PEnd) do
+                inc(P);
+            end;
+          'L':
+            begin
+              w := 0;
+              tab := @TEXT_CHARS;
+              while (tcNot01013 in tab[P[w]]) and
+                    (P + w <= PEnd) do
+                inc(w);
+              FastSetString(PRawUtf8(values[v])^, P, w);
+              inc(P, w);
+            end;
+          '%':
+            goto next;
+        else
+          raise ESynException.CreateUtf8(
+            'ScanUtf8: unknown ''%'' specifier [%]', [F^, fmt]);
+        end;
+        inc(result);
+        tab := @TEXT_CHARS;
+        if (tcIdentifier in tab[F[1]]) or
+           (ident <> nil) then
+        begin
+          w := 0;
+          repeat
+            inc(w)
+          until not (tcIdentifier in tab[F[w]]) or
+                (F + w = FEnd);
+          if ident <> nil then
+            FastSetString(ident^[v], F, w);
+          inc(F, w);
+        end
+        else
+          inc(F);
+        if (F >= FEnd) or
+           (P >= PEnd) then
+          exit;
+        break;
+      end
+      else
+      begin
+next:   while (P^ <> F^) and
+              (P <= PEnd) do
+          inc(P);
+        inc(F);
+        inc(P);
+        if (F >= FEnd) or
+           (P >= PEnd) then
+          exit;
+      end;
+    until false;
+end;
+
+function ScanUtf8(const text, fmt: RawUtf8; const values: array of pointer;
+  ident: PRawUtf8DynArray): integer;
+begin
+  result := ScanUtf8(pointer(text), length(text), fmt, values, ident);
+end;
+
+
+// inspired by ZMatchPattern.pas - http://www.zeoslib.sourceforge.net
+procedure TMatch.MatchMain;
+var
+  RangeStart, RangeEnd: PtrInt;
+  c: AnsiChar;
+  flags: set of (Invert, MemberMatch);
+begin
+  while ((State = sNONE) and
+        (P <= PMax)) do
+  begin
+    c := Upper[Pattern[P]];
+    if T > TMax then
+    begin
+      if (c = '*') and
+         (P + 1 > PMax) then
+        State := sVALID
+      else
+        State := sABORT;
+      exit;
+    end
+    else
+      case c of
+        '?':
+          ;
+        '*':
+          MatchAfterStar;
+        '[':
+          begin
+            inc(P);
+            byte(flags) := 0;
+            if Pattern[P] in ['!', '^'] then
+            begin
+              include(flags, Invert);
+              inc(P);
+            end;
+            if Pattern[P] = ']' then
+            begin
+              State := sPATTERN;
+              exit;
+            end;
+            c := Upper[Text[T]];
+            while Pattern[P] <> ']' do
+            begin
+              RangeStart := P;
+              RangeEnd := P;
+              inc(P);
+              if P > PMax then
+              begin
+                State := sPATTERN;
+                exit;
+              end;
+              if Pattern[P] = '-' then
+              begin
+                inc(P);
+                RangeEnd := P;
+                if (P > PMax) or
+                   (Pattern[RangeEnd] = ']') then
+                begin
+                  State := sPATTERN;
+                  exit;
+                end;
+                inc(P);
+              end;
+              if P > PMax then
+              begin
+                State := sPATTERN;
+                exit;
+              end;
+              if RangeStart < RangeEnd then
+              begin
+                if (c >= Upper[Pattern[RangeStart]]) and
+                   (c <= Upper[Pattern[RangeEnd]]) then
+                begin
+                  include(flags, MemberMatch);
+                  break;
+                end;
+              end
+              else if (c >= Upper[Pattern[RangeEnd]]) and
+                      (c <= Upper[Pattern[RangeStart]]) then
+              begin
+                include(flags, MemberMatch);
+                break;
+              end;
+            end;
+            if ((Invert in flags) and
+                (MemberMatch in flags)) or
+               not ((Invert in flags) or
+                    (MemberMatch in flags)) then
+            begin
+              State := sRANGE;
+              exit;
+            end;
+            if MemberMatch in flags then
+              while (P <= PMax) and
+                    (Pattern[P] <> ']') do
+                inc(P);
+            if P > PMax then
+            begin
+              State := sPATTERN;
+              exit;
+            end;
+          end;
+      else
+        if c <> Upper[Text[T]] then
+          State := sLITERAL;
+      end;
+    inc(P);
+    inc(T);
+  end;
+  if State = sNONE then
+    if T <= TMax then
+      State := sEND
+    else
+      State := sVALID;
+end;
+
+procedure TMatch.MatchAfterStar;
+var
+  retryT, retryP: PtrInt;
+begin
+  if (TMax = 1) or
+     (P = PMax) then
+  begin
+    State := sVALID;
+    exit;
+  end
+  else if (PMax = 0) or
+          (TMax = 0) then
+  begin
+    State := sABORT;
+    exit;
+  end;
+  while (T <= TMax) and
+        (P < PMax) and
+        (Pattern[P] in ['?', '*']) do
+  begin
+    if Pattern[P] = '?' then
+      inc(T);
+    inc(P);
+  end;
+  if T >= TMax then
+  begin
+    State := sABORT;
+    exit;
+  end
+  else if P >= PMax then
+  begin
+    State := sVALID;
+    exit;
+  end;
+  repeat
+    if (Upper[Pattern[P]] = Upper[Text[T]]) or
+       (Pattern[P] = '[') then
+    begin
+      retryT := T;
+      retryP := P;
+      MatchMain;
+      if State = sVALID then
+        break;
+      State := sNONE; // retry until end of Text, (check below) or State valid
+      T := retryT;
+      P := retryP;
+    end;
+    inc(T);
+    if (T > TMax) or
+       (P > PMax) then
+    begin
+      State := sABORT;
+      exit;
+    end;
+  until State <> sNONE;
+end;
+
+function SearchAny(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+begin
+  aMatch.State := sNONE;
+  aMatch.P := 0;
+  aMatch.T := 0;
+  aMatch.Text := aText;
+  aMatch.TMax := aTextLen - 1;
+  aMatch.MatchMain;
+  result := aMatch.State = sVALID;
+end;
+
+// faster alternative (without recursion) for only * ? (but not [...])
+
+{$ifdef CPU32} // less registers on this CPU - also circumvent ARM problems (Alf)
+
+function SearchNoRange(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+var
+  c: AnsiChar;
+  pat, txt: PtrInt; // use local registers
+begin
+  aMatch.T := 0; // aMatch.P/T are used for retry positions after *
+  aMatch.Text := aText;
+  aMatch.TMax := aTextLen - 1;
+  pat := 0;
+  txt := 0;
+  repeat
+    if pat <= aMatch.PMax then
+    begin
+      c := aMatch.Pattern[pat];
+      case c of
+        '?':
+          if txt <= aMatch.TMax then
+          begin
+            inc(pat);
+            inc(txt);
+            continue;
+          end;
+        '*':
+          begin
+            aMatch.P := pat;
+            aMatch.T := txt + 1;
+            inc(pat);
+            continue;
+          end;
+      else
+        if (txt <= aMatch.TMax) and
+           (c = aMatch.Text[txt]) then
+        begin
+          inc(pat);
+          inc(txt);
+          continue;
+        end;
+      end;
+    end
+    else if txt > aMatch.TMax then
+      break;
+    txt := aMatch.T;
+    if (txt > 0) and
+       (txt <= aMatch.TMax + 1) then
+    begin
+      inc(aMatch.T);
+      pat := aMatch.P + 1;
+      continue;
+    end;
+    result := false;
+    exit;
+  until false;
+  result := true;
+end;
+
+{$else} // optimized for x86_64/ARM with more registers
+
+function SearchNoRange(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+var
+  c: AnsiChar;
+  pat, patend, txtend, txtretry, patretry: PUtf8Char;
+label
+  fin;
+begin
+  pat := pointer(aMatch.Pattern);
+  if pat = nil then
+    goto fin;
+  patend := pat + aMatch.PMax;
+  patretry := nil;
+  txtend := aText + aTextLen - 1;
+  txtretry := nil;
+  repeat
+    if pat <= patend then
+    begin
+      c := pat^;
+      if c <> '*' then
+        if c <> '?' then
+        begin
+          if (aText <= txtend) and
+             (c = aText^) then
+          begin
+            inc(pat);
+            inc(aText);
+            continue;
+          end;
+        end
+        else
+        begin
+          // '?'
+          if aText <= txtend then
+          begin
+            inc(pat);
+            inc(aText);
+            continue;
+          end;
+        end
+      else
+      begin
+        // '*'
+        inc(pat);
+        txtretry := aText + 1;
+        patretry := pat;
+        continue;
+      end;
+    end
+    else if aText > txtend then
+      break;
+    if (PtrInt(PtrUInt(txtretry)) > 0) and
+       (txtretry <= txtend + 1) then
+    begin
+      aText := txtretry;
+      inc(txtretry);
+      pat := patretry;
+      continue;
+    end;
+fin:result := false;
+    exit;
+  until false;
+  result := true;
+end;
+
+{$endif CPUX86}
+
+function SearchNoRangeU(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+var
+  c: AnsiChar;
+  pat, txt: PtrInt;
+begin
+  aMatch.T := 0;
+  aMatch.Text := aText;
+  aMatch.TMax := aTextLen - 1;
+  pat := 0;
+  txt := 0;
+  repeat
+    if pat <= aMatch.PMax then
+    begin
+      c := aMatch.Pattern[pat];
+      case c of
+        '?':
+          if txt <= aMatch.TMax then
+          begin
+            inc(pat);
+            inc(txt);
+            continue;
+          end;
+        '*':
+          begin
+            aMatch.P := pat;
+            aMatch.T := txt + 1;
+            inc(pat);
+            continue;
+          end;
+      else
+        if (txt <= aMatch.TMax) and
+           (aMatch.Upper[c] = aMatch.Upper[aMatch.Text[txt]]) then
+        begin
+          inc(pat);
+          inc(txt);
+          continue;
+        end;
+      end;
+    end
+    else if txt > aMatch.TMax then
+      break;
+    txt := aMatch.T;
+    if (txt > 0) and
+       (txt <= aMatch.TMax + 1) then
+    begin
+      inc(aMatch.T);
+      pat := aMatch.P + 1;
+      continue;
+    end;
+    result := false;
+    exit;
+  until false;
+  result := true;
+end;
+
+function SimpleContainsU(t, tend, p: PUtf8Char; pmax: PtrInt; up: PNormTable): boolean;
+  {$ifdef FPC}inline;{$endif} // Delphi has troubles inlining goto/label
+// brute force case-insensitive search p[0..pmax] in t..tend-1
+var
+  first: AnsiChar;
+  i: PtrInt;
+label
+  next;
+begin
+  first := up[p^];
+  repeat
+    if up[t^] <> first then
+    begin
+next: inc(t);
+      if t < tend then
+        continue
+      else
+        break;
+    end;
+    for i := 1 to pmax do
+      if up[t[i]] <> up[p[i]] then
+        goto next;
+    result := true;
+    exit;
+  until false;
+  result := false;
+end;
+
+{$ifdef CPU64} // naive but very efficient code generation on FPC x86-64
+
+function SimpleContains8(t, tend, p: PUtf8Char; pmax: PtrInt): boolean;
+  {$ifdef FPC}inline;{$endif} // Delphi has troubles inlining goto/label
+label
+  next;
+var
+  i, first: PtrInt;
+begin
+  first := PPtrInt(p)^;
+  repeat
+    if PPtrInt(t)^ <> first then
+    begin
+next: inc(t);
+      if t < tend then
+        continue
+      else
+        break;
+    end;
+    for i := 8 to pmax do
+      if t[i] <> p[i] then
+        goto next;
+    result := true;
+    exit;
+  until false;
+  result := false;
+end;
+
+{$endif CPU64}
+
+
+{$ifdef CPUX86}
+
+function SimpleContains1(t, tend, p: PUtf8Char; pmax: PtrInt): boolean;
+  {$ifdef FPC}inline;{$endif} // Delphi has troubles inlining goto/label
+label
+  next;
+var
+  i: PtrInt;
+begin
+  repeat
+    if t^ <> p^ then
+    begin
+next: inc(t);
+      if t < tend then
+        continue
+      else
+        break;
+    end;
+    for i := 1 to pmax do
+      if t[i] <> p[i] then
+        goto next;
+    result := true;
+    exit;
+  until false;
+  result := false;
+end;
+
+function SimpleContains4(t, tend, p: PUtf8Char; pmax: PtrInt): boolean;
+  {$ifdef FPC}inline;{$endif} // Delphi has troubles inlining goto/label
+label
+  next;
+var
+  i: PtrInt;
+begin
+  repeat
+    if PCardinal(t)^ <> PCardinal(p)^ then
+    begin
+next: inc(t);
+      if t < tend then
+        continue
+      else
+        break;
+    end;
+    for i := 1 to pmax do
+      if t[i] <> p[i] then
+        goto next;
+    result := true;
+    exit;
+  until false;
+  result := false;
+end;
+
+{$else}
+
+function SimpleContains1(t, tend, p: PUtf8Char; pmax: PtrInt): boolean;
+  {$ifdef FPC}inline;{$endif} // Delphi has troubles inlining goto/label
+label
+  next;
+var
+  i: PtrInt;
+  first: AnsiChar;
+begin
+  first := p^;
+  repeat
+    if t^ <> first then
+    begin
+next: inc(t);
+      if t < tend then
+        continue
+      else
+        break;
+    end;
+    for i := 1 to pmax do
+      if t[i] <> p[i] then
+        goto next;
+    result := true;
+    exit;
+  until false;
+  result := false;
+end;
+
+function SimpleContains4(t, tend, p: PUtf8Char; pmax: PtrInt): boolean;
+  {$ifdef FPC}inline;{$endif} // Delphi has troubles inlining goto/label
+label
+  next;
+var
+  i: PtrInt;
+  first: cardinal;
+begin
+  first := PCardinal(p)^;
+  repeat
+    if PCardinal(t)^ <> first then
+    begin
+next: inc(t);
+      if t < tend then
+        continue
+      else
+        break;
+    end;
+    for i := 1 to pmax do
+      if t[i] <> p[i] then
+        goto next;
+    result := true;
+    exit;
+  until false;
+  result := false;
+end;
+
+{$endif CPUX86}
+
+function CompareMemU(P1, P2: PUtf8Char; len: PtrInt; U: PNormTable): boolean;
+  {$ifdef FPC} inline;{$endif}
+begin
+  // here we know that len>0
+  result := false;
+  repeat
+    dec(len);
+    if U[P1[len]] <> U[P2[len]] then
+      exit;
+  until len = 0;
+  result := true;
+end;
+
+function SearchVoid(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+begin
+  result := aTextLen = 0;
+end;
+
+function SearchNoPattern(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+begin
+  result := (aMatch.PMax + 1 = aTextLen) and
+            mormot.core.base.CompareMem(aText, aMatch.Pattern, aTextLen);
+end;
+
+function SearchNoPatternU(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+begin
+  result := (aMatch.PMax + 1 = aTextLen) and
+            CompareMemU(aText, aMatch.Pattern, aTextLen, aMatch.Upper);
+end;
+
+function SearchContainsValid(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+begin
+  result := true;
+end;
+
+function SearchContainsU(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+begin
+  dec(aTextLen, aMatch.PMax);
+  if aTextLen > 0 then
+    result := SimpleContainsU(aText, aText + aTextLen,
+      aMatch.Pattern, aMatch.PMax, aMatch.Upper)
+  else
+    result := false;
+end;
+
+function SearchContains1(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+begin
+  dec(aTextLen, aMatch.PMax);
+  if aTextLen > 0 then
+    result := SimpleContains1(aText, aText + aTextLen, aMatch.Pattern, aMatch.PMax)
+  else
+    result := false;
+end;
+
+function SearchContains4(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+begin
+  dec(aTextLen, aMatch.PMax);
+  if aTextLen > 0 then
+    result := SimpleContains4(aText, aText + aTextLen, aMatch.Pattern, aMatch.PMax)
+  else
+    result := false;
+end;
+
+{$ifdef CPU64}
+function SearchContains8(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+begin
+  // optimized e.g. to search an IP address as '*12.34.56.78*' in logs
+  dec(aTextLen, aMatch.PMax);
+  if aTextLen > 0 then
+    result := SimpleContains8(aText, aText + aTextLen, aMatch.Pattern, aMatch.PMax)
+  else
+    result := false;
+end;
+{$endif CPU64}
+
+function SearchStartWith(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+begin
+  result := (aMatch.PMax < aTextLen) and
+    mormot.core.base.CompareMem(aText, aMatch.Pattern, aMatch.PMax + 1);
+end;
+
+function SearchStartWithU(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+begin
+  result := (aMatch.PMax < aTextLen) and
+            CompareMemU(aText, aMatch.Pattern, aMatch.PMax + 1, aMatch.Upper);
+end;
+
+function SearchEndWith(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+begin
+  dec(aTextLen, aMatch.PMax);
+  result := (aTextLen >= 0) and
+    mormot.core.base.CompareMem(aText + aTextLen, aMatch.Pattern, aMatch.PMax);
+end;
+
+function SearchEndWithU(aMatch: PMatch; aText: PUtf8Char; aTextLen: PtrInt): boolean;
+begin
+  dec(aTextLen, aMatch.PMax);
+  result := (aTextLen >= 0) and
+            CompareMemU(aText + aTextLen, aMatch.Pattern, aMatch.PMax, aMatch.Upper);
+end;
+
+procedure TMatch.Prepare(const aPattern: RawUtf8;
+  aCaseInsensitive, aReuse: boolean);
+begin
+  Prepare(pointer(aPattern), length(aPattern), aCaseInsensitive, aReuse);
+end;
+
+procedure TMatch.Prepare(aPattern: PUtf8Char; aPatternLen: integer;
+  aCaseInsensitive, aReuse: boolean);
+const
+  SPECIALS: PUtf8Char = '*?[';
+begin
+  Pattern := aPattern;
+  pmax := aPatternLen - 1; // search in Pattern[0..PMax]
+  if Pattern = nil then
+  begin
+    Search := SearchVoid;
+    exit;
+  end;
+  if aCaseInsensitive and
+     not IsCaseSensitive(aPattern, aPatternLen) then
+    aCaseInsensitive := false; // don't slow down e.g. number or IP search
+  if aCaseInsensitive then
+    Upper := @NormToUpperAnsi7
+  else
+    Upper := @NormToNorm;
+  Search := nil;
+  if aReuse then
+    if strcspn(Pattern, SPECIALS) > pmax then
+      if aCaseInsensitive then
+        Search := SearchNoPatternU
+      else
+        Search := SearchNoPattern
+    else if pmax > 0 then
+    begin
+      if Pattern[pmax] = '*' then
+      begin
+        if strcspn(Pattern + 1, SPECIALS) = pmax - 1 then
+          case Pattern[0] of
+            '*':
+              begin
+                // *something*
+                inc(Pattern);
+                dec(pmax, 2); // trim trailing and ending *
+                if pmax < 0 then
+                  Search := SearchContainsValid
+                else if aCaseInsensitive then
+                  Search := SearchContainsU
+              {$ifdef CPU64}
+                else if pmax >= 7 then
+                  Search := SearchContains8
+              {$endif CPU64}
+                else if pmax >= 3 then
+                  Search := SearchContains4
+                else
+                  Search := SearchContains1;
+              end;
+            '?':
+              // ?something*
+              if aCaseInsensitive then
+                Search := SearchNoRangeU
+              else
+                Search := SearchNoRange;
+            '[':
+              Search := SearchAny;
+          else
+            begin
+              dec(pmax); // trim trailing *
+              if aCaseInsensitive then
+                Search := SearchStartWithU
+              else
+                Search := SearchStartWith;
+            end;
+          end;
+      end
+      else if (Pattern[0] = '*') and
+              (strcspn(Pattern + 1, SPECIALS) >= pmax) then
+      begin
+        inc(Pattern); // jump leading *
+        if aCaseInsensitive then
+          Search := SearchEndWithU
+        else
+          Search := SearchEndWith;
+      end;
+    end
+    else if Pattern[0] in ['*', '?'] then
+      Search := SearchContainsValid;
+  if not Assigned(Search) then
+  begin
+    aPattern := PosChar(Pattern, '[');
+    if (aPattern = nil) or
+       (aPattern - Pattern > pmax) then
+      if aCaseInsensitive then
+        Search := SearchNoRangeU
+      else
+        Search := SearchNoRange
+    else
+      Search := SearchAny;
+  end;
+end;
+
+type
+  // Holub and Durian (2005) SBNDM2 algorithm
+  // see http://www.cri.haifa.ac.il/events/2005/string/presentations/Holub.pdf
+  TSBNDMQ2Mask = array[AnsiChar] of cardinal;
+  PSBNDMQ2Mask = ^TSBNDMQ2Mask;
+
+function SearchSBNDMQ2ComputeMask(const Pattern: RawUtf8;
+  u: PNormTable): RawByteString;
+var
+  i: PtrInt;
+  p: PAnsiChar absolute Pattern;
+  m: PSBNDMQ2Mask absolute result;
+  c: PCardinal;
+begin
+  FastNewRawByteString(result, SizeOf(m^));
+  FillCharFast(m^, SizeOf(m^), 0);
+  for i := 0 to length(Pattern) - 1 do
+  begin
+    c := @m^[u[p[i]]]; // for FPC code generation
+    c^ := c^ or cardinal(1 shl i);
+  end;
+end;
+
+function SearchSBNDMQ2(aMatch: PMatch;
+  aText: PUtf8Char; aTextLen: PtrInt): boolean;
+var
+  mask: PSBNDMQ2Mask;
+  max, i, j: PtrInt;
+  state: cardinal;
+begin
+  mask := pointer(aMatch^.Pattern); // was filled by SearchSBNDMQ2ComputeMask()
+  max := aMatch^.pmax;
+  i := max - 1;
+  dec(aTextLen);
+  if i < aTextLen then
+  begin
+    repeat
+      state := mask[aText[i + 1]] shr 1; // in two steps for better FPC codegen
+      state := state and mask[aText[i]];
+      if state = 0 then
+      begin
+        inc(i, max); // fast skip
+        if i >= aTextLen then
+          break;
+        continue;
+      end;
+      j := i - max;
+      repeat
+        dec(i);
+        if i < 0 then
+          break;
+        state := (state shr 1) and mask[aText[i]];
+      until state = 0;
+      if i = j then
+      begin
+        result := true;
+        exit;
+      end;
+      inc(i, max);
+      if i >= aTextLen then
+        break;
+    until false;
+  end;
+  result := false;
+end;
+
+function SearchSBNDMQ2U(aMatch: PMatch;
+  aText: PUtf8Char; aTextLen: PtrInt): boolean;
+var
+  u: PNormTable;
+  mask: PSBNDMQ2Mask;
+  max, i, j: PtrInt;
+  state: cardinal;
+begin
+  mask := pointer(aMatch^.Pattern);
+  max := aMatch^.pmax;
+  u := aMatch^.Upper;
+  i := max - 1;
+  dec(aTextLen);
+  if i < aTextLen then
+  begin
+    repeat
+      state := mask[u[aText[i + 1]]] shr 1;
+      state := state and mask[u[aText[i]]];
+      if state = 0 then
+      begin
+        inc(i, max);
+        if i >= aTextLen then
+          break;
+        continue;
+      end;
+      j := i - max;
+      repeat
+        dec(i);
+        if i < 0 then
+          break;
+        state := (state shr 1) and mask[u[aText[i]]];
+      until state = 0;
+      if i = j then
+      begin
+        result := true;
+        exit;
+      end;
+      inc(i, max);
+      if i >= aTextLen then
+        break;
+    until false;
+  end;
+  result := false;
+end;
+
+procedure TMatch.PrepareContains(var aPattern: RawUtf8;
+  aCaseInsensitive: boolean);
+begin
+  pmax := length(aPattern) - 1;
+  if aCaseInsensitive and
+     not IsCaseSensitive(pointer(aPattern), pmax + 1) then
+    aCaseInsensitive := false;
+  if aCaseInsensitive then
+    Upper := @NormToUpperAnsi7
+  else
+    Upper := @NormToNorm;
+  if pmax < 0 then
+    Search := SearchContainsValid
+  else if pmax > 30 then
+    if aCaseInsensitive then
+      Search := SearchContainsU
+    else
+      {$ifdef CPU64}
+      Search := SearchContains8
+      {$else}
+      Search := SearchContains4
+      {$endif CPU64}
+  else if pmax >= 1 then
+  begin
+    // PMax=[1..30] -> len=[2..31] -> aPattern becomes a SBNDMQ2 lookup table
+    aPattern := SearchSBNDMQ2ComputeMask(aPattern, Upper);
+    if aCaseInsensitive then
+      Search := SearchSBNDMQ2U
+    else
+      Search := SearchSBNDMQ2;
+  end
+  else if aCaseInsensitive then
+    Search := SearchContainsU
+  else
+    Search := SearchContains1; // todo: use ByteScanIndex() asm?
+  Pattern := pointer(aPattern);
+end;
+
+procedure TMatch.PrepareRaw(aPattern: PUtf8Char; aPatternLen: integer;
+  aSearch: TMatchSearchFunction);
+begin
+  Pattern := aPattern;
+  pmax := aPatternLen - 1; // search in Pattern[0..PMax]
+  Search := aSearch;
+end;
+
+function TMatch.Match(const aText: RawUtf8): boolean;
+begin
+  if pointer(aText) <> nil then
+    result := Search(@self,
+                pointer(aText), PStrLen(PAnsiChar(pointer(aText)) - _STRLEN)^)
+  else
+    result := pmax < 0;
+end;
+
+function TMatch.Match(aText: PUtf8Char; aTextLen: PtrInt): boolean;
+begin
+  if (aText <> nil) and
+     (aTextLen > 0) then
+    result := Search(@self, aText, aTextLen)
+  else
+    result := pmax < 0;
+end;
+
+function TMatch.MatchThreadSafe(const aText: RawUtf8): boolean;
+var
+  local: TMatch; // thread-safe with no lock!
+begin
+  local := self;
+  if aText <> '' then
+    result := local.Search(@local, pointer(aText), length(aText))
+  else
+    result := local.PMax < 0;
+end;
+
+function TMatch.MatchString(const aText: string): boolean;
+var
+  local: TMatch; // thread-safe with no lock!
+  temp: TSynTempBuffer;
+  len: integer;
+begin
+  if aText = '' then
+  begin
+    result := pmax < 0;
+    exit;
+  end;
+  len := length(aText);
+  temp.Init(len * 3);
+  {$ifdef UNICODE}
+  len := RawUnicodeToUtf8(temp.buf, temp.len + 1, pointer(aText), len, [ccfNoTrailingZero]);
+  {$else}
+  len := CurrentAnsiConvert.AnsiBufferToUtf8(temp.buf, pointer(aText), len) - temp.buf;
+  {$endif UNICODE}
+  local := self;
+  result := local.Search(@local, temp.buf, len);
+  temp.Done;
+end;
+
+function TMatch.Equals(const aAnother: TMatch): boolean;
+begin
+  result := (pmax = TMatch(aAnother).pmax) and
+            (Upper = TMatch(aAnother).Upper) and
+    mormot.core.base.CompareMem(Pattern, TMatch(aAnother).Pattern, pmax + 1);
+end;
+
+function TMatch.PatternLength: integer;
+begin
+  result := pmax + 1;
+end;
+
+function TMatch.PatternText: PUtf8Char;
+begin
+  result := Pattern;
+end;
+
+function TMatch.CaseInsensitive: boolean;
+begin
+  result := Upper = @NormToUpperAnsi7;
+end;
+
+
+{ TUriMatchName }
+
+procedure TUriMatchName.ParsePath;
+var
+  i: PtrInt;
+begin
+  Name := Path;
+  i := Name.Len;
+  while i > 0 do // retrieve
+  begin
+    dec(i);
+    if Name.Text[i] <> '/' then
+      continue;
+    inc(i);
+    inc(Name.Text, i);
+    dec(Name.Len, i);
+    break;
+  end;
+end;
+
+
+{ TUriMatch }
+
+procedure TUriMatch.DoInit(csv: PUtf8Char; caseinsensitive: boolean);
+var
+  s: PUtf8Char;
+  m: ^TMatchDynArray;
+begin
+  if csv <> nil then
+    repeat
+      m := @Names; // default 'file.ext' pattern
+      csv := GotoNextNotSpace(csv);
+      s := csv;
+      repeat
+        case csv^ of
+          #0,
+          ',':
+            break;
+          '/':
+            m := @Paths; // is a 'path/to/file.ext' pattern
+        end;
+        inc(csv);
+      until false;
+      if csv <> s then
+        MatchNew(m^)^.Prepare(s, csv - s, caseinsensitive, true);
+      if csv^ = #0 then
+        break;
+      inc(csv);
+    until false;
+end;
+
+function TUriMatch.Check(const csv: RawUtf8;
+  const uri: TUriMatchName; caseinsensitive: boolean): boolean;
+begin
+  if Init.TryLock then // thread-safe init once from supplied csv
+    DoInit(pointer(csv), caseinsensitive);
+  result := ((Names <> nil) and
+             MatchAny(pointer(Names), uri.Name.Text, uri.Name.Len)) or
+            ((Paths <> nil) and
+             MatchAny(pointer(Paths), uri.Path.Text, uri.Path.Len));
+end;
+
+
+function IsMatch(const Pattern, Text: RawUtf8; CaseInsensitive: boolean): boolean;
+var
+  match: TMatch;
+begin
+  match.Prepare(pointer(Pattern), length(Pattern), CaseInsensitive, {reuse=}false);
+  result := match.Match(Text);
+end;
+
+function IsMatchString(const Pattern, Text: string;
+  CaseInsensitive: boolean): boolean;
+var
+  match: TMatch;
+  pat, txt: RawUtf8;
+begin
+  StringToUtf8(Pattern, pat); // local variable is mandatory for FPC
+  StringToUtf8(Text, txt);
+  match.Prepare(pat, CaseInsensitive, {reuse=}false);
+  result := match.Match(txt);
+end;
+
+function SetNextMatch(P: PUtf8Char; var Dest: TMatch;
+  CaseInsensitive, Reuse: boolean; CsvSep: AnsiChar): PUtf8Char;
+begin
+  result := P;
+  repeat
+    while not (result^ in [#0, CsvSep]) do
+      inc(result);
+    if result <> P then
+    begin
+      Dest.Prepare(P, result - P, CaseInsensitive, Reuse);
+      if result^ = CsvSep then
+        inc(result); // go to next CSV
+      exit;
+    end;
+  until result^ = #0;
+  result := nil; // indicates Dest.Prepare() was not called
+end;
+
+function IsMatchs(CsvPattern, Text: PUtf8Char; TextLen: PtrInt;
+  CaseInsensitive: boolean; CsvSep: AnsiChar): boolean;
+var
+  match: TMatch;
+begin
+  result := (CsvPattern <> nil) and (TextLen > 0);
+  if not result then
+    exit;
+  repeat
+    CsvPattern := SetNextMatch(
+      CsvPattern, match, CaseInsensitive, {reuse=}false, CsvSep);
+    if CsvPattern = nil then
+      break;
+    if match.Search(@match, Text, TextLen) then
+      exit;
+  until CsvPattern^ = #0;
+  result := false;
+end;
+
+function IsMatchs(const CsvPattern, Text: RawUtf8; CaseInsensitive: boolean;
+  CsvSep: AnsiChar): boolean;
+begin
+  result := IsMatchs(pointer(CsvPattern), pointer(Text), length(Text),
+    CaseInsensitive, CsvSep);
+end;
+
+function SetMatchs(const CsvPattern: RawUtf8; CaseInsensitive: boolean;
+  out Match: TMatchDynArray; CsvSep: AnsiChar): integer;
+var
+  P, S: PUtf8Char;
+begin
+  P := pointer(CsvPattern);
+  if P <> nil then
+    repeat
+      S := P;
+      while not (P^ in [#0, CsvSep]) do
+        inc(P);
+      if P <> S then
+        MatchNew(Match)^.Prepare(S, P - S, CaseInsensitive, {reuse=}true);
+      if P^ = #0 then
+        break;
+      inc(P);
+    until false;
+  result := length(Match);
+end;
+
+function SetMatchs(CsvPattern: PUtf8Char; CaseInsensitive: boolean;
+  Match: PMatch; MatchMax: integer; CsvSep: AnsiChar): integer;
+var
+  S: PUtf8Char;
+begin
+  result := 0;
+  if (CsvPattern <> nil) and
+     (MatchMax >= 0) then
+    repeat
+      S := CsvPattern;
+      while not (CsvPattern^ in [#0, CsvSep]) do
+        inc(CsvPattern);
+      if CsvPattern <> S then
+      begin
+        Match^.Prepare(S, CsvPattern - S, CaseInsensitive, {reuse=}true);
+        inc(result);
+        if result > MatchMax then
+          break;
+        inc(Match);
+      end;
+      if CsvPattern^ = #0 then
+        break;
+      inc(CsvPattern);
+    until false;
+end;
+
+function MatchExists(const One: TMatch; const Several: TMatchDynArray): boolean;
+var
+  i: PtrInt;
+begin
+  result := true;
+  for i := 0 to length(Several) - 1 do
+    if Several[i].Equals(One) then
+      exit;
+  result := false;
+end;
+
+function MatchAdd(const One: TMatch; var Several: TMatchDynArray): boolean;
+begin
+  result := not MatchExists(One, Several);
+  if result then
+    MatchNew(Several)^ := One;
+end;
+
+function MatchNew(var Several: TMatchDynArray): PMatch;
+var
+  n: PtrInt;
+begin
+  n := length(Several);
+  SetLength(Several, n + 1);
+  result := @Several[n];
+end;
+
+function MatchAny(const Match: TMatchDynArray; const Text: RawUtf8): boolean;
+begin
+  result := MatchAny(pointer(Match), pointer(Text), length(Text));
+end;
+
+function MatchAny(Match: PMatch; Text: PUtf8Char; TextLen: PtrInt): boolean;
+var
+  n: integer;
+begin
+  result := true;
+  if Match = nil then
+    exit;
+  if TextLen <= 0 then
+    Text := nil;
+  n := PDALen(PAnsiChar(pointer(Match)) - _DALEN)^ + (_DAOFF - 1);
+  repeat
+    // inlined Match^.Match() to avoid internal error on Delphi
+    if Text <> nil then
+    begin
+      if Match^.Search(Match, Text, TextLen) then
+        exit;
+    end
+    else if Match^.pmax < 0 then
+      exit;
+    inc(Match);
+    dec(n);
+  until n = 0;
+  result := false;
+end;
+
+procedure FilterMatchs(const CsvPattern: RawUtf8; CaseInsensitive: boolean;
+  var Values: TRawUtf8DynArray; CsvSep: AnsiChar);
+var
+  match: TMatchDynArray;
+  m, n, i: PtrInt;
+begin
+  if SetMatchs(CsvPattern, CaseInsensitive, match, CsvSep) = 0 then
+    exit;
+  n := 0;
+  for i := 0 to high(Values) do
+    for m := 0 to high(match) do
+      if match[m].Match(Values[i]) then
+      begin
+        if i <> n then
+          Values[n] := Values[i];
+        inc(n);
+        break;
+      end;
+  if n <> length(Values) then
+    SetLength(Values, n);
+end;
+
+procedure FilterMatchs(const CsvPattern: RawUtf8; CaseInsensitive: boolean;
+  var Values: TStringDynArray; CsvSep: AnsiChar);
+var
+  match: TMatchDynArray;
+  m, n, i: PtrInt;
+begin
+  if SetMatchs(CsvPattern, CaseInsensitive, match, CsvSep) = 0 then
+    exit;
+  n := 0;
+  for i := 0 to high(Values) do
+    for m := 0 to high(match) do
+      if match[m].MatchString(Values[i]) then
+      begin
+        if i <> n then
+          Values[n] := Values[i];
+        inc(n);
+        break;
+      end;
+  if n <> length(Values) then
+    SetLength(Values, n);
+end;
+
+
+{ TMatchs }
+
+constructor TMatchs.Create(const aPatterns: TRawUtf8DynArray; CaseInsensitive: boolean);
+begin
+  inherited Create; // may have been overriden
+  Subscribe(aPatterns, CaseInsensitive);
+end;
+
+function TMatchs.Match(const aText: RawUtf8): integer;
+begin
+  result := Match(pointer(aText), length(aText));
+end;
+
+function TMatchs.Match(aText: PUtf8Char; aLen: integer): integer;
+var
+  one: ^TMatchStore;
+  local: TMatch; // thread-safe with no lock!
+begin
+  if (self = nil) or
+     (fMatch = nil) then
+    result := -1 // no filter by name -> allow e.g. to process everything
+  else
+  begin
+    one := pointer(fMatch);
+    if aLen <> 0 then
+    begin
+      for result := 0 to fMatchCount - 1 do
+      begin
+        local := one^.Pattern;
+        if local.Search(@local, aText, aLen) then
+          exit;
+        inc(one);
+      end;
+    end
+    else
+      for result := 0 to fMatchCount - 1 do
+        if one^.Pattern.PMax < 0 then
+          exit
+        else
+          inc(one);
+    result := -2;
+  end;
+end;
+
+function TMatchs.MatchString(const aText: string): integer;
+var
+  temp: TSynTempBuffer;
+  len: integer;
+begin
+  len := StringToUtf8(aText, temp);
+  result := Match(temp.buf, len);
+  temp.Done;
+end;
+
+procedure TMatchs.Subscribe(const aPatternsCsv: RawUtf8; CaseInsensitive: boolean);
+var
+  patterns: TRawUtf8DynArray;
+begin
+  CsvToRawUtf8DynArray(pointer(aPatternsCsv), patterns);
+  Subscribe(patterns, CaseInsensitive);
+end;
+
+procedure TMatchs.Subscribe(const aPatterns: TRawUtf8DynArray; CaseInsensitive: boolean);
+var
+  i, j, m, n: integer;
+  found: ^TMatchStore;
+  pat: PRawUtf8;
+begin
+  m := length(aPatterns);
+  if m = 0 then
+    exit;
+  n := fMatchCount;
+  SetLength(fMatch, n + m);
+  pat := pointer(aPatterns);
+  for i := 1 to m do
+  begin
+    found := pointer(fMatch);
+    for j := 1 to n do
+      if StrComp(pointer(found^.PatternInstance), pointer(pat^)) = 0 then
+      begin
+        found := nil;
+        break;
+      end
+      else
+        inc(found);
+    if found <> nil then
+      with fMatch[n] do
+      begin
+        PatternInstance := pat^; // avoid GPF if aPatterns[] is released
+        Pattern.Prepare(PatternInstance, CaseInsensitive, {reuse=}true);
+        inc(n);
+      end;
+    inc(pat);
+  end;
+  fMatchCount := n;
+  if n <> length(fMatch) then
+    SetLength(fMatch, n);
+end;
+
+
+
+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
+      v := NormToUpperByte[ord(p^)]; // also handle 8-bit WinAnsi (1252 accents)
+      if not (tcWord in TEXT_BYTES[v]) 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-bit
+        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
+    result := NormToUpperByte[ord(p^)]; // also handle 8-bit WinAnsi (CP 1252)
+    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;
+
+procedure SoundExComputeUtf8(var U: PUtf8Char; var result: cardinal; Values: PSoundExValues);
+var
+  n, v, old: cardinal;
+begin
+  n := 0;
+  old := 0;
+  if Values <> nil then
+    repeat
+      v := GetNextUtf8Upper(U);
+      if not (tcWord in TEXT_BYTES[v]) 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-bit
+        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;
+
+
+{ 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 if not (tcWord in TEXT_CHARS[NormToUpper[A^]]) then
+          break
+        else
+          inc(A);
+      until false;
+    // find beginning of next word
+    repeat
+      if A^ = #0 then
+        exit
+      else if tcWord in TEXT_CHARS[NormToUpper[A^]] then
+        break
+      else
+        inc(A);
+    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 (tcWord in TEXT_BYTES[c]);
+    // find beginning of next word
+    repeat
+      if U = nil then
+        exit;
+      V := U;
+      c := GetNextUtf8Upper(U);
+      if c = 0 then
+        exit;
+    until tcWord in TEXT_BYTES[c];
+    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
+    while tcWord in TEXT_CHARS[NormToUpper[A^]] do
+      inc(A); // go to end of word
+    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;
+
+
+{ ******************  Efficient CSV Parsing using RTTI }
+
+function TDynArrayLoadCsv(var Value: TDynArray; Csv: PUtf8Char;
+  Intern: TRawUtf8Interning): boolean;
+var
+  rt: TRttiCustom;
+  pr: PRttiCustomProp;
+  p, v: PUtf8Char;
+  s: RawUtf8;
+  mapcount, mapped: PtrInt;
+  rec: PAnsiChar;
+  map: PRttiCustomPropDynArray;
+  m: ^PRttiCustomProp;
+  extcount, mcount: integer;
+  ext: PInteger;
+begin
+  result := false;
+  rt := Value.Info.ArrayRtti;
+  if (rt = nil) or
+     (rt.Parser <> ptRecord) or
+     (rt.Props.Count = 0) then
+    exit;
+  // parse the CSV headers
+  mapped := 0;
+  mapcount := 0;
+  SetLength(map, 32);
+  p := pointer(GetNextLine(Csv, Csv));
+  if Csv = nil then
+    exit; // no data
+  while p <> nil do
+  begin
+    GetNextItem(p, ',', '"', s);
+    if s = '' then
+      exit; // we don't support void headers
+    if mapcount = length(map) then
+      SetLength(map, NextGrow(mapcount));
+    pr := rt.Props.Find(s);
+    if pr <> nil then
+    begin
+      map[mapcount] := pr; // found a matching field
+      inc(mapped);
+    end;
+    inc(mapcount);
+  end;
+  if mapped = 0 then
+    exit; // no field matching any header
+  // parse the value rows
+  extcount := 0;
+  ext := Value.CountExternal;
+  if ext = nil then
+    Value.UseExternalCount(@extcount); // faster Value.NewPtr
+  v := Csv;
+  while v^ in [#10, #13] do
+    inc(v);
+  while v^ <> #0 do
+  begin
+    rec := Value.NewPtr;
+    m := pointer(map);
+    mcount := mapcount;
+    repeat
+      // parse next value
+      Csv := v;
+      if v^ = '"' then
+        v := GotoEndOfQuotedString(v); // special handling of double quotes
+      while (v^ <> ',') and
+            (v^ > #13) do
+        inc(v);
+      if mcount <> 0 then
+      begin
+        if m^ <> nil then // not matching fields are just ignored
+        begin
+          if Csv^ = '"' then
+          begin
+            UnQuoteSqlStringVar(Csv, s);
+            if Intern <> nil then
+              Intern.UniqueText(s);
+          end
+          else
+            Intern.Unique(s, Csv, v - Csv);
+          m^.Value.ValueSetText(rec + m^.OffsetSet, s);
+        end;
+        inc(m);
+        dec(mcount);
+      end;
+      if v^ <> ',' then
+        break;
+      inc(v);
+    until v^ in [#0, #10, #13];
+    // go to next row
+    while v^ in [#10, #13] do
+      inc(v);
+  end;
+  if Value.Count = 0 then
+    Value.Capacity := 0
+  else
+    DynArrayFakeLength(Value.Value^, Value.Count);
+  Value.UseExternalCount(ext); // restore fCountP if local n count was used
+  result := true;
+end;
+
+function DynArrayLoadCsv(var Value; const Csv: RawUtf8; TypeInfo: PRttiInfo;
+  Intern: TRawUtf8Interning): boolean;
+var
+  da: TDynArray;
+begin
+  da.Init(TypeInfo, Value);
+  result := TDynArrayLoadCsv(da, pointer(CSV), Intern);
+end;
+
+
+{ ****************** Versatile Expression Search Engine }
+
+
+function ToText(r: TExprParserResult): PShortString;
+begin
+  result := GetEnumName(TypeInfo(TExprParserResult), ord(r));
+end;
+
+function ToUtf8(r: TExprParserResult): RawUtf8;
+begin
+  result := UnCamelCase(TrimLeftLowerCaseShort(ToText(r)));
+end;
+
+
+{ TExprNode }
+
+function TExprNode.Append(node: TExprNode): boolean;
+begin
+  result := node <> nil;
+  if result then
+    Last.fNext := node;
+end;
+
+constructor TExprNode.Create(nodeType: TExprNodeType);
+begin
+  inherited Create; // may have been overriden
+  fNodeType := nodeType;
+end;
+
+destructor TExprNode.Destroy;
+begin
+  fNext.Free;
+  inherited Destroy;
+end;
+
+function TExprNode.Last: TExprNode;
+begin
+  result := self;
+  while result.Next <> nil do
+    result := result.Next;
+end;
+
+
+{ TParserAbstract }
+
+constructor TParserAbstract.Create;
+begin
+  inherited Create; // may have been overriden
+  Initialize;
+end;
+
+destructor TParserAbstract.Destroy;
+begin
+  Clear;
+  inherited Destroy;
+end;
+
+procedure TParserAbstract.Clear;
+begin
+  fWordCount := 0;
+  fWords := nil;
+  fExpression := '';
+  FreeAndNil(fFirstNode);
+end;
+
+function TParserAbstract.ParseExpr: TExprNode;
+begin
+  result := ParseFactor;
+  ParseNextCurrentWord;
+  if (fCurrentWord = '') or
+     (fCurrentWord = ')') then
+    exit;
+  if PropNameEquals(fCurrentWord, fAndWord) then
+  begin
+    // w1 & w2 = w1 AND w2
+    ParseNextCurrentWord;
+    if result.Append(ParseExpr) then
+      result.Append(TExprNode.Create(entAnd));
+    exit;
+  end
+  else if PropNameEquals(fCurrentWord, fOrWord) then
+  begin
+    // w1 + w2 = w1 OR w2
+    ParseNextCurrentWord;
+    if result.Append(ParseExpr) then
+      result.Append(TExprNode.Create(entOr));
+    exit;
+  end
+  else if fNoWordIsAnd and result.Append(ParseExpr) then
+    // 'w1 w2' = 'w1 & w2'
+    result.Append(TExprNode.Create(entAnd));
+end;
+
+function TParserAbstract.ParseFactor: TExprNode;
+begin
+  if fCurrentError <> eprSuccess then
+    result := nil
+  else if PropNameEquals(fCurrentWord, fNotWord) then
+  begin
+    ParseNextCurrentWord;
+    result := ParseFactor;
+    if fCurrentError <> eprSuccess then
+      exit;
+    result.Append(TExprNode.Create(entNot));
+  end
+  else
+    result := ParseTerm;
+end;
+
+function TParserAbstract.ParseTerm: TExprNode;
+begin
+  result := nil;
+  if fCurrentError <> eprSuccess then
+    exit;
+  if fCurrentWord = '(' then
+  begin
+    ParseNextCurrentWord;
+    result := ParseExpr;
+    if fCurrentError <> eprSuccess then
+      exit;
+    if fCurrentWord <> ')' then
+    begin
+      FreeAndNil(result);
+      fCurrentError := eprMissingParenthesis;
+    end;
+  end
+  else if fCurrentWord = '' then
+  begin
+    result := nil;
+    fCurrentError := eprMissingFinalWord;
+  end
+  else
+  try // calls meta-class overriden constructor
+    result := fWordClass.Create(self, fCurrentWord);
+    fCurrentError := TExprNodeWordAbstract(result).ParseWord;
+    if fCurrentError <> eprSuccess then
+    begin
+      FreeAndNil(result);
+      exit;
+    end;
+    SetLength(fWords, fWordCount + 1);
+    fWords[fWordCount] := TExprNodeWordAbstract(result);
+    inc(fWordCount);
+  except
+    FreeAndNil(result);
+    fCurrentError := eprInvalidExpression;
+  end;
+end;
+
+function TParserAbstract.Parse(const aExpression: RawUtf8): TExprParserResult;
+var
+  depth: integer;
+  n: TExprNode;
+begin
+  Clear;
+  fCurrentError := eprSuccess;
+  fCurrent := pointer(aExpression);
+  ParseNextCurrentWord;
+  if fCurrentWord = '' then
+  begin
+    result := eprNoExpression;
+    exit;
+  end;
+  fFirstNode := ParseExpr;
+  result := fCurrentError;
+  if result = eprSuccess then
+  begin
+    depth := 0;
+    n := fFirstNode;
+    while n <> nil do
+    begin
+      case n.NodeType of
+        entWord:
+          begin
+            inc(depth);
+            if depth > high(fFoundStack) then
+            begin
+              result := eprTooManyParenthesis;
+              break;
+            end;
+          end;
+        entOr, entAnd:
+          dec(depth);
+      end;
+      n := n.Next;
+    end;
+  end;
+  if result = eprSuccess then
+    fExpression := aExpression
+  else
+    Clear;
+  fCurrent := nil;
+end;
+
+class function TParserAbstract.ParseError(const aExpression: RawUtf8): RawUtf8;
+var
+  parser: TParserAbstract;
+  res: TExprParserResult;
+begin
+  parser := Create;
+  try
+    res := parser.Parse(aExpression);
+    if res = eprSuccess then
+      result := ''
+    else
+      result := ToUtf8(res);
+  finally
+    parser.Free;
+  end;
+end;
+
+function TParserAbstract.Execute: boolean;
+var
+  n: TExprNode;
+  st: PBoolean;
+begin
+  // code below compiles very efficiently on FPC/x86-64
+  st := @fFoundStack;
+  n := fFirstNode;
+  repeat
+    case n.NodeType of
+      entWord:
+        begin
+          st^ := TExprNodeWordAbstract(n).fFound;
+          inc(st); // see eprTooManyParenthesis above to avoid buffer overflow
+        end;
+      entNot:
+        PAnsiChar(st)[-1] := AnsiChar(ord(PAnsiChar(st)[-1]) xor 1);
+      entOr:
+        begin
+          dec(st);
+          PAnsiChar(st)[-1] := AnsiChar(st^ or boolean(PAnsiChar(st)[-1]));
+        end; { TODO : optimize TExprParser OR when left member is already TRUE }
+      entAnd:
+        begin
+          dec(st);
+          PAnsiChar(st)[-1] := AnsiChar(st^ and boolean(PAnsiChar(st)[-1]));
+        end;
+    end;
+    n := n.Next;
+  until n = nil;
+  result := boolean(PAnsiChar(st)[-1]);
+end;
+
+
+{ TExprParserAbstract }
+
+procedure TExprParserAbstract.Initialize;
+begin
+  fAndWord := '&';
+  fOrWord := '+';
+  fNotWord := '-';
+  fNoWordIsAnd := true;
+end;
+
+procedure TExprParserAbstract.ParseNextCurrentWord;
+var
+  P: PUtf8Char;
+begin
+  fCurrentWord := '';
+  P := fCurrent;
+  if P = nil then
+    exit;
+  while P^ in [#1..' '] do
+    inc(P);
+  if P^ = #0 then
+    exit;
+  if P^ in PARSER_STOPCHAR then
+  begin
+    FastSetString(fCurrentWord, P, 1);
+    fCurrent := P + 1;
+  end
+  else
+  begin
+    fCurrent := P;
+    ParseNextWord;
+  end;
+end;
+
+procedure TExprParserAbstract.ParseNextWord;
+const
+  STOPCHAR = PARSER_STOPCHAR + [#0, ' '];
+var
+  P: PUtf8Char;
+begin
+  P := fCurrent;
+  while not (P^ in STOPCHAR) do
+    inc(P);
+  FastSetString(fCurrentWord, fCurrent, P - fCurrent);
+  fCurrent := P;
+end;
+
+
+{ TExprNodeWordAbstract }
+
+constructor TExprNodeWordAbstract.Create(aOwner: TParserAbstract;
+  const aWord: RawUtf8);
+begin
+  inherited Create(entWord);
+  fWord := aWord;
+  fOwner := aOwner;
+end;
+
+
+{ TExprParserMatchNode }
+
+type
+  TExprParserMatchNode = class(TExprNodeWordAbstract)
+  protected
+    fMatch: TMatch;
+    function ParseWord: TExprParserResult; override;
+  end;
+
+function TExprParserMatchNode.ParseWord: TExprParserResult;
+begin
+  fMatch.Prepare(fWord, (fOwner as TExprParserMatch).fCaseSensitive, {reuse=}true);
+  result := eprSuccess;
+end;
+
+
+{ TExprParserMatch }
+
+var
+  // equals 1 for ['0'..'9', 'A'..'Z', 'a'..'z', #$80..#$ff]
+  ROUGH_UTF8: TAnsiCharToByte;
+
+constructor TExprParserMatch.Create(aCaseSensitive: boolean);
+var
+  c: AnsiChar;
+begin
+  inherited Create;
+  if ROUGH_UTF8['0'] = 0 then // ensure is initialized for Search()
+    for c := low(c) to high(c) do
+      if c in ['0'..'9', 'A'..'Z', 'a'..'z', #$80..#$ff] then
+        ROUGH_UTF8[c] := 1;
+  fCaseSensitive := aCaseSensitive;
+end;
+
+procedure TExprParserMatch.Initialize;
+begin
+  inherited Initialize;
+  fWordClass := TExprParserMatchNode;
+end;
+
+function TExprParserMatch.Search(const aText: RawUtf8): boolean;
+begin
+  result := Search(pointer(aText), length(aText));
+end;
+
+function TExprParserMatch.Search(aText: PUtf8Char; aTextLen: PtrInt): boolean;
+var
+  P, PEnd: PUtf8Char;
+  n: PtrInt;
+  tab: PAnsiCharToByte;
+begin
+  P := aText;
+  if (P = nil) or
+     (fWords = nil) then
+  begin
+    result := false;
+    exit;
+  end;
+  // reset any previous resultset
+  if fMatchedLastSet > 0 then
+  begin
+    n := fWordCount;
+    repeat
+      dec(n);
+      fWords[n].fFound := false;
+    until n = 0;
+    fMatchedLastSet := 0;
+  end;
+  PEnd := P + aTextLen;
+  while (P < PEnd) and
+        (fMatchedLastSet < fWordCount) do
+  begin
+    // recognize next word boudaries
+    tab := @ROUGH_UTF8;
+    while tab[P^] = 0 do
+    begin
+      inc(P);
+      if P = PEnd then
+        break;
+    end;
+    if P = PEnd then
+      break;
+    aText := P;
+    repeat
+      inc(P);
+    until (P = PEnd) or
+          (tab[P^] = 0);
+    // apply the expression nodes to this word
+    aTextLen := P - aText; // now aText/aTextLen point to a word
+    n := fWordCount;
+    repeat
+      dec(n);
+      with TExprParserMatchNode(fWords[n]) do
+        if not fFound and
+           fMatch.Match(aText, aTextLen) then
+        begin
+          fFound := true;
+          inc(fMatchedLastSet);
+        end;
+    until n = 0;
+  end;
+  result := Execute;
+end;
+
+
+
+{ ****************** Bloom Filter Probabilistic Index }
+
+{ TSynBloomFilter }
+
+const
+  BLOOM_VERSION = 0;
+  BLOOM_MAXHASH = 32; // only 7 is needed for 1% false positive ratio
+
+constructor TSynBloomFilter.Create;
+begin
+  fHasher := @crc32c; // default/standard/mORMot1 hash function
+end;
+
+constructor TSynBloomFilter.Create(aSize: integer;
+  aFalsePositivePercent: double; aHasher: THasher);
+const
+  LN2 = 0.69314718056;
+begin
+  Create; // set fHasher := crc32c + may have been overriden
+  if aSize < 0 then
+    fSize := 1000
+  else
+    fSize := aSize;
+  if aFalsePositivePercent <= 0 then
+    fFalsePositivePercent := 1
+  else if aFalsePositivePercent > 100 then
+    fFalsePositivePercent := 100
+  else
+    fFalsePositivePercent := aFalsePositivePercent;
+  if @aHasher <> nil then
+    fHasher := aHasher;
+  // see http://stackoverflow.com/a/22467497
+  fBits := Round(-ln(fFalsePositivePercent / 100) * aSize / (LN2 * LN2));
+  fHashFunctions := Round(fBits / fSize * LN2);
+  if fHashFunctions = 0 then
+    fHashFunctions := 1
+  else if fHashFunctions > BLOOM_MAXHASH then
+    fHashFunctions := BLOOM_MAXHASH;
+  Reset;
+end;
+
+constructor TSynBloomFilter.Create(const aSaved: RawByteString;
+  aMagic: cardinal; aHasher: THasher);
+begin
+  Create; // set fHasher := crc32c + may have been overriden
+  if @aHasher <> nil then
+    fHasher := aHasher;
+  if not LoadFrom(aSaved, aMagic) then // will load fSize+fBits+fHashFunctions
+    raise ESynException.CreateUtf8('%.Create with invalid aSaved content', [self]);
+end;
+
+procedure TSynBloomFilter.Insert(const aValue: RawByteString);
+begin
+  Insert(pointer(aValue), length(aValue));
+end;
+
+procedure TSynBloomFilter.Insert(aValue: pointer; aValueLen: integer);
+var
+  h: integer;
+  h1, h2: cardinal; // https://goo.gl/Pls5wi
+begin
+  if (self = nil) or
+     (aValueLen <= 0) or
+     (fBits = 0) then
+    exit;
+  h1 := fHasher(0, aValue, aValueLen);
+  if fHashFunctions = 1 then
+    h2 := 0
+  else
+    h2 := fHasher(h1, aValue, aValueLen);
+  fSafe.WriteLock;
+  try
+    for h := 0 to fHashFunctions - 1 do
+    begin
+      SetBitPtr(pointer(fStore), h1 mod fBits);
+      inc(h1, h2);
+    end;
+    inc(fInserted);
+  finally
+    fSafe.WriteUnLock;
+  end;
+end;
+
+function TSynBloomFilter.MayExist(const aValue: RawByteString): boolean;
+begin
+  result := MayExist(pointer(aValue), length(aValue));
+end;
+
+function TSynBloomFilter.MayExist(aValue: pointer; aValueLen: integer): boolean;
+var
+  h: integer;
+  h1, h2: cardinal; // https://goo.gl/Pls5wi
+begin
+  result := false;
+  if (self = nil) or
+     (aValueLen <= 0) or
+     (fBits = 0) then
+    exit;
+  h1 := fHasher(0, aValue, aValueLen);
+  if fHashFunctions = 1 then
+    h2 := 0
+  else
+    h2 := fHasher(h1, aValue, aValueLen);
+  fSafe.ReadOnlyLock; // allow concurrent reads
+  try
+    for h := 0 to fHashFunctions - 1 do
+      if GetBitPtr(pointer(fStore), h1 mod fBits) then
+        inc(h1, h2)
+      else
+        exit;
+  finally
+    fSafe.ReadOnlyUnLock;
+  end;
+  result := true;
+end;
+
+procedure TSynBloomFilter.Reset;
+begin
+  fSafe.WriteLock;
+  try
+    if fStore = '' then
+      SetLength(fStore, (fBits shr 3) + 1);
+    FillcharFast(pointer(fStore)^, length(fStore), 0);
+    fInserted := 0;
+  finally
+    fSafe.WriteUnLock;
+  end;
+end;
+
+function TSynBloomFilter.SaveTo(aMagic: cardinal): RawByteString;
+var
+  W: TBufferWriter;
+  BufLen: integer;
+  temp: array[word] of byte;
+begin
+  BufLen := length(fStore) + 100;
+  if BufLen <= SizeOf(temp) then
+    W := TBufferWriter.Create(TRawByteStringStream, @temp, SizeOf(temp))
+  else
+    W := TBufferWriter.Create(TRawByteStringStream, BufLen);
+  try
+    SaveTo(W, aMagic);
+    W.Flush;
+    result := TRawByteStringStream(W.Stream).DataString;
+  finally
+    W.Free;
+  end;
+end;
+
+procedure TSynBloomFilter.SaveTo(aDest: TBufferWriter; aMagic: cardinal);
+begin
+  aDest.Write4(aMagic);
+  aDest.Write1(BLOOM_VERSION);
+  fSafe.ReadOnlyLock;
+  try
+    aDest.Write8(@fFalsePositivePercent);
+    aDest.Write4(fSize);
+    aDest.Write4(fBits);
+    aDest.Write1(fHashFunctions);
+    aDest.Write4(fInserted);
+    // warning: fHasher is NOT persisted yet
+    ZeroCompress(pointer(fStore), Length(fStore), aDest);
+  finally
+    fSafe.ReadOnlyUnLock;
+  end;
+end;
+
+function TSynBloomFilter.LoadFrom(const aSaved: RawByteString; aMagic: cardinal): boolean;
+begin
+  result := LoadFrom(pointer(aSaved), length(aSaved));
+end;
+
+function TSynBloomFilter.LoadFrom(P: PByte; PLen: integer; aMagic: cardinal): boolean;
+var
+  start: PByte;
+  version: integer;
+begin
+  result := false;
+  start := P;
+  if (P = nil) or
+     (PLen < 32) or
+     (PCardinal(P)^ <> aMagic) then
+    exit;
+  inc(P, 4);
+  version := P^;
+  inc(P);
+  if version > BLOOM_VERSION then
+    exit;
+  fSafe.WriteLock;
+  try
+    fFalsePositivePercent := unaligned(PDouble(P)^);
+    inc(P, 8);
+    if (fFalsePositivePercent <= 0) or
+       (fFalsePositivePercent > 100) then
+      exit;
+    fSize := PCardinal(P)^;
+    inc(P, 4);
+    fBits := PCardinal(P)^;
+    inc(P, 4);
+    if fBits < fSize then
+      exit;
+    fHashFunctions := P^;
+    inc(P);
+    if fHashFunctions - 1 >= BLOOM_MAXHASH then
+      exit;
+    Reset;
+    fInserted := PCardinal(P)^;
+    inc(P, 4);
+    ZeroDecompress(P, PLen - (PAnsiChar(P) - PAnsiChar(start)), fStore);
+    result := length(fStore) = integer(fBits shr 3) + 1;
+  finally
+    fSafe.WriteUnLock;
+  end;
+end;
+
+
+{ TSynBloomFilterDiff }
+
+type
+  TBloomDiffHeaderKind = (bdDiff, bdFull, bdUpToDate);
+  TBloomDiffHeader = packed record
+    kind: TBloomDiffHeaderKind;
+    size: cardinal;
+    inserted: cardinal;
+    revision: Int64;
+    crc: cardinal;
+  end;
+
+procedure TSynBloomFilterDiff.Insert(aValue: pointer; aValueLen: integer);
+begin
+  fSafe.WriteLock;
+  try
+    inherited Insert(aValue, aValueLen);
+    inc(fRevision);
+    inc(fSnapshotInsertCount);
+  finally
+    fSafe.WriteUnLock;
+  end;
+end;
+
+procedure TSynBloomFilterDiff.Reset;
+begin
+  fSafe.WriteLock;
+  try
+    inherited Reset;
+    fSnapshotAfterInsertCount := fSize shr 5;
+    fSnapShotAfterMinutes := 30;
+    fSnapshotTimestamp := 0;
+    fSnapshotInsertCount := 0;
+    fRevision := UnixTimeUtc shl 31;
+    fKnownRevision := 0;
+    fKnownStore := '';
+  finally
+    fSafe.WriteUnLock;
+  end;
+end;
+
+procedure TSynBloomFilterDiff.DiffSnapshot;
+begin
+  fSafe.WriteLock;
+  try
+    fKnownRevision := fRevision;
+    fSnapshotInsertCount := 0;
+    FastSetRawByteString(fKnownStore, pointer(fStore), length(fStore));
+    if fSnapShotAfterMinutes = 0 then
+      fSnapshotTimestamp := 0
+    else
+      fSnapshotTimestamp := GetTickCount64 + fSnapShotAfterMinutes * 60000;
+  finally
+    fSafe.WriteUnLock;
+  end;
+end;
+
+function TSynBloomFilterDiff.SaveToDiff(const aKnownRevision: Int64): RawByteString;
+var
+  head: TBloomDiffHeader;
+  W: TBufferWriter;
+  temp: array[word] of byte;
+begin
+  fSafe.ReadWriteLock; // DiffSnapshot makes a WriteLock
+  try
+    if aKnownRevision = fRevision then
+      head.kind := bdUpToDate
+    else if (fKnownRevision = 0) or
+            (fSnapshotInsertCount > fSnapshotAfterInsertCount) or
+            ((fSnapshotInsertCount > 0) and
+             (fSnapshotTimestamp <> 0) and
+             (GetTickCount64 > fSnapshotTimestamp)) then
+    begin
+      DiffSnapshot;
+      head.kind := bdFull;
+    end
+    else if (aKnownRevision < fKnownRevision) or
+            (aKnownRevision > fRevision) then
+      head.kind := bdFull
+    else
+      head.kind := bdDiff;
+    head.size := length(fStore);
+    head.inserted := fInserted;
+    head.revision := fRevision;
+    head.crc := fHasher(0, @head, SizeOf(head) - SizeOf(head.crc));
+    if head.kind = bdUpToDate then
+    begin
+      FastSetRawByteString(result, @head, SizeOf(head));
+      exit;
+    end;
+    if head.size + 100 <= SizeOf(temp) then
+      W := TBufferWriter.Create(TRawByteStringStream, @temp, SizeOf(temp))
+    else
+      W := TBufferWriter.Create(TRawByteStringStream, head.size + 100);
+    try
+      W.Write(@head, SizeOf(head));
+      case head.kind of
+        bdFull:
+          SaveTo(W);
+        bdDiff:
+          ZeroCompressXor(pointer(fStore), pointer(fKnownStore), head.size, W);
+      end;
+      result := W.FlushTo;
+    finally
+      W.Free;
+    end;
+  finally
+    fSafe.ReadWriteUnLock;
+  end;
+end;
+
+function TSynBloomFilterDiff.DiffKnownRevision(const aDiff: RawByteString): Int64;
+var
+  head: ^TBloomDiffHeader absolute aDiff;
+begin
+  if (length(aDiff) < SizeOf(head^)) or
+     (head.kind > high(TBloomDiffHeaderKind)) or
+     (head.size <> cardinal(length(fStore))) or
+     (head.crc <> fHasher(0, pointer(head), SizeOf(head^) - SizeOf(head.crc))) then
+    result := 0
+  else
+    result := head.Revision;
+end;
+
+function TSynBloomFilterDiff.LoadFromDiff(const aDiff: RawByteString): boolean;
+var
+  head: ^TBloomDiffHeader absolute aDiff;
+  P: PByte;
+  PLen: integer;
+begin
+  result := false;
+  P := pointer(aDiff);
+  PLen := length(aDiff);
+  if (PLen < SizeOf(head^)) or
+     (head.kind > high(head.kind)) or
+     (head.crc <> fHasher(0, pointer(head), SizeOf(head^) - SizeOf(head.crc))) then
+    exit;
+  if (fStore <> '') and
+     (head.size <> cardinal(length(fStore))) then
+    exit;
+  inc(P, SizeOf(head^));
+  dec(PLen, SizeOf(head^));
+  fSafe.WriteLock;
+  try
+    case head.kind of
+      bdFull:
+        result := LoadFrom(P, PLen);
+      bdDiff:
+        if fStore <> '' then
+          result := ZeroDecompressOr(pointer(P), Pointer(fStore), PLen, head.size);
+      bdUpToDate:
+        result := true;
+    end;
+    if result then
+    begin
+      fRevision := head.revision;
+      fInserted := head.inserted;
+    end;
+  finally
+    fSafe.WriteUnLock;
+  end;
+end;
+
+
+procedure ZeroCompress(P: PAnsiChar; Len: integer; Dest: TBufferWriter);
+var
+  PEnd, beg, zero: PAnsiChar;
+  crc: cardinal;
+begin
+  Dest.WriteVarUInt32(Len);
+  PEnd := P + Len;
+  beg := P;
+  crc := 0;
+  while P < PEnd do
+  begin
+    while (P^ <> #0) and
+          (P < PEnd) do
+      inc(P);
+    zero := P;
+    while (P^ = #0) and
+          (P < PEnd) do
+      inc(P);
+    if P - zero > 3 then
+    begin
+      Len := zero - beg;
+      crc := crc32c(crc, beg, Len);
+      Dest.WriteVarUInt32(Len);
+      Dest.Write(beg, Len);
+      Len := P - zero;
+      crc := crc32c(crc, @Len, SizeOf(Len));
+      Dest.WriteVarUInt32(Len - 3);
+      beg := P;
+    end;
+  end;
+  Len := P - beg;
+  if Len > 0 then
+  begin
+    crc := crc32c(crc, beg, Len);
+    Dest.WriteVarUInt32(Len);
+    Dest.Write(beg, Len);
+  end;
+  Dest.Write4(crc);
+end;
+
+procedure ZeroCompressXor(New, Old: PAnsiChar; Len: cardinal; Dest: TBufferWriter);
+var
+  beg, same, index, crc, L: cardinal;
+begin
+  Dest.WriteVarUInt32(Len);
+  beg := 0;
+  index := 0;
+  crc := 0;
+  while index < Len do
+  begin
+    while (New[index] <> Old[index]) and
+          (index < Len) do
+      inc(index);
+    same := index;
+    while (New[index] = Old[index]) and
+          (index < Len) do
+      inc(index);
+    L := index - same;
+    if L > 3 then
+    begin
+      Dest.WriteVarUInt32(same - beg);
+      Dest.WriteXor(New + beg, Old + beg, same - beg, @crc);
+      crc := crc32c(crc, @L, SizeOf(L));
+      Dest.WriteVarUInt32(L - 3);
+      beg := index;
+    end;
+  end;
+  L := index - beg;
+  if L > 0 then
+  begin
+    Dest.WriteVarUInt32(L);
+    Dest.WriteXor(New + beg, Old + beg, L, @crc);
+  end;
+  Dest.Write4(crc);
+end;
+
+procedure ZeroDecompress(P: PByte; Len: integer; var Dest: RawByteString);
+var
+  PEnd, D, DEnd: PAnsiChar;
+  DestLen, crc: cardinal;
+begin
+  PEnd := PAnsiChar(P) + Len - 4;
+  DestLen := FromVarUInt32(P);
+  FastNewRawByteString(Dest, DestLen);
+  D := pointer(Dest);
+  DEnd := D + DestLen;
+  crc := 0;
+  while PAnsiChar(P) < PEnd do
+  begin
+    Len := FromVarUInt32(P);
+    if D + Len > DEnd then
+      break;
+    MoveFast(P^, D^, Len);
+    crc := crc32c(crc, D, Len);
+    inc(P, Len);
+    inc(D, Len);
+    if PAnsiChar(P) >= PEnd then
+      break;
+    Len := FromVarUInt32(P) + 3;
+    if D + Len > DEnd then
+      break;
+    FillCharFast(D^, Len, 0);
+    crc := crc32c(crc, @Len, SizeOf(Len));
+    inc(D, Len);
+  end;
+  if crc <> PCardinal(P)^ then
+    Dest := '';
+end;
+
+function ZeroDecompressOr(P, Dest: PAnsiChar; Len, DestLen: integer): boolean;
+var
+  PEnd, DEnd: PAnsiChar;
+  crc: cardinal;
+begin
+  PEnd := P + Len - 4;
+  if cardinal(DestLen) <> FromVarUInt32(PByte(P)) then
+  begin
+    result := false;
+    exit;
+  end;
+  DEnd := Dest + DestLen;
+  crc := 0;
+  while (P < PEnd) and
+        (Dest < DEnd) do
+  begin
+    Len := FromVarUInt32(PByte(P));
+    if Dest + Len > DEnd then
+      break;
+    crc := crc32c(crc, P, Len);
+    OrMemory(pointer(Dest), pointer(P), Len);
+    inc(P, Len);
+    inc(Dest, Len);
+    if P >= PEnd then
+      break;
+    Len := FromVarUInt32(PByte(P)) + 3;
+    crc := crc32c(crc, @Len, SizeOf(Len));
+    inc(Dest, Len);
+  end;
+  result := crc = PCardinal(P)^;
+end;
+
+
+{ ****************** Binary Buffers Delta Compression }
+
+function Max(a, b: PtrInt): PtrInt; {$ifdef HASINLINE}inline;{$endif}
+begin
+  if a > b then
+    result := a
+  else
+    result := b;
+end;
+
+function Min(a, b: PtrInt): PtrInt; {$ifdef HASINLINE}inline;{$endif}
+begin
+  if a < b then
+    result := a
+  else
+    result := b;
+end;
+
+{$ifdef HASINLINE}
+function Comp(a, b: PAnsiChar; len: PtrInt): PtrInt; inline;
+var
+  lenptr: PtrInt;
+begin
+  result := 0;
+  lenptr := len - SizeOf(PtrInt);
+  if lenptr >= 0 then
+    repeat
+      if PPtrInt(a + result)^ <> PPtrInt(b + result)^ then
+        break;
+      inc(result, SizeOf(PtrInt));
+    until result > lenptr;
+  if result < len then
+    repeat
+      if a[result] <> b[result] then
+        exit;
+      inc(result);
+    until result = len;
+end;
+{$else} // eax = a, edx = b, ecx = len
+function Comp(a, b: PAnsiChar; len: PtrInt): PtrInt;
+asm // the 'rep cmpsb' version is slower on Intel Core CPU (not AMD)
+        or      ecx, ecx
+        push    ebx
+        push    ecx
+        jz      @ok
+
+@1:     mov     bx, [eax]
+        lea     eax, [eax + 2]
+        cmp     bl, [edx]
+        jne     @ok
+        dec     ecx
+        jz      @ok
+        cmp     bh, [edx + 1]
+        lea     edx, [edx + 2]
+        jne     @ok
+        dec     ecx
+        jnz     @1
+
+@ok:    pop     eax
+        sub     eax, ecx
+        pop     ebx
+end;
+{$endif HASINLINE}
+
+function CompReverse(a, b: pointer; len: PtrInt): PtrInt;
+begin
+  result := 0;
+  if len > 0 then
+    repeat
+      if PByteArray(a)[-result] <> PByteArray(b)[-result] then
+        exit;
+      inc(result);
+    until result = len;
+end;
+
+function WriteCurOfs(curofs, curlen, curofssize: integer; sp: PAnsiChar): PAnsiChar;
+begin
+  if curlen = 0 then
+  begin
+    sp^ := #0;
+    inc(sp);
+  end
+  else
+  begin
+    sp := Pointer(ToVarUInt32(curlen, PByte(sp)));
+    PInteger(sp)^ := curofs;
+    inc(sp, curofssize);
+  end;
+  result := sp;
+end;
+
+{$ifdef CPUINTEL}
+// crc32c SSE4.2 hardware accellerated dword hash
+{$ifdef CPUX86}
+function crc32c32sse42(buf: pointer): cardinal;
+{$ifdef FPC} nostackframe; assembler; {$endif}
+asm
+        mov     edx, eax
+        xor     eax, eax
+        {$ifdef HASAESNI}
+        crc32   eax, dword ptr [edx]
+        {$else}
+        db $F2, $0F, $38, $F1, $02
+        {$endif HASAESNI}
+end;
+{$else}
+function crc32c32sse42(buf: pointer): cardinal;
+{$ifdef FPC}nostackframe; assembler; asm {$else}
+asm // ecx=buf (Linux: edi=buf)
+        .noframe
+{$endif FPC}
+        xor     eax, eax
+        crc32   eax, dword ptr [buf]
+end;
+{$endif CPUX86}
+{$endif CPUINTEL}
+
+function hash32prime(buf: pointer): cardinal;
+begin
+  // inlined xxHash32Mixup - won't pollute L1 cache with crc lookup tables
+  result := PCardinal(buf)^;
+  result := result xor (result shr 15);
+  result := result * 2246822519;
+  result := result xor (result shr 13);
+  result := result * 3266489917;
+  result := result xor (result shr 16);
+end;
+
+const
+  HTabBits = 18; // fits well with DeltaCompress(..,BufSize=2MB)
+  HTabMask = (1 shl HTabBits) - 1; // =$3ffff
+  HListMask = $ffffff; // HTab[]=($ff,$ff,$ff)
+
+type
+  PHTab = ^THTab; // HTabBits=18 -> SizeOf=767KB
+  THTab = packed array[0..HTabMask] of array[0..2] of byte;
+
+function DeltaCompute(NewBuf, OldBuf, OutBuf, WorkBuf: PAnsiChar;
+  NewBufSize, OldBufSize, MaxLevel: PtrInt; HList, HTab: PHTab): PAnsiChar;
+var
+  i, curofs, curlen, curlevel, match, curofssize, h, oldh: PtrInt;
+  sp, pInBuf, pOut: PAnsiChar;
+  ofs: cardinal;
+  spb: PByte absolute sp;
+  hash: function(buf: pointer): cardinal;
+begin
+  // 1. fill HTab[] with hashes for all old data
+  {$ifdef CPUINTEL}
+  if cfSSE42 in CpuFeatures then
+    hash := @crc32c32sse42
+  else
+  {$endif CPUINTEL}
+    hash := @hash32prime;
+  FillCharFast(HTab^, SizeOf(HTab^), $ff); // HTab[]=HListMask by default
+  pInBuf := OldBuf;
+  oldh := -1; // force calculate first hash
+  sp := pointer(HList);
+  for i := 0 to OldBufSize - 3 do
+  begin
+    h := hash(pInBuf) and HTabMask;
+    inc(pInBuf);
+    if h = oldh then
+      continue;
+    oldh := h;
+    h := PtrInt(@HTab^[h]); // fast 24-bit data process
+    PCardinal(sp)^ := PCardinal(h)^;
+    PCardinal(h)^ := cardinal(i) or (PCardinal(h)^ and $ff000000);
+    inc(sp, 3);
+  end;
+  // 2. compression init
+  if OldBufSize <= $ffff then
+    curofssize := 2
+  else
+    curofssize := 3;
+  curlen := -1;
+  curofs := 0;
+  pOut := OutBuf + 7;
+  sp := WorkBuf;
+  // 3. handle identical leading bytes
+  match := Comp(OldBuf, NewBuf, Min(OldBufSize, NewBufSize));
+  if match > 2 then
+  begin
+    sp := WriteCurOfs(0, match, curofssize, sp);
+    sp^ := #0;
+    inc(sp);
+    inc(NewBuf, match);
+    dec(NewBufSize, match);
+  end;
+  pInBuf := NewBuf;
+  // 4. main loop: identify longest sequences using hash, and store reference
+  if NewBufSize >= 8 then
+    repeat
+      // hash 4 next bytes from NewBuf, and find longest match in OldBuf
+      ofs := PCardinal(@HTab^[hash(NewBuf) and HTabMask])^ and HListMask;
+      if ofs <> HListMask then
+      begin
+        // brute force search loop of best hash match
+        curlevel := MaxLevel;
+        repeat
+          with PHash128Rec(OldBuf + ofs)^ do
+            // always test 8 bytes at once
+            {$ifdef CPU64}
+            if PHash128Rec(NewBuf)^.Lo = Lo then
+            {$else}
+            if (PHash128Rec(NewBuf)^.c0 = c0) and
+               (PHash128Rec(NewBuf)^.c1 = c1) then
+            {$endif CPU64}
+            begin
+              // test remaining bytes
+              match := Comp(@PHash128Rec(NewBuf)^.c2, @c2,
+                         Min(PtrUInt(OldBufSize) - ofs, NewBufSize) - 8);
+              if match > curlen then
+              begin
+                // found a longer sequence
+                curlen := match;
+                curofs := ofs;
+              end;
+            end;
+          dec(curlevel);
+          ofs := PCardinal(@HList^[ofs])^ and HListMask;
+        until (ofs = HListMask) or
+              (curlevel = 0);
+      end;
+      // curlen = longest sequence length
+      if curlen < 0 then
+      begin
+       // no sequence found -> copy one byte
+        dec(NewBufSize);
+        pOut^ := NewBuf^;
+        inc(NewBuf);
+        inc(pOut);
+        if NewBufSize > 8 then // >=8 may overflow
+          continue
+        else
+          break;
+      end;
+      inc(curlen, 8);
+      sp := WriteCurOfs(curofs, curlen, curofssize, sp);
+      spb := ToVarUInt32(NewBuf - pInBuf, spb);
+      inc(NewBuf, curlen); // continue to search after the sequence
+      dec(NewBufSize, curlen);
+      curlen := -1;
+      pInBuf := NewBuf;
+      if NewBufSize > 8 then // >=8 may overflow
+        continue
+      else
+        break;
+    until false;
+  // 5. write remaining bytes
+  if NewBufSize > 0 then
+  begin
+    MoveFast(NewBuf^, pOut^, NewBufSize);
+    inc(pOut, NewBufSize);
+    inc(NewBuf, NewBufSize);
+  end;
+  sp^ := #0;
+  inc(sp);
+  spb := ToVarUInt32(NewBuf - pInBuf, spb);
+  // 6. write header
+  PInteger(OutBuf)^ := pOut - OutBuf - 7;
+  h := sp - WorkBuf;
+  PInteger(OutBuf + 3)^ := h;
+  OutBuf[6] := AnsiChar(curofssize);
+  // 7. copy commands
+  MoveFast(WorkBuf^, pOut^, h);
+  result := pOut + h;
+end;
+
+function ExtractBuf(GoodCRC: cardinal; p: PAnsiChar;
+  var aUpd, Delta: PAnsiChar; Old: PAnsiChar): TDeltaError;
+var
+  pEnd, buf, upd, src: PAnsiChar;
+  bufsize, datasize, leading, srclen: PtrUInt;
+  curofssize: byte;
+begin
+  // 1. decompression init
+  upd := aUpd;
+  bufsize := PCardinal(p)^ and $00ffffff;
+  inc(p, 3);
+  datasize := PCardinal(p)^ and $00ffffff;
+  inc(p, 3);
+  curofssize := ord(p^);
+  inc(p);
+  buf := p;
+  inc(p, bufsize);
+  pEnd := p + datasize;
+  src := nil;
+  // 2. main loop
+  while p < pEnd do
+  begin
+    // src/srclen = sequence to be copied
+    srclen := FromVarUInt32(PByte(p));
+    if srclen > 0 then
+      if curofssize = 2 then
+      begin
+        src := Old + PWord(p)^;
+        inc(p, 2);
+      end
+      else
+      begin
+        src := Old + PCardinal(p)^ and $00ffffff;
+        inc(p, 3);
+      end;
+    // copy leading bytes
+    leading := FromVarUInt32(PByte(p));
+    if leading <> 0 then
+    begin
+      MoveFast(buf^, upd^, leading);
+      inc(buf, leading);
+      inc(upd, leading);
+    end;
+    // copy sequence
+    if srclen <> 0 then
+    begin
+      if PtrUInt(upd - src) < srclen then
+        MoveByOne(src, upd, srclen)
+      else
+        MoveFast(src^, upd^, srclen);
+      inc(upd, srclen);
+    end;
+  end;
+  // 3. result check
+  Delta := p;
+  if (p = pEnd) and
+     (crc32c(0, aUpd, upd - aUpd) = GoodCRC) then
+    // whole CRC is faster than incremental
+    result := dsSuccess
+  else
+    result := dsCrcExtract;
+  aUpd := upd;
+end;
+
+procedure WriteByte(var P: PAnsiChar; V: byte);
+  {$ifdef HASINLINE}inline;{$endif}
+begin
+  PByte(P)^ := V;
+  inc(P);
+end;
+
+procedure WriteInt(var P: PAnsiChar; V: cardinal);
+  {$ifdef HASINLINE}inline;{$endif}
+begin
+  PCardinal(P)^ := V;
+  inc(P, 4);
+end;
+
+const
+  FLAG_COPIED = 0;
+  FLAG_COMPRESS = 1;
+  FLAG_BEGIN = 2;
+  FLAG_END = 3;
+
+function DeltaCompress(New, Old: PAnsiChar; NewSize, OldSize: integer;
+  out Delta: PAnsiChar; Level, BufSize: integer): integer;
+var
+  HTab, HList: PHTab;
+  d, workbuf: PAnsiChar;
+  db: PByte absolute d;
+  BufRead, OldRead, Trailing, NewSizeSave: PtrInt;
+  bigfile: boolean;
+
+  procedure CreateCopied;
+  begin
+    Getmem(Delta, NewSizeSave + 17);  // 17 = 4*integer + 1*byte
+    d := Delta;
+    db := ToVarUInt32(0, ToVarUInt32(NewSizeSave, db));
+    WriteByte(d, FLAG_COPIED); // block copied flag
+    db := ToVarUInt32(NewSizeSave, db);
+    WriteInt(d, crc32c(0, New, NewSizeSave));
+    MoveFast(New^, d^, NewSizeSave);
+    inc(d, NewSizeSave);
+    result := d - Delta;
+  end;
+
+begin
+  // 1. special cases
+  if (NewSize = OldSize) and
+     mormot.core.base.CompareMem(Old, New, NewSize) then
+  begin
+    Getmem(Delta, 1);
+    Delta^ := '=';
+    result := 1;
+    exit;
+  end;
+  NewSizeSave := NewSize;
+  if OldSize = 0 then
+  begin
+    // Delta from nothing -> direct copy of whole block
+    CreateCopied;
+    exit;
+  end;
+  // 2. compression init
+  bigfile := OldSize > BufSize;
+  if BufSize > NewSize then
+    BufSize := NewSize;
+  if BufSize > HListMask then
+    BufSize := HListMask; // we store offsets with 2..3 bytes -> max 16MB chunk
+  Trailing := 0;
+  Getmem(workbuf, BufSize); // compression temporary buffers
+  Getmem(HList, BufSize * SizeOf({%H-}HList[0]));
+  Getmem(HTab, SizeOf({%H-}HTab^));
+  Getmem(Delta, Max(NewSize, OldSize) + 4096); // Delta size max evalulation
+  try
+    d := Delta;
+    db := ToVarUInt32(NewSize, db); // Destination Size
+    // 3. handle leading and trailing identical bytes (for biggest files)
+    if bigfile then
+    begin
+      // test initial same chars
+      BufRead := Comp(New, Old, Min(NewSize, OldSize));
+      if BufRead > 9 then
+      begin
+        // it happens very often: modification is usually in the middle/end
+        db := ToVarUInt32(BufRead, db); // blockSize = Size BufIdem
+        WriteByte(d, FLAG_BEGIN);
+        WriteInt(d, crc32c(0, New, BufRead));
+        inc(New, BufRead);
+        dec(NewSize, BufRead);
+        inc(Old, BufRead);
+        dec(OldSize, BufRead);
+      end;
+      // test trailing same chars
+      BufRead := CompReverse(New + NewSize - 1, Old + OldSize - 1,
+        Min(NewSize, OldSize));
+      if BufRead > 5 then
+      begin
+        if NewSize = BufRead then
+          dec(BufRead); // avoid block overflow
+        dec(OldSize, BufRead);
+        dec(NewSize, BufRead);
+        Trailing := BufRead;
+      end;
+    end;
+    // 4. main loop
+    repeat
+      BufRead := Min(BufSize, NewSize);
+      dec(NewSize, BufRead);
+      if (BufRead = 0) and
+         (Trailing > 0) then
+      begin
+        db := ToVarUInt32(Trailing, db);
+        WriteByte(d, FLAG_END); // block idem end flag
+        WriteInt(d, crc32c(0, New, Trailing));
+        break;
+      end;
+      OldRead := Min(BufSize, OldSize);
+      dec(OldSize, OldRead);
+      db := ToVarUInt32(OldRead, db);
+      if (BufRead < 4) or
+         (OldRead < 4) or
+         (BufRead shr 2 > OldRead) then
+      begin
+        WriteByte(d, FLAG_COPIED); // block copied flag
+        db := ToVarUInt32(BufRead, db);
+        if BufRead = 0 then
+          break;
+        WriteInt(d, crc32c(0, New, BufRead));
+        MoveFast(New^, d^, BufRead);
+        inc(New, BufRead);
+        inc(d, BufRead);
+      end
+      else
+      begin
+        WriteByte(d, FLAG_COMPRESS); // block compressed flag
+        WriteInt(d, crc32c(0, New, BufRead));
+        WriteInt(d, crc32c(0, Old, OldRead));
+        d := DeltaCompute(New, Old, d, workbuf, BufRead, OldRead, Level, HList, HTab);
+        inc(New, BufRead);
+        inc(Old, OldRead);
+      end;
+    until false;
+  // 5. release temp memory
+  finally
+    result := d - Delta;
+    Freemem(HTab);
+    Freemem(HList);
+    Freemem(workbuf);
+  end;
+  if result >= NewSizeSave + 17 then
+  begin
+    // Delta didn't compress well -> store it (with up to 17 bytes overhead)
+    Freemem(Delta);
+    CreateCopied;
+  end;
+end;
+
+function DeltaCompress(const New, Old: RawByteString;
+  Level, BufSize: integer): RawByteString;
+begin
+  result := DeltaCompress(pointer(New), pointer(Old),
+    length(New), length(Old), Level, BufSize);
+end;
+
+function DeltaCompress(New, Old: PAnsiChar; NewSize, OldSize,
+  Level, BufSize: integer): RawByteString;
+var
+  Delta: PAnsiChar;
+  DeltaLen: integer;
+begin
+  DeltaLen := DeltaCompress(New, Old, NewSize, OldSize, Delta, Level, BufSize);
+  FastSetRawByteString(result, Delta, DeltaLen);
+  Freemem(Delta);
+end;
+
+function DeltaExtract(Delta, Old, New: PAnsiChar): TDeltaError;
+var
+  BufCRC: cardinal;
+  Code: byte;
+  Len, BufRead, OldRead: PtrInt;
+  db: PByte absolute Delta;
+  Upd: PAnsiChar;
+begin
+  result := dsSuccess;
+  Len := FromVarUInt32(db);
+  Upd := New;
+  repeat
+    OldRead := FromVarUInt32(db);
+    Code := db^;
+    inc(db);
+    case Code of
+      FLAG_COPIED:
+        begin
+          // block copied flag - copy new from Delta
+          BufRead := FromVarUInt32(db);
+          if BufRead = 0 then
+            break;
+          if crc32c(0, Delta + 4, BufRead) <> PCardinal(Delta)^ then
+          begin
+            result := dsCrcCopy;
+            exit;
+          end;
+          inc(Delta, 4);
+          MoveFast(Delta^, New^, BufRead);
+          if BufRead >= Len then
+            exit; // if Old=nil -> only copy new
+          inc(Delta, BufRead);
+          inc(New, BufRead);
+        end;
+      FLAG_COMPRESS:
+        begin
+          // block compressed flag - extract Delta from Old
+          BufCRC := PCardinal(Delta)^;
+          inc(Delta, 4);
+          if crc32c(0, Old, OldRead) <> PCardinal(Delta)^ then
+          begin
+            result := dsCrcComp;
+            exit;
+          end;
+          inc(Delta, 4);
+          result := ExtractBuf(BufCRC, Delta, New, Delta, Old);
+          if result <> dsSuccess then
+            exit;
+        end;
+      FLAG_BEGIN:
+        begin
+          // block idem begin flag
+          if crc32c(0, Old, OldRead) <> PCardinal(Delta)^ then
+          begin
+            result := dsCrcBegin;
+            exit;
+          end;
+          inc(Delta, 4);
+          MoveFast(Old^, New^, OldRead);
+          inc(New, OldRead);
+        end;
+      FLAG_END:
+        begin
+          // block idem end flag
+          if crc32c(0, Old, OldRead) <> PCardinal(Delta)^ then
+            result := dsCrcEnd;
+          MoveFast(Old^, New^, OldRead);
+          inc(New, OldRead);
+          break;
+        end;
+    else
+      begin
+        result := dsFlag;
+        exit;
+      end;
+    end; // Case Code of
+    inc(Old, OldRead);
+  until false;
+  if New - Upd <> Len then
+    result := dsLen;
+end;
+
+function DeltaExtract(const Delta, Old: RawByteString;
+  out New: RawByteString): TDeltaError;
+begin
+  if (Delta = '') or
+     (Delta = '=') then
+  begin
+    New := Old;
+    result := dsSuccess;
+  end
+  else
+  begin
+    SetLength(New, DeltaExtractSize(pointer(Delta)));
+    result := DeltaExtract(pointer(Delta), pointer(Old), pointer(New));
+  end;
+end;
+
+function DeltaExtractSize(const Delta: RawByteString): integer;
+begin
+  result := DeltaExtractSize(pointer(Delta));
+end;
+
+function DeltaExtractSize(Delta: PAnsiChar): integer;
+begin
+  if Delta = nil then
+    result := 0
+  else
+    result := FromVarUInt32(PByte(Delta));
+end;
+
+function ToText(err: TDeltaError): PShortString;
+begin
+  result := GetEnumName(TypeInfo(TDeltaError), ord(err));
+end;
+
+
+{ ****************** TDynArray Low-Level Binary Search }
+
+function SimpleDynArrayLoadFrom(Source: PAnsiChar; aTypeInfo: PRttiInfo;
+  out Count, ElemSize: PtrInt): pointer;
+var
+  Hash: PCardinalArray absolute Source;
+  iteminfo: PRttiInfo;
+begin
+  result := nil;
+  if (aTypeInfo = nil) or
+     (aTypeInfo^.Kind <> rkDynArray) then
+    exit;
+  iteminfo := aTypeInfo^.DynArrayItemType(ElemSize);
+  if (iteminfo <> nil) or
+     (Source = nil) or
+     // (Source[0] <> AnsiChar(ElemSize)) or mORMot 2 stores elemsize=0
+     (Source[1] <> #0) then
+    exit; // invalid type information or Source content
+  inc(Source,2);
+  Count := FromVarUInt32(PByte(Source)); // dynamic array count
+  if Count <> 0 then
+    result := @Hash[1]; // returns valid Source content
+end;
+
+function IntegerDynArrayLoadFrom(Source: PAnsiChar;
+  var Count: integer): PIntegerArray;
+var
+  Hash: PCardinalArray absolute Source;
+begin
+  result := nil;
+  if (Source = nil) or
+     // (Source[0] <> #4) or mORMot 2 stores elemsize=0
+     (Source[1] <> #0) then
+    exit; // invalid Source content
+  inc(Source, 2);
+  Count := FromVarUInt32(PByte(Source)); // dynamic array count
+  if Count <> 0 then
+    result := @Hash[1]; // returns valid Source content
+end;
+
+function RawUtf8DynArrayLoadFromContains(Source: PAnsiChar;
+  Value: PUtf8Char; ValueLen: PtrInt; CaseSensitive: boolean): PtrInt;
+var
+  Count, Len: PtrInt;
+begin
+  if (Value = nil) or
+     (ValueLen = 0) or
+     (Source = nil) then
+     // (Source[0] <> AnsiChar(SizeOf(PtrInt))) mORMot 2 stores elemsize=0
+     // {$ifdef ISDELPHI} or (Source[1] <> AnsiChar(rkLString)){$endif}
+  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;
+
+
+{ TDynArrayLoadFrom }
+
+function TDynArrayLoadFrom.Init(ArrayTypeInfo: PRttiInfo; Source: PAnsiChar;
+  SourceMaxLen: PtrInt): boolean;
+begin
+  result := false;
+  Count := 0;
+  Current := 0;
+  Reader.Init(Source, SourceMaxLen);
+  ArrayRtti := Rtti.RegisterType(ArrayTypeInfo);
+  if (ArrayRtti.Parser <> ptDynArray) or
+     Reader.EOF then
+    exit;
+  if ArrayRtti.Cache.ItemInfo = nil then
+    ArrayLoad := nil
+  else
+    ArrayLoad := RTTI_BINARYLOAD[ArrayRtti.Cache.ItemInfo^.Kind];
+  Count := DynArrayLoadHeader(Reader, ArrayRtti.Info, ArrayRtti.Cache.ItemInfo);
+  result := true;
+end;
+
+function TDynArrayLoadFrom.Init(ArrayTypeInfo: PRttiInfo;
+  const Source: RawByteString): boolean;
+begin
+  result := Init(ArrayTypeInfo, pointer(Source), length(Source));
+end;
+
+function TDynArrayLoadFrom.Step(Item: pointer): boolean;
+begin
+  if (Current < Count) and
+     not Reader.EOF then
+  begin
+    if Assigned(ArrayLoad) then
+      ArrayLoad(Item, Reader, ArrayRtti.Cache.ItemInfo)
+    else
+      Reader.Copy(Item, ArrayRtti.Cache.ItemSize);
+    inc(Current);
+    result := true;
+  end
+  else
+    result := false;
+end;
+
+function TDynArrayLoadFrom.FirstField(Field: pointer): boolean;
+var
+  load: TRttiBinaryLoad;
+  info: PRttiInfo;
+  noiteration: TFastReader;
+begin
+  if (Current < Count) and
+     not Reader.EOF then
+  begin
+    info := PT_INFO[ArrayRtti.ArrayFirstField];
+    if info <> nil then
+    begin
+      load := RTTI_BINARYLOAD[info^.Kind];
+      if Assigned(load) then
+      begin
+        noiteration := Reader;
+        load(Field, noiteration, info);
+        result := true;
+        exit;
+      end;
+    end;
+  end;
+  result := false;
+end;
+
+
+
+{ ****************** TSynFilter and TSynValidate Processing Classes }
+
+function IsValidIP4Address(P: PUtf8Char): boolean;
+var
+  ndot: PtrInt;
+  V: PtrUInt;
+begin
+  result := false;
+  if (P = nil) or
+     not (P^ in ['0'..'9']) then
+    exit;
+  V := 0;
+  ndot := 0;
+  repeat
+    case P^ of
+      #0:
+        break;
+      '.':
+        if (P[-1] = '.') or
+           (V > 255) then
+          exit
+        else
+        begin
+          inc(ndot);
+          V := 0;
+        end;
+      '0'..'9':
+        V := (V * 10) + ord(P^) - 48;
+    else
+      exit;
+    end;
+    inc(P);
+  until false;
+  if (ndot = 3) and
+     (V <= 255) and
+     (P[-1] <> '.') then
+    result := true;
+end;
+
+function IsValidEmail(P: PUtf8Char): boolean;
+// Initial Author: Ernesto D'Spirito - UTF-8 version by AB
+// http://www.howtodothings.com/computers/a1169-validating-email-addresses-in-delphi.html
+const
+  // Valid characters in an "atom"
+  atom_chars: TSynAnsicharSet = [#33..#255] -
+    ['(', ')', '<', '>', '@', ',', ';', ':', '\', '/', '"', '.', '[', ']', #127];
+  // Valid characters in a "quoted-string"
+  quoted_string_chars: TSynAnsicharSet =
+    [#0..#255] - ['"', #13, '\'];
+  // Valid characters in a subdomain
+  letters_digits: TSynAnsicharSet =
+    ['0'..'9', 'A'..'Z', 'a'..'z'];
+type
+  States = (
+    STATE_BEGIN,
+    STATE_ATOM,
+    STATE_QTEXT,
+    STATE_QCHAR,
+    STATE_QUOTE,
+    STATE_LOCAL_PERIOD,
+    STATE_EXPECTING_SUBDOMAIN,
+    STATE_SUBDOMAIN,
+    STATE_HYPHEN);
+var
+  State: States;
+  subdomains: integer;
+  c: AnsiChar;
+  ch: PtrInt;
+begin
+  State := STATE_BEGIN;
+  subdomains := 1;
+  if P <> nil then
+    repeat
+      ch := ord(P^);
+      if ch and $80 = 0 then
+        inc(P)
+      else
+        ch := UTF8_TABLE.GetHighUtf8Ucs4(P);
+      if (ch <= 255) and
+         (WinAnsiConvert.AnsiToWide[ch] <= 255) then
+        // convert into WinAnsi char
+        c := AnsiChar(ch)
+      else
+        // invalid char
+        c := #127;
+      case State of
+        STATE_BEGIN:
+          if c in atom_chars then
+            State := STATE_ATOM
+          else if c = '"' then
+            State := STATE_QTEXT
+          else
+            break;
+        STATE_ATOM:
+          if c = '@' then
+            State := STATE_EXPECTING_SUBDOMAIN
+          else if c = '.' then
+            State := STATE_LOCAL_PERIOD
+          else if not (c in atom_chars) then
+            break;
+        STATE_QTEXT:
+          if c = '\' then
+            State := STATE_QCHAR
+          else if c = '"' then
+            State := STATE_QUOTE
+          else if not (c in quoted_string_chars) then
+            break;
+        STATE_QCHAR:
+          State := STATE_QTEXT;
+        STATE_QUOTE:
+          if c = '@' then
+            State := STATE_EXPECTING_SUBDOMAIN
+          else if c = '.' then
+            State := STATE_LOCAL_PERIOD
+          else
+            break;
+        STATE_LOCAL_PERIOD:
+          if c in atom_chars then
+            State := STATE_ATOM
+          else if c = '"' then
+            State := STATE_QTEXT
+          else
+            break;
+        STATE_EXPECTING_SUBDOMAIN:
+          if c in letters_digits then
+            State := STATE_SUBDOMAIN
+          else
+            break;
+        STATE_SUBDOMAIN:
+          if c = '.' then
+          begin
+            inc(subdomains);
+            State := STATE_EXPECTING_SUBDOMAIN
+          end
+          else if c = '-' then
+            State := STATE_HYPHEN
+          else if not (c in letters_digits) then
+            break;
+        STATE_HYPHEN:
+          if c in letters_digits then
+            State := STATE_SUBDOMAIN
+          else if c <> '-' then
+            break;
+      end;
+      if P^ = #0 then
+      begin
+        P := nil;
+        break;
+      end;
+    until false;
+  result := (State = STATE_SUBDOMAIN) and
+            (subdomains >= 2);
+end;
+
+
+{ TSynFilterOrValidate }
+
+constructor TSynFilterOrValidate.Create(const aParameters: RawUtf8);
+begin
+  inherited Create;
+  SetParameters(aParameters); // should parse the JSON-encoded parameters
+end;
+
+constructor TSynFilterOrValidate.CreateUtf8(const Format: RawUtf8; const Args,
+  Params: array of const);
+begin
+  Create(FormatJson(Format, Args, Params));
+end;
+
+procedure TSynFilterOrValidate.SetParameters(const value: RawUtf8);
+begin
+  fParameters := value;
+end;
+
+function TSynFilterOrValidate.AddOnce(var aObjArray: TSynFilterOrValidateObjArray;
+  aFreeIfAlreadyThere: boolean): TSynFilterOrValidate;
+var
+  i: integer;
+begin
+  if self <> nil then
+  begin
+    for i := 0 to length(aObjArray) - 1 do
+      if (PPointer(aObjArray[i])^ = PPointer(self)^) and
+         (aObjArray[i].fParameters = fParameters) then
+      begin
+        if aFreeIfAlreadyThere then
+          Free;
+        result := aObjArray[i];
+        exit;
+      end;
+    ObjArrayAdd(aObjArray, self);
+  end;
+  result := self;
+end;
+
+
+{ TSynFilterUpperCase }
+
+procedure TSynFilterUpperCase.Process(aFieldIndex: integer; var value: RawUtf8);
+begin
+  value := mormot.core.unicode.UpperCase(value);
+end;
+
+
+{ TSynFilterUpperCaseU }
+
+procedure TSynFilterUpperCaseU.Process(aFieldIndex: integer; var value: RawUtf8);
+begin
+  value := UpperCaseU(value);
+end;
+
+
+{ TSynFilterLowerCase }
+
+procedure TSynFilterLowerCase.Process(aFieldIndex: integer; var value: RawUtf8);
+begin
+  value := LowerCase(value);
+end;
+
+
+{ TSynFilterLowerCaseU }
+
+procedure TSynFilterLowerCaseU.Process(aFieldIndex: integer; var value: RawUtf8);
+begin
+  value := LowerCaseU(value);
+end;
+
+
+{ TSynFilterTrim }
+
+procedure TSynFilterTrim.Process(aFieldIndex: integer; var value: RawUtf8);
+begin
+  TrimSelf(value);
+end;
+
+
+{ TSynFilterTruncate}
+
+procedure TSynFilterTruncate.SetParameters(const value: RawUtf8);
+var
+  V: array[0..1] of TValuePUtf8Char;
+  tmp: TSynTempBuffer;
+begin
+  tmp.Init(value);
+  JsonDecode(tmp.buf, [
+    'MaxLength', // 0
+    'Utf8Length' // 1
+    ], @V);
+  fMaxLength := V[0].ToCardinal(0);
+  fUtf8Length := V[1].ToBoolean;
+  tmp.Done;
+end;
+
+procedure TSynFilterTruncate.Process(aFieldIndex: integer; var value: RawUtf8);
+begin
+  if fMaxLength - 1 < cardinal(maxInt) then
+    if fUtf8Length then
+      Utf8TruncateToLength(value, fMaxLength)
+    else
+      Utf8TruncateToUnicodeLength(value, fMaxLength);
+end;
+
+
+{ TSynValidateIPAddress }
+
+function TSynValidateIPAddress.Process(aFieldIndex: integer; const value:
+  RawUtf8; var ErrorMsg: string): boolean;
+begin
+  result := IsValidIP4Address(pointer(value));
+  if not result then
+    ErrorMsg := Format(sInvalidIPAddress, [Utf8ToString(value)]);
+end;
+
+
+{ TSynValidateEmail }
+
+function TSynValidateEmail.Process(aFieldIndex: integer; const value: RawUtf8;
+  var ErrorMsg: string): boolean;
+var
+  TLD, DOM: RawUtf8;
+  i: integer;
+const
+  TopLevelTLD: array[0..20] of PUtf8Char = (
+    // see http://en.wikipedia.org/wiki/List_of_Internet_top-level_domains
+    'aero', 'asia', 'biz', 'cat', 'com', 'coop', 'edu', 'gov', 'info', 'int',
+    'jobs', 'mil', 'mobi', 'museum', 'name', 'net', 'org', 'pro', 'site', 'tel',
+    'travel'); // no xxx !
+begin
+  if IsValidEmail(pointer(value)) then
+    repeat
+      DOM := lowercase(copy(value, PosExChar('@', value) + 1, 100));
+      if length(DOM) > 63 then
+        break; // exceeded 63-character limit of a DNS name
+      if (ForbiddenDomains <> '') and
+         CsvContains(ForbiddenDomains, DOM) then
+        break;
+      i := length(value);
+      while (i > 0) and
+            (value[i] <> '.') do
+        dec(i);
+      TLD := lowercase(copy(value, i + 1, 100));
+      if (AllowedTLD <> '') and
+         not CsvContains(AllowedTLD, TLD) then
+        break;
+      if (ForbiddenTLD <> '') and
+         CsvContains(ForbiddenTLD, TLD) then
+        break;
+      if not fAnyTLD then
+        if FastFindPUtf8CharSorted(@TopLevelTLD, high(TopLevelTLD), pointer(TLD)) < 0 then
+          if length(TLD) <> 2 then
+            break; // assume a two chars string is a ISO 3166-1 alpha-2 code
+      result := true;
+      exit;
+    until true;
+  ErrorMsg := Format(sInvalidEmailAddress, [Utf8ToString(value)]);
+  result := false;
+end;
+
+procedure TSynValidateEmail.SetParameters(const value: RawUtf8);
+var
+  V: array[0..3] of TValuePUtf8Char;
+  tmp: TSynTempBuffer;
+begin
+  inherited;
+  tmp.Init(value);
+  JsonDecode(tmp.buf, [
+    'AllowedTLD',        // 0
+    'ForbiddenTLD',      // 1
+    'ForbiddenDomains',  // 2
+    'AnyTLD'             // 3
+    ], @V);
+  LowerCaseCopy(V[0].Text, V[0].Len, fAllowedTLD);
+  LowerCaseCopy(V[1].Text, V[1].Len, fForbiddenTLD);
+  LowerCaseCopy(V[2].Text, V[2].Len, fForbiddenDomains);
+  AnyTLD := V[3].ToBoolean;
+  tmp.Done;
+end;
+
+
+{ TSynValidatePattern }
+
+procedure TSynValidatePattern.SetParameters(const Value: RawUtf8);
+begin
+  inherited SetParameters(Value);
+  fMatch.Prepare(Value, ClassType = TSynValidatePatternI, {reuse=}true);
+end;
+
+function TSynValidatePattern.Process(aFieldIndex: integer; const value: RawUtf8;
+  var ErrorMsg: string): boolean;
+
+  procedure SetErrorMsg;
+  begin
+    ErrorMsg := Format(sInvalidPattern, [Utf8ToString(value)]);
+  end;
+
+begin
+  result := fMatch.Match(value);
+  if not result then
+    SetErrorMsg;
+end;
+
+
+{ TSynValidateNonVoidText }
+
+function Character01n(n: integer): string;
+begin
+  if n < 0 then
+    n := 0
+  else if n > 1 then
+    n := 2;
+  result := GetCsvItemString(pointer(string(sCharacter01n)), n);
+end;
+
+procedure InvalidTextLengthMin(min: integer; var result: string);
+begin
+  result := Format(sInvalidTextLengthMin, [min, Character01n(min)]);
+end;
+
+function TSynValidateNonVoidText.Process(aFieldIndex: integer; const value:
+  RawUtf8; var ErrorMsg: string): boolean;
+begin
+  if value = '' then
+  begin
+    InvalidTextLengthMin(1, ErrorMsg);
+    result := false;
+  end
+  else
+    result := true;
+end;
+
+
+{ TSynValidateText }
+
+procedure TSynValidateText.SetErrorMsg(fPropsIndex, InvalidTextIndex, MainIndex:
+  integer; var result: string);
+var
+  P: PChar;
+begin
+  P := pointer(string(sInvalidTextChar));
+  result := GetCsvItemString(P, MainIndex);
+  if fPropsIndex > 0 then
+    result := Format(result, [fProps[fPropsIndex],
+      GetCsvItemString(P, InvalidTextIndex), Character01n(fProps[fPropsIndex])]);
+end;
+
+function TSynValidateText.Process(aFieldIndex: integer; const value: RawUtf8;
+  var ErrorMsg: string): boolean;
+var
+  i, L: cardinal;
+  Min: array[2..7] of cardinal;
+begin
+  result := false;
+  if fUtf8Length then
+    L := length(value)
+  else
+    L := Utf8ToUnicodeLength(pointer(value));
+  if L < MinLength then
+    InvalidTextLengthMin(MinLength, ErrorMsg)
+  else if L > MaxLength then
+    ErrorMsg := Format(sInvalidTextLengthMax, [MaxLength, Character01n(MaxLength)])
+  else
+  begin
+    FillCharFast(Min, SizeOf(Min), 0);
+    L := length(value);
+    for i := 1 to L do
+      case value[i] of
+        ' ':
+          inc(Min[7]);
+        'a'..'z':
+          begin
+            inc(Min[2]);
+            inc(Min[5]);
+          end;
+        'A'..'Z':
+          begin
+            inc(Min[2]);
+            inc(Min[6]);
+          end;
+        '0'..'9':
+          inc(Min[3]);
+        '_', '!', ';', '.', ',', '/', ':', '?', '%', '$', '=', '"', '#', '@',
+        '(', ')', '{', '}', '+', '''', '-', '*':
+          inc(Min[4]);
+      end;
+    for i := 2 to 7 do
+      if Min[i] < fProps[i] then
+      begin
+        SetErrorMsg(i, i, 0, ErrorMsg);
+        exit;
+      end
+      else if Min[i] > fProps[i + 8] then
+      begin
+        SetErrorMsg(i + 8, i, 1, ErrorMsg);
+        exit;
+      end;
+    if value <> '' then
+    begin
+      if MaxLeftTrimCount < cardinal(maxInt) then
+      begin
+        // if MaxLeftTrimCount is set, check against Value
+        i := 0;
+        while (i < L) and
+              (value[i + 1] = ' ') do
+          inc(i);
+        if i > MaxLeftTrimCount then
+        begin
+          SetErrorMsg(0, 0, 8, ErrorMsg);
+          exit;
+        end;
+      end;
+      if MaxRightTrimCount < cardinal(maxInt) then
+      begin
+        // if MaxRightTrimCount is set, check against Value
+        i := 0;
+        while (i < L) and
+              (value[L - i] = ' ') do
+          dec(i);
+        if i > MaxRightTrimCount then
+        begin
+          SetErrorMsg(0, 0, 9, ErrorMsg);
+          exit;
+        end;
+      end;
+    end;
+    result := true;
+  end;
+end;
+
+procedure TSynValidateText.SetParameters(const value: RawUtf8);
+var
+  V: array[0..high(TSynValidateTextProps) + {Utf8Length} 1] of TValuePUtf8Char;
+  i: PtrInt;
+  tmp: TSynTempBuffer;
+const
+  DEFAULT: TSynValidateTextProps = (
+    1,       //  MinLength
+    maxInt,  //  MaxLength
+    0,       //  MinAlphaCount
+    0,       //  MinDigitCount
+    0,       //  MinPunctCount
+    0,       //  MinLowerCount
+    0,       //  MinUpperCount
+    0,       //  MinSpaceCount
+    maxInt,  //  MaxLeftTrimCount
+    maxInt,  //  MaxRightTrimCount
+    maxInt,  //  MaxAlphaCount
+    maxInt,  //  MaxDigitCount
+    maxInt,  //  MaxPunctCount
+    maxInt,  //  MaxLowerCount
+    maxInt,  //  MaxUpperCount
+    maxInt); //  MaxSpaceCount
+begin
+  if (MinLength = 0) and
+     (MaxLength = 0) then  // if not previously set
+    fProps := DEFAULT;
+  inherited SetParameters(value);
+  if value = '' then
+    exit;
+  tmp.Init(value);
+  try
+    JsonDecode(tmp.buf, [
+      'MinLength',
+      'MaxLength',
+      'MinAlphaCount',
+      'MinDigitCount',
+      'MinPunctCount',
+      'MinLowerCount',
+      'MinUpperCount',
+      'MinSpaceCount',
+      'MaxLeftTrimCount',
+      'MaxRightTrimCount',
+      'MaxAlphaCount',
+      'MaxDigitCount',
+      'MaxPunctCount',
+      'MaxLowerCount',
+      'MaxUpperCount',
+      'MaxSpaceCount',
+      'Utf8Length'], @V);
+    for i := 0 to high(fProps) do
+      fProps[i] := V[i].ToCardinal(fProps[i]);
+    with V[high(V)] do
+      fUtf8Length := ToBoolean;
+  finally
+    tmp.Done;
+  end;
+end;
+
+
+{ TSynValidatePassWord }
+
+procedure TSynValidatePassWord.SetParameters(const value: RawUtf8);
+const
+  DEFAULT: TSynValidateTextProps = (
+    5,        //  MinLength
+    20,       //  MaxLength
+    1,        //  MinAlphaCount
+    1,        //  MinDigitCount
+    1,        //  MinPunctCount
+    1,        //  MinLowerCount
+    1,        //  MinUpperCount
+    0,        //  MinSpaceCount
+    maxInt,   //  MaxLeftTrimCount
+    maxInt,   //  MaxRightTrimCount
+    maxInt,   //  MaxAlphaCount
+    maxInt,   //  MaxDigitCount
+    maxInt,   //  MaxPunctCount
+    maxInt,   //  MaxLowerCount
+    maxInt,   //  MaxUpperCount
+    0);       //  MaxSpaceCount
+begin
+  // set default values for validating a strong password
+  fProps := DEFAULT;
+  fUtf8Length := false;
+  // read custom parameters
+  inherited;
+end;
+
+
+
+{ ***************** Cross-Platform TSynTimeZone Time Zones }
+
+{ TTimeZoneData }
+
+function TTimeZoneData.GetTziFor(year: integer): PTimeZoneInfo;
+var
+  i, last: PtrInt;
+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 < dyn[i].year then
+        begin
+          result := @dyn[i - 1].tzi;
+          exit;
+        end;
+      result := @tzi; // should never happen, but makes compiler happy
+    end;
+  end;
+end;
+
+
+{ TTimeZoneInformation }
+
+constructor TSynTimeZone.Create;
+begin
+  fZones.InitSpecific(TypeInfo(TTimeZoneDataDynArray),
+    fZone, ptRawUtf8, @fZoneCount);
+end;
+
+constructor TSynTimeZone.CreateDefault(dummycpp: integer);
+begin
+  Create;
+  {$ifdef OSWINDOWS}
+  LoadFromRegistry;
+  {$else}
+  LoadFromFile;
+  if fZoneCount = 0 then
+    LoadFromResource; // if no .tz file is available, try if bound to executable
+  {$endif OSWINDOWS}
+end;
+
+destructor TSynTimeZone.Destroy;
+begin
+  inherited Destroy;
+  fIds.Free;
+  fDisplays.Free;
+end;
+
+var
+  SharedSynTimeZone: TSynTimeZone;
+
+class function TSynTimeZone.Default: TSynTimeZone;
+begin
+  if SharedSynTimeZone = nil then
+  begin
+    GlobalLock; // RegisterGlobalShutdownRelease() will use it anyway
+    try
+      if SharedSynTimeZone = nil then
+        SharedSynTimeZone :=
+          RegisterGlobalShutdownRelease(TSynTimeZone.CreateDefault);
+    finally
+      GlobalUnLock;
+    end;
+  end;
+  result := SharedSynTimeZone;
+end;
+
+function TSynTimeZone.SaveToBuffer: RawByteString;
+begin
+  fSafe.ReadLock;
+  try
+    result := AlgoSynLZ.Compress(fZones.SaveTo);
+  finally
+    fSafe.ReadUnLock;
+  end;
+end;
+
+procedure TSynTimeZone.SaveToFile(const FileName: TFileName);
+var
+  FN: TFileName;
+begin
+  if FileName = '' then
+    FN := ChangeFileExt(Executable.ProgramFileName, '.tz')
+  else
+    FN := FileName;
+  FileFromString(SaveToBuffer, FN);
+end;
+
+procedure TSynTimeZone.LoadFromBuffer(const Buffer: RawByteString);
+begin
+  if Buffer = '' then
+   exit;
+  fSafe.WriteLock;
+  try
+    fZones.LoadFromBinary(AlgoSynLZ.Decompress(Buffer));
+    fZones.ForceReHash;
+    FreeAndNil(fIds);
+    FreeAndNil(fDisplays);
+  finally
+    fSafe.WriteUnLock;
+  end;
+end;
+
+procedure TSynTimeZone.LoadFromFile(const FileName: TFileName);
+var
+  FN: TFileName;
+begin
+  if FileName = '' then
+    FN := ChangeFileExt(Executable.ProgramFileName, '.tz')
+  else
+    FN := FileName;
+  LoadFromBuffer(StringFromFile(FN));
+end;
+
+procedure TSynTimeZone.LoadFromResource(Instance: TLibHandle);
+var
+  buf: RawByteString;
+begin
+  ResourceToRawByteString(ClassName, PChar(10), buf, Instance);
+  if buf <> '' then
+    LoadFromBuffer(buf);
+end;
+
+{$ifdef OSWINDOWS}
+
+procedure TSynTimeZone.LoadFromRegistry;
+const
+  REGKEY = 'Software\Microsoft\Windows NT\CurrentVersion\Time Zones\';
+var
+  reg: TWinRegistry;
+  keys: TRawUtf8DynArray;
+  i, first, last, year, n: integer;
+  item: TTimeZoneData;
+begin
+  fSafe.WriteLock;
+  try
+    fZones.Clear;
+    if reg.ReadOpen(wrLocalMachine, REGKEY) then
+      keys := reg.ReadEnumEntries
+    else
+      keys := nil; // make Delphi 6 happy
+    n := length(keys);
+    fZones.Capacity := n;
+    for i := 0 to n - 1 do
+    begin
+      Finalize(item);
+      FillcharFast(item.tzi, SizeOf(item.tzi), 0);
+      if reg.ReadOpen(wrLocalMachine, REGKEY + keys[i], {reopen=}true) then
+      begin
+        item.id := keys[i]; // registry keys are genuine by definition
+        item.display := reg.ReadString('Display');
+        reg.ReadBuffer('TZI', @item.tzi, SizeOf(item.tzi));
+        if reg.ReadOpen(wrLocalMachine, REGKEY + keys[i] + '\Dynamic DST', true) then
+        begin
+          // warning: never defined on XP/2003, and not for all entries
+          first := reg.ReadDword('FirstEntry');
+          last  := reg.ReadDword('LastEntry');
+          if (first > 0) and
+             (last >= first) then
+          begin
+            n := 0;
+            SetLength(item.dyn, last - first + 1);
+            for year := first to last do
+              if reg.ReadBuffer(Utf8ToSynUnicode(UInt32ToUtf8(year)),
+                @item.dyn[n].tzi, SizeOf(TTimeZoneInfo)) then
+              begin
+                item.dyn[n].year := year;
+                inc(n);
+              end;
+            SetLength(item.dyn, n);
+          end;
+        end;
+        fZones.Add(item);
+      end;
+    end;
+    reg.Close;
+    fZones.ForceReHash;
+    FreeAndNil(fIds);
+    FreeAndNil(fDisplays);
+  finally
+    fSafe.WriteUnLock;
+  end;
+end;
+
+{$endif OSWINDOWS}
+
+function TSynTimeZone.LockedFindZoneIndex(const TzId: TTimeZoneID): PtrInt;
+begin
+  if TzId = '' then
+    result := -1
+  else
+  begin
+    if TzId = fLastZone then
+      result := fLastIndex
+    else
+    begin
+      result := fZones.FindHashed(TzId);
+      fLastZone := TzId;
+      flastIndex := result;
+    end;
+  end;
+end;
+
+function TSynTimeZone.GetDisplay(const TzId: TTimeZoneID): RawUtf8;
+var
+  ndx: PtrInt;
+begin
+  fSafe.ReadLock;
+  ndx := LockedFindZoneIndex(TzId);
+  if ndx < 0 then
+    if TzId = 'UTC' then // e.g. on XP
+      result := TzId
+    else
+      result := ''
+  else
+    result := fZone[ndx].display;
+  fSafe.ReadUnLock;
+end;
+
+function TSynTimeZone.GetBiasForDateTime(const Value: TDateTime;
+  const TzId: TTimeZoneID; out Bias: integer; out HaveDaylight: boolean;
+  ValueIsUtc: boolean): boolean;
+var
+  ndx: PtrInt;
+  d: TSynSystemTime;
+  tzi: PTimeZoneInfo;
+  std, dlt: TDateTime;
+begin
+  fSafe.ReadLock;
+  try
+    ndx := LockedFindZoneIndex(TzId);
+    if ndx < 0 then
+    begin
+      Bias := 0;
+      HaveDaylight := false;
+      result := TzId = 'UTC'; // e.g. on XP
+      exit;
+    end;
+    d.FromDate(Value); // faster than DecodeDate
+    tzi := fZone[ndx].GetTziFor(d.Year);
+    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(d.Year);
+      dlt := tzi.change_time_dlt.EncodeForTimeChange(d.Year);
+      if ValueIsUtc then
+      begin
+        // STD shifts by the DLT bias to convert to UTC
+        std := ((std * MinsPerDay) + tzi.Bias + tzi.bias_dlt) / MinsPerDay;
+        // DLT shifts by the STD bias
+        dlt := ((dlt * MinsPerDay) + tzi.Bias + tzi.bias_std) / MinsPerDay;
+      end;
+      if std < dlt then
+        if (std <= Value) and
+           (Value < dlt) then
+          Bias := tzi.Bias + tzi.bias_std
+        else
+          Bias := tzi.Bias + tzi.bias_dlt
+      else if (dlt <= Value) and
+              (Value < std) then
+        Bias := tzi.Bias + tzi.bias_dlt
+      else
+        Bias := tzi.Bias + tzi.bias_std;
+    end;
+    result := true;
+  finally
+    fSafe.ReadUnLock;
+  end;
+end;
+
+function TSynTimeZone.UtcToLocal(const UtcDateTime: TDateTime;
+  const TzId: TTimeZoneID): TDateTime;
+var
+  Bias: integer;
+  HaveDaylight: boolean;
+begin
+  if (self = nil) or
+     (TzId = '') then
+    result := UtcDateTime
+  else
+  begin
+    GetBiasForDateTime(UtcDateTime, TzId, Bias, HaveDaylight, {fromutc=}true);
+    result := ((UtcDateTime * MinsPerDay) - Bias) / MinsPerDay;
+  end;
+end;
+
+function TSynTimeZone.NowToLocal(const TzId: TTimeZoneID): TDateTime;
+begin
+  result := UtcToLocal(NowUtc, TzId);
+end;
+
+function TSynTimeZone.LocalToUtc(const LocalDateTime: TDateTime;
+  const TzID: TTimeZoneID): TDateTime;
+var
+  Bias: integer;
+  HaveDaylight: boolean;
+begin
+  if (self = nil) or
+     (TzID = '') then
+    result := LocalDateTime
+  else
+  begin
+    GetBiasForDateTime(LocalDateTime, TzID, Bias, HaveDaylight);
+    result := ((LocalDateTime * MinsPerDay) + Bias) / MinsPerDay;
+  end;
+end;
+
+function TSynTimeZone.Ids: TStrings;
+var
+  i: PtrInt;
+begin
+  if fIDs = nil then
+  begin
+    fIDs := TStringList.Create;
+    fSafe.ReadLock;
+    for i := 0 to length(fZone) - 1 do
+      fIDs.Add(Utf8ToString(RawUtf8(fZone[i].id)));
+    fSafe.ReadUnLock;
+  end;
+  result := fIDs;
+end;
+
+function TSynTimeZone.Displays: TStrings;
+var
+  i: PtrInt;
+begin
+  if fDisplays = nil then
+  begin
+    fDisplays := TStringList.Create;
+    fSafe.ReadLock;
+    for i := 0 to length(fZone) - 1 do
+      fDisplays.Add(Utf8ToString(fZone[i].display));
+    fSafe.ReadUnLock;
+  end;
+  result := fDisplays;
+end;
+
+
+function GetBiasForDateTime(const Value: TDateTime; const TzId: TTimeZoneID;
+  out Bias: integer; out HaveDaylight: boolean; ValueIsUtc: boolean): boolean;
+begin
+  result := TSynTimeZone.Default.
+    GetBiasForDateTime(Value, TzId, Bias, HaveDaylight, ValueIsUtc);
+end;
+
+function GetDisplay(const TzId: TTimeZoneID): RawUtf8;
+begin
+  result := TSynTimeZone.Default.GetDisplay(TzId);
+end;
+
+function UtcToLocal(const UtcDateTime: TDateTime; const TzId: TTimeZoneID): TDateTime;
+begin
+  result := TSynTimeZone.Default.UtcToLocal(UtcDateTime, TzId);
+end;
+
+function NowToLocal(const TzId: TTimeZoneID): TDateTime;
+begin
+  result := TSynTimeZone.Default.NowToLocal(TzId);
+end;
+
+function LocalToUtc(const LocalDateTime: TDateTime; const TzID: TTimeZoneID): TDateTime;
+begin
+  result := TSynTimeZone.Default.LocalToUtc(LocalDateTime, TzId);
+end;
+
+
+end.
diff --git a/lib/dmustache/mormot.core.text.pas b/lib/dmustache/mormot.core.text.pas
new file mode 100644
index 00000000..7d496157
--- /dev/null
+++ b/lib/dmustache/mormot.core.text.pas
@@ -0,0 +1,10325 @@
+/// Framework Core Low-Level Text Processing
+// - this unit is a part of the Open Source Synopse mORMot framework 2,
+// licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+unit mormot.core.text;
+
+{
+  *****************************************************************************
+
+   Text Processing functions shared by all framework units
+    - CSV-like Iterations over Text Buffers
+    - TTextWriter parent class for Text Generation
+    - Numbers (integers or floats) and Variants to Text Conversion
+    - Text Formatting functions
+    - Resource and Time Functions
+    - ESynException class
+    - Hexadecimal Text And Binary Conversion
+
+  *****************************************************************************
+}
+
+interface
+
+{$I mormot.defines.inc}
+
+uses
+  classes,
+  contnrs,
+  types,
+  sysutils,
+  mormot.core.base,
+  mormot.core.os,
+  mormot.core.unicode;
+
+
+
+{ ************ CSV-like Iterations over Text Buffers }
+
+/// return true if IdemPChar(source,searchUp) matches, 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;
+
+/// 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 next CSV string from P from several separator characters
+// - P=nil after call when end of text is reached
+// - returns the character which ended the result string, i.e. #0 or one of Sep
+function GetNextItemMultiple(var P: PUtf8Char; const Sep: RawUtf8;
+  var Next: RawUtf8): AnsiChar; 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 RTL string type of the compiler, and
+// therefore can be used with ready to be displayed text (e.g. for the UI)
+function GetNextItemString(var P: PChar; Sep: Char = ','): string;
+
+/// 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;
+
+/// return next CSV string from P, nil if no more
+// - output text would be trimmed from any left or right space
+// - will always append a trailing #0 - excluded from Dest length (0..254)
+procedure GetNextItemShortString(var P: PUtf8Char; Dest: PShortString;
+  Sep: AnsiChar = ',');
+
+/// 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;
+
+/// 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: PtrInt;
+  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 RTL string type of the compiler, and
+// therefore can be used with ready to be displayed text
+function GetCsvItemString(P: PChar; Index: PtrUInt; Sep: Char = ','): string;
+
+/// return first CSV string in the supplied UTF-8 content
+function GetFirstCsvItem(const Csv: RawUtf8; Sep: AnsiChar = ','): RawUtf8;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// return last CSV string in the supplied UTF-8 content
+function GetLastCsvItem(const Csv: RawUtf8; Sep: AnsiChar = ','): RawUtf8;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// quickly check if Value is in Csv with no temporary memory allocation
+function CsvContains(const Csv, Value: RawUtf8; Sep: AnsiChar = ',';
+  CaseSensitive: boolean = true): boolean;
+
+/// 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
+// - warning: will add the strings, so List := nil may be needed before call
+procedure CsvToRawUtf8DynArray(Csv: PUtf8Char; var List: TRawUtf8DynArray;
+  Sep: AnsiChar = ','; TrimItems: boolean = false; AddVoidItems: boolean = false;
+  Quote: AnsiChar = #0); overload;
+
+/// add the strings in the specified CSV text into a dynamic array of UTF-8 strings
+// - warning: will add the strings, so List := nil may be needed before call
+procedure CsvToRawUtf8DynArray(const Csv, Sep, SepEnd: RawUtf8;
+  var List: TRawUtf8DynArray); overload;
+
+/// convert the strings in the specified CSV text into a dynamic array of UTF-8 strings
+function CsvToRawUtf8DynArray(const Csv: RawUtf8; const Sep: RawUtf8 = ',';
+  const SepEnd: RawUtf8 = ''): 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 = ','; HighValues: integer = -1): 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;
+
+/// recognize #9 ';' or ',' as separator in a CSV text
+// - to implement a separator-tolerant CSV parser
+function CsvGuessSeparator(const Csv: RawUtf8): AnsiChar;
+
+/// append the strings in the specified CSV text into a dynamic array of integer
+procedure CsvToIntegerDynArray(Csv: PUtf8Char; var List: TIntegerDynArray;
+  Sep: AnsiChar = ',');
+
+/// append the strings in the specified CSV text into a dynamic array of integer
+procedure CsvToInt64DynArray(Csv: PUtf8Char; var List: TInt64DynArray;
+  Sep: AnsiChar = ','); overload;
+
+/// convert the strings in the specified CSV text into a dynamic array of integer
+function CsvToInt64DynArray(Csv: PUtf8Char; Sep: AnsiChar = ','): TInt64DynArray; overload;
+
+/// return the corresponding CSV text from a dynamic array of 32-bit integer
+// - you can set some custom Prefix and Suffix text
+function IntegerDynArrayToCsv(Values: PIntegerArray; ValuesCount: integer;
+  const Prefix: RawUtf8 = ''; const Suffix: RawUtf8 = '';
+  InlinedValue: boolean = false; SepChar: AnsiChar = ','): 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; SepChar: AnsiChar = ','): 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; SepChar: AnsiChar = ','): 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; SepChar: AnsiChar = ','): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+
+{ ************ TTextWriter parent class for Text Generation }
+
+type
+  /// event signature for TTextWriter.OnFlushToStream callback
+  TOnTextWriterFlush = procedure(Text: PUtf8Char; Len: PtrInt) of object;
+
+  /// defines how text is to be added into TTextWriter / TJsonWriter
+  // - twNone will write the supplied text with no escaping
+  // - twJsonEscape will properly escape " and \ as expected by JSON
+  // - twOnSameLine will convert any line feeds or control chars into spaces
+  TTextWriterKind = (
+    twNone,
+    twJsonEscape,
+    twOnSameLine);
+
+  /// available global options for a TTextWriter / 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  - as a TRawByteStringStream if twoStreamIsRawByteString
+  // - 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 set via TRttiJson.RegisterCustomSerializer()
+  // 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
+  // may default to the deprecated global TTextWriter.SetDefaultEnumTrim setting
+  // - twoEndOfLineCRLF would reflect the TEchoWriter.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 published properties are serialized
+  // - twoDateTimeWithZ appends an ending 'Z' to TDateTime/TDateTimeMS values
+  // - twoNonExpandedArrays will force the 'non expanded' optimized JSON layout
+  // for array of records or classes, ignoring other formatting options:
+  // $ {"fieldCount":2,"values":["f1","f2","1v1",1v2,"2v1",2v2...],"rowCount":20}
+  // - twoNoSharedStream will force to create a new stream for each instance
+  // - twoNoWriteToStreamException let TTextWriter.WriteToStream silently fail
+  TTextWriterOption = (
+    twoStreamIsOwned,
+    twoStreamIsRawByteString,
+    twoFlushToStreamNoAutoResize,
+    twoEnumSetsAsTextInRecord,
+    twoEnumSetsAsBooleanInRecord,
+    twoFullSetsAsStar,
+    twoTrimLeftEnumSets,
+    twoForceJsonExtended,
+    twoForceJsonStandard,
+    twoEndOfLineCRLF,
+    twoBufferIsExternal,
+    twoIgnoreDefaultInRecord,
+    twoDateTimeWithZ,
+    twoNonExpandedArrays,
+    twoNoSharedStream,
+    twoNoWriteToStreamException);
+
+  /// options set for a TTextWriter / TTextWriter instance
+  // - allows to override e.g. AddRecordJson() and AddDynArrayJson() behavior;
+  // or set global process customization for a TTextWriter
+  TTextWriterOptions = set of TTextWriterOption;
+
+  /// may be used to allocate on stack a 8KB work buffer for a TTextWriter
+  // - via the TTextWriter.CreateOwnedStream overloaded constructor
+  TTextWriterStackBuffer = array[0..8191] of AnsiChar;
+  PTextWriterStackBuffer = ^TTextWriterStackBuffer;
+
+  /// 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/.dbg/.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_C (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 TOrm.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, RawBlob properties are serialized as null, unless
+  // woRawBlobAsBase64 is defined or a custom serialization is used (e.g. TOrm)
+  // - if woHideSensitivePersonalInformation is set, rcfSpi types (e.g. the
+  // 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
+  // - 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
+  // - woDontStoreVoid will avoid serializing numeric properties equal to 0 and
+  // string properties equal to '' (replace both deprecated woDontStore0 and
+  // woDontStoreEmptyString flags)
+  // - woPersistentLock paranoid setting will call TSynPersistentLock.Lock/Unlock
+  // during serialization
+  TTextWriterWriteObjectOption = (
+    woHumanReadable,
+    woDontStoreDefault,
+    woFullExpand,
+    woStoreClassName,
+    woStorePointer,
+    woStoreStoredFalse,
+    woHumanReadableFullSetsAsStar,
+    woHumanReadableEnumSetAsComment,
+    woEnumSetsAsText,
+    woDateTimeWithMagic,
+    woDateTimeWithZSuffix,
+    woTimeLogAsText,
+    woIDAsIDstr,
+    woRawBlobAsBase64,
+    woHideSensitivePersonalInformation,
+    woObjectListWontStoreClassName,
+    woDontStoreInherited,
+    woInt64AsHex,
+    woDontStoreVoid,
+    woPersistentLock);
+
+  /// options set for TTextWriter.WriteObject() method
+  TTextWriterWriteObjectOptions = set of TTextWriterWriteObjectOption;
+
+  /// the potential places were TJsonWriter.AddHtmlEscape should process
+  // proper HTML string escaping, unless hfNone is used
+  // $  < > & "  ->   < > & "e;
+  // by default (hfAnyWhere)
+  // $  < > &  ->   < > &
+  // outside HTML attributes (hfOutsideAttributes)
+  // $  & "  ->   & "e;
+  // within HTML attributes (hfWithinAttributes)
+  TTextWriterHtmlFormat = (
+    hfNone,
+    hfAnyWhere,
+    hfOutsideAttributes,
+    hfWithinAttributes);
+
+  /// 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, which is the smallest data output within mORMot instances
+  // - by default we rely on UTF-8 encoding (which is mandatory in the RFC 8259)
+  // but you can use jsonEscapeUnicode to produce pure 7-bit ASCII output,
+  // with \u#### escape of non-ASCII chars, e.g. as default python json.dumps
+  // - jsonNoEscapeUnicode will search for any \u#### pattern and generate pure
+  // UTF-8 output instead
+  // - those features are not implemented in this unit, but in mormot.core.json
+  TTextWriterJsonFormat = (
+    jsonCompact,
+    jsonHumanReadable,
+    jsonUnquotedPropName,
+    jsonUnquotedPropNameCompact,
+    jsonEscapeUnicode,
+    jsonNoEscapeUnicode);
+
+  /// parent to T*Writer text processing classes, with the minimum set of methods
+  // - use an internal buffer, so much faster than naive string+string
+  // - see TTextDateWriter in mormot.core.datetime for date/time methods
+  // - see TJsonWriter in mormot.core.json for proper JSON support
+  // - see TResultsWriter in mormot.db.core for SQL resultset export
+  // - see TOrmWriter in mormot.orm.core for ORM oriented serialization
+  // - note: mORMot 1.18 TTextWriter.RegisterCustomJSONSerializerFromText()
+  // are moved into Rtti.RegisterFromText() as other similar methods
+  TTextWriter = class
+  protected
+    fStream: TStream;
+    fInitialStreamPosition: PtrUInt;
+    fTotalFileSize: PtrUInt;
+    fHumanReadableLevel: integer;
+    // internal temporary buffer
+    fTempBufSize: integer;
+    fTempBuf: PUtf8Char;
+    fOnFlushToStream: TOnTextWriterFlush;
+    fCustomOptions: TTextWriterOptions;
+    function GetTextLength: PtrUInt;
+    procedure SetStream(aStream: TStream);
+    procedure SetBuffer(aBuf: pointer; aBufSize: integer);
+    procedure WriteToStream(data: pointer; len: PtrUInt); virtual;
+    procedure InternalSetBuffer(aBuf: PUtf8Char; const aBufSize: PtrUInt);
+      {$ifdef FPC} inline; {$endif}
+  public
+    /// direct access to the low-level current position in the buffer
+    // - you should not use this field directly
+    B: PUtf8Char;
+    /// direct access to the low-level last position in the buffer
+    // - you should not use this field directly
+    // - points in fact to 16 bytes before the buffer ending
+    BEnd: PUtf8Char;
+    /// 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
+    // - 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;
+      NoSharedStream: boolean = false); overload;
+    /// the data will be written to an internal TRawByteStringStream
+    // - will use an external buffer (which may be allocated on stack)
+    constructor CreateOwnedStream(aBuf: pointer; aBufSize: integer;
+      NoSharedStream: boolean = false); overload;
+    /// the data will be written to an internal TRawByteStringStream
+    // - will use the stack-allocated TTextWriterStackBuffer if possible
+    constructor CreateOwnedStream(var aStackBuf: TTextWriterStackBuffer;
+      aBufSize: integer; NoSharedStream: boolean = false); overload;
+    /// the data will be written to an internal TRawByteStringStream
+    // - will use the stack-allocated TTextWriterStackBuffer
+    constructor CreateOwnedStream(var aStackBuf: TTextWriterStackBuffer;
+      NoSharedStream: boolean = false); 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 = 16384);
+    /// release all internal structures
+    // - e.g. free fStream if the instance was owned by this class
+    destructor Destroy; override;
+    {$ifndef PUREMORMOT2}
+    /// 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);
+    {$endif PUREMORMOT2}
+
+    /// write pending data, then retrieve the whole text as a UTF-8 string
+    function Text: RawUtf8;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// write pending data, then retrieve the whole text as a UTF-8 string
+    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;
+      {$ifdef HASINLINE}inline;{$endif}
+
+    /// append one ASCII char to the buffer
+    procedure Add(c: AnsiChar); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append one ASCII char to the buffer with no buffer check
+    // - to be called after a regular Add(), within the 16 bytes buffer overhead
+    procedure AddDirect(c: AnsiChar); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append one ASCII char to the buffer with no buffer check
+    // - to be called after a regular Add(), within the 16 bytes buffer overhead
+    procedure AddDirect(c1, c2: AnsiChar); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append one comma (',') character
+    // - to be called after a regular Add(), within the 16 bytes buffer overhead
+    procedure AddComma;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append one ASCII char to the buffer, if not already there as LastChar
+    procedure AddOnce(c: AnsiChar); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append two chars to the buffer
+    procedure Add(c1, c2: AnsiChar); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    {$ifdef CPU32} // already implemented by Add(Value: PtrInt) method on CPU64
+    /// append a 64-bit signed integer Value as text
+    procedure Add(Value: Int64); overload;
+    {$endif CPU32}
+    /// append a 32-bit signed integer Value as text
+    procedure Add(Value: PtrInt); overload;
+      {$ifdef FPC_OR_DELPHIXE4}{$ifdef ASMINTEL}inline;{$endif}{$endif} // URW1111
+    /// append a boolean Value as text
+    // - write either 'true' or 'false'
+    procedure Add(Value: boolean); overload;
+    /// append a Currency from its Int64 in-memory representation
+    // - expects a PInt64 to avoid ambiguity with the AddCurr() method
+    procedure AddCurr64(Value: PInt64);
+    /// append a Currency value
+    // - just an inlined wrapper around AddCurr64(PInt64(@Value))
+    procedure AddCurr(const Value: currency); 
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append an Unsigned 32-bit integer Value as a String
+    procedure AddU(Value: cardinal);
+      {$ifdef FPC_OR_DELPHIXE4}{$ifdef ASMINTEL}inline;{$endif}{$endif} // URW1111
+    /// append an Unsigned 32-bit integer Value as a quoted hexadecimal String
+    procedure AddUHex(Value: cardinal; QuotedChar: AnsiChar = '"');
+      {$ifdef HASINLINE}inline;{$endif}
+    /// 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; QuotedChar: AnsiChar = '"');
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append a GUID value, encoded as text without any {}
+    // - will store e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301'
+    procedure Add(Value: PGuid; QuotedChar: AnsiChar = #0); overload;
+    /// append a floating-point Value as a String
+    // - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values
+    // - noexp=true will call ExtendedToShortNoExp() to avoid any scientific
+    // notation in the resulting text
+    procedure AddDouble(Value: double; noexp: boolean = false);
+    /// append a floating-point Value as a String
+    // - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values
+    // - noexp=true will call ExtendedToShortNoExp() to avoid any scientific
+    // notation in the resulting text
+    procedure AddSingle(Value: single; noexp: boolean = false);
+    /// append a floating-point Value as a String
+    // - write "Infinity", "-Infinity", and "NaN" for corresponding IEEE values
+    // - noexp=true will call ExtendedToShortNoExp() to avoid any scientific
+    // notation in the resulting text
+    procedure Add(Value: Extended; precision: integer; noexp: boolean = false); overload;
+    /// append a floating-point text buffer
+    // - will correct on the fly '.5' -> '0.5' and '-.5' -> '-0.5'
+    // - 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 CR+LF (#13#10) chars
+    // - this method won't call TEchoWriter.EchoAdd() registered events - use
+    // TEchoWriter.AddEndOfLine() method instead
+    // - TEchoWriter.AddEndOfLine() will append either CR+LF (#13#10) or
+    // only LF (#10) depending on its internal options
+    procedure AddCR;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append CR+LF (#13#10) chars and #9 indentation
+    // - indentation depth is defined by the HumanReadableLevel value
+    procedure AddCRAndIndent; virtual;
+    /// write the same character multiple times
+    procedure AddChars(aChar: AnsiChar; aCount: PtrInt);
+    /// append an integer Value as a 2 digits text with comma
+    procedure Add2(Value: PtrUInt);
+    /// append an integer Value as a 3 digits text without any comma
+    procedure Add3(Value: cardinal);
+    /// append an integer Value as a 4 digits text with comma
+    procedure Add4(Value: PtrUInt);
+    /// append a time period, specified in micro seconds, in 00.000.000 TSynLog format
+    procedure AddMicroSec(MicroSec: cardinal);
+    /// append an array of integers as CSV
+    procedure AddCsvInteger(const Integers: array of integer);
+    /// append an array of doubles as CSV
+    procedure AddCsvDouble(const Doubles: array of double);
+    /// 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;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append some UTF-8 chars to the buffer
+    // - don't escapes chars according to the JSON RFC
+    // - called by inlined AddNoJsonEscape() if Len >= fTempBufSize
+    procedure AddNoJsonEscapeBig(P: Pointer; Len: PtrInt);
+    /// append some UTF-8 chars to the buffer - inlined for small content
+    // - don't escapes chars according to the JSON RFC
+    procedure AddNoJsonEscape(P: Pointer; Len: PtrInt); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// 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}
+    /// append some UTF-8 encoded chars to the buffer, from a RTL string type
+    // - don't escapes chars according to the JSON RFC
+    // - if s is a UnicodeString, will convert UTF-16 into UTF-8
+    procedure AddNoJsonEscapeString(const s: string);
+    /// append some unicode chars to the buffer
+    // - WideCharCount is the unicode chars count, not the byte size; if it is
+    // 0, then it will convert until an ending #0 (fastest way)
+    // - 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 Ansi text as UTF-8 chars to the buffer
+    // - don't escapes chars according to the JSON RFC
+    procedure AddNoJsonEscape(P: PAnsiChar; Len: PtrInt; CodePage: cardinal); overload;
+    /// append some UTF-8 content to the buffer, with no JSON escape
+    // - if supplied json is '', will write 'null' so that valid JSON is written
+    // - redirect to AddNoJsonEscape() otherwise
+    procedure AddRawJson(const json: RawJson);
+    /// append a line of text with CR+LF at the end
+    procedure AddLine(const Text: ShortString);
+    /// 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);
+    /// append some RTL string to the buffer in one line
+    // - will write #0..#31 chars as spaces (so content will stay on the same line)
+    procedure AddOnSameLineString(const Text: string);
+    /// 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: PtrInt); overload;
+    /// append a ShortString
+    procedure AddShort(const Text: ShortString); overload;
+    /// append a ShortString - or at least a small buffer < 256 chars
+    procedure AddShort(Text: PUtf8Char; TextLen: PtrInt); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append a TShort8 - Text should be not '', and up to 8 chars long
+    // - this method is aggressively inlined, so may be preferred to AddShort()
+    // for appending simple UTF-8 constant text
+    procedure AddShorter(const Short8: TShort8);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append 'null' as text
+    procedure AddNull;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append a sub-part of an UTF-8 String
+    // - emulates AddString(copy(Text,start,len))
+    procedure AddStringCopy(const Text: RawUtf8; start, len: PtrInt);
+    /// append after trim first lowercase chars ('otDone' will add 'Done' e.g.)
+    procedure AddTrimLeftLowerCase(Text: PShortString);
+    /// append a UTF-8 String excluding any space or control char
+    // - this won't escape the text as expected by JSON
+    procedure AddTrimSpaces(const Text: RawUtf8); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append a #0-terminated UTF-8 buffer excluding any space or control char
+    // - this won't escape the text as expected by JSON
+    procedure AddTrimSpaces(P: PUtf8Char); overload;
+    /// append some text with left-filled spaces up to Width characters count
+    procedure AddSpaced(const Text: RawUtf8; Width: PtrInt;
+      SepChar: AnsiChar = #0); overload;
+    /// append some text with left-filled spaces up to Width characters count
+    // - if the value too big to fit, will truncate up to the first Width chars
+    procedure AddSpaced(Text: PUtf8Char; TextLen, Width: PtrInt); overload;
+    /// append some number with left-filled spaces up to Width characters count
+    // - if the value too big to fit in Width, will append K(Value) abbreviation
+    procedure AddSpaced(Value: QWord; Width: PtrInt;
+      SepChar: AnsiChar = #0); overload;
+    /// append some UTF-8 chars, replacing a given character with another
+    procedure AddReplace(Text: PUtf8Char; Orig, Replaced: AnsiChar);
+    /// append some UTF-8 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; TextLen: PtrUInt; Quote: AnsiChar;
+      TextMaxLen: PtrInt = 0);
+    /// append an URI-decoded domain name, also normalizing dual // into /
+    // - only parameters - i.e. after '?' - may have ' ' replaced by '+'
+    procedure AddUrlNameNormalize(U: PUtf8Char; L: PtrInt);
+    /// append some UTF-8 chars, escaping all HTML special chars as expected
+    procedure AddHtmlEscape(Text: PUtf8Char; Fmt: TTextWriterHtmlFormat = hfAnyWhere); overload;
+    /// append some UTF-8 chars, escaping all HTML special chars as expected
+    procedure AddHtmlEscape(Text: PUtf8Char; TextLen: PtrInt;
+      Fmt: TTextWriterHtmlFormat = hfAnyWhere); overload;
+    /// append some UTF-16 chars, escaping all HTML special chars as expected
+    procedure AddHtmlEscapeW(Text: PWideChar;
+      Fmt: TTextWriterHtmlFormat = hfAnyWhere); overload;
+    /// append some RTL string chars, escaping all HTML special chars as expected
+    procedure AddHtmlEscapeString(const Text: string;
+      Fmt: TTextWriterHtmlFormat = hfAnyWhere);
+    /// append some UTF-8 chars, escaping all HTML special chars as expected
+    procedure AddHtmlEscapeUtf8(const Text: RawUtf8;
+      Fmt: TTextWriterHtmlFormat = hfAnyWhere);
+    /// append some chars, escaping all XML special chars as expected
+    // - i.e.   < > & " '  as   < > & "e; '
+    // - and all control chars (i.e. #1..#31) as &#..;
+    // - see @http://www.w3.org/TR/xml/#syntax
+    procedure AddXmlEscape(Text: PUtf8Char);
+    /// append a property name, as '"PropName":'
+    // - PropName content should not need any JSON escape (e.g. no " within,
+    // and only ASCII 7-bit characters)
+    // - if twoForceJsonExtended is defined in CustomOptions, it would append
+    // 'PropName:' without the double quotes
+    procedure AddProp(PropName: PUtf8Char; PropNameLen: PtrInt); overload;
+    /// append a property name, as '"PropName":'
+    // - just a wrapper around AddProp(PropName, StrLen(PropName))
+    procedure AddProp(PropName: PUtf8Char); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append a ShortString property name, as '"PropName":'
+    // - PropName content should not need any JSON escape (e.g. no " within,
+    // and only ASCII 7-bit characters)
+    // - if twoForceJsonExtended is defined in CustomOptions, it would append
+    // 'PropName:' without the double quotes
+    // - is a wrapper around AddProp()
+    procedure AddPropName(const PropName: ShortString);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append a JSON field name, followed by a number value and a comma (',')
+    procedure AddPropInt64(const PropName: ShortString; Value: Int64;
+      WithQuote: AnsiChar = #0);
+    /// append a RawUtf8 property name, as '"FieldName":'
+    // - FieldName content should not need any JSON escape (e.g. no " within)
+    // - if twoForceJsonExtended is defined in CustomOptions, it would append
+    // 'PropName:' without the double quotes
+    // - is a wrapper around AddProp()
+    procedure AddFieldName(const FieldName: RawUtf8);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append a RawUtf8 property name, as '"FieldName"
+    // - FieldName content should not need any JSON escape (e.g. no " within)
+    procedure AddQuotedFieldName(const FieldName: RawUtf8;
+      const VoidPlaceHolder: RawUtf8 = ''); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append a RawUtf8 property name, as '"FieldName"
+    // - FieldName content should not need any JSON escape (e.g. no " within)
+    procedure AddQuotedFieldName(FieldName: PUtf8Char; FieldNameLen: PtrInt;
+      const VoidPlaceHolder: RawUtf8 = ''); overload;
+    /// append the class name of an Object instance as text
+    procedure AddClassName(aClass: TClass);
+    /// append an Instance name and pointer, as '"TObjectList(00425E68)"'+SepChar
+    // - append "void" if Instance = nil
+    procedure AddInstanceName(Instance: TObject; SepChar: AnsiChar);
+    /// append an Instance name and pointer, as 'TObjectList(00425E68)'+SepChar
+    procedure AddInstancePointer(Instance: TObject; SepChar: AnsiChar;
+      IncludeUnitName, IncludePointer: boolean);
+    /// append some binary data as hexadecimal text conversion
+    procedure AddBinToHex(Bin: Pointer; BinBytes: PtrInt; LowerHex: boolean = false);
+    /// append some binary data as hexadecimal text conversion
+    // - append its minimal chars, i.e. excluding last bytes containing 0
+    procedure AddBinToHexMinChars(Bin: Pointer; BinBytes: PtrInt; LowerHex: boolean = false);
+    /// 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: PtrInt);
+    /// fast conversion from binary data into MSB hexa chars
+    // - up to the internal buffer bytes may be converted
+    procedure AddBinToHexDisplayLower(Bin: pointer; BinBytes: PtrInt;
+      QuotedChar: AnsiChar = #0);
+    /// 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: PtrInt);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// append a Value as significant hexadecimal text
+    // - expects BinBytes to be > 0
+    // - append its minimal chars, i.e. excluding highest bytes containing 0
+    // - use GetNextItemHexa() to decode such a text value
+    procedure AddBinToHexDisplayMinChars(Bin: pointer; BinBytes: PtrInt;
+      QuotedChar: AnsiChar = #0);
+    /// add the pointer into significant hexa chars, ready to be displayed
+    // - append its minimal chars i.e. excluding highest bytes containing 0
+    procedure AddPointer(P: PtrUInt; QuotedChar: AnsiChar = #0);
+    /// write a byte as two hexa chars
+    procedure AddByteToHex(Value: PtrUInt);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// write a byte as two hexa chars
+    procedure AddByteToHexLower(Value: PtrUInt);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// 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 strings or integers with a specified format
+    // - this class implementation will raise an exception for twJsonEscape,
+    // and simply call FormatUtf8() over a temp RawUtf8 for twNone/twOnSameLine
+    // - use faster and more complete overriden TJsonWriter.Add instead!
+    procedure Add(const Format: RawUtf8; const Values: array of const;
+      Escape: TTextWriterKind = twNone;
+      WriteObjectOptions: TTextWriterWriteObjectOptions = [woFullExpand]); overload; virtual;
+    /// this class implementation will raise an exception
+    // - use overriden TJsonWriter version instead!
+    function AddJsonReformat(Json: PUtf8Char; Format: TTextWriterJsonFormat;
+      EndOfObject: PUtf8Char): PUtf8Char; virtual;
+    /// this class implementation will raise an exception
+    // - use overriden TJsonWriter version instead!
+    procedure AddVariant(const Value: variant; Escape: TTextWriterKind = twJsonEscape;
+      WriteOptions: TTextWriterWriteObjectOptions = []); virtual;
+    /// this class implementation will raise an exception
+    // - use overriden TJsonWriter version instead!
+    // - TypeInfo is a PRttiInfo instance - but not available in this early unit
+    procedure AddTypedJson(Value: pointer; TypeInfo: pointer;
+      WriteOptions: TTextWriterWriteObjectOptions = []); virtual;
+    /// write some #0 ended UTF-8 text, according to the specified format
+    // - use overriden TJsonWriter version instead!
+    procedure Add(P: PUtf8Char; Escape: TTextWriterKind); overload; virtual;
+    /// write some #0 ended UTF-8 text, according to the specified format
+    // - use overriden TJsonWriter version instead!
+    procedure Add(P: PUtf8Char; Len: PtrInt; Escape: TTextWriterKind); overload; virtual;
+    /// write some data Base64 encoded
+    // - use overriden TJsonWriter version instead!
+    procedure WrBase64(P: PAnsiChar; Len: PtrUInt; withMagic: boolean); virtual;
+
+    /// serialize as JSON the given object
+    // - use overriden TJsonWriter version instead!
+    procedure WriteObject(Value: TObject;
+      WriteOptions: TTextWriterWriteObjectOptions = [woDontStoreDefault]); virtual;
+    /// append a T*ObjArray dynamic array as a JSON array
+    // - for proper serialization on Delphi 7-2009, use Rtti.RegisterObjArray()
+    procedure AddObjArrayJson(const aObjArray;
+      aOptions: TTextWriterWriteObjectOptions = [woDontStoreDefault]);
+    /// return the last char appended
+    // - returns #0 if no char has been written yet, or the buffer has been just
+    // flushed: so this method is to be handled only in some particular usecases
+    function LastChar: AnsiChar;
+    /// how many bytes are currently in the internal buffer and not on disk/stream
+    // - see TextLength for the total number of bytes, on both stream and memory
+    function PendingBytes: PtrUInt;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// how many bytes were currently written on disk/stream
+    // - excluding the bytes in the internal buffer (see PendingBytes)
+    // - see TextLength for the total number of bytes, on both stream and memory
+    property WrittenBytes: PtrUInt
+      read fTotalFileSize;
+    /// low-level access to the current indentation level
+    property HumanReadableLevel: integer
+      read fHumanReadableLevel write fHumanReadableLevel;
+    /// the last char appended is canceled
+    // - only one char cancelation is allowed at the same position: don't call
+    // CancelLastChar/CancelLastComma more than once without appending text inbetween
+    procedure CancelLastChar; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// the last char appended is canceled, if match the supplied one
+    // - only one char cancelation is allowed at the same position: don't call
+    // CancelLastChar/CancelLastComma more than once without appending text inbetween
+    procedure CancelLastChar(aCharToCancel: AnsiChar); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// the last char appended is canceled if it was a ','
+    // - only one char cancelation is allowed at the same position: don't call
+    // CancelLastChar/CancelLastComma more than once without appending text inbetween
+    procedure CancelLastComma; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// the last char appended is canceled if it was a ',' and replaced
+    // - only one char cancelation is allowed at the same position: don't call
+    // CancelLastChar/CancelLastComma more than once without appending text inbetween
+    procedure CancelLastComma(aReplaceChar: AnsiChar); overload;
+      {$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;
+    /// same as CancelAll, and also reset the CustomOptions
+    procedure CancelAllAsNew;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// same as CancelAll, and also use a new local TTextWriterStackBuffer
+    procedure CancelAllWith(var temp: TTextWriterStackBuffer);
+
+    /// 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/stream
+    property TextLength: PtrUInt
+      read GetTextLength;
+    /// 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 writing
+    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;
+    /// optional event called before FlushToStream method process
+    // - used e.g. by TEchoWriter to perform proper content echoing
+    property OnFlushToStream: TOnTextWriterFlush
+      read fOnFlushToStream write fOnFlushToStream;
+  end;
+
+  /// class of our simple TEXT format writer to a Stream
+  TBaseWriterClass = class of TTextWriter;
+
+var
+  /// contains the default JSON serialization class for the framework
+  // - used internally by ObjectToJson/VariantSaveJson to avoid circular references
+  // - will be set to TJsonWriter by mormot.core.json; default TTextWriter
+  // would raise an exception on any JSON processing attempt
+  DefaultJsonWriter: TBaseWriterClass = TTextWriter;
+
+/// 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 class, via mormot.core.json.pas
+// TRttiJson.RegisterCustomSerializer() class method
+// - call internally TTextWriter.WriteObject() method from DefaultJsonWriter
+function ObjectToJson(Value: TObject;
+  Options: TTextWriterWriteObjectOptions = [woDontStoreDefault]): RawUtf8; overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// will serialize any TObject into its UTF-8 JSON representation
+procedure ObjectToJson(Value: TObject; var result: RawUtf8;
+  Options: TTextWriterWriteObjectOptions = [woDontStoreDefault]); overload;
+
+/// will serialize any TObject into its expanded UTF-8 JSON representation
+// - includes debugger-friendly information, similar to TSynLog, i.e.
+// class name and sets/enumerates as text
+// - redirect to ObjectToJson() with the proper TTextWriterWriteObjectOptions,
+// since our JSON serialization detects and serialize Exception.Message
+function ObjectToJsonDebug(Value: TObject;
+  Options: TTextWriterWriteObjectOptions = [woDontStoreDefault,
+    woHumanReadable, woStoreClassName, woStorePointer,
+    woHideSensitivePersonalInformation]): RawUtf8;
+
+/// a wrapper around ConsoleWrite(ObjectToJson(Value))
+procedure ConsoleObject(Value: TObject;
+  Options: TTextWriterWriteObjectOptions = [woHumanReadable]);
+
+/// check if some UTF-8 text would need HTML escaping
+function NeedsHtmlEscape(text: PUtf8Char; fmt: TTextWriterHtmlFormat): boolean;
+
+/// escape some UTF-8 text into HTML
+// - just a wrapper around TTextWriter.AddHtmlEscape() process,
+// replacing < > & " chars depending on the HTML layer
+function HtmlEscape(const text: RawUtf8;
+  fmt: TTextWriterHtmlFormat = hfAnyWhere): RawUtf8;
+
+/// escape some RTL string text into UTF-8 HTML
+// - just a wrapper around TTextWriter.AddHtmlEscapeString() process,
+// replacing < > & " chars depending on the HTML layer
+function HtmlEscapeString(const text: string;
+  fmt: TTextWriterHtmlFormat = hfAnyWhere): RawUtf8;
+
+/// escape as \xx hexadecimal some chars from a set into a pre-allocated buffer
+// - dest^ should have at least srclen * 3 bytes, for \## trios
+function EscapeHexBuffer(src, dest: PUtf8Char; srclen: integer;
+  const toescape: TSynAnsicharSet; escape: AnsiChar = '\'): PUtf8Char;
+
+/// escape as \xx hexadecimal some chars from a set into a new RawUtf8 string
+// - as used e.g. by LdapEscape()
+function EscapeHex(const src: RawUtf8;
+  const toescape: TSynAnsicharSet; escape: AnsiChar = '\'): RawUtf8;
+
+/// un-escape \xx or \c encoded chars from a pre-allocated buffer
+// - any CR/LF after \ will also be ignored
+// - dest^ should have at least the same length than src^
+function UnescapeHexBuffer(src, dest: PUtf8Char; escape: AnsiChar = '\'): PUtf8Char;
+
+/// un-escape \xx or \c encoded chars into a new RawUtf8 string
+// - any CR/LF after \ will also be ignored
+function UnescapeHex(const src: RawUtf8; escape: AnsiChar = '\'): RawUtf8;
+
+/// escape as \char pair some chars from a set into a pre-allocated buffer
+// - dest^ should have at least srclen * 2 bytes, for \char pairs
+// - by definition, escape should be part of the toescape set
+function EscapeCharBuffer(src, dest: PUtf8Char; srclen: integer;
+  const toescape: TSynAnsicharSet; escape: AnsiChar = '\'): PUtf8Char;
+
+/// escape as \char pair some chars from a set into a new RawUtf8 string
+// - by definition, escape should be part of the toescape set
+function EscapeChar(const src: RawUtf8;
+  const toescape: TSynAnsicharSet; escape: AnsiChar = '\'): RawUtf8;
+
+const
+  /// TTextWriter JSON serialization options focusing of sets support
+  // - as used e.g. by TJsonWriter.AddRecordJson/AddDynArrayJson and
+  // TDynArray.SaveJson methods, and SaveJson/RecordSaveJson functions
+  // - to be used as TEXTWRITEROPTIONS_TEXTSET[EnumSetsAsText]
+  TEXTWRITEROPTIONS_SETASTEXT: array[boolean] of TTextWriterOptions = (
+    [twoFullSetsAsStar],
+    [twoFullSetsAsStar, twoEnumSetsAsTextInRecord]);
+
+  /// TTextWriter JSON serialization options including twoEnumSetsAsTextInRecord
+  TEXTWRITEROPTIONS_ENUMASTEXT: array[boolean] of TTextWriterOptions = (
+    [],
+    [twoEnumSetsAsTextInRecord]);
+
+  /// TTextWriter JSON serialization options including woEnumSetsAsText
+  TEXTWRITEROBJECTOPTIONS_ENUMASTEXT: array[boolean] of TTextWriterWriteObjectOptions = (
+    [],
+    [woEnumSetsAsText]);
+
+  /// TTextWriter JSON serialization options which should be preserved
+  // - used e.g. by TTextWriter.CancelAllAsNew to reset its CustomOptions
+  TEXTWRITEROPTIONS_RESET =
+    [twoStreamIsOwned, twoStreamIsRawByteString, twoBufferIsExternal];
+
+type
+  TEchoWriter = class;
+
+  /// callback used to echo each line of TEchoWriter class
+  // - should return TRUE on success, FALSE if the log was not echoed: but
+  // TSynLog will continue logging, even if this event returned FALSE
+  TOnTextWriterEcho = function(Sender: TEchoWriter; Level: TSynLogLevel;
+    const Text: RawUtf8): boolean of object;
+
+  TEchoWriterBack = record
+    Level: TSynLogLevelDynArray;
+    Text: TRawUtf8DynArray;
+    Count: PtrInt;
+  end;
+
+  /// add optional echoing of the lines to TTextWriter
+  // - as used e.g. by TSynLog writer for log optional redirection
+  // - is defined as a nested class to reduce plain TTextWriter scope, and
+  // better follow the SOLID principles
+  TEchoWriter = class
+  protected
+    fWriter: TTextWriter;
+    fEchoStart: PtrInt;
+    fEchoBuf: RawUtf8;
+    fEchos: array of TOnTextWriterEcho;
+    fBack: TEchoWriterBack;
+    fBackSafe: TLightLock; // protect fBack.Level/Text
+    fEchoPendingExecuteBackground: boolean;
+    function EchoFlush: PtrInt;
+    procedure EchoPendingToBackground(aLevel: TSynLogLevel);
+    function GetEndOfLineCRLF: boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    procedure SetEndOfLineCRLF(aEndOfLineCRLF: boolean);
+  public
+    /// prepare for the echoing process
+    constructor Create(Owner: TTextWriter); reintroduce;
+    /// end the echoing process
+    destructor Destroy; override;
+    /// should be called from TTextWriter.FlushToStream
+    // - write pending data to the Stream, with automatic buffer resizal and echoing
+    // - this overriden method will handle proper echoing
+    procedure FlushToStream(Text: PUtf8Char; Len: PtrInt);
+    /// 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 in the
+    // current thread, or calling EchoPendingExecute from a background thread
+    // - used e.g. by TSynLog for console output, as stated by Level parameter
+    procedure AddEndOfLine(aLevel: TSynLogLevel = sllNone);
+    /// add a callback to echo each line written by this class
+    // - this class expects AddEndOfLine to mark the end of each line
+    procedure EchoAdd(const aEcho: TOnTextWriterEcho);
+    /// remove a callback to echo each line written by this class
+    // - event should have been previously registered by a EchoAdd() call
+    procedure EchoRemove(const aEcho: TOnTextWriterEcho);
+    /// reset the internal buffer used for echoing content
+    procedure EchoReset;
+    /// run all pending EchoPendingExecuteBackground notifications
+    // - should be executed from a background thread
+    procedure EchoPendingExecute;
+    /// the associated TTextWriter instance
+    property Writer: TTextWriter
+      read fWriter;
+    /// 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;
+    /// if EchoPendingExecute is about to be executed in the background
+    property EchoPendingExecuteBackground: boolean
+      read fEchoPendingExecuteBackground write fEchoPendingExecuteBackground;
+  end;
+
+
+
+{ ************ Numbers (integers or floats) and Variants to Text Conversion }
+
+var
+  /// 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 mormot.db.nosql.bson)
+  // - is defined globally, since may be used from an inlined function
+  SmallUInt32Utf8: array[0..999] of RawUtf8;
+
+/// fast RawUtf8 version of 32-bit IntToStr()
+function Int32ToUtf8(Value: PtrInt): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast RawUtf8 version of 32-bit IntToStr()
+// - result as var parameter saves a local assignment and a try..finally
+procedure Int32ToUtf8(Value: PtrInt; var result: RawUtf8); overload;
+
+/// fast RawUtf8 version of 64-bit IntToStr()
+function Int64ToUtf8(Value: Int64): RawUtf8; overload;
+  {$ifdef HASSAFEINLINE}inline;{$endif} // Delphi 2007 has trouble inlining this
+
+/// fast RawUtf8 version of 64-bit IntToStr()
+// - result as var parameter saves a local assignment and a try..finally
+procedure Int64ToUtf8(Value: Int64; var result: RawUtf8); overload;
+
+/// fast RawUtf8 version of 32-bit IntToStr()
+function ToUtf8(Value: PtrInt): RawUtf8; overload;
+
+{$ifdef CPU32}
+/// fast RawUtf8 version of 64-bit IntToStr()
+function ToUtf8(Value: Int64): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+{$endif CPU32}
+
+/// 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;
+
+/// fast RawUtf8 version of 64-bit IntToStr(), with proper QWord support
+procedure UInt64ToUtf8(Value: QWord; var result: RawUtf8);
+
+/// convert a string into its INTEGER Curr64 (value*10000) representation
+// - this type is compatible with currency memory mapping with PInt64(@Curr)^
+// - fast conversion, using only integer operations
+// - if NoDecimal is defined, will be set to TRUE if there is no decimal, AND
+// the returned value will be an Int64 (not a PInt64(@Curr)^)
+function StrToCurr64(P: PUtf8Char; NoDecimal: PBoolean = nil): Int64;
+
+/// convert a string into its currency representation
+// - will call StrToCurr64()
+function StrToCurrency(P: PUtf8Char): currency;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a currency value into a string
+// - fast conversion, using only integer operations
+// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals)
+function CurrencyToStr(const Value: currency): RawUtf8;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert an INTEGER Curr64 (value*10000) into a string
+// - this type is compatible with currency memory mapping with PInt64(@Curr)^
+// - fast conversion, using only integer operations
+// - decimals are joined by 2 (no decimal, 2 decimals, 4 decimals)
+function Curr64ToStr(const Value: Int64): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert an INTEGER Curr64 (value*10000) into a string
+// - this type is compatible with currency memory mapping 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 currency memory mapping 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;
+
+/// faster than default SysUtils.IntToStr implementation
+function IntToString(Value: integer): string; overload;
+
+/// faster than default SysUtils.IntToStr implementation
+function IntToString(Value: cardinal): string; overload;
+
+/// faster 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;
+
+/// convert a floating-point value to its numerical text equivalency
+// - on Delphi Win32, calls FloatToText() in ffGeneral mode; on FPC uses str()
+// - DOUBLE_PRECISION will redirect to DoubleToShort() and its faster Fabian
+// Loitsch's Grisu algorithm if available
+// - returns the count of chars stored into S, i.e. length(S)
+function ExtendedToShort(S: PShortString;
+  Value: TSynExtended; Precision: integer): integer;
+
+/// convert a floating-point value to its numerical text equivalency without
+// scientification notation
+// - DOUBLE_PRECISION will redirect to DoubleToShortNoExp() and its faster Fabian
+// Loitsch's Grisu algorithm if available - or calls str(Value:0:precision,S)
+// - returns the count of chars stored into S, i.e. length(S)
+function ExtendedToShortNoExp(S: PShortString; Value: TSynExtended;
+  Precision: integer): integer;
+
+/// check if the supplied text is NAN/INF/+INF/-INF, i.e. not a number
+// - as returned by ExtendedToShort/DoubleToShort textual conversion
+// - such values do appear as IEEE floating points, but are not defined in JSON
+function FloatToShortNan(const s: ShortString): TFloatNan;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// check if the supplied text is NAN/INF/+INF/-INF, i.e. not a number
+// - as returned e.g. by ExtendedToStr/DoubleToStr textual conversion
+// - such values do appear as IEEE floating points, but are not defined in JSON
+function FloatToStrNan(const s: RawUtf8): TFloatNan;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a floating-point value to its numerical text equivalency
+function ExtendedToStr(Value: TSynExtended; Precision: integer): RawUtf8; overload;
+
+/// convert a floating-point value to its numerical text equivalency
+procedure ExtendedToStr(Value: TSynExtended; Precision: integer;
+  var result: RawUtf8); overload;
+
+/// recognize if the supplied text is NAN/INF/+INF/-INF, i.e. not a number
+// - returns the number as text (stored into tmp variable), or "Infinity",
+// "-Infinity", and "NaN" for corresponding IEEE special values
+// - result is a PShortString either over tmp, or JSON_NAN[]
+function FloatToJsonNan(s: PShortString): PShortString;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a floating-point value to its JSON text equivalency
+// - depending on the platform, it may either call str() or FloatToText()
+// in ffGeneral mode (the shortest possible decimal string using fixed or
+// scientific format)
+// - returns the number as text (stored into tmp variable), or "Infinity",
+// "-Infinity", and "NaN" for corresponding IEEE special values
+// - result is a PShortString either over tmp, or JSON_NAN[]
+function ExtendedToJson(tmp: PShortString; Value: TSynExtended;
+  Precision: integer; NoExp: boolean): PShortString;
+
+/// convert a 64-bit floating-point value to its numerical text equivalency
+// - on Delphi Win32, calls FloatToText() in ffGeneral mode
+// - on other platforms, i.e. Delphi Win64 and all FPC targets, will use our own
+// faster Fabian Loitsch's Grisu algorithm implementation
+// - returns the count of chars stored into S, i.e. length(S)
+function DoubleToShort(S: PShortString; const Value: double): integer;
+
+/// convert a 64-bit floating-point value to its numerical text equivalency
+// without scientific notation
+// - on Delphi Win32, calls FloatToText() in ffGeneral mode
+// - on other platforms, i.e. Delphi Win64 and all FPC targets, will use our own
+// faster Fabian Loitsch's Grisu algorithm implementation
+// - returns the count of chars stored into S, i.e. length(S)
+function DoubleToShortNoExp(S: PShortString; const Value: double): integer;
+
+{$ifdef DOUBLETOSHORT_USEGRISU}
+const
+  // special text returned if the double is not a number
+  C_STR_INF: string[3] = 'Inf';
+  C_STR_QNAN: string[3] = 'Nan';
+
+  // min_width parameter special value, as used internally by FPC for str(d,s)
+  // - DoubleToAscii() only accept C_NO_MIN_WIDTH or 0 for min_width: space
+  // trailing has been removed in this cut-down version
+  C_NO_MIN_WIDTH = -32767;
+
+/// raw function to convert a 64-bit double into a ShortString, stored in str
+// - implements Fabian Loitsch's Grisu algorithm dedicated to double values
+// - currently, this unit only set min_width=0 (for DoubleToShortNoExp to avoid
+// any scientific notation ) or min_width=C_NO_MIN_WIDTH (for DoubleToShort to
+// force the scientific notation when the double cannot be represented as
+// a simple fractinal number)
+procedure DoubleToAscii(min_width, frac_digits: integer;
+  const v: double; str: PAnsiChar);
+{$endif DOUBLETOSHORT_USEGRISU}
+
+/// convert a 64-bit floating-point value to its JSON text equivalency
+// - on Delphi Win32, calls FloatToText() in ffGeneral mode
+// - on other platforms, i.e. Delphi Win64 and all FPC targets, will use our own
+// faster Fabian Loitsch's Grisu algorithm
+// - returns the number as text (stored into tmp variable), or "Infinity",
+// "-Infinity", and "NaN" for corresponding IEEE special values
+// - result is a PShortString either over tmp, or JSON_NAN[]
+function DoubleToJson(tmp: PShortString; Value: double;
+  NoExp: boolean): PShortString;
+
+/// convert a 64-bit floating-point value to its numerical text equivalency
+function DoubleToStr(Value: Double): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a 64-bit floating-point value to its numerical text equivalency
+procedure DoubleToStr(Value: Double; var result: RawUtf8); overload;
+
+/// copy a floating-point text buffer with proper correction and validation
+// - will correct on the fly '.5' -> '0.5' and '-.5' -> '-0.5'
+// - will end not only on #0 but on any char not matching 1[.2[e[-]3]] pattern
+// - is used when the input comes from a third-party source with no regular
+// output, e.g. a database driver, via TTextWriter.AddFloatStr
+function FloatStrCopy(s, d: PUtf8Char): PUtf8Char;
+
+/// 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;
+   ConvertHexToBinTab: PByteArray): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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;
+   ConvertHexToBinTab: PByteArray): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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;
+   ConvertHexToBinTab: PByteArray): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+
+
+/// convert any Variant into UTF-8 encoded String
+// - use VariantSaveJson() instead if you need a conversion to JSON with
+// custom parameters
+// - note: null will be returned as 'null'
+function VariantToUtf8(const V: Variant): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any Variant into UTF-8 encoded String
+// - use VariantSaveJson() instead if you need a conversion to JSON with
+// custom parameters
+// - note: null will be returned as 'null'
+function ToUtf8(const V: Variant): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any Variant/TVarData into UTF-8 encoded String
+// - use VariantSaveJson() instead if you need a conversion to JSON with
+// custom parameters
+// - note: null will be returned as 'null'
+function ToUtf8(const V: TVarData): 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;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any non-null Variant into UTF-8 encoded String
+// - empty and null variants will return false
+function VariantToText(const V: Variant; var Text: RawUtf8): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// save a variant value into a JSON content
+// - just a wrapper around the _VariantSaveJson procedure redirection
+function VariantSaveJson(const Value: variant;
+  Escape: TTextWriterKind = twJsonEscape): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// save a variant value into a JSON content
+// - just a wrapper around the _VariantSaveJson procedure redirection
+procedure VariantSaveJson(const Value: variant; Escape: TTextWriterKind;
+  var result: RawUtf8); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// internal low-level function to compare two variants with RawUt8 conversion
+// - as used e.g. by FastVarDataComp() for complex or diverse VType
+function VariantCompAsText(A, B: PVarData; caseInsensitive: boolean): integer;
+
+var
+  /// save a variant value into a JSON content
+  // - is implemented by mormot.core.json.pas and mormot.core.variants.pas:
+  // will raise an exception if none of these units is included in the project
+  // - 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
+  _VariantSaveJson: procedure(const Value: variant; Escape: TTextWriterKind;
+    var result: RawUtf8);
+
+  /// unserialize a JSON content into a variant
+  // - is properly implemented by mormot.core.json.pas: if this unit is not
+  // included in the project, this function is nil
+  // - used by mormot.core.data.pas RTTI_BINARYLOAD[tkVariant]() for complex types
+  BinaryVariantLoadAsJson: procedure(var Value: variant; Json: PUtf8Char;
+    TryCustomVariant: pointer);
+
+  /// write a TDateTime into strict ISO-8601 date and/or time text
+  // - is implemented by DateTimeToIso8601TextVar from mormot.core.datetime.pas:
+  // if this unit is not included in the project, an ESynException is raised
+  // - used by VariantToUtf8() for TDateTime conversion
+  _VariantToUtf8DateTimeToIso8601: procedure(DT: TDateTime; FirstChar: AnsiChar;
+    var result: RawUtf8; WithMS: boolean);
+
+  /// Date/Time conversion from ISO-8601 text
+  // - is implemented by Iso8601ToDateTime() from mormot.core.datetime.pas:
+  // if this unit is not included in the project, this function is nil
+  // - used by TRttiProp.SetValue() for TDateTime properties with a getter
+  _Iso8601ToDateTime: function(const iso: RawByteString): TDateTime;
+
+
+type
+  /// used e.g. by UInt4DigitsToShort/UInt3DigitsToShort/UInt2DigitsToShort
+  // - such result type would avoid a string allocation on heap
+  TShort4 = string[4];
+
+/// 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;
+
+/// 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;
+
+/// 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;
+
+  /// 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;
+
+/// 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;
+
+/// 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}
+
+/// convert an IPv4 'x.x.x.x' text into its 32-bit value
+// - result is in little endian order, not network order: 1.2.3.4 becomes $04030201
+// - 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(aIP: PUtf8Char; out aValue: cardinal): boolean; overload;
+
+/// convert an IPv4 'x.x.x.x' text into its 32-bit value
+// - result is in little endian order, not network order: 1.2.3.4 becomes $04030201
+// - 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
+// - result is in little endian order, not network order: 1.2.3.4 becomes $04030201
+// - 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}
+
+
+{ ************ Text Formatting functions }
+
+type
+  /// a memory structure which avoids a temporary RawUtf8 allocation
+  // - used by VarRecToTempUtf8/VariantToTempUtf8 and FormatUtf8/FormatShort
+  TTempUtf8 = record
+    Len: PtrInt;
+    Text: PUtf8Char;
+    TempRawUtf8: pointer;
+    Temp: array[0..23] of AnsiChar;
+  end;
+  PTempUtf8 = ^TTempUtf8;
+
+/// convert any Variant into a JSON-compatible UTF-8 encoded temporary buffer
+// - this function would allocate a RawUtf8 in Res.TempRawUtf8 only if needed,
+// but use the supplied Res.Temp[] buffer for numbers to text conversion -
+// caller should ensure to make RawUtf8(Res.TempRawUtf8) := '' once done with it
+// - wasString is set if the V value was a text
+// - empty and null variants will be stored as 'null' text - as expected by JSON
+// - booleans will be stored as 'true' or 'false' - as expected by JSON
+// - custom variant types (e.g. TDocVariant) will be stored as JSON
+procedure VariantToTempUtf8(const V: variant; var Res: TTempUtf8;
+  var wasString: boolean);
+
+const
+  /// which TVarRec.VType are numbers, i.e. don't need to be quoted
+  // - vtVariant is a number by default, unless detected e.g. by VariantToUtf8()
+  vtNotString = [vtBoolean, vtInteger, vtInt64, {$ifdef FPC} vtQWord, {$endif}
+                 vtCurrency, vtExtended, vtVariant];
+
+/// 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);
+
+/// 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 Res.TempRawUtf8 only if needed,
+// but use the supplied Res.Temp[] buffer for numbers to text conversion -
+// caller should ensure to make RawUtf8(Res.TempRawUtf8) := '' once done with it
+// - 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;
+  wasString: PBoolean = nil): PtrInt;
+
+/// 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}
+
+/// check if a supplied "array of const" argument is an instance of a given class
+function VarRecAs(const aArg: TVarRec; aClass: TClass): pointer;
+
+/// fast Format() function replacement, optimized for RawUtf8
+// - only supported token is %, which will be written in the resulting string
+// according to each Args[] supplied items - so you will never get any exception
+// as with the SysUtils.Format() when a specifier is incorrect
+// - resulting string has no length limit and uses fast concatenation
+// - there is no escape char, so to output a '%' character, you need to use '%'
+// as place-holder, and specify '%' as value in the Args array
+// - note that, due to a Delphi compiler limitation, cardinal values should be
+// type-casted to Int64() (otherwise the integer mapped value will be converted)
+// - any supplied TObject instance will be written as their class name
+// - see FormatSql() and FormatJson() from mormot.core.json for ? placeholders
+function FormatUtf8(const Format: RawUtf8; const Args: array of const): RawUtf8; overload;
+
+/// fast Format() function replacement, optimized for RawUtf8
+// - overloaded function, which avoid a temporary RawUtf8 instance on stack
+procedure FormatUtf8(const Format: RawUtf8; const Args: array of const;
+  out result: RawUtf8); overload;
+
+/// fast Format() function replacement, tuned for direct memory buffer write
+// - use the same single token % (and implementation) than FormatUtf8()
+// - returns the number of UTF-8 bytes appended to Dest^
+function FormatBuffer(const Format: RawUtf8; const Args: array of const;
+  Dest: pointer; DestLen: PtrInt): PtrInt;
+
+/// fast Format() function replacement, for UTF-8 content stored in ShortString
+// - use the same single token % (and implementation) than FormatUtf8()
+// - ShortString allows fast stack allocation, so is perfect for small content
+// - truncate result if the text size exceeds 255 bytes
+procedure FormatShort(const Format: RawUtf8; const Args: array of const;
+  var result: ShortString);
+
+/// fast Format() function replacement, for UTF-8 content stored in ShortString
+function FormatToShort(const Format: RawUtf8; const Args: array of const): ShortString;
+
+/// fast Format() function replacement, tuned for small content
+// - use the same single token % (and implementation) than FormatUtf8()
+procedure FormatString(const Format: RawUtf8; const Args: array of const;
+  out result: string); overload;
+
+/// fast Format() function replacement, tuned for small content
+// - use the same single token % (and implementation) than FormatUtf8()
+function FormatString(const Format: RawUtf8; const Args: array of const): string; overload;
+  {$ifdef FPC}inline;{$endif} // Delphi don't inline "array of const" parameters
+
+/// 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, for UTF-8 content stored in variant
+function FormatVariant(const Format: RawUtf8; const Args: array of const): variant;
+
+/// concatenate several arguments into an UTF-8 string
+function Make(const Args: array of const): RawUtf8; overload;
+
+/// concatenate several arguments into an UTF-8 string
+procedure Make(const Args: array of const; var Result: RawUtf8); overload;
+
+/// concatenate several arguments into a RTL string
+function MakeString(const Args: array of const): string;
+
+/// append some text items to a RawUtf8 variable
+// - see also AppendLine() below if you need a separator
+procedure Append(var Text: RawUtf8; const Args: array of const); overload;
+
+/// append one text item to a RawUtf8 variable with no code page conversion
+procedure Append(var Text: RawUtf8; const Added: RawByteString); overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// append two text items to a RawUtf8 variable with no code page conversion
+procedure Append(var Text: RawUtf8; const Added1, Added2: RawByteString); overload;
+
+/// append one char to a RawUtf8 variable with no code page conversion
+procedure Append(var Text: RawUtf8; Added: AnsiChar); overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// append one text buffer to a RawUtf8 variable with no code page conversion
+procedure Append(var Text: RawUtf8; Added: pointer; AddedLen: PtrInt); overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// append some text items to a RawByteString variable
+procedure Append(var Text: RawByteString; const Args: array of const); overload;
+
+/// append one text item to a RawByteString variable with no code page conversion
+procedure Append(var Text: RawByteString; const Added: RawByteString); overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// append one text buffer to a RawByteString variable with no code page conversion
+procedure Append(var Text: RawByteString; Added: pointer; AddedLen: PtrInt); overload;
+
+/// prepend some text to a RawByteString variable with no code page conversion
+procedure Prepend(var Text: RawByteString; const Added: RawByteString); overload;
+
+/// prepend one char to a RawByteString variable with no code page conversion
+procedure Prepend(var Text: RawByteString; Added: AnsiChar); overload;
+
+/// prepend some text items at the beginning of a RawUtf8 variable
+procedure Prepend(var Text: RawUtf8; const Args: array of const); overload;
+
+/// prepend some text items at the beginning of a RawByteString variable
+procedure Prepend(var Text: RawByteString; const Args: array of const); overload;
+
+/// append some text to a RawUtf8, ensuring previous text is separated with CRLF
+// - could be used e.g. to update HTTP headers
+procedure AppendLine(var Text: RawUtf8; const Args: array of const;
+  const Separator: shortstring = #13#10);
+
+/// append some path parts into a single file name with proper path delimiters
+// - set EndWithDelim=true if you want to create e.g. a full folder name
+// - similar to os.path.join() in the Python RTL
+// - e.g. on Windows: MakePath(['abc', 1, 'toto.json']) = 'abc\1\toto.json'
+function MakePath(const Part: array of const; EndWithDelim: boolean = false;
+  Delim: AnsiChar = PathDelim): TFileName;
+
+/// MakePath() variant which can handle the file extension specifically
+function MakeFileName(const Part: array of const; LastIsExt: boolean = true): TFileName;
+
+/// create a CSV text from some values
+function MakeCsv(const Value: array of const; EndWithComma: boolean = false;
+  Comma: AnsiChar = ','): RawUtf8;
+
+/// direct conversion of a RTL 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;
+
+/// write some text to the console using a given color
+procedure ConsoleWrite(const Fmt: RawUtf8; const Args: array of const;
+  Color: TConsoleColor = ccLightGray; NoLineFeed: boolean = false); overload;
+
+/// write some text to the console using a given color
+procedure ConsoleWrite(const Args: array of const;
+  Color: TConsoleColor = ccLightGray; NoLineFeed: boolean = false); overload;
+
+/// could be used in the main program block of a console application to
+// handle unexpected fatal exceptions
+// - WaitForEnterKey=true won't do anything on POSIX (to avoid locking a daemon)
+// - 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);
+
+
+{ ************ Resource and Time Functions }
+
+/// 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 count to a human readable value power-of-two metric value
+// - append E, P, T, G, M, K symbol, with one fractional digit
+procedure K(value: Int64; out result: TShort16); overload;
+
+/// convert a count to a human readable value power-of-two metric value
+// - append E, P, T, G, M, K symbol, with one fractional digit
+function K(value: Int64): TShort16; overload;
+  {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell
+
+/// convert a seconds elapsed time into a human readable value
+// - append 's', 'm', 'h' and 'd' symbol for the given value range,
+// with two fractional digits
+function SecToString(S: QWord): TShort16;
+  {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell
+
+/// convert a milliseconds elapsed time into a human readable value
+// - append 'ms', 's', 'm', 'h' and 'd' symbol for the given value range,
+// with two fractional digits
+function MilliSecToString(MS: QWord): TShort16;
+  {$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
+function MicroSecToString(Micro: QWord): TShort16; overload;
+  {$ifdef FPC_OR_UNICODE}inline;{$endif} // Delphi 2007 is buggy as hell
+
+/// compute elapsed time into a human readable value, from a Start value
+// - will get current QueryPerformanceMicroSeconds() and compute against Start
+// - append 'us', 'ms', 's', 'm', 'h' and 'd' symbol for the given value range,
+// with two fractional digits
+function MicroSecFrom(Start: QWord): TShort16;
+  {$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 a nano seconds elapsed time into a human readable value
+// - append 'ns', 'us', 'ms', 's', 'm', 'h' and 'd' symbol for the given value
+// range, with two fractional digits
+procedure NanoSecToString(Nano: QWord; out result: TShort16);
+
+/// convert "valueunit" values into x or x.xx text with up to 2 digits
+// - supplied value should be the actual unit value * 100
+procedure By100ToTwoDigitString(value: cardinal; const valueunit: ShortString;
+  var result: TShort16);
+
+/// 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;
+
+
+{ ************ ESynException class }
+
+{$ifndef NOEXCEPTIONINTERCEPT}
+
+type
+  /// 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;
+
+var
+  /// allow to customize the ESynException logging message
+  TSynLogExceptionToStrCustom: TSynLogExceptionToStr = nil;
+
+/// the default Exception handler for logging
+// - defined here to be called e.g. by ESynException.CustomLog() as default
+function DefaultSynLogExceptionToStr(WR: TTextWriter;
+  const Context: TSynLogExceptionContext): boolean;
+
+{$endif NOEXCEPTIONINTERCEPT}
+
+
+type
+  {$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;
+    fMessageUtf8: RawUtf8;
+    procedure CreateAfterSetMessageUtf8; virtual;
+  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 will accept RawUtf8 instead of string as message text
+    constructor CreateU(const Msg: RawUtf8);
+    /// constructor appending some FormatUtf8() content to the GetLastError
+    // - message will contain GetLastError value followed by the formatted text
+    // - expect % as delimiter, so is less error prone than %s %d %g
+    // - will handle vtPointer/vtClass/vtObject/vtVariant kind of arguments,
+    // appending class name for any class or object, the hexa value for a
+    // pointer, or the JSON representation of any supplied TDocVariant
+    constructor CreateLastOSError(const Format: RawUtf8; const Args: array of const;
+      const Trailer: ShortString = 'OSError');
+    {$ifndef NOEXCEPTIONINTERCEPT}
+    /// can be used to customize how the exception is logged
+    // - this default implementation will call the TSynLogExceptionToStrCustom
+    // global callback, if defined, or a default handler internal to this unit
+    // - 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 NOEXCEPTIONINTERCEPT}
+    /// the code location when this exception was triggered
+    // - populated by mormot.core.log unit, during interception - so may be nil
+    // - you can use TDebugFile.FindLocation(ESynException) class function to
+    // guess the corresponding source code line
+    // - will be serialized as "Address": hexadecimal and source code location,
+    // using TDebugFile .map/.dbg/.mab information, by JSON WriteObject
+    // when woStorePointer option is defined - e.g. with ObjectToJsonDebug()
+    property RaisedAt: pointer
+      read fRaisedAt write fRaisedAt;
+    /// the Exception Message UTF-8 text, as generated by CreateUtf8()
+    property MessageUtf8: RawUtf8
+      read fMessageUtf8;
+  published
+    /// the Exception Message string, as defined in parent Exception class
+    property Message;
+  end;
+  {$M-}
+
+  /// meta-class of the ESynException hierarchy
+  ESynExceptionClass = class of ESynException;
+
+/// convert any HTTP_* constant to an integer error code and its English text
+// - returns e.g. 'HTTP Error 404 - Not Found', calling StatusCodeToText()
+function StatusCodeToErrorMsg(Code: integer): RawUtf8;
+
+
+{ **************** Hexadecimal Text And Binary Conversion }
+
+type
+  /// type of a lookup table used for fast hexadecimal conversion
+  THexToDualByte = packed array[0..511] of byte;
+  /// type of a lookup table used for fast XML/HTML conversion
+  TAnsiCharToByte = array[AnsiChar] of byte;
+  PAnsiCharToByte = ^TAnsiCharToByte;
+  /// type of a lookup table used for fast two-digit chars conversion
+  TAnsiCharToWord = array[AnsiChar] of word;
+  PAnsiCharToWord = ^TAnsiCharToWord;
+  /// type of a lookup table used for fast two-digit chars conversion
+  TByteToWord = array[byte] of word;
+  PByteToWord = ^TByteToWord;
+
+var
+  /// a conversion table from hexa chars into binary data
+  // - [0..255] range maps the 0..15 binary, [256..511] maps 0..15 binary shl 4
+  // - 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: THexToDualByte;
+
+  /// 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: TByteToWord absolute TwoDigitsHex;
+  /// lowercase hexadecimal lookup table
+  TwoDigitsHexLower: array[byte] of array[1..2] of AnsiChar;
+  TwoDigitsHexWLower: TAnsiCharToWord absolute TwoDigitsHexLower;
+  TwoDigitsHexWBLower: TByteToWord absolute TwoDigitsHexLower;
+
+/// 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: PtrInt): boolean; overload;
+
+/// fast conversion with no validity check from hexa chars into binary data
+procedure HexToBinFast(Hex: PAnsiChar; Bin: PByte; BinBytes: PtrInt);
+
+/// 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; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// internal conversion from hexa pair into a AnsiChar for PIC, ARM and x86_64
+function HexToCharValid(Hex: PAnsiChar; HexToBin: PByteArray): boolean; overload;
+  {$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: PtrInt): 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; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// internal conversion from hexa pair into a AnsiChar for PIC, ARM and x86_64
+function HexToChar(Hex: PAnsiChar; Bin: PUtf8Char; HexToBin: PByteArray): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast conversion from two hexa bytes into a 16-bit UTF-16 WideChar
+// - as used by JsonUnicodeEscapeToUtf8() for \u#### chars unescape
+// - similar to HexDisplayToBin(Hex,@wordvar,2)
+// - returns 0 on malformated input
+function HexToWideChar(Hex: PUtf8Char): 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: PtrInt); overload;
+
+/// fast conversion from hexa chars into binary data
+function HexToBin(const Hex: RawUtf8): RawByteString; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast conversion from hexa chars into binary data
+function HexToBin(Hex: PAnsiChar; HexLen: PtrInt;
+  var Bin: RawByteString): boolean; overload;
+
+/// fast conversion from ToHumanHex() hexa chars into binary data
+function HumanHexToBin(const hex: RawUtf8; var Bin: RawByteString): boolean; overload;
+
+/// fast conversion from ToHumanHex() hexa chars into binary data
+function HumanHexToBin(const hex: RawUtf8): RawByteString; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast comparison between two ToHumanHex() hexa values
+function HumanHexCompare(const a, b: RawUtf8): integer; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast comparison between two ToHumanHex() hexa values
+function HumanHexCompare(a, b: PUtf8Char): integer; 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: PtrInt): 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: PtrInt); overload;
+
+/// fast conversion from binary data into hexa chars, ready to be displayed
+function BinToHexDisplay(Bin: PAnsiChar; BinBytes: PtrInt): 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: PtrInt); 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: PtrInt): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast conversion from binary data into lowercase hexa chars
+procedure BinToHexLower(Bin: PAnsiChar; BinBytes: PtrInt; 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: PtrInt): RawUtf8; overload;
+
+/// fast conversion from up to 127 bytes of binary data into lowercase hexa chars
+function BinToHexDisplayLowerShort(Bin: PAnsiChar; BinBytes: PtrInt): ShortString;
+
+/// fast conversion from up to 64-bit of binary data into lowercase hexa chars
+function BinToHexDisplayLowerShort16(Bin: Int64; BinBytes: PtrInt): TShort16;
+
+/// fast conversion from up to 64-bit of binary data into lowercase hexa chars
+// - warning: here binary size is in bits (typically 1..64), not bytes
+procedure BinBitsToHexDisplayLowerShort16(Bin: Int64; BinBits: PtrInt;
+  var Result: TShort16);
+
+/// fast conversion from binary data into hexa lowercase chars, ready to be
+// used as a convenient TFileName prefix
+function BinToHexDisplayFile(Bin: PAnsiChar; BinBytes: PtrInt): TFileName;
+
+/// append one byte as hexadecimal char pairs, into a text buffer
+function ByteToHex(P: PAnsiChar; Value: byte): PAnsiChar;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast conversion from a pointer data into hexa chars, ready to be displayed
+// - use internally BinToHexDisplay()
+function PointerToHex(aPointer: Pointer): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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 DisplayMinChars() and 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;
+
+/// compute the hexadecimal representation of the crc32 checkum of a given text
+// - wrapper around CardinalToHex(crc32c(...))
+function crc32cUtf8ToHex(const str: RawUtf8): RawUtf8;
+
+/// 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 for up to 256-bit of little-endian input into non-zero hexa
+// - Len should be <= 32 bytes, to fit in a TShort64 result
+// - use internally DisplayMinChars() and BinToHexDisplay()
+function ToHexShort(P: pointer; Len: PtrInt): TShort64;
+
+/// fast conversion from a pointer data into hexa chars, ready to be displayed
+// - use internally DisplayMinChars() and BinToHexDisplay()
+function Int64ToHexLower(aInt64: Int64): RawUtf8; 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 in reverse order into a binary buffer
+function HexDisplayToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: PtrInt): boolean;
+
+/// fast conversion from hexa chars in reverse order 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;
+  {$ifdef ISDELPHI}{$ifdef HASINLINE}inline;{$endif}{$endif}
+  // inline gives an error under release conditions with (old?) FPC
+
+/// fast conversion from hexa chars in reverse order 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;
+    {$ifdef ISDELPHI}{$ifdef HASINLINE}inline;{$endif}{$endif}
+    { inline gives an error under release conditions with FPC }
+
+/// fast conversion from hexa chars in reverse order 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}
+
+/// conversion from octal C-like escape into binary data
+// - \xxx is converted into a single xxx byte from octal, and \\ into \
+// - will stop the conversion when Oct^=#0 or when invalid \xxx is reached
+// - returns the number of bytes written to Bin^
+function OctToBin(Oct: PAnsiChar; Bin: PByte): PtrInt; overload;
+
+/// conversion from octal C-like escape into binary data
+// - \xxx is converted into a single xxx byte from octal, and \\ into \
+function OctToBin(const Oct: RawUtf8): RawByteString; overload;
+
+/// append a TGuid binary content as 36 chars 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 38 chars encoded { text } as RawUtf8
+// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {})
+// - if you do not need the embracing { }, use ToUtf8() overloaded function
+function GuidToRawUtf8(const guid: TGuid): RawUtf8;
+
+/// convert a TGuid into 36 chars encoded text as RawUtf8
+// - will return e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without the {})
+// - if you need the embracing { }, use GuidToRawUtf8() function instead
+function ToUtf8(const guid: TGuid): RawUtf8; overload;
+
+/// convert a TGuid into into 38 chars encoded { text } as RTL string
+// - will return e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {})
+// - this version is faster than the one supplied by SysUtils
+function GuidToString(const guid: TGuid): string;
+
+type
+  /// stack-allocated ASCII string, used by GuidToShort() function
+  TGuidShortString = string[38];
+  PGuidShortString = ^TGuidShortString;
+
+/// 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(const 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(const
+  guid: TGuid; out dest: TGuidShortString); overload;
+
+/// convert some text into its TGuid binary value
+// - expect e.g. '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without any {}) but
+// will ignore internal '-' so '3F2504E04F8911D39A0C0305E82C3301' is also fine
+// - note: TGuid binary order does not follow plain HexToBin or HexDisplayToBin
+// - return nil if the supplied text buffer is not a valid TGuid
+// - this will be the format used for JSON encoding, e.g.
+// $ { "Uid": "C9A646D3-9C61-4CB7-BFCD-EE2522C8F633" }
+function TextToGuid(P: PUtf8Char; Guid: PByteArray): PUtf8Char;
+
+/// convert some RTL string 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 {})
+// or '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without the {}) or even
+// '3F2504E04F8911D39A0C0305E82C3301' following TGuid order (not HexToBin)
+// - return {00000000-0000-0000-0000-000000000000} if the supplied text buffer
+// is not a valid TGuid
+function RawUtf8ToGuid(const text: RawByteString): TGuid; overload;
+
+/// convert some UTF-8 encoded text into a TGuid
+// - expect e.g. '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' (with the {})
+// or '3F2504E0-4F89-11D3-9A0C-0305E82C3301' (without the {}) or even
+// '3F2504E04F8911D39A0C0305E82C3301' following TGuid order (not HexToBin)
+function RawUtf8ToGuid(const text: RawByteString; out guid: TGuid): boolean; overload;
+
+/// trim any space and '{' '-' '}' chars from input to get a 32-char TGuid hexa
+// - change in-place the text into lowercase hexadecimal
+// - returns true if resulting text is a 128-bit cleaned hexa, false otherwise
+function TrimGuid(var text: RawUtf8): boolean;
+
+/// 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; aSize: Int64 = -1;
+  aCodePage: integer = CP_RAWBYTESTRING): RawByteString;
+
+/// iterative function to retrieve the new content appended to a stream
+// - aPosition should be set to 0 before the initial call
+function StreamChangeToRawByteString(
+  aStream: TStream; var aPosition: Int64): 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 UTF-8 text from a TStream saved with len prefix by WriteStringToStream
+// - format is Length(integer):Text - use StreamToRawByteString for raw data
+// - 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 with a len prefix - see ReadStringFromStream
+// - format is Length(integer):Text - use RawByteStringToStream for raw data
+function WriteStringToStream(S: TStream; const Text: RawUtf8): boolean;
+
+
+implementation
+
+{$ifdef FPC}
+  // globally disable some FPC paranoid warnings - rely on x86_64 as reference
+  {$WARN 4056 off : Conversion between ordinals and pointers is not portable }
+{$endif FPC}
+
+
+{ ************ CSV-like Iterations over Text Buffers }
+
+function IdemPCharAndGetNextItem(var source: PUtf8Char; const searchUp: RawUtf8;
+  var Item: RawUtf8; Sep: AnsiChar): boolean;
+begin
+  if source <> nil then
+    if IdemPChar(source, Pointer(searchUp)) then
+    begin
+      inc(source, Length(searchUp));
+      GetNextItem(source, Sep, Item);
+      result := true;
+      exit;
+    end;
+  result := false;
+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;
+    {$ifdef CPUINTEL}
+    S := PosChar(S, Sep); // SSE2 asm on i386 and x86_64
+    if S = nil then
+      S := P + mormot.core.base.StrLen(P);
+    {$else}
+    while (S^ <> #0) and
+          (S^ <> Sep) do
+      inc(S);
+    {$endif CPUINTEL}
+    FastSetString(result, P, S - P);
+    if S^ <> #0 then
+      P := S + 1
+    else
+      P := nil;
+  end;
+end;
+
+function GetNextItemMultiple(var P: PUtf8Char; const Sep: RawUtf8;
+  var Next: RawUtf8): AnsiChar;
+var
+  len: PtrInt;
+begin
+  if P = nil then
+  begin
+    Next := '';
+    result := #0;
+  end
+  else
+  begin
+    len := strcspn(P, pointer(Sep)); // search size of P which are not in Sep
+    FastSetString(Next, P, len);
+    inc(P, len);
+    result := P^;
+    if result <> #0 then
+      inc(P)
+    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
+      P := nil
+    else
+      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;
+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 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;
+
+procedure AppendCsvValues(const Csv: string; const Values: array of string;
+  var Result: string; const AppendBefore: string);
+var
+  s: 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
+    s := 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 + s + ': ';
+      if bool < 0 then
+        Result := Result + Values[i]
+      else
+        Result := Result + GetCsvItemString(pointer(GetNextItemString(P)), bool, '/');
+    end;
+  end;
+end;
+
+procedure GetNextItemShortString(var P: PUtf8Char; Dest: PShortString; Sep: AnsiChar);
+var
+  S, D: PUtf8Char;
+  c: AnsiChar;
+  len: PtrInt;
+begin
+  S := P;
+  D := pointer(Dest); // better FPC codegen with a dedicated variable
+  if S <> nil then
+  begin
+    len := 0;
+    if S^ <= ' ' then
+      while (S^ <= ' ') and
+            (S^ <> #0) do
+        inc(S); // trim left space
+    repeat
+      c := S^;
+      inc(S);
+      if c = Sep then
+        break;
+      if c <> #0 then
+        if len < 254 then // avoid shortstring buffer overflow
+        begin
+          inc(len);
+          D[len] := c;
+          continue;
+        end
+        else
+          len := 0;
+      S := nil; // reached #0: end of input
+      break;
+    until false;
+    if len <> 0 then
+      repeat
+        if D[len] >= ' ' then
+          break;
+        dec(len); // trim right space
+      until len = 0;
+    D[0] := AnsiChar(len);
+    D[len + 1] := #0; // trailing #0
+    P := S;
+  end
+  else
+    PCardinal(D)^ := 0 // Dest='' with trailing #0
+end;
+
+function GetNextItemHexDisplayToBin(var P: PUtf8Char;
+  Bin: PByte; BinBytes: PtrInt; Sep: AnsiChar): boolean;
+var
+  S: PUtf8Char;
+  len: integer;
+begin
+  result := false;
+  FillCharFast(Bin^, BinBytes, 0);
+  if P = nil then
+    exit;
+  while (P^ <= ' ') and
+        (P^ <> #0) do
+    inc(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
+      inc(P); // go to end of CSV item (ignore any decimal)
+  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: PtrUInt;
+  i: cardinal;
+  P: PAnsiChar;
+begin
+  // CsvOfValue('?',3)='?,?,?'
+  result := '';
+  if Count = 0 then
+    exit;
+  ValueLen := length(Value);
+  SepLen := Length(Sep);
+  FastSetString(result, ValueLen * Count + SepLen * pred(Count));
+  P := pointer(result);
+  i := 1;
+  repeat
+    if ValueLen = 1 then
+    begin
+      P^ := Value[1]; // optimized for the Value='?' common case
+      inc(P);
+    end
+    else
+    begin
+      MoveFast(Pointer(Value)^, P^, ValueLen);
+      inc(P, ValueLen);
+    end;
+    if i = Count then
+      break;
+    if SepLen = 1 then
+    begin
+      P^ := Sep[1]; // optimized for the Sep=',' most common case
+      inc(P);
+      inc(i);
+    end
+    else if SepLen > 0 then
+    begin
+      MoveFast(Pointer(Sep)^, P^, SepLen);
+      inc(P, SepLen);
+      inc(i);
+    end;
+  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 i < BitsCount do
+    if GetBitPtr(@Bits, i) then
+    begin
+      j := i;
+      while (j + 1 < BitsCount) and
+            GetBitPtr(@Bits, j + 1) do
+        inc(j);
+      result := result + UInt32ToUtf8(i + 1);
+      if j = i then
+        result := result + ','
+      else if j = i + 1 then
+        result := result + ',' + UInt32ToUtf8(j + 1) + ','
+      else
+        result := result + '-' + UInt32ToUtf8(j + 1) + ',';
+      i := j + 1;
+    end
+    else
+      inc(i);
+  result := result + '0'; // '0' marks end of list
+end;
+
+function GetNextItemCardinalW(var P: PWideChar; Sep: WideChar): PtrUInt;
+var
+  c: PtrUInt;
+begin
+  if P = nil then
+  begin
+    result := 0;
+    exit;
+  end;
+  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;
+  while (P^ <> #0) and
+        (P^ <> Sep) do // go to end of CSV item (ignore any decimal)
+    inc(P);
+  if P^ = #0 then
+    P := nil
+  else
+    inc(P);
+end;
+
+function GetNextItemInteger(var P: PUtf8Char; Sep: AnsiChar): PtrInt;
+var
+  minus: boolean;
+begin
+  if P = nil then
+  begin
+    result := 0;
+    exit;
+  end;
+  if P^ = ' ' then
+    repeat
+      inc(P)
+    until P^ <> ' ';
+  if P^ in ['+', '-'] then
+  begin
+    minus := P^ = '-';
+    inc(P);
+  end
+  else
+    minus := false;
+  result := PtrInt(GetNextItemCardinal(P, Sep));
+  if minus then
+    result := -result;
+end;
+
+function GetNextTChar64(var P: PUtf8Char; Sep: AnsiChar; out Buf: TChar64): PtrInt;
+var
+  S: PUtf8Char;
+  c: AnsiChar;
+begin
+  result := 0;
+  S := P;
+  if S = nil then
+    exit;
+  if Sep = #0 then
+    repeat // store up to next whitespace
+      c := S[result];
+      if c <= ' ' then
+        break;
+      Buf[result] := c;
+      inc(result);
+      if result >= SizeOf(Buf) then
+        exit; // avoid buffer overflow
+    until false
+  else
+    repeat // store up to Sep or end of string
+      c := S[result];
+      if (c = #0) or
+         (c = Sep) then
+        break;
+      Buf[result] := c;
+      inc(result);
+      if result >= SizeOf(Buf) then
+        exit; // avoid buffer overflow
+    until false;
+  Buf[result] := #0; // make asciiz
+  inc(S, result); // S[result]=Sep or #0
+  if S^ = #0 then
+    P := nil
+  else if Sep = #0 then
+    P := S
+  else
+    P := S + 1;
+end;
+
+{$ifdef CPU64}
+
+function GetNextItemInt64(var P: PUtf8Char; Sep: AnsiChar): Int64;
+begin
+  result := GetNextItemInteger(P, Sep); // PtrInt=Int64
+end;
+
+function GetNextItemQWord(var P: PUtf8Char; Sep: AnsiChar): QWord;
+begin
+  result := GetNextItemCardinal(P, Sep); // PtrUInt=QWord
+end;
+
+{$else}
+
+function GetNextItemInt64(var P: PUtf8Char; Sep: AnsiChar): Int64;
+var
+  tmp: TChar64;
+begin
+  if GetNextTChar64(P, Sep, tmp) > 0 then
+    SetInt64(tmp, result)
+  else
+    result := 0;
+end;
+
+function GetNextItemQWord(var P: PUtf8Char; Sep: AnsiChar): QWord;
+var
+  tmp: TChar64;
+begin
+  if GetNextTChar64(P, Sep, tmp) > 0 then
+    SetQWord(tmp, result)
+  else
+    result := 0;
+end;
+
+{$endif CPU64}
+
+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 GetFirstCsvItem(const Csv: RawUtf8; Sep: AnsiChar): RawUtf8;
+var
+  i: PtrInt;
+begin
+  i := PosExChar(Sep, Csv);
+  if i = 0 then
+    result := Csv
+  else
+    FastSetString(result, pointer(Csv), i - 1);
+end;
+
+function GetLastCsvItem(const Csv: RawUtf8; Sep: AnsiChar): RawUtf8;
+begin
+  result := SplitRight(Csv, Sep, nil);
+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 CsvContains(const Csv, Value: RawUtf8; Sep: AnsiChar;
+  CaseSensitive: boolean): boolean;
+var
+  i, l: PtrInt;
+  p, s: PUtf8Char;
+  match: TIdemPropNameUSameLen;
+begin
+  if (Csv = '') or
+     (Value = '') then
+  begin
+    result := false;
+    exit;
+  end;
+  // note: all search sub-functions do use fast SSE2 asm on i386 and x86_64
+  match := IdemPropNameUSameLen[CaseSensitive];
+  p := pointer(Csv);
+  l := PStrLen(PAnsiChar(pointer(Value)) - _STRLEN)^;
+  if l >= PStrLen(p - _STRLEN)^ then
+    result := (l = PStrLen(p - _STRLEN)^) and
+              match(p, pointer(Value), l)
+  else
+  begin
+    i := PosExChar(Sep, Csv);
+    if i <> 0 then
+    begin
+      result := true;
+      s := p + i - 1;
+      repeat
+        if (s - p = l) and
+           match(p, pointer(Value), l) then
+          exit;
+        p := s + 1;
+        s := PosChar(p, Sep);
+        if s <> nil then
+          continue;
+        if (PStrLen(PAnsiChar(pointer(Csv)) - _STRLEN)^ - (p - pointer(Csv)) = l) and
+           match(p, pointer(Value), l) then
+          exit;
+        break;
+      until false;
+    end;
+    result := false;
+  end;
+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
+      TrimSelf(s);
+    if CaseSensitive then
+    begin
+      if SortDynArrayRawByteString(s, Value) = 0 then
+        exit;
+    end
+    else if SameTextU(s, Value) then
+      exit;
+    inc(result);
+  end;
+  result := -1; // not found
+end;
+
+procedure CsvToRawUtf8DynArray(Csv: PUtf8Char; var List: TRawUtf8DynArray;
+  Sep: AnsiChar; TrimItems, AddVoidItems: boolean; Quote: AnsiChar);
+var
+  s: RawUtf8;
+  n: integer;
+begin
+  n := length(List);
+  while (Csv <> nil) and
+        (Csv^ <> #0) do
+  begin
+    if Quote <> #0 then
+    begin
+      GetNextItem(Csv, Sep, Quote, s);
+      if TrimItems then
+        TrimSelf(s);
+    end
+    else if TrimItems then
+      GetNextItemTrimed(Csv, Sep, s)
+    else
+      GetNextItem(Csv, Sep, s);
+    if (s <> '') or
+       AddVoidItems then
+      AddRawUtf8(List, n, s);
+  end;
+  if List <> nil then
+    DynArrayFakeLength(List, n);
+end;
+
+procedure CsvToRawUtf8DynArray(const Csv, Sep, SepEnd: RawUtf8;
+  var List: TRawUtf8DynArray);
+var
+  offs, i, n: integer;
+  s: RawUtf8;
+begin
+  n := length(List);
+  offs := 1;
+  while offs <= length(Csv) do
+  begin
+    i := PosEx(Sep, Csv, offs);
+    if i = 0 then
+    begin
+      i := PosEx(SepEnd, Csv, offs);
+      if i = 0 then
+        i := length(csv) + 1;
+      FastSetString(s, @PByteArray(Csv)[offs - 1], i - offs);
+      AddRawUtf8(List, n, s);
+      break;
+    end;
+    FastSetString(s, @PByteArray(Csv)[offs - 1], i - offs);
+    AddRawUtf8(List, n, s);
+    offs := i + length(Sep);
+  end;
+  if List <> nil then
+    DynArrayFakeLength(List, n);
+end;
+
+function CsvToRawUtf8DynArray(const Csv, Sep, SepEnd: RawUtf8): TRawUtf8DynArray;
+begin
+  result := nil;
+  CsvToRawUtf8DynArray(Csv, Sep, SepEnd, result);
+end;
+
+function AddPrefixToCsv(Csv: PUtf8Char; const Prefix: RawUtf8; Sep: AnsiChar): RawUtf8;
+var
+  s: RawUtf8;
+begin
+  GetNextItem(Csv, Sep, result);
+  if result = '' then
+    exit;
+  result := Prefix + result;
+  while Csv <> nil do
+  begin
+    GetNextItem(Csv, Sep, s);
+    if s <> '' then
+      result := result + ',' + Prefix + s;
+  end;
+end;
+
+procedure AddToCsv(const Value: RawUtf8; var Csv: RawUtf8; const Sep: RawUtf8);
+begin
+  if Csv = '' then
+    Csv := Value
+  else
+    Csv := Csv + Sep + Value;
+end;
+
+function RenameInCsv(const OldValue, NewValue: RawUtf8; var Csv: RawUtf8;
+  const Sep: RawUtf8): boolean;
+var
+  pattern: RawUtf8;
+  i, j: integer;
+begin
+  result := OldValue = NewValue;
+  i := length(OldValue);
+  if result or
+     (length(Sep) <> 1) or
+     (length(Csv) < i) or
+     (PosEx(Sep, OldValue) > 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 CsvGuessSeparator(const Csv: RawUtf8): AnsiChar;
+begin
+  if PosExChar(#9, Csv) <> 0 then
+    result := #9
+  else if PosExChar(';', Csv) <> 0 then
+    result := ';'
+  else if PosExChar(',', Csv) <> 0 then
+    result := ','
+  else
+    result := #0;
+end;
+
+function RawUtf8ArrayToCsv(const Values: array of RawUtf8; const Sep: RawUtf8;
+  HighValues: integer): RawUtf8;
+var
+  i, len, seplen, L: integer;
+  P: PAnsiChar;
+begin
+  result := '';
+  if HighValues < 0 then
+    HighValues := high(Values);
+  if HighValues < 0 then
+    exit;
+  seplen := length(Sep);
+  len := seplen * HighValues;
+  for i := 0 to HighValues do
+    inc(len, length(Values[i]));
+  FastSetString(result, len); // allocate the result buffer as once
+  P := pointer(result);
+  i := 0;
+  repeat
+    L := length(Values[i]);
+    if L > 0 then
+    begin
+      MoveFast(pointer(Values[i])^, P^, L);
+      inc(P, L);
+    end;
+    if i = HighValues then
+      break;
+    if seplen > 0 then
+    begin
+      MoveFast(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
+    QuotedStr(Values[i], Quote, tmp[i]);
+  result := RawUtf8ArrayToCsv(tmp, Sep);
+end;
+
+procedure CsvToIntegerDynArray(Csv: PUtf8Char; var List: TIntegerDynArray;
+  Sep: AnsiChar);
+var
+  n: integer;
+begin
+  n := length(List);
+  while (Csv <> nil) and
+        (Csv^ <> #0) do
+    AddInteger(List, n, GetNextItemInteger(Csv, Sep));
+  if List <> nil then
+    DynArrayFakeLength(List, n);
+end;
+
+procedure CsvToInt64DynArray(Csv: PUtf8Char; var List: TInt64DynArray;
+  Sep: AnsiChar);
+var
+  n: integer;
+begin
+  n := length(List);
+  while (Csv <> nil) and
+        (Csv^ <> #0) do
+    AddInt64(List, n, GetNextItemInt64(Csv, Sep));
+  if List <> nil then
+    DynArrayFakeLength(List, n);
+end;
+
+function CsvToInt64DynArray(Csv: PUtf8Char; Sep: AnsiChar): TInt64DynArray;
+var
+  n: integer;
+begin
+  result := nil;
+  n := 0;
+  while (Csv <> nil) and
+        (Csv^ <> #0) do
+    AddInt64(result, n, GetNextItemInt64(Csv, Sep));
+  if result <> nil then
+    DynArrayFakeLength(result, n);
+end;
+
+const // first byte is the len, then 20 bytes buffer for the 64-bit integer text
+  I2T_SIZE = 21; // as TSynTempBuffer = up to 194 integers on stack
+
+procedure IntToText(int: PAnsiChar; len, n: PtrInt; const pref, suf: RawUtf8;
+  inlin: boolean; sep: AnsiChar; var result: RawUtf8);
+var
+  L: PtrUInt;
+  P: PAnsiChar;
+begin
+  inc(len, (n - 1) + length(pref) + length(suf));
+  if inlin then
+    inc(len, n * 4); // :( ): markers
+  FastSetString(result, len);
+  P := pointer(result);
+  if pref <> '' then
+  begin
+    L := length(pref);
+    MoveFast(pointer(pref)^, P^, L);
+    inc(P, L);
+  end;
+  if inlin then
+    repeat
+      PCardinal(P)^ := ord(':') + ord('(') shl 8;
+      inc(P, 2);
+      MoveFast(int[I2T_SIZE - ord(int^)], P^, ord(int^));
+      inc(P, ord(int^));
+      PCardinal(P)^ := ord(')') + ord(':') shl 8;
+      inc(P, 2);
+      dec(n);
+      if n = 0 then
+        break;
+      inc(int, I2T_SIZE);
+      P^ := sep;
+      inc(P);
+    until false
+  else
+    repeat
+      L := ord(int^);
+      MoveFast(PAnsiChar(int)[I2T_SIZE - L], P^, L);
+      inc(P, L);
+      dec(n);
+      if n = 0 then
+        break;
+      inc(int, I2T_SIZE);
+      P^ := sep;
+      inc(P);
+    until false;
+  if suf <> '' then
+    MoveFast(pointer(suf)^, P^, length(suf));
+end;
+
+function IntegerDynArrayToCsv(Values: PIntegerArray; ValuesCount: integer;
+  const Prefix, Suffix: RawUtf8; InlinedValue: boolean; SepChar: AnsiChar): RawUtf8;
+var
+  i, L, Len: PtrInt;
+  int, P: PAnsiChar;
+  temp: TSynTempBuffer; // faster than a dynamic array
+begin
+  result := '';
+  if ValuesCount = 0 then
+    exit;
+  int := temp.Init(ValuesCount * I2T_SIZE);
+  try
+    Len := 0;
+    for i := 0 to ValuesCount - 1 do
+    begin
+      P := StrInt32(int + I2T_SIZE, Values[i]);
+      L := int + I2T_SIZE - P;
+      int^ := AnsiChar(L);
+      inc(Len, L);
+      inc(int, I2T_SIZE);
+    end;
+    IntToText(temp.buf, Len, ValuesCount, Prefix, Suffix, InlinedValue, SepChar, result);
+  finally
+    temp.Done;
+  end;
+end;
+
+function Int64DynArrayToCsv(Values: PInt64Array; ValuesCount: integer;
+  const Prefix, Suffix: RawUtf8; InlinedValue: boolean; SepChar: AnsiChar): RawUtf8;
+var
+  i, L, Len: PtrInt;
+  int, P: PAnsiChar;
+  temp: TSynTempBuffer; // faster than a dynamic array
+begin
+  result := '';
+  if ValuesCount = 0 then
+    exit;
+  int := temp.Init(ValuesCount * I2T_SIZE);
+  try
+    Len := 0;
+    for i := 0 to ValuesCount - 1 do
+    begin
+      P := StrInt64(int + I2T_SIZE, Values[i]);
+      L := int + I2T_SIZE - P;
+      int^ := AnsiChar(L);
+      inc(Len, L);
+      inc(int, I2T_SIZE);
+    end;
+    IntToText(temp.buf, Len, ValuesCount, Prefix, Suffix, InlinedValue, SepChar, result);
+  finally
+    temp.Done;
+  end;
+end;
+
+function IntegerDynArrayToCsv(const Values: TIntegerDynArray;
+  const Prefix, Suffix: RawUtf8; InlinedValue: boolean; SepChar: AnsiChar): RawUtf8;
+begin
+  result := IntegerDynArrayToCsv(pointer(Values), length(Values),
+    Prefix, Suffix, InlinedValue, SepChar);
+end;
+
+function Int64DynArrayToCsv(const Values: TInt64DynArray;
+  const Prefix, Suffix: RawUtf8; InlinedValue: boolean; SepChar: AnsiChar): RawUtf8;
+begin
+  result := Int64DynArrayToCsv(pointer(Values), length(Values),
+    Prefix, Suffix, InlinedValue, SepChar);
+end;
+
+
+{ ************ TTextWriter parent class for Text Generation }
+
+function HexToChar(Hex: PAnsiChar; Bin: PUtf8Char): boolean; // for inlining
+var
+  b, c: byte;
+  {$ifdef CPUX86NOTPIC}
+  tab: THexToDualByte absolute ConvertHexToBin;
+  {$else}
+  tab: PByteArray; // faster on PIC, ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  if Hex <> nil then
+  begin
+    {$ifndef CPUX86NOTPIC}
+    tab := @ConvertHexToBin;
+    {$endif CPUX86NOTPIC}
+    b := tab[ord(Hex[0]) + 256]; // + 256 for shl 4
+    c := tab[ord(Hex[1])];
+    if (b <> 255) and
+       (c <> 255) then
+    begin
+      if Bin <> nil then
+      begin
+        inc(c, b);
+        Bin^ := AnsiChar(c);
+      end;
+      result := true;
+      exit;
+    end;
+  end;
+  result := false; // return false if any invalid char
+end;
+
+
+{ TTextWriter }
+
+{$ifndef PUREMORMOT2}
+var
+  DefaultTextWriterTrimEnum: boolean; // see TTextWriter.SetDefaultEnumTrim()
+
+class procedure TTextWriter.SetDefaultEnumTrim(aShouldTrimEnumsAsText: boolean);
+begin
+  DefaultTextWriterTrimEnum := aShouldTrimEnumsAsText;
+end;
+{$endif PUREMORMOT2}
+
+procedure TTextWriter.InternalSetBuffer(aBuf: PUtf8Char; const aBufSize: PtrUInt);
+begin
+  fTempBufSize := aBufSize;
+  fTempBuf := aBuf;
+  dec(aBuf);
+  B := aBuf; // Add() methods will append at B+1
+  BEnd := @aBuf[aBufSize - 15]; // BEnd := B-16 to avoid overwrite/overread
+  {$ifndef PUREMORMOT2}
+  if DefaultTextWriterTrimEnum then
+    Include(fCustomOptions, twoTrimLeftEnumSets);
+  {$endif PUREMORMOT2}
+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;
+
+var
+  TextWriterSharedStreamSafe: TLightLock; // thread-safe instance acquisition
+  TextWriterSharedStream: TRawByteStringStream;
+
+constructor TTextWriter.CreateOwnedStream(
+  aBuf: pointer; aBufSize: integer; NoSharedStream: boolean);
+begin
+  if (not NoSharedStream) and TextWriterSharedStreamSafe.TryLock then
+    fStream := TextWriterSharedStream
+  else
+    fStream := TRawByteStringStream.Create; // inlined SetStream()
+  fCustomOptions := [twoStreamIsOwned, twoStreamIsRawByteString];
+  SetBuffer(aBuf, aBufSize); // aBuf may be nil
+end;
+
+constructor TTextWriter.CreateOwnedStream(aBufSize: integer; NoSharedStream: boolean);
+begin
+  CreateOwnedStream(nil, aBufSize, NoSharedStream);
+end;
+
+constructor TTextWriter.CreateOwnedStream(var aStackBuf: TTextWriterStackBuffer;
+  aBufSize: integer; NoSharedStream: boolean);
+begin
+  if aBufSize > SizeOf(aStackBuf) then // too small -> allocate on heap
+    CreateOwnedStream(nil, aBufSize, NoSharedStream)
+  else
+    CreateOwnedStream(aStackBuf, NoSharedStream);
+end;
+
+constructor TTextWriter.CreateOwnedStream(
+  var aStackBuf: TTextWriterStackBuffer; NoSharedStream: boolean);
+begin
+  if (not NoSharedStream) and TextWriterSharedStreamSafe.TryLock then
+    fStream := TextWriterSharedStream
+  else
+    fStream := TRawByteStringStream.Create; // inlined SetStream()
+  fCustomOptions := [twoStreamIsOwned, twoStreamIsRawByteString, twoBufferIsExternal];
+  InternalSetBuffer(@aStackBuf, SizeOf(aStackBuf));
+end;
+
+constructor TTextWriter.CreateOwnedFileStream(
+  const aFileName: TFileName; aBufSize: integer);
+begin
+  DeleteFile(aFileName);
+  fStream := TFileStreamEx.Create(aFileName, fmCreate or fmShareRead);
+  fCustomOptions := [twoStreamIsOwned];
+  SetBuffer(nil, aBufSize);
+end;
+
+destructor TTextWriter.Destroy;
+begin
+  if twoStreamIsOwned in fCustomOptions then
+    if fStream = TextWriterSharedStream then
+    begin
+      TRawByteStringStream(fStream).Clear; // for proper reuse
+      TextWriterSharedStreamSafe.UnLock;
+    end
+    else
+      fStream.Free;
+  if not (twoBufferIsExternal in fCustomOptions) then
+    FreeMem(fTempBuf);
+  inherited Destroy;
+end;
+
+function TTextWriter.PendingBytes: PtrUInt;
+begin
+  result := B - fTempBuf + 1;
+end;
+
+procedure TTextWriter.Add(c: AnsiChar);
+begin
+  if B >= BEnd then
+    FlushToStream; // may rewind B -> not worth any local PUtf8Char variable
+  B[1] := c;
+  inc(B);
+end;
+
+procedure TTextWriter.AddDirect(c: AnsiChar);
+begin
+  B[1] := c;
+  inc(B);
+end;
+
+procedure TTextWriter.AddDirect(c1, c2: AnsiChar);
+begin
+  PCardinal(B + 1)^ := byte(c1) + PtrUInt(byte(c2)) shl 8;
+  inc(B, 2); // with proper constant propagation above when inlined
+end;
+
+procedure TTextWriter.AddComma;
+begin
+  B[1] := ',';
+  inc(B);
+end;
+
+procedure TTextWriter.Add(c1, c2: AnsiChar);
+begin
+  if B >= BEnd then
+    FlushToStream;
+  PCardinal(B + 1)^ := byte(c1) + PtrUInt(byte(c2)) shl 8;
+  inc(B, 2); // with proper constant propagation above when inlined
+end;
+
+procedure TTextWriter.Add(const Format: RawUtf8; const Values: array of const;
+  Escape: TTextWriterKind; WriteObjectOptions: TTextWriterWriteObjectOptions);
+var
+  tmp: RawUtf8;
+begin
+  // basic implementation: see faster and more complete version in TJsonWriter
+  FormatUtf8(Format, Values, tmp);
+  case Escape of
+    twNone:
+      AddString(tmp);
+    twOnSameLine:
+      AddOnSameLine(pointer(tmp)); // minimalistic version for TSynLog
+    twJsonEscape:
+      raise ESynException.CreateUtf8(
+        '%.Add(twJsonEscape) unimplemented: use TJsonWriter', [self]);
+  end;
+end;
+
+procedure TTextWriter.AddVariant(const Value: variant; Escape: TTextWriterKind;
+  WriteOptions: TTextWriterWriteObjectOptions);
+begin
+  raise ESynException.CreateUtf8(
+    '%.AddVariant unimplemented: use TJsonWriter', [self]);
+end;
+
+procedure TTextWriter.AddTypedJson(Value, TypeInfo: pointer;
+  WriteOptions: TTextWriterWriteObjectOptions);
+begin
+  raise ESynException.CreateUtf8(
+    '%.AddTypedJson unimplemented: use TJsonWriter', [self]);
+end;
+
+function TTextWriter.{%H-}AddJsonReformat(Json: PUtf8Char;
+  Format: TTextWriterJsonFormat; EndOfObject: PUtf8Char): PUtf8Char;
+begin
+  raise ESynException.CreateUtf8(
+    '%.AddJsonReformat unimplemented: use TJsonWriter', [self]);
+end;
+
+procedure TTextWriter.Add(P: PUtf8Char; Escape: TTextWriterKind);
+begin
+  raise ESynException.CreateUtf8(
+    '%.Add(..,Escape: TTextWriterKind) unimplemented: use TJsonWriter', [self]);
+end;
+
+procedure TTextWriter.Add(P: PUtf8Char; Len: PtrInt; Escape: TTextWriterKind);
+begin
+  raise ESynException.CreateUtf8(
+    '%.Add(..,Escape: TTextWriterKind) unimplemented: use TJsonWriter', [self]);
+end;
+
+procedure TTextWriter.WrBase64(P: PAnsiChar; Len: PtrUInt; withMagic: boolean);
+begin
+  raise ESynException.CreateUtf8(
+    '%.WrBase64() unimplemented: use TJsonWriter', [self]);
+end;
+
+procedure TTextWriter.AddShorter(const Short8: TShort8);
+begin
+  if B >= BEnd then
+    FlushToStream;
+  PInt64(B + 1)^ := PInt64(@Short8[1])^;
+  inc(B, ord(Short8[0]));
+end;
+
+procedure TTextWriter.AddNull;
+begin
+  if B >= BEnd then
+    FlushToStream;
+  PCardinal(B + 1)^ := NULL_LOW;
+  inc(B, 4);
+end;
+
+procedure TTextWriter.WriteObject(Value: TObject;
+  WriteOptions: TTextWriterWriteObjectOptions);
+begin
+  raise ESynException.CreateUtf8(
+    '%.WriteObject unimplemented: use TJsonWriter', [self]);
+end;
+
+procedure TTextWriter.AddObjArrayJson(const aObjArray;
+  aOptions: TTextWriterWriteObjectOptions);
+var
+  i: PtrInt;
+  a: TObjectDynArray absolute aObjArray;
+begin
+  Add('[');
+  for i := 0 to length(a) - 1 do
+  begin
+    WriteObject(a[i], aOptions);
+    AddComma;
+  end;
+  CancelLastComma(']');
+end;
+
+procedure TTextWriter.WriteToStream(data: pointer; len: PtrUInt);
+var
+  written: PtrUInt;
+begin
+  if Assigned(fOnFlushToStream) then
+    fOnFlushToStream(data, len);
+  if (len <> 0) and
+     Assigned(fStream) then
+    repeat
+      written := fStream.Write(data^, len);
+      if PtrInt(written) <= 0 then
+        if twoNoWriteToStreamException in fCustomOptions then
+          break // silent failure
+        else
+          raise ESynException.CreateUtf8(
+            '%.WriteToStream failed on %', [self, fStream]);
+      inc(fTotalFileSize, written);
+      dec(len, written);
+      if len = 0 then
+        break;
+      inc(PByte(data), written); // several calls to Write() may be needed
+    until false;
+end;
+
+function TTextWriter.GetTextLength: PtrUInt;
+begin
+  result := PtrUInt(self);
+  if self <> nil then
+    result := PtrUInt(B - fTempBuf + 1) + fTotalFileSize - fInitialStreamPosition;
+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(aBuf, aBufSize)
+  else
+    Include(fCustomOptions, twoBufferIsExternal);
+  InternalSetBuffer(aBuf, aBufSize);
+end;
+
+procedure TTextWriter.SetStream(aStream: TStream);
+begin
+  exclude(fCustomOptions, twoStreamIsRawByteString);
+  if fStream <> nil then
+    if twoStreamIsOwned in fCustomOptions then
+    begin
+      if fStream = TextWriterSharedStream then
+      begin
+        TRawByteStringStream(fStream).Clear; // for proper reuse
+        TextWriterSharedStreamSafe.UnLock;
+        fStream := nil;
+      end
+      else
+        FreeAndNilSafe(fStream);
+      exclude(fCustomOptions, twoStreamIsOwned);
+    end;
+  if aStream = nil then
+    exit;
+  fStream := aStream;
+  fInitialStreamPosition := fStream.Position;
+  fTotalFileSize := fInitialStreamPosition;
+  if aStream.InheritsFrom(TRawByteStringStream) then
+    include(fCustomOptions, twoStreamIsRawByteString);
+end;
+
+procedure TTextWriter.FlushFinal;
+var
+  len: PtrInt;
+begin // don't mess with twoFlushToStreamNoAutoResize: it may not be final
+  len := B - fTempBuf + 1;
+  if len > 0 then
+    WriteToStream(fTempBuf, len);
+  B := fTempBuf - 1;
+end;
+
+procedure TTextWriter.FlushToStream;
+var
+  tmp, written: PtrUInt;
+begin
+  FlushFinal;
+  if twoFlushToStreamNoAutoResize in fCustomOptions then
+    exit;
+  written := fTotalFileSize - fInitialStreamPosition;
+  tmp := fTempBufSize;
+  if (tmp < 49152) and
+     (written > PtrUInt(tmp) * 4) then
+    // tune small (stack-allocated?) buffer to grow by twice its size
+    fTempBufSize := fTempBufSize * 2
+  else if (written > 40 shl 20) and
+          (tmp < 1 shl 20) then
+    // total > 40MB -> grow internal buffer to 1MB
+    fTempBufSize := 1 shl 20
+  else
+    // nothing to change about internal buffer size
+    exit;
+  if twoBufferIsExternal in fCustomOptions then
+    // use heap, not stack from now on
+    exclude(fCustomOptions, twoBufferIsExternal)
+  else
+    // from big content comes bigger buffer - but no need to realloc/move
+    FreeMem(fTempBuf);
+  GetMem(fTempBuf, fTempBufSize);
+  BEnd := fTempBuf + (fTempBufSize - 16); // as in SetBuffer()
+  B := fTempBuf - 1;
+end;
+
+procedure TTextWriter.ForceContent(const text: RawUtf8);
+begin
+  CancelAll;
+  if (fInitialStreamPosition = 0) and
+     (twoStreamIsRawByteString in fCustomOptions) then
+    TRawByteStringStream(fStream).DataString := text
+  else
+    fStream.WriteBuffer(pointer(text)^, length(text));
+  fTotalFileSize := fInitialStreamPosition + PtrUInt(length(text));
+end;
+
+procedure TTextWriter.SetText(var result: RawUtf8; reformat: TTextWriterJsonFormat);
+var
+  Len: PtrUInt;
+  temp: TTextWriter;
+begin
+  FlushFinal;
+  Len := fTotalFileSize - fInitialStreamPosition;
+  if Len = 0 then
+  begin
+    result := '';
+    exit;
+  end;
+  if twoStreamIsRawByteString in fCustomOptions then
+    TRawByteStringStream(fStream).GetAsText(fInitialStreamPosition, Len, result)
+  else if fStream.InheritsFrom(TCustomMemoryStream) then
+    with TCustomMemoryStream(fStream) do
+      FastSetString(result, PAnsiChar(Memory) + fInitialStreamPosition, Len)
+  else
+  begin
+    FastSetString(result, Len);
+    fStream.Seek(fInitialStreamPosition, soBeginning);
+    fStream.Read(pointer(result)^, Len);
+  end;
+  if reformat <> jsonCompact then
+  begin
+    // reformat using the very same temp buffer but not the same RawUtf8
+    temp := DefaultJsonWriter.CreateOwnedStream(fTempBuf, fTempBufSize);
+    try
+      temp.AddJsonReformat(pointer(result), reformat, nil);
+      temp.SetText(result);
+    finally
+      temp.Free;
+    end;
+  end;
+end;
+
+function TTextWriter.Text: RawUtf8;
+begin
+  SetText(result);
+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.CancelAllAsNew;
+begin
+  CancelAll;
+  fCustomOptions := fCustomOptions * TEXTWRITEROPTIONS_RESET;
+end;
+
+procedure TTextWriter.CancelAllWith(var temp: TTextWriterStackBuffer);
+begin
+  if fTotalFileSize <> 0 then
+    fTotalFileSize := fStream.Seek(fInitialStreamPosition, soBeginning);
+  InternalSetBuffer(@temp, SizeOf(temp));
+end;
+
+procedure TTextWriter.CancelLastChar(aCharToCancel: AnsiChar);
+var
+  P: PUtf8Char;
+begin
+  P := B;
+  if (P >= fTempBuf) and
+     (P^ = aCharToCancel) then
+    dec(B);
+end;
+
+procedure TTextWriter.CancelLastChar;
+begin
+  if B >= fTempBuf then // Add() methods append at B+1
+    dec(B);
+end;
+
+procedure TTextWriter.CancelLastComma;
+var
+  P: PUtf8Char;
+begin
+  P := B;
+  if (P >= fTempBuf) and
+     (P^ = ',') then
+    dec(B);
+end;
+
+procedure TTextWriter.CancelLastComma(aReplaceChar: AnsiChar);
+var
+  P: PUtf8Char;
+begin
+  P := B;
+  if (P < fTempBuf) or
+     (P^ <> ',') then
+  begin
+    inc(P);
+    B := P;
+  end;
+  P^ := aReplaceChar;
+end;
+
+function TTextWriter.LastChar: AnsiChar;
+begin
+  if B >= fTempBuf then
+    result := B^
+  else
+    result := #0;
+end;
+
+procedure TTextWriter.AddOnce(c: AnsiChar);
+begin
+  if (B >= fTempBuf) and
+     (B^ = c) then
+    exit; // no duplicate
+  if B >= BEnd then
+    FlushToStream;
+  B[1] := c;
+  inc(B);
+end;
+
+procedure TTextWriter.Add(Value: PtrInt);
+var
+  tmp: array[0..23] of AnsiChar;
+  P: PAnsiChar;
+  Len: PtrInt;
+begin
+  if BEnd - B <= 23 then
+    FlushToStream;
+  {$ifndef ASMINTEL} // our StrInt32 asm has less CPU cache pollution
+  if PtrUInt(Value) <= high(SmallUInt32Utf8) then
+  begin
+    P := pointer(SmallUInt32Utf8[Value]);
+    Len := PStrLen(P - _STRLEN)^;
+  end
+  else
+  {$endif ASMINTEL}
+  begin
+    P := StrInt32(@tmp[23], Value);
+    Len := @tmp[23] - P;
+  end;
+  MoveFast(P^, B[1], Len);
+  inc(B, Len);
+end;
+
+{$ifdef CPU32} // Add(Value: PtrInt) already implemented it for CPU64
+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
+  {$ifndef ASMINTEL} // our StrUInt32 asm has less CPU cache pollution
+  else if Value <= high(SmallUInt32Utf8) then
+  begin
+    P := pointer(SmallUInt32Utf8[Value]);
+    Len := PStrLen(P - _STRLEN)^;
+  end
+  {$endif ASMINTEL} // our StrInt32 asm has less CPU cache pollution
+  else
+  begin
+    P := StrUInt64(@tmp[23], Value);
+    Len := @tmp[23] - P;
+  end;
+  MoveByOne(P, B + 1, Len);
+  inc(B, Len);
+end;
+{$endif CPU32}
+
+procedure TTextWriter.AddCurr64(Value: PInt64);
+var
+  tmp: array[0..31] of AnsiChar;
+  P: PAnsiChar;
+  Len: PtrInt;
+begin
+  if BEnd - B <= 31 then
+    FlushToStream;
+  P := StrCurr64(@tmp[31], Value^);
+  Len := @tmp[31] - P;
+  if Len > 4 then
+    if P[Len - 1] = '0' then
+      if P[Len - 2] = '0' then
+        if P[Len - 3] = '0' then
+          if P[Len - 4] = '0' then
+            dec(Len, 5) // 'xxx.0000' -> 'xxx'
+          else
+            dec(Len, 3) // 'xxx.1000' -> 'xxx.1'
+        else
+          dec(Len, 2) // 'xxx.1200' -> 'xxx.12'
+      else
+        dec(Len); // 'xxx.1220' -> 'xxx.123'
+  MoveFast(P^, B[1], Len);
+  inc(B, Len);
+end;
+
+procedure TTextWriter.AddCurr(const Value: currency);
+begin
+  AddCurr64(PInt64(@Value));
+end;
+
+procedure TTextWriter.AddU(Value: cardinal);
+var
+  tmp: array[0..23] of AnsiChar;
+  P: PAnsiChar;
+  Len: PtrInt;
+begin
+  if BEnd - B <= 24 then
+    FlushToStream;
+  {$ifndef ASMINTEL} // our StrUInt32 asm has less CPU cache pollution
+  if Value <= high(SmallUInt32Utf8) then
+  begin
+    P := pointer(SmallUInt32Utf8[Value]);
+    Len := PStrLen(P - _STRLEN)^;
+  end
+  else
+  {$endif ASMINTEL}
+  begin
+    P := StrUInt32(@tmp[23], Value);
+    Len := @tmp[23] - P;
+  end;
+  MoveFast(P^, B[1], Len);
+  inc(B, Len);
+end;
+
+procedure TTextWriter.AddUHex(Value: cardinal; QuotedChar: AnsiChar);
+begin
+  AddBinToHexDisplayLower(@Value, SizeOf(Value), QuotedChar);
+end;
+
+procedure TTextWriter.AddQ(Value: QWord);
+var
+  tmp: array[0..23] of AnsiChar;
+  P: PAnsiChar;
+  Len: PtrInt;
+begin
+  if BEnd - B <= 32 then
+    FlushToStream;
+  {$ifndef ASMINTEL} // our StrInt32 asm has less CPU cache pollution
+  if Value <= high(SmallUInt32Utf8) then
+  begin
+    P := pointer(SmallUInt32Utf8[Value]);
+    Len := PStrLen(P - _STRLEN)^;
+  end
+  else
+  {$endif ASMINTEL}
+  begin
+    P := StrUInt64(@tmp[23], Value);
+    Len := @tmp[23] - P;
+  end;
+  MoveFast(P^, B[1], Len);
+  inc(B, Len);
+end;
+
+procedure TTextWriter.AddQHex(Value: Qword; QuotedChar: AnsiChar);
+begin
+  AddBinToHexDisplayLower(@Value, SizeOf(Value), QuotedChar);
+end;
+
+procedure TTextWriter.Add(Value: Extended; precision: integer; noexp: boolean);
+var
+  tmp: ShortString;
+begin
+  AddShort(ExtendedToJson(@tmp, Value, precision, noexp)^);
+end;
+
+procedure TTextWriter.AddDouble(Value: double; noexp: boolean);
+var
+  tmp: ShortString;
+begin
+  AddShort(DoubleToJson(@tmp, Value, noexp)^);
+end;
+
+procedure TTextWriter.AddSingle(Value: single; noexp: boolean);
+var
+  tmp: ShortString;
+begin
+  AddShort(ExtendedToJson(@tmp, Value, SINGLE_PRECISION, noexp)^);
+end;
+
+procedure TTextWriter.Add(Value: boolean);
+var
+  PS: PShortString;
+begin
+  if Value then // normalize: boolean may not be in the expected [0,1] range
+    PS := @BOOL_STR[true]
+  else
+    PS := @BOOL_STR[false];
+  AddShorter(PS^);
+end;
+
+procedure TTextWriter.AddFloatStr(P: PUtf8Char);
+begin
+  if mormot.core.base.StrLen(P) > 127 then
+    exit; // clearly invalid input
+  if BEnd - B <= 127 then
+    FlushToStream;
+  inc(B);
+  if P <> nil then
+    B := FloatStrCopy(P, B) - 1
+  else
+    B^ := '0';
+end;
+
+procedure TTextWriter.Add(Value: PGuid; QuotedChar: AnsiChar);
+begin
+  if BEnd - B <= 38 then
+    FlushToStream;
+  inc(B);
+  if QuotedChar <> #0 then
+  begin
+    B^ := QuotedChar;
+    inc(B);
+  end;
+  B := GuidToText(B, pointer(Value));
+  if QuotedChar <> #0 then
+    B^ := QuotedChar
+  else
+    dec(B);
+end;
+
+procedure TTextWriter.AddCR;
+begin
+  if B >= BEnd then
+    FlushToStream;
+  PCardinal(B + 1)^ := 13 + 10 shl 8; // CR + LF
+  inc(B, 2);
+end;
+
+procedure TTextWriter.AddCRAndIndent;
+var
+  ntabs: cardinal;
+begin
+  if B^ = #9 then
+    // we just already added an indentation level - do it once
+    exit;
+  ntabs := fHumanReadableLevel;
+  if ntabs >= cardinal(fTempBufSize) then
+    ntabs := 0; // fHumanReadableLevel=-1 after the last level of a document
+  if BEnd - B <= PtrInt(ntabs) then
+    FlushToStream;
+  PCardinal(B + 1)^ := 13 + 10 shl 8; // CR + LF
+  if ntabs > 0 then
+    FillCharFast(B[3], ntabs, 9); // #9=tab
+  inc(B, ntabs + 2);
+end;
+
+procedure TTextWriter.AddChars(aChar: AnsiChar; aCount: PtrInt);
+var
+  n: PtrInt;
+begin
+  while aCount > 0 do
+  begin
+    n := BEnd - B;
+    if n <= aCount then
+    begin
+      FlushToStream;
+      n := BEnd - B;
+    end;
+    if aCount < n then
+      n := aCount;
+    FillCharFast(B[1], n, ord(aChar));
+    inc(B, n);
+    dec(aCount, n);
+  end;
+end;
+
+procedure TTextWriter.Add2(Value: PtrUInt);
+begin
+  if B >= BEnd then
+    FlushToStream;
+  if Value > 99 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.Add3(Value: cardinal);
+var
+  V: cardinal;
+begin
+  if B >= BEnd then
+    FlushToStream;
+  if Value > 999 then
+    PCardinal(B + 1)^ := $303030 // '000,' if overflow
+  else
+  begin
+    V := Value div 10;
+    PCardinal(B + 1)^ := TwoDigitLookupW[V] + (Value - V * 10 + 48) shl 16;
+  end;
+  inc(B, 4);
+  B^ := ',';
+end;
+
+procedure TTextWriter.Add4(Value: PtrUInt);
+begin
+  if B >= BEnd then
+    FlushToStream;
+  if Value > 9999 then
+    PCardinal(B + 1)^ := $30303030 // '0000,' if overflow
+  else
+    YearToPChar(Value, B + 1);
+  inc(B, 5);
+  B^ := ',';
+end;
+
+function Value3Digits(V: cardinal; P: PUtf8Char; W: PWordArray): cardinal;
+  {$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(MicroSec: cardinal);
+var
+  W: PWordArray;
+begin
+  // in 00.000.000 TSynLog format
+  if B >= BEnd then
+    FlushToStream;
+  B[3] := '.';
+  B[7] := '.';
+  inc(B);
+  W := @TwoDigitLookupW;
+  MicroSec := Value3Digits(Value3Digits(MicroSec, B + 7, W), B + 3, W);
+  if MicroSec > 99 then
+    MicroSec := $3939
+  else
+    MicroSec := W[MicroSec];
+  PWord(B)^ := MicroSec;
+  inc(B, 9);
+end;
+
+procedure TTextWriter.AddCsvInteger(const Integers: array of integer);
+var
+  i: PtrInt;
+begin
+  if length(Integers) = 0 then
+    exit;
+  for i := 0 to high(Integers) do
+  begin
+    Add(Integers[i]);
+    AddComma;
+  end;
+  CancelLastComma;
+end;
+
+procedure TTextWriter.AddCsvDouble(const Doubles: array of double);
+var
+  i: PtrInt;
+begin
+  if length(Doubles) = 0 then
+    exit;
+  for i := 0 to high(Doubles) do
+  begin
+    AddDouble(Doubles[i]);
+    AddComma;
+  end;
+  CancelLastComma;
+end;
+
+procedure TTextWriter.AddNoJsonEscapeBig(P: Pointer; Len: PtrInt);
+var
+  direct: PtrInt;
+  D: PUtf8Char;
+  comma: boolean;
+begin
+  if (P <> nil) and
+     (Len > 0) then
+    if Len < fTempBufSize * 2 then
+      repeat
+        D := B + 1;
+        direct := BEnd - D; // guess biggest size available in fTempBuf at once
+        if direct > 0 then  // 0..-15 may happen because Add up to BEnd + 16
+        begin
+          if Len < direct then
+            direct := Len;
+          // append UTF-8 bytes to fTempBuf
+          if direct > 0 then
+          begin
+            MoveFast(P^, D^, direct);
+            inc(B, direct);
+          end;
+          dec(Len, direct);
+          if Len = 0 then
+            break;
+          inc(PByte(P), direct);
+        end;
+        FlushToStream;
+      until false
+    else
+    begin
+      FlushFinal; // no auto-resize if content is really huge
+      comma := PAnsiChar(P)[Len - 1] = ',';
+      if comma then
+        dec(Len);
+      WriteToStream(P, Len); // no need to transit huge content into fTempBuf
+      if comma then
+        AddDirect(','); // but we need the last comma to be cancelable
+    end;
+end;
+
+procedure TTextWriter.AddNoJsonEscape(P: Pointer; Len: PtrInt);
+begin
+  if (P <> nil) and
+     (Len > 0) then
+    if Len < fTempBufSize then // inlined for small chunk
+    begin
+      if BEnd - B <= Len then
+        FlushToStream;
+      MoveFast(P^, B[1], Len);
+      inc(B, Len);
+    end
+    else
+      AddNoJsonEscapeBig(P, Len); // big chunks
+end;
+
+procedure TTextWriter.AddNoJsonEscape(P: Pointer);
+begin
+  if P <> nil then
+    AddNoJsonEscape(P, mormot.core.base.StrLen(PUtf8Char(P)));
+end;
+
+procedure EngineAppendUtf8(W: TTextWriter; Engine: TSynAnsiConvert;
+  P: PAnsiChar; Len: PtrInt);
+var
+  tmp: TSynTempBuffer;
+begin
+  // explicit conversion using a temporary buffer on stack
+  Len := Engine.AnsiBufferToUtf8(tmp.Init(Len * 3), P, Len) - PUtf8Char({%H-}tmp.buf);
+  W.AddNoJsonEscape(tmp.buf, Len);
+  tmp.Done;
+end;
+
+procedure TTextWriter.AddNoJsonEscape(P: PAnsiChar; Len: PtrInt; CodePage: cardinal);
+var
+  B: PAnsiChar;
+begin
+  if Len > 0 then
+    case CodePage of
+      CP_UTF8, CP_RAWBYTESTRING, CP_RAWBLOB:
+        AddNoJsonEscape(P, Len);
+      CP_UTF16:
+        AddNoJsonEscapeW(PWord(P), 0);
+    else
+      begin
+        // first handle trailing 7-bit ASCII chars, by quad
+        B := 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^ <= #127) then
+          repeat
+            inc(P);
+            dec(Len);
+          until (Len = 0) or
+                (P^ > #127);
+        if P <> B then
+          AddNoJsonEscape(B, P - B);
+        if Len > 0 then
+          // rely on explicit conversion for all remaining ASCII characters
+          EngineAppendUtf8(self, TSynAnsiConvert.Engine(CodePage), P, Len);
+      end;
+    end;
+end;
+
+procedure TTextWriter.AddNoJsonEscapeUtf8(const text: RawByteString);
+begin
+  AddNoJsonEscape(pointer(text), length(text));
+end;
+
+procedure TTextWriter.AddRawJson(const json: RawJson);
+begin
+  if json = '' then
+    AddNull
+  else
+    AddNoJsonEscape(pointer(json), length(json));
+end;
+
+procedure TTextWriter.AddNoJsonEscapeString(const s: string);
+begin
+  if s <> '' then
+    {$ifdef UNICODE}
+    AddNoJsonEscapeW(pointer(s), 0);
+    {$else}
+    AddNoJsonEscape(pointer(s), length(s),
+      Unicode_CodePage); // =CurrentAnsiConvert.CodePage
+    {$endif UNICODE}
+end;
+
+procedure TTextWriter.AddNoJsonEscapeW(WideChar: PWord; WideCharCount: integer);
+var
+  PEnd: PtrUInt;
+  c: cardinal;
+begin
+  if WideChar = nil then
+    exit;
+  if WideCharCount = 0 then
+    repeat
+      if B >= BEnd then
+        FlushToStream;
+      c := WideChar^;
+      if c = 0 then
+        break
+      else if c <= 127 then
+      begin
+        B[1] := AnsiChar(c);
+        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 >= BEnd then
+        FlushToStream;
+      c := WideChar^;
+      if c = 0 then
+        break
+      else if c <= 127 then
+      begin
+        B[1] := AnsiChar(c);
+        inc(WideChar);
+        inc(B);
+        if PtrUInt(WideChar) < PEnd then
+          continue
+        else
+          break;
+      end;
+      inc(B, Utf16CharToUtf8(B + 1, WideChar));
+      if PtrUInt(WideChar) < PEnd then
+        continue
+      else
+        break;
+    until false;
+  end;
+end;
+
+procedure TTextWriter.AddProp(PropName: PUtf8Char);
+begin
+  AddProp(PropName, mormot.core.base.StrLen(PropName));
+end;
+
+procedure TTextWriter.AddProp(PropName: PUtf8Char; PropNameLen: PtrInt);
+begin // not faster with a local P: PUtf8Char temp pointer instead of B
+  if PropNameLen <= 0 then
+    exit; // paranoid check
+  if BEnd - B <= PropNameLen then
+    FlushToStream;
+  if twoForceJsonExtended in fCustomOptions then
+  begin
+    MoveFast(PropName^, B[1], PropNameLen);
+    inc(B, PropNameLen + 1);
+    B^ := ':';
+  end
+  else
+  begin
+    B[1] := '"';
+    MoveFast(PropName^, B[2], PropNameLen);
+    inc(B, PropNameLen + 2);
+    PCardinal(B)^ := ord('"') + ord(':') shl 8;
+    inc(B);
+  end;
+end;
+
+procedure TTextWriter.AddPropName(const PropName: ShortString);
+begin
+  AddProp(@PropName[1], ord(PropName[0]));
+end;
+
+procedure TTextWriter.AddPropInt64(const PropName: ShortString;
+  Value: Int64; WithQuote: AnsiChar);
+begin
+  AddProp(@PropName[1], ord(PropName[0]));
+  if WithQuote <> #0 then
+  begin
+    B[1] := WithQuote;
+    inc(B);
+  end;
+  Add(Value);
+  inc(B);
+  if WithQuote <> #0 then
+  begin
+    B^ := WithQuote;
+    inc(B);
+  end;
+  B^ := ',';
+end;
+
+procedure TTextWriter.AddFieldName(const FieldName: RawUtf8);
+begin
+  AddProp(Pointer(FieldName), length(FieldName));
+end;
+
+procedure TTextWriter.AddQuotedFieldName(const FieldName, VoidPlaceHolder: RawUtf8);
+begin
+  AddQuotedFieldName(pointer(FieldName), length(FieldName), VoidPlaceHolder);
+end;
+
+procedure TTextWriter.AddQuotedFieldName(
+   FieldName: PUtf8Char; FieldNameLen: PtrInt; const VoidPlaceHolder: RawUtf8);
+begin
+  if FieldNameLen = 0 then
+  begin
+    FieldName := pointer(VoidPlaceHolder);
+    FieldNameLen := length(VoidPlaceHolder);
+  end;
+  if BEnd - B <= FieldNameLen then
+    FlushToStream;
+  B[1] := '"';
+  MoveFast(FieldName^, B[2], FieldNameLen);
+  inc(B, FieldNameLen + 2);
+  B^ := '"';
+end;
+
+procedure TTextWriter.AddClassName(aClass: TClass);
+begin
+  if aClass <> nil then
+    AddShort(ClassNameShort(aClass)^);
+end;
+
+procedure TTextWriter.AddInstanceName(Instance: TObject; SepChar: AnsiChar);
+begin
+  Add('"');
+  if Instance = nil then
+    AddShorter('void')
+  else
+    AddShort(ClassNameShort(Instance)^);
+  AddDirect('(');
+  AddPointer(PtrUInt(Instance));
+  AddDirect(')', '"');
+  if SepChar <> #0 then
+    AddDirect(SepChar);
+end;
+
+procedure TTextWriter.AddInstancePointer(Instance: TObject; SepChar: AnsiChar;
+  IncludeUnitName, IncludePointer: boolean);
+var
+  u: PShortString;
+begin
+  if IncludeUnitName and
+     Assigned(ClassUnit) then
+  begin
+    u := ClassUnit(PClass(Instance)^);
+    if u^[0] <> #0 then
+    begin
+      AddShort(u^);
+      AddDirect('.');
+    end;
+  end;
+  AddShort(PPShortString(PPAnsiChar(Instance)^ + vmtClassName)^^);
+  if IncludePointer then
+  begin
+    AddDirect('(');
+    AddPointer(PtrUInt(Instance));
+    AddDirect(')');
+  end;
+  if SepChar<>#0 then
+    AddDirect(SepChar);
+end;
+
+procedure TTextWriter.AddShort(Text: PUtf8Char; TextLen: PtrInt);
+begin
+  if TextLen <= 0 then
+    exit;
+  if BEnd - B <= TextLen then
+    FlushToStream;
+  MoveFast(Text^, B[1], TextLen);
+  inc(B, TextLen);
+end;
+
+procedure TTextWriter.AddShort(const Text: ShortString);
+begin
+  if BEnd - B <= 255 then
+    FlushToStream;
+  MoveFast(Text[1], B[1], ord(Text[0]));
+  inc(B, ord(Text[0]));
+end;
+
+procedure TTextWriter.AddLine(const Text: ShortString);
+var
+  L: PtrInt;
+begin
+  L := ord(Text[0]);
+  if BEnd - B <= L then
+    FlushToStream;
+  inc(B);
+  if L > 0 then
+  begin
+    MoveFast(Text[1], B^, L);
+    inc(B, L);
+  end;
+  PCardinal(B)^ := 13 + 10 shl 8; // CR + LF
+  inc(B);
+end;
+
+procedure TTextWriter.AddOnSameLine(P: PUtf8Char);
+var
+  D: PUtf8Char;
+  c: AnsiChar;
+begin
+  if P = nil then
+    exit;
+  D := B + 1;
+  if P^ <> #0 then
+    repeat
+      if D >= BEnd then
+      begin
+        B := D - 1;
+        FlushToStream;
+        D := B + 1;
+      end;
+      c := P^;
+      if c < ' ' then
+        if c = #0 then
+          break
+        else
+          c := ' ';
+      D^ := c;
+      inc(P);
+      inc(D);
+    until false;
+  B := D - 1;
+end;
+
+procedure TTextWriter.AddOnSameLine(P: PUtf8Char; Len: PtrInt);
+var
+  D: PUtf8Char;
+  c: AnsiChar;
+begin
+  if (P = nil) or
+     (Len <= 0) then
+    exit;
+  D := B + 1;
+  repeat
+    if D >= BEnd then
+    begin
+      B := D - 1;
+      FlushToStream;
+      D := B + 1;
+    end;
+    c := P^;
+    if c < ' ' then
+      c := ' ';
+    D^ := c;
+    inc(D);
+    inc(P);
+    dec(Len);
+  until Len = 0;
+  B := D - 1;
+end;
+
+procedure TTextWriter.AddOnSameLineW(P: PWord; Len: PtrInt);
+var
+  PEnd: PtrUInt;
+  c: cardinal;
+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) < PEnd) do
+  begin
+    if B >= BEnd then
+      FlushToStream;
+    // escape chars, so that all content will stay on the same text line
+    c := P^;
+    case c of
+      0:
+        break;
+      1..32:
+        begin
+          B[1] := ' ';
+          inc(B);
+          inc(P);
+        end;
+      33..127:
+        begin
+          B[1] := AnsiChar(c); // direct store 7-bit ASCII
+          inc(B);
+          inc(P);
+        end;
+    else // characters higher than #127 -> UTF-8 encode
+      inc(B, Utf16CharToUtf8(B + 1, P));
+    end;
+  end;
+end;
+
+procedure TTextWriter.AddOnSameLineString(const Text: string);
+begin
+  {$ifdef UNICODE}
+  AddOnSameLineW(pointer(Text), length(Text));
+  {$else}
+  AddOnSameLine(pointer(Text), length(Text));
+  {$endif UNICODE}
+end;
+
+procedure TTextWriter.AddTrimLeftLowerCase(Text: PShortString);
+var
+  P: PUtf8Char;
+  L: PtrInt;
+begin
+  L := ord(Text^[0]);
+  P := @Text^[1];
+  while (L > 0) and
+        (P^ in ['a'..'z']) do
+  begin
+    inc(P);
+    dec(L);
+  end;
+  if L = 0 then
+  begin
+    L := ord(Text^[0]);
+    P := @Text^[1];
+  end;
+  AddShort(P, L);
+end;
+
+procedure TTextWriter.AddTrimSpaces(const Text: RawUtf8);
+begin
+  AddTrimSpaces(pointer(Text));
+end;
+
+procedure TTextWriter.AddTrimSpaces(P: PUtf8Char);
+var
+  c: AnsiChar;
+begin
+  if P <> nil then
+    repeat
+      c := P^;
+      inc(P);
+      if c > ' ' then
+        Add(c);
+    until c = #0;
+end;
+
+procedure TTextWriter.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: PtrUInt);
+begin
+  if B >= BEnd then
+    FlushToStream;
+  PCardinal(B + 1)^ := TwoDigitsHexWB[Value];
+  inc(B, 2);
+end;
+
+procedure TTextWriter.AddByteToHexLower(Value: PtrUInt);
+begin
+  if B >= BEnd then
+    FlushToStream;
+  PCardinal(B + 1)^ := TwoDigitsHexWBLower[Value];
+  inc(B, 2);
+end;
+
+procedure TTextWriter.AddInt18ToChars3(Value: cardinal);
+begin
+  if B >= BEnd then
+    FlushToStream;
+  PCardinal(B + 1)^ := ((Value shr 12) and $3f) or
+                       ((Value shr 6) and $3f) shl 8 or
+                       (Value and $3f) shl 16 + $202020;
+  inc(B, 3);
+end;
+
+procedure TTextWriter.AddString(const Text: RawUtf8);
+var
+  L: PtrInt;
+begin
+  L := PtrInt(Text);
+  if L <> 0 then
+    AddNoJsonEscape(pointer(Text), PStrLen(L - _STRLEN)^);
+end;
+
+procedure TTextWriter.AddSpaced(Text: PUtf8Char; TextLen, Width: PtrInt);
+begin
+  if Width <= TextLen then
+    TextLen := Width // truncate text right
+  else
+    AddChars(' ', Width - TextLen);
+  AddNoJsonEscape(Text, TextLen);
+end;
+
+procedure TTextWriter.AddSpaced(const Text: RawUtf8; Width: PtrInt;
+  SepChar: AnsiChar);
+begin
+  AddSpaced(pointer(Text), length(Text), Width);
+  if SepChar <> #0 then
+    Add(SepChar);
+end;
+
+procedure TTextWriter.AddSpaced(Value: QWord; Width: PtrInt; SepChar: AnsiChar);
+var
+  tmp: array[0..23] of AnsiChar;
+  alt: TShort16;
+  p: PAnsiChar;
+  len: PtrInt;
+begin
+  p := StrUInt64(@tmp[23], Value);
+  len := @tmp[23] - p;
+  if len > Width then
+  begin
+    K(Value, alt); // truncate to xxxK or xxxM
+    p := @alt[1];
+    len := ord(alt[0]);
+  end;
+  AddSpaced(p, len);
+  if SepChar <> #0 then
+    Add(SepChar);
+end;
+
+procedure TTextWriter.AddStringCopy(const Text: RawUtf8; start, len: PtrInt);
+var
+  L: PtrInt;
+begin
+  L := PtrInt(Text);
+  if (len <= 0) or
+     (L = 0) then
+    exit;
+  if start < 0 then
+    start := 0
+  else
+    dec(start);
+  L := PStrLen(L - _STRLEN)^;
+  dec(L, start);
+  if L > 0 then
+  begin
+    if len < L then
+      L := len;
+    AddNoJsonEscape(@PByteArray(Text)[start], L);
+  end;
+end;
+
+procedure TTextWriter.AddStrings(const Text: array of RawUtf8);
+var
+  i: PtrInt;
+begin
+  for i := 0 to high(Text) do
+    AddString(Text[i]);
+end;
+
+procedure TTextWriter.AddStrings(const Text: RawUtf8; count: PtrInt);
+var
+  i, L, siz: PtrInt;
+begin
+  L := length(Text);
+  siz := L * count;
+  if siz > 0 then
+    if siz > fTempBufSize then
+      for i := 1 to count do
+        AddString(Text) // would overfill our buffer -> manual append
+    else
+    begin
+      if BEnd - B <= siz then
+        FlushToStream;
+      for i := 1 to count do
+      begin
+        MoveFast(pointer(Text)^, B[1], L); // direct in-memory append
+        inc(B, L);
+      end;
+    end;
+end;
+
+procedure TTextWriter.AddBinToHexDisplay(Bin: pointer; BinBytes: PtrInt);
+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: PtrInt;
+  QuotedChar: AnsiChar);
+var
+  max: PtrUInt;
+begin
+  max := PtrUInt(BinBytes) * 2 + 1;
+  if PtrUInt(BEnd - B) <= max then
+    if max >= cardinal(fTempBufSize) then
+      exit // too big for a single call
+    else
+      FlushToStream;
+  inc(B);
+  if QuotedChar <> #0 then
+  begin
+    B^ := QuotedChar;
+    inc(B);
+  end;
+  BinToHexDisplayLower(Bin, pointer(B), BinBytes);
+  inc(B, BinBytes * 2);
+  if QuotedChar <> #0 then
+    B^ := QuotedChar
+  else
+    dec(B);
+end;
+
+procedure TTextWriter.AddBinToHexDisplayQuoted(Bin: pointer; BinBytes: PtrInt);
+begin
+  AddBinToHexDisplayLower(Bin, BinBytes, '"');
+end;
+
+function DisplayMinChars(Bin: PByteArray; BinBytes: PtrInt): PtrInt;
+  {$ifdef HASINLINE}inline;{$endif}
+begin
+  result := BinBytes;
+  repeat // append hexa chars up to the last non zero byte
+    dec(result);
+  until (result = 0) or
+        (Bin[result] <> 0);
+  inc(result);
+end;
+
+procedure TTextWriter.AddBinToHexDisplayMinChars(Bin: pointer; BinBytes: PtrInt;
+  QuotedChar: AnsiChar);
+begin
+  if BinBytes > 0 then
+    AddBinToHexDisplayLower(Bin, DisplayMinChars(Bin, BinBytes), QuotedChar);
+end;
+
+procedure TTextWriter.AddPointer(P: PtrUInt; QuotedChar: AnsiChar);
+begin
+  AddBinToHexDisplayLower(@P, DisplayMinChars(@P, SizeOf(P)), QuotedChar);
+end;
+
+procedure TTextWriter.AddBinToHex(Bin: Pointer; BinBytes: PtrInt; LowerHex: boolean);
+var
+  chunk: 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
+    chunk := (BEnd - B) shr 1; // div 2 -> two hexa chars per byte
+    if BinBytes < chunk then
+      chunk := BinBytes;
+    // add hexa characters
+    if LowerHex then
+      mormot.core.text.BinToHexLower(PAnsiChar(Bin), PAnsiChar(B), chunk)
+    else
+      mormot.core.text.BinToHex(PAnsiChar(Bin), PAnsiChar(B), chunk);
+    inc(B, chunk * 2);
+    inc(PByte(Bin), chunk);
+    dec(BinBytes, chunk);
+    if BinBytes = 0 then
+      break;
+    // FlushToStream writes B-fTempBuf+1 -> special one below:
+    WriteToStream(fTempBuf, B - fTempBuf);
+    B := fTempBuf;
+  until false;
+  dec(B); // allow CancelLastChar
+end;
+
+procedure TTextWriter.AddBinToHexMinChars(Bin: Pointer; BinBytes: PtrInt;
+  LowerHex: boolean);
+begin
+  if BinBytes > 0 then
+    AddBinToHex(Bin, DisplayMinChars(Bin, BinBytes), LowerHex);
+end;
+
+procedure TTextWriter.AddQuotedStr(Text: PUtf8Char; TextLen: PtrUInt;
+  Quote: AnsiChar; TextMaxLen: PtrInt);
+var
+  q: PtrInt;
+begin
+  Add(Quote);
+  if (TextMaxLen > 5) and
+     (TextLen > PtrUInt(TextMaxLen)) then
+    TextLen := TextMaxLen - 5
+  else
+    TextMaxLen := 0;
+  inc(TextLen, PtrUInt(Text)); // PUtf8Char(TextLen)=TextEnd
+  if Text <> nil then
+  begin
+    repeat
+      q := ByteScanIndex(pointer(Text), PUtf8Char(TextLen) - Text, byte(Quote));
+      if q < 0 then
+      begin
+        AddNoJsonEscape(Text, PUtf8Char(TextLen) - Text); // no double quote
+        break;
+      end;
+      inc(q); // include first Quote
+      AddNoJsonEscape(Text, q);
+      Add(Quote); // double Quote
+      inc(Text, q); // continue
+    until false;
+    if TextMaxLen <> 0 then
+      AddShorter('...');
+  end;
+  Add(Quote);
+end;
+
+procedure TTextWriter.AddUrlNameNormalize(U: PUtf8Char; L: PtrInt);
+begin
+  if L <= 0 then
+    exit;
+  repeat
+    if B >= BEnd then
+      FlushToStream; // inlined Add() in the loop
+    inc(B);
+    case U^ of
+      #0:
+        begin
+          dec(B); // reached end of URI (should not happen if L is accurate)
+          break;
+        end;
+      '%':
+        if (L <= 2) or
+           not HexToChar(PAnsiChar(U + 1), B) then
+          B^ := '%'  // browsers may not follow the RFC (e.g. encode % as % !)
+        else
+        begin
+          inc(U, 2); // jump %xx
+          dec(L, 2);
+        end;
+      '/':
+         if (L = 1) or
+            (U[1] <> '/') then
+           B^ := '/'
+         else
+           dec(B); // normalize URI by ignoring this first /
+    else
+      B^ := U^;
+    end;
+    inc(U);
+    dec(L);
+  until L = 0;
+end;
+
+var
+  HTML_ESC: array[hfAnyWhere..hfWithinAttributes] of TAnsiCharToByte;
+  HTML_ESCAPED: array[1..4] of string[7] = (
+    '<', '>', '&', '"');
+
+procedure TTextWriter.AddHtmlEscape(Text: PUtf8Char; Fmt: TTextWriterHtmlFormat);
+var
+  beg: PUtf8Char;
+  esc: PAnsiCharToByte;
+begin
+  if Text = nil then
+    exit;
+  if Fmt <> hfNone then
+  begin
+    esc := @HTML_ESC[Fmt];
+    beg := Text;
+    repeat
+      while esc[Text^] = 0 do
+        inc(Text);
+      AddNoJsonEscape(beg, Text - beg);
+      if Text^ = #0 then
+        exit
+      else
+        AddShorter(HTML_ESCAPED[esc[Text^]]);
+      inc(Text);
+      beg := Text;
+    until Text^ = #0;
+  end
+  else
+    AddNoJsonEscape(Text, mormot.core.base.StrLen(Text)); // hfNone
+end;
+
+function HtmlEscape(const text: RawUtf8; fmt: TTextWriterHtmlFormat): RawUtf8;
+var
+  temp: TTextWriterStackBuffer;
+  W: TTextWriter;
+begin
+  if NeedsHtmlEscape(pointer(text), fmt) then
+  begin
+    W := TTextWriter.CreateOwnedStream(temp);
+    try
+      W.AddHtmlEscape(pointer(text), fmt);
+      W.SetText(result);
+    finally
+      W.Free;
+    end;
+  end
+  else
+    result := text;
+end;
+
+function HtmlEscapeString(const text: string; fmt: TTextWriterHtmlFormat): RawUtf8;
+var
+  temp: TTextWriterStackBuffer;
+  W: TTextWriter;
+begin
+  {$ifdef UNICODE}
+  if fmt = hfNone then
+  {$else}
+  if not NeedsHtmlEscape(pointer(text), fmt) then // work for any AnsiString
+  {$endif UNICODE}
+  begin
+    StringToUtf8(text, result);
+    exit;
+  end;
+  W := TTextWriter.CreateOwnedStream(temp);
+  try
+    W.AddHtmlEscapeString(text, fmt);
+    W.SetText(result);
+  finally
+    W.Free;
+  end;
+end;
+
+function NeedsHtmlEscape(Text: PUtf8Char; Fmt: TTextWriterHtmlFormat): boolean;
+var
+  esc: PAnsiCharToByte;
+begin
+  if (Text <> nil) and
+     (Fmt <> hfNone) then
+  begin
+    result := true;
+    esc := @HTML_ESC[Fmt];
+    repeat
+      if esc[Text^] <> 0 then
+        if Text^ = #0 then
+          break
+        else
+          exit;
+      inc(Text);
+    until false;
+  end;
+  result := false;
+end;
+
+procedure TTextWriter.AddHtmlEscape(Text: PUtf8Char; TextLen: PtrInt;
+  Fmt: TTextWriterHtmlFormat);
+var
+  beg: PUtf8Char;
+  esc: PAnsiCharToByte;
+begin
+  if (Text = nil) or
+     (TextLen <= 0) then
+    exit;
+  if Fmt = hfNone then
+  begin
+    AddNoJsonEscape(Text, TextLen);
+    exit;
+  end;
+  inc(TextLen, PtrInt(Text)); // TextLen = final PtrInt(Text)
+  esc := @HTML_ESC[Fmt];
+  repeat
+    beg := Text;
+    while (PtrUInt(Text) < PtrUInt(TextLen)) and
+          (esc[Text^] = 0) do
+      inc(Text);
+    AddNoJsonEscape(beg, Text - beg);
+    if (PtrUInt(Text) = PtrUInt(TextLen)) or
+       (Text^ = #0) then
+      exit
+    else
+      AddShorter(HTML_ESCAPED[esc[Text^]]);
+    inc(Text);
+  until false;
+end;
+
+procedure TTextWriter.AddHtmlEscapeW(Text: PWideChar;
+  Fmt: TTextWriterHtmlFormat);
+var
+  tmp: TSynTempBuffer;
+begin
+  if (Text = nil) or
+     (Fmt = hfNone) then
+  begin
+    AddNoJsonEscapeW(pointer(Text), 0);
+    exit;
+  end;
+  RawUnicodeToUtf8(Text, StrLenW(Text), tmp, [ccfNoTrailingZero]);
+  AddHtmlEscape(tmp.buf, tmp.Len, Fmt);
+  tmp.Done;
+end;
+
+procedure TTextWriter.AddHtmlEscapeString(const Text: string; Fmt: TTextWriterHtmlFormat);
+var
+  tmp: TSynTempBuffer;
+  len: integer;
+begin
+  len := StringToUtf8(Text, tmp);
+  AddHtmlEscape(tmp.buf, len, Fmt);
+  tmp.Done;
+end;
+
+procedure TTextWriter.AddHtmlEscapeUtf8(const Text: RawUtf8; Fmt: TTextWriterHtmlFormat);
+begin
+  AddHtmlEscape(pointer(Text), length(Text), Fmt);
+end;
+
+var
+  XML_ESC: TAnsiCharToByte;
+
+procedure TTextWriter.AddXmlEscape(Text: PUtf8Char);
+var
+  i, beg: PtrInt;
+  esc: PAnsiCharToByte;
+begin
+  if Text = nil then
+    exit;
+  esc := @XML_ESC;
+  i := 0;
+  repeat
+    if esc[Text[i]] = 0 then
+    begin
+      beg := i;
+      repeat // it is faster to handle all not-escaped chars at once
+        inc(i);
+      until esc[Text[i]] <> 0;
+      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. -> // '	'
+            AddShorter('&#x');
+            AddByteToHex(ord(Text[i]));
+            AddDirect(';');
+          end;
+        '<':
+          AddShorter('<');
+        '>':
+          AddShorter('>');
+        '&':
+          AddShorter('&');
+        '"':
+          AddShorter('"');
+        '''':
+          AddShorter(''');
+      else
+        break; // should match XML_ESC[] lookup table
+      end;
+      inc(i);
+    until false;
+  until false;
+end;
+
+
+{ TEchoWriter }
+
+constructor TEchoWriter.Create(Owner: TTextWriter);
+begin
+  fWriter := Owner;
+  if Assigned(fWriter.OnFlushToStream) then
+    raise ESynException.CreateUtf8('Unexpected %.Create', [self]);
+  fWriter.OnFlushToStream := FlushToStream; // register
+end;
+
+destructor TEchoWriter.Destroy;
+begin
+  if (fWriter <> nil) and
+     (TMethod(fWriter.OnFlushToStream).Data = self) then
+    fWriter.OnFlushToStream := nil; // unregister
+  inherited Destroy;
+end;
+
+procedure TEchoWriter.EchoPendingToBackground(aLevel: TSynLogLevel);
+var
+  n, cap: PtrInt;
+begin
+  fBackSafe.Lock;
+  try
+    n := fBack.Count;
+    if length(fBack.Level) = n then
+    begin
+      cap := NextGrow(n);
+      SetLength(fBack.Level, cap);
+      SetLength(fBack.Text, cap);
+    end;
+    fBack.Level[n] := aLevel;
+    fBack.Text[n] := fEchoBuf;
+  finally
+    fBackSafe.UnLock;
+  end;
+end;
+
+procedure TEchoWriter.AddEndOfLine(aLevel: TSynLogLevel);
+var
+  e: PtrInt;
+begin
+  if twoEndOfLineCRLF in fWriter.CustomOptions then
+    fWriter.AddCR
+  else
+    fWriter.Add(#10);
+  if fEchos = nil then
+    exit; // no redirection yet
+  fEchoStart := EchoFlush;
+  if fEchoPendingExecuteBackground then
+    EchoPendingToBackground(aLevel)
+  else
+    for e := length(fEchos) - 1 downto 0 do // for MultiEventRemove() below
+      try
+        fEchos[e](self, aLevel, fEchoBuf);
+      except // remove callback in case of exception during echoing
+        MultiEventRemove(fEchos, e);
+      end;
+  fEchoBuf := '';
+end;
+
+procedure TEchoWriter.EchoPendingExecute;
+var
+  todo: TEchoWriterBack; // thread-safe per reference copy
+  i, e: PtrInt;
+begin
+  if fBack.Count = 0 then
+    exit;
+  fBackSafe.Lock;
+  MoveFast(fBack, todo, SizeOf(fBack)); // fast copy without refcount
+  FillCharFast(fBack, SizeOf(fBack), 0);
+  fBackSafe.UnLock;
+  for i := 0 to todo.Count - 1 do
+    for e := length(fEchos) - 1 downto 0 do // for MultiEventRemove() below
+      try
+        fEchos[e](self, todo.Level[i], todo.Text[i]);
+      except // remove callback in case of exception during echoing in user code
+        MultiEventRemove(fEchos, e);
+        if fEchos = nil then
+          break;
+      end;
+end;
+
+procedure TEchoWriter.FlushToStream(Text: PUtf8Char; Len: PtrInt);
+begin
+  if fEchos = nil then
+    exit;
+  EchoFlush;
+  fEchoStart := 0;
+end;
+
+procedure TEchoWriter.EchoAdd(const aEcho: TOnTextWriterEcho);
+begin
+  if self <> nil then
+    if MultiEventAdd(fEchos, TMethod(aEcho)) then
+      if fEchos <> nil then
+        fEchoStart := fWriter.B - fWriter.fTempBuf + 1; // ignore any previous buffer
+end;
+
+procedure TEchoWriter.EchoRemove(const aEcho: TOnTextWriterEcho);
+begin
+  if self <> nil then
+    MultiEventRemove(fEchos, TMethod(aEcho));
+end;
+
+function TEchoWriter.EchoFlush: PtrInt;
+var
+  L, LI: PtrInt;
+  P: PUtf8Char;
+begin
+  P := fWriter.fTempBuf;
+  result := fWriter.B - P + 1;
+  L := result - fEchoStart;
+  inc(P, fEchoStart);
+  while (L > 0) and
+        (P[L - 1] in [#10, #13]) do // trim right CR/LF chars
+    dec(L);
+  if L = 0 then
+    exit;
+  LI := length(fEchoBuf); // fast append to fEchoBuf
+  SetLength(fEchoBuf, LI + L);
+  MoveFast(P^, PByteArray(fEchoBuf)[LI], L);
+end;
+
+procedure TEchoWriter.EchoReset;
+begin
+  fEchoBuf := '';
+end;
+
+function TEchoWriter.GetEndOfLineCRLF: boolean;
+begin
+  result := twoEndOfLineCRLF in fWriter.CustomOptions;
+end;
+
+procedure TEchoWriter.SetEndOfLineCRLF(aEndOfLineCRLF: boolean);
+begin
+  if aEndOfLineCRLF then
+    fWriter.CustomOptions := fWriter.CustomOptions + [twoEndOfLineCRLF]
+  else
+    fWriter.CustomOptions := fWriter.CustomOptions - [twoEndOfLineCRLF];
+end;
+
+
+function ObjectToJson(Value: TObject; Options: TTextWriterWriteObjectOptions): RawUtf8;
+begin
+  ObjectToJson(Value, result, Options);
+end;
+
+procedure ObjectToJson(Value: TObject; var Result: RawUtf8;
+  Options: TTextWriterWriteObjectOptions);
+var
+  temp: TTextWriterStackBuffer;
+begin
+  if Value = nil then
+    Result := NULL_STR_VAR
+  else
+    with DefaultJsonWriter.CreateOwnedStream(temp) do
+    try
+      include(fCustomOptions, twoForceJsonStandard);
+      WriteObject(Value, Options);
+      SetText(Result);
+    finally
+      Free;
+    end;
+end;
+
+function ObjectToJsonDebug(Value: TObject;
+  Options: TTextWriterWriteObjectOptions): RawUtf8;
+begin
+  // our JSON serialization detects and serialize Exception.Message
+  result := ObjectToJson(Value, Options);
+end;
+
+procedure ConsoleObject(Value: TObject; Options: TTextWriterWriteObjectOptions);
+begin
+  ConsoleWrite(ObjectToJson(Value, Options));
+end;
+
+function EscapeHexBuffer(src, dest: PUtf8Char; srclen: integer;
+  const toescape: TSynAnsicharSet; escape: AnsiChar): PUtf8Char;
+begin
+  result := dest;
+  if srclen > 0 then
+    repeat
+      if src^ in toescape then
+      begin
+        result^ := escape;
+        result := pointer(ByteToHex(pointer(result + 1), ord(src^)));
+      end
+      else
+      begin
+        result^ := src^;
+        inc(result);
+      end;
+      inc(src);
+      dec(srclen);
+    until srclen = 0;
+end;
+
+function EscapeHex(const src: RawUtf8;
+  const toescape: TSynAnsicharSet; escape: AnsiChar): RawUtf8;
+var
+  l: PtrInt;
+begin
+  l := length(src);
+  if l <> 0 then
+  begin
+    FastSetString(result, l * 3); // allocate maximum size
+    l := EscapeHexBuffer(pointer(src), pointer(result), l,
+      toescape, escape) - pointer(result);
+  end;
+  FakeSetLength(result, l); // return in-place with no realloc
+end;
+
+function UnescapeHexBuffer(src, dest: PUtf8Char; escape: AnsiChar): PUtf8Char;
+var
+  c: AnsiChar;
+begin
+  result := dest;
+  if src <> nil then
+    while src^ <> #0 do
+    begin
+      if src^ = escape then
+      begin
+        inc(src);
+        if src^ in [#10, #13] then // \CRLF or \LF
+        begin
+          repeat
+            inc(src);
+          until not (src^ in [#10, #13]);
+          continue;
+        end
+        else if HexToChar(PAnsiChar(src), @c) then // \xx
+        begin
+          result^ := c;
+          inc(src, 2);
+          inc(result);
+          continue;
+        end;
+        if src^ = #0 then // expect valid \c
+          break;
+      end;
+      result^ := src^;
+      inc(src);
+      inc(result);
+    end;
+end;
+
+function UnescapeHex(const src: RawUtf8; escape: AnsiChar): RawUtf8;
+begin
+  if PosExChar(escape, src) = 0 then
+    result := src // no unescape needed
+  else
+  begin
+    FastSetString(result, length(src)); // allocate maximum size
+    FakeSetLength(result, UnescapeHexBuffer(
+      pointer(src), pointer(result), escape) - pointer(result));
+  end;
+end;
+
+function EscapeCharBuffer(src, dest: PUtf8Char; srclen: integer;
+  const toescape: TSynAnsicharSet; escape: AnsiChar): PUtf8Char;
+begin
+  result := dest;
+  if srclen > 0 then
+    repeat
+      if src^ in toescape then
+      begin
+        result^ := escape;
+        inc(result);
+      end;
+      result^ := src^;
+      inc(result);
+      inc(src);
+      dec(srclen);
+    until srclen = 0;
+end;
+
+function EscapeChar(const src: RawUtf8;
+  const toescape: TSynAnsicharSet; escape: AnsiChar): RawUtf8;
+var
+  l: PtrInt;
+begin
+  l := length(src);
+  if l <> 0 then
+  begin
+    FastSetString(result, l * 2); // allocate maximum size
+    l := EscapeCharBuffer(pointer(src), pointer(result), l,
+      toescape, escape) - pointer(result);
+  end;
+  FakeSetLength(result, l); // return in-place with no realloc
+end;
+
+
+{ ************ Numbers (integers or floats) to Text Conversion }
+
+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;
+
+function Int32ToUtf8(Value: PtrInt): RawUtf8;
+begin
+  Int32ToUtf8(Value, result);
+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
+    {$ifdef CPU64}
+    P := StrInt32(@tmp[23], Value);
+    {$else}
+    P := StrInt64(@tmp[23], Value);
+    {$endif CPU64}
+    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
+    {$ifdef CPU64}
+    P := StrUInt32(@tmp[23], Value);
+    {$else}
+    P := StrUInt64(@tmp[23], Value);
+    {$endif CPU64}
+    FastSetString(result, P, @tmp[23] - P);
+  end;
+end;
+
+function Int64ToUtf8(Value: Int64): RawUtf8; // faster than SysUtils.IntToStr
+begin
+  Int64ToUtf8(Value, result);
+end;
+
+{$ifdef CPU32} // already implemented by ToUtf8(Value: PtrInt) below for CPU64
+function ToUtf8(Value: Int64): RawUtf8;
+begin
+  Int64ToUtf8(Value, result);
+end;
+{$endif CPU32}
+
+function ToUtf8(Value: PtrInt): RawUtf8;
+begin
+  Int32ToUtf8(Value, result);
+end;
+
+procedure UInt32ToUtf8(Value: PtrUInt; var result: RawUtf8);
+var
+  tmp: array[0..23] of AnsiChar;
+  P: PAnsiChar;
+begin
+  if Value <= high(SmallUInt32Utf8) then
+    result := SmallUInt32Utf8[Value]
+  else
+  begin
+    P := StrUInt32(@tmp[23], Value);
+    FastSetString(result, P, @tmp[23] - P);
+  end;
+end;
+
+function UInt32ToUtf8(Value: PtrUInt): RawUtf8;
+begin
+  UInt32ToUtf8(Value, result);
+end;
+
+function StrCurr64(P: PAnsiChar; const Value: Int64): PAnsiChar;
+var
+  c: QWord;
+  d: cardinal;
+begin
+  if Value = 0 then
+  begin
+    result := P - 1;
+    result^ := '0';
+    exit;
+  end;
+  if Value < 0 then
+    c := -Value
+  else
+    c := Value;
+  if c < 10000 then
+  begin
+    result := P - 6; // only decimals -> append '0.xxxx'
+    PCardinal(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(const 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 = 4 last digits = 4 decimals
+    Decim := PCardinal(P + result - SizeOf(cardinal))^;
+    if Decim = ord('0') + ord('0') shl 8 + ord('0') shl 16 + ord('0') shl 24 then
+      // no decimal -> trunc trailing *.0000 chars
+      dec(result, 5)
+    else if Decim and $ffff0000 = ord('0') shl 16 + ord('0') shl 24 then
+      // 2 decimals -> trunc trailing *.??00 chars
+      dec(result, 2);
+  end;
+  MoveFast(P^, Dest^, result);
+end;
+
+function StrToCurr64(P: PUtf8Char; NoDecimal: PBoolean): Int64;
+var
+  c: cardinal;
+  minus: boolean;
+  Dec: cardinal;
+begin
+  result := 0;
+  if P = nil then
+    exit;
+  while (P^ <= ' ') and
+        (P^ <> #0) do
+    inc(P);
+  if P^ = '-' then
+  begin
+    minus := true;
+    repeat
+      inc(P)
+    until P^ <> ' ';
+  end
+  else
+  begin
+    minus := false;
+    if P^ = '+' then
+      repeat
+        inc(P)
+      until P^ <> ' ';
+  end;
+  if P^ = '.' then
+  begin
+    // '.5' -> 500
+    Dec := 2;
+    inc(P);
+  end
+  else
+    Dec := 0;
+  c := byte(P^) - 48;
+  if c > 9 then
+    exit;
+  PCardinal(@result)^ := c;
+  inc(P);
+  repeat
+    if P^ <> '.' then
+    begin
+      c := byte(P^) - 48;
+      if c > 9 then
+        break;
+      {$ifdef CPU32DELPHI}
+      result := result shl 3 + result + result;
+      {$else}
+      result := result * 10;
+      {$endif CPU32DELPHI}
+      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 CPU32DELPHI}
+    end;
+  if minus then
+    result := -result;
+end;
+
+function StrToCurrency(P: PUtf8Char): currency;
+begin
+  PInt64(@result)^ := StrToCurr64(P, nil);
+end;
+
+{$ifdef UNICODE}
+
+function IntToString(Value: integer): string;
+var
+  tmp: array[0..23] of AnsiChar;
+  P: PAnsiChar;
+begin
+  P := StrInt32(@tmp[23], Value);
+  Ansi7ToString(PWinAnsiChar(P), @tmp[23] - P, result);
+end;
+
+function IntToString(Value: cardinal): string;
+var
+  tmp: array[0..23] of AnsiChar;
+  P: PAnsiChar;
+begin
+  P := StrUInt32(@tmp[23], Value);
+  Ansi7ToString(PWinAnsiChar(P), @tmp[23] - P, result);
+end;
+
+function IntToString(Value: Int64): string;
+var
+  tmp: array[0..31] of AnsiChar;
+  P: PAnsiChar;
+begin
+  P := StrInt64(@tmp[31], Value);
+  Ansi7ToString(PWinAnsiChar(P), @tmp[31] - P, result);
+end;
+
+function DoubleToString(Value: Double): string;
+var
+  tmp: ShortString;
+begin
+  if Value = 0 then
+    result := '0'
+  else
+    Ansi7ToString(PWinAnsiChar(@tmp[1]), DoubleToShort(@tmp, Value), result);
+end;
+
+function Curr64ToString(Value: Int64): string;
+var
+  tmp: array[0..31] of AnsiChar;
+begin
+  Ansi7ToString(tmp, Curr64ToPChar(Value, tmp), result);
+end;
+
+{$else UNICODE}
+
+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;
+
+function IntToString(Value: cardinal): string;
+var
+  tmp: array[0..23] of AnsiChar;
+  P: PAnsiChar;
+begin
+  if Value <= high(SmallUInt32Utf8) then
+    result := SmallUInt32Utf8[Value]
+  else
+  begin
+    P := StrUInt32(@tmp[23], Value);
+    SetString(result, P, @tmp[23] - P);
+  end;
+end;
+
+function IntToString(Value: Int64): string;
+var
+  tmp: array[0..31] of AnsiChar;
+  P: PAnsiChar;
+begin
+  if (Value >= 0) and
+     (Value <= high(SmallUInt32Utf8)) then
+    result := SmallUInt32Utf8[Value]
+  else
+  begin
+    P := StrInt64(@tmp[31], Value);
+    SetString(result, P, @tmp[31] - P);
+  end;
+end;
+
+function DoubleToString(Value: Double): string;
+var
+  tmp: ShortString;
+begin
+  if Value = 0 then
+    result := '0'
+  else
+    SetString(result, PAnsiChar(@tmp[1]), DoubleToShort(@tmp, Value));
+end;
+
+function Curr64ToString(Value: Int64): string;
+begin
+  result := Curr64ToStr(Value);
+end;
+
+{$endif UNICODE}
+
+{$ifndef EXTENDEDTOSHORT_USESTR}
+var // standard FormatSettings (US)
+  SettingsUS: TFormatSettings;
+{$endif EXTENDEDTOSHORT_USESTR}
+
+// used ExtendedToShortNoExp / DoubleToShortNoExp from str/DoubleToAscii output
+function FloatStringNoExp(S: PAnsiChar; Precision: PtrInt): PtrInt;
+var
+  i, prec: PtrInt;
+  c: AnsiChar;
+begin
+  result := ord(S[0]);
+  prec := result; // if no decimal
+  if S[1] = '-' then
+    dec(prec);
+  // test if scientific format -> return as this
+  for i := 2 to result do
+  begin
+    c := S[i];
+    if c = 'E' then // should not appear
+      exit
+    else if c = '.' then
+      if i >= Precision then
+      begin
+        // return huge decimal number as is
+        result := i - 1;
+        exit;
+      end
+      else
+        dec(prec);
+  end;
+  if (prec >= Precision) and
+     (prec <> result) then
+  begin
+    dec(result, prec - Precision);
+    if S[result + 1] > '5' then
+    begin
+      // manual rounding
+      prec := result;
+      repeat
+        c := S[prec];
+        if c <> '.' then
+          if c = '9' then
+          begin
+            S[prec] := '0';
+            if ((prec = 2) and
+                (S[1] = '-')) or
+               (prec = 1) then
+            begin
+              i := result;
+              inc(S, prec);
+              repeat
+                // inlined MoveFast(S[prec],S[prec+1],result);
+                S[i] := S[i - 1];
+                dec(i);
+              until i = 0;
+              S^ := '1';
+              dec(S, prec);
+              break;
+            end;
+          end
+          else if (c >= '0') and
+                  (c <= '8') then
+          begin
+            inc(S[prec]);
+            break;
+          end
+          else
+            break;
+        dec(prec);
+      until prec = 0;
+    end; // note: this fixes http://stackoverflow.com/questions/2335162
+  end;
+  if S[result] = '0' then
+    repeat
+      // trunc any trailing 0
+      dec(result);
+      c := S[result];
+      if c <> '.' then
+        if c <> '0' then
+          break
+        else
+          continue
+      else
+      begin
+        dec(result);
+        if (result = 2) and
+           (S[1] = '-') and
+           (S[2] = '0') then
+        begin
+          result := 1;
+          S[1] := '0'; // '-0.000' -> '0'
+        end;
+        break; // if decimal are all '0' -> return only integer part
+      end;
+    until false;
+end;
+
+function ExtendedToShortNoExp(S: PShortString; Value: TSynExtended;
+  Precision: integer): integer;
+begin
+  {$ifdef DOUBLETOSHORT_USEGRISU}
+  if Precision = DOUBLE_PRECISION then
+    DoubleToAscii(0, DOUBLE_PRECISION, Value, pointer(S))
+  else
+  {$endif DOUBLETOSHORT_USEGRISU}
+    str(Value: 0: Precision, S^); // not str(Value:0,S) -> '  0.0E+0000'
+  result := FloatStringNoExp(pointer(S), Precision);
+  S^[0] := AnsiChar(result);
+end;
+
+const // range when to switch into scientific notation - minimal 6 digits
+  SINGLE_HI = 1E3;
+  SINGLE_LO = 1E-3;
+  DOUBLE_HI = 1E9;
+  DOUBLE_LO = 1E-9;
+  {$ifdef TSYNEXTENDED80}
+  EXT_HI = 1E12;
+  EXT_LO = 1E-12;
+  {$endif TSYNEXTENDED80}
+
+{$ifdef EXTENDEDTOSHORT_USESTR}
+function ExtendedToShort(S: PShortString; Value: TSynExtended; Precision: integer): integer;
+var
+  scientificneeded: boolean;
+  valueabs: TSynExtended;
+begin
+  {$ifdef DOUBLETOSHORT_USEGRISU}
+  if Precision = DOUBLE_PRECISION then
+  begin
+    result := DoubleToShort(S, Value);
+    exit;
+  end;
+  {$endif DOUBLETOSHORT_USEGRISU}
+  if Value = 0 then
+  begin
+    PCardinal(S)^ := 1 + ord('0') shl 8;
+    result := 1;
+    exit;
+  end;
+  scientificneeded := false;
+  valueabs := abs(Value);
+  if Precision <= SINGLE_PRECISION then
+  begin
+    if (valueabs > SINGLE_HI) or
+       (valueabs < SINGLE_LO) then
+      scientificneeded := true;
+  end
+  else
+  {$ifdef TSYNEXTENDED80}
+  if Precision > DOUBLE_PRECISION then
+  begin
+    if (valueabs > EXT_HI) or
+       (valueabs < EXT_LO) then
+      scientificneeded := true;
+  end
+  else
+  {$endif TSYNEXTENDED80}
+  if (valueabs > DOUBLE_HI) or
+     (valueabs < DOUBLE_LO) then
+    scientificneeded := true;
+  if scientificneeded then
+  begin
+    str(Value, S^);
+    if S^[1] = ' ' then
+    begin
+      dec(S^[0]);
+      MoveFast(S^[2], S^[1], ord(S^[0]));
+    end;
+    result := ord(S^[0]);
+  end
+  else
+  begin
+    str(Value: 0:Precision, S^); // not str(Value:0,S) -> '  0.0E+0000'
+    result := FloatStringNoExp(pointer(S), Precision);
+    S^[0] := AnsiChar(result);
+  end;
+end;
+
+{$else not EXTENDEDTOSHORT_USESTR}
+
+function ExtendedToShort(S: PShortString; Value: TSynExtended; Precision: integer): integer;
+{$ifdef UNICODE}
+var
+  i: PtrInt;
+{$endif UNICODE}
+begin
+  // use ffGeneral: see https://synopse.info/forum/viewtopic.php?pid=442#p442
+  result := FloatToText(PChar(@S^[1]), Value, fvExtended, ffGeneral, Precision, 0, SettingsUS);
+  {$ifdef UNICODE} // FloatToText(PWideChar) is faster than FloatToText(PAnsiChar)
+  for i := 1 to result do
+    PByteArray(S)[i] := PWordArray(PtrInt(S) - 1)[i];
+  {$endif UNICODE}
+  S^[0] := AnsiChar(result);
+end;
+
+{$endif EXTENDEDTOSHORT_USESTR}
+
+function FloatToShortNan(const s: ShortString): TFloatNan;
+begin
+  case PInteger(@s)^ and $ffdfdfdf of
+    3 + ord('N') shl 8 + ord('A') shl 16 + ord('N') shl 24:
+      result := fnNan;
+    3 + ord('I') shl 8 + ord('N') shl 16 + ord('F') shl 24,
+    4 + ord('+') shl 8 + ord('I') shl 16 + ord('N') shl 24:
+      result := fnInf;
+    4 + ord('-') shl 8 + ord('I') shl 16 + ord('N') shl 24:
+      result := fnNegInf;
+  else
+    result := fnNumber;
+  end;
+end;
+
+function FloatToStrNan(const s: RawUtf8): TFloatNan;
+begin
+  case length(s) of
+    3:
+      case PInteger(s)^ and $dfdfdf of
+        ord('N') + ord('A') shl 8 + ord('N') shl 16:
+          result := fnNan;
+        ord('I') + ord('N') shl 8 + ord('F') shl 16:
+          result := fnInf;
+      else
+        result := fnNumber;
+      end;
+    4:
+      case PInteger(s)^ and $dfdfdfdf of
+        ord('+') + ord('I') shl 8 + ord('N') shl 16 + ord('F') shl 24:
+          result := fnInf;
+        ord('-') + ord('I') shl 8 + ord('N') shl 16 + ord('F') shl 24:
+          result := fnNegInf;
+      else
+        result := fnNumber;
+      end;
+  else
+    result := fnNumber;
+  end;
+end;
+
+function ExtendedToStr(Value: TSynExtended; Precision: integer): RawUtf8;
+begin
+  ExtendedToStr(Value, Precision, result);
+end;
+
+procedure ExtendedToStr(Value: TSynExtended; Precision: integer; var result: RawUtf8);
+var
+  tmp: ShortString;
+begin
+  if Value = 0 then
+    result := SmallUInt32Utf8[0]
+  else
+    FastSetString(result, @tmp[1], ExtendedToShort(@tmp, Value, Precision));
+end;
+
+function FloatToJsonNan(s: PShortString): PShortString;
+begin
+  case PInteger(s)^ and $ffdfdfdf of
+    3 + ord('N') shl 8 + ord('A') shl 16 + ord('N') shl 24:
+      result := @JSON_NAN[fnNan];
+    3 + ord('I') shl 8 + ord('N') shl 16 + ord('F') shl 24,
+    4 + ord('+') shl 8 + ord('I') shl 16 + ord('N') shl 24:
+      result := @JSON_NAN[fnInf];
+    4 + ord('-') shl 8 + ord('I') shl 16 + ord('N') shl 24:
+      result := @JSON_NAN[fnNegInf];
+  else
+    result := s;
+  end;
+end;
+
+function ExtendedToJson(tmp: PShortString; Value: TSynExtended;
+  Precision: integer; NoExp: boolean): PShortString;
+begin
+  if Value = 0 then
+    result := @JSON_NAN[fnNumber]
+  else
+  begin
+    if NoExp then
+      ExtendedToShortNoExp(tmp, Value, Precision)
+    else
+      ExtendedToShort(tmp, Value, Precision);
+    result := FloatToJsonNan(tmp);
+  end;
+end;
+
+{$ifdef DOUBLETOSHORT_USEGRISU}
+
+{
+    Implement 64-bit floating point (double) to ASCII conversion using the
+    GRISU-1 efficient algorithm.
+
+    Original Code in flt_core.inc flt_conv.inc flt_pack.inc from FPC RTL.
+    Copyright (C) 2013 by Max Nazhalov
+    Licenced with LGPL 2 with the linking exception.
+    If you don't agree with these License terms, disable this feature
+    by undefining DOUBLETOSHORT_USEGRISU in Synopse.inc
+
+    GRISU Original Algorithm
+    Copyright (c) 2009 Florian Loitsch
+
+    We extracted a double-to-ascii only cut-down version of those files,
+    and made a huge refactoring to reach the best performance, especially
+    tuning the Intel target with some dedicated asm and code rewrite.
+
+  With Delphi 10.3 on Win32:
+   100000 FloatToText    in 38.11ms i.e. 2,623,570/s, aver. 0us, 47.5 MB/s
+   100000 str            in 43.19ms i.e. 2,315,082/s, aver. 0us, 50.7 MB/s
+   100000 DoubleToShort  in 45.50ms i.e. 2,197,367/s, aver. 0us, 43.8 MB/s
+   100000 DoubleToAscii  in 42.44ms i.e. 2,356,045/s, aver. 0us, 47.8 MB/s
+
+  With Delphi 10.3 on Win64:
+   100000 FloatToText    in 61.83ms i.e. 1,617,233/s, aver. 0us, 29.3 MB/s
+   100000 str            in 53.20ms i.e. 1,879,663/s, aver. 0us, 41.2 MB/s
+   100000 DoubleToShort  in 18.45ms i.e. 5,417,998/s, aver. 0us, 108 MB/s
+   100000 DoubleToAscii  in 18.19ms i.e. 5,496,921/s, aver. 0us, 111.5 MB/s
+
+  With FPC on Win32:
+   100000 FloatToText    in 115.62ms i.e.  864,842/s, aver. 1us, 15.6 MB/s
+   100000 str            in 57.30ms i.e. 1,745,109/s, aver. 0us, 39.9 MB/s
+   100000 DoubleToShort  in 23.88ms i.e. 4,187,078/s, aver. 0us, 83.5 MB/s
+   100000 DoubleToAscii  in 23.34ms i.e. 4,284,490/s, aver. 0us, 86.9 MB/s
+
+  With FPC on Win64:
+   100000 FloatToText    in 76.92ms i.e. 1,300,052/s, aver. 0us, 23.5 MB/s
+   100000 str            in 27.70ms i.e. 3,609,456/s, aver. 0us, 82.6 MB/s
+   100000 DoubleToShort  in 14.73ms i.e. 6,787,944/s, aver. 0us, 135.4 MB/s
+   100000 DoubleToAscii  in 13.78ms i.e. 7,253,735/s, aver. 0us, 147.2 MB/s
+
+  With FPC on Linux x86_64:
+   100000 FloatToText    in 81.48ms i.e. 1,227,249/s, aver. 0us, 22.2 MB/s
+   100000 str            in 36.98ms i.e. 2,703,871/s, aver. 0us, 61.8 MB/s
+   100000 DoubleToShort  in 13.11ms i.e. 7,626,601/s, aver. 0us, 152.1 MB/s
+   100000 DoubleToAscii  in 12.59ms i.e. 7,942,180/s, aver. 0us, 161.2 MB/s
+
+  - Our rewrite is twice faster than original flt_conv.inc from FPC RTL (str)
+  - Delphi Win32 has trouble making 64-bit computation - no benefit since it
+    has good optimized i87 asm (but slower than our code with FPC/Win32)
+  - FPC is more efficient when compiling integer arithmetic; we avoided slow
+    division by calling our Div100(), but Delphi Win64 is still far behind
+  - Delphi Win64 has very slow FloatToText and str()
+
+}
+
+// Controls printing of NaN-sign.
+// Undefine to print NaN sign during float->ASCII conversion.
+// IEEE does not interpret the sign of a NaN, so leave it defined.
+{$define GRISU1_F2A_NAN_SIGNLESS}
+
+// Controls rounding of generated digits when formatting with narrowed
+// width (either fixed or exponential notation).
+// Traditionally, FPC and BP7/Delphi use "roundTiesToAway" mode.
+// Undefine to use "roundTiesToEven" approach.
+{$define GRISU1_F2A_HALF_ROUNDUP}
+
+// This one is a hack against Grusu sub-optimality.
+// It may be used only strictly together with GRISU1_F2A_HALF_ROUNDUP.
+// It does not violate most general rules due to the fact that it is
+// applicable only when formatting with narrowed width, where the fine
+// view is more desirable, and the precision is already lost, so it can
+// be used in general-purpose applications.
+// Refer to its implementation.
+{$define GRISU1_F2A_AGRESSIVE_ROUNDUP} // Defining this fixes several tests.
+
+// Undefine to enable SNaN support.
+// Note: IEEE [754-2008, page 31] requires (1) to recognize "SNaN" during
+// ASCII->float, and (2) to generate the "invalid FP operation" exception
+// either when SNaN is printed as "NaN", or "SNaN" is evaluated to QNaN,
+// so it would be preferable to undefine these settings,
+// but the FPC RTL is not ready for this right now..
+{$define GRISU1_F2A_NO_SNAN}
+
+/// If Value=0 would just store '0', whatever frac_digits is supplied.
+{$define GRISU1_F2A_ZERONOFRACT}
+
+var
+  /// fast lookup table for converting any decimal number from
+  // 0 to 99 into their byte digits (00..99) equivalence
+  // - used e.g. by DoubleToAscii() implementing Grisu algorithm
+  TwoDigitByteLookupW: packed array[0..99] of word;
+
+const
+  // TFloatFormatProfile for double
+  nDig_mantissa = 17;
+  nDig_exp10 = 3;
+
+type
+  // "Do-It-Yourself Floating-Point" structures
+  TDIY_FP = record
+    f: qword;
+    e: integer;
+  end;
+
+  TDIY_FP_Power_of_10 = record
+    c: TDIY_FP;
+    e10: integer;
+  end;
+  PDIY_FP_Power_of_10 = ^TDIY_FP_Power_of_10;
+
+const
+  ROUNDER = $80000000;
+
+{$ifdef CPUINTEL} // our faster version using 128-bit x86_64 multiplication
+
+procedure d2a_diy_fp_multiply(var x, y: TDIY_FP; normalize: boolean;
+  out result: TDIY_FP); {$ifdef HASINLINE}inline;{$endif}
+var
+  p: THash128Rec;
+begin
+  mul64x64(x.f, y.f, p); // fast x86_64 / i386 asm
+  if (p.c1 and ROUNDER) <>  0 then
+    inc(p.h);
+  result.f := p.h;
+  result.e := PtrInt(x.e) + PtrInt(y.e) + 64;
+  if normalize then
+    if (PQWordRec(@result.f)^.h and ROUNDER) = 0 then
+    begin
+      result.f := result.f * 2;
+      dec(result.e);
+    end;
+end;
+
+{$else} // regular Grisu method - optimized for 32-bit CPUs
+
+procedure d2a_diy_fp_multiply(var x, y: TDIY_FP; normalize: boolean; out result: TDIY_FP);
+var
+  _x: TQWordRec absolute x;
+  _y: TQWordRec absolute y;
+  r: TQWordRec absolute result;
+  ac, bc, ad, bd, t1: TQWordRec;
+begin
+  ac.v := qword(_x.h) * _y.h;
+  bc.v := qword(_x.l) * _y.h;
+  ad.v := qword(_x.h) * _y.l;
+  bd.v := qword(_x.l) * _y.l;
+  t1.v := qword(ROUNDER) + bd.h + bc.l + ad.l;
+  result.f := ac.v + ad.h + bc.h + t1.h;
+  result.e := x.e + y.e + 64;
+  if normalize then
+    if (r.h and ROUNDER) = 0 then
+    begin
+      inc(result.f, result.f);
+      dec(result.e);
+    end;
+end;
+
+{$endif CPUINTEL}
+
+const
+  // alpha =-61; gamma = 0
+  // full cache: 1E-450 .. 1E+432, step = 1E+18
+  // sparse = 1/10
+  C_PWR10_DELTA = 18;
+  C_PWR10_COUNT = 50;
+
+type
+  TDIY_FP_Cached_Power10 = record
+    base:         array [ 0 .. 9 ] of TDIY_FP_Power_of_10;
+    factor_plus:  array [ 0 .. 1 ] of TDIY_FP_Power_of_10;
+    factor_minus: array [ 0 .. 1 ] of TDIY_FP_Power_of_10;
+    // extra mantissa correction [ulp; signed]
+    corrector:    array [ 0 .. C_PWR10_COUNT - 1 ] of shortint;
+  end;
+
+const
+  CACHED_POWER10: TDIY_FP_Cached_Power10 = (
+    base: (
+        ( c: ( f: qword($825ECC24C8737830); e: -362 ); e10:  -90 ),
+        ( c: ( f: qword($E2280B6C20DD5232); e: -303 ); e10:  -72 ),
+        ( c: ( f: qword($C428D05AA4751E4D); e: -243 ); e10:  -54 ),
+        ( c: ( f: qword($AA242499697392D3); e: -183 ); e10:  -36 ),
+        ( c: ( f: qword($9392EE8E921D5D07); e: -123 ); e10:  -18 ),
+        ( c: ( f: qword($8000000000000000); e:  -63 ); e10:    0 ),
+        ( c: ( f: qword($DE0B6B3A76400000); e:   -4 ); e10:   18 ),
+        ( c: ( f: qword($C097CE7BC90715B3); e:   56 ); e10:   36 ),
+        ( c: ( f: qword($A70C3C40A64E6C52); e:  116 ); e10:   54 ),
+        ( c: ( f: qword($90E40FBEEA1D3A4B); e:  176 ); e10:   72 )
+    );
+    factor_plus: (
+        ( c: ( f: qword($F6C69A72A3989F5C); e:   534 ); e10:  180 ),
+        ( c: ( f: qword($EDE24AE798EC8284); e:  1132 ); e10:  360 )
+    );
+    factor_minus: (
+        ( c: ( f: qword($84C8D4DFD2C63F3B); e:  -661 ); e10: -180 ),
+        ( c: ( f: qword($89BF722840327F82); e: -1259 ); e10: -360 )
+    );
+    corrector: (
+        0,  0,  0,  0,  1,  0,  0,  0,  1, -1,
+        0,  1,  1,  1, -1,  0,  0,  1,  0, -1,
+        0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
+       -1,  0,  0, -1,  0,  0,  0,  0,  0, -1,
+        0,  0,  0,  0,  1,  0,  0,  0, -1,  0
+    ));
+  CACHED_POWER10_MIN10 = -90 -360;
+  // = ref.base[low(ref.base)].e10 + ref.factor_minus[high(ref.factor_minus)].e10
+
+// return normalized correctly rounded approximation of the power of 10
+// scaling factor, intended to shift a binary exponent of the original number
+// into selected [ alpha .. gamma ] range
+procedure d2a_diy_fp_cached_power10(exp10: integer; out factor: TDIY_FP_Power_of_10);
+var
+  i, xmul: integer;
+  A, B: PDIY_FP_Power_of_10;
+  cx: PtrInt;
+  ref: ^TDIY_FP_Cached_Power10;
+begin
+  ref := @CACHED_POWER10; // much better code generation on PIC/x86_64
+  // find non-sparse index
+  if exp10 <= CACHED_POWER10_MIN10 then
+    i := 0
+  else
+  begin
+    i := (exp10 - CACHED_POWER10_MIN10) div C_PWR10_DELTA;
+    if i * C_PWR10_DELTA + CACHED_POWER10_MIN10 <> exp10 then
+      inc(i); // round-up
+    if i > C_PWR10_COUNT - 1 then
+      i := C_PWR10_COUNT - 1;
+  end;
+  // generate result
+  xmul := i div length(ref.base);
+  A := @ref.base[i - (xmul * length(ref.base))]; // fast mod
+  dec(xmul, length(ref.factor_minus));
+  if xmul = 0 then
+  begin
+    // base
+    factor := A^;
+    exit;
+  end;
+  // surrogate
+  if xmul > 0 then
+  begin
+    dec(xmul);
+    B := @ref.factor_plus[xmul];
+  end
+  else
+  begin
+    xmul := -(xmul + 1);
+    B := @ref.factor_minus[xmul];
+  end;
+  factor.e10 := A.e10 + B.e10;
+  if A.e10 <> 0 then
+  begin
+    d2a_diy_fp_multiply(A.c, B.c, true, factor.c);
+    // adjust mantissa
+    cx := ref.corrector[i];
+    if cx <> 0 then
+      inc(int64(factor.c.f), int64(cx));
+  end
+  else
+    // exact
+    factor.c := B^.c;
+end;
+
+procedure d2a_unpack_float(const f: double; out minus: boolean;
+  out result: TDIY_FP);   {$ifdef HASINLINE}inline;{$endif}
+type
+  TSplitFloat = packed record
+    case byte of
+      0: (f: double);
+      1: (b: array[0..7] of byte);
+      2: (w: array[0..3] of word);
+      3: (d: array[0..1] of cardinal);
+      4: (l: qword);
+  end;
+var
+  doublebits: TSplitFloat;
+begin
+{$ifdef FPC_DOUBLE_HILO_SWAPPED}
+  // high and low cardinal are swapped when using the arm fpa
+  doublebits.d[0] := TSplitFloat(f).d[1];
+  doublebits.d[1] := TSplitFloat(f).d[0];
+{$else not FPC_DOUBLE_HILO_SWAPPED}
+  doublebits.f := f;
+{$endif FPC_DOUBLE_HILO_SWAPPED}
+{$ifdef endian_big}
+  minus := (doublebits.b[0] and $80 <> 0);
+  result.e := (doublebits.w[0] shr 4) and $7FF;
+{$else endian_little}
+  minus := (doublebits.b[7] and $80 <> 0);
+  result.e := (doublebits.w[3] shr 4) and $7FF;
+{$endif endian}
+  result.f := doublebits.l and $000FFFFFFFFFFFFF;
+end;
+
+const
+  C_FRAC2_BITS = 52;
+  C_EXP2_BIAS = 1023;
+  C_DIY_FP_Q = 64;
+  C_GRISU_ALPHA = -61;
+  C_GRISU_GAMMA = 0;
+
+  C_EXP2_SPECIAL = C_EXP2_BIAS * 2 + 1;
+  C_MANT2_INTEGER = qword(1) shl C_FRAC2_BITS;
+
+type
+  TAsciiDigits = array[0..39] of byte;
+  PAsciiDigits = ^TAsciiDigits;
+
+// convert unsigned integers into decimal digits
+
+{$ifdef FPC_64} // leverage efficient FPC 64-bit division as mul reciprocal
+
+function d2a_gen_digits_64(buf: PAsciiDigits; x: qword): PtrInt;
+var
+  tab: PWordArray;
+  P: PAnsiChar;
+  c100: qword;
+begin
+  tab := @TwoDigitByteLookupW; // 0..99 value -> two byte digits (00..99)
+  P := PAnsiChar(@buf[24]); // append backwards
+  repeat
+    if x >= 100 then
+    begin
+      dec(P, 2);
+      c100 := x div 100;
+      dec(x, c100 * 100);
+      PWord(P)^ := tab[x]; // 2 digits per loop
+      if c100 = 0 then
+        break;
+      x := c100;
+      continue;
+    end;
+    if x < 10 then
+    begin
+      dec(P);
+      P^ := AnsiChar(x); // 0..9
+      break;
+    end;
+    dec(P, 2);
+    PWord(P)^ := tab[x]; // 10..99
+    break;
+  until false;
+  PHash192(buf)^ := PHash192(P)^; // faster than MoveByOne(P,buf,result)
+  result := PAnsiChar(@buf[24]) - P;
+end;
+
+{$else not FPC_64} // use three 32-bit groups of digit
+
+function d2a_gen_digits_32(buf: PAsciiDigits; x: dword; pad_9zero: boolean): PtrInt;
+const
+  digits: array[0..9] of cardinal = (
+    0, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000);
+var
+  n: PtrInt;
+  m: cardinal;
+  {$ifdef FPC}
+  z: cardinal;
+  {$else}
+  d100: TDiv100Rec;
+  {$endif FPC}
+  tab: PWordArray;
+begin
+  // Calculate amount of digits
+  if x = 0 then
+    n := 0  // emit nothing if padding is not required
+  else
+  begin
+    n := integer((BSRdword(x) + 1) * 1233) shr 12;
+    if x >= digits[n] then
+      inc(n);
+  end;
+  if pad_9zero and (n < 9) then
+    n := 9;
+  result := n;
+  if n = 0 then
+    exit;
+  // Emit digits
+  dec(PByte(buf));
+  tab := @TwoDigitByteLookupW;
+  m := x;
+  while (n >= 2) and (m <> 0) do
+  begin
+    dec(n);
+    {$ifdef FPC} // FPC will use fast mul reciprocal
+    z := m div 100; // compute two 0..9 digits
+    PWord(@buf[n])^ := tab^[m - z * 100];
+    m := z;
+    {$else}
+    Div100(m, d100); // our asm is faster than Delphi div operation
+    PWord(@buf[n])^ := tab^[d100.M];
+    m := d100.D;
+    {$endif FPC}
+    dec(n);
+  end;
+  if n = 0 then
+    exit;
+  if m <> 0 then
+  begin
+    if m > 9 then
+      m := m mod 10; // compute last 0..9 digit
+    buf[n] := m;
+    dec(n);
+    if n = 0 then
+      exit;
+  end;
+  repeat
+    buf[n] := 0; // padding with 0
+    dec(n);
+  until n = 0;
+end;
+
+function d2a_gen_digits_64(buf: PAsciiDigits; const x: qword): PtrInt;
+var
+  n_digits: PtrInt;
+  temp: qword;
+  splitl, splitm, splith: cardinal;
+begin
+  // Split X into 3 unsigned 32-bit integers; lower two should be < 10 digits long
+  n_digits := 0;
+  if x < 1000000000 then
+    splitl := x
+  else
+  begin
+    temp := x div 1000000000;
+    splitl := x - temp * 1000000000;
+    if temp < 1000000000 then
+      splitm := temp
+    else
+    begin
+      splith := temp div 1000000000;
+      splitm := cardinal(temp) - splith * 1000000000;
+      n_digits := d2a_gen_digits_32(buf, splith, false); // Generate hi digits
+    end;
+    inc(n_digits, d2a_gen_digits_32(@buf[n_digits], splitm, n_digits <> 0));
+  end;
+  // Generate digits
+  inc(n_digits, d2a_gen_digits_32(@buf[n_digits], splitl, n_digits <> 0));
+  result := n_digits;
+end;
+
+{$endif FPC_64}
+
+// Performs digit sequence rounding, returns decimal point correction
+function d2a_round_digits(var buf: TAsciiDigits; var n_current: integer;
+  n_max: PtrInt; half_round_to_even: boolean = true): PtrInt;
+var
+  n: PtrInt;
+  dig_round, dig_sticky: byte;
+  {$ifdef GRISU1_F2A_AGRESSIVE_ROUNDUP}
+  i: PtrInt;
+  {$endif GRISU1_F2A_AGRESSIVE_ROUNDUP}
+begin
+  result := 0;
+  n := n_current;
+  n_current := n_max;
+  // Get round digit
+  dig_round := buf[n_max];
+{$ifdef GRISU1_F2A_AGRESSIVE_ROUNDUP}
+  // Detect if rounding-up the second last digit turns the "dig_round"
+  // into "5"; also make sure we have at least 1 digit between "dig_round"
+  // and the second last.
+  if not half_round_to_even then
+    if (dig_round = 4) and
+       (n_max < n - 3) then
+      if buf[n - 2] >= 8 then // somewhat arbitrary...
+      begin
+        // check for only "9" are in between
+        i := n - 2;
+        repeat
+          dec(i);
+        until (i = n_max) or
+              (buf[i] <> 9);
+        if i = n_max then
+          // force round-up
+          dig_round := 9; // any value ">=5"
+      end;
+{$endif GRISU1_F2A_AGRESSIVE_ROUNDUP}
+  if dig_round < 5 then
+    exit;
+  // Handle "round half to even" case
+  if (dig_round = 5) and
+     half_round_to_even and
+     ((n_max = 0) or
+      (buf[n_max - 1] and 1 = 0)) then
+  begin
+    // even and a half: check if exactly the half
+    dig_sticky := 0;
+    while (n > n_max + 1) and (dig_sticky = 0) do
+    begin
+      dec(n);
+      dig_sticky := buf[n];
+    end;
+    if dig_sticky = 0 then
+      exit; // exactly a half -> no rounding is required
+  end;
+  // Round-up
+  while n_max > 0 do
+  begin
+    dec(n_max);
+    inc(buf[n_max]);
+    if buf[n_max] < 10 then
+    begin
+      // no more overflow: stop now
+      n_current := n_max + 1;
+      exit;
+    end;
+    // continue rounding
+  end;
+  // Overflow out of the 1st digit, all n_max digits became 0
+  buf[0] := 1;
+  n_current := 1;
+  result := 1;
+end;
+
+// format the number in the fixed-point representation
+procedure d2a_return_fixed(str: PAnsiChar; minus: boolean;
+  var digits: TAsciiDigits; n_digits_have, fixed_dot_pos, frac_digits: integer);
+var
+  p: PAnsiChar;
+  d: PByte;
+  cut_digits_at, n_before_dot, n_before_dot_pad0, n_after_dot_pad0,
+  n_after_dot, n_tail_pad0: integer;
+begin
+  // Round digits if necessary
+  cut_digits_at := fixed_dot_pos + frac_digits;
+  if cut_digits_at < 0 then
+    // zero
+    n_digits_have := 0
+  else if cut_digits_at < n_digits_have then
+    // round digits
+    inc(fixed_dot_pos, d2a_round_digits(digits, n_digits_have, cut_digits_at
+      {$ifdef GRISU1_F2A_HALF_ROUNDUP}, false {$endif} ));
+  // Before dot: digits, pad0
+  if (fixed_dot_pos <= 0) or
+     (n_digits_have = 0) then
+  begin
+    n_before_dot := 0;
+    n_before_dot_pad0 := 1;
+  end
+  else if fixed_dot_pos > n_digits_have then
+  begin
+    n_before_dot := n_digits_have;
+    n_before_dot_pad0 := fixed_dot_pos - n_digits_have;
+  end
+  else
+  begin
+    n_before_dot := fixed_dot_pos;
+    n_before_dot_pad0 := 0;
+  end;
+  // After dot: pad0, digits, pad0
+  if fixed_dot_pos < 0 then
+    n_after_dot_pad0 := -fixed_dot_pos
+  else
+    n_after_dot_pad0 := 0;
+  if n_after_dot_pad0 > frac_digits then
+    n_after_dot_pad0 := frac_digits;
+  n_after_dot := n_digits_have - n_before_dot;
+  n_tail_pad0 := frac_digits - n_after_dot - n_after_dot_pad0;
+  p := str + 1;
+  // Sign
+  if minus then
+  begin
+    p^ := '-';
+    inc(p);
+  end;
+  // integer significant digits
+  d := @digits;
+  if n_before_dot > 0 then
+    repeat
+      p^ := AnsiChar(d^ + ord('0'));
+      inc(p);
+      inc(d);
+      dec(n_before_dot);
+    until n_before_dot = 0;
+  // integer 0-padding
+  if n_before_dot_pad0 > 0 then
+    repeat
+      p^ := '0';
+      inc(p);
+      dec(n_before_dot_pad0);
+    until n_before_dot_pad0 = 0;
+  // Fractional part
+  if frac_digits <> 0 then
+  begin
+    // Dot
+    p^ := '.';
+    inc(p);
+    // Pre-fraction 0-padding
+    if n_after_dot_pad0 > 0 then
+      repeat
+        p^ := '0';
+        inc(p);
+        dec(n_after_dot_pad0);
+      until n_after_dot_pad0 = 0;
+    // Fraction significant digits
+    if n_after_dot > 0 then
+      repeat
+        p^ := AnsiChar(d^ + ord('0'));
+        inc(p);
+        inc(d);
+        dec(n_after_dot);
+      until n_after_dot = 0;
+    // Tail 0-padding
+    if n_tail_pad0 > 0 then
+      repeat
+        p^ := '0';
+        inc(p);
+        dec(n_tail_pad0);
+      until n_tail_pad0 = 0;
+  end;
+  // Store length
+  str[0] := AnsiChar(p - str - 1);
+end;
+
+// formats the number as exponential representation
+procedure d2a_return_exponential(str: PAnsiChar; minus: boolean;
+  digits: PByte; n_digits_have, n_digits_req, d_exp: PtrInt);
+var
+  p, exp: PAnsiChar;
+begin
+  p := str + 1;
+  // Sign
+  if minus then
+  begin
+    p^ := '-';
+    inc(p);
+  end;
+  // integer part
+  if n_digits_have > 0 then
+  begin
+    p^ := AnsiChar(digits^ + ord('0'));
+    dec(n_digits_have);
+  end
+  else
+    p^ := '0';
+  inc(p);
+  // Dot
+  if n_digits_req > 1 then
+  begin
+    p^ := '.';
+    inc(p);
+  end;
+  // Fraction significant digits
+  if n_digits_req < n_digits_have then
+    n_digits_have := n_digits_req;
+  if n_digits_have > 0 then
+  begin
+    repeat
+      inc(digits);
+      p^ := AnsiChar(digits^ + ord('0'));
+      inc(p);
+      dec(n_digits_have);
+    until n_digits_have = 0;
+    while p[-1] = '0' do
+      dec(p); // trim #.###00000 -> #.###
+    if p[-1] = '.' then
+      dec(p); // #.0 -> #
+  end;
+  // Exponent designator
+  p^ := 'E';
+  inc(p);
+  // Exponent sign (+ is not stored, as in Delphi)
+  if d_exp < 0 then
+  begin
+    p^ := '-';
+    d_exp := -d_exp;
+    inc(p);
+  end;
+  // Exponent digits
+  exp := pointer(SmallUInt32Utf8[d_exp]); // 0..999 range is fine
+  PCardinal(p)^ := PCardinal(exp)^;
+  inc(p, PStrLen(exp - _STRLEN)^);
+  // Store length
+  str[0] := AnsiChar(p - str - 1);
+end;
+
+/// set one of special results with proper sign
+procedure d2a_return_special(str: PAnsiChar; sign: integer;
+  const spec: ShortString);
+begin
+  // Compute length
+  str[0] := spec[0];
+  if sign <> 0 then
+    inc(str[0]);
+  inc(str);
+  // Sign
+  if sign <> 0 then
+  begin
+    if sign > 0 then
+      str^ := '+'
+    else
+      str^ := '-';
+    inc(str);
+  end;
+  // Special text (3 chars)
+  PCardinal(str)^ := PCardinal(@spec[1])^;
+end;
+
+
+// Calculates the exp10 of a factor required to bring the binary exponent
+// of the original number into selected [ alpha .. gamma ] range:
+// result := ceiling[ ( alpha - e ) * log10(2) ]
+function d2a_k_comp(e, alpha{, gamma}: integer): integer;
+var
+  dexp: double;
+const
+  D_LOG10_2: double = 0.301029995663981195213738894724493027; // log10(2)
+var
+  x, n: integer;
+begin
+  x := alpha - e;
+  dexp := x * D_LOG10_2;
+  // ceil( dexp )
+  n := trunc(dexp);
+  if x > 0 then
+    if dexp <> n then
+      inc(n); // round-up
+  result := n;
+end;
+
+procedure DoubleToAscii(min_width, frac_digits: integer; const v: double;
+  str: PAnsiChar);
+var
+  w, D: TDIY_FP;
+  c_mk: TDIY_FP_Power_of_10;
+  n, mk, dot_pos, n_digits_need, n_digits_have: integer;
+  n_digits_req, n_digits_sci: integer;
+  minus: boolean;
+  fl, one_maskl: qword;
+  one_e: integer;
+  {$ifdef CPU32}
+  one_mask, f: cardinal; // run a 2nd loop with 32-bit range
+  {$endif CPU32}
+  buf: TAsciiDigits;
+begin
+  // Limit parameters
+  if frac_digits > 216 then
+    frac_digits := 216; // Delphi compatible
+  if min_width <= C_NO_MIN_WIDTH then
+    min_width := -1 // no minimal width
+  else if min_width < 0 then
+    min_width := 0; // minimal width is as short as possible
+  // Format profile: select "n_digits_need" (and "n_digits_exp")
+  n_digits_req := nDig_mantissa;
+  // number of digits to be calculated by Grisu
+  n_digits_need := nDig_mantissa;
+  if n_digits_req < n_digits_need then
+    n_digits_need := n_digits_req;
+  // number of mantissa digits to be printed in exponential notation
+  if min_width < 0 then
+    n_digits_sci := n_digits_req
+  else
+  begin
+    n_digits_sci := min_width -1 {sign} -1 {dot} -1 {E} -1 {E-sign} - nDig_exp10;
+    if n_digits_sci < 2 then
+      n_digits_sci := 2; // at least 2 digits
+    if n_digits_sci > n_digits_req then
+      n_digits_sci := n_digits_req; // at most requested by real_type
+  end;
+  // Float -> DIY_FP
+  d2a_unpack_float(v, minus, w);
+  // Handle Zero
+  if (w.e = 0) and
+     (w.f = 0) then
+  begin
+    {$ifdef GRISU1_F2A_ZERONOFRACT}
+    PCardinal(str)^ := 1 + ord('0') shl 8; // just return '0'
+    {$else}
+    if frac_digits >= 0 then
+      d2a_return_fixed(str, minus, buf, 0, 1, frac_digits)
+    else
+      d2a_return_exponential(str, minus, @buf, 0, n_digits_sci, 0);
+    {$endif GRISU1_F2A_ZERONOFRACT}
+    exit;
+  end;
+  // Handle specials
+  if w.e = C_EXP2_SPECIAL then
+  begin
+    n := 1 - ord(minus) * 2; // default special sign [-1|+1]
+    if w.f = 0 then
+      d2a_return_special(str, n, C_STR_INF)
+    else
+    begin
+      // NaN [also pseudo-NaN, pseudo-Inf, non-normal for floatx80]
+      {$ifdef GRISU1_F2A_NAN_SIGNLESS}
+      n := 0;
+      {$endif GRISU1_F2A_NAN_SIGNLESS}
+      {$ifndef GRISU1_F2A_NO_SNAN}
+      if (w.f and (C_MANT2_INTEGER shr 1)) = 0 then
+        return_special(str, n, C_STR_SNAN)
+      else
+      {$endif GRISU1_F2A_NO_SNAN}
+        d2a_return_special(str, n, C_STR_QNAN);
+    end;
+    exit;
+  end;
+  // Handle denormals
+  if w.e <> 0 then
+  begin
+    // normal
+    w.f := w.f or C_MANT2_INTEGER;
+    n := C_DIY_FP_Q - C_FRAC2_BITS - 1;
+  end
+  else
+  begin
+    // denormal
+    n := 63 - BSRqword(w.f);
+    inc(w.e);
+  end;
+  // Final normalization
+  w.f := w.f shl n;
+  dec(w.e, C_EXP2_BIAS + n + C_FRAC2_BITS);
+  // 1. Find the normalized "c_mk = f_c * 2^e_c" such that
+  //    "alpha <= e_c + e_w + q <= gamma"
+  // 2. Define "V = D * 10^k": multiply the input number by "c_mk", do not
+  //    normalize to land into [ alpha .. gamma ]
+  // 3. Generate digits ( n_digits_need + "round" )
+  if (C_GRISU_ALPHA <= w.e) and
+     (w.e <= C_GRISU_GAMMA) then
+  begin
+    // no scaling required
+    D := w;
+    c_mk.e10 := 0;
+  end
+  else
+  begin
+    mk := d2a_k_comp(w.e, C_GRISU_ALPHA{, C_GRISU_GAMMA} );
+    d2a_diy_fp_cached_power10(mk, c_mk);
+    // Let "D = f_D * 2^e_D := w (*) c_mk"
+    if c_mk.e10 = 0 then
+      D := w
+    else
+      d2a_diy_fp_multiply(w, c_mk.c, false, D);
+  end;
+  // Generate digits: integer part
+  n_digits_have := d2a_gen_digits_64(@buf, D.f shr (-D.e));
+  dot_pos := n_digits_have;
+  // Generate digits: fractional part
+  {$ifdef CPU32}
+  f := 0; // "sticky" digit
+  {$endif CPU32}
+  if D.e < 0 then
+    repeat
+      // MOD by ONE
+      one_e := D.e;
+      one_maskl := qword(1) shl (-D.e) - 1;
+      fl := D.f and one_maskl;
+      // 64-bit loop (very efficient on x86_64, slower on i386)
+      while {$ifdef CPU32} (one_e < -29) and {$endif}
+            (n_digits_have < n_digits_need + 1) and (fl <> 0) do
+      begin
+        // f := f * 5;
+        inc(fl, fl shl 2);
+        // one := one / 2
+        one_maskl := one_maskl shr 1;
+        inc(one_e);
+        // DIV by one
+        buf[n_digits_have] := fl shr (-one_e);
+        // MOD by one
+        fl := fl and one_maskl;
+        // next
+        inc(n_digits_have);
+      end;
+      {$ifdef CPU32}
+      if n_digits_have >= n_digits_need + 1 then
+      begin
+        // only "sticky" digit remains
+        f := ord(fl <> 0);
+        break;
+      end;
+      one_mask := cardinal(one_maskl);
+      f := cardinal(fl);
+      // 32-bit loop
+      while (n_digits_have < n_digits_need + 1) and (f <> 0) do
+      begin
+        // f := f * 5;
+        inc(f, f shl 2);
+        // one := one / 2
+        one_mask := one_mask shr 1;
+        inc(one_e);
+        // DIV by one
+        buf[n_digits_have] := f shr (-one_e);
+        // MOD by one
+        f := f and one_mask;
+        // next
+        inc(n_digits_have);
+      end;
+      {$endif CPU32}
+    until true;
+  {$ifdef CPU32}
+  // Append "sticky" digit if any
+  if (f <> 0) and
+     (n_digits_have >= n_digits_need + 1) then
+  begin
+    // single "<>0" digit is enough
+    n_digits_have := n_digits_need + 2;
+    buf[n_digits_need + 1] := 1;
+  end;
+  {$endif CPU32}
+  // Round to n_digits_need using "roundTiesToEven"
+  if n_digits_have > n_digits_need then
+    inc(dot_pos, d2a_round_digits(buf, n_digits_have, n_digits_need));
+  // Generate output
+  if frac_digits >= 0 then
+  begin
+    d2a_return_fixed(str, minus, buf, n_digits_have, dot_pos - c_mk.e10,
+      frac_digits);
+    exit;
+  end;
+  if n_digits_have > n_digits_sci then
+    inc(dot_pos, d2a_round_digits(buf, n_digits_have, n_digits_sci
+      {$ifdef GRISU1_F2A_HALF_ROUNDUP}, false {$endif} ));
+  d2a_return_exponential(str, minus, @buf, n_digits_have, n_digits_sci,
+    dot_pos - c_mk.e10 - 1);
+end;
+
+function DoubleToShort(S: PShortString; const Value: double): integer;
+var
+  valueabs: double;
+begin
+  valueabs := abs(Value);
+  if (valueabs > {$ifdef FPC}double{$endif}(DOUBLE_HI)) or
+     (valueabs < {$ifdef FPC}double{$endif}(DOUBLE_LO)) then
+    // = str(Value,S) for scientific notation outside of 1E-9 '0.5'
+    inc(d,2);
+    inc(s);
+    c := s^;
+  end;
+  if (c >= '0') and
+     (c <= '9') then
+    repeat
+      inc(s);
+      d^ := c;
+      inc(d);
+      c := s^;
+      if ((c >= '0') and
+          (c <= '9')) or
+         (c = '.') then
+        continue;
+      if (c <> 'e') and
+         (c <> 'E') then
+        break;
+      inc(s);
+      d^ := c; // 1.23e120 or 1.23e-45
+      inc(d);
+      c := s^;
+      if c = '-' then
+      begin
+        inc(s);
+        d^ := c;
+        inc(d);
+        c := s^;
+      end;
+      while (c >= '0') and
+            (c <= '9') do
+      begin
+        inc(s);
+        d^ := c;
+        inc(d);
+        c := s^;
+      end;
+      break;
+    until false;
+  result := d;
+end;
+
+function Char2ToByte(P: PUtf8Char; out Value: cardinal;
+   ConvertHexToBinTab: PByteArray): boolean;
+var
+  B: PtrUInt;
+begin
+  B := ConvertHexToBinTab[ord(P[0])];
+  if B <= 9 then
+  begin
+    Value := B;
+    B := ConvertHexToBinTab[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;
+   ConvertHexToBinTab: PByteArray): boolean;
+var
+  B: PtrUInt;
+begin
+  B := ConvertHexToBinTab[ord(P[0])];
+  if B <= 9 then
+  begin
+    Value := B;
+    B := ConvertHexToBinTab[ord(P[1])];
+    if B <= 9 then
+    begin
+      Value := Value * 10 + B;
+      B := ConvertHexToBinTab[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;
+   ConvertHexToBinTab: PByteArray): boolean;
+var
+  B: PtrUInt;
+begin
+  B := ConvertHexToBinTab[ord(P[0])];
+  if B <= 9 then
+  begin
+    Value := B;
+    B := ConvertHexToBinTab[ord(P[1])];
+    if B <= 9 then
+    begin
+      Value := Value * 10 + B;
+      B := ConvertHexToBinTab[ord(P[2])];
+      if B <= 9 then
+      begin
+        Value := Value * 10 + B;
+        B := ConvertHexToBinTab[ord(P[3])];
+        if B <= 9 then
+        begin
+          Value := Value * 10 + B;
+          result := false;
+          exit;
+        end;
+      end;
+    end;
+  end;
+  result := true; // error
+end;
+
+procedure VariantToUtf8(const V: Variant; var result: RawUtf8;
+  var wasString: boolean);
+var
+  tmp: TVarData;
+  vt: cardinal;
+begin
+  wasString := false;
+  vt := TVarData(V).VType;
+  with TVarData(V) do
+    case vt of
+      varEmpty, varNull:
+        result := NULL_STR_VAR;
+      varSmallint:
+        Int32ToUtf8(VSmallInt, result);
+      varShortInt:
+        Int32ToUtf8(VShortInt, result);
+      varWord:
+        UInt32ToUtf8(VWord, result);
+      varLongWord:
+        UInt32ToUtf8(VLongWord, result);
+      varByte:
+        result := SmallUInt32Utf8[VByte];
+      varBoolean:
+        if VBoolean then
+          result := SmallUInt32Utf8[1]
+        else
+          result := SmallUInt32Utf8[0];
+      varInteger:
+        Int32ToUtf8(VInteger, result);
+      varInt64:
+        Int64ToUtf8(VInt64, result);
+      varWord64:
+        UInt64ToUtf8(VInt64, result);
+      varSingle:
+        ExtendedToStr(VSingle, SINGLE_PRECISION, result);
+      varDouble:
+        DoubleToStr(VDouble, result);
+      varCurrency:
+        Curr64ToStr(VInt64, result);
+      varDate:
+        begin
+          _VariantToUtf8DateTimeToIso8601(VDate, 'T', result, {withms=}false);
+          wasString := true;
+        end;
+      varString:
+        begin
+          wasString := true;
+          {$ifdef HASCODEPAGE}
+          AnyAnsiToUtf8(RawByteString(VString), result);
+          {$else}
+          result := RawUtf8(VString);
+          {$endif HASCODEPAGE}
+        end;
+      {$ifdef HASVARUSTRING}
+      varUString:
+        begin
+          wasString := true;
+          RawUnicodeToUtf8(VAny, length(UnicodeString(VAny)), result);
+        end;
+      {$endif HASVARUSTRING}
+      varOleStr:
+        begin
+          wasString := true;
+          RawUnicodeToUtf8(VAny, length(WideString(VAny)), result);
+        end;
+      varOlePAnsiChar: // = VT_LPSTR
+        begin
+          wasString := true;
+          CurrentAnsiConvert.AnsiBufferToRawUtf8(VString, StrLen(VString), result);
+        end;
+      varOlePWideChar: // = VT_LPWSTR
+        begin
+          wasString := true;
+          RawUnicodeToUtf8(VAny, StrLenW(VAny), result);
+        end;
+    else
+      if SetVariantUnRefSimpleValue(V, tmp{%H-}) then
+        // simple varByRef
+        VariantToUtf8(Variant(tmp), result, wasString)
+      else if vt = varVariantByRef then{%H-}
+        // complex varByRef
+        VariantToUtf8(PVariant(VPointer)^, result, wasString)
+      else if vt = varStringByRef then
+      begin
+        wasString := true;
+        {$ifdef HASCODEPAGE}
+        AnyAnsiToUtf8(PRawByteString(VString)^, result);
+        {$else}
+        result := PRawUtf8(VString)^;
+        {$endif HASCODEPAGE}
+      end
+      else if vt = varOleStrByRef then
+      begin
+        wasString := true;
+        RawUnicodeToUtf8(pointer(PWideString(VAny)^),
+          length(PWideString(VAny)^), result);
+      end
+      else
+      {$ifdef HASVARUSTRING}
+      if vt = varUStringByRef then
+      begin
+        wasString := true;
+        RawUnicodeToUtf8(pointer(PUnicodeString(VAny)^),
+          length(PUnicodeString(VAny)^), result);
+      end
+      else
+      {$endif HASVARUSTRING}
+        // not recognizable vt -> seralize as JSON to handle also custom types
+        _VariantSaveJson(V, twJsonEscape, result); // = mormot.core.variants.pas
+    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 ToUtf8(const V: TVarData): RawUtf8; overload;
+var
+  wasString: boolean;
+begin
+  VariantToUtf8(PVariant(@V)^, result, wasString);
+end;
+
+function VariantToUtf8(const V: Variant; var Text: RawUtf8): boolean;
+begin
+  VariantToUtf8(V, Text, result);
+end;
+
+function VariantToText(const V: Variant; var Text: RawUtf8): boolean;
+begin
+  result := not VarIsEmptyOrNull(V) and
+            VariantToUtf8(V, Text);
+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);
+begin
+  _VariantSaveJson(Value, Escape, result);
+end;
+
+procedure __VariantSaveJson(const Value: variant; Escape: TTextWriterKind;
+  var result: RawUtf8);
+begin
+  raise ESynException.Create('VariantSaveJson() unsupported:' +
+    ' please include mormot.core.variants to your uses clause');
+end;
+
+procedure __VariantToUtf8DateTimeToIso8601(DT: TDateTime; FirstChar: AnsiChar;
+  var result: RawUtf8; WithMS: boolean);
+begin
+  raise ESynException.Create('VariantToUtf8(varDate) unsupported:' +
+    ' please include mormot.core.datetime to your uses clause');
+end;
+
+function VariantCompAsText(A, B: PVarData; caseInsensitive: boolean): integer;
+var
+  au, bu: pointer;
+  wasString: boolean;
+begin
+  au := nil; // no try..finally for local RawUtf8 variables
+  bu := nil;
+  VariantToUtf8(PVariant(A)^, RawUtf8(au), wasString);
+  VariantToUtf8(PVariant(B)^, RawUtf8(bu), wasString);
+  result := SortDynArrayAnsiStringByCase[caseInsensitive](au, bu);
+  FastAssignNew(au);
+  FastAssignNew(bu);
+end;
+
+function Int18ToChars3(Value: cardinal): RawUtf8;
+begin
+  FastSetString(result, 3);
+  PCardinal(result)^ := ((Value shr 12) and $3f) or
+                        ((Value shr 6) and $3f) shl 8 or
+                        (Value and $3f) shl 16 + $202020;
+end;
+
+procedure Int18ToChars3(Value: cardinal; var result: RawUtf8);
+begin
+  FastSetString(result, 3);
+  PCardinal(result)^ := ((Value shr 12) and $3f) or
+                        ((Value shr 6) and $3f) shl 8 or
+                        (Value and $3f) shl 16 + $202020;
+end;
+
+function Chars3ToInt18(P: pointer): cardinal;
+begin
+  result := PCardinal(P)^ - $202020;
+  result := ((result shr 16) and $3f) or
+            ((result shr 8) and $3f) shl 6 or
+            (result and $3f) shl 12;
+end;
+
+function UInt3DigitsToUtf8(Value: cardinal): RawUtf8;
+begin
+  FastSetString(result, 3);
+  PWordArray(result)[0] := TwoDigitLookupW[Value div 10];
+  PByteArray(result)[2] := (Value mod 10) + 48;
+end;
+
+function UInt4DigitsToUtf8(Value: cardinal): RawUtf8;
+begin
+  FastSetString(result, 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;
+  PCardinal(@result[1])^ := TwoDigitLookupW[Value];
+end;
+
+function UInt2DigitsToShortFast(Value: byte): TShort4;
+begin
+  result[0] := #2;
+  PCardinal(@result[1])^ := TwoDigitLookupW[Value];
+end;
+
+function IPToCardinal(aIP: PUtf8Char; out aValue: cardinal): boolean;
+var
+  i, c: cardinal;
+  b: array[0..3] of byte;
+begin
+  aValue := 0;
+  result := false;
+  if (aIP = nil) or
+     (IdemPChar(aIP, '127.0.0.1') and
+      (aIP[9] = #0)) then
+    exit;
+  for i := 0 to 3 do
+  begin
+    c := GetNextItemCardinal(aIP, '.');
+    if (c > 255) or
+       ((aIP = nil) and
+        (i < 3)) then
+      exit;
+    b[i] := c;
+  end;
+  if PCardinal(@b)^ <> $0100007f then // may be e.g. '127.000.000.001'
+  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;
+
+
+{ ************ Text Formatting functions }
+
+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 VarRecAs(const aArg: TVarRec; aClass: TClass): pointer;
+begin
+  if (aArg.VType = vtObject) and
+     (aArg.VObject <> nil) and
+     aArg.VObject.InheritsFrom(aClass) then
+    result := aArg.VObject
+  else
+    result := nil;
+end;
+
+function VarRecToInt64(const V: TVarRec; out value: Int64): boolean;
+begin
+  case V.VType of
+    vtInteger:
+      value := V.VInteger;
+    {$ifdef FPC} vtQWord, {$endif}
+    vtInt64:
+      value := V.VInt64^;
+    vtBoolean:
+      if V.VBoolean then
+        value := 1
+      else
+        value := 0; // normalize
+    vtVariant:
+      value := V.VVariant^;
+  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 FPC}
+    vtBoolean:
+      if V.VBoolean then
+        value := 1
+      else
+        value := 0; // normalize
+    vtExtended:
+      value := V.VExtended^;
+    vtCurrency:
+      value := V.VCurrency^;
+    vtVariant:
+      value := V.VVariant^;
+  else
+    begin
+      result := false;
+      exit;
+    end;
+  end;
+  result := true;
+end;
+
+procedure BufToTempUtf8(Buf: PUtf8Char; var Res: TTempUtf8);
+begin // Res.Len has been set by caller
+  if Res.Len > SizeOf(Res.Temp) then
+  begin
+    FastSetString(RawUtf8(Res.TempRawUtf8), Buf, Res.Len); // new RawUtf8
+    Res.Text := Res.TempRawUtf8;
+  end
+  else
+  begin
+    {$ifdef CPUX86}
+    MoveFast(Buf^, Res.Temp, Res.Len);    // avoid slow "rep movsd" on FPC i386
+    {$else}
+    THash192(Res.Temp) := PHash192(Buf)^; // faster than MoveByOne/MoveFast
+    {$endif CPUX86}
+    Res.Text := @Res.Temp; // no RawUtf8 memory allocation
+  end;
+end;
+
+procedure DoubleToTempUtf8(V: double; var Res: TTempUtf8);
+var
+  tmp: shortstring;
+begin
+  Res.Len := DoubleToShort(@tmp, V);
+  BufToTempUtf8(@tmp[1], Res);
+end;
+
+procedure WideToTempUtf8(WideChar: PWideChar; WideCharCount: integer;
+  var Res: TTempUtf8);
+var
+  tmp: TSynTempBuffer;
+begin
+  if (WideChar = nil) or
+     (WideCharCount = 0) then
+  begin
+    Res.Text := nil;
+    Res.Len := 0;
+  end
+  else
+  begin
+    tmp.Init(WideCharCount * 3);
+    Res.Len := RawUnicodeToUtf8(tmp.buf, tmp.len + 1,
+      WideChar, WideCharCount, [ccfNoTrailingZero]);
+    BufToTempUtf8(tmp.buf, Res);
+    tmp.Done;
+  end;
+end;
+
+procedure PtrIntToTempUtf8(V: PtrInt; var Res: TTempUtf8);
+  {$ifdef HASINLINE} inline; {$endif}
+begin
+  {$ifndef ASMINTEL} // our StrInt32 asm has less CPU cache pollution
+  if PtrUInt(V) <= high(SmallUInt32Utf8) then
+  begin
+    Res.Text := pointer(SmallUInt32Utf8[V]);
+    Res.Len := PStrLen(Res.Text - _STRLEN)^;
+  end
+  else
+  {$endif ASMINTEL}
+  begin
+    Res.Text := PUtf8Char(StrInt32(@Res.Temp[23], V));
+    Res.Len := @Res.Temp[23] - Res.Text;
+  end;
+end;
+
+procedure Int64ToTempUtf8(V: PInt64; var Res: TTempUtf8);
+  {$ifdef HASINLINE} inline; {$endif}
+begin
+{$ifdef CPU64}
+  PtrIntToTempUtf8(V^, Res);
+{$else}
+  if (PCardinalArray(V)^[0] <= high(SmallUInt32Utf8)) and
+     (PCardinalArray(V)^[1] = 0) then
+  begin
+    Res.Text := pointer(SmallUInt32Utf8[PPtrInt(V)^]);
+    Res.Len := PStrLen(Res.Text - _STRLEN)^;
+  end
+  else
+  begin
+    Res.Text := PUtf8Char(StrInt64(@Res.Temp[23], V^));
+    Res.Len := @Res.Temp[23] - Res.Text;
+  end;
+{$endif CPU64}
+end;
+
+procedure QWordToTempUtf8(V: PQWord; var Res: TTempUtf8);
+  {$ifdef HASINLINE} inline; {$endif}
+begin
+  {$ifndef ASMINTEL} // our StrUInt64 asm has less CPU cache pollution
+  if V^ <= high(SmallUInt32Utf8) then
+  begin
+    Res.Text := pointer(SmallUInt32Utf8[PPtrInt(V)^]);
+    Res.Len := PStrLen(Res.Text - _STRLEN)^;
+  end
+  else
+  {$endif ASMINTEL}
+  begin
+    Res.Text := PUtf8Char(StrUInt64(@Res.Temp[23], V^));
+    Res.Len := @Res.Temp[23] - Res.Text;
+  end;
+end;
+
+procedure VariantToTempUtf8(const V: variant; var Res: TTempUtf8;
+  var wasString: boolean);
+var
+  tmp: TVarData;
+  vt: cardinal;
+begin
+  wasString := false;
+  Res.TempRawUtf8 := nil; // no allocation by default - and avoid GPF
+  vt := TVarData(V).VType;
+  with TVarData(V) do
+    case vt of
+      varEmpty,
+      varNull:
+        begin
+          Res.Text := pointer(NULL_STR_VAR);
+          Res.Len := 4;
+        end;
+      varSmallint:
+        PtrIntToTempUtf8(VSmallInt, Res);
+      varShortInt:
+        PtrIntToTempUtf8(VShortInt, Res);
+      varWord:
+        PtrIntToTempUtf8(VWord, Res);
+      varLongWord:
+        {$ifdef CPU32}
+        if VLongWord > high(SmallUInt32Utf8) then
+        begin
+          Res.Text := PUtf8Char(StrUInt32(@Res.Temp[23], VLongWord));
+          Res.Len := @Res.Temp[23] - Res.Text;
+        end
+        else
+        {$endif CPU32}
+          PtrIntToTempUtf8(VLongWord, Res);
+      varByte:
+        PtrIntToTempUtf8(VByte, Res);
+      varBoolean:
+        if VBoolean then
+        begin
+          Res.Text := @BOOL_STR[true][1];
+          Res.Len := 4;
+        end
+        else
+        begin
+          Res.Text := @BOOL_STR[false][1];
+          Res.Len := 5;
+        end;
+      varInteger:
+        PtrIntToTempUtf8(VInteger, Res);
+      varInt64:
+        Int64ToTempUtf8(@VInt64, Res);
+      varWord64:
+        QWordToTempUtf8(@VInt64, Res);
+      varSingle:
+        DoubleToTempUtf8(VSingle, Res);
+      varDouble:
+        DoubleToTempUtf8(VDouble, Res);
+      varCurrency:
+        begin
+          Res.Len := Curr64ToPChar(VInt64, @Res.Temp);
+          Res.Text := @Res.Temp;
+        end;
+      varDate:
+        begin
+          wasString := true;
+          _VariantToUtf8DateTimeToIso8601(VDate, 'T', RawUtf8(Res.TempRawUtf8), false);
+          Res.Text := pointer(Res.TempRawUtf8);
+          Res.Len := length(RawUtf8(Res.TempRawUtf8));
+        end;
+      varString:
+        begin
+          wasString := true;
+          Res.Text := VString; // assume RawUtf8
+          Res.Len := length(RawUtf8(VString));
+        end;
+      {$ifdef HASVARUSTRING}
+      varUString:
+        begin
+          wasString := true;
+          WideToTempUtf8(VAny, length(UnicodeString(VAny)), Res);
+        end;
+      {$endif HASVARUSTRING}
+      varOleStr:
+        begin
+          wasString := true;
+          WideToTempUtf8(VAny, length(WideString(VAny)), Res);
+        end;
+    else
+      if SetVariantUnRefSimpleValue(V, tmp{%H-}) then
+        // simple varByRef
+        VariantToTempUtf8(Variant(tmp), Res, wasString)
+      else if vt = varVariantByRef then{%H-}
+        // complex varByRef
+        VariantToTempUtf8(PVariant(VPointer)^, Res, wasString)
+      else if vt = varStringByRef then
+      begin
+        wasString := true;
+        Res.Text := PPointer(VString)^; // assume RawUtf8
+        Res.Len := length(PRawUtf8(VString)^);
+      end
+      else if vt = varOleStrByRef then
+      begin
+        wasString := true;
+        WideToTempUtf8(PPointer(VAny)^, length(PWideString(VAny)^), Res);
+      end
+      else
+      {$ifdef HASVARUSTRING}
+      if vt = varUStringByRef then
+      begin
+        wasString := true;
+        WideToTempUtf8(PPointer(VAny)^, length(PUnicodeString(VAny)^), Res);
+      end
+      else
+      {$endif HASVARUSTRING}
+      begin
+        // not recognizable vt -> seralize as JSON to handle also custom types
+        wasString := true;
+        _VariantSaveJson(V, twJsonEscape, RawUtf8(Res.TempRawUtf8));
+        Res.Text := pointer(Res.TempRawUtf8);
+        Res.Len := length(RawUtf8(Res.TempRawUtf8));
+      end;
+   end;
+end;
+
+function VarRecToTempUtf8(const V: TVarRec; var Res: TTempUtf8;
+  wasString: PBoolean): PtrInt;
+var
+  isString: boolean;
+begin
+  isString := true;
+  Res.TempRawUtf8 := nil; // no allocation by default - and avoid GPF
+  case V.VType of
+    vtString:
+      if V.VString = nil then
+        Res.Len := 0
+      else
+      begin
+        Res.Text := @V.VString^[1];
+        Res.Len := ord(V.VString^[0]);
+      end;
+    vtAnsiString:
+      begin
+        // expect UTF-8 content
+        Res.Text := pointer(V.VAnsiString);
+        Res.Len := length(RawUtf8(V.VAnsiString));
+      end;
+    {$ifdef HASVARUSTRING}
+    vtUnicodeString:
+      WideToTempUtf8(V.VPWideChar, length(UnicodeString(V.VUnicodeString)), Res);
+    {$endif HASVARUSTRING}
+    vtWideString:
+      WideToTempUtf8(V.VPWideChar, length(WideString(V.VWideString)), Res);
+    vtPChar:
+      begin
+        // expect UTF-8 content
+        Res.Text := V.VPointer;
+        Res.Len := mormot.core.base.StrLen(V.VPointer);
+      end;
+    vtChar:
+      begin
+        Res.Temp[0] := V.VChar; // V may be on transient stack (alf: FPC)
+        Res.Text := @Res.Temp;
+        Res.Len := 1;
+      end;
+    vtPWideChar:
+      WideToTempUtf8(V.VPWideChar, StrLenW(V.VPWideChar), Res);
+    vtWideChar:
+      WideToTempUtf8(@V.VWideChar, 1, Res);
+    vtBoolean:
+      begin
+        isString := false;
+        if V.VBoolean then // normalize
+          Res.Text := pointer(SmallUInt32Utf8[1])
+        else
+          Res.Text := pointer(SmallUInt32Utf8[0]);
+        Res.Len := 1;
+      end;
+    vtInteger:
+      begin
+        isString := false;
+        PtrIntToTempUtf8(V.VInteger, Res);
+      end;
+    vtInt64:
+      begin
+        isString := false;
+        Int64ToTempUtf8(V.VInt64, Res);
+      end;
+    {$ifdef FPC}
+    vtQWord:
+      begin
+        isString := false;
+        QwordToTempUtf8(V.VQWord, Res);
+      end;
+    {$endif FPC}
+    vtCurrency:
+      begin
+        isString := false;
+        Res.Text := @Res.Temp;
+        Res.Len := Curr64ToPChar(V.VInt64^, Res.Temp);
+      end;
+    vtExtended:
+      begin
+        isString := false;
+        DoubleToTempUtf8(V.VExtended^, Res);
+      end;
+    vtPointer, vtInterface:
+      begin
+        Res.Text := @Res.Temp;
+        Res.Len := DisplayMinChars(@V.VPointer, SizeOf(pointer)) * 2;
+        BinToHexDisplayLower(@V.VPointer, @Res.Temp, Res.Len shr 1);
+      end;
+    vtClass:
+      if V.VClass = nil then
+        Res.Len := 0
+      else
+      begin
+        Res.Text := PPUtf8Char(PtrInt(PtrUInt(V.VClass)) + vmtClassName)^ + 1;
+        Res.Len := ord(Res.Text[-1]);
+      end;
+    vtObject:
+      if V.VObject = nil then
+        Res.Len := 0
+      else
+      begin
+        Res.Text := PPUtf8Char(PPtrInt(V.VObject)^ + vmtClassName)^ + 1;
+        Res.Len := ord(Res.Text[-1]);
+      end;
+    vtVariant:
+      VariantToTempUtf8(V.VVariant^, Res, isString);
+  else
+    Res.Len := 0;
+  end;
+  result := Res.Len;
+  if wasString <> nil then
+    wasString^ := isString;
+end;
+
+procedure VarRecToUtf8(const V: TVarRec; var result: RawUtf8; wasString: PBoolean);
+var
+  isString: boolean;
+label
+  none;
+begin
+  isString := false;
+  with V do
+    case V.VType of
+      vtString:
+        begin
+          isString := true;
+          if VString = nil then
+            goto none;
+          FastSetString(result, @VString^[1], ord(VString^[0]));
+        end;
+      vtAnsiString:
+        begin
+          isString := true;
+          result := RawUtf8(VAnsiString); // expect UTF-8 content
+        end;
+      {$ifdef HASVARUSTRING}
+      vtUnicodeString:
+        begin
+          isString := true;
+          RawUnicodeToUtf8(VUnicodeString,
+            length(UnicodeString(VUnicodeString)), result);
+        end;
+      {$endif HASVARUSTRING}
+      vtWideString:
+        begin
+          isString := true;
+          RawUnicodeToUtf8(VWideString, length(WideString(VWideString)), result);
+        end;
+      vtPChar:
+        begin
+          isString := true;
+          FastSetString(result, VPChar, mormot.core.base.StrLen(VPChar));
+        end;
+      vtChar:
+        begin
+          isString := true;
+          FastSetString(result, PAnsiChar(@VChar), 1);
+        end;
+      vtPWideChar:
+        begin
+          isString := true;
+          RawUnicodeToUtf8(VPWideChar, StrLenW(VPWideChar), result);
+        end;
+      vtWideChar:
+        begin
+          isString := true;
+          RawUnicodeToUtf8(@VWideChar, 1, result);
+        end;
+      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 FPC}
+      vtCurrency:
+        Curr64ToStr(VInt64^, result);
+      vtExtended:
+        DoubleToStr(VExtended^,result);
+      vtPointer:
+        begin
+          isString := true;
+          PointerToHex(VPointer, result);
+        end;
+      vtClass:
+        begin
+          isString := true;
+          if VClass <> nil then
+            ClassToText(VClass, result)
+          else
+none:       result := '';
+        end;
+      vtObject:
+        if VObject <> nil then
+          ClassToText(PClass(VObject)^, result)
+        else
+          goto none;
+      vtInterface:
+      {$ifdef HASINTERFACEASTOBJECT}
+        if VInterface <> nil then
+          ClassToText((IInterface(VInterface) as TObject).ClassType, result)
+        else
+          goto none;
+      {$else}
+        PointerToHex(VInterface,result);
+      {$endif HASINTERFACEASTOBJECT}
+      vtVariant:
+        VariantToUtf8(VVariant^, result, isString);
+    else
+      goto none;
+    end;
+  if wasString <> nil then
+    wasString^ := isString;
+end;
+
+function VarRecToUtf8IsString(const V: TVarRec; var value: RawUtf8): boolean;
+begin
+  VarRecToUtf8(V, value, @result);
+end;
+
+procedure VarRecToInlineValue(const V: TVarRec; var result: RawUtf8);
+var
+  wasString: boolean;
+  tmp: RawUtf8;
+begin
+  VarRecToUtf8(V, tmp, @wasString);
+  if wasString then
+    QuotedStr(tmp, '"', result)
+  else
+    result := tmp;
+end;
+
+function FormatUtf8(const Format: RawUtf8; const Args: array of const): RawUtf8;
+begin
+  FormatUtf8(Format, Args, result);
+end;
+
+function FormatVariant(const Format: RawUtf8; const Args: array of const): variant;
+begin
+  ClearVariantForString(result);
+  FormatUtf8(Format, Args, RawUtf8(TVarData(result).VString));
+end;
+
+type
+  // 3KB info on stack - only supported token is %, with any const arguments
+  {$ifdef USERECORDWITHMETHODS}
+  TFormatUtf8 = record
+  {$else}
+  TFormatUtf8 = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    last: PTempUtf8;
+    L: PtrInt;
+    blocks: array[0..63] of TTempUtf8; // to avoid most heap allocations
+    procedure TooManyArgs;
+    procedure Parse(const Format: RawUtf8; Arg: PVarRec; ArgCount: PtrInt);
+    procedure Add(const SomeText: RawUtf8);
+    procedure DoDelim(Arg: PVarRec; ArgCount: integer; EndWithDelim: boolean;
+      Delim: AnsiChar);
+    procedure DoAdd(Arg: PVarRec; ArgCount: integer);
+      {$ifdef HASINLINE} inline; {$endif}
+    procedure DoAppendLine(var Text: RawUtf8; Arg: PVarRec; ArgCount: PtrInt;
+      const Separator: shortstring);
+    procedure DoPrepend(var Text: RawUtf8; Arg: PVarRec;
+      ArgCount, CodePage: PtrInt);
+    procedure Write(Dest: PUtf8Char);
+    procedure WriteString(var result: string);
+    function WriteMax(Dest: PUtf8Char; Max: PtrUInt): PUtf8Char;
+  end;
+
+procedure TFormatUtf8.TooManyArgs;
+begin
+  raise ESynException.Create('TFormatUtf8: too many arguments');
+end;
+
+procedure TFormatUtf8.Parse(const Format: RawUtf8; Arg: PVarRec; ArgCount: PtrInt);
+var
+  F, FDeb: PUtf8Char;
+  c: PTempUtf8;
+begin
+  if ArgCount >= length(blocks) div 2 then
+    TooManyArgs;
+  L := 0;
+  c := @blocks;
+  F := pointer(Format);
+  repeat
+    if F^ = #0 then
+      break
+    else if F^ <> '%' then
+    begin
+      FDeb := F;
+      repeat
+        inc(F);
+      until (F^ = '%') or
+            (F^ = #0);
+      c^.Text := FDeb;
+      c^.Len := F - FDeb;
+      inc(L, c^.Len);
+      c^.TempRawUtf8 := nil;
+      inc(c);
+      if F^ = #0 then
+        break;
+    end;
+    inc(F); // jump '%'
+    if ArgCount <> 0 then
+    begin
+      inc(L, VarRecToTempUtf8(Arg^, c^));
+      if c^.Len > 0 then
+        inc(c);
+      inc(Arg);
+      dec(ArgCount);
+      if F^ = #0 then
+        break;
+    end
+    else // no more available Args -> add all remaining text
+    if F^ = #0 then
+      break
+    else
+    begin
+      c^.Text := F;
+      c^.Len := length(Format) - (F - pointer(Format));
+      inc(L, c^.Len);
+      c^.TempRawUtf8 := nil;
+      inc(c);
+      break;
+    end;
+  until false;
+  last := c;
+end;
+
+procedure TFormatUtf8.DoDelim(Arg: PVarRec; ArgCount: integer;
+  EndWithDelim: boolean; Delim: AnsiChar);
+var
+  c: PTempUtf8;
+begin
+  L := 0;
+  if ArgCount > 0 then
+    if ArgCount >= length(blocks) div 2 then
+      TooManyArgs
+    else
+    begin
+      c := @blocks;
+      repeat
+        inc(L, VarRecToTempUtf8(Arg^, c^));
+        inc(Arg);
+        if (EndWithDelim and
+            (ArgCount = 1)) or
+           ((ArgCount <> 1) and
+            (c^.Len <> 0) and
+            (c^.Text[c^.Len - 1] <> Delim)) then
+        begin
+          inc(c);
+          c^.Len := 1;
+          c^.Text := @c^.Temp;
+          c^.Temp[0] := Delim;
+          c^.TempRawUtf8 := nil;
+          inc(L);
+        end;
+        inc(c);
+        dec(ArgCount);
+      until ArgCount = 0;
+      last := c;
+    end;
+end;
+
+procedure TFormatUtf8.Add(const SomeText: RawUtf8);
+begin
+  if PtrUInt(last) > PtrUInt(@blocks[high(blocks)]) then
+    TooManyArgs;
+  with last^ do
+  begin
+    Len := length(SomeText);
+    inc(L, Len);
+    Text := pointer(SomeText);
+    TempRawUtf8 := nil;
+  end;
+  inc(last);
+end;
+
+procedure TFormatUtf8.DoAdd(Arg: PVarRec; ArgCount: integer);
+begin
+  L := 0;
+  if ArgCount <= 0 then
+    exit
+  else if ArgCount > length(blocks) then
+    TooManyArgs;
+  last := @blocks;
+  repeat
+    inc(L, VarRecToTempUtf8(Arg^, last^));
+    inc(Arg);
+    inc(last);
+    dec(ArgCount)
+  until ArgCount = 0;
+end;
+
+procedure TFormatUtf8.DoAppendLine(var Text: RawUtf8;
+  Arg: PVarRec; ArgCount: PtrInt; const Separator: shortstring);
+var
+  c: PTempUtf8;
+begin
+  if ArgCount <= 0 then
+    exit
+  else if ArgCount >= length(blocks) then
+    TooManyArgs;
+  L := length(Text);
+  c := @blocks;
+  if (Text <> '') and
+     (Separator[0] <> #0) then
+  begin
+    c^.Len := ord(Separator[0]);
+    inc(L, c^.Len);
+    c^.Text := @Separator[1];
+    c^.TempRawUtf8 := nil;
+    inc(c);
+  end;
+  repeat
+    inc(L, VarRecToTempUtf8(Arg^, c^));
+    inc(Arg);
+    inc(c);
+    dec(ArgCount)
+  until ArgCount = 0;
+  last := c;
+  ArgCount := length(Text);
+  SetLength(Text, L); // realloc in-place and append the new text
+  Write(PUtf8Char(@PByteArray(Text)[ArgCount]));
+end;
+
+procedure TFormatUtf8.DoPrepend(var Text: RawUtf8; Arg: PVarRec;
+  ArgCount, CodePage: PtrInt);
+var
+  c: PTempUtf8;
+  new: PUtf8Char;
+begin
+  if ArgCount <= 0 then
+    exit;
+  L := length(Text);
+  c := @blocks;
+  repeat
+    inc(L, VarRecToTempUtf8(Arg^, c^));
+    inc(Arg);
+    inc(c);
+    dec(ArgCount)
+  until ArgCount = 0;
+  last := c;
+  ArgCount := length(Text);
+  new := pointer(FastNewString(L, CodePage));
+  MoveFast(pointer(Text)^, new[L - ArgCount], ArgCount);
+  FastAssignNew(Text, new);
+  Write(new);
+end;
+
+procedure TFormatUtf8.Write(Dest: PUtf8Char);
+var
+  d: PTempUtf8;
+begin
+  if L = 0 then
+    exit;
+  d := @blocks;
+  repeat
+    MoveFast(d^.Text^, Dest^, d^.Len); // no MoveByOne() - may be huge result
+    inc(Dest, d^.Len);
+    if d^.TempRawUtf8 <> nil then
+      {$ifdef FPC}
+      FastAssignNew(d^.TempRawUtf8);
+      {$else}
+      RawUtf8(d^.TempRawUtf8) := '';
+      {$endif FPC}
+    inc(d);
+  until d = last;
+end;
+
+function TFormatUtf8.WriteMax(Dest: PUtf8Char; Max: PtrUInt): PUtf8Char;
+var
+  d: PTempUtf8;
+begin
+  if (Max > 0) and
+     (L <> 0) and
+     (Dest <> nil) then
+  begin
+    inc(Max, PtrUInt(Dest));
+    d := @blocks;
+    repeat
+      if PtrUInt(Dest) + PtrUInt(d^.Len) > Max then
+      begin
+        // avoid buffer overflow
+        MoveFast(d^.Text^, Dest^, Max - PtrUInt(Dest));
+        repeat
+          if d^.TempRawUtf8 <> nil then
+            {$ifdef FPC}
+            FastAssignNew(d^.TempRawUtf8); // release temp RawUtf8
+            {$else}
+            RawUtf8(d^.TempRawUtf8) := '';
+            {$endif FPC}
+          inc(d);
+        until d = last; // avoid memory leak
+        result := PUtf8Char(Max);
+        exit;
+      end;
+      MoveFast(d^.Text^, Dest^, d^.Len);
+      inc(Dest, d^.Len);
+      if d^.TempRawUtf8 <> nil then
+        {$ifdef FPC}
+        FastAssignNew(d^.TempRawUtf8);
+        {$else}
+        RawUtf8(d^.TempRawUtf8) := '';
+        {$endif FPC}
+      inc(d);
+    until d = last;
+  end;
+  result := Dest;
+end;
+
+procedure TFormatUtf8.WriteString(var result: string);
+var
+  temp: TSynTempBuffer; // will avoid most memory allocations
+begin
+  result := '';
+  if L = 0 then
+    exit;
+  {$ifndef UNICODE}
+  if Unicode_CodePage = CP_UTF8 then // e.g. on POSIX or Windows + Lazarus
+  begin
+    FastSetString(RawUtf8(result), L);
+    Write(pointer(result)); // here string=UTF8String=RawUtf8
+    exit;
+  end;
+  {$endif UNICODE}
+  temp.Init(L);
+  Write(temp.buf);
+  Utf8DecodeToString(temp.buf, L, result);
+  temp.Done;
+end;
+
+procedure FormatUtf8(const Format: RawUtf8; const Args: array of const;
+  out result: RawUtf8);
+var
+  f: 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
+    f.Parse(Format, @Args[0], length(Args));
+    FastSetString(result, f.L);
+    f.Write(pointer(result));
+  end;
+end;
+
+procedure FormatShort(const Format: RawUtf8; const Args: array of const;
+  var result: ShortString);
+var
+  f: TFormatUtf8;
+begin
+  if (Format = '') or
+     (high(Args) < 0) then // no formatting needed
+    SetString(result, PAnsiChar(pointer(Format)), length(Format))
+  else
+  begin
+    f.Parse(Format, @Args[0], length(Args));
+    result[0] := AnsiChar(f.WriteMax(@result[1], 255) - @result[1]);
+  end;
+end;
+
+function FormatBuffer(const Format: RawUtf8; const Args: array of const;
+  Dest: pointer; DestLen: PtrInt): PtrInt;
+var
+  f: TFormatUtf8;
+begin
+  if (Dest = nil) or
+     (DestLen <= 0) then
+  begin
+    result := 0;
+    exit; // avoid buffer overflow
+  end;
+  f.Parse(Format, @Args[0], length(Args));
+  result := PtrUInt(f.WriteMax(Dest, DestLen)) - PtrUInt(Dest);
+end;
+
+function FormatToShort(const Format: RawUtf8;
+  const Args: array of const): ShortString;
+var
+  f: TFormatUtf8;
+begin
+  f.Parse(Format, @Args[0], length(Args));
+  result[0] := AnsiChar(f.WriteMax(@result[1], 255) - @result[1]);
+end;
+
+procedure FormatShort16(const Format: RawUtf8; const Args: array of const;
+  var result: TShort16);
+var
+  f: TFormatUtf8;
+begin
+  if (Format = '') or
+     (high(Args) < 0) then // no formatting needed
+    SetString(result, PAnsiChar(pointer(Format)), length(Format))
+  else
+  begin
+    f.Parse(Format, @Args[0], length(Args));
+    result[0] := AnsiChar(f.WriteMax(@result[1], 16) - @result[1]);
+  end;
+end;
+
+procedure FormatString(const Format: RawUtf8; const Args: array of const;
+  out result: string);
+var
+  f: TFormatUtf8;
+begin
+  if (Format = '') or
+     (high(Args) < 0) then
+    // no formatting needed
+    Utf8ToStringVar(Format, result)
+  else
+  begin
+    f.Parse(Format, @Args[0], length(Args));
+    f.WriteString(result);
+  end;
+end;
+
+function FormatString(const Format: RawUtf8; const Args: array of const): string;
+begin
+  FormatString(Format, Args, result);
+end;
+
+procedure AppendLine(var Text: RawUtf8; const Args: array of const;
+  const Separator: shortstring);
+var
+  f: TFormatUtf8;
+begin
+  {%H-}f.DoAppendLine(Text, @Args[0], length(Args), Separator);
+end;
+
+procedure Append(var Text: RawUtf8; const Args: array of const);
+var
+  f: TFormatUtf8;
+begin
+  {%H-}f.DoAppendLine(Text, @Args[0], length(Args), '');
+end;
+
+procedure Append(var Text: RawByteString; const Args: array of const);
+var
+  f: TFormatUtf8;
+begin
+  {%H-}f.DoAppendLine(RawUtf8(Text), @Args[0], length(Args), '');
+  if Text <> '' then
+    FakeCodePage(Text, CP_RAWBYTESTRING);
+end;
+
+procedure Append(var Text: RawUtf8; const Added: RawByteString);
+begin
+  if Added <> '' then
+    Append(Text, pointer(Added), PStrLen(PtrUInt(Added) - _STRLEN)^);
+end;
+
+procedure Append(var Text: RawUtf8; const Added1, Added2: RawByteString);
+var
+  l, a1, a2: PtrInt;
+begin
+  l := length(Text);
+  a1 := length(Added1);
+  a2 := length(Added2);
+  SetLength(Text, l + a1 + a2);
+  MoveFast(pointer(Added1)^, PByteArray(Text)[l], a1);
+  MoveFast(pointer(Added2)^, PByteArray(Text)[l + a1], a2);
+end;
+
+procedure Append(var Text: RawUtf8; Added: AnsiChar);
+begin
+  Append(Text, @Added, 1);
+end;
+
+procedure Append(var Text: RawUtf8; Added: pointer; AddedLen: PtrInt);
+var
+  t: PtrInt;
+begin
+  if (Added = nil) or (AddedLen <= 0) then
+    exit;
+  t := length(Text);
+  SetLength(Text, t + AddedLen);
+  MoveFast(pointer(Added)^, PByteArray(Text)[t], AddedLen);
+end;
+
+procedure Append(var Text: RawByteString; const Added: RawByteString);
+begin
+  if Added <> '' then
+    Append(Text, pointer(Added), PStrLen(PtrUInt(Added) - _STRLEN)^);
+end;
+
+procedure Append(var Text: RawByteString; Added: pointer; AddedLen: PtrInt);
+var
+  t: PtrInt;
+begin
+  if (Added = nil) or
+     (AddedLen <= 0) then
+    exit;
+  t := length(Text);
+  SetLength(Text, t + AddedLen);
+  MoveFast(Added^, PByteArray(Text)^[t], AddedLen);
+  if Text <> '' then
+    FakeCodePage(Text, CP_RAWBYTESTRING);
+end;
+
+procedure Prepend(var Text: RawUtf8; const Args: array of const);
+var
+  f: TFormatUtf8;
+begin
+  {%H-}f.DoPrepend(Text, @Args[0], length(Args), CP_UTF8);
+end;
+
+procedure Prepend(var Text: RawByteString; const Added: RawByteString);
+var
+  t, a: PtrInt;
+  new: PAnsiChar;
+begin
+  t := length(Text);
+  a := length(Added);
+  if a <> 0 then
+    if t = 0 then
+      Text := Added
+    else
+    begin
+      new := FastNewString(t + a, CP_RAWBYTESTRING);
+      MoveFast(PByteArray(Text)[0], new[a], t);
+      MoveFast(PByteArray(Added)[0], new[0], a);
+      FastAssignNew(Text, new);
+    end;
+end;
+
+procedure Prepend(var Text: RawByteString; Added: AnsiChar);
+var
+  t: PtrInt;
+begin
+  t := length(Text);
+  SetLength(Text, t + 1); // is likely to avoid any reallocmem
+  MoveFast(PByteArray(Text)[0], PByteArray(Text)[1], t);
+  PByteArray(Text)[0] := ord(Added);
+end;
+
+procedure Prepend(var Text: RawByteString; const Args: array of const);
+var
+  f: TFormatUtf8;
+begin
+  {%H-}f.DoPrepend(RawUtf8(Text), @Args[0], length(Args), CP_RAWBYTESTRING);
+end;
+
+function Make(const Args: array of const): RawUtf8;
+var
+  f: TFormatUtf8;
+begin
+  {%H-}f.DoAdd(@Args[0], length(Args));
+  FastSetString(result, f.L);
+  f.Write(pointer(result));
+end;
+
+procedure Make(const Args: array of const; var Result: RawUtf8);
+var
+  f: TFormatUtf8;
+begin
+  {%H-}f.DoAdd(@Args[0], length(Args));
+  FastSetString(result, f.L);
+  f.Write(pointer(result));
+end;
+
+function MakeString(const Args: array of const): string;
+var
+  f: TFormatUtf8;
+begin
+  {%H-}f.DoAdd(@Args[0], length(Args));
+  f.WriteString(result);
+end;
+
+function MakePath(const Part: array of const; EndWithDelim: boolean;
+  Delim: AnsiChar): TFileName;
+var
+  f: TFormatUtf8;
+begin
+  {%H-}f.DoDelim(@Part[0], length(Part), EndWithDelim, Delim);
+  f.WriteString(string(result));
+end;
+
+function MakeFileName(const Part: array of const; LastIsExt: boolean): TFileName;
+var
+  f: TFormatUtf8;
+  ext: RawUtf8;
+  hipart: integer;
+begin
+  hipart := High(Part);
+  if LastIsExt then
+    if (hipart > 0) and
+       VarRecToUtf8IsString(Part[hipart], ext) then
+      dec(hipart)
+    else
+      LastIsExt := false;
+  f.DoDelim(@Part[0], hipart + 1, false, PathDelim);
+  if LastIsExt and
+     (ext <> '') then
+  begin
+    if ext[1] <> '.' then
+      f.Add('.');
+    f.Add(ext);
+  end;
+  f.WriteString(string(result));
+end;
+
+function MakeCsv(const Value: array of const; EndWithComma: boolean;
+  Comma: AnsiChar): RawUtf8;
+var
+  f: TFormatUtf8;
+begin
+  f.DoDelim(@Value[0], length(Value), EndWithComma, Comma);
+  FastSetString(result, f.L);
+  f.Write(pointer(result));
+end;
+
+function StringToConsole(const S: string): RawByteString;
+begin
+  result := Utf8ToConsole(StringToUtf8(S));
+end;
+
+procedure ConsoleWrite(const Fmt: RawUtf8; const Args: array of const;
+  Color: TConsoleColor; NoLineFeed: boolean);
+var
+  tmp: RawUtf8;
+begin
+  FormatUtf8(Fmt, Args, tmp);
+  ConsoleWrite(tmp, Color, NoLineFeed);
+end;
+
+procedure ConsoleWrite(const Args: array of const;
+  Color: TConsoleColor; NoLineFeed: boolean);
+var
+  tmp: RawUtf8;
+begin
+  Append(tmp, Args);
+  ConsoleWrite(tmp, Color, NoLineFeed);
+end;
+
+procedure ConsoleShowFatalException(E: Exception; WaitForEnterKey: boolean);
+begin
+  ConsoleWrite(#13#10'Fatal exception ', ccLightRed, true);
+  ConsoleWrite('%', [E.ClassType], ccWhite, true);
+  ConsoleWrite(' raised with message ', ccLightRed);
+  ConsoleWrite('  %', [E.Message], ccLightMagenta);
+  TextColor(ccLightGray);
+  if WaitForEnterKey then
+  begin
+    ConsoleWrite(#13#10'Program will now abort');
+    {$ifndef OSPOSIX}
+    ConsoleWrite('Press [Enter] to quit');
+    ConsoleWaitForEnterKey;
+    {$endif OSPOSIX}
+  end;
+end;
+
+
+{ ************ Resource and Time Functions }
+
+procedure KB(bytes: Int64; out result: TShort16; nospace: boolean);
+type
+  TUnits = (kb, mb, gb, tb, pb, eb, b);
+const
+  TXT: array[{nospace:}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 bytes < Int64(1) shl 40 - (Int64(1) shl 40) div 10 then
+  begin
+    u := gb;
+    rem := bytes shr 20;
+    hi  := bytes shr 30;
+  end
+  else if bytes < Int64(1) shl 50 - (Int64(1) shl 50) div 10 then
+  begin
+    u := tb;
+    rem := bytes shr 30;
+    hi  := bytes shr 40;
+  end
+  else if bytes < Int64(1) shl 60 - (Int64(1) shl 60) div 10 then
+  begin
+    u := pb;
+    rem := bytes shr 40;
+    hi  := bytes shr 50;
+  end
+  else
+  begin
+    u := eb;
+    rem := bytes shr 50;
+    hi  := bytes shr 60;
+  end;
+  rem := rem and 1023;
+  if rem <> 0 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;
+
+procedure K(value: Int64; out result: TShort16);
+begin
+  KB(Value, result, {nospace=}true);
+  if result[0] <> #0 then
+    dec(result[0]); // just trim last 'B' ;)
+end;
+
+function K(value: Int64): TShort16;
+begin
+  K(Value, result);
+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
+    // ignore '-' sign
+    dec(L, 2)
+  else
+    dec(L);
+  for i := 1 to L div 3 do
+    insert(ThousandSep, result, Len - i * 3);
+end;
+
+function SecToString(S: QWord): TShort16;
+begin
+  MicroSecToString(S * 1000000, result);
+end;
+
+function MilliSecToString(MS: QWord): TShort16;
+begin
+  MicroSecToString(MS * 1000, result);
+end;
+
+function MicroSecToString(Micro: QWord): TShort16;
+begin
+  MicroSecToString(Micro, result);
+end;
+
+function MicroSecFrom(Start: QWord): TShort16;
+var
+  stop: Int64;
+begin
+  QueryPerformanceMicroSeconds(stop);
+  MicroSecToString(stop - Int64(Start), result);
+end;
+
+procedure By100ToTwoDigitString(value: cardinal; const valueunit: ShortString;
+  var result: TShort16);
+var
+  d100: TDiv100Rec;
+begin
+  if value < 100 then
+    FormatShort16('0.%%', [UInt2DigitsToShortFast(value), valueunit], result)
+  else
+  begin
+    Div100(value, d100{%H-});
+    if d100.m = 0 then
+      FormatShort16('%%', [d100.d, valueunit], result)
+    else
+      FormatShort16('%.%%', [d100.d, UInt2DigitsToShortFast(d100.m), valueunit], 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;
+
+procedure MicroSecToString(Micro: QWord; out result: TShort16);
+begin
+  if Int64(Micro) <= 0 then
+    PCardinal(@result)^ := 3 + ord('0') shl 8 + ord('u') shl 16 + ord('s') shl 24
+  else if Micro < 1000 then
+    FormatShort16('%us', [Micro], result)
+  else if Micro < 1000000 then
+    By100ToTwoDigitString(
+      {$ifdef CPU32} PCardinal(@Micro)^ {$else} Micro {$endif} div 10, 'ms', result)
+  else if Micro < 60000000 then
+    By100ToTwoDigitString(
+      {$ifdef CPU32} PCardinal(@Micro)^ {$else} Micro {$endif} div 10000, 's', result)
+  else if Micro < QWord(3600000000) then
+    _TimeToString(
+      {$ifdef CPU32} PCardinal(@Micro)^ {$else} Micro {$endif} div 1000000, 'm', result)
+  else if Micro < QWord(86400000000 * 2) then
+    _TimeToString(Micro div 60000000, 'h', result)
+  else
+    FormatShort16('%d', [Micro div QWord(86400000000)], result)
+end;
+
+procedure NanoSecToString(Nano: QWord; out result: TShort16);
+begin
+  if Int64(Nano) <= 0 then
+    PCardinal(@result)^ := 3 + ord('0') shl 8 + ord('n') shl 16 + ord('s') shl 24
+  else if Nano > 9900 then
+    MicroSecToString(Nano div 1000, result)
+  else if Nano >= 1000 then
+    By100ToTwoDigitString(
+      {$ifdef CPU32} PCardinal(@Nano)^ {$else} Nano {$endif} div 10, 'us', result)
+  else
+    By100ToTwoDigitString(
+      {$ifdef CPU32} PCardinal(@Nano)^ {$else} Nano {$endif} * 100, 'ns', result);
+end;
+
+
+{ ************ ESynException class }
+
+{ ESynException }
+
+procedure ESynException.CreateAfterSetMessageUtf8;
+begin
+  inherited Create(Utf8ToString(fMessageUtf8));
+end;
+
+constructor ESynException.CreateUtf8(const Format: RawUtf8;
+  const Args: array of const);
+begin
+  FormatUtf8(Format, Args, fMessageUtf8);
+  CreateAfterSetMessageUtf8;
+end;
+
+constructor ESynException.CreateU(const Msg: RawUtf8);
+begin
+  fMessageUtf8 := Msg;
+  CreateAfterSetMessageUtf8;
+end;
+
+constructor ESynException.CreateLastOSError(const Format: RawUtf8;
+  const Args: array of const; const Trailer: ShortString);
+var
+  error: integer;
+  fmt: RawUtf8;
+begin
+  error := GetLastError;
+  FormatUtf8('% 0x% [%] %', [Trailer, CardinalToHexShort(error),
+    StringReplaceAll(GetErrorText(error), '%', '#'), Format], fmt);
+  CreateUtf8(fmt, Args);
+end;
+
+{$ifndef NOEXCEPTIONINTERCEPT}
+
+function DefaultSynLogExceptionToStr(WR: TTextWriter;
+  const Context: TSynLogExceptionContext): boolean;
+var
+  extcode: cardinal;
+  extnames: TPUtf8CharDynArray;
+  i: PtrInt;
+begin
+  WR.AddClassName(Context.EClass);
+  if (Context.ELevel = sllException) and
+     (Context.EInstance <> nil) and
+     (Context.EClass <> EExternalException) then
+  begin
+    extcode := Context.AdditionalInfo(extnames);
+    if extcode <> 0 then
+    begin
+      WR.AddShorter(' 0x');
+      WR.AddBinToHexDisplayLower(@extcode, SizeOf(extcode));
+      for i := 0 to high(extnames) do
+      begin
+        {$ifdef OSWINDOWS}
+        WR.AddShort(' [.NET/CLR unhandled ');
+        {$else}
+        WR.AddShort(' [unhandled ');
+        {$endif OSWINDOWS}
+        WR.AddNoJsonEscape(extnames[i]);
+        WR.AddShort('Exception]');
+      end;
+    end;
+    WR.AddDirect(' ');
+    if WR.ClassType = TTextWriter then
+      {$ifdef UNICODE}
+      WR.AddOnSameLineW(pointer(Context.EInstance.Message), 0)
+      {$else}
+      WR.AddOnSameLine(pointer(Context.EInstance.Message))
+      {$endif UNICODE}
+    else
+      WR.WriteObject(Context.EInstance); // use RTTI for JSON serialization
+  end
+  else if Context.ECode <> 0 then
+  begin
+    WR.AddDirect(' ', '(');
+    WR.AddPointer(Context.ECode);
+    WR.AddDirect(')');
+  end;
+  result := false; // caller should append "at EAddr" and the stack trace
+end;
+
+function ESynException.CustomLog(WR: TTextWriter;
+  const Context: TSynLogExceptionContext): boolean;
+begin
+  if Assigned(TSynLogExceptionToStrCustom) then
+    result := TSynLogExceptionToStrCustom(WR, Context)
+  else
+    result := DefaultSynLogExceptionToStr(WR, Context);
+end;
+
+{$endif NOEXCEPTIONINTERCEPT}
+
+
+function StatusCodeToErrorMsg(Code: integer): RawUtf8;
+begin
+  FormatUtf8('HTTP Error % - %', [Code, StatusCodeToText(Code)^], result);
+end;
+
+
+{ **************** Hexadecimal Text And Binary Conversion }
+
+procedure BinToHex(Bin, Hex: PAnsiChar; BinBytes: PtrInt);
+var
+  {$ifdef CPUX86NOTPIC}
+  tab: TAnsiCharToWord absolute TwoDigitsHexW;
+  {$else}
+  tab: PAnsiCharToWord; // faster on PIC, ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  {$ifndef CPUX86NOTPIC}
+  tab := @TwoDigitsHexW;
+  {$endif CPUX86NOTPIC}
+  if BinBytes > 0 then
+    repeat
+      PWord(Hex)^ := tab[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, L * 2);
+  mormot.core.text.BinToHex(pointer(Bin), pointer(result), L);
+end;
+
+function BinToHex(Bin: PAnsiChar; BinBytes: PtrInt): RawUtf8;
+begin
+  FastSetString(result, BinBytes * 2);
+  mormot.core.text.BinToHex(Bin, pointer(result), BinBytes);
+end;
+
+function HexToBin(Hex: PAnsiChar; HexLen: PtrInt;
+  var Bin: RawByteString): boolean;
+begin
+  Bin := '';
+  if HexLen and 1 <> 0 then
+  begin
+    result := false;
+    exit; // hexadecimal should be in char pairs
+  end;
+  HexLen := HexLen shr 1;
+  pointer(Bin) := FastNewString(HexLen, CP_RAWBYTESTRING);
+  result := mormot.core.text.HexToBin(Hex, pointer(Bin), HexLen);
+  if not result then
+    Bin := '';
+end;
+
+function HexToBin(const Hex: RawUtf8): RawByteString;
+begin
+  HexToBin(pointer(Hex), length(Hex), result);
+end;
+
+function HexaToByte(P: PUtf8Char; var Dest: byte; tab: PByteArray): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+var
+  b, c: byte;
+begin
+  b := tab[Ord(P[0]) + 256]; // + 256 for shl 4
+  if b <> 255 then
+  begin
+    c := tab[Ord(P[1])];
+    if c <> 255 then
+    begin
+      inc(b, c);
+      Dest := b;
+      result := true;
+      exit;
+    end;
+  end;
+  result := false; // mark error
+end;
+
+function HumanHexToBin(const hex: RawUtf8; var Bin: RawByteString): boolean;
+var
+  len: PtrInt;
+  h, p: PAnsiChar;
+  tab: PByteArray;
+begin
+  Bin := '';
+  result := false;
+  len := length(hex);
+  if len = 0 then
+    exit;
+  p := FastNewString(len shr 1, CP_RAWBYTESTRING); // shr 1 = maximum length
+  pointer(Bin) := p;
+  h := pointer(hex);
+  tab := @ConvertHexToBin;
+  repeat
+    while h^ = ' ' do
+      inc(h);
+    if not HexaToByte(pointer(h), PByte(p)^, tab) then
+      break; // invalid 'xx' pair - may be len < 2
+    inc(p);
+    inc(h, 2);
+    dec(len, 2);
+    if len = 0 then
+    begin
+      result := true; // properly ended with 'xx' last hexa byte
+      break;
+    end;
+    while h^ = ' ' do
+      inc(h);
+    if h^ <> ':' then
+      continue;
+    dec(len);
+    if len = 0 then
+      break; // should not end with ':'
+    inc(h);
+  until false;
+  if result then
+    FakeLength(Bin, p - pointer(Bin))
+  else
+    Bin := '';
+end;
+
+function HumanHexCompare(a, b: PUtf8Char): integer;
+var
+  ca, cb: byte;
+  tab: PByteArray;
+begin
+  result := 0;
+  if a <> b then
+    if a <> nil then
+      if b <> nil then
+      begin
+        tab := @ConvertHexToBin;
+        repeat
+          while a^ = ' ' do
+            inc(a);
+          while b^ = ' ' do
+            inc(b);
+          if not HexaToByte(pointer(a), ca{%H-}, tab) or
+             not HexaToByte(pointer(b), cb{%H-}, tab) then
+          begin
+            result := ComparePointer(a, b); // consistent but not zero
+            break;
+          end;
+          result := ca - cb;
+          if result <> 0 then
+            break;
+          inc(a, 2);
+          inc(b, 2);
+          while a^ = ' ' do
+            inc(a);
+          while b^ = ' ' do
+            inc(b);
+          case a^ of
+            #0:
+              begin
+                if b^ <> #0 then
+                  dec(result);
+                break;
+              end;
+            ':':
+              inc(a);
+          end;
+          case b^ of
+            #0:
+              begin
+                inc(result); // we know a^<>#0
+                break;
+              end;
+            ':':
+              inc(b);
+          end;
+        until false;
+      end
+      else
+        inc(result)
+    else
+      dec(result);
+end;
+
+function HumanHexCompare(const a, b: RawUtf8): integer;
+begin
+  result := HumanHexCompare(pointer(a), pointer(b));
+end;
+
+function HumanHexToBin(const hex: RawUtf8): RawByteString;
+begin
+  HumanHexToBin(hex, result);
+end;
+
+function ByteToHex(P: PAnsiChar; Value: byte): PAnsiChar;
+begin
+  PWord(P)^ := TwoDigitsHexWB[Value];
+  result := P + 2;
+end;
+
+procedure BinToHexDisplay(Bin, Hex: PAnsiChar; BinBytes: PtrInt);
+var
+  {$ifdef CPUX86NOTPIC}
+  tab: TAnsiCharToWord absolute TwoDigitsHexW;
+  {$else}
+  tab: PAnsiCharToWord; // faster on PIC, ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  {$ifndef CPUX86NOTPIC}
+  tab := @TwoDigitsHexW;
+  {$endif CPUX86NOTPIC}
+  inc(Hex, BinBytes * 2);
+  if BinBytes > 0 then
+    repeat
+      dec(Hex, 2);
+      PWord(Hex)^ := tab[Bin^];
+      inc(Bin);
+      dec(BinBytes);
+    until BinBytes = 0;
+end;
+
+function BinToHexDisplay(Bin: PAnsiChar; BinBytes: PtrInt): RawUtf8;
+begin
+  FastSetString(result, BinBytes * 2);
+  BinToHexDisplay(Bin, pointer(result), BinBytes);
+end;
+
+procedure BinToHexLower(Bin, Hex: PAnsiChar; BinBytes: PtrInt);
+var
+  {$ifdef CPUX86NOTPIC}
+  tab: TAnsiCharToWord absolute TwoDigitsHexWLower;
+  {$else}
+  tab: PAnsiCharToWord; // faster on PIC, ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  {$ifndef CPUX86NOTPIC}
+  tab := @TwoDigitsHexWLower;
+  {$endif CPUX86NOTPIC}
+  if BinBytes > 0 then
+    repeat
+      PWord(Hex)^ := tab[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: PtrInt; var result: RawUtf8);
+begin
+  FastSetString(result, BinBytes * 2);
+  BinToHexLower(Bin, pointer(result), BinBytes);
+end;
+
+function BinToHexLower(Bin: PAnsiChar; BinBytes: PtrInt): RawUtf8;
+begin
+  BinToHexLower(Bin, BinBytes, result);
+end;
+
+procedure BinToHexDisplayLower(Bin, Hex: PAnsiChar; BinBytes: PtrInt);
+var
+  {$ifdef CPUX86NOTPIC}
+  tab: TAnsiCharToWord absolute TwoDigitsHexWLower;
+  {$else}
+  tab: PAnsiCharToWord; // faster on PIC, ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  if (Bin = nil) or
+     (Hex = nil) or
+     (BinBytes <= 0) then
+    exit;
+  {$ifndef CPUX86NOTPIC}
+  tab := @TwoDigitsHexWLower;
+  {$endif CPUX86NOTPIC}
+  inc(Hex, BinBytes * 2);
+  repeat
+    dec(Hex, 2);
+    PWord(Hex)^ := tab[Bin^];
+    inc(Bin);
+    dec(BinBytes);
+  until BinBytes = 0;
+end;
+
+function BinToHexDisplayLower(Bin: PAnsiChar; BinBytes: PtrInt): RawUtf8;
+begin
+  FastSetString(result, BinBytes * 2);
+  BinToHexDisplayLower(Bin, pointer(result), BinBytes);
+end;
+
+function BinToHexDisplayLowerShort(Bin: PAnsiChar; BinBytes: PtrInt): ShortString;
+begin
+  if BinBytes > 127 then
+    BinBytes := 127;
+  result[0] := AnsiChar(BinBytes * 2);
+  BinToHexDisplayLower(Bin, @result[1], BinBytes);
+end;
+
+function {%H-}BinToHexDisplayLowerShort16(Bin: Int64; BinBytes: PtrInt): TShort16;
+begin
+  if BinBytes > 8 then
+    BinBytes := 8;
+  result[0] := AnsiChar(BinBytes * 2);
+  BinToHexDisplayLower(@Bin, @result[1], BinBytes);
+end;
+
+procedure BinBitsToHexDisplayLowerShort16(Bin: Int64; BinBits: PtrInt;
+  var Result: TShort16);
+begin
+  Result[0] := AnsiChar(BitsToBytes(BinBits) * 2);
+  if Result[0] > #16 then
+    Result[0] := #16;
+  BinToHexDisplayLower(@Bin, @Result[1], ord(Result[0]) shr 1);
+end;
+
+{$ifdef UNICODE}
+function BinToHexDisplayFile(Bin: PAnsiChar; BinBytes: PtrInt): TFileName;
+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}
+function BinToHexDisplayFile(Bin: PAnsiChar; BinBytes: PtrInt): TFileName;
+begin
+  SetString(result, nil, BinBytes * 2);
+  BinToHexDisplayLower(Bin, pointer(result), BinBytes);
+end;
+{$endif UNICODE}
+
+procedure PointerToHex(aPointer: Pointer; var result: RawUtf8);
+begin
+  FastSetString(result, SizeOf(Pointer) * 2);
+  BinToHexDisplay(@aPointer, pointer(result), SizeOf(Pointer));
+end;
+
+function PointerToHex(aPointer: Pointer): RawUtf8;
+begin
+  PointerToHex(aPointer, result);
+end;
+
+function CardinalToHex(aCardinal: cardinal): RawUtf8;
+begin
+  FastSetString(result, SizeOf(aCardinal) * 2);
+  BinToHexDisplay(@aCardinal, pointer(result), SizeOf(aCardinal));
+end;
+
+function CardinalToHexLower(aCardinal: cardinal): RawUtf8;
+begin
+  FastSetString(result, SizeOf(aCardinal) * 2);
+  BinToHexDisplayLower(@aCardinal, pointer(result), SizeOf(aCardinal));
+end;
+
+function Int64ToHex(aInt64: Int64): RawUtf8;
+begin
+  FastSetString(result, SizeOf(Int64) * 2);
+  BinToHexDisplay(@aInt64, pointer(result), SizeOf(Int64));
+end;
+
+procedure Int64ToHex(aInt64: Int64; var result: RawUtf8);
+begin
+  FastSetString(result, SizeOf(Int64) * 2);
+  BinToHexDisplay(@aInt64, pointer(result), SizeOf(Int64));
+end;
+
+function PointerToHexShort(aPointer: Pointer): TShort16;
+begin
+  result[0] := AnsiChar(DisplayMinChars(@aPointer, SizeOf(aPointer)) * 2);
+  BinToHexDisplayLower(@aPointer, @result[1], ord(result[0]) shr 1);
+end;
+
+function CardinalToHexShort(aCardinal: cardinal): TShort16;
+begin
+  result[0] := AnsiChar(SizeOf(aCardinal) * 2);
+  BinToHexDisplay(@aCardinal, @result[1], SizeOf(aCardinal));
+end;
+
+function crc32cUtf8ToHex(const str: RawUtf8): RawUtf8;
+begin
+  result := CardinalToHex(crc32c(0, pointer(str), length(str)));
+end;
+
+function Int64ToHexShort(aInt64: Int64): TShort16;
+begin
+  result[0] := AnsiChar(SizeOf(aInt64) * 2);
+  BinToHexDisplay(@aInt64, @result[1], SizeOf(aInt64));
+end;
+
+function ToHexShort(P: pointer; Len: PtrInt): TShort64;
+begin
+  if Len = 0 then
+  begin
+    result[0] := AnsiChar(Len);
+    exit;
+  end;
+  if Len > 32 then
+    Len := 32;
+  Len := DisplayMinChars(P, Len);
+  result[0] := AnsiChar(Len * 2);
+  BinToHexDisplay(P, @result[1], Len);
+end;
+
+function Int64ToHexLower(aInt64: Int64): RawUtf8;
+var
+  L: PtrInt;
+begin
+  L := DisplayMinChars(@aInt64, SizeOf(Int64));
+  FastSetString(result, L * 2);
+  BinToHexDisplay(@aInt64, pointer(result), L);
+end;
+
+procedure Int64ToHexShort(aInt64: Int64; out result: TShort16);
+begin
+  result[0] := AnsiChar(SizeOf(aInt64) * 2);
+  BinToHexDisplay(@aInt64, @result[1], SizeOf(aInt64));
+end;
+
+function Int64ToHexString(aInt64: Int64): string;
+var
+  temp: TShort16;
+begin
+  Int64ToHexShort(aInt64, temp);
+  Ansi7ToString(@temp[1], ord(temp[0]), result);
+end;
+
+function HexDisplayToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: PtrInt): boolean;
+var
+  b, c: byte;
+  {$ifdef CPUX86NOTPIC}
+  tab: THexToDualByte absolute ConvertHexToBin;
+  {$else}
+  tab: PByteArray; // faster on PIC, ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  result := false; // return false if any invalid char
+  if (Hex = nil) or
+     (Bin = nil) then
+    exit;
+  {$ifndef CPUX86NOTPIC}
+  tab := @ConvertHexToBin;
+  {$endif CPUX86NOTPIC}
+  if BinBytes > 0 then
+  begin
+    inc(Bin, BinBytes - 1); // display = reverse order
+    repeat
+      b := tab[Ord(Hex[0]) + 256]; // + 256 for shl 4
+      if b = 255 then
+        exit;
+      c := tab[Ord(Hex[1])];
+      if c = 255 then
+        exit;
+      Bin^ := b or c;
+      dec(Bin);
+      inc(Hex, 2);
+      dec(BinBytes);
+    until BinBytes = 0;
+  end;
+  result := true; // correct content in Hex
+end;
+
+function HexDisplayToCardinal(Hex: PAnsiChar; out aValue: cardinal): boolean;
+begin
+  result := HexDisplayToBin(Hex, @aValue, SizeOf(aValue));
+  if not result then
+    aValue := 0;
+end;
+
+function HexDisplayToInt64(Hex: PAnsiChar; out aValue: Int64): boolean;
+begin
+  result := HexDisplayToBin(Hex, @aValue, SizeOf(aValue));
+  if not result then
+    aValue := 0;
+end;
+
+function HexDisplayToInt64(const Hex: RawByteString): Int64;
+begin
+  if not HexDisplayToBin(pointer(Hex), @result, SizeOf(result)) then
+    result := 0;
+end;
+
+function HexToBin(Hex: PAnsiChar; Bin: PByte; BinBytes: PtrInt): boolean;
+var
+  b, c: byte;
+  {$ifdef CPUX86NOTPIC}
+  tab: THexToDualByte absolute ConvertHexToBin;
+  {$else}
+  tab: PByteArray; // faster on PIC, ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  result := false; // return false if any invalid char
+  if Hex = nil then
+    exit;
+  {$ifndef CPUX86NOTPIC}
+  tab := @ConvertHexToBin;
+  {$endif CPUX86NOTPIC}
+  if BinBytes > 0 then
+    if Bin <> nil then
+      repeat
+        b := tab[Ord(Hex[0]) + 256]; // + 256 for shl 4
+        if b = 255 then
+          exit;
+        c := tab[Ord(Hex[1])];
+        if c = 255 then
+          exit;
+        inc(Hex, 2);
+        Bin^ := b or c;
+        inc(Bin);
+        dec(BinBytes);
+      until BinBytes = 0
+    else
+      repeat // Bin=nil -> validate Hex^ input
+        if (tab[Ord(Hex[0])] > 15) or
+           (tab[Ord(Hex[1])] > 15) then
+          exit;
+        inc(Hex, 2);
+        dec(BinBytes);
+      until BinBytes = 0;
+  result := true; // conversion OK
+end;
+
+procedure HexToBinFast(Hex: PAnsiChar; Bin: PByte; BinBytes: PtrInt);
+var
+  {$ifdef CPUX86NOTPIC}
+  tab: THexToDualByte absolute ConvertHexToBin;
+  {$else}
+  tab: PByteArray; // faster on PIC, ARM and x86_64
+  {$endif CPUX86NOTPIC}
+  c: byte;
+begin
+  {$ifndef CPUX86NOTPIC}
+  tab := @ConvertHexToBin;
+  {$endif CPUX86NOTPIC}
+  if BinBytes > 0 then
+    repeat
+      c := tab[ord(Hex[0]) + 256]; // + 256 for shl 4
+      c := tab[ord(Hex[1])] or c;
+      Bin^ := c;
+      inc(Hex, 2);
+      inc(Bin);
+      dec(BinBytes);
+    until BinBytes = 0;
+end;
+
+function IsHex(const Hex: RawByteString; BinBytes: PtrInt): boolean;
+begin
+  result := (length(Hex) = BinBytes * 2) and
+    mormot.core.text.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 HexToCharValid(Hex: PAnsiChar; HexToBin: PByteArray): boolean;
+begin
+  result := (HexToBin[Ord(Hex[0])] <= 15) and
+            (HexToBin[Ord(Hex[1])] <= 15);
+end;
+
+function HexToChar(Hex: PAnsiChar; Bin: PUtf8Char; HexToBin: PByteArray): boolean;
+var
+  b, c: byte;
+begin
+  if Hex <> nil then
+  begin
+    b := HexToBin[ord(Hex[0]) + 256]; // + 256 for shl 4
+    c := HexToBin[ord(Hex[1])];
+    if (b <> 255) and
+       (c <> 255) then
+    begin
+      if Bin <> nil then
+      begin
+        inc(c, b);
+        Bin^ := AnsiChar(c);
+      end;
+      result := true;
+      exit;
+    end;
+  end;
+  result := false; // return false if any invalid char
+end;
+
+function HexToWideChar(Hex: PUtf8Char): cardinal;
+var
+  B: cardinal;
+  {$ifdef CPUX86NOTPIC}
+  tab: THexToDualByte absolute ConvertHexToBin;
+  {$else}
+  tab: PByteArray; // faster on PIC, ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  {$ifndef CPUX86NOTPIC}
+  tab := @ConvertHexToBin;
+  {$endif CPUX86NOTPIC}
+  result := tab[ord(Hex[0])];
+  if result <= 15 then
+  begin
+    result := result shl 12;
+    B := tab[ord(Hex[1])];
+    if B <= 15 then
+    begin
+      B := B shl 8;
+      inc(result, B);
+      B := tab[ord(Hex[2])];
+      if B <= 15 then
+      begin
+        B := B shl 4;
+        inc(result, B);
+        B := tab[ord(Hex[3])];
+        if B <= 15 then
+        begin
+          inc(result, B);
+          exit;
+        end;
+      end;
+    end;
+  end;
+  result := 0;
+end;
+
+function OctToBin(Oct: PAnsiChar; Bin: PByte): PtrInt;
+var
+  c, v: byte;
+label
+  _nxt;
+begin
+  result := PtrInt(Bin);
+  if Oct <> nil then
+    repeat
+      c := ord(Oct^);
+      inc(Oct);
+      if c <> ord('\') then
+      begin
+        if c = 0 then
+          break;
+_nxt:   Bin^ := c;
+        inc(Bin);
+        continue;
+      end;
+      c := ord(Oct^);
+      inc(Oct);
+      if c = ord('\') then
+        goto _nxt;
+      dec(c, ord('0'));
+      if c > 3 then
+        // stop at malformated input (includes #0)
+        break;
+      c := c shl 6;
+      v := c;
+      c := ord(Oct[0]);
+      dec(c, ord('0'));
+      if c > 7 then
+        break;
+      c := c shl 3;
+      v := v or c;
+      c := ord(Oct[1]);
+      dec(c, ord('0'));
+      if c > 7 then
+        break;
+      c := c or v;
+      Bin^ := c;
+      inc(Bin);
+      inc(Oct, 2);
+    until false;
+  result := PAnsiChar(Bin) - PAnsiChar(result);
+end;
+
+function OctToBin(const Oct: RawUtf8): RawByteString;
+var
+  tmp: TSynTempBuffer;
+  L: integer;
+begin
+  tmp.Init(length(Oct));
+  try
+    L := OctToBin(pointer(Oct), tmp.buf);
+    FastSetRawByteString(result, tmp.buf, L);
+  finally
+    tmp.Done;
+  end;
+end;
+
+function GuidToText(P: PUtf8Char; guid: PByteArray): PUtf8Char;
+var
+  i: PtrInt;
+  tab: PWordArray;
+begin
+  // encode as '3F2504E0-4F89-11D3-9A0C-0305E82C3301'
+  tab := @TwoDigitsHexWB;
+  for i := 3 downto 0 do
+  begin
+    PWord(P)^ := tab[guid[i]];
+    inc(P, 2);
+  end;
+  inc(PByte(guid), 4);
+  for i := 1 to 2 do
+  begin
+    P[0] := '-';
+    PWord(P + 1)^ := tab[guid[1]];
+    PWord(P + 3)^ := tab[guid[0]];
+    inc(PByte(guid), 2);
+    inc(P, 5);
+  end;
+  P[0] := '-';
+  PWord(P + 1)^ := tab[guid[0]];
+  PWord(P + 3)^ := tab[guid[1]];
+  P[5] := '-';
+  inc(PByte(guid), 2);
+  inc(P, 6);
+  for i := 0 to 5 do
+  begin
+    PWord(P)^ := tab[guid[i]];
+    inc(P, 2);
+  end;
+  result := P;
+end;
+
+function GuidToRawUtf8(const guid: TGuid): RawUtf8;
+var
+  P: PUtf8Char;
+begin
+  FastSetString(result, 38);
+  P := pointer(result);
+  P^ := '{';
+  GuidToText(P + 1, @guid)^ := '}';
+end;
+
+function ToUtf8(const guid: TGuid): RawUtf8;
+begin
+  FastSetString(result, 36);
+  GuidToText(pointer(result), @Guid);
+end;
+
+function GuidToShort(const guid: TGuid): TGuidShortString;
+begin
+  GuidToShort(Guid, result);
+end;
+
+procedure GuidToShort(const guid: TGuid; out dest: TGuidShortString);
+begin
+  dest[0] := #38;
+  dest[1] := '{';
+  GuidToText(@dest[2], @guid)^ := '}';
+end;
+
+{$ifdef UNICODE}
+function GuidToString(const guid: TGuid): string;
+var
+  tmp: TGuidShortString;
+begin
+  GuidToShort(guid, tmp);
+  Ansi7ToString(@tmp[1], 38, result);
+end;
+{$else}
+function GuidToString(const guid: TGuid): string;
+begin
+  result := GuidToRawUtf8(guid);
+end;
+{$endif UNICODE}
+
+function TextToGuid(P: PUtf8Char; guid: PByteArray): PUtf8Char;
+var
+  i: PtrInt;
+  tab: PByteArray;
+begin
+  // decode from '3F2504E0-4F89-11D3-9A0C-0305E82C3301'
+  result := nil;
+  tab := @ConvertHexToBin;
+  for i := 3 downto 0 do
+  begin
+    if not HexaToByte(P, guid[i], tab) then
+      exit;
+    inc(P, 2);
+  end;
+  inc(PByte(guid), 4);
+  for i := 1 to 2 do
+  begin
+    if P^ = '-' then // '-' separators are optional
+      inc(P);
+    if not HexaToByte(P, guid[1], tab) or
+       not HexaToByte(P + 2, guid[0], tab) then
+      exit;
+    inc(P, 4);
+    inc(PByte(guid), 2);
+  end;
+  if P^ = '-' then
+    inc(P);
+  if not HexaToByte(P, guid[0], tab) or // in reverse order than the previous loop
+     not HexaToByte(P + 2, guid[1], tab) then
+    exit;
+  inc(P, 4);
+  inc(PByte(guid), 2);
+  if P^ = '-' then
+    inc(P);
+  for i := 0 to 5 do
+    if HexaToByte(P, guid[i], tab) then
+      inc(P, 2)
+    else
+      exit;
+  result := P;
+end;
+
+function StringToGuid(const text: string): TGuid;
+{$ifdef UNICODE}
+var
+  tmp: array[0..35] of byte;
+  i: integer;
+{$endif UNICODE}
+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 UNICODE}
+      exit; // conversion OK
+  end;
+  FillZero(PHash128(@result)^);
+end;
+
+function RawUtf8ToGuid(const text: RawByteString): TGuid;
+begin
+  if not RawUtf8ToGuid(text, result) then
+    FillZero(PHash128(@result)^);
+end;
+
+function RawUtf8ToGuid(const text: RawByteString; out guid: TGuid): boolean;
+begin
+  result := true;
+  case length(text) of
+    32, // '3F2504E04F8911D39A0C0305E82C3301' TextToGuid() order, not HexToBin()
+    36: // '3F2504E0-4F89-11D3-9A0C-0305E82C3301' JSON compatible layout
+      if TextToGuid(pointer(text), @guid) <> nil then
+        exit;
+    38: // '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}' regular layout
+      if (text[1] <> '{') or
+         (text[38] <> '}') or
+         (TextToGuid(@text[2], @guid) <> nil) then
+        exit;
+  end;
+  result := false;
+end;
+
+function TrimGuid(var text: RawUtf8): boolean;
+var
+  s, d: PUtf8Char;
+  L: PtrInt;
+  c: AnsiChar;
+begin
+  s := UniqueRawUtf8(text);
+  if s = nil then
+  begin
+    result := false;
+    exit;
+  end;
+  result := true;
+  d := s;
+  repeat
+    c := s^;
+    inc(s);
+    case c of
+      #0:
+        break;
+      #1..' ', '-', '{', '}': // trim spaces and GUID/UUID separators
+        continue;
+      'A'..'F':
+        inc(c, 32);    // convert to lower-case
+      'a'..'f', '0'..'9':
+        ;              // valid hexadecimal char
+    else
+      result := false; // not a true hexadecimal content
+    end;
+    d^ := c;
+    inc(d);
+  until false;
+  L := d - pointer(text);
+  if L = 0 then
+  begin
+    FastAssignNew(text);
+    result := false;
+  end
+  else
+  begin
+    FakeLength(text, L);
+    result := result and (L = 32);
+  end;
+end;
+
+function StreamToRawByteString(aStream: TStream; aSize: Int64;
+  aCodePage: integer): RawByteString;
+var
+  current: Int64;
+begin
+  result := '';
+  if aStream = nil then
+    exit;
+  current := aStream.Position;
+  if (current = 0) and
+     aStream.InheritsFrom(TRawByteStringStream) and
+     ((aSize < 0) or
+      (aSize = length(TRawByteStringStream(aStream).DataString))) then
+  begin
+    result := TRawByteStringStream(aStream).DataString; // fast COW
+    exit;
+  end;
+  if aSize < 0 then
+    aSize := aStream.Size - current;
+  if (aSize = 0) or
+     (aSize > maxInt) then
+    exit;
+  pointer(result) := FastNewString(aSize, aCodePage);
+  aStream.ReadBuffer(pointer(result)^, aSize);
+  aStream.Position := current;
+end;
+
+function StreamChangeToRawByteString(aStream: TStream; var aPosition: Int64): RawByteString;
+var
+  current, size: Int64;
+begin
+  result := '';
+  if aStream = nil then
+    exit;
+  size := aStream.Size - aPosition;
+  if size <= 0 then
+    exit; // nothing new
+  pointer(result) := FastNewString(size, CP_RAWBYTESTRING);
+  current := aStream.Position;
+  aStream.Position := aPosition;
+  aStream.ReadBuffer(pointer(result)^, size);
+  aStream.Position := current;
+  aPosition := current;
+end;
+
+function RawByteStringToStream(const aString: RawByteString): TStream;
+begin
+  result := TRawByteStringStream.Create(aString);
+end;
+
+function ReadStringFromStream(S: TStream; MaxAllowedSize: integer): RawUtf8;
+var
+  L: integer;
+begin
+  result := '';
+  L := 0;
+  if (S.Read(L, 4) <> 4) or
+     (L <= 0) or
+     (L > MaxAllowedSize) then
+    exit;
+  FastSetString(result, L);
+  if S.Read(pointer(result)^, L) <> L then
+    result := '';
+end;
+
+function WriteStringToStream(S: TStream; const Text: RawUtf8): boolean;
+var
+  L: integer;
+begin
+  L := length(Text);
+  if L = 0 then
+    result := S.Write(L, 4) = 4
+  else
+    {$ifdef FPC}
+    result := (S.Write(L, 4) = 4) and
+              (S.Write(pointer(Text)^, L) = L);
+    {$else}
+    result := S.Write(pointer(PtrInt(Text) - SizeOf(integer))^, L + 4) = L + 4;
+    {$endif FPC}
+end;
+
+const // should be local for better code generation
+  HexChars:      array[0..15] of AnsiChar = '0123456789ABCDEF';
+  HexCharsLower: array[0..15] of AnsiChar = '0123456789abcdef';
+
+procedure InitializeUnit;
+var
+  i: PtrInt;
+  v: byte;
+  c: AnsiChar;
+  P: PAnsiChar;
+  B: PByteArray;
+  tmp: array[0..15] of AnsiChar;
+begin
+  // initialize internal lookup tables for various text conversions
+  for i := 0 to 255 do
+  begin
+    TwoDigitsHex[i][1]      := HexChars[i shr 4];
+    TwoDigitsHex[i][2]      := HexChars[i and $f];
+    TwoDigitsHexLower[i][1] := HexCharsLower[i shr 4];
+    TwoDigitsHexLower[i][2] := HexCharsLower[i and $f];
+  end;
+  {$ifndef EXTENDEDTOSHORT_USESTR}
+  {$ifdef ISDELPHIXE}
+  SettingsUS := TFormatSettings.Create(ENGLISH_LANGID);
+  {$else}
+  GetLocaleFormatSettings(ENGLISH_LANGID, SettingsUS);
+  {$endif ISDELPHIXE}
+  SettingsUS.DecimalSeparator := '.'; // value may have been overriden :(
+  {$endif EXTENDEDTOSHORT_USESTR}
+  {$ifdef DOUBLETOSHORT_USEGRISU}
+  MoveFast(TwoDigitLookup[0], TwoDigitByteLookupW[0], SizeOf(TwoDigitLookup));
+  for i := 0 to 199 do
+    dec(PByteArray(@TwoDigitByteLookupW)[i], ord('0')); // '0'..'9' -> 0..9
+  {$endif DOUBLETOSHORT_USEGRISU}
+  FillcharFast(ConvertHexToBin[0], SizeOf(ConvertHexToBin), 255); // all to 255
+  B := @ConvertHexToBin;
+  v := 0;
+  for i := ord('0') to ord('9') do
+  begin
+    B[i] := v;
+    B[i + 256] := v shl 4;
+    inc(v);
+  end;
+  for i := ord('A') to ord('F') do
+  begin
+    B[i] := v;
+    B[i + 256] := v shl 4;
+    B[i + (ord('a') - ord('A'))] := v;
+    B[i + (ord('a') - ord('A') + 256)] := v shl 4;
+    inc(v);
+  end;
+  for i := 0 to high(SmallUInt32Utf8) do
+  begin
+    P := StrUInt32(@tmp[15], i);
+    FastSetString(SmallUInt32Utf8[i], P, @tmp[15] - P);
+  end;
+  for c := #0 to #127 do
+  begin
+    XML_ESC[c] := ord(c in [#0..#31, '<', '>', '&', '"', '''']);
+    case c of // HTML_ESCAPED: array[1..4] = '<', '>', '&', '"'
+      #0,
+      '<':
+        v := 1;
+      '>':
+        v := 2;
+      '&':
+        v := 3;
+      '"':
+        v := 4;
+    else
+      v := 0;
+    end;
+    HTML_ESC[hfAnyWhere, c] := v;
+    if c in [#0, '&', '<', '>'] then
+      HTML_ESC[hfOutsideAttributes, c] := v;
+    if c in [#0, '&', '"'] then
+      HTML_ESC[hfWithinAttributes, c] := v;
+  end;
+  _VariantToUtf8DateTimeToIso8601 := __VariantToUtf8DateTimeToIso8601;
+  _VariantSaveJson := __VariantSaveJson;
+  TextWriterSharedStream := TRawByteStringStream.Create;
+end;
+
+
+
+initialization
+  InitializeUnit;
+
+finalization
+  TextWriterSharedStream.Free;
+
+end.
+
diff --git a/lib/dmustache/mormot.core.unicode.pas b/lib/dmustache/mormot.core.unicode.pas
new file mode 100644
index 00000000..4974b213
--- /dev/null
+++ b/lib/dmustache/mormot.core.unicode.pas
@@ -0,0 +1,10431 @@
+/// Framework Core Low-Level Unicode UTF-8 UTF-16 Ansi Conversion
+// - this unit is a part of the Open Source Synopse mORMot framework 2,
+// licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+unit mormot.core.unicode;
+
+{
+  *****************************************************************************
+
+   Efficient Unicode Conversion Classes shared by all framework units
+   - UTF-8 Efficient Encoding / Decoding
+   - UTF-8 / UTF-16 / Ansi Conversion Classes
+   - Text File Loading with BOM/Unicode Support
+   - Low-Level String Conversion Functions
+   - Text Case-(in)sensitive Conversion and Comparison
+   - UTF-8 String Manipulation Functions
+   - TRawUtf8DynArray Processing Functions
+   - Operating-System Independent Unicode Process
+
+  *****************************************************************************
+}
+
+interface
+
+{$I mormot.defines.inc}
+
+uses
+  classes,
+  sysutils,
+  mormot.core.base,
+  mormot.core.os;
+
+
+{ *************** UTF-8 Efficient Encoding / Decoding }
+
+// some constants used for UTF-8 conversion, including surrogates
+type
+  // see http://floodyberry.wordpress.com/2007/04/14/utf-8-conversion-tricks
+  {$ifdef USERECORDWITHMETHODS}
+  TUtf8Table = record
+  {$else}
+  TUtf8Table = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    Lookup: array[byte] of byte;
+    Extra: array[0..6] of record
+      offset, minimum: cardinal;
+    end;
+    FirstByte: array[2..6] of byte;
+    /// retrieve a >127 UCS4 CodePoint from UTF-8
+    function GetHighUtf8Ucs4(var U: PUtf8Char): Ucs4CodePoint;
+  end;
+  PUtf8Table = ^TUtf8Table;
+
+const
+  UTF8_ASCII = 0;
+  UTF8_INVALID = 6;
+  UTF8_ZERO = 7;
+  UTF8_TABLE: TUtf8Table = (
+    Lookup: (
+      7, 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, 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,
+      6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
+      6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
+      6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
+      6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
+      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, 6, 6);
+    Extra: (
+      (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));
+    FirstByte: (
+      $c0, $e0, $f0, $f8, $fc));
+
+  UTF8_EXTRA_SURROGATE = 3;
+  UTF16_HISURROGATE_MIN = $d800;
+  UTF16_HISURROGATE_MAX = $dbff;
+  UTF16_LOSURROGATE_MIN = $dc00;
+  UTF16_LOSURROGATE_MAX = $dfff;
+  UTF16_SURROGATE_OFFSET = $d7c0;
+
+  /// replace any incoming character whose value is unrepresentable in Unicode
+  // - set e.g. by GetUtf8WideChar(), Utf8UpperReference() or
+  // RawUnicodeToUtf8() when ccfReplacementCharacterForUnmatchedSurrogate is set
+  // - encoded as $ef $bf $bd bytes in UTF-8
+  UNICODE_REPLACEMENT_CHARACTER = $fffd;
+
+
+/// internal function, used to retrieve a >127 US4 CodePoint 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): Ucs4CodePoint;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// decode UTF-16 WideChar from UTF-8 input buffer
+// - any surrogate (Ucs4>$ffff) is returned as UNICODE_REPLACEMENT_CHARACTER=$fffd
+function GetUtf8WideChar(P: PUtf8Char): cardinal;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// get the UCS4 CodePoint stored in P^ (decode UTF-8 if necessary)
+function NextUtf8Ucs4(var P: PUtf8Char): Ucs4CodePoint;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// UTF-8 encode one UTF-16 encoded UCS4 CodePoint 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 properly handle UTF-16 surrogate pairs
+function Utf16CharToUtf8(Dest: PUtf8Char; var Source: PWord): integer;
+
+/// UTF-8 encode one UCS4 CodePoint into Dest
+// - return the number of bytes written into Dest (i.e. from 1 up to 6)
+// - this method DOES properly handle UTF-16 surrogate pairs
+function Ucs4ToUtf8(ucs4: Ucs4CodePoint; Dest: PUtf8Char): PtrInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+type
+  /// option set for RawUnicodeToUtf8() conversion
+  TCharConversionFlags = set of (
+    ccfNoTrailingZero,
+    ccfReplacementCharacterForUnmatchedSurrogate);
+
+/// convert a UTF-16 PWideChar buffer into a UTF-8 string
+procedure RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer;
+  var result: RawUtf8; Flags: TCharConversionFlags = [ccfNoTrailingZero]); overload;
+
+/// convert a UTF-16 PWideChar buffer into a UTF-8 temporary buffer
+procedure RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer;
+  var result: TSynTempBuffer; Flags: TCharConversionFlags); overload;
+
+/// convert a UTF-16 PWideChar buffer into a UTF-8 string
+function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer;
+  Flags: TCharConversionFlags = [ccfNoTrailingZero]): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a UTF-16 PWideChar buffer 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 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 UTF-16 PWideChar buffer 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 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;
+
+/// direct conversion of a UTF-8 encoded buffer into a WinAnsi ShortString buffer
+// - non WinAnsi chars are replaced by '?' placeholders
+procedure Utf8ToShortString(var dest: ShortString; source: PUtf8Char);
+
+/// calculate the UTF-16 Unicode characters count, UTF-8 encoded in source^
+// - count may not match the UCS4 CodePoint, 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 also refuse #0 characters within the buffer
+// - on Haswell AVX2 Intel/AMD CPUs, will use very efficient ASM
+var
+  IsValidUtf8Buffer: function(source: PUtf8Char; sourcelen: PtrInt): boolean;
+
+/// returns TRUE if the supplied buffer has valid UTF-8 encoding
+// - will also refuse #0 characters within the buffer
+// - on Haswell AVX2 Intel/AMD CPUs, will use very efficient ASM, reaching e.g.
+// 21 GB/s parsing speed on a Core i5-13500
+function IsValidUtf8(const source: RawUtf8): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// returns TRUE if the supplied buffer has valid UTF-8 encoding
+// - will stop when the buffer contains #0
+// - just a wrapper around IsValidUtf8Buffer(source, StrLen(source)) so if you
+// know the source length, you would better call IsValidUtf8Buffer() directly
+// - on Haswell AVX2 Intel/AMD CPUs, will use very efficient ASM, reaching e.g.
+// 15 GB/s parsing speed on a Core i5-13500 - StrLen() itself runs at 37 GB/s
+function IsValidUtf8(source: PUtf8Char): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// detect UTF-8 content and mark the variable with the CP_UTF8 codepage
+// - to circumvent FPC concatenation bug with CP_UTF8 and CP_RAWBYTESTRING
+procedure DetectRawUtf8(var source: RawByteString);
+  {$ifndef HASCODEPAGE}{$ifdef HASINLINE}inline;{$endif}{$endif}
+
+/// 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 CodePoint, in case of UTF-16 surrogates
+// - returns FALSE if text was not truncated, TRUE otherwise
+function Utf8TruncateToUnicodeLength(var text: RawUtf8; maxUtf16: integer): boolean;
+
+/// will truncate the supplied UTF-8 value if its length exceeds the specified
+// bytes count
+// - this function will ensure that the returned content will contain only valid
+// UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence
+// - returns FALSE if text was not truncated, TRUE otherwise
+function Utf8TruncateToLength(var text: RawUtf8; maxBytes: PtrUInt): boolean;
+
+/// compute the truncated length of the supplied UTF-8 value if it exceeds the
+// specified bytes count
+// - this function will ensure that the returned content will contain only valid
+// UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence
+// - returns maxBytes if text was not truncated, or the number of fitting bytes
+function Utf8TruncatedLength(const text: RawUtf8; maxBytes: PtrUInt): PtrInt; overload;
+
+/// compute the truncated length of the supplied UTF-8 value if it exceeds the
+// specified bytes count
+// - this function will ensure that the returned content will contain only valid
+// UTF-8 sequence, i.e. will trim the whole trailing UTF-8 sequence
+// - returns maxBytes if text was not truncated, or the number of fitting bytes
+function Utf8TruncatedLength(text: PAnsiChar;
+  textlen, maxBytes: PtrUInt): PtrInt; overload;
+
+/// calculate the UTF-16 Unicode characters count of the UTF-8 encoded first line
+// - count may not match the UCS4 CodePoint, in case of UTF-16 surrogates
+// - end the parsing at first #13 or #10 character
+function Utf8FirstLineToUtf16Length(source: PUtf8Char): PtrInt;
+
+
+
+{ **************** UTF-8 / UTF-16 / Ansi Conversion Classes }
+
+type
+  /// Exception raised by this unit in case of fatal conversion issue
+  ESynUnicode = class(ExceptionWithProps);
+
+  /// 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;
+  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;
+    {$ifndef PUREMORMOT2}
+    /// 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;
+    {$endif PUREMORMOT2}
+    /// 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
+    // - internally 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
+    procedure AnsiBufferToRawUtf8(Source: PAnsiChar;
+      SourceChars: cardinal; out Value: RawUtf8); overload; virtual;
+    /// direct conversion of an Unicode buffer into a PAnsiChar buffer
+    // - Dest^ buffer must be reserved with at least SourceChars * 3 bytes
+    // - will detect and ignore any trailing UTF-16LE BOM marker
+    // - 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
+    // - internally calls UnicodeBufferToAnsi virtual method
+    function UnicodeStringToAnsi(const Source: SynUnicode): RawByteString;
+      {$ifdef HASINLINE}inline;{$endif}
+    {$ifndef PUREMORMOT2}
+    /// convert any Unicode-encoded String into Ansi Text
+    // - internally calls UnicodeBufferToAnsi virtual method
+    function RawUnicodeToAnsi(const Source: RawUnicode): RawByteString;
+    {$endif PUREMORMOT2}
+    /// 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
+    // - internally 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
+    // - internally calls Utf8BufferToAnsi virtual method
+    procedure Utf8BufferToAnsi(Source: PUtf8Char;
+      SourceChars: cardinal; var result: RawByteString); overload; virtual;
+    /// convert any UTF-8 encoded String into Ansi Text
+    // - internally calls Utf8BufferToAnsi virtual method
+    function Utf8ToAnsi(const u: RawUtf8): RawByteString; virtual;
+    /// direct conversion of a UTF-8 encoded string into a WinAnsi <2KB 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 Utf8ToAnsiBuffer2K(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;
+    /// corresponding length binary shift used for worst conversion case
+    property AnsiCharShift: byte
+      read fAnsiCharShift;
+  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;
+  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;
+    {$ifndef PUREMORMOT2}
+    /// 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;
+    {$endif PUREMORMOT2}
+    /// direct conversion of an Unicode buffer into a PAnsiChar buffer
+    // - Dest^ buffer must be reserved with at least SourceChars * 3 bytes
+    // - will detect and ignore any trailing UTF-16LE BOM marker
+    // - 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
+    // - non Ansi compatible characters are replaced as '?'
+    function Utf8BufferToAnsi(Dest: PAnsiChar; Source: PUtf8Char;
+      SourceChars: cardinal): PAnsiChar; override;
+    /// conversion of a wide char into the corresponding Ansi character
+    // - return -1 for an unknown WideChar in the current code page
+    function WideCharToAnsiChar(wc: cardinal): integer;
+    /// return TRUE if the supplied unicode buffer only contains characters of
+    // the corresponding Ansi code page
+    // - i.e. if the text can be displayed using this code page
+    function IsValidAnsi(WideText: PWideChar; Length: PtrInt): boolean; overload;
+    /// return TRUE if the supplied unicode buffer only contains characters of
+    // the corresponding Ansi code page
+    // - i.e. if the text can be displayed using this code page
+    function IsValidAnsi(WideText: PWideChar): boolean; overload;
+    /// return TRUE if the supplied UTF-8 buffer only contains characters of
+    // the corresponding Ansi code page
+    // - i.e. if the text can be displayed using this code page
+    function IsValidAnsiU(Utf8Text: PUtf8Char): boolean;
+    /// return TRUE if the supplied UTF-8 buffer only contains 8-bit 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)
+  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;
+    {$ifndef PUREMORMOT2}
+    /// 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;
+    {$endif PUREMORMOT2}
+    /// direct conversion of an Unicode buffer into a PAnsiChar UTF-8 buffer
+    // - will detect and ignore any trailing UTF-16LE BOM marker
+    // - 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 u: 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
+    procedure AnsiBufferToRawUtf8(Source: PAnsiChar;
+      SourceChars: cardinal; out Value: 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;
+    {$ifndef PUREMORMOT2}
+    /// 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;
+    {$endif PUREMORMOT2}
+    /// 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;
+
+
+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 type, so will be used
+  // before Delphi 2009 to speed-up RTL 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;
+
+  /// global TSynAnsiConvert instance with no encoding (RawByteString/RawBlob)
+  RawByteStringConvert: TSynAnsiFixedWidth;
+
+/// check if a code page is known to be of fixed width, i.e. not MBCS
+// - i.e. will be implemented as a TSynAnsiFixedWidth
+function IsFixedWidthCodePage(aCodePage: cardinal): boolean;
+
+/// return a code page number into human-friendly text
+function CodePageToText(aCodePage: cardinal): TShort16;
+
+
+{ *************** Text File Loading with BOM/Unicode Support }
+
+type
+  /// text file layout, as returned by BomFile() and StringFromBomFile()
+  // - bomNone means there was no BOM recognized
+  // - bomUnicode stands for UTF-16 LE encoding (as on Windows products)
+  // - bomUtf8 stands for a UTF-8 BOM (as on Windows products)
+  TBomFile = (
+    bomNone,
+    bomUnicode,
+    bomUtf8);
+
+const
+  /// UTF-16LE BOM WideChar marker, as existing e.g. in some UTF-16 Windows files
+  BOM_UTF16LE = #$FEFF;
+
+/// check the file BOM at the beginning of a file buffer
+// - BOM is common only with Microsoft products
+// - returns bomNone if no BOM was recognized
+// - returns bomUnicode or bomUtf8 if UTF-16LE or UTF-8 BOM were recognized:
+// and will adjust Buffer/BufferSize to ignore the leading 2 or 3 bytes
+function BomFile(var Buffer: pointer; var BufferSize: PtrInt): TBomFile;
+
+/// read a file into a temporary variable, check the BOM, and adjust the buffer
+function StringFromBomFile(const FileName: TFileName; out FileContent: RawByteString;
+  out Buffer: pointer; out BufferSize: PtrInt): TBomFile;
+
+/// read a File content into a RawUtf8, detecting any leading BOM
+// - will assume text file with no BOM is already UTF-8 encoded
+// - an alternative to StringFromFile() if you want to handle UTF-8 content
+// and the files are likely to be natively UTF-8 encoded, or with a BOM
+function RawUtf8FromFile(const FileName: TFileName): RawUtf8;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// read a File content into a RawUtf8, detecting any leading BOM
+// - assume file with no BOM is encoded with the current Ansi code page, not
+// UTF-8, unless AssumeUtf8IfNoBom is true and it behaves like RawUtf8FromFile()
+function AnyTextFileToRawUtf8(const FileName: TFileName;
+  AssumeUtf8IfNoBom: boolean = false): RawUtf8;
+
+/// read a File content into a RTL string, detecting any leading BOM
+// - assume file with no BOM is encoded with the current Ansi code page, not UTF-8
+// - if ForceUtf8 is true, won't detect the BOM but assume whole file is UTF-8
+function AnyTextFileToString(const FileName: TFileName;
+  ForceUtf8: boolean = false): string;
+
+/// read a File content into SynUnicode string, detecting any leading BOM
+// - assume file with no BOM is encoded with the current Ansi code page, not UTF-8
+// - if ForceUtf8 is true, won't detect the BOM but assume whole file is UTF-8
+function AnyTextFileToSynUnicode(const FileName: TFileName;
+  ForceUtf8: boolean = false): SynUnicode;
+
+
+{ *************** Low-Level String Conversion Functions }
+
+/// 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 UTF-8 buffer)
+// - could allow logging of parsed input e.g. after an exception
+procedure UniqueRawUtf8ZeroToTilde(var u: RawUtf8; MaxSize: PtrInt = maxInt);
+
+/// convert a binary buffer into a fake ASCII/UTF-8 content without any #0 input
+// - will use ~ char to escape any #0 as ~0 pair (and plain ~ as ~~ pair)
+// - output is just a bunch of non 0 bytes, so not trully valid UTF-8 content
+// - may be used as an alternative to Base64 encoding if 8-bit chars are allowed
+// - call ZeroedRawUtf8() as reverse function
+function UnZeroed(const bin: RawByteString): RawUtf8;
+
+/// convert a fake UTF-8 buffer without any #0 input back into its original binary
+// - may be used as an alternative to Base64 decoding if 8-bit chars are allowed
+// - call UnZeroedRawUtf8() as reverse function
+function Zeroed(const u: RawUtf8): RawByteString;
+
+/// 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 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}
+
+/// 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
+// - use AnsiToUtf8() if you want to specify the codepage
+function AnyAnsiToUtf8(const s: RawByteString): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert an AnsiString (of a given code page) into a UTF-8 string
+// - use AnyAnsiToUtf8() if you want to use the codepage of the input string
+// - wrapper around TSynAnsiConvert.Engine(CodePage).AnsiToUtf8()
+function AnsiToUtf8(const Ansi: RawByteString; CodePage: integer): RawUtf8;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert an AnsiChar buffer (of a given code page) into a UTF-8 string
+// - the destination code page should be supplied
+// - wrapper around TSynAnsiConvert.Engine(CodePage).AnsiBufferToRawUtf8()
+procedure AnsiCharToUtf8(P: PAnsiChar; L: integer; var result: RawUtf8;
+  CodePage: integer);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert an AnsiString (of a given code page) into a RTL string
+// - the destination code page should be supplied
+// - wrapper around TSynAnsiConvert.Engine(CodePage) and string conversion
+function AnsiToString(const Ansi: RawByteString; CodePage: integer): string;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// direct conversion of a WinAnsi (CodePage 1252) string into a UTF-8 encoded String
+// - faster than SysUtils: don't use Utf8Encode(WideString) -> no Windows.Global(),
+// and use a fixed pre-calculated array for individual chars conversion
+function WinAnsiToUtf8(const S: WinAnsiString): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// direct conversion of a WinAnsi (CodePage 1252) string into a UTF-8 encoded String
+// - faster than SysUtils: don't use Utf8Encode(WideString) -> no Windows.Global(),
+// and use a fixed pre-calculated array for individual chars conversion
+function WinAnsiToUtf8(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// direct conversion of a WinAnsi PAnsiChar buffer into a UTF-8 encoded buffer
+// - Dest^ buffer must be reserved with at least SourceChars*3
+// - call internally WinAnsiConvert fast conversion class
+function WinAnsiBufferToUtf8(Dest: PUtf8Char;
+  Source: PAnsiChar; SourceChars: cardinal): PUtf8Char;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// direct conversion of a WinAnsi ShortString into a UTF-8 text
+// - call internally WinAnsiConvert fast conversion class
+function ShortStringToUtf8(const source: ShortString): RawUtf8;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// direct conversion of a WinAnsi (CodePage 1252) string into a Unicode buffer
+// - very fast, by using a fixed pre-calculated array for individual chars conversion
+// - text will be truncated if necessary to avoid buffer overflow in Dest[]
+procedure WinAnsiToUnicodeBuffer(const S: WinAnsiString;
+  Dest: PWordArray; DestLen: PtrInt);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// direct conversion of a UTF-8 encoded string into a WinAnsi String
+function Utf8ToWinAnsi(const S: RawUtf8): WinAnsiString; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// direct conversion of a UTF-8 encoded zero terminated buffer into a WinAnsi String
+function Utf8ToWinAnsi(P: PUtf8Char): WinAnsiString; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// direct conversion of a UTF-8 encoded zero terminated buffer into a RawUtf8 String
+procedure Utf8ToRawUtf8(P: PUtf8Char; var result: RawUtf8);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// direct conversion of a UTF-8 encoded buffer into a WinAnsi PAnsiChar buffer
+function Utf8ToWinPChar(dest: PAnsiChar; source: PUtf8Char; count: integer): integer;
+  {$ifdef HASINLINE}inline;{$endif}
+
+{$ifndef PUREMORMOT2}
+/// 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;
+
+/// convert a UTF-16 string into a WinAnsi (code page 1252) string
+function RawUnicodeToWinAnsi(const Unicode: RawUnicode): WinAnsiString; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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
+// - see also Utf8DecodeToUnicode() which uses a TSynTempBuffer for storage
+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
+// - see also Utf8DecodeToUnicode() which uses a TSynTempBuffer for storage
+function Utf8DecodeToRawUnicodeUI(const S: RawUtf8;
+  var Dest: RawUnicode): integer; overload;
+
+/// convert a RawUnicode string into a UTF-8 string
+function RawUnicodeToUtf8(const Unicode: RawUnicode): RawUtf8; overload;
+
+/// convert any RawUnicode String into a generic SynUnicode Text
+function RawUnicodeToSynUnicode(const Unicode: RawUnicode): SynUnicode; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any RTL string into a RawUnicode 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 RTL string into a RawUnicode 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 RawUnicode encoded string into a RTL string
+// - uses StrLenW() and not length(U) to handle case when was used as buffer
+function RawUnicodeToString(const U: RawUnicode): string; overload;
+{$endif PUREMORMOT2}
+
+/// 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 UTF-16 encoded buffer into a WinAnsi PAnsiChar buffer
+procedure RawUnicodeToWinPChar(dest: PAnsiChar;
+  source: PWideChar; WideCharCount: integer);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a UTF-16 PWideChar buffer into a WinAnsi (code page 1252) string
+function RawUnicodeToWinAnsi(
+  WideChar: PWideChar; WideCharCount: integer): 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 any UTF-16 buffer 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 RTL string
+function UnicodeBufferToString(source: PWideChar): string;
+
+/// convert an Unicode buffer into a UTF-8 string
+function UnicodeBufferToUtf8(source: PWideChar): RawUtf8;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// convert an Unicode buffer into a variant storing a UTF-8 string
+// - could be used e.g. as TDocVariantData.AddValue() parameter
+function UnicodeBufferToVariant(source: PWideChar): variant;
+
+/// convert any RTL string into a variant storing a UTF-8 string
+// - could be used e.g. as TDocVariantData.AddValue() parameter
+function StringToVariant(const Txt: string): variant; overload;
+
+/// convert any RTL string into a variant storing a UTF-8 string
+// - could be used e.g. as TDocVariantData.AddValue() parameter
+procedure StringToVariant(const Txt: string; var result: variant); overload;
+
+{$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 an UTF-8 encoded buffer into a Delphi 2009+ or FPC 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+ or FPC Unicode string into a WinAnsi (code page 1252) string
+function UnicodeStringToWinAnsi(const S: UnicodeString): WinAnsiString; inline;
+
+/// convert our UTF-8 encoded buffer into a Delphi 2009+ or FPC 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+ or FPC Unicode string
+// - this function is faster than default RTL, since use no Win32 API call
+function WinAnsiToUnicodeString(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): UnicodeString; overload;
+
+/// convert a Win-Ansi string into a Delphi 2009+ or FPC 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 an UTF-8 encoded buffer into a UTF-16 encoded RawByteString buffer
+// - could be used instead of deprecated RawUnicode when a temp UTF-16 buffer is needed
+function Utf8DecodeToUnicodeRawByteString(P: PUtf8Char; L: integer): RawByteString; overload;
+
+/// convert an UTF-8 encoded buffer into a UTF-16 encoded RawByteString buffer
+// - could be used instead of deprecated RawUnicode when a temp UTF-16 buffer is needed
+function Utf8DecodeToUnicodeRawByteString(const U: RawUtf8): RawByteString; overload;
+
+/// convert an UTF-8 encoded buffer into a UTF-16 encoded stream of bytes
+function Utf8DecodeToUnicodeStream(P: PUtf8Char; L: integer): TStream;
+
+/// convert a Win-Ansi encoded buffer into a Delphi 2009+ or FPC Unicode string
+// - this function is faster than default RTL, since use no Win32 API call
+function WinAnsiToSynUnicode(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): SynUnicode; overload;
+
+/// convert a Win-Ansi string into a Delphi 2009+ or FPC Unicode string
+// - this function is faster than default RTL, since use no Win32 API call
+function WinAnsiToSynUnicode(const WinAnsi: WinAnsiString): SynUnicode;
+  {$ifdef HASINLINE}inline;{$endif} overload;
+
+/// convert any RTL string 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 RTL string buffer into an UTF-8 encoded String
+// - it will work as is with Delphi 2009+ (direct unicode conversion)
+// - under older version of Delphi (no unicode), it will use the
+// current RTL codepage, as with WideString conversion (but without slow
+// WideString usage)
+procedure StringToUtf8(Text: PChar; TextLen: PtrInt; var result: RawUtf8); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any RTL string 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 RTL string into an UTF-8 encoded String
+function ToUtf8(const Text: string): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any RTL string into an UTF-8 encoded TSynTempBuffer
+// - returns the number of UTF-8 bytes available in Temp.buf
+// - this overloaded function use a TSynTempBuffer for the result to avoid any
+// memory allocation for the shorter content
+// - caller should call Temp.Done to release any heap-allocated memory
+function StringToUtf8(const Text: string; var Temp: TSynTempBuffer): integer; overload;
+
+/// convert any Ansi memory buffer into UTF-8, using a TSynTempBuffer if needed
+// - caller should release any memory by calling Temp.Done
+// - returns a pointer to the UTF-8 converted buffer - which may be buf
+function AnsiBufferToTempUtf8(var Temp: TSynTempBuffer;
+  Buf: PAnsiChar; BufLen, CodePage: cardinal): PUtf8Char;
+
+/// 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 any RTL string 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 RTL string 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 RTL string into a SynUnicode encoded String
+// - it's prefered to use TLanguageFile.StringToUtf8() method in mORMoti18n,
+// which will handle full i18n of your application
+// - it will work as is with Delphi 2009+ (direct unicode conversion)
+// - under older version of Delphi (no unicode), it will use the
+// current RTL codepage, as with WideString conversion (but without slow
+// WideString usage)
+function StringToSynUnicode(const S: string): SynUnicode; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any RTL string into a SynUnicode encoded String
+// - overloaded to avoid a copy to a temporary result string of a function
+procedure StringToSynUnicode(const S: string; var result: SynUnicode); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any UTF-16 encoded buffer into a RTL string
+function RawUnicodeToString(P: PWideChar; L: integer): string; overload;
+
+/// convert any UTF-16 encoded buffer into a RTL string
+procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string); overload;
+
+/// convert any SynUnicode encoded string into a RTL string
+function SynUnicodeToString(const U: SynUnicode): string;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any UTF-8 encoded String into a RTL string
+// - 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 String into a RTL string
+procedure Utf8ToStringVar(const Text: RawUtf8; var result: string);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any UTF-8 encoded String into a generic RTL file name string
+procedure Utf8ToFileName(const Text: RawUtf8; var result: TFileName);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any UTF-8 encoded buffer into a RTL string
+// - 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 RTL string
+procedure Utf8DecodeToString(P: PUtf8Char; L: integer; var result: string); overload;
+
+/// convert any UTF-8 encoded String into a generic WideString Text
+function Utf8ToWideString(const Text: RawUtf8): WideString; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any UTF-8 encoded String into a generic WideString Text
+procedure Utf8ToWideString(const Text: RawUtf8; var result: WideString); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any UTF-8 encoded String into a generic WideString Text
+procedure Utf8ToWideString(Text: PUtf8Char; Len: PtrInt; var result: WideString); overload;
+
+/// convert any UTF-8 encoded String into a generic SynUnicode Text
+function Utf8ToSynUnicode(const Text: RawUtf8): SynUnicode; overload;
+
+/// convert any UTF-8 encoded String into a generic SynUnicode Text
+procedure Utf8ToSynUnicode(const Text: RawUtf8; var result: SynUnicode); overload;
+
+/// convert any UTF-8 encoded buffer into a generic SynUnicode Text
+procedure Utf8ToSynUnicode(Text: PUtf8Char; Len: PtrInt; var result: SynUnicode); overload;
+
+/// convert any UTF-8 encoded string into an UTF-16 temporary buffer
+// - returns the number of WideChar stored in temp (not bytes)
+// - caller should make temp.Done after temp.buf has been used
+function Utf8DecodeToUnicode(const Text: RawUtf8; var temp: TSynTempBuffer): PtrInt; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any UTF-8 encoded buffer into an UTF-16 temporary buffer
+function Utf8DecodeToUnicode(Text: PUtf8Char; Len: PtrInt; var temp: TSynTempBuffer): PtrInt; overload;
+
+/// convert any Ansi 7-bit encoded String into a RTL string
+// - 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 RTL string
+// - the Text content must contain only 7-bit pure ASCII characters
+function Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt): string; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any Ansi 7-bit encoded String into a RTL string
+// - the Text content must contain only 7-bit pure ASCII characters
+procedure Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt; var result: string); overload;
+
+/// convert any RTL string into Ansi 7-bit encoded String
+// - the Text content must contain only 7-bit pure ASCII characters
+function StringToAnsi7(const Text: string): RawByteString;
+  {$ifndef UNICODE}{$ifdef HASINLINE}inline;{$endif}{$endif}
+
+/// convert any RTL string into WinAnsi (Win-1252) 8-bit encoded String
+function StringToWinAnsi(const Text: string): WinAnsiString;
+  {$ifdef UNICODE}inline;{$endif}
+
+
+
+{ **************** Text Case-(in)sensitive Conversion and Comparison }
+
+type
+  /// lookup table used for fast case conversion
+  TNormTable = packed array[AnsiChar] of AnsiChar;
+  /// pointer to a lookup table used for fast case conversion
+  PNormTable = ^TNormTable;
+
+  /// lookup table used for fast case conversion
+  TNormTableByte = packed array[byte] of byte;
+  /// pointer to a lookup table used for fast case conversion
+  PNormTableByte = ^TNormTableByte;
+
+var
+  /// lookup table used for fast case conversion to uppercase
+  // - handle 8-bit upper chars as in WinAnsi / code page 1252 (e.g. accents)
+  // - is defined globally, since may be used from an inlined function
+  NormToUpper: TNormTable;
+  NormToUpperByte: TNormTableByte absolute NormToUpper;
+
+  /// lookup table used for fast case conversion to lowercase
+  // - handle 8-bit upper chars as in WinAnsi / code page 1252 (e.g. accents)
+  // - is defined globally, since may be used from an inlined function
+  NormToLower: TNormTable;
+  NormToLowerByte: TNormTableByte absolute NormToLower;
+
+  /// 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;
+
+  /// this table will convert 'A'..'Z' into 'a'..'z'
+  // - so it will work with UTF-8 without decoding, whereas NormToUpper[] expects
+  // WinAnsi encoding
+  NormToLowerAnsi7: TNormTable;
+  NormToLowerAnsi7Byte: TNormTableByte absolute NormToLowerAnsi7;
+
+  /// case sensitive NormToUpper[]/NormToLower[]-like table
+  // - i.e. NormToNorm[c] = c
+  NormToNorm: TNormTable;
+  NormToNormByte: TNormTableByte absolute NormToNorm;
+
+const
+  NORM2CASE: array[boolean] of PNormTable = (nil, @NormToUpperAnsi7);
+
+type
+  /// character categories for text linefeed/word/identifier/uri parsing
+  // - using such a set compiles into TEST [MEM], IMM so is more efficient
+  // than a regular set of AnsiChar which generates much slower BT [MEM], IMM
+  // - the same 256-byte memory will also be reused from L1 CPU cache
+  // during the parsing of complex input
+  TTextChar = set of (
+    tcNot01013,
+    tc1013,
+    tcCtrlNotLF,
+    tcCtrlNot0Comma,
+    tcWord,
+    tcIdentifierFirstChar,
+    tcIdentifier,
+    tcUriUnreserved);
+
+  /// defines an AnsiChar lookup table used for branch-less text parsing
+  TTextCharSet = array[AnsiChar] of TTextChar;
+  /// points to an AnsiChar lookup table used for branch-less text parsing
+  PTextCharSet = ^TTextCharSet;
+
+  /// defines an Ordinal lookup table used for branch-less text parsing
+  TTextByteSet = array[byte] of TTextChar;
+  /// points to an Ordinal lookup table used for branch-less text parsing
+  PTextByteSet = ^TTextByteSet;
+
+var
+  /// lookup table for text linefeed/word/identifier/uri branch-less parsing
+  TEXT_CHARS: TTextCharSet;
+  TEXT_BYTES: TTextByteSet absolute TEXT_CHARS;
+
+/// 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
+// - following classic pascal naming convention, first char must be alphabetical
+// or '_' (i.e. not a digit), following chars can be alphanumerical or '_'
+function PropNameValid(P: PUtf8Char): boolean;
+
+/// 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 allows numbers as first char, so won't check the first char
+// the same way than PropNameValid() which refuses digits as pascal convention
+function PropNamesValid(const Values: array of RawUtf8): boolean;
+
+/// try to generate a PropNameValid() output from an incoming text
+// - will trim all spaces, and replace most special chars by '_'
+// - if it is not PropNameValid() after those replacements, will return fallback
+function PropNameSanitize(const text, fallback: RawUtf8): RawUtf8;
+
+/// case insensitive comparison of ASCII 7-bit identifiers
+// - use it with property names values (i.e. only including A..Z,0..9,_ chars)
+// - behavior is undefined with UTF-8 encoding (some false positive may occur)
+function IdemPropName(const P1, P2: ShortString): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+  /// case insensitive comparison of ASCII 7-bit identifiers
+  // - use it with property names values (i.e. only including A..Z,0..9,_ chars)
+  // - behavior is undefined with UTF-8 encoding (some false positive may occur)
+function IdemPropName(const P1: ShortString; P2: PUtf8Char; P2Len: PtrInt): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// case insensitive comparison of ASCII 7-bit identifiers
+// - use it with property names values (i.e. only including A..Z,0..9,_ chars)
+// - behavior is undefined with UTF-8 encoding (some false positive may occur)
+// - 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 7-bit identifiers
+// - use it with property names values (i.e. only including A..Z,0..9,_ chars)
+// - behavior is undefined with UTF-8 encoding (some false positive may occur)
+// - 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 7-bit identifiers of same length
+// - use it with property names values (i.e. only including A..Z,0..9,_ chars)
+// - behavior is undefined with UTF-8 encoding (some false positive may occur)
+// - 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 IdemPropNameUSameLenNotNull(P1, P2: PUtf8Char; P1P2Len: PtrInt): boolean;
+  {$ifdef FPC}inline;{$endif} // Delphi does not like to inline goto
+
+type
+  TIdemPropNameUSameLen = function(P1, P2: pointer; P1P2Len: PtrInt): boolean;
+
+var
+  /// case (in)sensitive comparison of ASCII 7-bit identifiers of same length
+  IdemPropNameUSameLen: array[{casesensitive=}boolean] of TIdemPropNameUSameLen;
+
+/// case insensitive comparison of ASCII 7-bit identifiers
+// - use it with property names values (i.e. only including A..Z,0..9,_ chars)
+// - behavior is undefined with UTF-8 encoding (some false positive may occur)
+// - is an alternative with PropNameEquals() to be used inlined e.g. in a loop
+function IdemPropNameU(const P1, P2: RawUtf8): boolean; overload;
+  {$ifdef HASINLINE}inline;{$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; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// returns true if the beginning of p^ is the same as up^
+// - this overloaded function accept the uppercase lookup buffer as parameter
+function IdemPChar(p: PUtf8Char; up: PAnsiChar; table: PNormTable): boolean; overload;
+  {$ifdef HASINLINE}inline;{$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 chars, nor UTF-8)
+// - warning: this function expects upArray[] items to have AT LEAST TWO
+// CHARS (it will use a fast 16-bit comparison of initial 2 bytes)
+// - consider IdemPPChar() which is faster but a bit more verbose
+function IdemPCharArray(p: PUtf8Char; const upArray: array of PAnsiChar): integer;
+
+/// returns the index of a matching beginning of p^ in nil-terminated up^ array
+// - returns -1 if no item matched
+// - ignore case - each up^ must be already Upper
+// - chars are compared as 7-bit Ansi only (no accentuated chars, nor UTF-8)
+// - warning: this function expects up^ items to have AT LEAST TWO CHARS
+// (it will use a fast 16-bit comparison of initial 2 bytes)
+function IdemPPChar(p: PUtf8Char; up: PPAnsiChar): PtrInt;
+
+/// 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 chars, nor UTF-8)
+function IdemPCharArrayBy2(p: PUtf8Char; const upArrayBy2Chars: RawUtf8): PtrInt;
+  {$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 case-insensitive matching starting of text in upTextStart
+// - returns true if the item matched
+// - ignore case - upTextStart must be already in upper case
+// - chars are compared as 7-bit Ansi only (no accentuated chars, nor UTF-8)
+// - see StartWithExact() from mormot.core.text for a case-sensitive version
+function StartWith(const text, upTextStart: RawUtf8): boolean;
+
+/// check case-insensitive matching ending of text in upTextEnd
+// - returns true if the item matched
+// - ignore case - upTextEnd must be already in upper case
+// - chars are compared as 7-bit Ansi only (no accentuated chars, nor UTF-8)
+// - see EndWithExact() from mormot.core.text for a case-sensitive version
+function EndWith(const text, upTextEnd: RawUtf8): boolean;
+
+/// returns the index of a case-insensitive matching ending of p^ in upArray[]
+// - returns -1 if no item matched
+// - ignore case - upArray[] items must be already in upper case
+// - chars are compared as 7-bit Ansi only (no accentuated chars, nor UTF-8)
+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 7-bit Ansi only (no accentuated chars, nor UTF-8)
+// - could be used e.g. like IdemFileExt(aFileName,'.JP');
+function IdemFileExt(p: PUtf8Char; extup: PAnsiChar; sepChar: AnsiChar = '.'): boolean;
+
+/// returns matching file name extension index as extup^
+// - ignore case - extup[] must be already Upper
+// - chars are compared as 7-bit Ansi only (no accentuated chars, nor UTF-8)
+// - could be used e.g. like IdemFileExts(aFileName,['.PAS','.INC']);
+function IdemFileExts(p: PUtf8Char; const extup: array of PAnsiChar;
+  sepChar: AnsiChar = '.'): integer;
+
+/// fast retrieve the position of any value of a given set of characters
+// - see also strspn() function which is likely to be faster
+function PosCharAny(Str: PUtf8Char; Characters: PAnsiChar): PUtf8Char;
+
+/// a non case-sensitive RawUtf8 version of Pos()
+// - uppersubstr is expected to be already in upper case
+// - this version handle only 7-bit ASCII (no accentuated characters)
+// - see PosIU() if you want an UTF-8 version with accentuated chars support
+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[]
+// - see PosI() for a non-accentuated, but faster version
+function PosIU(substr: PUtf8Char; const str: RawUtf8): integer;
+
+/// pure pascal 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
+// - 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 strspn(s, accept: pointer): integer;
+
+/// pure pascal 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
+// - 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 strcspn(s, reject: pointer): integer;
+
+/// our fast version of StrCompL(), to be used with PUtf8Char
+// - i.e. make a binary comparison of two memory buffers, using supplied length
+// - Default value is returned if both P1 and P2 buffers are equal
+function StrCompL(P1, P2: pointer; L: PtrInt; Default: PtrInt = 0): PtrInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// our fast version of StrCompIL(), to be used with PUtf8Char
+// - i.e. make a case-insensitive comparison of two memory buffers, using
+// supplied length
+// - Default value is returned if both P1 and P2 buffers are equal
+function StrCompIL(P1, P2: pointer; L: PtrInt; Default: PtrInt = 0): PtrInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// our fast version of StrIComp(), to be used with PUtf8Char/PAnsiChar
+function StrIComp(Str1, Str2: pointer): PtrInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// StrIComp-like function with a lookup table and Str1/Str2 expected not nil
+function StrICompNotNil(Str1, Str2: pointer; Up: PNormTableByte): PtrInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// StrIComp-like function with a length, lookup table and Str1/Str2 expected not nil
+function StrICompLNotNil(Str1, Str2: pointer; Up: PNormTableByte; L: PtrInt): PtrInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// StrIComp function with a length, lookup table and Str1/Str2 expected not nil
+// - returns L for whole match, or < L for a partial match
+function StrILNotNil(Str1, Str2: pointer; Up: PNormTableByte; L: PtrInt): PtrInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+type
+  /// function prototype used internally for UTF-8 buffer comparison
+  // - also used e.g. in mormot.core.variants unit
+  TUtf8Compare = function(P1, P2: PUtf8Char): PtrInt;
+
+var
+  /// a quick wrapper to StrComp or StrIComp comparison functions
+  StrCompByCase: array[{CaseInsensitive=}boolean] of TUtf8Compare;
+
+/// retrieve the next UCS4 CodePoint stored in U, then update the U pointer
+// - this function will decode the UTF-8 content before using NormToUpper[]
+// - will return '?' if the UCS4 CodePoint 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): Ucs4CodePoint;
+  {$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 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 (Win32 or ICU)
+// to perform the comparison at Unicode-level
+// - consider using StrPosIReference() for our faster Unicode 10.0 version
+function FindUnicode(PW: PWideChar; Upper: PWideChar; UpperLen: PtrInt): boolean;
+
+/// 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 FPC}inline;{$endif} // Delphi does not like inlining goto+label
+
+/// copy source into a 256 chars dest^ buffer with 7-bit 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-bit 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 UpperCopy255Buf(dest: PAnsiChar; source: PUtf8Char; sourceLen: PtrInt): PAnsiChar;
+
+/// copy source into dest^ with WinAnsi 8-bit 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 UTF-16 source into dest^ with ASCII 7-bit 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), replacing any non WinAnsi character by '?'
+function UpperCopy255W(dest: PAnsiChar; const source: SynUnicode): PAnsiChar; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// 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), replacing any non WinAnsi character by '?'
+function UpperCopy255W(dest: PAnsiChar; source: PWideChar; L: PtrInt): PAnsiChar; overload;
+
+/// copy source into dest^ with ASCII 7-bit 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 ASCII 7-bit upper case conversion
+// - returns final dest pointer
+// - this special version expect source to be a ShortString
+function UpperCopyShort(dest: PAnsiChar; const source: ShortString): PAnsiChar;
+
+/// fast UTF-8 comparison handling WinAnsi CP-1252 case folding
+// - this version expects u1 and u2 to be zero-terminated
+// - decode the UTF-8 content before using NormToUpper[] lookup table
+// - match the our SYSTEMNOCASE custom (and default) SQLite 3 collation
+// - consider Utf8ICompReference() for Unicode 10.0 support
+function Utf8IComp(u1, u2: PUtf8Char): PtrInt;
+
+/// fast UTF-8 comparison handling WinAnsi CP-1252 case folding
+// - this version expects u1 and u2 not to be necessary zero-terminated, but
+// uses L1 and L2 as length for u1 and u2 respectively
+// - decode the UTF-8 content before using NormToUpper[] lookup table
+// - consider Utf8ILCompReference() for Unicode 10.0 support
+function Utf8ILComp(u1, u2: PUtf8Char; L1, L2: cardinal): PtrInt;
+
+/// copy UTF-8 buffer into dest^ handling WinAnsi CP-1252 NormToUpper[] folding
+// - returns the final dest pointer
+// - current implementation handles UTF-16 surrogates
+function Utf8UpperCopy(Dest, Source: PUtf8Char; SourceChars: cardinal): PUtf8Char;
+
+/// copy UTF-8 buffer into dest^ handling WinAnsi CP-1252 NormToUpper[] folding
+// - returns the 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 case-insensitive Unicode comparison handling ASCII 7-bit chars
+// - 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;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// compare two "array of AnsiString" elements, with no case sensitivity
+// - just a wrapper around inlined StrIComp()
+function SortDynArrayAnsiStringI(const A, B): integer;
+
+/// compare two "array of PUtf8Char/PAnsiChar" elements, with no case sensitivity
+// - just a wrapper around inlined StrIComp()
+function SortDynArrayPUtf8CharI(const A, B): integer;
+
+/// compare two "array of RTL string" elements, with no case sensitivity
+// - the expected string type is the RTL string
+// - just a wrapper around StrIComp() for AnsiString or AnsiICompW() for UNICODE
+function SortDynArrayStringI(const A, B): integer;
+
+/// compare two "array of WideString/UnicodeString" elements, with no case sensitivity
+// - implemented here since would call AnsiICompW()
+function SortDynArrayUnicodeStringI(const A, B): integer;
+
+var
+  /// a quick wrapper to SortDynArrayAnsiString or SortDynArrayAnsiStringI
+  // comparison functions
+  SortDynArrayAnsiStringByCase: array[{CaseInsensitive=}boolean] of TDynArraySortCompare;
+
+/// SameText() overloaded function with proper UTF-8 decoding
+// - fast version using NormToUpper[] array for all WinAnsi 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;
+
+/// check if the supplied text has some case-insentitive 'a'..'z','A'..'Z' chars
+// - will therefore be correct with true UTF-8 content, but only for 7-bit
+function IsCaseSensitive(const S: RawUtf8): boolean; overload;
+
+/// check if the supplied text has some case-insentitive 'a'..'z','A'..'Z' chars
+// - will therefore be correct with true UTF-8 content, but only for 7-bit
+function IsCaseSensitive(P: PUtf8Char; PLen: PtrInt): boolean; overload;
+
+/// low-level function called when inlining UpperCase(Copy) and LowerCase(Copy)
+procedure CaseCopy(Text: PUtf8Char; Len: PtrInt; Table: PNormTable;
+  var Dest: RawUtf8);
+
+/// low-level function called when inlining UpperCaseSelf and LowerCaseSelf
+procedure CaseSelf(var S: RawUtf8; Table: PNormTable);
+
+/// 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;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// fast conversion of the supplied text into uppercase
+// - this will only convert 'a'..'z' into 'A'..'Z' (no NormToUpper use), and
+// will therefore be correct with true UTF-8 content, but only for 7-bit
+procedure UpperCaseCopy(Text: PUtf8Char; Len: PtrInt; var Dest: RawUtf8); overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// 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;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// 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);
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// 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;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// fast conversion of the supplied text into lowercase
+// - this will only convert 'A'..'Z' into 'a'..'z' (no NormToLower use), and
+// will therefore be correct with true UTF-8 content
+procedure LowerCaseCopy(Text: PUtf8Char; Len: PtrInt; var Dest: RawUtf8);
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// 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);
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// accurate conversion of the supplied UTF-8 content into the corresponding
+// upper-case Unicode characters
+// - will use the available API (e.g. Win32 or ICU), so may not be consistent on
+// all systems - consider UpperCaseReference() to use our Unicode 10.0 tables
+// - will temporary decode S into and from UTF-16 so is likely to be slower
+function UpperCaseUnicode(const S: RawUtf8): RawUtf8;
+
+/// accurate conversion of the supplied UTF-8 content into the corresponding
+// lower-case Unicode characters
+// - will use the available API (e.g. Win32 or ICU), so may not be consistent on
+// all systems - and also slower than LowerCase/LowerCaseU versions
+function LowerCaseUnicode(const S: RawUtf8): RawUtf8;
+
+/// use the RTL to convert the SynUnicode text to UpperCase
+function UpperCaseSynUnicode(const S: SynUnicode): SynUnicode;
+
+/// use the RTL to convert the SynUnicode text to LowerCase
+function LowerCaseSynUnicode(const S: SynUnicode): SynUnicode;
+
+/// fast WinAnsi comparison using the NormToUpper[] array for all 8-bit values
+function AnsiIComp(Str1, Str2: pointer): PtrInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// internal function used when inlining PosExI()
+function PosExIPas(pSub, p: PUtf8Char; Offset: PtrUInt;
+  Lookup: PNormTable): PtrInt;
+
+/// a ASCII-7 case-insensitive version of PosEx()
+// - will use the NormToUpperAnsi7 lookup table for character conversion
+function PosExI(const SubStr, S: RawUtf8; Offset: PtrUInt): PtrInt; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// a case-insensitive version of PosEx() with a specified lookup table
+// - redirect to mormot.core.base PosEx() if Lookup = nil
+function PosExI(const SubStr, S: RawUtf8; Offset: PtrUInt;
+  Lookup: PNormTable): PtrInt; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+
+{ ************ UTF-8 String Manipulation Functions }
+
+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;
+
+  /// 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;
+
+
+/// check case-sensitive matching starting of text in start
+// - returns true if the item matched
+// - see StartWith() from mormot.core.unicode for a case-insensitive version
+function StartWithExact(const text, textStart: RawUtf8): boolean;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// check case-sensitive matching ending of text in ending
+// - returns true if the item matched
+// - see EndWith() from mormot.core.unicode for a case-insensitive version
+function EndWithExact(const text, textEnd: RawUtf8): boolean;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// extract a line from source array of chars
+// - next will contain the beginning of next line, or nil if source has ended
+function GetNextLine(source: PUtf8Char; out next: PUtf8Char;
+  andtrim: boolean = false): RawUtf8;
+
+/// returns n leading characters
+function LeftU(const S: RawUtf8; n: PtrInt): RawUtf8;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// returns n trailing characters
+function RightU(const S: RawUtf8; n: PtrInt): 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;
+
+/// trims leading whitespaces of every lines of the UTF-8 text
+// - also delete void lines
+// - could be used e.g. before FindNameValue() call
+// - modification is made in-place so S will be modified
+procedure TrimLeftLines(var S: RawUtf8);
+
+/// trim some trailing and ending chars
+// - if S is unique (RefCnt=1), will modify the RawUtf8 in place
+// - faster alternative to S := copy(S, Left + 1, length(S) - Left - Right)
+procedure TrimChars(var S: RawUtf8; Left, Right: PtrInt);
+
+/// returns the supplied text content, without any specified char
+// - specify a custom char set to be excluded, e.g. as [#0 .. ' ']
+function TrimChar(const text: RawUtf8; const exclude: TSynAnsicharSet): RawUtf8;
+
+/// returns the supplied text content, without one specified char
+function TrimOneChar(const text: RawUtf8; exclude: AnsiChar): RawUtf8;
+
+/// returns the supplied text content, without any other char than specified
+// - specify a custom char set to be included, e.g. as ['A'..'Z']
+function OnlyChar(const text: RawUtf8; const only: TSynAnsicharSet): RawUtf8;
+
+/// returns the supplied text content, without any control char
+// - here control chars have an ASCII code in [#0 .. ' '], i.e. text[] <= ' '
+function TrimControlChars(const text: RawUtf8): RawUtf8;
+
+/// split a RawUtf8 string into two strings, according to SepStr separator
+// - returns true and LeftStr/RightStr if they were separated by SepStr
+// - if SepStr is not found, LeftStr=Str and RightStr='' and returns false
+// - if ToUpperCase is TRUE, then LeftStr and RightStr will be made uppercase
+function Split(const Str, SepStr: RawUtf8; var LeftStr, RightStr: RawUtf8;
+  ToUpperCase: boolean = false): boolean; 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;
+
+/// split a RawUtf8 string into several strings, according to SepStr separator
+// - this overloaded function will fill a DestPtr[] array of PRawUtf8
+// - if any DestPtr[]=nil, the item will be skipped
+// - if input Str end before al SepStr[] are found, DestPtr[] is set to ''
+// - returns the number of values extracted into DestPtr[]
+function Split(const Str: RawUtf8; const SepStr: array of RawUtf8;
+  const DestPtr: array of PRawUtf8): PtrInt; overload;
+
+/// returns the last occurrence 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 occurrence 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;
+
+/// check all character within text are spaces or control chars
+// - i.e. a faster alternative to  if TrimU(text)='' then
+function IsVoid(const text: RawUtf8): boolean;
+
+/// fill all bytes of this memory buffer with zeros, i.e. 'toto' -> #0#0#0#0
+// - will write the memory buffer directly, if this string instance is not shared
+// (i.e. has refcount = 1), to avoid zeroing still-used values
+// - may be used to cleanup stack-allocated content
+// ! ... finally FillZero(secret); end;
+procedure FillZero(var secret: RawByteString); overload;
+
+/// fill all bytes of this UTF-8 string with zeros, i.e. 'toto' -> #0#0#0#0
+// - will write the memory buffer directly, if this string instance is not shared
+// (i.e. has refcount = 1), to avoid zeroing still-used values
+// - may be used to cleanup stack-allocated content
+// ! ... finally FillZero(secret); end;
+procedure FillZero(var secret: RawUtf8); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fill all bytes of this UTF-8 string with zeros, i.e. 'toto' -> #0#0#0#0
+// - SpiUtf8 type has been defined explicitly to store Sensitive Personal
+// Information
+procedure FillZero(var secret: SpiUtf8); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fill all bytes of this dynamic array of bytes with zeros
+// - will write the memory buffer directly, if this array instance is not shared
+// (i.e. has refcount = 1), to avoid zeroing still-used values
+procedure FillZero(var secret: TBytes); overload;
+
+{$ifdef HASVARUSTRING}
+/// fill all bytes of this UTF-16 string with zeros, i.e. 'toto' -> #0#0#0#0
+procedure FillZero(var secret: UnicodeString); overload;
+{$endif HASVARUSTRING}
+
+/// actual replacement function called by StringReplaceAll() on first match
+// - not to be called as such, but defined globally for proper inlining
+function StringReplaceAllProcess(const S, OldPattern, NewPattern: RawUtf8;
+  found: integer; Lookup: PNormTable): RawUtf8;
+
+/// fast version of StringReplace(S, OldPattern, NewPattern, [rfReplaceAll]);
+function StringReplaceAll(const S, OldPattern, NewPattern: RawUtf8;
+  Lookup: PNormTable = nil): RawUtf8; overload;
+
+/// case-sensitive (or not) StringReplace(S, OldPattern, NewPattern,[rfReplaceAll])
+// - calls plain StringReplaceAll() version for CaseInsensitive = false
+// - calls StringReplaceAll(.., NormToUpperAnsi7) if CaseInsensitive = true
+function StringReplaceAll(const S, OldPattern, NewPattern: RawUtf8;
+  CaseInsensitive: boolean): RawUtf8; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// fast version of several cascaded StringReplaceAll()
+function StringReplaceAll(const S: RawUtf8;
+  const OldNewPatternPairs: array of RawUtf8;
+  CaseInsensitive: boolean = false): RawUtf8; overload;
+
+/// fast replace of a specified char by a given string
+function StringReplaceChars(const Source: RawUtf8; OldChar, NewChar: AnsiChar): RawUtf8;
+
+/// fast replace of all #9 chars by a given string
+function StringReplaceTabs(const Source, TabText: RawUtf8): RawUtf8;
+
+/// UTF-8 dedicated (and faster) alternative to StringOfChar((Ch,Count))
+function RawUtf8OfChar(Ch: AnsiChar; Count: integer): RawUtf8;
+
+/// format a 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(const S: RawUtf8; Quote: AnsiChar = ''''): RawUtf8; overload;
+
+/// format a text content with SQL-like quotes
+procedure QuotedStr(const S: RawUtf8; Quote: AnsiChar; var result: RawUtf8); overload;
+
+/// format a text buffer with SQL-like quotes
+procedure QuotedStr(P: PUtf8Char; PLen: PtrInt; Quote: AnsiChar;
+  var result: RawUtf8); overload;
+
+/// unquote a SQL-compatible string
+// - the first character in P^ must be either ' or " then internal double quotes
+// are transformed into single quotes
+// - 'text '' end'   -> text ' end
+// - "text "" end"   -> text " end
+// - returns nil if P doesn't contain a valid SQL string
+// - returns a pointer just after the quoted text otherwise
+function UnQuoteSqlStringVar(P: PUtf8Char; out Value: RawUtf8): PUtf8Char;
+
+/// unquote a SQL-compatible string
+function UnQuoteSqlString(const Value: RawUtf8): RawUtf8;
+
+/// unquote a SQL-compatible symbol name
+// - e.g. '[symbol]' -> 'symbol' or '"symbol"' -> 'symbol'
+function UnQuotedSqlSymbolName(const ExternalDBSymbol: RawUtf8): RawUtf8;
+
+/// get the next character after a quoted buffer
+// - the first character in P^ must be either ', either "
+// - it will return the latest quote position, ignoring double quotes within
+function GotoEndOfQuotedString(P: PUtf8Char): PUtf8Char;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// get the next character not in [#1..' ']
+function GotoNextNotSpace(P: PUtf8Char): PUtf8Char;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// get the next character not in [#9,' ']
+function GotoNextNotSpaceSameLine(P: PUtf8Char): PUtf8Char;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// get the next character in [#0..' ']
+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}
+
+/// retrieve the next SQL-like identifier within the UTF-8 buffer
+// - will also trim any space (or line feeds) and trailing ';'
+// - any comment like '/*nocache*/' will be ignored
+// - returns true if something was set to Prop
+function GetNextFieldProp(var P: PUtf8Char; var Prop: RawUtf8): boolean;
+
+/// retrieve the next identifier within the UTF-8 buffer on the same line
+// - GetNextFieldProp() will just handle line feeds (and ';') as spaces - which
+// is fine e.g. for SQL, but not for regular config files with name/value pairs
+// - returns true if something was set to Prop
+function GetNextFieldPropSameLine(var P: PUtf8Char; var Prop: ShortString): boolean;
+
+/// return true if IdemPChar(source,searchUp), and go to the next line of source
+function IdemPCharAndGetNextLine(var source: PUtf8Char; searchUp: PAnsiChar): boolean;
+
+/// search for a value from its uppercased named entry
+// - i.e. iterate IdemPChar(source,UpperName) over every line of the source
+// - returns the text just after UpperName if it has been found at line beginning
+// - returns nil if UpperName was not found at any line beginning
+// - could be used e.g. to efficently extract a value from HTTP headers, whereas
+// FindIniNameValue() is tuned for [section]-oriented INI files
+function FindNameValue(P: PUtf8Char; UpperName: PAnsiChar): PUtf8Char; overload;
+
+/// search and returns a value from its uppercased named entry
+// - i.e. iterate IdemPChar(source,UpperName) over every line of the source
+// - returns true and the trimmed text just after UpperName into Value
+// if it has been found at line beginning
+// - returns false and set Value := '' if UpperName was not found (or leave
+// Value untouched if KeepNotFoundValue is true)
+// - could be used e.g. to efficently extract a value from HTTP headers, whereas
+// FindIniNameValue() is tuned for [section]-oriented INI files
+// - do TrimLeftLines(NameValuePairs) first if the lines start with spaces/tabs
+function FindNameValue(const NameValuePairs: RawUtf8; UpperName: PAnsiChar;
+  var Value: RawUtf8; KeepNotFoundValue: boolean = false;
+  UpperNameSeparator: AnsiChar = #0): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// search and returns a PUtf8Char value from its uppercased named entry
+// - as called when inlining FindNameValue()
+// - won't make any memory allocation, so could be fine for a quick lookup
+function FindNameValuePointer(NameValuePairs: PUtf8Char; UpperName: PAnsiChar;
+  out FoundLen: PtrInt; UpperNameSeparator: AnsiChar): PUtf8Char;
+
+/// compute the line length from source array of chars
+// - if PEnd = nil, end counting at either #0, #13 or #10
+// - otherwise, end counting at either #13 or #10
+// - just a wrapper around BufferLineLength() checking PEnd=nil case
+function GetLineSize(P, PEnd: PUtf8Char): PtrUInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// returns true if the line length from source array of chars is not less than
+// the specified count
+function GetLineSizeSmallerThan(P, PEnd: PUtf8Char; aMinimalCount: integer): boolean;
+
+{$ifndef PUREMORMOT2}
+/// 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;
+{$endif PUREMORMOT2}
+
+/// 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 7-bit 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 7-bit 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 7-bit ANSI with Delphi 7
+// to 2007, and UTF-8 encoded with Delphi 2009+
+procedure TrimLeftLowerCaseToShort(V: PShortString; out result: ShortString); overload;
+
+/// fast append some UTF-8 text into a ShortString, with an ending ','
+procedure AppendShortComma(text: PAnsiChar; len: PtrInt; var result: ShortString;
+  trimlowercase: boolean);   {$ifdef FPC} inline; {$endif}
+
+/// fast search of an exact case-insensitive match of a RTTI's PShortString array
+function FindShortStringListExact(List: PShortString; MaxValue: integer;
+  aValue: PUtf8Char; aValueLen: PtrInt): integer;
+
+/// fast case-insensitive search of a left-trimmed lowercase match
+// of a RTTI's PShortString array
+function FindShortStringListTrimLowerCase(List: PShortString; MaxValue: integer;
+  aValue: PUtf8Char; aValueLen: PtrInt): integer;
+
+/// fast case-sensitive search of a left-trimmed lowercase match
+// of a RTTI's PShortString array
+function FindShortStringListTrimLowerCaseExact(List: PShortString; MaxValue: integer;
+  aValue: PUtf8Char; aValueLen: PtrInt): integer;
+
+/// 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 7-bit ANSI with Delphi
+// up 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 7-bit ANSI with Delphi 7 to 2007, and UTF-8 encoded with Delphi 2009+
+// - '_' char is transformed into ' - '
+// - '__' chars are transformed into ': '
+function UnCamelCase(D, P: PUtf8Char): integer; overload;
+
+/// convert a string into an human-friendly CamelCase identifier
+// - replacing spaces or punctuations by an uppercase character
+// - as such, it is not the reverse function to UnCamelCase()
+procedure CamelCase(P: PAnsiChar; len: PtrInt; var s: RawUtf8;
+  const isWord: TSynByteSet = [ord('0')..ord('9'), ord('a')..ord('z'), ord('A')..ord('Z')]); overload;
+
+/// convert a string into an human-friendly CamelCase identifier
+// - replacing spaces or punctuations by an uppercase character
+// - as such, it is not the reverse function to UnCamelCase()
+procedure CamelCase(const text: RawUtf8; var s: RawUtf8;
+  const isWord: TSynByteSet = [ord('0')..ord('9'), ord('a')..ord('z'), ord('A')..ord('Z')]); overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+var
+  /// these procedure type must be defined if a default system.pas is used
+  // - expect generic "string" type, i.e. UnicodeString for Delphi 2009+
+  LoadResStringTranslate: procedure(var Text: string) = nil;
+
+/// 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);
+
+
+{ ************ TRawUtf8DynArray Processing Functions }
+
+/// returns TRUE if Value is nil or all supplied Values[] equal ''
+function IsZero(const Values: TRawUtf8DynArray): boolean; overload;
+
+/// 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;
+
+/// low-level efficient search of Value in Values[]
+// - CaseSensitive=false will use StrICmp() for A..Z / a..z equivalence
+function FindRawUtf8(Values: PRawUtf8; const Value: RawUtf8; ValuesCount: integer;
+  CaseSensitive: boolean): integer; overload;
+
+/// return the index of Value in Values[], -1 if not found
+// - CaseSensitive=false will use StrICmp() for A..Z / a..z equivalence
+function FindRawUtf8(const Values: TRawUtf8DynArray; const Value: RawUtf8;
+  CaseSensitive: boolean = true): integer; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// return the index of Value in Values[], -1 if not found
+// - CaseSensitive=false will use StrICmp() for A..Z / a..z equivalence
+function FindRawUtf8(const Values: array of RawUtf8; const Value: RawUtf8;
+  CaseSensitive: boolean = true): integer; overload;
+
+/// 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
+function AddRawUtf8(var Values: TRawUtf8DynArray; var ValuesCount: integer;
+  const Value: RawUtf8): PtrInt; overload;
+
+/// add Value[] items to Values[]
+procedure AddRawUtf8(var Values: TRawUtf8DynArray; const Value: TRawUtf8DynArray); overload;
+
+/// add Value[] items to Values[], with an external count variable, for performance
+procedure AddRawUtf8(var Values: TRawUtf8DynArray; var ValuesCount: integer;
+  const Value: TRawUtf8DynArray); overload;
+
+/// true if both TRawUtf8DynArray are the same
+// - comparison is case-sensitive
+function RawUtf8DynArrayEquals(const A, B: TRawUtf8DynArray): boolean; overload;
+
+/// true if both TRawUtf8DynArray are the same for a given number of items
+// - A and B are expected to have at least Count items
+// - comparison is case-sensitive
+function RawUtf8DynArrayEquals(const A, B: TRawUtf8DynArray;
+  Count: integer): boolean; overload;
+
+/// add the Value to Values[] string array
+function AddString(var Values: TStringDynArray; const Value: string): PtrInt;
+
+/// 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);
+
+/// retrieve the index where to insert a PUtf8Char in a sorted PUtf8Char array
+// - R is the last index of available entries in P^ (i.e. Count-1)
+// - string comparison is case-sensitive StrComp (so will work with any PAnsiChar)
+// - returns -1 if the specified Value was found (i.e. adding will duplicate a value)
+// - will use fast O(log(n)) binary search algorithm
+function FastLocatePUtf8CharSorted(P: PPUtf8CharArray; R: PtrInt;
+  Value: PUtf8Char): PtrInt; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// retrieve the index where to insert a PUtf8Char in a sorted PUtf8Char array
+// - this overloaded function accept a custom comparison function for sorting
+// - R is the last index of available entries in P^ (i.e. Count-1)
+// - string comparison is case-sensitive (so will work with any PAnsiChar)
+// - returns -1 if the specified Value was found (i.e. adding will duplicate a value)
+// - will use fast O(log(n)) binary search algorithm
+function FastLocatePUtf8CharSorted(P: PPUtf8CharArray; R: PtrInt;
+  Value: PUtf8Char; Compare: TUtf8Compare): PtrInt; overload;
+
+/// retrieve the index where is located a PUtf8Char in a sorted PUtf8Char array
+// - R is the last index of available entries in P^ (i.e. Count-1)
+// - string comparison is case-sensitive StrComp (so will work with any PAnsiChar)
+// - returns -1 if the specified Value was not found
+// - will use inlined binary search algorithm with optimized x86_64 branchless asm
+// - slightly faster than plain FastFindPUtf8CharSorted(P,R,Value,@StrComp)
+function FastFindPUtf8CharSorted(P: PPUtf8CharArray; R: PtrInt;
+  Value: PUtf8Char): PtrInt; overload;
+
+/// retrieve the index where is located a PUtf8Char in a sorted uppercase array
+// - P[] array is expected to be already uppercased
+// - searched Value is converted to uppercase before search via UpperCopy255Buf(),
+// so is expected to be short, i.e. length < 250
+// - R is the last index of available entries in P^ (i.e. Count-1)
+// - returns -1 if the specified Value was not found
+// - will use fast O(log(n)) binary search algorithm
+// - slightly faster than plain FastFindPUtf8CharSorted(P,R,Value,@StrIComp)
+function FastFindUpperPUtf8CharSorted(P: PPUtf8CharArray; R: PtrInt;
+  Value: PUtf8Char; ValueLen: PtrInt): PtrInt;
+  {$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 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 - 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: PtrInt): 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); overload;
+
+/// sort a RawUtf8 array, low values first
+procedure QuickSortRawUtf8(Values: PRawUtf8Array; L, R: PtrInt;
+  caseInsensitive: boolean = false); overload;
+
+{$ifdef OSPOSIX}
+type
+  /// monitor a POSIX folder for all its file names, and allow efficient
+  // case-insensitive search, as it would on a Windows file system
+  // - will use our fast PosixFileNames() low-level API to read the names
+  // and store them into its in-memory cache (until Flush or after FlushSeconds)
+  TPosixFileCaseInsensitive = class
+  protected
+    fSafe: TRWLightLock;
+    fFiles: TRawUtf8DynArray;
+    fFolder: TFileName;
+    fNextTix, fFlushSeconds: integer;
+    fSubFolders: boolean;
+    procedure SetFolder(const aFolder: TFileName);
+    procedure SetSubFolders(aSubFolders: boolean);
+  public
+    /// initialize the file names lookup
+    constructor Create(const aFolder: TFileName; aSubFolders: boolean); reintroduce;
+    /// to be called on a regular pace (e.g. every second) to perform FlushSeconds
+    procedure OnIdle(tix64: Int64);
+    /// clear the internal list to force full reload of the directory
+    procedure Flush;
+    /// case-insensitive search for a given TFileName in the folder
+    // - returns '' if not found, or the exact file name in the POSIX folder
+    // - is thread-safe and non blocking during its lookup
+    // - can optionally return MicroSec spent for actual filenames read on disk
+    function Find(const aSearched: TFileName; aReadMs: PInteger = nil): TFileName;
+    /// how many file entries are currently in the internal list
+    function Count: PtrInt;
+    /// make a dynamic array copy of the internal file names, sorted by StrIComp
+    function Files: TRawUtf8DynArray;
+    /// allow to change the monitored folder at runtime
+    property Folder: TFileName
+      read fFolder write SetFolder;
+    /// define if sub-folders should also be included to the internal list
+    property SubFolders: boolean
+      read fSubFolders write SetSubFolders;
+    /// after how many seconds OnIdle() should flush the internal cache
+    // - default is 60, i.e. 1 minute
+    // - you can set 0 to disable any auto-flush from OnIdle()
+    property FlushSeconds: integer
+      read fFlushSeconds write fFlushSeconds;
+  end;
+{$endif OSPOSIX}
+
+
+{ ************** Operating-System Independent Unicode Process }
+
+/// UpperCase conversion of a UTF-8 buffer using our Unicode 10.0 tables
+// - won't call the Operating System, so is consistent on all platforms,
+// whereas UpperCaseUnicode() may vary depending on each library implementation
+// - some codepoints enhance in length, so D^ should be at least twice than S^
+// - any invalid input is replaced by UNICODE_REPLACEMENT_CHARACTER=$fffd
+// - won't use temporary UTF-16 decoding, and optimized for plain ASCII content
+function Utf8UpperReference(S, D: PUtf8Char): PUtf8Char; overload;
+
+/// UpperCase conversion of a UTF-8 buffer using our Unicode 10.0 tables
+// - won't call the Operating System, so is consistent on all platforms,
+// whereas UpperCaseUnicode() may vary depending on each library implementation
+// - some codepoints enhance in length, so D^ should be at least twice than S^
+// - any invalid input is replaced by UNICODE_REPLACEMENT_CHARACTER=$fffd
+// - won't use temporary UTF-16 decoding, and optimized for plain ASCII content
+// - knowing the Source length, this function will handle any ASCII 7-bit input
+// by quad, for efficiency
+function Utf8UpperReference(S, D: PUtf8Char; SLen: PtrUInt): PUtf8Char; overload;
+
+/// UpperCase conversion of a UTF-8 string using our Unicode 10.0 tables
+// - won't call the Operating System, so is consistent on all platforms,
+// whereas UpperCaseUnicode() may vary depending on each library implementation
+// - won't use temporary UTF-16 decoding, and optimized for plain ASCII content
+function UpperCaseReference(const S: RawUtf8): RawUtf8;
+
+/// UTF-8 comparison using our Unicode 10.0 tables
+// - this version expects u1 and u2 to be zero-terminated
+// - Utf8IComp() handles WinAnsi CP-1252 latin accents - this one is Unicode
+// - won't call the Operating System, so is consistent on all platforms, and
+// don't require any temporary UTF-16 decoding
+// - has a branchless optimized process of 7-bit ASCII charset [a..z] -> [A..Z]
+function Utf8ICompReference(u1, u2: PUtf8Char): PtrInt;
+
+/// UTF-8 comparison using our Unicode 10.0 tables
+// - this version expects u1 and u2 not to be necessary zero-terminated, but
+// uses L1 and L2 as length for u1 and u2 respectively
+// - Utf8ILComp() handles WinAnsi CP-1252 latin accents - this one is Unicode
+// - won't call the Operating System, so is consistent on all platforms, and
+// don't require any temporary UTF-16 decoding
+// - has a branchless optimized process of 7-bit ASCII charset [a..z] -> [A..Z]
+function Utf8ILCompReference(u1, u2: PUtf8Char; L1, L2: integer): PtrInt;
+
+/// UpperCase conversion of UTF-8 into UCS4 using our Unicode 10.0 tables
+// - won't call the Operating System, so is consistent on all platforms,
+// whereas UpperCaseUnicode() may vary depending on each library implementation
+function UpperCaseUcs4Reference(const S: RawUtf8): RawUcs4;
+
+/// UTF-8 Unicode 10.0 case-insensitive Pattern search within UTF-8 buffer
+// - returns nil if no match, or the Pattern position found inside U^
+// - Up should have been already converted using UpperCaseUcs4Reference()
+// - won't call the Operating System, so is consistent on all platforms, and
+// don't require any temporary UTF-16 decoding
+function StrPosIReference(U: PUtf8Char; const Up: RawUcs4): PUtf8Char;
+
+
+implementation
+
+
+{ *************** UTF-8 Efficient Encoding / Decoding }
+
+{ TUtf8Table }
+
+function TUtf8Table.GetHighUtf8Ucs4(var U: PUtf8Char): Ucs4CodePoint;
+var
+  x, i: PtrInt;
+  v: byte;
+  c: PtrUInt;
+begin
+  result := 0;
+  c := byte(U^); // here c=U^>=#80
+  inc(U);
+  x := Lookup[c];
+  if x = UTF8_INVALID then
+    exit;
+  i := 0;
+  repeat
+    v := byte(U[i]);
+    if v and $c0 <> $80 then
+      exit; // invalid input content
+    c := (c shl 6) + v;
+    inc(i);
+  until i = x;
+  inc(U, x);
+  with Extra[x] do
+  begin
+    dec(c, offset);
+    if c < minimum then
+      exit; // invalid input content
+  end;
+  result := c;
+end;
+
+function GetHighUtf8Ucs4(var U: PUtf8Char): Ucs4CodePoint;
+begin
+  result := UTF8_TABLE.GetHighUtf8Ucs4(U);
+end;
+
+function GetUtf8WideChar(P: PUtf8Char): cardinal;
+begin
+  if P <> nil then
+  begin
+    result := byte(P^);
+    if result > $7f then
+    begin
+      result := UTF8_TABLE.GetHighUtf8Ucs4(P);
+      if result > $ffff then
+        // surrogates can't be stored in a single UTF-16 WideChar
+        result := UNICODE_REPLACEMENT_CHARACTER;
+    end;
+  end
+  else
+    result := PtrUInt(P);
+end;
+
+function NextUtf8Ucs4(var P: PUtf8Char): Ucs4CodePoint;
+begin
+  if P <> nil then
+  begin
+    result := byte(P[0]);
+    if result <= 127 then
+      inc(P)
+    else
+      if result and $20 = 0 then
+      begin
+        // fast $0..$7ff process
+        result := (result shl 6) + byte(P[1]) - $3080;
+        inc(P, 2);
+      end
+      else
+        // complex but efficient wrapper handling even UTF-16 surrogates
+        result := UTF8_TABLE.GetHighUtf8Ucs4(P);
+  end
+  else
+    result := 0;
+end;
+
+function Ucs4ToUtf8(ucs4: Ucs4CodePoint; Dest: PUtf8Char): PtrInt;
+var
+  j: PtrInt;
+begin
+  if ucs4 <= $7f then
+  begin
+    Dest^ := AnsiChar(ucs4);
+    result := 1;
+  end
+  else if ucs4 <= $7ff then
+  begin
+    Dest[0] := AnsiChar($C0 or (ucs4 shr 6));
+    Dest[1] := AnsiChar($80 or (ucs4 and $3F));
+    result := 2;
+  end
+  else if ucs4 <= $ffff then
+  begin
+    Dest[0] := AnsiChar($E0 or (ucs4 shr 12));
+    Dest[1] := AnsiChar($80 or ((ucs4 shr 6) and $3F));
+    Dest[2] := AnsiChar($80 or (ucs4 and $3F));
+    result := 3;
+  end
+  else
+  begin
+    // here ucs4 > $ffff
+    if ucs4 <= $1FFFFF then
+      result := 4
+    else if ucs4 <= $3FFFFFF then
+      result := 5
+    else
+      result := 6;
+    j := result - 1;
+    repeat
+      Dest[j] := AnsiChar((ucs4 and $3f) or $80);
+      ucs4 := ucs4 shr 6;
+      dec(j);
+    until j = 0;
+    Dest^ := AnsiChar(byte(ucs4) or UTF8_TABLE.FirstByte[result]);
+  end;
+end;
+
+function Utf16CharToUtf8(Dest: PUtf8Char; var Source: PWord): integer;
+var
+  c: cardinal;
+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 - UTF16_SURROGATE_OFFSET) shl 10) or
+              (Source^ xor UTF16_LOSURROGATE_MIN);
+        inc(Source);
+      end;
+    UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX:
+      begin
+        c := ((cardinal(Source^) - UTF16_SURROGATE_OFFSET) shl 10) or
+              (c xor UTF16_LOSURROGATE_MIN);
+        inc(Source);
+      end;
+  end;
+  // now c is the UTF-32/UCS4 code point
+  result := Ucs4ToUtf8(c, Dest);
+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
+     (SourceLen > 0) and
+     (Dest <> nil) then
+  begin
+    // ignore any trailing BOM (do exist on Windows files)
+    if Source^ = BOM_UTF16LE then
+    begin
+      inc(Source);
+      dec(SourceLen);
+    end;
+    // first handle 7-bit ASCII WideChars, by pairs (Sha optimization)
+    SourceLen := SourceLen * 2 + PtrInt(PtrUInt(Source));
+    Tail := PWideChar(SourceLen) - 2;
+    if (PtrInt(PtrUInt(Dest)) < DestLen) and
+       (Source <= Tail) then
+      repeat
+        c := PCardinal(Source)^;
+        if c and $ff80ff80 <> 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 CodePoint per iteration
+    if (PtrInt(PtrUInt(Dest)) < DestLen) and
+       (PtrInt(PtrUInt(Source)) < SourceLen) then
+      repeat
+      // inlined Utf16CharToUtf8() with bufferoverlow check and $FFFD on unmatch
+        c := cardinal(Source^);
+        inc(Source);
+        case c of
+          0..$7f:
+            begin
+              Dest^ := AnsiChar(c);
+              inc(Dest);
+              if (PtrInt(PtrUInt(Dest)) < DestLen) and
+                 (PtrInt(PtrUInt(Source)) < SourceLen) then
+                continue
+              else
+                break;
+            end;
+          UTF16_HISURROGATE_MIN..UTF16_HISURROGATE_MAX:
+            if (PtrInt(PtrUInt(Source)) >= SourceLen) or
+               ((cardinal(Source^) < UTF16_LOSURROGATE_MIN) 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; // UTF-8 UNICODE_REPLACEMENT_CHARACTER
+              Dest[2] := AnsiChar($BD);
+              inc(Dest, 3);
+              if (PtrInt(PtrUInt(Dest)) < DestLen) and
+                 (PtrInt(PtrUInt(Source)) < SourceLen) then
+                continue
+              else
+                break;
+            end
+            else
+            begin
+              c := ((c - UTF16_SURROGATE_OFFSET) shl 10) or
+                   (cardinal(Source^) xor UTF16_LOSURROGATE_MIN);
+              inc(Source);
+            end;
+          UTF16_LOSURROGATE_MIN..UTF16_LOSURROGATE_MAX:
+            if (PtrInt(PtrUInt(Source)) >= SourceLen) or
+               ((cardinal(Source^) < UTF16_HISURROGATE_MIN) or
+                (cardinal(Source^) > UTF16_HISURROGATE_MAX)) then
+              goto unmatch
+            else
+            begin
+              c := ((cardinal(Source^) - UTF16_SURROGATE_OFFSET) shl 10) or
+                   (c xor UTF16_LOSURROGATE_MIN);
+              inc(Source);
+            end;
+        end; // now c is the UTF-32/UCS4 code point
+        if c <= $7ff then
+          i := 2
+        else if c <= $ffff then
+          i := 3
+        else if c <= $1FFFFF then
+          i := 4
+        else if c <= $3FFFFFF then
+          i := 5
+        else
+          i := 6;
+        if PtrInt(PtrUInt(Dest)) + i > DestLen then
+          break;
+        j := i - 1;
+        repeat
+          Dest[j] := AnsiChar((c and $3f) or $80);
+          c := c shr 6;
+          dec(j);
+        until j = 0;
+        Dest^ := AnsiChar(byte(c) or UTF8_TABLE.FirstByte[i]);
+        inc(Dest, i);
+        if (PtrInt(PtrUInt(Dest)) < DestLen) and
+           (PtrInt(PtrUInt(Source)) < SourceLen) then
+          continue
+        else
+          break;
+      until false;
+    if not (ccfNoTrailingZero in Flags) then
+      Dest^ := #0;
+  end;
+  result := PtrInt(PtrUInt(Dest)) - result;
+end;
+
+procedure RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer;
+  var result: TSynTempBuffer; Flags: TCharConversionFlags);
+begin
+  if (WideChar = nil) or
+     (WideCharCount = 0) then
+    result.Init(0)
+  else
+  begin
+    result.Init(WideCharCount * 3);
+    result.Len := RawUnicodeToUtf8(
+      result.buf, result.len, WideChar, WideCharCount, Flags);
+  end;
+end;
+
+procedure RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer;
+  var result: RawUtf8; Flags: TCharConversionFlags);
+var
+  tmp: TSynTempBuffer;
+begin
+  RawUnicodeToUtf8(WideChar, WideCharCount, tmp, Flags);
+  FastSetString(result, tmp.buf, tmp.len);
+  tmp.Done;
+end;
+
+function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer;
+  Flags: TCharConversionFlags): RawUtf8;
+begin
+  RawUnicodeToUtf8(WideChar, WideCharCount, result, Flags);
+end;
+
+function RawUnicodeToUtf8(WideChar: PWideChar; WideCharCount: integer;
+  out Utf8Length: integer): RawUtf8;
+var
+  LW: integer;
+begin
+  result := ''; // somewhat faster if result is freed before any SetLength()
+  if WideCharCount = 0 then
+    exit;
+  LW := WideCharCount * 3; // maximum resulting length
+  SetLength(result, LW);
+  Utf8Length := RawUnicodeToUtf8(pointer(result), LW + 1,
+    WideChar, WideCharCount, [ccfNoTrailingZero]);
+  if Utf8Length <= 0 then
+    result := '';
+end;
+
+procedure Utf8ToShortString(var dest: ShortString; source: PUtf8Char);
+var
+  c: cardinal;
+  len, extra, i: integer;
+  {$ifdef CPUX86NOTPIC}
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+begin
+  {$ifndef CPUX86NOTPIC}
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  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.Lookup[c];
+        if extra = UTF8_INVALID then
+          break;
+        i := extra;
+        repeat
+          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);
+          dec(i);
+        until i = 0;
+        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 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;
+  {$ifdef CPUX86NOTPIC}
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+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;
+  {$ifndef CPUX86NOTPIC}
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  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 (source < endSource) and
+         (dest < endDest) then
+        continue
+      else
+        break;
+    end;
+    extra := utf8.Lookup[c];
+    if (extra = UTF8_INVALID) or
+       (source + extra > endSource) then
+      break;
+    i := 0;
+    repeat
+      if byte(source^) and $c0 <> $80 then
+        goto Quit; // invalid input content
+      c := (c shl 6) + byte(source[i]);
+      inc(i);
+    until i = extra;
+    inc(source, extra);
+    with utf8.Extra[extra] do
+    begin
+      dec(c, offset);
+      if c < minimum then
+        break; // invalid input content
+    end;
+    if c <= $ffff then
+    begin
+      PWord(dest)^ := c;
+      inc(dest);
+      if (source < endSource) and
+         (dest < endDest) then
+        continue
+      else
+        break;
+    end;
+    dec(c, $10000); // store as UTF-16 surrogates
+    PWordArray(dest)[0] := (c shr 10) or UTF16_HISURROGATE_MIN;
+    PWordArray(dest)[1] := (c and $3FF) or UTF16_LOSURROGATE_MIN;
+    inc(dest, 2);
+    if (source >= 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;
+  {$ifdef CPUX86NOTPIC}
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+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;
+  {$ifndef CPUX86NOTPIC}
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  begd := dest;
+  endSource := source + sourceBytes;
+  endSourceBy4 := endSource - 4;
+  if {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}(PtrUInt(source) and 3 = 0) and{$endif}
+     (source <= endSourceBy4) then
+    repeat // handle 7-bit ASCII chars, by quad
+      c := PCardinal(source)^;
+      if c and $80808080 <> 0 then
+        goto by1; // break on first non ASCII quad
+by4:  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 source < endSource then
+    repeat
+by1:  c := byte(source^);
+      inc(source);
+      if c <= 127 then
+      begin
+        PWord(dest)^ := c; // much faster than dest^ := WideChar(c) for FPC
+        inc(dest);
+        if {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}(PtrUInt(source) and 3 = 0) and{$endif}
+           (source <= endSourceBy4) then
+        begin
+          c := PCardinal(source)^;
+          if c and $80808080 = 0 then
+            goto by4
+          else
+            continue;
+        end;
+        if source < endSource then
+          continue
+        else
+          break;
+      end;
+      extra := utf8.Lookup[c];
+      if (extra = UTF8_INVALID) or
+         (source + extra > endSource) then
+        break;
+      i := 0;
+      repeat
+        if byte(source^) and $c0 <> $80 then
+          goto quit; // invalid input content
+        c := (c shl 6) + byte(source[i]);
+        inc(i);
+      until i = extra;
+      inc(source, extra);
+      with utf8.Extra[extra] do
+      begin
+        dec(c, offset);
+        if c < minimum then
+          break; // invalid input content
+      end;
+      if c <= $ffff then
+      begin
+        PWord(dest)^ := c;
+        inc(dest);
+        if {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}(PtrUInt(source) and 3 = 0) and{$endif}
+           (source <= endSourceBy4) then
+        begin
+          c := PCardinal(source)^;
+          if c and $80808080 = 0 then
+            goto by4;
+          continue;
+        end;
+        if source < endSource then
+          continue
+        else
+          break;
+      end;
+      dec(c, $10000); // store as UTF-16 surrogates
+      PWordArray(dest)[0] := (c shr 10) or UTF16_HISURROGATE_MIN;
+      PWordArray(dest)[1] := (c and $3FF) or UTF16_LOSURROGATE_MIN;
+      inc(dest, 2);
+      if {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}(PtrUInt(source) and 3 = 0) and{$endif}
+         (source <= endSourceBy4) then
+      begin
+        c := PCardinal(source)^;
+        if c and $80808080 = 0 then
+          goto by4;
+        continue;
+      end;
+      if source >= endSource then
+        break;
+    until false;
+quit:
+  result := PtrUInt(dest) - PtrUInt(begd); // dest-begd returns bytes length
+nosource:
+  if not NoTrailingZero then
+    dest^ := #0; // always append a WideChar(0) to the end of the buffer
+end;
+
+function IsValidUtf8Pas(source: PUtf8Char; sourcelen: PtrInt): boolean;
+var
+  c: byte;
+  {$ifdef CPUX86NOTPIC}
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+label
+  done;
+begin
+  inc(PtrUInt(sourcelen), PtrUInt(source) - 4);
+  if source = nil then
+    goto done;
+  {$ifndef CPUX86NOTPIC}
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  repeat
+    if PtrUInt(source) <= PtrUInt(sourcelen) then
+    begin
+      if utf8.Lookup[ord(source[0])] = UTF8_ASCII then
+        if utf8.Lookup[ord(source[1])] = UTF8_ASCII then
+          if utf8.Lookup[ord(source[2])] = UTF8_ASCII then
+            if utf8.Lookup[ord(source[3])] = UTF8_ASCII then
+            begin
+              inc(source, 4); // optimized for JSON-like content
+              continue;
+            end
+            else
+              inc(source, 3)
+          else
+            inc(source, 2)
+        else
+          inc(source);
+    end
+    else if PtrUInt(source) >= PtrUInt(sourcelen) + 4 then
+      break;
+    c := utf8.Lookup[ord(source^)];
+    inc(source);
+    if c = UTF8_ASCII then
+      continue
+    else if c >= UTF8_INVALID then
+      // UTF8_INVALID=6, UTF8_ZERO=7 means unexpected end of input
+      break;
+    // c = extras -> check valid UTF-8 content
+    repeat
+      if byte(source^) and $c0 <> $80 then
+        goto done;
+      inc(source);
+      dec(c);
+    until c = 0;
+  until false;
+done:
+  result := PtrUInt(source) = PtrUInt(sourcelen) + 4;
+end;
+
+function IsValidUtf8(source: PUtf8Char): boolean;
+begin
+  result := IsValidUtf8Buffer(source, StrLen(source));
+end;
+
+function IsValidUtf8(const source: RawUtf8): boolean;
+begin
+  result := IsValidUtf8Buffer(pointer(source), length(source));
+end;
+
+procedure DetectRawUtf8(var source: RawByteString);
+begin
+  {$ifdef HASCODEPAGE} // do nothing on oldest Delphi
+  if (source <> '') and
+     IsValidUtf8(source) then
+    EnsureRawUtf8(source);
+  {$endif HASCODEPAGE}
+end;
+
+function IsValidUtf8WithoutControlChars(source: PUtf8Char): boolean;
+var
+  c: byte;
+  {$ifdef CPUX86NOTPIC}
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+begin
+  {$ifndef CPUX86NOTPIC}
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  result := false;
+  if source <> nil then
+    repeat
+      c := byte(source^);
+      inc(source);
+      if c <= $7f then
+        if c < 32 then
+          if c = 0 then
+            break // reached end of input
+          else
+            exit // disallow #1..#31 control char
+        else
+         continue;
+      c := utf8.Lookup[c];
+      if c = UTF8_INVALID then
+        exit;
+      // check valid UTF-8 content
+      repeat
+        if byte(source^) and $c0 <> $80 then
+          exit;
+        inc(source);
+        dec(c);
+      until c = 0;
+    until false;
+  result := true;
+end;
+
+function IsValidUtf8WithoutControlChars(const source: RawUtf8): boolean;
+var
+  s, len: PtrInt;
+  c: byte;
+  {$ifdef CPUX86NOTPIC}
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+begin
+  {$ifndef CPUX86NOTPIC}
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  result := false;
+  s := 1;
+  len := Length(source);
+  while s <= len do
+  begin
+    c := byte(source[s]);
+    inc(s);
+    if c < 32 then
+      exit // disallow #0..#31 control char
+    else if c > $7f then
+    begin
+      c := utf8.Lookup[c];
+      if c = UTF8_INVALID then
+        exit;
+      // check valid UTF-8 content
+      repeat
+        if byte(source[s]) and $c0 <> $80 then
+          exit;
+        inc(s);
+        dec(c);
+      until c = 0;
+    end;
+  end;
+  result := true;
+end;
+
+function Utf8ToUnicodeLength(source: PUtf8Char): PtrUInt;
+var
+  c: byte;
+  {$ifdef CPUX86NOTPIC}
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+begin
+  {$ifndef CPUX86NOTPIC}
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  result := 0;
+  if source <> nil then
+    repeat
+      c := utf8.Lookup[byte(source^)];
+      inc(source);
+      if c = UTF8_ASCII then
+        inc(result)
+      else if c = UTF8_ZERO then
+        break
+      else if c = UTF8_INVALID then
+        exit
+      else
+      begin
+        inc(result, 1 + ord(c >= UTF8_EXTRA_SURROGATE));
+        // check valid UTF-8 content
+        repeat
+          if byte(source^) and $c0 <> $80 then
+            exit;
+          inc(source);
+          dec(c);
+        until c = 0;
+      end;
+    until false;
+end;
+
+function Utf8TruncateToUnicodeLength(var text: RawUtf8; maxUtf16: integer): boolean;
+var
+  c: byte;
+  source: PUtf8Char;
+  {$ifdef CPUX86NOTPIC}
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+label
+  trunc;
+begin
+  {$ifndef CPUX86NOTPIC}
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  source := pointer(text);
+  if (source <> nil) and
+     (cardinal(maxUtf16) < cardinal(Length(text))) then
+    repeat
+      c := utf8.Lookup[byte(source^)];
+      inc(source);
+      if c = UTF8_ASCII then
+      begin
+        dec(maxUtf16);
+        if maxUtf16 <> 0 then
+          continue;
+trunc:  SetLength(text, source - pointer(text));
+        result := true;
+        exit;
+      end
+      else if (c = UTF8_ZERO) or
+              (c = UTF8_INVALID) then
+        break
+      else
+      begin
+        dec(maxUtf16, 1 + ord(c >= UTF8_EXTRA_SURROGATE));
+        if maxUtf16 < 0 then
+          goto trunc; // not enough place for this UTF-8 codepoint
+        // check valid UTF-8 content
+        repeat
+          if byte(source^) and $c0 <> $80 then
+            break;
+          inc(source);
+          dec(c);
+        until c = 0;
+        if maxUtf16 = 0 then
+          goto trunc;
+      end;
+    until false;
+  result := false;
+end;
+
+function Utf8TruncateToLength(var text: RawUtf8; maxBytes: PtrUInt): boolean;
+begin
+  if PtrUInt(Length(text)) < maxBytes then
+  begin
+    result := false;
+    exit; // nothing to truncate
+  end;
+  while (maxBytes > 0) and
+        (ord(text[maxBytes]) and $c0 = $80) do
+    dec(maxBytes);
+  if (maxBytes > 0) and
+     (text[maxBytes] > #$7f) then
+    dec(maxBytes);
+  SetLength(text, maxBytes);
+  result := true;
+end;
+
+function Utf8TruncatedLength(const text: RawUtf8; maxBytes: PtrUInt): PtrInt;
+begin
+  result := Length(text);
+  if PtrUInt(result) < maxBytes then
+    exit;
+  result := maxBytes;
+  if (result = 0) or
+     (text[result] <= #$7f) then
+    exit; 
+  while (result > 0) and
+        (ord(text[result]) and $c0 = $80) do
+    dec(result);
+  if (result > 0) and
+     (text[result] > #$7f) then
+    dec(result);
+end;
+
+function Utf8TruncatedLength(text: PAnsiChar; textlen, maxBytes: PtrUInt): PtrInt;
+begin
+  result := textlen;
+  if textlen < maxBytes then
+    exit;
+  result := maxBytes;
+  while (result > 0) and
+        (ord(text[result]) and $c0 = $80) do
+    dec(result);
+  if (result > 0) and
+     (text[result] > #$7f) then
+    dec(result);
+end;
+
+function Utf8FirstLineToUtf16Length(source: PUtf8Char): PtrInt;
+var
+  c: PtrUInt;
+  {$ifdef CPUX86NOTPIC}
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+begin
+  {$ifndef CPUX86NOTPIC}
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  result := 0;
+  if source <> nil then
+    repeat
+      c := byte(source^);
+      inc(source);
+      if c <= $7f then
+        if byte(c) in [0, 10, 13] then
+          break // #0, #10 or #13 stop the count
+        else
+          inc(result)
+      else
+      begin
+        c := utf8.Lookup[c];
+        if c = UTF8_INVALID then
+          exit; // invalid leading byte
+        inc(result, 1 + ord(c >= UTF8_EXTRA_SURROGATE));
+        inc(source, c); // a bit less safe, but faster
+      end;
+    until false;
+end;
+
+
+
+{ **************** UTF-8 / Unicode / Ansi Conversion Classes }
+
+var
+  // internal list of TSynAnsiConvert instances
+  SynAnsiConvertList: array of TSynAnsiConvert;
+  SynAnsiConvertListLock: TRWLightLock;
+  SynAnsiConvertListCount: integer;
+  SynAnsiConvertListCodePage: TWordDynArray; // for fast lookup in CPU L1 cache
+
+
+{ TSynAnsiConvert }
+
+function TSynAnsiConvert.AnsiBufferToUnicode(Dest: PWideChar;
+  Source: PAnsiChar; SourceChars: cardinal; NoTrailingZero: boolean): PWideChar;
+var
+  c: cardinal;
+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
+      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^); // faster than dest^ := WideChar(c) on FPC
+      inc(Source);
+      inc(Dest);
+    until (SourceChars = 0) or
+          (ord(Source^) >= 128);
+  if SourceChars > 0 then
+    // rely on the Operating System for all remaining ASCII characters
+    inc(Dest,
+      Unicode_AnsiToWide(Source, Dest, SourceChars, SourceChars, fCodePage));
+  if not NoTrailingZero then
+    Dest^ := #0;
+  result := Dest;
+end;
+
+function TSynAnsiConvert.AnsiBufferToUtf8(Dest: PUtf8Char; Source: PAnsiChar;
+  SourceChars: cardinal; NoTrailingZero: boolean): PUtf8Char;
+var
+  tmp: TSynTempBuffer;
+  c: cardinal;
+  U: PWideChar;
+begin
+  // first handle trailing 7-bit ASCII chars, by quad (Sha optimization)
+  if SourceChars >= 4 then
+    repeat
+      c := PCardinal(Source)^;
+      if c and $80808080 <> 0 then
+        break; // break on first non ASCII quad
+      PCardinal(Dest)^ := c;
+      dec(SourceChars, 4);
+      inc(Source, 4);
+      inc(Dest, 4);
+    until SourceChars < 4;
+  if (SourceChars > 0) and
+     (ord(Source^) < 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
+  begin
+    U := AnsiBufferToUnicode(tmp.Init(SourceChars * 3), Source, SourceChars);
+    result := Dest + RawUnicodeToUtf8(Dest, SourceChars * 3, tmp.buf,
+      (PtrUInt(U) - PtrUInt(tmp.buf)) shr 1, [ccfNoTrailingZero]);
+    tmp.Done;
+  end;
+  if not NoTrailingZero then
+    result^ := #0;
+end;
+
+// UTF-8 is AT MOST 50% bigger than UTF-16 in bytes in range U+0800..U+FFFF
+// see http://stackoverflow.com/a/7008095 -> bytes=WideCharCount*3 below
+
+{$ifndef PUREMORMOT2}
+
+function TSynAnsiConvert.AnsiToRawUnicode(const AnsiText: RawByteString): RawUnicode;
+begin
+  result := AnsiToRawUnicode(pointer(AnsiText), length(AnsiText));
+end;
+
+function TSynAnsiConvert.AnsiToRawUnicode(Source: PAnsiChar;
+  SourceChars: cardinal): RawUnicode;
+var
+  U: PWideChar;
+  tmp: TSynTempBuffer;
+begin
+  if SourceChars = 0 then
+    result := ''
+  else
+  begin
+    U := AnsiBufferToUnicode(tmp.Init(SourceChars * 2), Source, SourceChars);
+    U^ := #0;
+    SetString(result, PAnsiChar(tmp.buf), PtrUInt(U) - PtrUInt(tmp.buf) + 1);
+    tmp.Done;
+  end;
+end;
+
+{$endif PUREMORMOT2}
+
+function TSynAnsiConvert.AnsiToUnicodeString(Source: PAnsiChar;
+  SourceChars: cardinal): SynUnicode;
+var
+  tmp: TSynTempBuffer;
+  U: PWideChar;
+begin
+  if SourceChars = 0 then
+    result := ''
+  else
+  begin
+    U := AnsiBufferToUnicode(tmp.Init(SourceChars * 2), Source, SourceChars);
+    SetString(result, PWideChar(tmp.buf), (PtrUInt(U) - PtrUInt(tmp.buf)) shr 1);
+    tmp.Done;
+  end;
+end;
+
+function TSynAnsiConvert.AnsiToUnicodeString(const Source: RawByteString): SynUnicode;
+var
+  tmp: TSynTempBuffer;
+  U: PWideChar;
+begin
+  if Source = '' then
+    result := ''
+  else
+  begin
+    tmp.Init(length(Source) * 2); // max dest size in bytes
+    U := AnsiBufferToUnicode(tmp.buf, pointer(Source), length(Source));
+    SetString(result, PWideChar(tmp.buf), (PtrUInt(U) - PtrUInt(tmp.buf)) shr 1);
+    tmp.Done;
+  end;
+end;
+
+function TSynAnsiConvert.AnsiToUtf8(const AnsiText: RawByteString): RawUtf8;
+begin
+  AnsiBufferToRawUtf8(pointer(AnsiText), length(AnsiText), result);
+end;
+
+procedure TSynAnsiConvert.AnsiBufferToRawUtf8(Source: PAnsiChar;
+  SourceChars: cardinal; out Value: RawUtf8);
+var
+  tmp: TSynTempBuffer;
+  P: PUtf8Char;
+begin
+  if (Source = nil) or
+     (SourceChars = 0) then
+    exit;
+  P := AnsiBufferToUtf8(tmp.Init(SourceChars * 3), Source, SourceChars);
+  FastSetString(Value, tmp.buf, P - tmp.buf);
+  tmp.Done;
+end;
+
+constructor TSynAnsiConvert.Create(aCodePage: cardinal);
+begin
+  fCodePage := aCodePage;
+  fAnsiCharShift := 1; // default is safe
+end;
+
+function GetEngine(aCodePage: cardinal): TSynAnsiConvert;
+  {$ifdef HASINLINE} inline; {$endif}
+var
+  i: PtrInt;
+begin
+  SynAnsiConvertListLock.ReadLock; // concurrent read lock
+  i := WordScanIndex(pointer(SynAnsiConvertListCodePage),
+    SynAnsiConvertListCount, aCodePage); // SSE2 asm on i386 and x86_64
+  if i >= 0 then
+    result := SynAnsiConvertList[i]
+  else
+    result := nil;
+  SynAnsiConvertListLock.ReadUnLock;
+end;
+
+function NewEngine(aCodePage: cardinal): TSynAnsiConvert;
+var
+  i: PtrInt;
+begin
+  SynAnsiConvertListLock.WriteLock;
+  try
+    i := WordScanIndex(pointer(SynAnsiConvertListCodePage),
+      SynAnsiConvertListCount, aCodePage); // search again for thread safety
+    if i >= 0 then
+    begin
+      result := SynAnsiConvertList[i]; // avoid any (unlikely) race condition
+      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);
+    RegisterGlobalShutdownRelease(result);
+    ObjArrayAdd(SynAnsiConvertList, result);
+    AddWord(SynAnsiConvertListCodePage, SynAnsiConvertListCount, aCodePage);
+  finally
+    SynAnsiConvertListLock.WriteUnLock;
+  end;
+end;
+
+class function TSynAnsiConvert.Engine(aCodePage: cardinal): TSynAnsiConvert;
+begin
+  if aCodePage <> CP_ACP then
+  begin
+    result := GetEngine(aCodePage);
+    if result = nil then
+      if aCodePage = CP_RAWBLOB then
+        result := RawByteStringConvert // CP_RAWBLOB is internal -> no engine
+      else
+        result := NewEngine(aCodePage)
+  end
+  else
+    result := CurrentAnsiConvert;
+end;
+
+function TSynAnsiConvert.UnicodeBufferToAnsi(Dest: PAnsiChar;
+  Source: PWideChar; SourceChars: cardinal): PAnsiChar;
+var
+  c: cardinal;
+begin
+  if (Source <> nil) and
+     (SourceChars <> 0) then
+  begin
+    // ignore any trailing BOM (do exist on Windows files)
+    if Source^ = BOM_UTF16LE then
+    begin
+      inc(Source);
+      dec(SourceChars);
+    end;
+    // 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
+      inc(Dest,
+        Unicode_WideToAnsi(Source, Dest, SourceChars, SourceChars * 3, fCodePage));
+  end;
+  result := Dest;
+end;
+
+function TSynAnsiConvert.Utf8BufferToAnsi(Dest: PAnsiChar;
+  Source: PUtf8Char; SourceChars: cardinal): PAnsiChar;
+var
+  tmp: TSynTempBuffer;
+begin
+  if (Source = nil) or
+     (SourceChars = 0) then
+    result := Dest
+  else
+  begin
+    tmp.Init((SourceChars + 1) shl fAnsiCharShift);
+    result := UnicodeBufferToAnsi(Dest, tmp.buf,
+      Utf8ToWideChar(tmp.buf, Source, SourceChars) shr 1);
+    tmp.Done;
+  end;
+end;
+
+function TSynAnsiConvert.Utf8BufferToAnsi(
+  Source: PUtf8Char; SourceChars: cardinal): RawByteString;
+begin
+  Utf8BufferToAnsi(Source, SourceChars, result);
+end;
+
+procedure TSynAnsiConvert.Utf8BufferToAnsi(Source: PUtf8Char; SourceChars: cardinal;
+  var result: RawByteString);
+var
+  tmp: array[word] of AnsiChar;
+  max: PtrInt;
+begin
+  if (Source = nil) or
+     (SourceChars = 0) then
+    result := ''
+  else
+  begin
+    max := (SourceChars + 1) shl fAnsiCharShift;
+    if max < SizeOf(tmp) then
+      // use a temporary stack buffer up to 64KB
+      FastSetStringCP(result, @tmp,
+        Utf8BufferToAnsi(@tmp, Source, SourceChars) - PAnsiChar(@tmp), fCodePage)
+    else
+    begin
+      // huge strings will be allocated once and truncated, not resized
+      FastSetStringCP(result, nil, max, fCodePage);
+      FakeLength(result,
+        Utf8BufferToAnsi(pointer(result), Source, SourceChars) - pointer(result));
+    end;
+  end;
+end;
+
+function TSynAnsiConvert.Utf8ToAnsi(const u: RawUtf8): RawByteString;
+begin
+  Utf8BufferToAnsi(pointer(u), length(u), result);
+end;
+
+function TSynAnsiConvert.Utf8ToAnsiBuffer2K(const S: RawUtf8;
+  Dest: PAnsiChar; DestSize: integer): integer;
+var
+  tmp: array[0..2047] of AnsiChar; // truncated to 2KB as documented
+begin
+  if (DestSize <= 0) or
+     (Dest = nil) then
+  begin
+    result := 0;
+    exit;
+  end;
+  result := length(S);
+  if result > 0 then
+  begin
+    if result > SizeOf(tmp) then
+      result := SizeOf(tmp);
+    result := Utf8BufferToAnsi(tmp{%H-}, pointer(S), result) - {%H-}tmp;
+    if result >= DestSize then
+      result := DestSize - 1;
+    MoveFast(tmp, Dest^, result);
+  end;
+  Dest[result] := #0;
+end;
+
+function TSynAnsiConvert.UnicodeBufferToAnsi(Source: PWideChar;
+  SourceChars: cardinal): RawByteString;
+var
+  tmp: TSynTempBuffer;
+begin
+  if (Source = nil) or
+     (SourceChars = 0) then
+    result := ''
+  else
+  begin
+    tmp.Init(SourceChars * 3);
+    FastSetStringCP(result, tmp.buf, UnicodeBufferToAnsi(
+      tmp.buf, Source, SourceChars) - PAnsiChar(tmp.buf), fCodePage);
+    tmp.Done;
+  end;
+end;
+
+function TSynAnsiConvert.UnicodeStringToAnsi(const Source: SynUnicode): RawByteString;
+begin
+  result := UnicodeBufferToAnsi(pointer(Source), length(Source));
+end;
+
+{$ifndef PUREMORMOT2}
+function TSynAnsiConvert.RawUnicodeToAnsi(const Source: RawUnicode): RawByteString;
+begin
+  result := UnicodeBufferToAnsi(pointer(Source), length(Source) shr 1);
+end;
+{$endif PUREMORMOT2}
+
+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
+  tmp: TSynTempBuffer;
+  U: PWideChar;
+begin
+  if From.fCodePage = fCodePage then
+    FastSetStringCP(result, Source, SourceChars, fCodePage)
+  else if (Source = nil) or
+          (SourceChars = 0) then
+    result := ''
+  else
+  begin
+    U := tmp.Init(SourceChars * 2 + 2);
+    result := UnicodeBufferToAnsi(U,
+      From.AnsiBufferToUnicode(U, Source, SourceChars) - U);
+    tmp.Done;
+  end;
+end;
+
+
+{ TSynAnsiFixedWidth }
+
+function TSynAnsiFixedWidth.AnsiBufferToUnicode(Dest: PWideChar;
+  Source: PAnsiChar; SourceChars: cardinal; NoTrailingZero: boolean): PWideChar;
+var
+  i: integer;
+  tab: PWordArray;
+begin
+  // PWord*(Dest)[] is much faster than dest^ := WideChar(c) for FPC
+  tab := pointer(fAnsiToWide);
+  for i := 1 to SourceChars shr 2 do
+  begin
+    PWordArray(Dest)[0] := tab[Ord(Source[0])];
+    PWordArray(Dest)[1] := tab[Ord(Source[1])];
+    PWordArray(Dest)[2] := tab[Ord(Source[2])];
+    PWordArray(Dest)[3] := tab[Ord(Source[3])];
+    inc(Source, 4);
+    inc(Dest, 4);
+  end;
+  for i := 1 to SourceChars and 3 do
+  begin
+    PWord(Dest)^ := tab[Ord(Source^)];
+    inc(Dest);
+    inc(Source);
+  end;
+  if not NoTrailingZero then
+    Dest^ := #0;
+  result := Dest;
+end;
+
+function TSynAnsiFixedWidth.AnsiBufferToUtf8(Dest: PUtf8Char;
+  Source: PAnsiChar; SourceChars: cardinal; NoTrailingZero: boolean): PUtf8Char;
+var
+  EndSource, EndSourceBy4: PAnsiChar;
+  c: cardinal;
+label
+  by4, by1; // ugly but faster
+begin
+  if (self = nil) or
+     (Dest = nil) then
+  begin
+    result := nil;
+    Exit;
+  end
+  else if (Source <> nil) and
+          (SourceChars > 0) then
+  begin
+    // handle 7-bit ASCII WideChars, by quads
+    EndSource := Source + SourceChars;
+    EndSourceBy4 := EndSource - 4;
+    if {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}(PtrUInt(Source) and 3 = 0) and{$endif}
+       (Source <= EndSourceBy4) then
+      repeat
+        c := PCardinal(Source)^;
+        if c and $80808080 <> 0 then
+          goto by1; // break on first non ASCII quad
+by4:    inc(Source, 4);
+        PCardinal(Dest)^ := c;
+        inc(Dest, 4);
+      until Source > EndSourceBy4;
+    // generic loop, handling one WideChar per iteration
+    if Source < EndSource then
+      repeat
+by1:    c := byte(Source^);
+        inc(Source);
+        if c <= $7F then
+        begin
+          Dest^ := AnsiChar(c); // 0..127 don't need any translation
+          Inc(Dest);
+          if {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}(PtrUInt(Source) and 3 = 0) and{$endif}
+             (Source <= EndSourceBy4) then
+         begin
+           c := PCardinal(Source)^;
+           if c and $80808080 = 0 then
+             goto by4;
+           continue;
+         end;
+          if Source < EndSource then
+            continue
+          else
+            break;
+        end
+        else
+        begin
+          // no surrogate is expected in TSynAnsiFixedWidth charsets
+          c := fAnsiToWide[c]; // convert FixedAnsi char into Unicode char
+          if c > $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 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}(PtrUInt(Source) and 3 = 0) and{$endif}
+               (Source <= EndSourceBy4) then
+            begin
+              c := PCardinal(Source)^;
+              if c and $80808080 = 0 then
+                goto by4;
+              continue;
+            end;
+            if Source < EndSource then
+              continue
+            else
+              break;
+          end
+          else
+          begin
+            Dest[0] := AnsiChar($C0 or (c shr 6));
+            Dest[1] := AnsiChar($80 or (c and $3F));
+            Inc(Dest, 2);
+            if {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}(PtrUInt(Source) and 3 = 0) and{$endif}
+               (Source < EndSourceBy4) then
+            begin
+              c := PCardinal(Source)^;
+              if c and $80808080 = 0 then
+                goto by4;
+              continue;
+            end;
+            if Source < EndSource then
+              continue
+            else
+              break;
+          end;
+        end;
+      until false;
+  end;
+  if not NoTrailingZero then
+    Dest^ := #0;
+  {$ifdef ISDELPHI104}
+  exit(Dest); // circumvent Delphi 10.4 optimizer bug
+  {$else}
+  result := Dest;
+  {$endif ISDELPHI104}
+end;
+
+{$ifndef PUREMORMOT2}
+function TSynAnsiFixedWidth.AnsiToRawUnicode(Source: PAnsiChar;
+  SourceChars: cardinal): RawUnicode;
+begin
+  if SourceChars = 0 then
+    result := ''
+  else
+  begin
+    SetString(result, nil, SourceChars * 2 + 1);
+    AnsiBufferToUnicode(pointer(result), Source, SourceChars);
+  end;
+end;
+{$endif PUREMORMOT2}
+
+const
+  /// reference set for WinAnsi to Unicode conversion
+  // - this table contains all the Unicode codepoints corresponding to
+  // the Ansi Code Page 1252 (i.e. WinAnsi), which Unicode value are > 255
+  // - values taken from MultiByteToWideChar(1252,0,@Tmp,256,@WinAnsiTable,256)
+  // so are available outside the Windows platforms (e.g. Linux/BSD) and even
+  // if the system 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, len: PtrInt;
+  A256: array[0..255] of AnsiChar;
+  U256: array[0..255] of WideChar;
+begin
+  inherited;
+  if not IsFixedWidthCodePage(aCodePage) then
+    // warning: CreateUtf8() uses Utf8ToString() -> call CreateFmt() here
+    raise ESynUnicode.CreateFmt('%s.Create - Invalid code page %d',
+      [ClassNameShort(self)^, fCodePage]);
+  // create internal look-up tables
+  SetLength(fAnsiToWide, 256);
+  if (aCodePage = CP_WINANSI) or
+     (aCodePage = CP_LATIN1) or
+     (aCodePage >= CP_RAWBLOB) then
+  begin
+    // Win1252 has its own table, LATIN1 and RawByteString map 8-bit Unicode
+    for i := 0 to 255 do
+      fAnsiToWide[i] := i;
+    if aCodePage = CP_WINANSI then
+      // do not trust the Windows API for the 1252 code page :(
+      for i := low(WinAnsiUnicodeChars) to high(WinAnsiUnicodeChars) do
+        fAnsiToWide[i] := WinAnsiUnicodeChars[i];
+  end
+  else
+  begin
+    // initialize table from Operating System returned values
+    for i := 0 to 255 do
+      A256[i] := AnsiChar(i);
+    FillcharFast(U256, SizeOf(U256), 0);
+    // call mormot.core.os cross-platform Unicode_AnsiToWide()
+    len := PtrUInt(inherited AnsiBufferToUnicode(U256, A256, 256)) - PtrUInt(@U256);
+    if (len < 500) or
+       (len > 512) then
+      // warning: CreateUtf8() uses Utf8ToString() -> call CreateFmt() now
+      raise ESynUnicode.CreateFmt('OS error for %s.Create(%d) [%d]',
+        [ClassNameShort(self)^, aCodePage, len]);
+    MoveFast(U256[0], fAnsiToWide[0], 512);
+  end;
+  SetLength(fWideToAnsi, 65536);
+  for i := 1 to 126 do
+    fWideToAnsi[i] := i;
+  FillcharFast(fWideToAnsi[127], 65536 - 127, ord('?')); // '?' for unknown char
+  for i := 127 to 255 do
+    if (fAnsiToWide[i] <> 0) and
+       (fAnsiToWide[i] <> ord('?')) then
+      fWideToAnsi[fAnsiToWide[i]] := i;
+  // fixed width Ansi will never be bigger than UTF-8
+  fAnsiCharShift := 0;
+end;
+
+function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar; Length: PtrInt): boolean;
+var
+  i: PtrInt;
+  wc: PtrUInt;
+begin
+  result := false;
+  if WideText <> nil then
+    for i := 0 to Length - 1 do
+    begin
+      wc := PtrUInt(WideText[i]);
+      if wc = 0 then
+        break
+      else if wc < 256 then
+        if fAnsiToWide[wc] < 256 then
+          continue
+        else
+          exit
+      else if fWideToAnsi[wc] = ord('?') then
+        exit
+      else
+        continue;
+    end;
+  result := true;
+end;
+
+function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar): boolean;
+var
+  wc: PtrUInt;
+begin
+  result := false;
+  if WideText <> nil then
+    repeat
+      wc := PtrUInt(WideText^);
+      inc(WideText);
+      if wc = 0 then
+        break
+      else if wc < 256 then
+        if fAnsiToWide[wc] < 256 then
+          continue
+        else
+          exit
+      else if fWideToAnsi[wc] = ord('?') then
+        exit
+      else
+        continue;
+    until false;
+  result := true;
+end;
+
+function TSynAnsiFixedWidth.IsValidAnsiU(Utf8Text: PUtf8Char): boolean;
+var
+  extra: byte;
+  c, n: cardinal;
+  {$ifdef CPUX86NOTPIC}
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+begin
+  {$ifndef CPUX86NOTPIC}
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  result := false;
+  if Utf8Text <> nil then
+    repeat
+      extra := utf8.Lookup[ord(Utf8Text^)];
+      inc(Utf8Text);
+      if extra = UTF8_ASCII then
+        continue
+      else if extra = UTF8_ZERO then
+        break
+      else if extra = UTF8_INVALID then
+        exit
+      else
+      begin
+        if utf8.Extra[extra].minimum > $ffff then
+          exit;
+        n := extra;
+        c := ord(Utf8Text[-1]);
+        repeat
+          if byte(Utf8Text^) and $c0 <> $80 then
+            exit; // invalid UTF-8 content
+          c := (c shl 6) + byte(Utf8Text^);
+          inc(Utf8Text);
+          dec(n)
+        until n = 0;
+        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
+  extra: byte;
+  c, n: cardinal;
+  {$ifdef CPUX86NOTPIC}
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+begin
+  {$ifndef CPUX86NOTPIC}
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  result := false;
+  if Utf8Text <> nil then
+    repeat
+      extra := utf8.Lookup[ord(Utf8Text^)];
+      inc(Utf8Text);
+      if extra = UTF8_ASCII then
+        continue
+      else if extra = UTF8_ZERO then
+        break
+      else if extra = UTF8_INVALID then
+        exit
+      else
+      begin
+        if utf8.Extra[extra].minimum > $ffff then
+          exit;
+        n := extra;
+        c := ord(Utf8Text[-1]);
+        repeat
+          if byte(Utf8Text^) and $c0 <> $80 then
+            exit; // invalid UTF-8 content
+          c := (c shl 6) + byte(Utf8Text^);
+          inc(Utf8Text);
+          dec(n)
+        until n = 0;
+        dec(c, utf8.Extra[extra].offset);
+        if (c > 255) or
+           (fAnsiToWide[c] > 255) then
+          exit; // not 8-bit char (like "tm" or such) is marked invalid
+      end;
+    until false;
+  result := true;
+end;
+
+function TSynAnsiFixedWidth.UnicodeBufferToAnsi(Dest: PAnsiChar;
+  Source: PWideChar; SourceChars: cardinal): PAnsiChar;
+var
+  c: cardinal;
+  tab: PAnsiChar;
+begin
+  if (Source <> nil) and
+     (SourceChars <> 0) then
+  begin
+    // ignore any trailing BOM (do exist on Windows files)
+    if Source^ = BOM_UTF16LE then
+    begin
+      inc(Source);
+      dec(SourceChars);
+    end;
+    // first handle trailing 7-bit ASCII chars, by pairs (Sha optimization)
+    if SourceChars >= 2 then
+      repeat
+        c := PCardinal(Source)^;
+        if c and $ff80ff80 <> 0 then
+          break; // break on first non ASCII pair
+        dec(SourceChars, 2);
+        inc(Source, 2);
+        c := c shr 8 or c;
+        PWord(Dest)^ := c;
+        inc(Dest, 2);
+      until SourceChars < 2;
+    // use internal lookup tables for fast process of remaining chars
+    tab := pointer(fWideToAnsi);
+    for c := 1 to SourceChars shr 2 do
+    begin
+      Dest[0] := tab[Ord(Source[0])];
+      Dest[1] := tab[Ord(Source[1])];
+      Dest[2] := tab[Ord(Source[2])];
+      Dest[3] := tab[Ord(Source[3])];
+      inc(Source, 4);
+      inc(Dest, 4);
+    end;
+    for c := 1 to SourceChars and 3 do
+    begin
+      Dest^ := tab[Ord(Source^)];
+      inc(Dest);
+      inc(Source);
+    end;
+  end;
+  result := Dest;
+end;
+
+function TSynAnsiFixedWidth.Utf8BufferToAnsi(Dest: PAnsiChar;
+  Source: PUtf8Char; SourceChars: cardinal): PAnsiChar;
+var
+  c: cardinal;
+  endSource, endSourceBy4: PUtf8Char;
+  i, extra: PtrInt;
+  {$ifdef CPUX86NOTPIC}
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+label
+  by1, by4, quit; // ugly but faster
+begin
+  {$ifndef CPUX86NOTPIC}
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  // first handle trailing 7-bit ASCII chars, by quad (Sha optimization)
+  endSource := Source + SourceChars;
+  endSourceBy4 := endSource - 4;
+  if {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}(PtrUInt(Source) and 3 = 0) and{$endif}
+     (Source <= endSourceBy4) then
+    repeat
+      c := PCardinal(Source)^;
+      if c and $80808080 <> 0 then
+        goto by1; // break on first non ASCII quad
+by4:  PCardinal(Dest)^ := c;
+      inc(Source, 4);
+      inc(Dest, 4);
+    until Source > endSourceBy4;
+  // generic loop, handling one UTF-8 code per iteration
+  if Source < endSource then
+  begin
+    repeat
+by1:  c := byte(Source^);
+      inc(Source);
+      if ord(c) <= 127 then
+      begin
+        Dest^ := AnsiChar(c);
+        inc(Dest);
+        if {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}(PtrUInt(Source) and 3 = 0) and{$endif}
+           (Source <= endSourceBy4) then
+        begin
+          c := PCardinal(Source)^;
+          if c and $80808080 = 0 then
+            goto by4;
+          continue;
+        end;
+        if Source < endSource then
+          continue
+        else
+          break;
+      end
+      else
+      begin
+        extra := utf8.Lookup[c];
+        if (extra = UTF8_INVALID) or
+           (Source + extra > endSource) then
+          break;
+        i := extra;
+        repeat
+          if byte(Source^) and $c0 <> $80 then
+            goto quit; // invalid UTF-8 content
+          c := (c shl 6) + byte(Source^);
+          inc(Source);
+          dec(i);
+        until i = 0;
+        dec(c, utf8.Extra[extra].offset);
+        if c > $ffff then
+          Dest^ := '?' // '?' as in unknown fWideToAnsi[] items
+        else
+          Dest^ := AnsiChar(fWideToAnsi[c]);
+        inc(Dest);
+        if {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}(PtrUInt(Source) and 3 = 0) and{$endif}
+           (Source <= endSourceBy4) then
+        begin
+          c := PCardinal(Source)^;
+          if c and $80808080 = 0 then
+            goto by4;
+          continue;
+        end;
+        if Source < endSource then
+          continue
+        else
+          break;
+      end;
+    until false;
+  end;
+quit:
+  result := Dest;
+end;
+
+function TSynAnsiFixedWidth.WideCharToAnsiChar(wc: cardinal): integer;
+begin
+  if wc < 256 then
+    if fAnsiToWide[wc] < 256 then
+      result := wc
+    else
+      result := -1
+  else if wc <= 65535 then
+  begin
+    result := fWideToAnsi[wc];
+    if result = ord('?') then
+      result := -1;
+  end
+  else
+    result := -1;
+end;
+
+
+{ TSynAnsiUtf8 }
+
+function TSynAnsiUtf8.AnsiBufferToUnicode(Dest: PWideChar;
+  Source: PAnsiChar; SourceChars: cardinal; NoTrailingZero: boolean): PWideChar;
+begin
+  result := Dest + (Utf8ToWideChar(Dest,
+    PUtf8Char(Source), SourceChars, NoTrailingZero) shr 1);
+end;
+
+function TSynAnsiUtf8.AnsiBufferToUtf8(Dest: PUtf8Char;
+  Source: PAnsiChar; SourceChars: cardinal; NoTrailingZero: boolean): PUtf8Char;
+begin
+  MoveFast(Source^, Dest^, SourceChars);
+  if not NoTrailingZero then
+    Dest[SourceChars] := #0;
+  result := Dest + SourceChars;
+end;
+
+{$ifndef PUREMORMOT2}
+function TSynAnsiUtf8.AnsiToRawUnicode(Source: PAnsiChar;
+  SourceChars: cardinal): RawUnicode;
+begin
+  result := Utf8DecodeToRawUniCode(PUtf8Char(Source), SourceChars);
+end;
+{$endif PUREMORMOT2}
+
+constructor TSynAnsiUtf8.Create(aCodePage: cardinal);
+begin
+  if aCodePage <> CP_UTF8 then
+    raise ESynUnicode.CreateFmt('%s.Create(%d)', [ClassNameShort(self)^, aCodePage]);
+  inherited Create(aCodePage);
+end;
+
+function TSynAnsiUtf8.UnicodeBufferToAnsi(Dest: PAnsiChar;
+  Source: PWideChar; SourceChars: cardinal): PAnsiChar;
+begin
+  result := Dest + RawUnicodeToUtf8(PUtf8Char(Dest), SourceChars * 3,
+    Source, SourceChars, [ccfNoTrailingZero]);
+end;
+
+function TSynAnsiUtf8.UnicodeBufferToAnsi(Source: PWideChar;
+  SourceChars: cardinal): RawByteString;
+var
+  tmp: TSynTempBuffer;
+begin
+  if (Source = nil) or
+     (SourceChars = 0) then
+    result := ''
+  else
+  begin
+    tmp.Init(SourceChars * 3);
+    FastSetStringCP(result, tmp.buf, RawUnicodeToUtf8(tmp.buf,
+      SourceChars * 3, Source, SourceChars, [ccfNoTrailingZero]), fCodePage);
+    tmp.Done;
+  end;
+end;
+
+function TSynAnsiUtf8.Utf8BufferToAnsi(Dest: PAnsiChar;
+  Source: PUtf8Char; SourceChars: cardinal): PAnsiChar;
+begin
+  MoveFast(Source^, Dest^, SourceChars);
+  result := Dest + SourceChars;
+end;
+
+procedure TSynAnsiUtf8.Utf8BufferToAnsi(Source: PUtf8Char; SourceChars: cardinal;
+  var result: RawByteString);
+begin
+  FastSetString(RawUtf8(result), Source, SourceChars);
+end;
+
+function TSynAnsiUtf8.Utf8ToAnsi(const u: RawUtf8): RawByteString;
+begin
+  result := u; // may be read-only: no FastAssignUtf8/FakeCodePage
+  EnsureRawUtf8(result);
+end;
+
+function TSynAnsiUtf8.AnsiToUtf8(const AnsiText: RawByteString): RawUtf8;
+begin
+  result := AnsiText; // may be read-only: no FastAssignUtf8/FakeCodePage
+  EnsureRawUtf8(result);
+end;
+
+procedure TSynAnsiUtf8.AnsiBufferToRawUtf8(
+  Source: PAnsiChar; SourceChars: cardinal; out Value: RawUtf8);
+begin
+  FastSetString(Value, Source, SourceChars);
+end;
+
+
+{ TSynAnsiUtf16 }
+
+function TSynAnsiUtf16.AnsiBufferToUnicode(Dest: PWideChar;
+  Source: PAnsiChar; SourceChars: cardinal; NoTrailingZero: boolean): PWideChar;
+begin
+  MoveFast(Source^, Dest^, SourceChars);
+  result := Pointer(PtrUInt(Dest) + SourceChars);
+  if not NoTrailingZero then
+    result^ := #0;
+end;
+
+const
+  NOTRAILING: array[boolean] of TCharConversionFlags = (
+    [], [ccfNoTrailingZero]);
+
+function TSynAnsiUtf16.AnsiBufferToUtf8(Dest: PUtf8Char;
+  Source: PAnsiChar; SourceChars: cardinal; NoTrailingZero: boolean): PUtf8Char;
+begin
+  SourceChars := SourceChars shr 1; // from byte count to WideChar count
+  result := Dest + RawUnicodeToUtf8(Dest,
+    SourceChars * 3, PWideChar(Source), SourceChars, NOTRAILING[NoTrailingZero]);
+end;
+
+{$ifndef PUREMORMOT2}
+function TSynAnsiUtf16.AnsiToRawUnicode(Source: PAnsiChar;
+  SourceChars: cardinal): RawUnicode;
+begin
+  SetString(result, Source, SourceChars); // byte count
+end;
+{$endif PUREMORMOT2}
+
+constructor TSynAnsiUtf16.Create(aCodePage: cardinal);
+begin
+  if aCodePage <> CP_UTF16 then
+    raise ESynUnicode.CreateFmt('%s.Create(%d)', [ClassNameShort(self)^, aCodePage]);
+  inherited Create(aCodePage);
+end;
+
+function TSynAnsiUtf16.UnicodeBufferToAnsi(Dest: PAnsiChar;
+  Source: PWideChar; SourceChars: cardinal): PAnsiChar;
+begin
+  SourceChars := SourceChars shl 1; // from WideChar count to byte count
+  MoveFast(Source^, Dest^, SourceChars);
+  result := Dest + SourceChars;
+end;
+
+function TSynAnsiUtf16.Utf8BufferToAnsi(Dest: PAnsiChar;
+  Source: PUtf8Char; SourceChars: cardinal): PAnsiChar;
+begin
+  result := Dest + Utf8ToWideChar(PWideChar(Dest), Source, SourceChars, true);
+end;
+
+
+function IsFixedWidthCodePage(aCodePage: cardinal): boolean;
+begin
+  result := ((aCodePage >= 1250) and
+             (aCodePage <= 1258)) or
+            (aCodePage = CP_LATIN1) or
+            (aCodePage >= CP_RAWBLOB);
+end;
+
+function CodePageToText(aCodePage: cardinal): TShort16;
+begin
+  case aCodePage of
+    CP_UTF8:
+      result := 'utf8';
+    CODEPAGE_US:
+      result := 'WinAnsi';
+  else
+    begin
+      PCardinal(@result)^ := 2 + ord('c') shl 8 + ord('p') shl 16;
+      AppendShortCardinal(aCodePage, result);
+    end;
+  end;
+end;
+
+
+{ *************** Text File Loading with BOM/Unicode Support }
+
+function BomFile(var Buffer: pointer; var BufferSize: PtrInt): TBomFile;
+begin
+  result := bomNone;
+  if (Buffer <> nil) and
+     (BufferSize >= 2) then
+    case PWord(Buffer)^ of
+      ord(BOM_UTF16LE):
+        begin
+          inc(PByte(Buffer), 2);
+          dec(BufferSize, 2);
+          result := bomUnicode; // UTF-16 LE
+        end;
+      $BBEF:
+        if (BufferSize >= 3) and
+           (PByteArray(Buffer)[2] = $BF) then
+        begin
+          inc(PByte(Buffer), 3);
+          dec(BufferSize, 3);
+          result := bomUtf8;
+        end;
+    end;
+end;
+
+function StringFromBomFile(const FileName: TFileName; out FileContent: RawByteString;
+  out Buffer: pointer; out BufferSize: PtrInt): TBomFile;
+begin
+  FileContent := StringFromFile(FileName);
+  Buffer := pointer(FileContent);
+  BufferSize := length(FileContent);
+  result := BomFile(Buffer, BufferSize);
+end;
+
+function RawUtf8FromFile(const FileName: TFileName): RawUtf8;
+begin
+  result := AnyTextFileToRawUtf8(FileName, {AssumeUtf8IfNoBom=}true);
+end;
+
+function AnyTextFileToRawUtf8(const FileName: TFileName; AssumeUtf8IfNoBom: boolean): RawUtf8;
+var
+  tmp: RawByteString;
+  buf: pointer;
+  len: PtrInt;
+begin
+  case StringFromBomFile(FileName, tmp, buf, len) of
+    bomNone:
+      if AssumeUtf8IfNoBom then
+        FastAssignUtf8(result, tmp)
+      else
+        CurrentAnsiConvert.AnsiBufferToRawUtf8(buf, len, result);
+    bomUnicode:
+      RawUnicodeToUtf8(PWideChar(buf), len shr 1, result);
+    bomUtf8:
+      if len = 0 then
+        result := ''
+      else
+      begin
+        MoveFast(buf^, pointer(tmp)^, len); // fast in-place delete(bom)
+        FakeLength(tmp, len);
+        FastAssignUtf8(result, tmp)
+      end;
+  end;
+end;
+
+function AnyTextFileToSynUnicode(const FileName: TFileName; ForceUtf8: boolean): SynUnicode;
+var
+  tmp: RawByteString;
+  buf: pointer;
+  len: PtrInt;
+begin
+  if ForceUtf8 then
+    Utf8ToSynUnicode(StringFromFile(FileName), result)
+  else
+    case StringFromBomFile(FileName, tmp, buf, len) of
+      bomNone:
+        result := CurrentAnsiConvert.AnsiToUnicodeString(buf, len);
+      bomUnicode:
+        SetString(result, PWideChar(buf), len shr 1);
+      bomUtf8:
+        Utf8ToSynUnicode(buf, len, result);
+    end;
+end;
+
+function AnyTextFileToString(const FileName: TFileName; ForceUtf8: boolean): string;
+var
+  tmp: RawByteString;
+  buf: pointer;
+  len: PtrInt;
+begin
+
+  {$ifdef UNICODE}
+  if ForceUtf8 then
+    Utf8ToStringVar(StringFromFile(FileName), result)
+  else
+    case StringFromBomFile(FileName, tmp, buf, len) of
+      bomNone:
+        result := CurrentAnsiConvert.AnsiToUnicodeString(buf, len);
+      bomUnicode:
+        SetString(result, PWideChar(buf), len shr 1);
+      bomUtf8:
+        Utf8DecodeToString(buf, len, result);
+    end;
+  {$else}
+  if ForceUtf8 then
+    result := CurrentAnsiConvert.Utf8ToAnsi(StringFromFile(FileName))
+  else
+    case StringFromBomFile(FileName, tmp, buf, len) of
+      bomNone:
+        SetString(result, PAnsiChar(buf), len);
+      bomUnicode:
+        result := CurrentAnsiConvert.UnicodeBufferToAnsi(buf, len shr 1);
+      bomUtf8:
+        result := CurrentAnsiConvert.Utf8BufferToAnsi(buf, len);
+    end;
+  {$endif UNICODE}
+end;
+
+
+{ *************** Low-Level String Conversion Functions }
+
+procedure AnyAnsiToUtf8(const s: RawByteString; var result: RawUtf8);
+{$ifdef HASCODEPAGE}
+var
+  cp: cardinal;
+{$endif HASCODEPAGE}
+begin
+  if s = '' then
+    result := ''
+  else
+  {$ifdef HASCODEPAGE}
+  begin
+    cp := GetCodePage(s);
+    if cp = CP_ACP then
+    begin
+      cp := Unicode_CodePage;
+      {$ifdef FPC}
+      if cp = CP_UTF8 then // happens on POSIX and with Lazarus - so FPC only
+      begin
+        if PStrRec(PAnsiChar(pointer(s)) - _STRRECSIZE)^.refCnt >= 0 then
+        begin
+          result := s; // not a read-only constant: assign by ref
+          FakeCodePage(RawByteString(result), cp); // override 0 by CP_UTF8
+        end
+        else
+          FastSetString(result, pointer(s), length(s)); // realloc constant
+        exit;
+      end;
+      {$endif FPC}
+    end;
+    if cp = CP_UTF8 then
+      result := s
+    else if cp >= CP_RAWBLOB then
+      FastSetString(result, pointer(s), length(s)) // no convert, just copy
+    else
+      TSynAnsiConvert.Engine(cp).AnsiBufferToRawUtf8(pointer(s), length(s), result);
+  end;
+  {$else}
+  CurrentAnsiConvert.AnsiBufferToRawUtf8(pointer(s), length(s), result);
+  {$endif HASCODEPAGE}
+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
+  WinAnsiConvert.AnsiBufferToRawUtf8(@source[1], ord(source[0]), result);
+end;
+
+procedure WinAnsiToUnicodeBuffer(const S: WinAnsiString; Dest: PWordArray; DestLen: PtrInt);
+var
+  L: PtrInt;
+begin
+  L := length(S);
+  if L <> 0 then
+  begin
+    if L >= DestLen then
+      L := DestLen - 1; // truncate to avoid buffer overflow
+    WinAnsiConvert.AnsiBufferToUnicode(PWideChar(Dest), pointer(S), L);
+    // including last #0
+  end
+  else
+    Dest^[0] := 0;
+end;
+
+{$ifndef PUREMORMOT2}
+function WinAnsiToRawUnicode(const S: WinAnsiString): RawUnicode;
+begin
+  result := WinAnsiConvert.AnsiToRawUnicode(S);
+end;
+{$endif PUREMORMOT2}
+
+function WinAnsiToUtf8(const S: WinAnsiString): RawUtf8;
+begin
+  WinAnsiConvert.AnsiBufferToRawUtf8(pointer(S), length(S), result);
+end;
+
+function WinAnsiToUtf8(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): RawUtf8;
+begin
+  WinAnsiConvert.AnsiBufferToRawUtf8(WinAnsi, WinAnsiLen, result);
+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 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 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;
+
+{$ifndef PUREMORMOT2}
+
+function Utf8DecodeToRawUnicode(P: PUtf8Char; L: integer): RawUnicode;
+var
+  tmp: TSynTempBuffer;
+begin
+  result := ''; // somewhat faster if result is freed before any SetLength()
+  if L = 0 then
+    L := StrLen(P);
+  if L = 0 then
+    exit;
+  // +1 below is for #0 ending -> true WideChar(#0) ending
+  tmp.Init(L * 3); // maximum posible unicode size (if all <#128)
+  SetString(result, PAnsiChar(tmp.buf), Utf8ToWideChar(tmp.buf, P, L) + 1);
+  tmp.Done;
+end;
+
+function Utf8DecodeToRawUnicode(const S: RawUtf8): RawUnicode;
+begin
+  if S = '' then
+    result := ''
+  else
+    result := Utf8DecodeToRawUnicode(pointer(S), Length(S));
+end;
+
+function Utf8DecodeToRawUnicodeUI(const S: RawUtf8; DestLen: PInteger): RawUnicode;
+var
+  L: integer;
+begin
+  L := Utf8DecodeToRawUnicodeUI(S, result);
+  if DestLen <> nil then
+    DestLen^ := L;
+end;
+
+function Utf8DecodeToRawUnicodeUI(const S: RawUtf8; var Dest: RawUnicode): integer;
+begin
+  Dest := ''; // somewhat faster if Dest is freed before any SetLength()
+  if S = '' then
+  begin
+    result := 0;
+    exit;
+  end;
+  result := Length(S);
+  SetLength(Dest, result * 2 + 2);
+  result := Utf8ToWideChar(pointer(Dest), Pointer(S), result);
+end;
+
+function RawUnicodeToUtf8(const Unicode: RawUnicode): RawUtf8;
+begin
+  RawUnicodeToUtf8(pointer(Unicode), Length(Unicode) shr 1, result);
+end;
+
+function RawUnicodeToSynUnicode(const Unicode: RawUnicode): SynUnicode;
+begin
+  SetString(result, PWideChar(pointer(Unicode)), Length(Unicode) shr 1);
+end;
+
+function RawUnicodeToWinAnsi(const Unicode: RawUnicode): WinAnsiString;
+begin
+  result := WinAnsiConvert.UnicodeBufferToAnsi(pointer(Unicode), Length(Unicode) shr 1);
+end;
+
+{$endif PUREMORMOT2}
+
+function SynUnicodeToUtf8(const Unicode: SynUnicode): RawUtf8;
+begin
+  RawUnicodeToUtf8(pointer(Unicode), Length(Unicode), result);
+end;
+
+function RawUnicodeToSynUnicode(WideChar: PWideChar; WideCharCount: integer): SynUnicode;
+begin
+  SetString(result, WideChar, WideCharCount);
+end;
+
+procedure RawUnicodeToWinPChar(dest: PAnsiChar; source: PWideChar; WideCharCount: integer);
+begin
+  WinAnsiConvert.UnicodeBufferToAnsi(dest, source, WideCharCount);
+end;
+
+function RawUnicodeToWinAnsi(WideChar: PWideChar; WideCharCount: integer): WinAnsiString;
+begin
+  result := WinAnsiConvert.UnicodeBufferToAnsi(WideChar, WideCharCount);
+end;
+
+function WideStringToWinAnsi(const Wide: WideString): WinAnsiString;
+begin
+  result := WinAnsiConvert.UnicodeBufferToAnsi(pointer(Wide), Length(Wide));
+end;
+
+procedure UnicodeBufferToWinAnsi(source: PWideChar; out Dest: WinAnsiString);
+var
+  L: integer;
+begin
+  L := StrLenW(source);
+  SetLength(Dest, L);
+  WinAnsiConvert.UnicodeBufferToAnsi(pointer(Dest), source, L);
+end;
+
+function UnicodeBufferToString(source: PWideChar): string;
+begin
+  result := RawUnicodeToString(source, StrLenW(source));
+end;
+
+function UnicodeBufferToUtf8(source: PWideChar): RawUtf8;
+begin
+  RawUnicodeToUtf8(source, StrLenW(source), result);
+end;
+
+function UnicodeBufferToVariant(source: PWideChar): variant;
+begin
+  ClearVariantForString(result);
+  if Source <> nil then
+    RawUnicodeToUtf8(source, StrLenW(source), RawUtf8(TVarData(result).VAny));
+end;
+
+function StringToVariant(const Txt: string): variant;
+begin
+  StringToVariant(Txt, result);
+end;
+
+procedure StringToVariant(const Txt: string; var result: variant);
+begin
+  ClearVariantForString(result);
+  if Txt <> '' then
+    {$ifndef UNICODE}
+    if (Unicode_CodePage = CP_UTF8) or
+       IsAnsiCompatible(Txt) then
+    begin
+      RawByteString(TVarData(result).VAny) := Txt;
+      EnsureRawUtf8(RawByteString(TVarData(result).VAny));
+    end
+    else
+    {$endif UNICODE}
+      StringToUtf8(Txt, RawUtf8(TVarData(result).VAny));
+end;
+
+procedure AnsiCharToUtf8(P: PAnsiChar; L: integer; var result: RawUtf8;
+  CodePage: integer);
+begin
+  TSynAnsiConvert.Engine(CodePage).AnsiBufferToRawUtf8(P, L, result);
+end;
+
+function AnsiToUtf8(const Ansi: RawByteString; CodePage: integer): RawUtf8;
+begin
+  if Ansi = '' then
+    result := ''
+  else
+    result := TSynAnsiConvert.Engine(CodePage).AnsiToUtf8(Ansi);
+end;
+
+function AnsiToString(const Ansi: RawByteString; CodePage: integer): string;
+begin
+  if Ansi = '' then
+    result := ''
+  else
+    {$ifdef UNICODE}
+    result := TSynAnsiConvert.Engine(CodePage).AnsiToUnicodeString(Ansi);
+    {$else}
+    result := CurrentAnsiConvert.AnsiToAnsi(TSynAnsiConvert.Engine(CodePage), Ansi);
+    {$endif UNICODE}
+end;
+
+function AnsiBufferToTempUtf8(var Temp: TSynTempBuffer; Buf: PAnsiChar; BufLen,
+  CodePage: cardinal): PUtf8Char;
+begin
+  if (BufLen = 0) or
+     (CodePage = CP_UTF8) or
+     (CodePage >= CP_RAWBLOB) or
+     IsAnsiCompatible(Buf, BufLen) then
+  begin
+    temp.Buf := nil;
+    temp.len := BufLen;
+    result := PUtf8Char(Buf);
+  end
+  else
+  begin
+    temp.Init(BufLen * 3);
+    Buf := pointer(TSynAnsiConvert.Engine(CodePage).
+      AnsiBufferToUtf8(temp.Buf, Buf, BufLen));
+    temp.len := Buf - PAnsiChar(temp.Buf);
+    result := temp.Buf;
+  end;
+end;
+
+{$ifdef UNICODE}
+
+function Ansi7ToString(const Text: RawByteString): string;
+var
+  i: PtrInt;
+begin
+  SetString(result, nil, Length(Text));
+  for i := 0 to Length(Text) - 1 do
+    PWordArray(result)[i] := PByteArray(Text)[i]; // no conversion for 7-bit Ansi
+end;
+
+function Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt): string;
+begin
+  Ansi7ToString(Text, Len, result);
+end;
+
+procedure Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt; var result: string);
+var
+  i: PtrInt;
+begin
+  SetString(result, nil, Len);
+  for i := 0 to Len - 1 do
+    PWordArray(result)[i] := PByteArray(Text)[i]; // no conversion for 7-bit Ansi
+end;
+
+function StringToAnsi7(const Text: string): RawByteString;
+var
+  i: PtrInt;
+begin
+  SetString(result, nil, Length(Text));
+  for i := 0 to Length(Text) - 1 do
+    PByteArray(result)[i] := PWordArray(Text)[i]; // no conversion for 7-bit Ansi
+end;
+
+function StringToWinAnsi(const Text: string): WinAnsiString;
+begin
+  result := RawUnicodeToWinAnsi(Pointer(Text), Length(Text));
+end;
+
+function StringBufferToUtf8(Dest: PUtf8Char; Source: PChar; SourceChars: PtrInt): PUtf8Char;
+begin
+  result := Dest + RawUnicodeToUtf8(Dest, SourceChars * 3, PWideChar(Source), SourceChars, []);
+end;
+
+procedure StringBufferToUtf8(Source: PChar; out result: RawUtf8);
+begin
+  RawUnicodeToUtf8(Source, StrLenW(Source), result);
+end;
+
+function StringToUtf8(const Text: string): RawUtf8;
+begin
+  RawUnicodeToUtf8(pointer(Text), Length(Text), result);
+end;
+
+procedure StringToUtf8(Text: PChar; TextLen: PtrInt; var result: RawUtf8);
+begin
+  RawUnicodeToUtf8(Text, TextLen, result);
+end;
+
+procedure StringToUtf8(const Text: string; var result: RawUtf8);
+begin
+  RawUnicodeToUtf8(pointer(Text), Length(Text), result);
+end;
+
+function StringToUtf8(const Text: string; var Temp: TSynTempBuffer): integer;
+var
+  len: integer;
+begin
+  len := length(Text);
+  Temp.Init(len * 3);
+  result := RawUnicodeToUtf8(Temp.buf, Temp.len + 1, pointer(Text), len, []);
+end;
+
+function ToUtf8(const Text: string): RawUtf8;
+begin
+  RawUnicodeToUtf8(pointer(Text), Length(Text), result);
+end;
+
+{$ifndef PUREMORMOT2}
+
+function StringToRawUnicode(const S: string): RawUnicode;
+begin
+  SetString(result, PAnsiChar(pointer(S)), length(S) * 2 + 1); // +1 for last wide #0
+end;
+
+function StringToRawUnicode(P: PChar; L: integer): RawUnicode;
+begin
+  SetString(result, PAnsiChar(P), L * 2 + 1); // +1 for last wide #0
+end;
+
+function RawUnicodeToString(const U: RawUnicode): string;
+begin
+  // uses StrLenW() and not length(U) to handle case when was used as buffer
+  SetString(result, PWideChar(pointer(U)), StrLenW(Pointer(U)));
+end;
+
+{$endif PUREMORMOT2}
+
+function StringToSynUnicode(const S: string): SynUnicode;
+begin
+  result := S;
+end;
+
+procedure StringToSynUnicode(const S: string; var result: SynUnicode);
+begin
+  result := S;
+end;
+
+function RawUnicodeToString(P: PWideChar; L: integer): string;
+begin
+  SetString(result, P, L);
+end;
+
+procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string);
+begin
+  SetString(result, P, L);
+end;
+
+function SynUnicodeToString(const U: SynUnicode): string;
+begin
+  result := U;
+end;
+
+function Utf8DecodeToString(P: PUtf8Char; L: integer): string;
+begin
+  Utf8DecodeToUnicodeString(P, L, result);
+end;
+
+procedure Utf8DecodeToString(P: PUtf8Char; L: integer; var result: string);
+begin
+  Utf8DecodeToUnicodeString(P, L, result);
+end;
+
+function Utf8ToString(const Text: RawUtf8): string;
+begin
+  Utf8DecodeToUnicodeString(pointer(Text), length(Text), result);
+end;
+
+procedure Utf8ToStringVar(const Text: RawUtf8; var result: string);
+begin
+  Utf8DecodeToUnicodeString(pointer(Text), length(Text), result);
+end;
+
+procedure Utf8ToFileName(const Text: RawUtf8; var result: TFileName);
+begin
+  Utf8DecodeToUnicodeString(pointer(Text), length(Text), string(result));
+end;
+
+{$else}
+
+function Ansi7ToString(const Text: RawByteString): string;
+begin
+  result := Text; // if we are SURE this text is 7-bit Ansi -> direct assign
+  {$ifdef FPC} // if Text is CP_RAWBYTESTRING then FPC won't handle it properly
+  SetCodePage(RawByteString(result), DefaultSystemCodePage, false);
+  {$endif FPC} // no FakeCodePage() since Text may be read-only
+end;
+
+function Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt): string;
+begin
+  SetString(result, PAnsiChar(Text), Len);
+end;
+
+procedure Ansi7ToString(Text: PWinAnsiChar; Len: PtrInt; var result: string);
+begin
+  SetString(result, PAnsiChar(Text), Len);
+end;
+
+function StringToAnsi7(const Text: string): RawByteString;
+begin
+  result := Text; // if we are SURE this text is 7-bit Ansi -> direct assign
+end;
+
+function StringToWinAnsi(const Text: string): WinAnsiString;
+begin
+  result := WinAnsiConvert.AnsiToAnsi(CurrentAnsiConvert, Text);
+end;
+
+function StringBufferToUtf8(Dest: PUtf8Char; Source: PChar; SourceChars: PtrInt): PUtf8Char;
+begin
+  result := CurrentAnsiConvert.AnsiBufferToUtf8(Dest, Source, SourceChars);
+end;
+
+procedure StringBufferToUtf8(Source: PChar; out result: RawUtf8);
+begin
+  CurrentAnsiConvert.AnsiBufferToRawUtf8(Source, StrLen(Source), result);
+end;
+
+function StringToUtf8(const Text: string): RawUtf8;
+begin
+  result := CurrentAnsiConvert.AnsiToUtf8(Text);
+end;
+
+procedure StringToUtf8(Text: PChar; TextLen: PtrInt; var result: RawUtf8);
+begin
+  CurrentAnsiConvert.AnsiBufferToRawUtf8(Text, TextLen, result);
+end;
+
+procedure StringToUtf8(const Text: string; var result: RawUtf8);
+begin
+  result := CurrentAnsiConvert.AnsiToUtf8(Text);
+end;
+
+function StringToUtf8(const Text: string; var Temp: TSynTempBuffer): integer;
+var
+  len: integer;
+begin
+  len := length(Text);
+  Temp.Init(len * 3);
+  if len <> 0 then
+    result := CurrentAnsiConvert.
+      AnsiBufferToUtf8(Temp.buf, pointer(Text), len) - PUtf8Char(Temp.buf)
+  else
+    result := 0;
+end;
+
+function ToUtf8(const Text: string): RawUtf8;
+begin
+  result := CurrentAnsiConvert.AnsiToUtf8(Text);
+end;
+
+{$ifndef PUREMORMOT2}
+
+function StringToRawUnicode(const S: string): RawUnicode;
+begin
+  result := CurrentAnsiConvert.AnsiToRawUnicode(S);
+end;
+
+function StringToRawUnicode(P: PChar; L: integer): RawUnicode;
+begin
+  result := CurrentAnsiConvert.AnsiToRawUnicode(P, L);
+end;
+
+function RawUnicodeToString(const U: RawUnicode): string;
+begin
+  // uses StrLenW() and not length(U) to handle case when was used as buffer
+  result := CurrentAnsiConvert.UnicodeBufferToAnsi(Pointer(U), StrLenW(Pointer(U)));
+end;
+
+{$endif PUREMORMOT2}
+
+function StringToSynUnicode(const S: string): SynUnicode;
+begin
+  result := CurrentAnsiConvert.AnsiToUnicodeString(pointer(S), length(S));
+end;
+
+procedure StringToSynUnicode(const S: string; var result: SynUnicode);
+begin
+  result := CurrentAnsiConvert.AnsiToUnicodeString(pointer(S), length(S));
+end;
+
+function RawUnicodeToString(P: PWideChar; L: integer): string;
+begin
+  result := CurrentAnsiConvert.UnicodeBufferToAnsi(P, L);
+end;
+
+procedure RawUnicodeToString(P: PWideChar; L: integer; var result: string);
+begin
+  result := CurrentAnsiConvert.UnicodeBufferToAnsi(P, L);
+end;
+
+function SynUnicodeToString(const U: SynUnicode): string;
+begin
+  result := CurrentAnsiConvert.UnicodeBufferToAnsi(Pointer(U), length(U));
+end;
+
+function Utf8DecodeToString(P: PUtf8Char; L: integer): string;
+begin
+  CurrentAnsiConvert.Utf8BufferToAnsi(P, L, RawByteString(result));
+end;
+
+procedure Utf8DecodeToString(P: PUtf8Char; L: integer; var result: string);
+begin
+  CurrentAnsiConvert.Utf8BufferToAnsi(P, L, RawByteString(result));
+end;
+
+function Utf8ToString(const Text: RawUtf8): string;
+begin
+  result := CurrentAnsiConvert.Utf8ToAnsi(Text);
+end;
+
+procedure Utf8ToStringVar(const Text: RawUtf8; var result: string);
+begin
+  result := CurrentAnsiConvert.Utf8ToAnsi(Text);
+end;
+
+procedure Utf8ToFileName(const Text: RawUtf8; var result: TFileName);
+begin
+  result := CurrentAnsiConvert.Utf8ToAnsi(Text);
+end;
+
+{$endif UNICODE}
+
+function ToUtf8(const Ansi7Text: ShortString): RawUtf8;
+begin
+  FastSetString(result, @Ansi7Text[1], ord(Ansi7Text[0]));
+end;
+
+{$ifdef HASVARUSTRING} // some UnicodeString dedicated functions
+
+function UnicodeStringToUtf8(const S: UnicodeString): RawUtf8;
+begin
+  RawUnicodeToUtf8(pointer(S), Length(S), result);
+end;
+
+function Utf8DecodeToUnicodeString(const S: RawUtf8): UnicodeString;
+begin
+  Utf8DecodeToUnicodeString(pointer(S), Length(S), result);
+end;
+
+procedure Utf8DecodeToUnicodeString(P: PUtf8Char; L: integer; var result: UnicodeString);
+var
+  tmp: TSynTempBuffer;
+begin
+  if (P = nil) or
+     (L = 0) then
+    result := ''
+  else
+  begin
+    tmp.Init(L * 3); // maximum posible unicode size (if all <#128)
+    SetString(result, PWideChar(tmp.buf), Utf8ToWideChar(tmp.buf, P, L) shr 1);
+    tmp.Done;
+  end;
+end;
+
+function UnicodeStringToWinAnsi(const S: UnicodeString): WinAnsiString;
+begin
+  result := WinAnsiConvert.UnicodeBufferToAnsi(pointer(S), Length(S));
+end;
+
+function Utf8DecodeToUnicodeString(P: PUtf8Char; L: integer): UnicodeString;
+begin
+  Utf8DecodeToUnicodeString(P, L, result);
+end;
+
+function WinAnsiToUnicodeString(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): UnicodeString;
+begin
+  SetString(result, nil, WinAnsiLen);
+  WinAnsiConvert.AnsiBufferToUnicode(pointer(result), WinAnsi, WinAnsiLen);
+end;
+
+function WinAnsiToUnicodeString(const WinAnsi: WinAnsiString): UnicodeString;
+begin
+  result := WinAnsiToUnicodeString(pointer(WinAnsi), Length(WinAnsi));
+end;
+
+{$endif HASVARUSTRING}
+
+function Utf8DecodeToUnicodeRawByteString(P: PUtf8Char; L: integer): RawByteString;
+begin
+  if (P <> nil) and
+     (L <> 0) then
+  begin
+    FastNewRawByteString(result, L * 3);
+    FakeSetLength(result, Utf8ToWideChar(pointer(result), P, L));
+  end
+  else
+    result := '';
+end;
+
+function Utf8DecodeToUnicodeRawByteString(const U: RawUtf8): RawByteString;
+begin
+  result := Utf8DecodeToUnicodeRawByteString(pointer(U), length(U));
+end;
+
+function Utf8DecodeToUnicodeStream(P: PUtf8Char; L: integer): TStream;
+begin
+  result := TRawByteStringStream.Create(Utf8DecodeToUnicodeRawByteString(P, L));
+end;
+
+function WinAnsiToSynUnicode(WinAnsi: PAnsiChar; WinAnsiLen: PtrInt): SynUnicode;
+begin
+  SetString(result, nil, WinAnsiLen);
+  WinAnsiConvert.AnsiBufferToUnicode(pointer(result), WinAnsi, WinAnsiLen);
+end;
+
+function WinAnsiToSynUnicode(const WinAnsi: WinAnsiString): SynUnicode;
+begin
+  result := WinAnsiToSynUnicode(pointer(WinAnsi), Length(WinAnsi));
+end;
+
+procedure UniqueRawUtf8ZeroToTilde(var u: RawUtf8; MaxSize: PtrInt);
+var
+  i: PtrInt;
+begin
+  i := length(u);
+  if i > MaxSize then
+    PByteArray(u)[MaxSize] := 0
+  else
+    MaxSize := i;
+  for i := 0 to MaxSize - 1 do
+    if PByteArray(u)[i] = 0 then
+      PByteArray(u)[i] := ord('~');
+end;
+
+const
+  ZEROED_CW = '~'; // any byte would do - followed by ~ or 0
+
+function UnZeroed(const bin: RawByteString): RawUtf8;
+var
+  len, z, c: PtrInt;
+  a: AnsiChar;
+  s, d: PAnsiChar;
+begin
+  result := '';
+  len := length(bin);
+  if len = 0 then
+    exit;
+  s := pointer(bin);
+  z := StrLen(s);
+  c := ByteScanIndex(pointer(s), len, ord(ZEROED_CW));
+  if (z = len) and
+     (c < 0) then
+  begin
+    result := bin; // nothing to convert
+    exit;
+  end;
+  if (c < 0) or
+     (z < c) then
+    c := z;
+  FastSetString(result, len shl 1);
+  d := pointer(result);
+  MoveFast(s^, d^, c);
+  inc(s, c);
+  inc(d, c);
+  dec(len, c);
+  repeat
+    a := s^;
+    if a = #0 then
+    begin
+      d^ := ZEROED_CW;
+      inc(d);
+      a := '0';
+    end
+    else if a = ZEROED_CW then
+    begin
+      d^ := ZEROED_CW;
+      inc(d);
+    end;
+    d^ := a;
+    inc(d);
+    inc(s);
+    dec(len);
+  until len = 0;
+  FakeLength(result, d - pointer(result));
+end;
+
+function Zeroed(const u: RawUtf8): RawByteString;
+var
+  len, c: PtrInt;
+  a: AnsiChar;
+  s, d: PAnsiChar;
+begin
+  result := '';
+  len := length(u);
+  if len = 0 then
+    exit;
+  s := pointer(u);
+  c := ByteScanIndex(pointer(s), len, ord(ZEROED_CW));
+  if c < 0 then
+  begin
+    result := u;
+    exit;
+  end;
+  FastNewRawByteString(result, len);
+  d := pointer(result);
+  MoveFast(s^, d^, c);
+  inc(s, c);
+  inc(d, c);
+  dec(len, c);
+  repeat
+    a := s^;
+    if a = ZEROED_CW then
+    begin
+      inc(s);
+      dec(len);
+      if s^ = '0' then
+        a := #0;
+    end;
+    d^ := a;
+    inc(d);
+    inc(s);
+    dec(len);
+  until len = 0;
+  FakeLength(result, d - pointer(result));
+end;
+
+procedure Utf8ToWideString(const Text: RawUtf8; var result: WideString);
+begin
+  Utf8ToWideString(pointer(Text), Length(Text), result);
+end;
+
+function Utf8ToWideString(const Text: RawUtf8): WideString;
+begin
+  {$ifdef FPC}
+  Finalize(result);
+  {$endif FPC}
+  Utf8ToWideString(pointer(Text), Length(Text), result);
+end;
+
+procedure Utf8ToWideString(Text: PUtf8Char; Len: PtrInt; var result: WideString);
+var
+  tmp: TSynTempBuffer;
+begin
+  if (Text = nil) or
+     (Len = 0) then
+    result := ''
+  else
+  begin
+    tmp.Init(Len * 3); // maximum posible unicode size (if all <#128)
+    SetString(result, PWideChar(tmp.buf), Utf8ToWideChar(tmp.buf, Text, Len) shr 1);
+    tmp.Done;
+  end;
+end;
+
+function WideStringToUtf8(const aText: WideString): RawUtf8;
+begin
+  RawUnicodeToUtf8(pointer(aText), length(aText), result);
+end;
+
+function Utf8ToSynUnicode(const Text: RawUtf8): SynUnicode;
+begin
+  Utf8ToSynUnicode(pointer(Text), length(Text), result);
+end;
+
+procedure Utf8ToSynUnicode(const Text: RawUtf8; var result: SynUnicode);
+begin
+  Utf8ToSynUnicode(pointer(Text), length(Text), result);
+end;
+
+procedure Utf8ToSynUnicode(Text: PUtf8Char; Len: PtrInt; var result: SynUnicode);
+var
+  tmp: TSynTempBuffer;
+  n: PtrInt;
+begin
+  n := Utf8DecodeToUnicode(Text, Len, tmp);
+  SetString(result, PWideChar(tmp.buf), n);
+  if n <> 0 then
+    tmp.Done;
+end;
+
+function Utf8DecodeToUnicode(const Text: RawUtf8; var temp: TSynTempBuffer): PtrInt;
+begin
+  result := Utf8DecodeToUnicode(pointer(Text), length(Text), temp);
+end;
+
+function Utf8DecodeToUnicode(Text: PUtf8Char; Len: PtrInt; var temp: TSynTempBuffer): PtrInt;
+begin
+  if (Text = nil) or
+     (Len <= 0) then
+  begin
+    temp.buf := nil;
+    temp.len := 0;
+    result := 0;
+  end
+  else
+  begin
+    temp.Init(Len * 3); // maximum posible unicode size (if all <#128)
+    result := Utf8ToWideChar(temp.buf, Text, Len) shr 1;
+  end;
+end;
+
+
+{ **************** Text Case-(in)sensitive Conversion and Comparison }
+
+function IdemPropNameUSameLenNotNull(P1, P2: PUtf8Char; P1P2Len: PtrInt): boolean;
+label
+  zero;
+begin
+  {$ifndef CPUX86}
+  result := false;
+  {$endif CPUX86}
+  pointer(P1P2Len) := @P1[P1P2Len - SizeOf(cardinal)];
+  dec(PtrUInt(P2), PtrUInt(P1));
+  while PtrUInt(P1P2Len) >= PtrUInt(P1) do
+    // compare 4 Bytes per loop
+    if (PCardinal(P1)^ xor PCardinal(@P2[PtrUInt(P1)])^) and $dfdfdfdf <> 0 then
+      goto zero
+    else
+      inc(PCardinal(P1));
+  inc(P1P2Len, SizeOf(cardinal));
+  while PtrUInt(P1) < PtrUInt(P1P2Len) do
+    if (ord(P1^) xor ord(P2[PtrUInt(P1)])) and $df <> 0 then
+      goto zero
+    else
+      inc(PByte(P1));
+  result := true;
+  exit;
+zero:
+  {$ifdef CPUX86}
+  result := false;
+  {$endif CPUX86}
+end;
+
+function PropNameValid(P: PUtf8Char): boolean;
+var
+  tab: PTextCharSet;
+{%H-}begin
+  tab := @TEXT_CHARS;
+  if (P <> nil) and
+     (tcIdentifierFirstChar in tab[P^]) then
+    // first char must be in ['_', 'a'..'z', 'A'..'Z']
+    repeat
+      inc(P); // following chars can be ['_', '0'..'9', 'a'..'z', 'A'..'Z']
+      if tcIdentifier in tab[P^] then
+        continue;
+      result := P^ = #0;
+      exit;
+    until false
+  else
+    result := false;
+end;
+
+function PropNamesValid(const Values: array of RawUtf8): boolean;
+var
+  i, j: PtrInt;
+  tab: PTextCharSet;
+begin
+  result := false;
+  tab := @TEXT_CHARS;
+  for i := 0 to high(Values) do
+    for j := 1 to length(Values[i]) do
+      if not (tcIdentifier in tab[Values[i][j]]) then
+        exit; // not ['_', '0'..'9', 'a'..'z', 'A'..'Z']
+  result := true;
+end;
+
+function PropNameSanitize(const text, fallback: RawUtf8): RawUtf8;
+var
+  i: PtrInt;
+begin
+  result := text;
+  for i := length(result) downto 1 do
+    if result[i] in [#0 .. ' ', '#', '"', '''', '*'] then
+      delete(result, i, 1);
+  for i := 1 to length(result) do
+    if result[i] in ['[', ']', '/', '\', '&', '@', '+', '-', '.'] then
+      result[i] := '_';
+  if not PropNameValid(pointer(result)) then
+    result := fallback; // it was not good enough
+end;
+
+function IdemPropName(const P1, P2: ShortString): boolean;
+begin
+  result := (P1[0] = P2[0]) and
+            ((P1[0] = #0) or
+             (((ord(P1[1]) xor ord(P2[1])) and $df = 0) and
+              IdemPropNameUSameLenNotNull(@P1[1], @P2[1], ord(P2[0]))));
+end;
+
+function IdemPropName(const P1: ShortString; P2: PUtf8Char; P2Len: PtrInt): boolean;
+begin
+  result := (ord(P1[0]) = P2Len) and
+            ((P2Len = 0) or
+             IdemPropNameUSameLenNotNull(@P1[1], P2, P2Len));
+end;
+
+function IdemPropName(P1, P2: PUtf8Char; P1Len, P2Len: PtrInt): boolean;
+begin
+  result := (P1Len = P2Len) and
+            ((P1Len = 0) or
+             IdemPropNameUSameLenNotNull(P1, P2, P1Len));
+end;
+
+function IdemPropNameU(const P1: RawUtf8; P2: PUtf8Char; P2Len: PtrInt): boolean;
+begin
+  if PtrUInt(P1) <> 0 then
+    result := (PStrLen(PAnsiChar(pointer(P1)) - _STRLEN)^ = P2Len) and
+              ((PByte(P1)^ xor PByte(P2)^) and $df = 0) and
+              IdemPropNameUSameLenNotNull(pointer(P1), pointer(P2), P2Len)
+  else
+    result := P2Len = 0;
+end;
+
+function IdemPropNameU(const P1, P2: RawUtf8): boolean;
+var
+  L: TStrLen;
+begin
+  if PtrUInt(P1) <> PtrUInt(P2) then
+    if (PtrUInt(P1) <> 0) and
+       (PtrUInt(P2) <> 0) then
+    begin
+      L := PStrLen(PAnsiChar(pointer(P1)) - _STRLEN)^;
+      result := (PStrLen(PAnsiChar(pointer(P2)) - _STRLEN)^ = L) and
+                ((PByte(P1)^ xor PByte(P2)^) and $df = 0) and
+                IdemPropNameUSameLenNotNull(pointer(P1), pointer(P2), L);
+    end
+    else
+      result := false
+  else
+    result := true;
+end;
+
+function IdemPChar(p: PUtf8Char; up: PAnsiChar): boolean;
+var
+  {$ifdef CPUX86NOTPIC}
+  table: TNormTable absolute NormToUpperAnsi7;
+  {$else}
+  table: PNormTable; // faster on PIC/ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  result := false;
+  if p = nil then
+    exit;
+  if up <> nil then
+  begin
+    dec(PtrUInt(p), PtrUInt(up));
+    {$ifndef CPUX86NOTPIC}
+    table := @NormToUpperAnsi7;
+    {$endif CPUX86NOTPIC}
+    while true do
+      if up^ = #0 then
+        break
+      else if table[up[PtrUInt(p)]] <> up^ then
+        exit
+      else
+        inc(up);
+  end;
+  result := true;
+end;
+
+function IdemPChar(p: PUtf8Char; up: PAnsiChar; table: PNormTable): boolean;
+begin
+  result := false;
+  if p = nil then
+    exit;
+  if up <> nil then
+  begin
+    dec(PtrUInt(p), PtrUInt(up));
+    while true do
+      if up^ = #0 then
+        break
+      else if table[up[PtrUInt(p)]] <> up^ then
+        exit
+      else
+        inc(up);
+  end;
+  result := true;
+end;
+
+function IdemPCharAnsi(
+  {$ifdef CPUX86NOTPIC}
+  const table: TNormTable;
+  {$else}
+  const table: PNormTable;
+  {$endif CPUX86NOTPIC}
+  p: PUtf8Char; up: PAnsiChar): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+begin
+  // in this local IdemPChar() version, p and up are expected to be <> nil
+  result := false;
+  dec(PtrUInt(p), PtrUInt(up));
+  while true do
+    if up^ = #0 then
+      break
+    else if table[up[PtrUInt(p)]] <> up^ then
+      exit
+    else
+      inc(up);
+  result := true;
+end;
+
+function IdemPCharByte(
+  {$ifdef CPUX86NOTPIC}
+  const table: TNormTableByte;
+  {$else}
+  const table: PByteArray;
+  {$endif CPUX86NOTPIC}
+  p: PUtf8Char; up: PAnsiChar): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+begin
+  // in this local IdemPChar() version, p and up are expected to be <> nil
+  result := false;
+  dec(PtrUInt(p), PtrUInt(up));
+  while true do
+    if up^ = #0 then
+      break
+    else if table[PtrInt(up[PtrUInt(p)])] <> PByte(up)^ then
+      exit
+    else
+      inc(up);
+  result := true;
+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;
+  up: ^PAnsiChar;
+  {$ifdef CPUX86NOTPIC}
+  tab: TNormTableByte absolute NormToUpperAnsi7;
+  {$else}
+  tab: PByteArray; // faster on PIC/ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  if p <> nil then
+  begin
+    {$ifndef CPUX86NOTPIC}
+    tab := @NormToUpperAnsi7;
+    {$endif CPUX86NOTPIC}
+    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
+         IdemPCharByte(tab, p + 2, up^ + 2) then
+        exit
+      else
+        inc(up);
+  end;
+  result := -1;
+end;
+
+function IdemPPChar(p: PUtf8Char; up: PPAnsiChar): PtrInt;
+var
+  w: word;
+  u: PAnsiChar;
+  p2: PtrUInt;
+  c: byte;
+  {$ifdef CPUX86NOTPIC}
+  tab: TNormTableByte absolute NormToUpperAnsi7;
+  {$else}
+  tab: PByteArray; // faster on PIC/ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  if p <> nil then
+  begin
+    // uppercase the first two p^ chars
+    {$ifndef CPUX86NOTPIC}
+    tab := @NormToUpperAnsi7;
+    {$endif CPUX86NOTPIC}
+    w := tab[ord(p[0])] + tab[ord(p[1])] shl 8;
+    result := 0;
+    repeat
+      // quickly check the first 2 up^[result] chars
+      u := PPointerArray(up)[result];
+      if u = nil then
+        break
+      else if PWord(u)^ <> w then
+      begin
+        inc(result);
+        continue;
+      end;
+      // inlined if IdemPCharByte(tab, p + 2, up^ + 2) then exit
+      p2 := PtrUInt(p);
+      dec(p2, PtrUInt(u));
+      inc(u, 2);
+      repeat
+        c := PByte(u)^;
+        if c = 0 then
+          exit   // found IdemPChar(p^, up^[result])
+        else if tab[PtrUInt(u[p2])] <> c then
+          break; // at least one char doesn't match
+        inc(u);
+      until false;
+      inc(result);
+    until false;
+  end;
+  result := -1;
+end;
+
+function IdemPCharArrayBy2(p: PUtf8Char; const upArrayBy2Chars: RawUtf8): PtrInt;
+begin
+  if p <> nil then
+    result := WordScanIndex(pointer(upArrayBy2Chars), length(upArrayBy2Chars) shr 1,
+      NormToUpperAnsi7Byte[ord(p[0])] + NormToUpperAnsi7Byte[ord(p[1])] shl 8)
+  else
+    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 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;
+
+function StartWith(const text, upTextStart: RawUtf8): boolean;
+begin
+  result := (PtrUInt(text) <> 0) and
+            (PtrUInt(upTextStart) <> 0) and
+            (PStrLen(PAnsiChar(pointer(text)) - _STRLEN)^ >=
+              PStrLen(PAnsiChar(pointer(upTextStart)) - _STRLEN)^) and
+            IdemPChar(pointer(text), pointer(upTextStart));
+end;
+
+function EndWith(const text, upTextEnd: RawUtf8): boolean;
+var
+  o: PtrInt;
+begin
+  o := length(text) - length(upTextEnd);
+  result := (o >= 0) and
+            IdemPChar(PUtf8Char(pointer(text)) + o, pointer(upTextEnd));
+end;
+
+function EndWithArray(const text: RawUtf8; const upArray: array of RawUtf8): integer;
+var
+  t, o: PtrInt;
+  {$ifdef CPUX86NOTPIC}
+  tab: TNormTableByte absolute NormToUpperAnsi7;
+  {$else}
+  tab: PByteArray; // faster on PIC/ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  t := length(text);
+  if t > 0 then
+  begin
+    {$ifndef CPUX86NOTPIC}
+    tab := @NormToUpperAnsi7;
+    {$endif CPUX86NOTPIC}
+    for result := 0 to high(upArray) do
+    begin
+      o := t - length(upArray[result]);
+      if (o >= 0) and
+         ((upArray[result] = '') or
+          IdemPCharByte(tab, PUtf8Char(pointer(text)) + o,
+            pointer(upArray[result]))) then
+        exit;
+    end;
+  end;
+  result := -1;
+end;
+
+function IdemFileExt(p: PUtf8Char; extup: PAnsiChar; sepChar: AnsiChar): boolean;
+var
+  ext: PUtf8Char;
+begin
+  if (p <> nil) and
+     (extup <> nil) then
+  begin
+    ext := nil;
+    repeat
+      if p^ = sepChar then
+        ext := p; // get last '.' position from p into ext
+      inc(p);
+    until p^ = #0;
+    result := IdemPChar(ext, extup);
+  end
+  else
+    result := false;
+end;
+
+function IdemFileExts(p: PUtf8Char; const extup: array of PAnsiChar;
+  sepChar: AnsiChar): integer;
+var
+  ext: PUtf8Char;
+begin
+  result := -1;
+  if (p <> nil) and
+     (high(extup) > 0) then
+  begin
+    ext := nil;
+    repeat
+      if p^ = sepChar then
+        ext := p; // get last '.' position from p into ext
+      inc(p);
+    until p^ = #0;
+    if ext <> nil then
+      result := IdemPCharArray(ext, extup);
+  end;
+end;
+
+function 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;
+      result := Str;
+      s := Characters;
+      repeat
+        if s^ = c then
+          exit;
+        inc(s);
+      until s^ = #0;
+      inc(Str);
+    until false;
+  result := nil;
+end;
+
+function PosI(uppersubstr: PUtf8Char; const str: RawUtf8): PtrInt;
+var
+  u: AnsiChar;
+  {$ifdef CPUX86NOTPIC}
+  table: TNormTable absolute NormToUpperAnsi7;
+  {$else}
+  table: PNormTable;
+  {$endif CPUX86NOTPIC}
+begin
+  if uppersubstr <> nil then
+  begin
+    {$ifndef CPUX86NOTPIC}
+    table := @NormToUpperAnsi7;
+    {$endif CPUX86NOTPIC}
+    u := uppersubstr^;
+    for result := 1 to Length(str) do
+      if table[str[result]] = u then
+        if IdemPCharAnsi(table, @PUtf8Char(pointer(str))[result],
+             PAnsiChar(uppersubstr) + 1) then
+          exit;
+  end;
+  result := 0;
+end;
+
+function StrPosI(uppersubstr, str: PUtf8Char): PUtf8Char;
+var
+  u: AnsiChar;
+  {$ifdef CPUX86NOTPIC}
+  table: TNormTable absolute NormToUpperAnsi7;
+  {$else}
+  table: PNormTable;
+  {$endif CPUX86NOTPIC}
+begin
+  if (uppersubstr <> nil) and
+     (str <> nil) then
+  begin
+    {$ifndef CPUX86NOTPIC}
+    table := @NormToUpperAnsi7;
+    {$endif CPUX86NOTPIC}
+    u := uppersubstr^;
+    inc(uppersubstr);
+    result := str;
+    while result^ <> #0 do
+    begin
+      if table[result^] = u then
+        if IdemPCharAnsi(table, result + 1, PAnsiChar(uppersubstr)) then
+          exit;
+      inc(result);
+    end;
+  end;
+  result := nil;
+end;
+
+function PosIU(substr: PUtf8Char; const str: RawUtf8): integer;
+var
+  p: PUtf8Char;
+begin
+  if (substr <> nil) and
+     (str <> '') then
+  begin
+    p := pointer(str);
+    repeat
+      if GetNextUtf8Upper(p) = ord(substr^) then
+        if IdemPCharU(p, substr + 1) then
+        begin
+          result := p - pointer(str);
+          exit;
+        end;
+    until p^ = #0;
+  end;
+  result := 0;
+end;
+
+function strspn(s, accept: pointer): integer;
+// FPC is efficient at compiling this code, but is SLOWER when inlined
+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 strcspn(s, reject: pointer): integer;
+// FPC is efficient at compiling this code, but is SLOWER when inlined
+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;
+
+function StrCompL(P1, P2: pointer; L, Default: PtrInt): PtrInt;
+var
+  i: PtrInt;
+begin
+  i := 0;
+  repeat
+    result := PByteArray(P1)[i] - PByteArray(P2)[i];
+    if result = 0 then
+    begin
+      inc(i);
+      if i < L then
+        continue
+      else
+        break;
+    end;
+    exit;
+  until false;
+  result := Default;
+end;
+
+function StrCompIL(P1, P2: pointer; L, Default: PtrInt): PtrInt;
+var
+  i: PtrInt;
+  {$ifdef CPUX86NOTPIC}
+  tab: TNormTableByte absolute NormToUpperAnsi7Byte;
+  {$else}
+  tab: PByteArray; // faster on PIC/ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  i := 0;
+  {$ifndef CPUX86NOTPIC}
+  tab := @NormToUpperAnsi7Byte;
+  {$endif CPUX86NOTPIC}
+  repeat
+    if tab[PByteArray(P1)[i]] = tab[PByteArray(P2)[i]] then
+    begin
+      inc(i);
+      if i < L then
+        continue
+      else
+        break;
+    end;
+    result := PByteArray(P1)[i] - PByteArray(P2)[i];
+    exit;
+  until false;
+  result := Default;
+end;
+
+function StrICompNotNil(Str1, Str2: pointer; Up: PNormTableByte): PtrInt;
+var
+  C1, C2: byte; // integer/PtrInt are actually slower on FPC
+begin
+  result := PtrInt(PtrUInt(Str2)) - PtrInt(PtrUInt(Str1));
+  if result <> 0 then
+  begin
+    repeat
+      C1 := Up[PByteArray(Str1)[0]];
+      C2 := Up[PByteArray(Str1)[result]];
+      inc(PByte(Str1));
+    until (C1 = 0) or
+          (C1 <> C2);
+    result := C1 - C2;
+  end;
+end;
+
+function StrICompLNotNil(Str1, Str2: pointer; Up: PNormTableByte; L: PtrInt): PtrInt;
+begin
+  result := 0;
+  repeat
+    if Up[PByteArray(Str1)[result]] = Up[PByteArray(Str2)[result]] then
+    begin
+      inc(result);
+      if result < L then
+        continue
+      else
+        break;
+    end;
+    result := PByteArray(Str1)[result] - PByteArray(Str2)[result];
+    exit;
+  until false;
+  result := 0;
+end;
+
+function StrILNotNil(Str1, Str2: pointer; Up: PNormTableByte; L: PtrInt): PtrInt;
+begin
+  result := 0;
+  repeat
+    if Up[PByteArray(Str1)[result]] <> Up[PByteArray(Str2)[result]] then
+      exit;
+    inc(result);
+  until result = L;
+end;
+
+
+function StrIComp(Str1, Str2: pointer): PtrInt;
+var
+  C1, C2: byte; // integer/PtrInt are actually slower on FPC
+  {$ifdef CPUX86NOTPIC}
+  table: TNormTableByte absolute NormToUpperAnsi7Byte;
+  {$else}
+  table: PByteArray;
+  {$endif CPUX86NOTPIC}
+begin
+  result := PtrInt(PtrUInt(Str2)) - PtrInt(PtrUInt(Str1));
+  if result <> 0 then
+    if Str1 <> nil then
+      if Str2 <> nil then
+      begin
+        {$ifndef CPUX86NOTPIC}
+        table := @NormToUpperAnsi7Byte;
+        {$endif CPUX86NOTPIC}
+        repeat
+          C1 := table[PByteArray(Str1)[0]];
+          C2 := table[PByteArray(Str1)[result]];
+          inc(PByte(Str1));
+        until (C1 = 0) or
+              (C1 <> C2);
+        result := C1 - C2;
+      end
+      else
+        // Str2=''
+        result := 1
+    else
+      // Str1=''
+      result := -1;
+end;
+
+function GetLineContains(p, pEnd, up: PUtf8Char): boolean;
+var
+  i: PtrInt;
+  {$ifdef CPUX86NOTPIC}
+  table: TNormTable absolute NormToUpperAnsi7Byte;
+  {$else}
+  table: PNormTable;
+  {$endif CPUX86NOTPIC}
+label
+  Fnd1, LF1, Fnd2, LF2, Ok; // ugly but fast
+begin
+  if (p <> nil) and
+     (up <> nil) then
+  begin
+    {$ifndef CPUX86NOTPIC}
+    table := @NormToUpperAnsi7;
+    {$endif CPUX86NOTPIC}
+    if pEnd = nil then
+      repeat
+        if p^ <= #13 then // p^ into a temp var is slower
+          goto LF1
+        else if table[p^] = up^ then
+          goto Fnd1;
+        inc(p);
+        continue;
+LF1:    if (p^ = #0) or
+           (p^ = #13) or
+           (p^ = #10) then
+          break;
+        inc(p);
+        continue;
+Fnd1:   i := 0;
+        repeat
+          inc(i);
+          if up[i] <> #0 then
+            if up[i] = table[p[i]] then
+              continue
+            else
+              break
+          else
+          begin
+Ok:         result := true; // found
+            exit;
+          end;
+        until false;
+        inc(p);
+      until false
+    else
+      repeat
+        if p >= pEnd then
+          break;
+        if p^ <= #13 then
+          goto LF2
+        else if table[p^] = up^ then
+          goto Fnd2;
+        inc(p);
+        continue;
+LF2:    if (p^ = #13) or
+           (p^ = #10) then
+          break;
+        inc(p);
+        continue;
+Fnd2:   i := 0;
+        repeat
+          inc(i);
+          if up[i] = #0 then
+            goto Ok;
+          if p + i >= pEnd then
+            break;
+        until up[i] <> table[p[i]];
+        inc(p);
+      until false;
+  end;
+  result := false;
+end;
+
+function 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 GetNextUtf8Upper(var U: PUtf8Char): Ucs4CodePoint;
+begin
+  result := ord(U^);
+  if result = 0 then
+    exit;
+  if result <= 127 then
+  begin
+    inc(U);
+    result := NormToUpperByte[result];
+    exit;
+  end;
+  result := UTF8_TABLE.GetHighUtf8Ucs4(U);
+  if (result <= 255) and
+     (WinAnsiConvert.AnsiToWide[result] <= 255) then
+    result := NormToUpperByte[result];
+end;
+
+function FindNextUtf8WordBegin(U: PUtf8Char): PUtf8Char;
+var
+  c: cardinal;
+  V: PUtf8Char;
+begin
+  result := nil;
+  repeat
+    c := GetNextUtf8Upper(U);
+    if c = 0 then
+      exit;
+  until (c >= 127) or
+        not (tcWord in TEXT_BYTES[c]); // not ['0'..'9', 'a'..'z', 'A'..'Z']
+  repeat
+    V := U;
+    c := GetNextUtf8Upper(U);
+    if c = 0 then
+      exit;
+  until (c < 127) and
+        (tcWord in TEXT_BYTES[c]);
+  result := V;
+end;
+
+function AnsiICompW(u1, u2: PWideChar): PtrInt;
+var
+  C1, C2: PtrInt;
+  {$ifdef CPUX86NOTPIC}
+  table: TNormTableByte absolute NormToUpperAnsi7Byte;
+  {$else}
+  table: PByteArray;
+  {$endif CPUX86NOTPIC}
+begin
+  if u1 <> u2 then
+    if u1 <> nil then
+      if u2 <> nil then
+      begin
+        {$ifndef CPUX86NOTPIC}
+        table := @NormToUpperAnsi7Byte;
+        {$endif CPUX86NOTPIC}
+        repeat
+          C1 := PtrInt(u1^);
+          C2 := PtrInt(u2^);
+          result := C1 - C2;
+          if result <> 0 then
+          begin
+            if (C1 > 255) or
+               (C2 > 255) then
+              exit;
+            result := table[C1] - table[C2];
+            if result <> 0 then
+              exit;
+          end;
+          if (C1 = 0) or
+             (C2 = 0) then
+            break;
+          inc(u1);
+          inc(u2);
+        until false;
+      end
+      else
+        result := 1
+    else  // u2=''
+      result := -1
+  else // u1=''
+    result := 0;      // u1=u2
+end;
+
+function AnsiIComp(Str1, Str2: pointer): PtrInt;
+var
+  C1, C2: byte; // integer/PtrInt are actually slower on FPC
+  lookupper: PByteArray; // better x86-64 / PIC asm generation
+begin
+  result := PtrInt(PtrUInt(Str2)) - PtrInt(PtrUInt(Str1));
+  if result <> 0 then
+    if Str1 <> nil then
+      if Str2 <> nil then
+      begin
+        lookupper := @NormToUpperByte;
+        repeat
+          C1 := lookupper[PByteArray(Str1)[0]];
+          C2 := lookupper[PByteArray(Str1)[result]];
+          inc(PByte(Str1));
+        until (C1 = 0) or
+              (C1 <> C2);
+        result := C1 - C2;
+      end
+      else
+        result := 1
+    else  // Str2=''
+      result := -1;     // Str1=''
+end;
+
+function SortDynArrayAnsiStringI(const A, B): integer;
+begin
+  result := StrIComp(PUtf8Char(A), PUtf8Char(B)); // very agressively inlined
+end;
+
+function SortDynArrayPUtf8CharI(const A, B): integer;
+begin
+  result := StrIComp(PUtf8Char(A), PUtf8Char(B));
+end;
+
+function SortDynArrayStringI(const A, B): integer;
+begin
+  {$ifdef UNICODE}
+  result := AnsiICompW(PWideChar(A), PWideChar(B));
+  {$else}
+  result := StrIComp(PUtf8Char(A), PUtf8Char(B));
+  {$endif UNICODE}
+end;
+
+function SortDynArrayUnicodeStringI(const A, B): integer;
+begin
+  result := AnsiICompW(PWideChar(A), PWideChar(B));
+end;
+
+function ConvertCaseUtf8(P: PUtf8Char; const Table: TNormTableByte): PtrInt;
+var
+  D, S: PUtf8Char;
+  c: PtrUInt;
+  extra, i: PtrInt;
+  {$ifdef CPUX86NOTPIC}
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+begin
+  result := 0;
+  if P = nil then
+    exit;
+  {$ifndef CPUX86NOTPIC}
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  D := P;
+  repeat
+    c := byte(P[0]);
+    inc(P);
+    if c = 0 then
+      break;
+    if c <= 127 then
+    begin
+      D[result] := AnsiChar(Table[c]);
+      inc(result);
+    end
+    else
+    begin
+      extra := utf8.Lookup[c];
+      if extra = UTF8_INVALID then
+        exit; // invalid leading byte
+      i := 0;
+      repeat
+        if byte(P[i]) and $c0 <> $80 then
+          exit; // invalid input content
+        c := (c shl 6) + byte(P[i]);
+        inc(i);
+      until i = extra;
+      with utf8.Extra[extra] do
+      begin
+        dec(c, offset);
+        if c < minimum then
+          exit; // invalid input content
+      end;
+      if (c <= 255) and
+         (Table[c] <= 127) then
+      begin
+        D[result] := AnsiChar(Table[c]);
+        inc(result);
+        inc(P, extra);
+        continue;
+      end;
+      S := P - 1;
+      inc(P, extra);
+      inc(extra);
+      MoveByOne(S, D + result, extra);
+      inc(result, extra);
+    end;
+  until false;
+end;
+
+function UpperCaseU(const S: RawUtf8): RawUtf8;
+var
+  LS, LD: integer;
+begin
+  LS := length(S);
+  FastSetString(result, pointer(S), LS);
+  LD := ConvertCaseUtf8(pointer(result), NormToUpperByte);
+  if LS <> LD 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;
+  {$ifdef CPUX86NOTPIC}
+  table: TNormTableByte absolute NormToUpperByte;
+  {$else}
+  table: PByteArray;
+  {$endif CPUX86NOTPIC}
+label
+  c2low;
+begin
+  // fast UTF-8 comparison using the NormToUpper[] array for all 8-bit values
+  {$ifndef CPUX86NOTPIC}
+  table := @NormToUpperByte;
+  {$endif CPUX86NOTPIC}
+  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
+c2low:          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;    // u1 0 then
+            exit;
+        until false
+      else
+        result := 1 // u2=''
+    else
+      result := -1  // u1=''
+  else
+    result := 0;    // u1=u2
+end;
+
+function Utf8ILComp(u1, u2: PUtf8Char; L1, L2: cardinal): PtrInt;
+var
+  c2: PtrInt;
+  extra, i: integer;
+  {$ifdef CPUX86NOTPIC}
+  table: TNormTableByte absolute NormToUpperByte;
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  table: PByteArray;
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+label
+  neg, pos;
+begin
+  // fast UTF-8 comparison using the NormToUpper[] array for all 8-bit values
+  {$ifndef CPUX86NOTPIC}
+  table := @NormToUpperByte;
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  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
+              // 'a'..'z' / 'A'..'Z' case insensitive comparison
+              dec(result, table[c2]);
+              dec(L2);
+              inc(u2);
+              if result <> 0 then
+                // found unmatching char
+                exit
+              else if L1 <> 0 then
+                if L2 <> 0 then
+                  // L1>0 and L2>0 -> next char
+                  continue
+                else
+                  // L1>0 and L2=0 -> u1>u2
+                  goto pos
+              else
+              if L2 <> 0 then
+                // L1=0 and L2>0 -> u1 u1=u2 -> returns 0
+                exit;
+            end;
+          end
+          else
+          begin
+            // Win-1252 case insensitive comparison
+            extra := utf8.Lookup[result];
+            if extra = UTF8_INVALID then
+              // invalid leading byte
+              goto neg;
+            dec(L1, extra);
+            if integer(L1) < 0 then
+              goto neg;
+            i := 0;
+            repeat
+              result := result shl 6;
+              inc(result, ord(u1[i]));
+              inc(i);
+            until i = extra;
+            inc(u1, extra);
+            dec(result, utf8.Extra[extra].offset);
+            if result and $ffffff00 = 0 then
+              // 8-bit to upper conversion, 32-bit as is
+              result := table[result];
+          end;
+          // here result=NormToUpper[u1^]
+          inc(u2);
+          dec(L2);
+          if c2 <= 127 then
+          begin
+            dec(result, table[c2]);
+            if result <> 0 then
+              // found unmatching char
+              exit;
+          end
+          else
+          begin
+            extra := utf8.Lookup[c2];
+            if extra = UTF8_INVALID then
+              goto pos;
+            dec(L2, extra);
+            if integer(L2) < 0 then
+              goto pos;
+            i := 0;
+            repeat
+              c2 := c2 shl 6;
+              inc(c2, ord(u2[i]));
+              inc(i);
+            until i = extra;
+            inc(u2, extra);
+            dec(c2, utf8.Extra[extra].offset);
+            if c2 and $ffffff00 = 0 then
+              // 8-bit to upper
+              dec(result, table[c2])
+            else
+              // returns 32-bit diff
+              dec(result, c2);
+            if result <> 0 then
+              // found unmatching char
+              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
+              // u1=u2
+              exit
+            else
+              // u1u2
+            goto pos;
+        until false
+      else
+pos:    // u2='' or u1>u2
+        result := 1
+    else
+neg:  // u1='' or u1 UpperValue^ then
+        break;
+      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 if not (tcWord in TEXT_CHARS[NormToUpper[A^]]) then
+        break
+      else
+        inc(A);
+    until false;
+  until false;
+end;
+
+function FindUnicode(PW, Upper: PWideChar; UpperLen: PtrInt): boolean;
+var
+  Start: PWideChar;
+  w: PtrUInt;
+begin
+  result := false;
+  if (PW = nil) or
+     (Upper = nil) then
+    exit;
+  repeat
+    // go to beginning of next word
+    repeat
+      w := ord(PW^);
+      if w = 0 then
+        exit
+      else if (w > 126) or
+              (tcWord in TEXT_BYTES[w]) then
+        Break;
+      inc(PW);
+    until false;
+    Start := PW;
+    // search end of word matching UpperLen characters
+    repeat
+      inc(PW);
+      w := ord(PW^);
+    until (PW - Start >= UpperLen) or
+          (w = 0) or
+          ((w < 127) and
+           not (tcWord in TEXT_BYTES[w]));
+    if PW - Start >= UpperLen then
+      if Unicode_CompareString(Start, Upper, UpperLen, UpperLen,
+           {ignorecase=}true) = 2 then
+      begin
+        result := true; // case-insensitive match found
+        exit;
+      end;
+    // not found: go to end of current word
+    repeat
+      w := ord(PW^);
+      if w = 0 then
+        exit
+      else if ((w < 127) and
+              not (tcWord in TEXT_BYTES[w])) then
+        Break;
+      inc(PW);
+    until false;
+  until false;
+end;
+
+function FindUtf8(U: PUtf8Char; UpperValue: PAnsiChar): boolean;
+var
+  ValueStart: PAnsiChar;
+  c: PtrUInt;
+  FirstChar: AnsiChar;
+  {$ifdef CPUX86NOTPIC}
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+label
+  Next;
+begin
+  result := false;
+  if (U = nil) or
+     (UpperValue = nil) then
+    exit;
+  // handles 8-bits WinAnsi chars inside UTF-8 encoded data
+  {$ifndef CPUX86NOTPIC}
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  FirstChar := UpperValue^;
+  ValueStart := UpperValue + 1;
+  repeat
+    // test beginning of word
+    repeat
+      c := byte(U^);
+      inc(U);
+      if c = 0 then
+        exit;
+      if c <= 127 then
+      begin
+        if tcWord in TEXT_BYTES[c] then
+          if PAnsiChar(@NormToUpper)[c] <> FirstChar then
+            goto Next
+          else
+            break;
+      end
+      else if c and $20 = 0 then
+      begin
+        // fast direct process of $0..$7ff codepoints including accents
+        c := ((c shl 6) + byte(U^)) - $3080;
+        inc(U);
+        if c <= 255 then
+        begin
+          c := NormToUpperByte[c];
+          if tcWord in TEXT_BYTES[c] then
+            if AnsiChar(c) <> FirstChar then
+              goto Next
+            else
+              break;
+        end;
+      end
+      else
+      begin
+        c := utf8.Lookup[c];
+        if c = UTF8_INVALID then
+          exit
+        else
+          // just ignore surrogates for soundex
+          inc(U, c);
+      end;
+      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
+        c := utf8.Lookup[c];
+        if c = UTF8_INVALID then
+          exit
+        else
+          inc(U, c);
+        break;
+      end;
+      inc(UpperValue);
+    until false;
+Next: // find beginning of next word
+    U := FindNextUtf8WordBegin(U);
+  until U = nil;
+end;
+
+function UpperCopy255(dest: PAnsiChar; const source: RawUtf8): PAnsiChar;
+begin
+  if source <> '' then
+    result := UpperCopy255Buf(
+      dest, pointer(source), PStrLen(PAnsiChar(pointer(source)) - _STRLEN)^)
+  else
+    result := dest;
+end;
+
+function UpperCopy255Buf(dest: PAnsiChar; source: PUtf8Char; sourceLen: PtrInt): PAnsiChar;
+var
+  i, c, d {$ifdef CPU64}, _80, _61, _7b {$endif}: PtrUInt;
+begin
+  if sourceLen <> 0 then
+  begin
+    if sourceLen > 248 then
+      sourceLen := 248; // avoid buffer overflow
+    // we allow to copy up to 3/7 more chars in Dest^ since its size is 255
+    {$ifdef CPU64}
+    // unbranched uppercase conversion of 8 chars blocks
+    _80 := PtrUInt($8080808080808080); // use registers for constants
+    _61 := $6161616161616161;
+    _7b := $7b7b7b7b7b7b7b7b;
+    for i := 0 to (sourceLen - 1) shr 3 do
+    begin
+      c := PPtrUIntArray(source)^[i];
+      d := c or _80;
+      PPtrUIntArray(dest)^[i] := c - ((d - _61) and
+        not (d - _7b)) and ((not c) and _80) shr 2;
+    end;
+    {$else}
+    // unbranched uppercase conversion of 4 chars blocks
+    for i := 0 to (sourceLen - 1) shr 2 do
+    begin
+      c := PPtrUIntArray(source)^[i];
+      d := c or PtrUInt($80808080);
+      PPtrUIntArray(dest)^[i] := c - ((d - PtrUInt($61616161)) and
+        not(d - PtrUInt($7b7b7b7b))) and ((not c) and PtrUInt($80808080)) shr 2;
+    end;
+    {$endif CPU64}
+  end;
+  result := dest + sourceLen; // return the exact size
+end;
+
+function UpperCopyWin255(dest: PWinAnsiChar; const source: RawUtf8): PWinAnsiChar;
+var
+  i, L: PtrInt;
+  {$ifdef CPUX86NOTPIC}
+  tab: TNormTableByte absolute NormToUpperByte;
+  {$else}
+  tab: PByteArray; // faster on PIC/ARM and x86_64
+  {$endif CPUX86NOTPIC}
+begin
+  if source = '' then
+    result := dest
+  else
+  begin
+    L := PStrLen(PAnsiChar(pointer(source)) - _STRLEN)^;
+    if L > 250 then
+      L := 250; // avoid buffer overflow
+    result := dest + L;
+    {$ifndef CPUX86NOTPIC}
+    tab := @NormToUpperByte;
+    {$endif CPUX86NOTPIC}
+    for i := 0 to L - 1 do
+      dest[i] := AnsiChar(tab[PByteArray(source)[i]]);
+  end;
+end;
+
+function Utf8UpperCopy(Dest, Source: PUtf8Char; SourceChars: cardinal): PUtf8Char;
+var
+  c: cardinal;
+  endSource, endSourceBy4, up: PUtf8Char;
+  extra, i: PtrInt;
+  {$ifdef CPUX86NOTPIC}
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+label
+  by1, by4, set1; // ugly but faster
+begin
+  if (Source <> nil) and
+     (Dest <> nil) then
+  begin
+    {$ifndef CPUX86NOTPIC}
+    utf8 := @UTF8_TABLE;
+    {$endif CPUX86NOTPIC}
+    // first handle trailing 7-bit ASCII chars, by quad (Sha optimization)
+    endSource := Source + SourceChars;
+    endSourceBy4 := endSource - 4;
+    up := @NormToUpper;
+    if {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}(PtrUInt(Source) and 3 = 0) and{$endif}
+       (Source <= endSourceBy4) then
+      repeat
+        c := PCardinal(Source)^;
+        if c and $80808080 <> 0 then
+          goto by1; // break on first non ASCII quad
+by4:    inc(Source, 4);
+        Dest[0] := up[ToByte(c)];
+        Dest[1] := up[ToByte(c shr 8)];
+        Dest[2] := up[ToByte(c shr 16)];
+        Dest[3] := up[ToByte(c shr 24)];
+        inc(Dest, 4);
+      until Source > endSourceBy4;
+    // generic loop, handling one UCS4 CodePoint per iteration
+    if Source < endSource then
+      repeat
+by1:    c := byte(Source^);
+        inc(Source);
+        if c <= 127 then
+        begin
+          Dest^ := up[c];
+set1:     inc(Dest);
+          if {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}(PtrUInt(Source) and 3 = 0) and{$endif}
+             (Source <= endSourceBy4) then
+          begin
+            c := PCardinal(Source)^;
+            if c and $80808080 = 0 then
+              goto by4;
+            continue;
+          end
+          else if Source < endSource then
+            continue
+          else
+            break;
+        end
+        else
+        begin
+          extra := utf8.Lookup[c];
+          if (extra = UTF8_INVALID) or
+             (Source + extra > endSource) then
+            break;
+          i := 0;
+          repeat
+            c := (c shl 6) + byte(Source[i]);
+            inc(i)
+          until i = extra;
+          with utf8.Extra[extra] do
+          begin
+            dec(c, offset);
+            if c < minimum then
+              break; // invalid input content
+          end;
+          if (c <= 255) and
+             (up[c] <= #127) then
+          begin
+            Dest^ := up[c];
+            inc(Source, extra);
+            goto set1;
+          end;
+          Dest^ := Source[-1];
+          repeat // here we now extra>0 - just copy UTF-8 input untouched
+            inc(Dest);
+            Dest^ := Source^;
+            inc(Source);
+            dec(extra);
+            if extra = 0 then
+              goto set1;
+          until false;
+        end;
+      until false;
+  end;
+  result := Dest;
+end;
+
+function Utf8UpperCopy255(dest: PAnsiChar; const source: RawUtf8): PUtf8Char;
+var
+  L: integer;
+begin
+  L := length(source);
+  if L > 0 then
+  begin
+    if L > 250 then
+      L := 250; // avoid buffer overflow
+    result := Utf8UpperCopy(pointer(dest), pointer(source), L);
+  end
+  else
+    result := pointer(dest);
+end;
+
+function UpperCopy255W(dest: PAnsiChar; const source: SynUnicode): PAnsiChar;
+begin
+  result := UpperCopy255W(dest, pointer(source), length(source));
+end;
+
+function UpperCopy255W(dest: PAnsiChar; source: PWideChar; L: PtrInt): PAnsiChar;
+var
+  c: PtrUInt;
+  d: byte;
+  lookupper: PByteArray; // better x86-64 / PIC asm generation
+begin
+  if L > 0 then
+  begin
+    if L > 250 then
+      L := 250; // avoid buffer overflow
+    lookupper := @NormToUpperAnsi7Byte;
+    repeat
+      c := PWord(source)^;
+      d := ord('?');
+      if c < 255 then
+        d := lookupper[c];
+      dest^ := AnsiChar(d);
+      inc(dest);
+      inc(source);
+      dec(L);
+    until L = 0;
+  end;
+  result := dest;
+end;
+
+function UpperCopy(dest: PAnsiChar; const source: RawUtf8): PAnsiChar;
+var
+  s: PAnsiChar;
+  c: byte;
+  lookupper: PByteArray; // better x86-64 / PIC asm generation
+begin
+  s := pointer(source);
+  if s <> nil then
+  begin
+    lookupper := @NormToUpperAnsi7Byte;
+    repeat
+      c := lookupper[ord(s^)];
+      if c = 0 then
+        break;
+      dest^ := AnsiChar(c);
+      inc(s);
+      inc(dest);
+    until false;
+  end;
+  result := dest;
+end;
+
+function UpperCopyShort(dest: PAnsiChar; const source: ShortString): PAnsiChar;
+var
+  s: PByteArray;
+  i: PtrInt;
+  lookupper: PByteArray; // better x86-64 / PIC asm generation
+begin
+  s := @source;
+  lookupper := @NormToUpperAnsi7Byte;
+  for i := 1 to s[0] do
+  begin
+    dest^ := AnsiChar(lookupper[s[i]]);
+    inc(dest);
+  end;
+  result := dest;
+end;
+
+function UpperCaseUnicode(const S: RawUtf8): RawUtf8;
+var
+  tmp: TSynTempBuffer;
+  len: integer;
+begin
+  if S = '' then
+  begin
+    result := '';
+    exit;
+  end;
+  tmp.Init(length(s) * 2);
+  len := Utf8ToWideChar(tmp.buf, pointer(S), length(S)) shr 1;
+  RawUnicodeToUtf8(tmp.buf, Unicode_InPlaceUpper(tmp.buf, len), result);
+  tmp.Done;
+end;
+
+function UpperCaseSynUnicode(const S: SynUnicode): SynUnicode;
+begin
+  {$ifdef UNICODE}
+  result := SysUtils.UpperCase(S);
+  {$else}
+  {$ifdef HASVARUSTRING}
+  result := UnicodeUpperCase(S);
+  {$else}
+  result := WideUpperCase(s);
+  {$endif HASVARUSTRING}
+  {$endif UNICODE}
+end;
+
+function LowerCaseSynUnicode(const S: SynUnicode): SynUnicode;
+begin
+  {$ifdef UNICODE}
+  result := SysUtils.LowerCase(S);
+  {$else}
+  {$ifdef HASVARUSTRING}
+  result := UnicodeLowerCase(S);
+  {$else}
+  result := WideLowerCase(s);
+  {$endif HASVARUSTRING}
+  {$endif UNICODE}
+end;
+
+function LowerCaseUnicode(const S: RawUtf8): RawUtf8;
+var
+  tmp: TSynTempBuffer;
+  len: integer;
+begin
+  if S = '' then
+  begin
+    result := '';
+    exit;
+  end;
+  tmp.Init(length(s) * 2);
+  len := Utf8ToWideChar(tmp.buf, pointer(S), length(S)) shr 1;
+  RawUnicodeToUtf8(tmp.buf, Unicode_InPlaceLower(tmp.buf, len),result);
+  tmp.Done;
+end;
+
+function IsCaseSensitive(const S: RawUtf8): boolean;
+begin
+  result := IsCaseSensitive(pointer(S), length(S));
+end;
+
+function IsCaseSensitive(P: PUtf8Char; PLen: PtrInt): boolean;
+begin
+  result := true;
+  if (P <> nil) and
+     (PLen > 0) then
+    repeat
+      if ord(P^) in [ord('a')..ord('z'), ord('A')..ord('Z')] then
+        exit;
+      inc(P);
+      dec(PLen);
+    until PLen = 0;
+  result := false;
+end;
+
+procedure CaseCopy(Text: PUtf8Char; Len: PtrInt; Table: PNormTable;
+  var Dest: RawUtf8);
+var
+  i: PtrInt;
+  tmp: PAnsiChar;
+begin
+  tmp := FastNewString(Len, CP_UTF8);
+  for i := 0 to Len - 1 do
+    tmp[i] := Table[Text[i]]; // branchless conversion
+  FastAssignNew(Dest, tmp);
+end;
+
+procedure CaseSelf(var S: RawUtf8; Table: PNormTable);
+var
+  i: PtrInt;
+  P: PUtf8Char;
+begin
+  P := UniqueRawUtf8(S);
+  for i := 0 to length(S) - 1 do
+    P[i] := Table[P[i]]; // branchless conversion
+end;
+
+function UpperCase(const S: RawUtf8): RawUtf8;
+begin
+  CaseCopy(pointer(S), length(S), @NormToUpperAnsi7, result);
+end;
+
+procedure UpperCaseCopy(Text: PUtf8Char; Len: PtrInt; var Dest: RawUtf8);
+begin
+  CaseCopy(Text, Len, @NormToUpperAnsi7, Dest);
+end;
+
+procedure UpperCaseCopy(const Source: RawUtf8; var Dest: RawUtf8);
+begin
+  CaseCopy(pointer(Source), length(Source), @NormToUpperAnsi7, Dest);
+end;
+
+procedure UpperCaseSelf(var S: RawUtf8);
+begin
+  CaseSelf(S, @NormToUpperAnsi7);
+end;
+
+function LowerCase(const S: RawUtf8): RawUtf8;
+begin
+  CaseCopy(pointer(S), length(S), @NormToLowerAnsi7, result);
+end;
+
+procedure LowerCaseCopy(Text: PUtf8Char; Len: PtrInt; var Dest: RawUtf8);
+begin
+  CaseCopy(Text, Len, @NormToLowerAnsi7, Dest);
+end;
+
+procedure LowerCaseSelf(var S: RawUtf8);
+begin
+  CaseSelf(S, @NormToLowerAnsi7);
+end;
+
+function PosExIPas(pSub, p: PUtf8Char; Offset: PtrUInt;
+  Lookup: PNormTable): PtrInt;
+var
+  len, lenSub: PtrInt;
+  ch: AnsiChar;
+  pStart, pStop: PUtf8Char;
+label
+  s2, s6, tt, t0, t1, t2, t3, t4, s0, s1, fnd, quit;
+begin
+  result := 0;
+  if (p = nil) or
+     (pSub = nil) or
+     (PtrInt(Offset) <= 0) or
+     (Lookup = nil) then
+    goto quit;
+  len := PStrLen(p - _STRLEN)^;
+  lenSub := PStrLen(pSub - _STRLEN)^ - 1;
+  if (len < lenSub + PtrInt(Offset)) or
+     (lenSub < 0) then
+    goto quit;
+  pStop := p + len;
+  inc(p, lenSub);
+  inc(pSub, lenSub);
+  pStart := p;
+  p := @p[Offset + 3];
+  ch := Lookup[pSub[0]];
+  lenSub := -lenSub;
+  if p < pStop then
+    goto s6;
+  dec(p, 4);
+  goto s2;
+s6: // check 6 chars per loop iteration with O(1) case comparison
+  if ch = Lookup[p[-4]] then
+    goto t4;
+  if ch = Lookup[p[-3]] then
+    goto t3;
+  if ch = Lookup[p[-2]] then
+    goto t2;
+  if ch = Lookup[p[-1]] then
+    goto t1;
+s2:if ch = Lookup[p[0]] then
+    goto t0;
+s1:if ch = Lookup[p[1]] then
+    goto tt;
+s0:inc(p, 6);
+  if p < pStop then
+    goto s6;
+  dec(p, 4);
+  if p >= pStop then
+    goto quit;
+  goto s2;
+t4:dec(p, 2);
+t2:dec(p, 2);
+  goto t0;
+t3:dec(p, 2);
+t1:dec(p, 2);
+tt:len := lenSub;
+  if lenSub <> 0 then
+    repeat
+      if (Lookup[pSub[len]] <> Lookup[p[len + 1]]) or
+         (Lookup[pSub[len + 1]] <> Lookup[p[len + 2]]) then
+        goto s0;
+      inc(len, 2);
+    until len >= 0;
+  inc(p, 2);
+  if p <= pStop then
+    goto fnd;
+  goto quit;
+t0:len := lenSub;
+  if lenSub <> 0 then
+    repeat
+      if (Lookup[pSub[len]] <> Lookup[p[len]]) or
+         (Lookup[pSub[len + 1]] <> Lookup[p[len + 1]]) then
+        goto s1;
+      inc(len, 2);
+    until len >= 0;
+  inc(p);
+fnd:
+  result := p - pStart;
+quit:
+end;
+
+function PosExI(const SubStr, S: RawUtf8; Offset: PtrUInt): PtrInt;
+begin
+  result := PosExIPas(pointer(SubStr), pointer(S), Offset, @NormToUpperAnsi7);
+end;
+
+function PosExI(const SubStr, S: RawUtf8; Offset: PtrUInt;
+  Lookup: PNormTable): PtrInt;
+begin
+  if Lookup = nil then
+    {$ifdef CPUX86}
+    result := PosEx(SubStr, S, Offset)
+    {$else}
+    result := PosExPas(pointer(SubStr), pointer(S), Offset)
+    {$endif CPUX86}
+  else
+    result := PosExIPas(pointer(SubStr), pointer(S), Offset, Lookup);
+end;
+
+
+{ ************ UTF-8 String Manipulation Functions }
+
+function StartWithExact(const text, textStart: RawUtf8): boolean;
+var
+  l: PtrInt;
+begin
+  l := length(textStart);
+  result := (length(text) >= l) and
+            CompareMem(pointer(text), pointer(textStart), l);
+end;
+
+function EndWithExact(const text, textEnd: RawUtf8): boolean;
+var
+  l, o: PtrInt;
+begin
+  l := length(textEnd);
+  o := length(text) - l;
+  result := (o >= 0) and
+            CompareMem(PUtf8Char(pointer(text)) + o, pointer(textEnd), l);
+end;
+
+function GetNextLine(source: PUtf8Char; out next: PUtf8Char; andtrim: boolean): RawUtf8;
+var
+  beg: PUtf8Char;
+begin
+  if source = nil then
+  begin
+    {$ifdef FPC}
+    FastAssignNew(result);
+    {$else}
+    result := '';
+    {$endif FPC}
+    next := source;
+    exit;
+  end;
+  if andtrim then // optional trim left
+    while source^ in [#9, ' '] do
+      inc(source);
+  beg := source;
+  repeat // just here to avoid a goto
+    if source[0] > #13 then
+      if source[1] > #13 then
+        if source[2] > #13 then
+          if source[3] > #13 then
+          begin
+            inc(source, 4); // fast process 4 chars per loop
+            continue;
+          end
+          else
+            inc(source, 3)
+        else
+          inc(source, 2)
+      else
+        inc(source);
+    case source^ of
+      #0:
+        next := nil;
+      #10:
+        next := source + 1;
+      #13:
+        if source[1] = #10 then
+          next := source + 2
+        else
+          next := source + 1;
+    else
+      begin
+        inc(source);
+        continue;
+      end;
+    end;
+    if andtrim then // optional trim right
+      while (source > beg) and
+            (source[-1] in [#9, ' ']) do
+        dec(source);
+    FastSetString(result, beg, source - beg);
+    exit;
+  until false;
+end;
+
+function LeftU(const S: RawUtf8; n: PtrInt): RawUtf8;
+begin
+  result := Copy(S, 1, n);
+end;
+
+function RightU(const S: RawUtf8; n: PtrInt): RawUtf8;
+var
+  L: PtrInt;
+begin
+  L := length(S);
+  if n > L then
+    n := L;
+  result := Copy(S, L + 1 - n, n);
+end;
+
+function TrimLeft(const S: RawUtf8): RawUtf8;
+var
+  i, l: PtrInt;
+begin
+  l := Length(S);
+  i := 1;
+  while (i <= l) and
+        (S[i] <= ' ') do
+    inc(i);
+  if i = 1 then
+    result := S
+  else
+    FastSetString(result, @PByteArray(S)[i - 1], l - i);
+end;
+
+function TrimRight(const S: RawUtf8): RawUtf8;
+var
+  i: PtrInt;
+begin
+  i := Length(S);
+  while (i > 0) and
+        (S[i] <= ' ') do
+    dec(i);
+  FastSetString(result, pointer(S), i);
+end;
+
+procedure TrimLeftLines(var S: RawUtf8);
+var
+  P, D: PUtf8Char;
+begin
+  if S = '' then
+    exit;
+  P := UniqueRawUtf8(S);
+  D := P; // in-place process
+  repeat
+    while (P^ <= ' ') and
+          (P^ <> #0) do
+      inc(P);
+    while not (P^ in [#0, #10, #13]) do
+    begin
+      D^ := P^;
+      inc(P);
+      inc(D);
+    end;
+    if P^ = #0 then
+      break;
+    D^ := #10;
+    inc(D);
+  until false;
+  if D = pointer(S) then
+    S := ''
+  else
+    FakeLength(S, D); // no SetLength needed
+end;
+
+procedure TrimChars(var S: RawUtf8; Left, Right: PtrInt);
+var
+  P: PUtf8Char;
+begin
+  P := pointer(S);
+  if P = nil then
+    exit;
+  if Left < 0 then
+    Left := 0;
+  if Right < 0 then
+    Right := 0;
+  inc(Right, Left);
+  if Right = 0 then
+    exit; // nothing to trim
+  Right := PStrLen(P - _STRLEN)^ - Right; // compute new length
+  if Right > 0 then
+    if PStrCnt(P - _STRCNT)^ = 1 then // RefCnt=1 ?
+    begin
+      PStrLen(P - _STRLEN)^ := Right; // we can modify it in-place
+      if Left <> 0 then
+        MoveFast(P[Left], P^, Right);
+      P[Right] := #0;
+    end
+    else
+      FastSetString(S, P + Left, Right) // create a new unique string
+  else
+    FastAssignNew(S);
+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
+      FastSetString(result, @PByteArray(Str)[i], length(Str) - i);
+      if LeftStr <> nil then
+        FastSetString(LeftStr^, pointer(Str), i - 1);
+      exit;
+    end;
+  result := Str;
+  if LeftStr <> nil then
+    FastAssignNew(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
+            FastSetString(result, @PByteArray(Str)[i], length(Str) - i);
+            exit;
+          end;
+      end;
+    end;
+  result := Str;
+end;
+
+function Split(const Str, SepStr: RawUtf8; var LeftStr, RightStr: RawUtf8;
+  ToUpperCase: boolean): boolean;
+var
+  i: PtrInt;
+  tmp: pointer; // may be called as Split(Str,SepStr,Str,RightStr)
+begin
+  if length(SepStr) = 1 then
+    i := PosExChar(SepStr[1], Str) // may use SSE2 on i386/x86_64
+  else
+    i := PosEx(SepStr, Str);
+  if i = 0 then
+  begin
+    LeftStr := Str;
+    RightStr := '';
+    result := false;
+  end
+  else
+  begin
+    dec(i);
+    tmp := nil;
+    FastSetString(RawUtf8(tmp), pointer(Str), i);
+    inc(i, length(SepStr));
+    FastSetString(RightStr, @PByteArray(Str)[i], length(Str) - i);
+    FastAssignNew(LeftStr, tmp);
+    result := true;
+  end;
+  if ToUpperCase then
+  begin
+    UpperCaseSelf(LeftStr);
+    UpperCaseSelf(RightStr);
+  end;
+end;
+
+function Split(const Str, SepStr: RawUtf8; var LeftStr: RawUtf8;
+  ToUpperCase: boolean): RawUtf8;
+begin
+  Split(Str, SepStr, LeftStr, result, ToUpperCase);
+end;
+
+function Split(const Str: RawUtf8; const SepStr: array of RawUtf8;
+  const DestPtr: array of PRawUtf8): PtrInt;
+var
+  s, i, j: PtrInt;
+  P: pointer;
+begin
+  j := 1;
+  result := 0;
+  s := 0;
+  if high(SepStr) >= 0 then
+    while result <= high(DestPtr) do
+    begin
+      P := @PByteArray(Str)[j - 1];
+      i := PosEx(SepStr[s], Str, j);
+      if i = 0 then
+      begin
+        if DestPtr[result] <> nil then
+          FastSetString(DestPtr[result]^, P, length(Str) - j + 1);
+        inc(result);
+        break;
+      end;
+      if DestPtr[result] <> nil then
+        FastSetString(DestPtr[result]^, P, i - j);
+      inc(result);
+      if s < high(SepStr) then
+        inc(s);
+      j := i + 1;
+    end;
+  for i := result to high(DestPtr) do
+    if DestPtr[i] <> nil then
+      FastAssignNew(DestPtr[i]^);
+end;
+
+function IsVoid(const text: RawUtf8): boolean;
+var
+  i: PtrInt;
+begin
+  result := false;
+  for i := 1 to length(text) do
+    if text[i] > ' ' then
+      exit;
+  result := true;
+end;
+
+function TrimControlChars(const text: RawUtf8): RawUtf8;
+var
+  len, i, j, n: PtrInt;
+  P: PAnsiChar;
+begin
+  len := length(text);
+  for i := 1 to len do
+    if text[i] <= ' ' then
+    begin
+      n := i - 1;
+      FastSetString(result, len);
+      P := pointer(result);
+      if n > 0 then
+        MoveFast(pointer(text)^, P^, n);
+      for j := i + 1 to len do
+        if text[j] > ' ' then
+        begin
+          P[n] := text[j];
+          inc(n);
+        end;
+      FakeSetLength(result, n);
+      exit;
+    end;
+  result := text; // no control char found
+end;
+
+function TrimChar(const text: RawUtf8; const exclude: TSynAnsicharSet): RawUtf8;
+var
+  len, i, j, n: PtrInt;
+  P: PAnsiChar;
+begin
+  len := length(text);
+  for i := 1 to len do
+    if text[i] in exclude then
+    begin
+      n := i - 1;
+      FastSetString(result, len - 1);
+      P := pointer(result);
+      if n > 0 then
+        MoveFast(pointer(text)^, P^, n);
+      for j := i + 1 to len do
+        if not (text[j] in exclude) then
+        begin
+          P[n] := text[j];
+          inc(n);
+        end;
+      FakeSetLength(result, n);
+      exit;
+    end;
+  result := text; // no exclude char found
+end;
+
+function TrimOneChar(const text: RawUtf8; exclude: AnsiChar): RawUtf8;
+var
+  first, len, i: PtrInt;
+  c: AnsiChar;
+  P: PAnsiChar;
+begin
+  len := length(text);
+  first := ByteScanIndex(pointer(text), len, ord(exclude));
+  if first < 0 then
+  begin
+    result := text; // no exclude char found
+    exit;
+  end;
+  FastSetString(result, len - 1);
+  P := pointer(result);
+  MoveFast(pointer(text)^, P^, first);
+  inc(P, first);
+  for i := first + 1 to len do
+  begin
+    c := text[i];
+    if c <> exclude then
+    begin
+      P^ := c;
+      inc(P);
+    end;
+  end;
+  FakeSetLength(result, P - pointer(result));
+end;
+
+function OnlyChar(const text: RawUtf8; const only: TSynAnsicharSet): RawUtf8;
+var
+  i: PtrInt;
+  exclude: array[0..(SizeOf(only) shr POINTERSHR) - 1] of PtrInt;
+begin // reverse bits in local stack copy before calling TrimChar()
+  for i := 0 to (SizeOf(only) shr POINTERSHR) - 1 do
+    exclude[i] := not PPtrIntArray(@only)[i];
+  result := TrimChar(text, TSynAnsicharSet(exclude));
+end;
+
+procedure FillZero(var secret: RawByteString);
+begin
+  if secret <> '' then
+    with PStrRec(Pointer(PtrInt(secret) - _STRRECSIZE))^ do
+      if refCnt = 1 then // avoid GPF if const
+        FillCharFast(pointer(secret)^, length, 0);
+  FastAssignNew(secret); // dec refCnt
+end;
+
+procedure FillZero(var secret: RawUtf8);
+begin
+  FillZero(RawByteString(secret));
+end;
+
+procedure FillZero(var secret: SpiUtf8);
+begin
+  FillZero(RawByteString(secret));
+end;
+
+{$ifdef HASVARUSTRING}
+procedure FillZero(var secret: UnicodeString);
+begin
+  if secret <> '' then
+    with PStrRec(Pointer(PtrInt(secret) - _STRRECSIZE))^ do
+      if refCnt = 1 then // avoid GPF if const
+        FillCharFast(pointer(secret)^, length * SizeOf(WideChar), 0);
+  Finalize(secret); // dec refCnt
+end;
+{$endif HASVARUSTRING}
+
+procedure FillZero(var secret: TBytes);
+begin
+  if secret <> nil then
+    with PDynArrayRec(Pointer(PtrInt(secret) - _DARECSIZE))^ do
+      if refCnt = 1 then // avoid GPF if const
+        FillCharFast(pointer(secret)^, length, 0);
+  secret := nil; // dec refCnt
+end;
+
+function StringReplaceAllProcess(const S, OldPattern, NewPattern: RawUtf8;
+  found: integer; Lookup: PNormTable): RawUtf8;
+var
+  i, last, oldlen, newlen, sharedlen: PtrInt;
+  posCount: integer;
+  pos: TIntegerDynArray;
+  src, dst: PAnsiChar;
+begin
+  oldlen := length(OldPattern);
+  newlen := length(NewPattern);
+  SetLength(pos, 64);
+  pos[0] := found;
+  posCount := 1;
+  repeat
+    found := PosExI(OldPattern, S, found + oldlen, Lookup);
+    if found = 0 then
+      break;
+    AddInteger(pos, posCount, found);
+  until false;
+  FastSetString(result, Length(S) + (newlen - oldlen) * posCount);
+  last := 1;
+  src := pointer(S);
+  dst := pointer(result);
+  for i := 0 to posCount - 1 do
+  begin
+    sharedlen := pos[i] - last;
+    MoveFast(src^, dst^, sharedlen);
+    inc(src, sharedlen + oldlen);
+    inc(dst, sharedlen);
+    if newlen > 0 then
+    begin
+      MoveByOne(pointer(NewPattern), dst, newlen);
+      inc(dst, newlen);
+    end;
+    last := pos[i] + oldlen;
+  end;
+  MoveFast(src^, dst^, length(S) - last + 1);
+end;
+
+function StringReplaceAll(const S, OldPattern, NewPattern: RawUtf8;
+  Lookup: PNormTable): RawUtf8;
+var
+  found: integer;
+begin
+  if (S = '') or
+     (OldPattern = '') or
+     (OldPattern = NewPattern) then
+    result := S
+  else
+  begin
+    if (Lookup = nil) and
+       (length(OldPattern) = 1) then
+      found := ByteScanIndex(pointer(S), {%H-}PStrLen(PtrUInt(S) - _STRLEN)^,
+        byte(OldPattern[1])) + 1
+    else
+      found := PosExI(OldPattern, S, 1, Lookup); // handle Lookup=nil
+    if found = 0 then
+      result := S
+    else
+      result := StringReplaceAllProcess(S, OldPattern, NewPattern, found, Lookup);
+  end;
+end;
+
+function StringReplaceAll(const S, OldPattern, NewPattern: RawUtf8;
+  CaseInsensitive: boolean): RawUtf8;
+begin
+  result := StringReplaceAll(S, OldPattern, NewPattern, NORM2CASE[CaseInsensitive]);
+end;
+
+function StringReplaceAll(const S: RawUtf8;
+  const OldNewPatternPairs: array of RawUtf8; CaseInsensitive: boolean): RawUtf8;
+var
+  n, i: PtrInt;
+  tab: PNormTable;
+begin
+  result := S;
+  n := high(OldNewPatternPairs);
+  if (n <= 0) or
+     (n and 1 <> 1) then
+    exit;
+  tab := NORM2CASE[CaseInsensitive];
+  for i := 0 to n shr 1 do
+    result := StringReplaceAll(result,
+      OldNewPatternPairs[i * 2], OldNewPatternPairs[i * 2 + 1], tab);
+end;
+
+function StringReplaceChars(const Source: RawUtf8; OldChar, NewChar: AnsiChar): RawUtf8;
+var
+  i, j, n: PtrInt;
+  P: PAnsiChar;
+begin
+  if (OldChar <> NewChar) and
+     (Source <> '') then
+  begin
+    n := length(Source);
+    i := ByteScanIndex(pointer(Source), n, ord(OldChar));
+    if i >= 0 then
+    begin
+      FastSetString(result, pointer(Source), n);
+      P := pointer(result);
+      for j := i to n - 1 do
+        if P[j] = OldChar then
+          P[j] := NewChar;
+      exit;
+    end;
+  end;
+  result := Source;
+end;
+
+function StringReplaceTabs(const Source, TabText: RawUtf8): RawUtf8;
+
+  procedure Process(S, D, T: PAnsiChar; TLen: integer);
+  begin
+    repeat
+      if S^ = #0 then
+        break
+      else if S^ <> #9 then
+      begin
+        D^ := S^;
+        inc(D);
+        inc(S);
+      end
+      else
+      begin
+        if TLen > 0 then
+        begin
+          MoveByOne(T, D, TLen);
+          inc(D, TLen);
+        end;
+        inc(S);
+      end;
+    until false;
+  end;
+
+var
+  L, i, n, ttl: PtrInt;
+begin
+  ttl := length(TabText);
+  L := Length(Source);
+  n := 0;
+  if ttl <> 0 then
+    for i := 1 to L do
+      if Source[i] = #9 then
+        inc(n);
+  if n = 0 then
+  begin
+    result := Source;
+    exit;
+  end;
+  FastSetString(result, L + n * pred(ttl));
+  Process(pointer(Source), pointer(result), pointer(TabText), ttl);
+end;
+
+function RawUtf8OfChar(Ch: AnsiChar; Count: integer): RawUtf8;
+begin
+  if Count <= 0 then
+    FastAssignNew(result)
+  else
+  begin
+    FastSetString(result, Count);
+    FillCharFast(pointer(result)^, Count, byte(Ch));
+  end;
+end;
+
+function QuotedStr(const S: RawUtf8; Quote: AnsiChar): RawUtf8;
+begin
+  QuotedStr(pointer(S), length(S), Quote, result);
+end;
+
+procedure QuotedStr(const S: RawUtf8; Quote: AnsiChar; var result: RawUtf8);
+var
+  P: PUtf8Char;
+  tmp: pointer; // will hold a RawUtf8 with no try..finally exception block
+begin
+  tmp := nil;
+  P := pointer(S);
+  if (P <> nil) and
+     (P = pointer(result)) then
+  begin
+    RawUtf8(tmp) := S; // make private ref-counted copy for QuotedStr(U,'"',U)
+    P := pointer(tmp);
+  end;
+  QuotedStr(P, length(S), Quote, result);
+  if tmp <> nil then
+    {$ifdef FPC}
+    FastAssignNew(tmp);
+    {$else}
+    RawUtf8(tmp) := '';
+    {$endif FPC}
+end;
+
+procedure QuotedStr(P: PUtf8Char; PLen: PtrInt; Quote: AnsiChar;
+  var result: RawUtf8);
+var
+  i, quote1, nquote: PtrInt;
+  R: PUtf8Char;
+  c: AnsiChar;
+begin
+  nquote := 0;
+  quote1 := ByteScanIndex(pointer(P), PLen, byte(Quote)); // asm if available
+  if quote1 >= 0 then
+    for i := quote1 to PLen - 1 do
+      if P[i] = Quote then
+        inc(nquote);
+  FastSetString(result, PLen + nquote + 2);
+  R := pointer(result);
+  R^ := Quote;
+  inc(R);
+  if nquote = 0 then
+  begin
+    MoveFast(P^, R^, PLen);
+    R[PLen] := Quote;
+  end
+  else
+  begin
+    MoveFast(P^, R^, quote1);
+    inc(R, quote1);
+    inc(PLen, PtrInt(PtrUInt(P))); // efficient use of registers on FPC
+    inc(quote1, PtrInt(PtrUInt(P)));
+    repeat
+      if quote1 = PLen then
+        break;
+      c := PAnsiChar(quote1)^;
+      inc(quote1);
+      R^ := c;
+      inc(R);
+      if c <> Quote then
+        continue;
+      R^ := c;
+      inc(R);
+    until false;
+    R^ := Quote;
+  end;
+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^='"' or P^=#0 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 FPC}
+  result := P;
+end;
+
+function GotoNextNotSpaceSameLine(P: PUtf8Char): PUtf8Char;
+begin
+  while P^ in [#9, ' '] do
+    inc(P);
+  result := P;
+end;
+
+function GotoNextSpace(P: PUtf8Char): PUtf8Char;
+begin
+  if P^ > ' ' then
+    repeat
+      inc(P)
+    until P^ <= ' ';
+  result := P;
+end;
+
+function NextNotSpaceCharIs(var P: PUtf8Char; ch: AnsiChar): boolean;
+begin
+  while (P^ <= ' ') and
+        (P^ <> #0) do
+    inc(P);
+  if P^ = ch then
+  begin
+    inc(P);
+    result := true;
+  end
+  else
+    result := false;
+end;
+
+function GotoNextSqlIdentifier(P: PUtf8Char; tab: PTextCharSet): PUtf8Char;
+  {$ifdef HASINLINE} inline; {$endif}
+begin
+  while tcCtrlNot0Comma in tab[P^] do // in [#1..' ', ';']
+    inc(P);
+  if PWord(P)^ = ord('/') + ord('*') shl 8 then
+  begin
+    // detect and ignore e.g. '/*nocache*/'
+    repeat
+      inc(P);
+      if PWord(P)^ = ord('*') + ord('/') shl 8 then
+      begin
+        inc(P, 2);
+        break;
+      end;
+    until P^ = #0;
+    while tcCtrlNot0Comma in tab[P^] do
+      inc(P);
+  end;
+  result := P;
+end;
+
+function GetNextFieldProp(var P: PUtf8Char; var Prop: RawUtf8): boolean;
+var
+  B: PUtf8Char;
+  tab: PTextCharSet;
+begin
+  tab := @TEXT_CHARS;
+  P := GotoNextSqlIdentifier(P, tab); // handle /*comment*/
+  B := P;
+  while tcIdentifier in tab[P^] do
+    inc(P); // go to end of ['_', '0'..'9', 'a'..'z', 'A'..'Z'] chars
+  FastSetString(Prop, B, P - B);
+  P := GotoNextSqlIdentifier(P, tab);
+  result := Prop <> '';
+end;
+
+function GetNextFieldPropSameLine(var P: PUtf8Char; var Prop: ShortString): boolean;
+var
+  B: PUtf8Char;
+  tab: PTextCharSet;
+begin
+  tab := @TEXT_CHARS;
+  while tcCtrlNotLF in tab[P^] do
+    inc(P); // ignore [#1..#9, #11, #12, #14..' ']
+  B := P;
+  while tcIdentifier in tab[P^] do
+    inc(P); // go to end of field name
+  SetString(Prop, PAnsiChar(B), P - B);
+  while tcCtrlNotLF in TEXT_CHARS[P^] do
+    inc(P);
+  result := Prop <> '';
+end;
+
+function UnQuoteSqlStringVar(P: PUtf8Char; out Value: RawUtf8): PUtf8Char;
+var
+  quote: AnsiChar;
+  PBeg, PS: PUtf8Char;
+  internalquote: PtrInt;
+begin
+  result := nil;
+  if P = nil then
+    exit;
+  quote := P^; // " or '
+  inc(P);
+  // compute unquoted string length
+  PBeg := P;
+  internalquote := 0;
+  P := PosChar(P, quote); // fast SSE2 search on x86_64
+  if P = nil then
+    exit; // we need at least an ending quote
+  while true do
+    if P^ = #0 then
+      exit // where is my quote?
+    else if P^ <> quote then
+      inc(P)
+    else if P[1] = quote then
+    begin
+      inc(P, 2); // allow double quotes inside string
+      inc(internalquote);
+    end
+    else
+      break; // end quote
+  // create unquoted string
+  if internalquote = 0 then
+    // no quote within
+    FastSetString(Value, PBeg, P - PBeg)
+  else
+  begin
+    // unescape internal quotes
+    pointer(Value) := FastNewString(P - PBeg - internalquote, CP_UTF8);
+    P := PBeg;
+    PS := pointer(Value);
+    repeat
+      if P[0] = quote then
+        if P[1] = quote then
+          // allow double quotes inside string
+          inc(P)
+        else
+          // end quote
+          break;
+      PS^ := P[0];
+      inc(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 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 FindNameValue(P: PUtf8Char; UpperName: PAnsiChar): PUtf8Char;
+var
+  table: PNormTable; // faster even on i386
+  u: PAnsiChar;
+label
+  eof, eol;
+begin
+  if (P = nil) or
+     (UpperName = nil) then
+    goto eof;
+  table := @NormToUpperAnsi7;
+  repeat
+    if table[P^] <> UpperName^ then // first character is likely not to match
+      repeat // quickly go to end of current line
+        repeat
+eol:      if P^ <= #13 then
+            break;
+          inc(P);
+        until false;
+        if (P^ = #13) or
+           (P^ = #10) then
+        begin
+          repeat
+            inc(P);
+          until (P^ <> #10) and
+                (P^ <> #13);
+          if P^ = #0 then
+            goto eof;
+          break; // handle next line
+        end
+        else if P^ <> #0 then
+          continue; // e.g. #9
+eof:    result := nil; // reached P^=#0 -> not found
+        exit;
+      until false
+    else
+    begin
+      // first char did match -> try other chars
+      inc(P);
+      u := UpperName + 1;
+      repeat
+        if u^ = #0 then
+          break
+        else if u^ <> table[P^] then
+          goto eol;
+        inc(P);
+        inc(u);
+      until false;
+      result := P; // if found, points just after UpperName
+      exit;
+    end;
+  until false;
+end;
+
+function FindNameValuePointer(NameValuePairs: PUtf8Char; UpperName: PAnsiChar;
+  out FoundLen: PtrInt; UpperNameSeparator: AnsiChar): PUtf8Char;
+var
+  P: PUtf8Char;
+  L: PtrInt;
+begin
+  P := FindNameValue(NameValuePairs, UpperName);
+  if P <> nil then
+    repeat
+      if UpperNameSeparator <> #0 then
+        if P^ = UpperNameSeparator then
+          inc(P) // e.g. THttpSocket.HeaderGetValue uses UpperNameSeparator=':'
+        else
+          break;
+      while P^ in [#9, ' '] do // trim left
+        inc(P);
+      L := 0;
+      while P[L] > #13 do      // end of line/value
+        inc(L);
+      while P[L - 1] = ' ' do  // trim right
+        dec(L);
+      FoundLen := L;
+      break;
+    until false;
+  result := P;
+end;
+
+function FindNameValue(const NameValuePairs: RawUtf8; UpperName: PAnsiChar;
+  var Value: RawUtf8; KeepNotFoundValue: boolean; UpperNameSeparator: AnsiChar): boolean;
+var
+  P: PUtf8Char;
+  L: PtrInt;
+begin
+  P := FindNameValuePointer(pointer(NameValuePairs), UpperName, L, UpperNameSeparator);
+  if P <> nil then
+  begin
+    FastSetString(Value, P, L);
+    result := true;
+  end
+  else
+  begin
+    if not KeepNotFoundValue then
+      {$ifdef FPC}
+      FastAssignNew(Value);
+      {$else}
+      Value := '';
+      {$endif FPC}
+    result := false;
+  end;
+end;
+
+function GetLineSize(P, PEnd: PUtf8Char): PtrUInt;
+var
+  c: byte;
+begin
+  {$ifdef CPUX64}
+  if PEnd <> nil then
+  begin
+    result := BufferLineLength(P, PEnd); // use branchless SSE2 on x86_64
+    exit;
+  end;
+  result := PtrUInt(P) - 1;
+  {$else}
+  result := PtrUInt(P) - 1;
+  if PEnd <> nil then
+    repeat // inlined BufferLineLength()
+      inc(result);
+      if PtrUInt(result) < PtrUInt(PEnd) then
+      begin
+        c := PByte(result)^;
+        if (c > 13) or
+           ((c <> 10) and
+            (c <> 13)) then
+          continue;
+      end;
+      break;
+    until false
+  else
+  {$endif CPUX64}
+    repeat // inlined BufferLineLength() ending at #0 for PEnd=nil
+      inc(result);
+      c := PByte(result)^;
+      if (c > 13) or
+         ((c <> 0) and (c <> 10) and (c <> 13)) then
+        continue;
+      break;
+    until false;
+  dec(result, PtrUInt(P)); // returns length
+end;
+
+function GetLineSizeSmallerThan(P, PEnd: PUtf8Char; aMinimalCount: integer): boolean;
+begin
+  result := false;
+  if P <> nil then
+    while (P < PEnd) and
+          (P^ <> #10) and
+          (P^ <> #13) do
+      if aMinimalCount = 0 then
+        exit
+      else
+      begin
+        dec(aMinimalCount);
+        inc(P);
+      end;
+  result := true;
+end;
+
+{$ifndef PUREMORMOT2}
+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;
+{$endif PUREMORMOT2}
+
+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;
+
+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;
+
+procedure AppendShortComma(text: PAnsiChar; len: PtrInt; var result: ShortString;
+  trimlowercase: boolean);
+begin
+  if trimlowercase then
+    while text^ in ['a'..'z'] do
+      if len = 1 then
+        exit
+      else
+      begin
+        inc(text);
+        dec(len);
+      end;
+  if integer(ord(result[0])) + len >= 255 then
+    exit;
+  if len > 0 then
+    MoveByOne(text, @result[ord(result[0]) + 1], len);
+  inc(result[0], len + 1);
+  result[ord(result[0])] := ',';
+end;
+
+function IdemPropNameUSmallNotVoid(P1, P2, P1P2Len: PtrInt): boolean;
+  {$ifdef HASINLINE}inline;{$endif}
+begin
+  inc(P1P2Len, P1);
+  dec(P2, P1);
+  repeat
+    result := (PByte(P1)^ xor ord(PAnsiChar(P1)[P2])) and $df = 0;
+    if not result then
+      exit;
+    inc(P1);
+  until P1 >= P1P2Len;
+end;
+
+function FindShortStringListExact(List: PShortString; MaxValue: integer;
+  aValue: PUtf8Char; aValueLen: PtrInt): integer;
+var
+  PLen: PtrInt;
+begin
+  if aValueLen <> 0 then
+    for result := 0 to MaxValue do
+    begin
+      PLen := PByte(List)^;
+      if (PLen = aValueLen) and
+         IdemPropNameUSmallNotVoid(PtrInt(@List^[1]), PtrInt(aValue), PLen) then
+        exit;
+      List := pointer(@PAnsiChar(PLen)[PtrUInt(List) + 1]); // next
+    end;
+  result := -1;
+end;
+
+function FindShortStringListTrimLowerCase(List: PShortString; MaxValue: integer;
+  aValue: PUtf8Char; aValueLen: PtrInt): integer;
+var
+  PLen: PtrInt;
+begin
+  if aValueLen <> 0 then
+    for result := 0 to MaxValue do
+    begin
+      PLen := ord(List^[0]);
+      inc(PUtf8Char(List));
+      repeat // trim lower case
+        if not (PUtf8Char(List)^ in ['a'..'z']) then
+          break;
+        inc(PUtf8Char(List));
+        dec(PLen);
+      until PLen = 0;
+      if (PLen = aValueLen) and
+         IdemPropNameUSmallNotVoid(PtrInt(aValue), PtrInt(List), PLen) then
+        exit;
+      inc(PUtf8Char(List), PLen); // next
+    end;
+  result := -1;
+end;
+
+function FindShortStringListTrimLowerCaseExact(List: PShortString;
+  MaxValue: integer; aValue: PUtf8Char; aValueLen: PtrInt): integer;
+var
+  PLen: PtrInt;
+begin
+  if aValueLen <> 0 then
+    for result := 0 to MaxValue do
+    begin
+      PLen := ord(List^[0]);
+      inc(PUtf8Char(List));
+      repeat
+        if not (PUtf8Char(List)^ in ['a'..'z']) then
+          break;
+        inc(PUtf8Char(List));
+        dec(PLen);
+      until PLen = 0;
+      if (PLen = aValueLen) and
+         CompareMemSmall(aValue, List, PLen) then
+        exit;
+      inc(PUtf8Char(List), PLen);
+    end;
+  result := -1;
+end;
+
+function UnCamelCase(const S: RawUtf8): RawUtf8;
+var
+  tmp: TSynTempBuffer;
+  destlen: PtrInt;
+begin
+  if S = '' then
+    result := ''
+  else
+  begin
+    destlen := UnCamelCase(tmp.Init(length(S) * 2), pointer(S));
+    tmp.Done(PAnsiChar(tmp.buf) + destlen, result);
+  end;
+end;
+
+function UnCamelCase(D, P: PUtf8Char): integer;
+var
+  Space, SpaceBeg, DBeg: PUtf8Char;
+  CapitalCount: integer;
+  Number: boolean;
+label
+  Next;
+begin
+  DBeg := D;
+  if (D <> nil) and
+     (P <> nil) then
+  begin
+    // avoid GPF
+    Space := D;
+    SpaceBeg := D;
+    repeat
+      CapitalCount := 0;
+      Number := P^ in ['0'..'9'];
+      if Number then
+        repeat
+          inc(CapitalCount);
+          D^ := P^;
+          inc(P);
+          inc(D);
+        until not (P^ in ['0'..'9'])
+      else
+        repeat
+          inc(CapitalCount);
+          D^ := P^;
+          inc(P);
+          inc(D);
+        until not (P^ in ['A'..'Z']);
+      if P^ = #0 then
+        break; // no lowercase conversion of last fully uppercased word
+      if (CapitalCount > 1) and
+         not Number then
+      begin
+        dec(P);
+        dec(D);
+      end;
+      while P^ in ['a'..'z'] do
+      begin
+        D^ := P^;
+        inc(D);
+        inc(P);
+      end;
+      if P^ = '_' then
+        if P[1] = '_' then
+        begin
+          D^ := ':';
+          inc(P);
+          inc(D);
+          goto Next;
+        end
+        else
+        begin
+          PWord(D)^ := ord(' ') + ord('-') shl 8;
+          inc(D, 2);
+Next:     if Space = SpaceBeg then
+            SpaceBeg := D + 1;
+          inc(P);
+          Space := D + 1;
+        end
+      else
+        Space := D;
+      if P^ = #0 then
+        break;
+      D^ := ' ';
+      inc(D);
+    until false;
+    if Space > DBeg then
+      dec(Space);
+    while Space > SpaceBeg do
+    begin
+      if Space^ in ['A'..'Z'] then
+        if not (Space[1] in ['A'..'Z', ' ']) then
+          inc(Space^, 32); // lowercase conversion of not last fully uppercased word
+      dec(Space);
+    end;
+  end;
+  result := D - DBeg;
+end;
+
+procedure CamelCase(P: PAnsiChar; len: PtrInt; var s: RawUtf8; const isWord: TSynByteSet);
+var
+  i: PtrInt;
+  d: PAnsiChar;
+  tmp: array[byte] of AnsiChar;
+begin
+  if len > SizeOf(tmp) then
+    len := SizeOf(tmp);
+  for i := 0 to len - 1 do
+    if not (ord(P[i]) in isWord) then
+    begin
+      if i > 0 then
+      begin
+        MoveFast(P^, tmp, i);
+        inc(P, i);
+        dec(len, i);
+      end;
+      d := @tmp[i];
+      while len > 0 do
+      begin
+        while (len > 0) and
+              not (ord(P^) in isWord) do
+        begin
+          inc(P);
+          dec(len);
+        end;
+        if len = 0 then
+          break;
+        d^ := NormToUpperAnsi7[P^];
+        inc(d);
+        repeat
+          inc(P);
+          dec(len);
+          if not (ord(P^) in isWord) then
+            break;
+          d^ := P^;
+          inc(d);
+        until len = 0;
+      end;
+      P := @tmp;
+      len := d - tmp;
+      break;
+    end;
+  FastSetString(s, P, len);
+end;
+
+procedure CamelCase(const text: RawUtf8; var s: RawUtf8; const isWord: TSynByteSet);
+begin
+  CamelCase(pointer(text), length(text), s, isWord);
+end;
+
+procedure GetCaptionFromPCharLen(P: PUtf8Char; out result: string);
+var
+  Temp: array[byte] of AnsiChar;
+begin
+  if P = nil then
+    exit;
+  {$ifdef UNICODE}
+  Utf8DecodeToUnicodeString(Temp, UnCamelCase(@Temp, P), result);
+  {$else}
+  SetString(result, PAnsiChar(@Temp), UnCamelCase(@Temp, P));
+  {$endif UNICODE}
+  if Assigned(LoadResStringTranslate) then
+    LoadResStringTranslate(result);
+end;
+
+
+{ ************ TRawUtf8DynArray Processing Functions }
+
+function IsZero(const Values: TRawUtf8DynArray): boolean;
+var
+  i: PtrInt;
+begin
+  result := false;
+  for i := 0 to length(Values) - 1 do
+    if Values[i] <> '' then
+      exit;
+  result := true;
+end;
+
+function TRawUtf8DynArrayFrom(const Values: array of RawUtf8): TRawUtf8DynArray;
+var
+  i: PtrInt;
+begin
+  Finalize(result);
+  SetLength(result, length(Values));
+  for i := 0 to high(Values) do
+    result[i] := Values[i];
+end;
+
+function FindRawUtf8(Values: PRawUtf8; const Value: RawUtf8; ValuesCount: integer;
+  CaseSensitive: boolean): integer;
+var
+  ValueLen: TStrLen;
+begin
+  dec(ValuesCount);
+  ValueLen := length(Value);
+  if ValueLen = 0 then
+    for result := 0 to ValuesCount do
+      if Values^ = '' then
+        exit
+      else
+        inc(Values)
+  else if CaseSensitive then
+    for result := 0 to ValuesCount do
+      if (PtrUInt(Values^) <> 0) and
+         ({%H-}PStrLen(PtrUInt(Values^) - _STRLEN)^ = ValueLen) and
+         CompareMemFixed(pointer(PtrInt(Values^)), pointer(Value), ValueLen) then
+        exit
+      else
+        inc(Values)
+  else
+    for result := 0 to ValuesCount do
+      if (PtrUInt(Values^) <> 0) and // StrIComp() won't change length
+         ({%H-}PStrLen(PtrUInt(Values^) - _STRLEN)^ = ValueLen) and
+         (StrIComp(pointer(Values^), pointer(Value)) = 0) then
+        exit
+      else
+        inc(Values);
+  result := -1;
+end;
+
+function FindRawUtf8(const Values: TRawUtf8DynArray; const Value: RawUtf8;
+  CaseSensitive: boolean): integer;
+begin
+  result := FindRawUtf8(pointer(Values), Value, length(Values), CaseSensitive);
+end;
+
+function FindRawUtf8(const Values: array of RawUtf8; const Value: RawUtf8;
+  CaseSensitive: boolean): integer;
+begin
+  result := high(Values);
+  if result >= 0 then
+    result := FindRawUtf8(@Values[0], Value, result + 1, CaseSensitive);
+end;
+
+function AddRawUtf8(var Values: TRawUtf8DynArray; const Value: RawUtf8;
+  NoDuplicates, CaseSensitive: boolean): boolean;
+var
+  i: PtrInt;
+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 AddRawUtf8(var Values: TRawUtf8DynArray; var ValuesCount: integer;
+  const Value: RawUtf8): PtrInt;
+begin
+  result := ValuesCount;
+  if result = Length(Values) then
+    SetLength(Values, NextGrow(result));
+  Values[result] := Value;
+  inc(ValuesCount);
+end;
+
+procedure AddRawUtf8(var Values: TRawUtf8DynArray; const Value: TRawUtf8DynArray);
+var
+  n, o, i: PtrInt;
+begin
+  n := length(Value);
+  if n = 0 then
+    exit;
+  o := length(Values);
+  SetLength(Values, o + n);
+  for i := 0 to n - 1 do
+    Values[o + i] := Value[i];
+end;
+
+procedure AddRawUtf8(var Values: TRawUtf8DynArray; var ValuesCount: integer;
+  const Value: TRawUtf8DynArray);
+var
+  n, o, i: PtrInt;
+begin
+  n := length(Value);
+  o := ValuesCount;
+  inc(ValuesCount, n);
+  if ValuesCount > Length(Values) then
+    SetLength(Values, NextGrow(ValuesCount));
+  for i := 0 to n - 1 do
+    Values[o + i] := Value[i];
+end;
+
+function RawUtf8DynArrayEquals(const A, B: TRawUtf8DynArray): boolean;
+var
+  n, i: PtrInt;
+begin
+  result := false;
+  n := length(A);
+  if n <> length(B) then
+    exit;
+  for i := 0 to n - 1 do
+    if A[i] <> B[i] then
+      exit;
+  result := true;
+end;
+
+function RawUtf8DynArrayEquals(const A, B: TRawUtf8DynArray; Count: integer): boolean;
+var
+  i: PtrInt;
+begin
+  result := false;
+  for i := 0 to Count - 1 do
+    if A[i] <> B[i] then
+      exit;
+  result := true;
+end;
+
+function AddString(var Values: TStringDynArray; const Value: string): PtrInt;
+begin
+  result := length(Values);
+  SetLength(Values, result + 1);
+  Values[result] := Value;
+end;
+
+procedure StringDynArrayToRawUtf8DynArray(const Source: TStringDynArray;
+  var Result: TRawUtf8DynArray);
+var
+  i: PtrInt;
+begin
+  Finalize(Result);
+  SetLength(Result, length(Source));
+  for i := 0 to length(Source) - 1 do
+    StringToUtf8(Source[i], Result[i]);
+end;
+
+procedure StringListToRawUtf8DynArray(Source: TStringList; var Result: TRawUtf8DynArray);
+var
+  i: PtrInt;
+begin
+  Finalize(Result);
+  SetLength(Result, Source.Count);
+  for i := 0 to Source.Count - 1 do
+    StringToUtf8(Source[i], Result[i]);
+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
+      {$ifdef CPUX64}
+      i := L + R;
+      i := i shr 1;
+      {$else}
+      i := (L + R) shr 1;
+      {$endif CPUX64}
+      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
+      {$ifdef CPUX64}
+      result := L + R;
+      result := result shr 1;
+      {$else}
+      result := (L + R) shr 1;
+      {$endif CPUX64}
+      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;
+
+{$ifdef CPUX64}
+
+function FastFindPUtf8CharSorted(P: PPUtf8CharArray; R: PtrInt; Value: PUtf8Char): PtrInt;
+{$ifdef FPC} assembler; nostackframe; asm {$else} asm .noframe {$endif}
+        {$ifdef win64}  // P=rcx/rdi R=rdx/rsi Value=r8/rdx
+        push    rdi
+        mov     rdi, P  // P=rdi
+        {$endif win64}
+        push    r12
+        push    r13
+        xor     r9, r9  // L=r9
+        test    R, R
+        jl      @err
+        test    Value, Value
+        jz      @void
+        mov     cl, byte ptr [Value]  // to check first char (likely diverse)
+@s:     lea     rax, qword ptr [r9 + R]
+        shr     rax, 1
+        lea     r12, qword ptr [rax - 1]  // branchless main loop
+        lea     r13, qword ptr [rax + 1]
+        mov     r10, qword ptr [rdi + rax * 8]
+        test    r10, r10
+        jz      @lt
+        cmp     cl, byte ptr [r10]
+        je      @eq
+        cmovc   R, r12
+        cmovnc  r9, r13
+@nxt:   cmp     r9, R
+        jle     @s
+@err:   mov     rax, -1
+@found: pop     r13
+        pop     r12
+        {$ifdef win64}
+        pop     rdi
+        {$endif win64}
+        ret
+@lt:    mov     r9, r13 // very unlikely P[rax]=nil
+        jmp     @nxt
+@eq:    mov     r11, Value // first char equal -> check others
+@sub:   mov     cl, byte ptr [r10]
+        add     r10, 1
+        add     r11, 1
+        test    cl, cl
+        jz      @found
+        mov     cl, byte ptr [r11]
+        cmp     cl, byte ptr [r10]
+        je      @sub
+        mov     cl, byte ptr [Value]  // reset first char
+        cmovc   R, r12
+        cmovnc  r9, r13
+        cmp     r9, R
+        jle     @s
+        jmp     @err
+@void:  mov     rax, -1
+        cmp     qword ptr [P], 0
+        cmove   rax, Value
+        jmp     @found
+end;
+
+{$else}
+
+function FastFindPUtf8CharSorted(P: PPUtf8CharArray; R: PtrInt; Value: PUtf8Char): PtrInt;
+var
+  L: PtrInt;
+  c: byte;
+  piv, val: PByte;
+begin
+  // fast O(log(n)) binary search using inlined StrCompFast()
+  if R >= 0 then
+    if Value <> nil then
+    begin
+      L := 0;
+      repeat
+        result := L + R;
+        result := result shr 1;
+        piv := pointer(P^[result]);
+        if piv <> nil then
+        begin
+          val := pointer(Value);
+          c := piv^;
+          if c = val^ then
+            repeat
+              if c = 0 then
+                exit;  // StrComp(P^[result],Value)=0
+              inc(piv);
+              inc(val);
+              c := piv^;
+            until c <> val^;
+          if c > val^ then
+          begin
+            R := result - 1;  // StrComp(P^[result],Value)>0
+            if L <= R then
+              continue;
+            break;
+          end;
+        end;
+        L := result + 1;  // StrComp(P^[result],Value)<0
+        if L <= R then
+          continue;
+        break;
+      until false;
+    end
+    else if P^[0] = nil then
+    begin
+      // '' should be in lowest P[] slot
+      result := 0;
+      exit;
+    end;
+  result := -1;
+end;
+
+{$endif CPUX64}
+
+function FastFindUpperPUtf8CharSorted(P: PPUtf8CharArray; R: PtrInt;
+  Value: PUtf8Char; ValueLen: PtrInt): PtrInt;
+var
+  tmp: array[byte] of AnsiChar;
+begin
+  UpperCopy255Buf(@tmp, Value, ValueLen)^ := #0;
+  result := FastFindPUtf8CharSorted(P, R, @tmp);
+end;
+
+function FastFindIndexedPUtf8Char(P: PPUtf8CharArray; R: PtrInt;
+  var SortedIndexes: TCardinalDynArray; Value: PUtf8Char;
+  ItemComp: TUtf8Compare): PtrInt;
+var
+  L, cmp: PtrInt;
+begin
+  // fast O(log(n)) binary search
+  L := 0;
+  if 0 <= R then
+    repeat
+      {$ifdef CPUX64}
+      result := L + R;
+      result := result shr 1;
+      {$else}
+      result := (L + R) shr 1;
+      {$endif CPUX64}
+      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 result < n then
+  begin
+    n := (n - result) * SizeOf(pointer);
+    MoveFast(Pointer(Values[result]), Pointer(Values[result + 1]), n);
+    PtrInt(Values[result]) := 0; // avoid GPF
+    if CoValues <> nil then
+    begin
+      {$ifdef CPU64} n := n shr 1; {$endif} // 64-bit pointer to 32-bit integer
+      MoveFast(CoValues^[result], CoValues^[result + 1], n);
+    end;
+  end
+  else
+    result := n;
+  Values[result] := Value;
+  inc(ValuesCount);
+end;
+
+type
+  /// used internally for faster quick sort
+  {$ifdef USERECORDWITHMETHODS}
+  TQuickSortRawUtf8 = record
+  {$else}
+  TQuickSortRawUtf8 = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    Compare: TUtf8Compare;
+    CoValues: PIntegerArray;
+    pivot: pointer;
+    procedure Sort(Values: PPointerArray; L, R: PtrInt);
+  end;
+
+procedure TQuickSortRawUtf8.Sort(Values: PPointerArray; L, R: PtrInt);
+var
+  I, J, P: PtrInt;
+  tmp: Pointer;
+  int: integer;
+begin
+  if L < R then
+    repeat
+      I := L;
+      J := R;
+      P := (L + R) shr 1;
+      repeat
+        pivot := Values^[P];
+        while Compare(Values^[I], pivot) < 0 do
+          inc(I);
+        while Compare(Values^[J], pivot) > 0 do
+          dec(J);
+        if I <= J then
+        begin
+          tmp := Values^[J];
+          Values^[J] := Values^[I];
+          Values^[I] := tmp;
+          if CoValues <> nil then
+          begin
+            int := CoValues^[J];
+            CoValues^[J] := CoValues^[I];
+            CoValues^[I] := int;
+          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(Values, L, J);
+        L := I;
+      end
+      else
+      begin
+        if I < R then
+          Sort(Values, I, R);
+        R := J;
+      end;
+    until L >= R;
+end;
+
+procedure QuickSortRawUtf8(var Values: TRawUtf8DynArray; ValuesCount: integer;
+  CoValues: PIntegerDynArray; Compare: TUtf8Compare);
+var
+  QS: TQuickSortRawUtf8;
+begin
+  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(pointer(Values), 0, ValuesCount - 1);
+end;
+
+procedure QuickSortRawUtf8(Values: PRawUtf8Array; L, R: PtrInt;
+  caseInsensitive: boolean);
+var
+  QS: TQuickSortRawUtf8;
+begin
+  QS.Compare := StrCompByCase[caseInsensitive];
+  QS.CoValues := nil;
+  QS.Sort(pointer(Values), L, R);
+end;
+
+procedure MakeUniqueArray(var Values: TRawUtf8DynArray);
+begin
+  Values := copy(Values); // sub-proc to avoid try..finally
+end;
+
+function DeleteRawUtf8(var Values: TRawUtf8DynArray; Index: PtrInt): boolean;
+var
+  n: PtrInt;
+begin
+  n := length(Values);
+  if PtrUInt(Index) >= PtrUInt(n) then
+    result := false
+  else
+  begin
+    dec(n);
+    if PDACnt(PAnsiChar(pointer(Values)) - _DACNT)^ > 1 then
+      MakeUniqueArray(Values);
+    Values[Index] := ''; // avoid GPF
+    if n > Index then
+    begin
+      MoveFast(pointer(Values[Index + 1]), pointer(Values[Index]),
+        (n - Index) * SizeOf(pointer));
+      PtrUInt(Values[n]) := 0; // avoid GPF
+    end;
+    SetLength(Values, n);
+    result := true;
+  end;
+end;
+
+function DeleteRawUtf8(var Values: TRawUtf8DynArray; var ValuesCount: integer;
+  Index: integer; CoValues: PIntegerDynArray): boolean;
+var
+  n: integer;
+begin
+  n := ValuesCount;
+  if cardinal(Index) >= cardinal(n) then
+    result := false
+  else
+  begin
+    dec(n);
+    ValuesCount := n;
+    if PDACnt(PAnsiChar(pointer(Values)) - _DACNT)^ > 1 then
+      MakeUniqueArray(Values);
+    Values[Index] := ''; // avoid GPF
+    dec(n, Index);
+    if n > 0 then
+    begin
+      if CoValues <> nil then
+        MoveFast(CoValues^[Index + 1], CoValues^[Index], n * SizeOf(integer));
+      MoveFast(pointer(Values[Index + 1]), pointer(Values[Index]), n * SizeOf(pointer));
+      PtrUInt(Values[ValuesCount]) := 0; // avoid GPF
+    end;
+    result := true;
+  end;
+end;
+
+{$ifdef OSPOSIX}
+
+{ TPosixFileCaseInsensitive }
+
+constructor TPosixFileCaseInsensitive.Create(
+  const aFolder: TFileName; aSubFolders: boolean);
+begin
+  fFolder := aFolder;
+  fSubFolders := aSubFolders;
+  fFlushSeconds := 60;
+end;
+
+procedure TPosixFileCaseInsensitive.SetFolder(const aFolder: TFileName);
+begin
+  if self = nil then
+    exit;
+  fSafe.WriteLock;
+  try
+    fFiles := nil; // force list refresh
+    fFolder := aFolder;
+  finally
+    fSafe.WriteUnLock;
+  end;
+end;
+
+procedure TPosixFileCaseInsensitive.SetSubFolders(aSubFolders: boolean);
+begin
+  if (self = nil) or
+     (fSubFolders = aSubFolders) then
+    exit;
+  fSubFolders := aSubFolders;
+  Flush;
+end;
+
+procedure TPosixFileCaseInsensitive.OnIdle(tix64: Int64);
+begin
+  if (self = nil) or
+     (fFiles = nil) or
+     (fFlushSeconds = 0) then
+    exit;
+  if tix64 = 0 then
+    tix64 := GetTickCount64;
+  if tix64 shr 10 < fNextTix then
+    exit;
+  fSafe.WriteLock;
+  try
+    fFiles := nil; // force list refresh
+  finally
+    fSafe.WriteUnLock;
+  end;
+end;
+
+procedure TPosixFileCaseInsensitive.Flush;
+begin
+  SetFolder(fFolder);
+end;
+
+function TPosixFileCaseInsensitive.Find(const aSearched: TFileName;
+  aReadMs: PInteger): TFileName;
+var
+  start, stop: Int64;
+  i: PtrInt;
+  fn: RawUtf8;
+begin
+  result := '';
+  if aReadMs <> nil then
+    aReadMs^ := 0;
+  if (self = nil) or
+     (fFolder = '') or
+     (aSearched = '') then
+    exit;
+  if fFiles = nil then // need to refresh the cache
+  begin
+    fSafe.WriteLock;
+    try
+      if fFiles = nil then
+      begin
+        if aReadMs <> nil then
+          QueryPerformanceMicroSeconds(start);
+        fFiles := PosixFileNames(fFolder, fSubFolders); // fast syscall
+        QuickSortRawUtf8(fFiles, length(fFiles), nil, @StrIComp);
+        // e.g. 4392 filenames from /home/ab/dev/lib/ in 7.20ms
+        if aReadMs <> nil then
+        begin
+          QueryPerformanceMicroSeconds(stop);
+          aReadMs^ := stop - start;
+        end;
+        if fFlushSeconds <> 0 then
+          fNextTix := (GetTickCount64 shr 10) + fFlushSeconds;
+      end;
+    finally
+      fSafe.WriteUnLock;
+    end;
+  end;
+  StringToUtf8(aSearched, fn);
+  fSafe.ReadLock; // non-blocking lookup
+  try
+    i := FastFindPUtf8CharSorted( // efficient O(log(n)) binary search
+      pointer(fFiles), high(fFiles), pointer(fn), @StrIComp);
+    if i >= 0 then
+      Utf8ToFileName(fFiles[i], result); // use exact file name case from OS
+  finally
+    fSafe.ReadUnLock;
+  end;
+end;
+
+function TPosixFileCaseInsensitive.Count: PtrInt;
+begin
+  if self = nil then
+    result := 0
+  else
+    result := length(fFiles);
+end;
+
+function TPosixFileCaseInsensitive.Files: TRawUtf8DynArray;
+begin
+  result := nil;
+  if (self = nil) or
+     (fFiles = nil) then
+    exit;
+  fSafe.ReadLock;
+  try
+    result := copy(fFiles); // make a copy for thread safety
+  finally
+    fSafe.ReadUnLock;
+  end;
+end;
+
+{$endif OSPOSIX}
+
+
+{ ************** Operating-System Independent Unicode Process }
+
+// freely inspired by Bero's PUCU library, released under zlib license
+//  https://github.com/BeRo1985/pucu  (C)2016-2020 Benjamin Rosseaux
+
+{$define UU_COMPRESSED}
+// 1KB compressed static table in the exe renders into our 20KB UU[] array :)
+
+type
+  // 20,016 bytes for full Unicode 10.0 case folding branchless conversion
+  {$ifdef USERECORDWITHMETHODS}
+  TUnicodeUpperTable = record
+  {$else}
+  TUnicodeUpperTable = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    Block: array[0..37, 0..127] of integer;
+    IndexHi: array[0..271] of byte;
+    IndexLo: array[0..8, 0..31] of byte;
+    // branchless Unicode 10.0 uppercase folding using our internal tables
+    // caller should have checked that c <= UU_MAX
+    function Ucs4Upper(c: PtrUInt): PtrUInt;
+      {$ifdef HASINLINE} inline; {$endif}
+  end;
+  {$ifndef CPUX86NOTPIC}
+  PUnicodeUpperTable = ^TUnicodeUpperTable;
+  {$endif CPUX86NOTPIC}
+
+const
+  UU_BLOCK_HI = 7;
+  UU_BLOCK_LO = 127;
+  UU_INDEX_HI = 5;
+  UU_INDEX_LO = 31;
+  UU_MAX = $10ffff;
+
+var
+  {$ifdef UU_COMPRESSED}
+  UU: TUnicodeUpperTable;
+  {$else}
+  UU: TUnicodeUpperTable = (
+    Block: (
+     (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, 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,
+      -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32,
+      -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, 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, 743, 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, -32, -32, -
+      32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32,
+      -32, -32, -32, -32, -32, -32, 0, -32, -32, -32, -32, -32, -32, -32, 121),
+     (0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, -1, 0, -1, 0, -232, 0, -1, 0, -1, 0, -1, 0, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, 0, -1, 0, -1, 0, -1, -300),
+     (195, 0, 0, -1, 0, -1, 0, 0, -1, 0, 0, 0, -1, 0, 0, 0, 0, 0, -1, 0,
+      0, 97, 0, 0, 0, -1, 163, 0, 0, 0, 130, 0, 0, -1, 0, -1, 0, -1, 0, 0, -1, 0,
+      0, 0, 0, -1, 0, 0, -1, 0, 0, 0, -1, 0, -1, 0, 0, -1, 0, 0, 0, -1, 0, 56, 0,
+      0, 0, 0, 0, -1, -2, 0, -1, -2, 0, -1, -2, 0, -1, 0, -1, 0, -1, 0, -1, 0, -
+      1, 0, -1, 0, -1, 0, -1, -79, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, 0, -1, -2, 0, -1, 0, 0, 0, -1, 0, -1, 0, -1, 0, -1),
+     (0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, 0, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, 0, 0, 0, 0, 0, 0, 0, -1, 0, 0, 10815,
+      10815, 0, -1, 0, 0, 0, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 10783, 10780,
+      10782, -210, -206, 0, -205, -205, 0, -202, 0, -203, 42319, 0, 0, 0, -205,
+      42315, 0, -207, 0, 42280, 42308, 0, -209, -211, 42308, 10743, 42305, 0, 0,
+      -211, 0, 10749, -213, 0, 0, -214, 0, 0, 0, 0, 0, 0, 0, 10727, 0, 0),
+     (-218, 0, 0, -218, 0, 0, 0, 42282, -218, -69, -217, -217, -71, 0, 0, 0, 0, 0,
+      -219, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42261, 42258, 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, 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, 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, 84, 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, 0, -1, 0, 0, 0, -1, 0, 0, 0, 130, 130, 130, 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, -38, -37, -37, -37, 0, -32,
+      -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32,
+      -32, -31, -32, -32, -32, -32, -32, -32, -32, -32, -32, -64, -63, -63, 0,
+      -62, -57, 0, 0, 0, -47, -54, -8, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, -86, -80, 7, -116, 0, -96, 0, 0,
+      -1, 0, 0, -1, 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, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32,
+      -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32,
+      -32, -32, -32, -32, -32, -32, -80, -80, -80, -80, -80, -80, -80, -80, -80,
+      -80, -80, -80, -80, -80, -80, -80, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1),
+     (0, -1, 0, 0, 0, 0, 0, 0, 0, 0, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, -15, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1),
+     (0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, -1, 0, -1, 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, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48,
+      -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48,
+      -48, -48, -48, -48, -48),
+     (-48, -48, -48, -48, -48, -48, -48, 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, 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,
+      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, 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, 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, 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, -8, -8, -8,
+      -8, -8, -8, 0, 0),
+     (-6254, -6253, -6244, -6242, -6242, -6243, -6236, -6181, 35266, 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, 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, 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, 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, 35332, 0, 0, 0, 3814, 0, 0),
+     (0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1),
+     (0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, 0, 0, 0, 0, -59, 0, 0, 0, 0, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1),
+     (8, 8, 8, 8, 8, 8, 8, 8, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 8, 8, 8, 8, 0,
+      0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 8, 8, 8, 8, 8, 8, 0, 0, 0, 0, 0, 0, 0, 0,
+      8, 8, 8, 8, 8, 8, 8, 8, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 8, 8, 8, 8, 0, 0, 0,
+      0, 0, 0, 0, 0, 0, 0, 0, 8, 0, 8, 0, 8, 0, 8, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8,
+      8, 8, 8, 8, 8, 8, 0, 0, 0, 0, 0, 0, 0, 0, 74, 74, 86, 86, 86, 86, 100, 100,
+      128, 128, 112, 112, 126, 126, 0, 0),
+     (8, 8, 8, 8, 8, 8, 8, 8, 0, 0, 0, 0,
+      0, 0, 0, 0, 8, 8, 8, 8, 8, 8, 8, 8, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 8, 8, 8,
+      8, 8, 8, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 0, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+      -7205, 0, 0, 0, 0, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 0, 0, 0, 0,
+      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 0, 0, 0, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+      0, 0, 0, 0, 9, 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, 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, -28, 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, -16, -16, -16, -16, -16, -16, -16, -16, -16, -16, -16,
+      -16, -16, -16, -16, -16),
+     (0, 0, 0, 0, -1, 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, 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, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -26, -26, -26, -26,
+      -26, -26, -26, -26, -26, -26, -26, -26, -26, -26, -26, -26, -26, -26, -26,
+      -26, -26, -26, -26, -26, -26, -26, 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, 0, 0, 0, 0, 0, 0, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48,
+      -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48,
+      -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48, -48,
+      -48, -48, -48, -48, -48, -48, -48, 0, 0, -1, 0, 0, 0, -10795, -10792, 0, -1,
+      0, -1, 0, -1, 0, 0, 0, 0, 0, 0, -1, 0, 0, -1, 0, 0, 0, 0, 0, 0, 0, 0, 0),
+     (0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, 0, 0, 0, 0, 0, 0,
+      0, -1, 0, -1, 0, 0, 0, 0, -1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
+     (-7264, -7264, -7264, -7264, -7264, -7264, -7264, -7264, -7264, -7264, -7264,
+      -7264, -7264, -7264, -7264, -7264, -7264, -7264, -7264, -7264, -7264, -7264,
+      -7264, -7264, -7264, -7264, -7264, -7264, -7264, -7264, -7264, -7264, -7264,
+      -7264, -7264, -7264, -7264, -7264, 0, -7264, 0, 0, 0, 0, 0, -7264, 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, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1,
+      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
+     (0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 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, 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, 0, 0, 0, 0, 0, 0, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, 0, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1,
+      0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      -1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -1, 0, -1, 0, 0, -1),
+     (0, -1, 0, -1, 0,  -1, 0, -1, 0, 0, 0, 0, -1, 0, 0, 0, 0, -1, 0, -1, 0, 0,
+      0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0, -1, 0,
+      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -1, 0, -1, 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, 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, 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, -928, 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, -38864, -38864,
+      -38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864,
+      -38864, -38864, -38864, -38864, -38864),
+     (-38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864,
+      -38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864,
+      -38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864,
+      -38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864,
+      -38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864,
+      -38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864,
+      -38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864, -38864,
+      -38864, 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),
+     (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, 0, -32, -32, -32, -32, -32, -32,
+      -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32,
+      -32, -32, -32, -32, -32, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -40, -40, -40, -40,
+      -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40,
+      -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40,
+      -40, -40, -40, -40, -40, -40, 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,
+      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, 0, 0, 0, 0, 0, 0, 0, 0, -40, -40,
+      -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40,
+      -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40, -40,
+      -40, -40, -40, -40, 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, 0, 0, 0, 0,
+      -64, -64, -64, -64, -64, -64, -64, -64, -64, -64, -64, -64, -64, -64, -64,
+      -64, -64, -64, -64, -64, -64, -64, -64, -64, -64, -64, -64, -64, -64, -64,
+      -64, -64, -64, -64, -64, -64, -64, -64, -64, -64, -64, -64, -64, -64, -64,
+      -64, -64, -64, -64, -64, -64, 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,
+      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -32, -32, -32, -32, -32, -32, -32,
+      -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, -32,
+      -32, -32, -32, -32, -32, -32, -32, -32, -32, -32, 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, 0, 0, -34, -34, -34, -34, -34, -34, -34, -34, -34, -34,
+      -34, -34, -34, -34, -34, -34, -34, -34, -34, -34, -34, -34, -34, -34, -34,
+      -34, -34, -34, -34, -34, -34, -34, -34, -34, 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)
+    );
+    IndexHi: (0, 1, 2, 3, 3, 3, 3, 3, 3, 3, 4, 3, 3, 3, 3, 5, 6, 7, 3, 3, 3, 3,
+      3, 3, 3, 3, 3, 3, 3, 3, 8, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+      3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+      3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+      3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+      3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+      3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+      3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+      3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+      3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+      3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3);
+    IndexLo: ((0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 12, 12, 12, 12, 12, 12,
+      12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12), (12, 12, 12, 12, 12,
+      12, 12, 13, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,
+      12, 14, 15, 12, 16, 17, 18, 19), (12, 12, 20, 21, 12, 12, 12, 12, 12, 22,
+      12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 23, 24, 25, 12, 12,
+      12, 12, 12), (12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,
+      12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12), (12,
+      12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 26, 27, 28, 29, 12, 12, 12, 12,
+      12, 12, 30, 31, 12, 12, 12, 12, 12, 12, 12, 12), (12, 12, 12, 12, 12, 12,
+      12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,
+      12, 12, 12, 12, 12, 32, 12), (12, 12, 12, 12, 12, 12, 12, 12, 33, 34, 12,
+      12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 35, 12, 12, 12, 12,
+      12, 12), (12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,
+      12, 36, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12), (12, 12,
+      12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 37, 12, 12,
+      12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12));
+  );
+  {$endif UU_COMPRESSED}
+
+function TUnicodeUpperTable.Ucs4Upper(c: PtrUInt): PtrUInt;
+var
+  i: PtrUInt;
+begin
+  // branchless conversion of 0..UU_MAX = $10ffff Unicode codepoints
+  i := c shr UU_BLOCK_HI;
+  result := PtrInt(c) +
+            Block[IndexLo[IndexHi[i shr UU_INDEX_HI], i and UU_INDEX_LO],
+                  c and UU_BLOCK_LO];
+end;
+
+function Utf8UpperReference(S, D: PUtf8Char): PUtf8Char;
+var
+  c: PtrUInt;
+  S2: PUtf8Char;
+  {$ifdef CPUX86NOTPIC}
+  tab: TUnicodeUpperTable absolute UU;
+  {$else}
+  tab: PUnicodeUpperTable;
+  {$endif CPUX86NOTPIC}
+begin
+  {$ifndef CPUX86NOTPIC}
+  tab := @UU;
+  {$endif CPUX86NOTPIC}
+  if S <> nil then
+    repeat
+      c := ord(S^);
+      if c <= 127 then
+        if c = 0 then
+          break
+        else
+        begin
+          inc(c, tab.Block[0, c]); // branchless a..z -> A..Z
+          D^ := AnsiChar(c);
+          inc(S);
+          inc(D);
+          continue;
+        end
+      else if c and $20 = 0 then
+      begin
+        c := (c shl 6) + byte(S[1]) - $3080; // fast process $0..$7ff
+        inc(S, 2);
+      end
+      else
+      begin
+        S2 := S;
+        c := UTF8_TABLE.GetHighUtf8Ucs4(S2); // handle even surrogates
+        S := S2;
+        if c = 0 then
+          c := UNICODE_REPLACEMENT_CHARACTER; // =$fffd for invalid input
+      end;
+      if c <= UU_MAX then
+        c := tab.Ucs4Upper(c);
+      inc(D, Ucs4ToUtf8(c, D));
+    until false;
+  D^ := #0;
+  result := D;
+end;
+
+function Utf8UpperReference(S, D: PUtf8Char; SLen: PtrUInt): PUtf8Char;
+var
+  c: PtrUInt;
+  endSBy4: PUtf8Char;
+  extra, i: PtrInt;
+  {$ifdef CPUX86NOTPIC}
+  tab: TUnicodeUpperTable absolute UU;
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  tab: PUnicodeUpperTable;
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+label
+  by1, by4; // ugly but faster
+begin
+  if (S <> nil) and
+     (D <> nil) then
+  begin
+    {$ifndef CPUX86NOTPIC}
+    tab := @UU;
+    utf8 := @UTF8_TABLE;
+    {$endif CPUX86NOTPIC}
+    // first handle trailing 7-bit ASCII chars, by quad
+    inc(SLen, PtrUInt(S));
+    endSBy4 := PUtf8Char(SLen) - 4;
+    if {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}(PtrUInt(S) and 3 = 0) and {$endif}
+       (S <= endSBy4) then
+      repeat
+        if PCardinal(S)^ and $80808080 <> 0 then
+          goto by1; // break on first non ASCII quad
+by4:    i := byte(S[0]);
+        inc(i, tab.Block[0, i]); // branchless a..z -> A..Z
+        D[0] := AnsiChar(i);
+        i := byte(S[1]);
+        inc(i, tab.Block[0, i]);
+        D[1] := AnsiChar(i);
+        i := byte(S[2]);
+        inc(i, tab.Block[0, i]);
+        D[2] := AnsiChar(i);
+        i := byte(S[3]);
+        inc(i, tab.Block[0, i]);
+        D[3] := AnsiChar(i);
+        inc(S, 4);
+        inc(D, 4);
+      until S > endSBy4;
+    // generic loop, handling one UCS4 CodePoint per iteration
+    if S < PUtf8Char(SLen) then
+      repeat
+by1:    c := byte(S^);
+        inc(S);
+        if c <= 127 then
+        begin
+          inc(c, tab.Block[0, c]); // branchless a..z -> A..Z
+          D^ := AnsiChar(c);
+          inc(D);
+          if {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}(PtrUInt(S) and 3 = 0) and{$endif}
+             (S <= endSBy4) then
+            if PCardinal(S)^ and $80808080 = 0 then
+              goto By4
+            else
+              continue
+          else if S < PUtf8Char(SLen) then
+            continue
+          else
+            break;
+        end
+        else
+        begin
+          extra := utf8.Lookup[c];
+          if (extra = UTF8_INVALID) or
+             (S + extra > PUtf8Char(SLen)) then
+            break;
+          i := 0;
+          repeat
+            c := (c shl 6) + byte(S[i]);
+            inc(i)
+          until i = extra;
+          inc(S, extra);
+          with utf8.Extra[extra] do
+          begin
+            dec(c, offset);
+            if c < minimum then
+              break; // invalid input content
+          end;
+          if c <= UU_MAX then
+            c := tab.Ucs4Upper(c);
+          inc(D, Ucs4ToUtf8(c, D));
+          if S < PUtf8Char(SLen) then
+            continue
+          else
+            break;
+        end;
+      until false;
+    D^ := #0;
+  end;
+  result := D;
+end;
+
+function UpperCaseReference(const S: RawUtf8): RawUtf8;
+var
+  len: integer;
+  tmp: TSynTempBuffer;
+begin
+  len := length(S);
+  tmp.Init(len * 2); // some codepoints enhance in length
+  tmp.Done(Utf8UpperReference(pointer(S), tmp.buf, len), result);
+end;
+
+function UpperCaseUcs4Reference(const S: RawUtf8): RawUcs4;
+var
+  c, n: PtrUInt;
+  U: PUtf8Char;
+begin
+  if S = '' then
+  begin
+    result := nil;
+    exit;
+  end;
+  SetLength(result, length(S) + 1);
+  U := pointer(S);
+  n := 0;
+  repeat
+    c := NextUtf8Ucs4(U);
+    if c = 0 then
+      break;
+    if c <= UU_MAX then
+      c := UU.Ucs4Upper(c);
+    result[n] := c;
+    inc(n);
+  until false;
+  if n = 0 then
+    result := nil
+  else
+  begin
+    result[n] := 0; // always end with a 0
+    DynArrayFakeLength(result, n); // faster than SetLength()
+  end;
+end;
+
+function Utf8ICompReference(u1, u2: PUtf8Char): PtrInt;
+var
+  c2: PtrInt;
+  {$ifdef CPUX86NOTPIC}
+  tab: TUnicodeUpperTable absolute UU;
+  {$else}
+  tab: PUnicodeUpperTable;
+  {$endif CPUX86NOTPIC}
+label
+  c2low;
+begin
+  {$ifndef CPUX86NOTPIC}
+  tab := @UU;
+  {$endif CPUX86NOTPIC}
+  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);
+              inc(result, tab.Block[0, result]); // branchless a..z -> A..Z
+              if c2 <= 127 then
+              begin
+c2low:          if c2 = 0 then
+                  exit; // u1>u2 -> return u1^
+                inc(u2);
+                inc(c2, tab.Block[0, c2]);
+                dec(result, c2);
+                if result <> 0 then
+                  exit;
+                continue;
+              end;
+            end
+            else
+            begin
+              // result=u1^=#0 -> end of u1 reached
+              if c2 <> 0 then    // end of u2 reached -> u1=u2 -> return 0
+                result := -1;    // u1 0 then
+            exit;
+        until false
+      else
+        result := 1 // u2=''
+    else
+      result := -1  // u1=''
+  else
+    result := 0;    // u1=u2
+end;
+
+function Utf8ILCompReference(u1, u2: PUtf8Char; L1, L2: integer): PtrInt;
+var
+  c2: PtrInt;
+  extra, i: integer;
+  {$ifdef CPUX86NOTPIC}
+  tab: TUnicodeUpperTable absolute UU;
+  utf8: TUtf8Table absolute UTF8_TABLE;
+  {$else}
+  tab: PUnicodeUpperTable;
+  utf8: PUtf8Table;
+  {$endif CPUX86NOTPIC}
+label
+  neg, pos;
+begin
+  {$ifndef CPUX86NOTPIC}
+  tab := @UU;
+  utf8 := @UTF8_TABLE;
+  {$endif CPUX86NOTPIC}
+  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
+            inc(result, tab.Block[0, result]); // branchless a..z -> A..Z
+            if c2 <= 127 then
+            begin
+              inc(c2, tab.Block[0, c2]);
+              dec(L2);
+              inc(u2);
+              dec(result, c2);
+              if result <> 0 then
+                // found unmatching char
+                exit
+              else if L1 <> 0 then
+                if L2 <> 0 then
+                  // L1>0 and L2>0 -> next char
+                  continue
+                else
+                  // L1>0 and L2=0 -> u1>u2
+                  goto pos
+              else
+              if L2 <> 0 then
+                // L1=0 and L2>0 -> u1 u1=u2 -> returns 0
+                exit;
+            end;
+          end
+          else
+          begin
+            // fast Unicode 10.0 uppercase conversion
+            extra := utf8.Lookup[result];
+            if extra = UTF8_INVALID then
+              // invalid leading byte
+              goto neg;
+            dec(L1, extra);
+            if L1 < 0 then
+              goto neg;
+            i := 0;
+            repeat
+              result := result shl 6;
+              inc(result, ord(u1[i]));
+              inc(i);
+            until i = extra;
+            inc(u1, extra);
+            dec(result, utf8.Extra[extra].offset);
+            if PtrUInt(result) <= UU_MAX then
+              result := tab.Ucs4Upper(result);
+          end;
+          // here result=NormToUpper[u1^]
+          inc(u2);
+          dec(L2);
+          if c2 <= 127 then
+          begin
+            inc(c2, tab.Block[0, c2]);
+            dec(result, c2);
+            if result <> 0 then
+              // found unmatching codepoint
+              exit;
+          end
+          else
+          begin
+            extra := utf8.Lookup[c2];
+            if extra = UTF8_INVALID then
+              goto pos;
+            dec(L2, extra);
+            if L2 < 0 then
+              goto pos;
+            i := 0;
+            repeat
+              c2 := c2 shl 6;
+              inc(c2, ord(u2[i]));
+              inc(i);
+            until i = extra;
+            inc(u2, extra);
+            dec(c2, utf8.Extra[extra].offset);
+            if PtrUInt(c2) <= UU_MAX then
+              c2 := tab.Ucs4Upper(c2);
+            dec(result, c2);
+            if result <> 0 then
+              // found unmatching codepoint
+              exit;
+          end;
+          // here we have result=0
+          if L1 = 0 then
+            // test if we reached end of u1 or end of u2
+            if L2 = 0 then
+              // u1=u2
+              exit
+            else
+              // u1u2
+            goto pos;
+        until false
+      else
+pos:    // u2='' or u1>u2
+        result := 1
+    else
+neg:  // u1='' or u1 return nil
+      inc(c, tab.Block[0, c]); // branchless a..z -> A..Z
+      if c <> Up[0] then
+        continue;
+    end
+    else
+    begin
+      extra := utf8.Lookup[c];
+      if extra = UTF8_INVALID then
+        exit;
+      i := 0;
+      repeat
+        c := c shl 6;
+        inc(c, ord(U[i]));
+        inc(i);
+      until i = extra;
+      inc(U, extra);
+      dec(c, utf8.Extra[extra].offset);
+      if PtrUInt(c) <= UU_MAX then
+        c := tab.Ucs4Upper(c);
+      if c <> Up[0] then
+        continue;
+    end;
+    // if we reached here, U^ and Up^ first UCS4 CodePoint do match
+    u2 := U;
+    up2 := @Up[1];
+    repeat
+      if up2^ = 0 then
+      begin
+        result := u0; // found -> return position in U
+        exit;
+      end;
+      c := byte(u2^);
+      inc(u2);
+      if c <= 127 then
+      begin
+        if c = 0 then
+          exit; // not found -> return nil
+        inc(c, tab.Block[0, c]);
+        if c <> up2^ then
+          goto nxt;
+        inc(up2);
+      end
+      else
+      begin
+        extra := utf8.Lookup[c];
+        if extra = UTF8_INVALID then
+          exit; // invalid input
+        i := 0;
+        repeat
+          c := c shl 6;
+          inc(c, ord(u2[i]));
+          inc(i);
+        until i = extra;
+        inc(u2, extra);
+        dec(c, utf8.Extra[extra].offset);
+        if PtrUInt(c) <= UU_MAX then
+          c := tab.Ucs4Upper(c);
+        if c <> up2^ then
+          goto nxt;
+        inc(up2);
+      end;
+    until false;
+  until false;
+end;
+
+
+
+
+const
+  // reference 8-bit upper chars as in WinAnsi/CP1252 for NormToUpper/Lower[]
+  WinAnsiToUp: 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);
+
+{$ifdef UU_COMPRESSED}
+
+  // 1KB compressed buffer which renders into our 20,016 bytes UU[] array
+  UU_: array[byte] of cardinal = (
+    $040019FD, $FF5A6024, $00855A00, $FFFFFFE0, $5A5201F0, $02E700E8, $FFE0AA5A,
+    $E0045A4B, $5A790BFF, $045A0007, $A045A1FF, $DB1878BA, $01A82B01, $0145A000,
+    $1DA45008, $041E5A80, $401DA450, $5A8F185A, $FFFFFED4, $590B5AC3, $0C5A84A4,
+    $5314A453, $610008A4, $A4520F5A, $82F5A1A3, $F1EBB5AB, $5A44DDF7, $52105A84,
+    $5A845AA4, $5A4A5AC4, $5A385AC6, $11A45217, $10ABA500, $45A00200, $4F5A4401,
+    $0000B15A, $A05A4F04, $5A830145, $C65A0018, $5EBAA05A, $20245AC0, $85A1A452,
+    $5BB55700, $00002A3F, $065A2A3F, $5B04A453, $1F055A40, $A11C02A1, $02A11E02,
+    $3200012E, $45A10001, $C2000133, $3645A10C, $45A10001, $4F000135, $00550690,
+    $000E5AA5, $A54B0CC2, $013165A1, $2845A100, $440000A5, $012FAC02, $00012D00,
+    $F70A5144, $41000029, $000A5AA5, $2AC4A16B, $45A10D22, $2B0291FD, $85A10001,
+    $1C00022A, $A129E700, $000226A5, $0D930008, $512A000C, $BB0D920A, $05270001,
+    $0001B900, $0644145A, $25000107, $00280002, $120A5115, $F1F552A5, $54009C55,
+    $A453AF5A, $5AC45A44, $0082000C, $5A208400, $FFDA00BB, $AD6EFFFF, $09DB15D5,
+    $F045A100, $01E13201, $1201F000, $C10001C0, $45A10005, $C70001C2, $C5A10001,
+    $CA0001D1, $01F80001, $A045A100, $01AA33BA, $0001B000, $D0000007, $001EFBFB,
+    $A2FFFF8C, $0002A0AB, $85A15A83, $E0D0BAA2, $01F00BFF, $2E01F012, $04F004F2,
+    $3645A02A, $240D45A0, $5A44A459, $847E5A40, $115A405A, $400002F1, $45A0115A,
+    $CC5A400D, $1FD000C4, $01255507, $8202F000, $55F1F555, $00C955F4, $700001F8,
+    $85A10200, $FFFFE792, $9C018193, $859E0181, $01819D01, $DB0181A4, $89C20181,
+    $00C5F558, $3C90F1E4, $E5A18A04, $E5A10EE6, $5A40BAA2, $CC5A40CC, $01C50014,
+    $A045B100, $45AAFFBA, $00000008, $5A070080, $04800023, $80002B5A, $80000604,
+    $00000635, $BC2F5A0E, $00F75B6D, $D875A108, $050A30A7, $014A0009, $5604A200,
+    $056A0001, $42000164, $00018006, $01700802, $7E070200, $A17E0001, $070080B5,
+    $80080001, $00022635, $35860002, $C4304825, $810975A1, $01E3DBB5, $090010A5,
+    $8004335A, $80053B5A, $5A07000F, $F1CA0137, $E4006C55, $84A501FF, $0001F000,
+    $8E2A00F0, $5AEDC05B, $55F15B04, $002F55F4, $900001E6, $F5525201, $87FFD019,
+    $5A1202F0, $000C5A84, $FFFFD5D5, $AA02A1D8, $1845A545, $5A84A453, $40A45328,
+    $5A40CC5A, $FB5FC736, $445804BF, $305B045A, $01C1A000, $A182C5E0, $B1C5E245,
+    $F4C5E345, $A4504E55, $A4504C77, $1E55F441, $C417A450, $405A445A, $588A9C5A,
+    $5A405A84, $045B0406, $C05A445B, $592C2A5A, $C6F021A4, $6E55F49B, $01FC6000,
+    $300070A5, $60FFFF68, $0970FF7C, $F1F55219, $FFE00655, $35F55257, $0001D800,
+    $528A0270, $2255F1F5, $527F7FD0, $F20011F5, $00063B03, $B603F000, $E035F552,
+    $01F057FF, $09F55206, $0001DE00, $5A720210, $020100F1, $0403075A, $0503045A,
+    $0C5A0706, $F15A0803, $00000012, $03120103, $08675104, $5A0B0A09, $5A0D0C1B,
+    $0F0E0C11, $1211100C, $140C0C13, $0C055A15, $00005A16, $0C0E0000, $5A191817,
+    $1B1A0C31, $065A1D1C, $5A1F1E0C, $5A200C26, $22210C09, $230C0F5A, $0000175A,
+    $240C0000, $250C205A, $000C0D5A, $00000000);
+
+procedure InitializeUU;
+var
+  tmp: array[0..7000] of byte; // need only 6653 bytes
+begin
+  // Uppercase Unicode table RLE + SynLZ decompression from 1KB to 20KB :)
+  if (RleUnCompress(@tmp, @UU, SynLZdecompress1(@UU_, 1019, @tmp)) <> SizeOf(UU)) or
+     (crc32c(0, @UU, SizeOf(UU)) <> $7343D053) then
+    raise ESynUnicode.Create('UU Table Decompression Failed'); // paranoid
+end;
+
+{$endif UU_COMPRESSED}
+
+(*
+procedure doUU;
+var
+  tmp1, tmp2: array[0..5500] of cardinal;
+  rle, lz, i: PtrInt;
+  l: RawUtf8;
+begin
+  rle := RleCompress(@UU, @tmp1, SizeOf(UU), SizeOf(tmp1));
+  lz := SynLZCompress1(@tmp1, rle, @tmp2);
+  writeln(SizeOf(UU)); writeln(rle); writeln(lz);
+  writeln('UU_ = array[byte] of cardinal = ('); l := '  ';
+  for i := 0 to 255 do
+  begin
+    l := l + '$' + HexStr(tmp2[i], 8) + ',';
+    if length(l) > 70 then
+    begin
+      writeln(l);
+      l := '  ';
+    end;
+  end;
+  writeln(l, ');');
+end;
+*)
+
+procedure InitializeUnit;
+var
+  i: PtrInt;
+  c: AnsiChar;
+begin
+  // decompress 1KB static in the exe into 20KB UU[] array for Unicode Uppercase
+  {$ifdef UU_COMPRESSED}
+  InitializeUU;
+  {$endif UU_COMPRESSED}
+  // initialize internal lookup tables for various text conversions
+  for i := 0 to 255 do
+    NormToNormByte[i] := i;
+  NormToUpperAnsi7Byte := NormToNormByte;
+  for i := ord('a') to ord('z') do
+    dec(NormToUpperAnsi7Byte[i], 32);
+  NormToLowerAnsi7Byte := NormToNormByte;
+  for i := ord('A') to ord('Z') do
+    inc(NormToLowerAnsi7Byte[i], 32);
+  MoveFast(NormToUpperAnsi7, NormToUpper, 138);
+  MoveFast(WinAnsiToUp, NormToUpperByte[138], SizeOf(WinAnsiToUp));
+  for i := 0 to 255 do
+  begin
+    c := NormToUpper[AnsiChar(i)];
+    if c in ['A'..'Z'] then
+      inc(c, 32);
+    NormToLower[AnsiChar(i)] := c;
+  end;
+  for c := low(c) to high(c) do
+  begin
+    if not (c in [#0, #10, #13]) then
+      include(TEXT_CHARS[c], tcNot01013);
+    if c in [#10, #13] then
+      include(TEXT_CHARS[c], tc1013);
+    if c in ['0'..'9', 'a'..'z', 'A'..'Z'] then
+      include(TEXT_CHARS[c], tcWord);
+    if c in ['_', 'a'..'z', 'A'..'Z'] then
+      include(TEXT_CHARS[c], tcIdentifierFirstChar);
+    if c in ['_', '0'..'9', 'a'..'z', 'A'..'Z'] then
+      include(TEXT_CHARS[c], tcIdentifier);
+    if c in ['_', '-', '.', '0'..'9', 'a'..'z', 'A'..'Z'] then
+      // '~' is part of the RFC 3986 but should be escaped in practice
+      // see https://blog.synopse.info/?post/2020/08/11/The-RFC%2C-The-URI%2C-and-The-Tilde
+      include(TEXT_CHARS[c], tcUriUnreserved);
+    if c in [#1..#9, #11, #12, #14..' '] then
+      include(TEXT_CHARS[c], tcCtrlNotLF);
+    if c in [#1..' ', ';'] then
+      include(TEXT_CHARS[c], tcCtrlNot0Comma);
+  end;
+  // setup sorting functions redirection
+  StrCompByCase[false] := @StrComp;
+  StrCompByCase[true] := @StrIComp;
+  {$ifdef CPUINTEL}
+  SortDynArrayAnsiStringByCase[false] := @SortDynArrayAnsiString;
+  {$else}
+  SortDynArrayAnsiStringByCase[false] := @SortDynArrayRawByteString;
+  {$endif CPUINTEL}
+  SortDynArrayAnsiStringByCase[true] := @SortDynArrayAnsiStringI;
+  IdemPropNameUSameLen[false] := @IdemPropNameUSameLenNotNull;
+  IdemPropNameUSameLen[true] := @mormot.core.base.CompareMem;
+
+  // setup basic Unicode conversion engines
+  SetLength(SynAnsiConvertListCodePage, 16); // no resize -> more thread safe
+  CurrentAnsiConvert   := NewEngine(Unicode_CodePage);
+  WinAnsiConvert       := NewEngine(CP_WINANSI) as TSynAnsiFixedWidth;
+  Utf8AnsiConvert      := NewEngine(CP_UTF8) as TSynAnsiUtf8;
+  RawByteStringConvert := NewEngine(CP_RAWBYTESTRING) as TSynAnsiFixedWidth;
+  // setup optimized ASM functions
+  IsValidUtf8Buffer := @IsValidUtf8Pas;
+  {$ifdef ASMX64AVXNOCONST}
+  if cpuHaswell in X64CpuFeatures then
+    // Haswell CPUs can use simdjson AVX2 asm for IsValidUtf8()
+    IsValidUtf8Buffer := @IsValidUtf8Avx2;
+  {$endif ASMX64AVXNOCONST}
+end;
+
+
+initialization
+  InitializeUnit;
+
+
+end.
diff --git a/lib/dmustache/mormot.core.variants.pas b/lib/dmustache/mormot.core.variants.pas
new file mode 100644
index 00000000..33c0889f
--- /dev/null
+++ b/lib/dmustache/mormot.core.variants.pas
@@ -0,0 +1,12030 @@
+/// Framework Core Low-Level Variants / TDocVariant process
+// - this unit is a part of the Open Source Synopse mORMot framework 2,
+// licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+unit mormot.core.variants;
+
+{
+  *****************************************************************************
+
+  Variant / TDocVariant feature shared by all framework units
+  - Low-Level Variant Wrappers
+  - Custom Variant Types with JSON support
+  - TDocVariant Object/Array Document Holder with JSON support
+  - IDocList/IDocDict advanced Wrappers of TDocVariant Documents
+  - JSON Parsing into Variant
+  - Variant Binary Serialization
+
+  *****************************************************************************
+}
+
+interface
+
+{$I \mormot.defines.inc}
+
+uses
+  sysutils,
+  classes,
+  variants,
+  mormot.core.base,
+  mormot.core.os,
+  mormot.core.unicode,
+  mormot.core.text,
+  mormot.core.data, // already included in mormot.core.json
+  mormot.core.buffers,
+  mormot.core.rtti,
+  mormot.core.json;
+
+
+{ ************** Low-Level Variant Wrappers }
+
+type
+  /// exception class raised by this unit during raw Variant process
+  ESynVariant = class(ESynException);
+
+const
+  {$ifdef HASVARUSTRING}
+  varFirstCustom = varUString + 1;
+  {$else}
+  varFirstCustom = varAny + 1;
+  {$endif HASVARUSTRING}
+
+/// 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. floats or integer) would be considered as not void
+function VarIsVoid(const V: Variant): boolean;
+
+/// returns a supplied string as variant, or null if v is void ('')
+function VarStringOrNull(const v: RawUtf8): variant;
+
+type
+  /// a set of simple TVarData.VType, as specified to VarIs()
+  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}
+
+/// same as Dest := Source, but copying by reference
+// - i.e. VType is defined as varVariant or varByRef / varVariantByRef
+// - 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;
+
+/// convert an UTF-8 encoded text buffer into a variant RawUtf8 varString
+// - this overloaded version expects a destination variant type (e.g. varString
+// varOleStr / varUString) - if the type is not handled, will raise an
+// EVariantTypeCastError
+procedure RawUtf8ToVariant(const Txt: RawUtf8; var Value: TVarData;
+  ExpectedValueType: cardinal); overload;
+
+/// convert an open array (const Args: array of const) argument to a variant
+// - note that, due to a Delphi compiler limitation, cardinal values should be
+// type-casted to Int64() (otherwise the integer mapped value will be converted)
+// - vt*String or vtVariant arguments are returned as varByRef
+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)
+// - vt*String or vtVariant arguments are returned as varByRef
+function VarRecToVariant(const V: TVarRec): variant; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a variant to an open array (const Args: array of const) argument
+// - variant is accessed by reference as vtVariant so should remain available
+procedure VariantToVarRec(const V: variant; var result: TVarRec);
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert a variant array to open array (const Args: array of const) arguments
+// - variants are accessed by reference as vtVariant so should remain available
+procedure VariantsToArrayOfConst(const V: array of variant; VCount: PtrInt;
+  out result: TTVarRecDynArray); overload;
+
+/// convert a variant array to open array (const Args: array of const) arguments
+// - variants are accessed by reference as vtVariant so should remain available
+function VariantsToArrayOfConst(const V: array of variant): TTVarRecDynArray; overload;
+
+/// convert an array of RawUtf8 to open array (const Args: array of const) arguments
+// - RawUtf8 are accessed by reference as vtAnsiString so should remain available
+function RawUtf8DynArrayToArrayOfConst(const V: array of RawUtf8): TTVarRecDynArray;
+
+/// convert any Variant into a RTL 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; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// convert any Variant into a RTL string type
+procedure VariantToString(const V: Variant; var result: string); overload;
+
+/// convert a dynamic array of variants into its JSON serialization
+// - will use a TDocVariantData temporary storage
+function VariantDynArrayToJson(const V: TVariantDynArray): RawUtf8;
+
+/// convert a dynamic array of variants into its text values
+function VariantDynArrayToRawUtf8DynArray(const V: TVariantDynArray): TRawUtf8DynArray;
+
+/// 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
+  /// function prototype used internally for variant comparison
+  // - as used e.g. by TDocVariantData.SortByValue
+  TVariantCompare = function(const V1, V2: variant): PtrInt;
+  /// function prototype used internally for extended variant comparison
+  // - as used by TDocVariantData.SortByRow
+  TVariantComparer = function(const V1, V2: variant): PtrInt of object;
+  /// function prototype used internally for extended variant comparison
+  // - as used by TDocVariantData.SortArrayByFields
+  TVariantCompareField = function(const FieldName: RawUtf8;
+    const V1, V2: variant): PtrInt of object;
+
+/// internal function as called by inlined VariantCompare/VariantCompareI and
+// the SortDynArrayVariantComp() function overriden by this unit
+function FastVarDataComp(A, B: PVarData; caseInsensitive: boolean): integer;
+
+/// TVariantCompare-compatible case-sensitive comparison function
+// - just a wrapper around FastVarDataComp(caseInsensitive=false)
+function VariantCompare(const V1, V2: variant): PtrInt;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// TVariantCompare-compatible case-insensitive comparison function
+// - just a wrapper around FastVarDataComp(caseInsensitive=true)
+function VariantCompareI(const V1, V2: variant): PtrInt;
+  {$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 (varEmpty), null or false
+// - if CaseSensitive is false, will use PropNameEquals() for comparison
+function VariantEquals(const V: Variant; const Str: RawUtf8;
+  CaseSensitive: boolean = true): boolean; overload;
+
+/// return the TVarData.VType as text, e.g. 'Integer', 'String' or 'DocVariant'
+function VariantTypeName(V: PVarData): PShortString; overload;
+
+/// return the variant VType as text, e.g. 'Integer', 'String' or 'DocVariant'
+function VariantTypeName(const V: variant): PShortString; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+
+{ ************** Custom Variant Types with JSON support }
+
+type
+  /// define how our custom variant types behave, i.e. its methods featureset
+  TSynInvokeableVariantTypeOptions = set of (
+    sioHasTryJsonToVariant,
+    sioHasToJson,
+    sioCanIterate);
+
+  /// custom variant handler with easier/faster access of variant properties,
+  // and JSON serialization support
+  // - default GetProperty/SetProperty methods are called via some protected
+  // virtual IntGet/IntSet methods, with less overhead (to be overriden)
+  // - these kind of custom variants will be faster than the default
+  // TInvokeableVariantType for properties getter/setter, but you should
+  // manually register each type by calling SynRegisterCustomVariantType()
+  // - also feature custom JSON parsing, via TryJsonToVariant() protected method
+  TSynInvokeableVariantType = class(TInvokeableVariantType)
+  protected
+    fOptions: TSynInvokeableVariantTypeOptions;
+    {$ifdef ISDELPHI}
+    /// our custom call backs do not want the function names to be uppercased
+    function FixupIdent(const AText: string): string; override;
+    {$endif ISDELPHI}
+    // intercept for a faster direct IntGet/IntSet calls
+    // - note: SetProperty/GetProperty are never called by this class/method
+    // - also circumvent FPC 3.2+ inverted parameters order
+    {$ifdef FPC_VARIANTSETVAR}
+    procedure DispInvoke(Dest: PVarData; var Source: TVarData;
+      CallDesc: PCallDesc; Params: Pointer); override;
+    {$else} // see http://mantis.freepascal.org/view.php?id=26773
+    {$ifdef ISDELPHIXE7}
+    procedure DispInvoke(Dest: PVarData; [ref] const Source: TVarData;
+      CallDesc: PCallDesc; Params: Pointer); override;
+    {$else}
+    procedure DispInvoke(Dest: PVarData; const Source: TVarData;
+      CallDesc: PCallDesc; Params: Pointer); override;
+    {$endif ISDELPHIXE7}
+    {$endif FPC_VARIANTSETVAR}
+  public
+    /// virtual constructor which should set the custom type Options
+    constructor Create; virtual;
+    /// search of a registered custom variant type from its low-level VarType
+    // - will first compare with its own VarType for efficiency
+    // - returns true and set the matching CustomType if found, false otherwise
+    function FindSynVariantType(aVarType: cardinal;
+      out CustomType: TSynInvokeableVariantType): boolean; overload;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// search of a registered custom variant type from its low-level VarType
+    // - will first compare with its own VarType for efficiency
+    function FindSynVariantType(aVarType: cardinal): TSynInvokeableVariantType; overload;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// customization of JSON parsing into variants
+    // - is enabled only if the sioHasTryJsonToVariant option is set
+    // - will be called by e.g. by VariantLoadJson() or GetVariantFromJsonField()
+    // 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: TJsonWriter; Value: PVarData); overload; virtual;
+    /// save a variant as UTF-8 encoded JSON
+    // - implemented as a wrapper around ToJson()
+    procedure ToJson(Value: PVarData; var Json: RawUtf8;
+      const Prefix: RawUtf8 = ''; const Suffix: RawUtf8 = '';
+      Format: TTextWriterJsonFormat = jsonCompact); overload; virtual;
+    /// 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;
+    /// compare two items - this overriden method will redirect to Compare()
+    // - Delphi RTL does this redirection, where FPC does not (but should)
+    function CompareOp(const Left, Right: TVarData;
+      const Operation: TVarOp): boolean; override;
+    /// compare two items - overriden method calling case-sensitive IntCompare()
+    procedure Compare(const Left, Right: TVarData;
+      var Relationship: TVarCompareResult); 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'
+    // - return Unassigned (varEmpty) if the FullName does not match any value
+    // - will identify TDocVariant storage, or resolve and call the generic
+    // TSynInvokeableVariantType.IntGet() method until nested value match
+    // - you can set e.g. PathDelim = '/' to search e.g. for 'parent/child'
+    procedure Lookup(var Dest: TVarData; const Instance: TVarData;
+      FullName: PUtf8Char; PathDelim: AnsiChar = '.');
+    /// will check if the value is an array, and return the number of items
+    // - if the document is an array, will return the items count (0 meaning
+    // void array) - used e.g. by TSynMustacheContextVariant
+    // - this default implementation will return -1 (meaning this is not an array)
+    // - overridden method could implement it, e.g. for TDocVariant of kind
+    // dvArray - or dvObject (ignoring names) if GetObjectAsValues is true
+    function IterateCount(const V: TVarData; GetObjectAsValues: boolean): integer; virtual;
+    /// allow to loop over an array document
+    // - Index should be in 0..IterateCount-1 range
+    // - this default implementation will do nothing
+    procedure Iterate(var Dest: TVarData; const V: TVarData;
+      Index: integer); virtual;
+    /// returns TRUE if the supplied variant is of the exact custom type
+    function IsOfType(const V: variant): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// returns TRUE if the supplied custom variant is void
+    // - e.g. returns true for a TDocVariant or TBsonVariant with Count = 0
+    // - caller should have ensured that it is of the exact custom type
+    function IsVoid(const V: TVarData): boolean; virtual;
+    /// override this abstract method for actual getter by name implementation
+    function IntGet(var Dest: TVarData; const Instance: TVarData;
+      Name: PAnsiChar; NameLen: PtrInt; NoException: boolean): boolean; virtual;
+    /// override this abstract method for actual setter by name implementation
+    function IntSet(const Instance, Value: TVarData;
+      Name: PAnsiChar; NameLen: PtrInt): boolean; virtual;
+    /// override this method if default VariantCompAsText() call is not optimal
+    function IntCompare(const Instance, Another: TVarData;
+      CaseInsensitive: boolean): integer; virtual;
+    /// identify how this custom type behave
+    // - as set by the class constructor, to avoid calling any virtual method
+    property Options: TSynInvokeableVariantTypeOptions
+      read fOptions;
+  end;
+
+  /// class-reference type (metaclass) of custom variant type definition
+  // - used by SynRegisterCustomVariantType() function
+  TSynInvokeableVariantTypeClass = class of TSynInvokeableVariantType;
+
+var
+  /// internal list of our TSynInvokeableVariantType instances
+  // - SynVariantTypes[0] is always DocVariantVType
+  // - SynVariantTypes[1] is e.g. BsonVariantType from mormot.db.nosql.bson
+  // - instances are owned by Variants.pas as TInvokeableVariantType instances
+  // - is defined here for proper FindSynVariantType inlining
+  SynVariantTypes: array of TSynInvokeableVariantType;
+
+/// register a custom variant type to handle properties
+// - the registration process is thread-safe
+// - 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 TDocVariant, TBsonVariant or TSqlDBRowVariant
+function SynRegisterCustomVariantType(
+  aClass: TSynInvokeableVariantTypeClass): TSynInvokeableVariantType;
+
+/// search of a registered custom variant type from its low-level VarType
+// - returns the matching custom variant type, nil if not found
+function FindSynVariantType(aVarType: cardinal): TSynInvokeableVariantType;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// try to serialize a custom variant value into JSON
+// - as used e.g. by TJsonWriter.AddVariant
+function CustomVariantToJson(W: TJsonWriter; Value: PVarData;
+  Escape: TTextWriterKind): boolean;
+
+/// low-level conversion of a Compare() result to TCustomVariantType.Compare
+function SortCompTo(cmp: integer): TVarCompareResult;
+  {$ifdef HASINLINE}inline;{$endif}
+
+
+{ ************** TDocVariant Object/Array Document Holder with JSON support }
+
+type
+  /// JSON_[] constant convenient TDocVariant options
+  // - mVoid defines a safe (and slow) full-copy behavior with [] (no option)
+  // - mDefault defines a safe (and slow) full-copy behavior, returning null
+  // for unknown fields, as defined e.g. by _Json() and _JsonFmt() functions
+  // or JSON_OPTIONS[false]
+  // - mFast will copy-by-reference any TDocVariantData content, as defined
+  // e.g. by _JsonFast() and _JsonFastFmt() functions or JSON_OPTIONS[true]
+  // - mFastFloat will copy-by-reference and can parse floating points as double
+  // - mFastStrict will copy-by-reference and only parse strict (quoted) JSON,
+  // as defined by JSON_FAST_STRICT global variable
+  // - mFastExtended will copy-by-reference and write extended (unquoted) JSON,
+  // as defined by JSON_FAST_EXTENDED global variable
+  // - mFastExtendedIntern will copy-by-reference, write extended JSON and
+  // intern names and values, as defined by JSON_FAST_EXTENDEDINTERN variable
+  // - mNameValue will copy-by-reference and check field names case-sensitively,
+  // as defined by JSON_NAMEVALUE[false] global variable
+  // - mNameValueExtended will copy-by-reference, check field names
+  // case-sensitively and write extended (unquoted) JSON,
+  // as defined by JSON_NAMEVALUE[true] global variable
+  // - mNameValueIntern will copy-by-reference, check field names
+  // case-sensitively and intern names and values,
+  // as defined by JSON_NAMEVALUEINTERN[false] global variable
+  // - mNameValueInternExtended will copy-by-reference, check field names
+  // case-sensitively, write extended JSON and intern names and values,
+  // as defined by JSON_NAMEVALUEINTERN[true] global variable
+  TDocVariantModel = (
+    mVoid,
+    mDefault,
+    mFast,
+    mFastFloat,
+    mFastStrict,
+    mFastExtended,
+    mFastExtendedIntern,
+    mNameValue,
+    mNameValueExtended,
+    mNameValueIntern,
+    mNameValueInternExtended);
+
+var
+  /// some convenient TDocVariant options, e.g. as JSON_[fDefault]
+  JSON_: array[TDocVariantModel] of TDocVariantOptions = (
+    // mVoid
+    [],
+    // mDefault
+    [dvoReturnNullForUnknownProperty],
+    // mFast
+    [dvoReturnNullForUnknownProperty,
+     dvoValueCopiedByReference],
+    // mFastFloat
+    [dvoReturnNullForUnknownProperty,
+     dvoValueCopiedByReference,
+     dvoAllowDoubleValue],
+    // mFastStrict
+    [dvoReturnNullForUnknownProperty,
+     dvoValueCopiedByReference,
+     dvoJsonParseDoNotTryCustomVariants],
+    // mFastExtended
+    [dvoReturnNullForUnknownProperty,
+     dvoValueCopiedByReference,
+     dvoSerializeAsExtendedJson],
+    // mFastExtendedIntern
+    [dvoReturnNullForUnknownProperty,
+     dvoValueCopiedByReference,
+     dvoSerializeAsExtendedJson,
+     dvoJsonParseDoNotTryCustomVariants,
+     dvoInternNames,
+     dvoInternValues],
+    // mNameValue
+    [dvoReturnNullForUnknownProperty,
+     dvoValueCopiedByReference,
+     dvoNameCaseSensitive],
+    // mNameValueExtended
+    [dvoReturnNullForUnknownProperty,
+     dvoValueCopiedByReference,
+     dvoNameCaseSensitive,
+     dvoSerializeAsExtendedJson],
+    // mNameValueIntern
+    [dvoReturnNullForUnknownProperty,
+     dvoValueCopiedByReference,
+     dvoNameCaseSensitive,
+     dvoInternNames,
+     dvoInternValues],
+    // mNameValueInternExtended
+    [dvoReturnNullForUnknownProperty,
+     dvoValueCopiedByReference,
+     dvoNameCaseSensitive,
+     dvoInternNames,
+     dvoInternValues,
+     dvoSerializeAsExtendedJson]
+    );
+
+const
+  /// same as JSON_[mFast], but can not be used as PDocVariantOptions
+  // - handle only currency for floating point values: use JSON_FAST_FLOAT
+  // if you want to support double values, with potential precision loss
+  JSON_FAST =
+    [dvoReturnNullForUnknownProperty,
+     dvoValueCopiedByReference];
+
+  /// same as JSON_FAST, but including dvoAllowDoubleValue for floating
+  // point values parsing into double, with potential precision loss
+  JSON_FAST_FLOAT =
+    [dvoReturnNullForUnknownProperty,
+     dvoValueCopiedByReference,
+     dvoAllowDoubleValue];
+
+var
+  /// TDocVariant options which may be used for plain JSON parsing
+  // - this won't recognize any extended syntax
+  JSON_FAST_STRICT: TDocVariantOptions;
+
+  /// 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 TOrm variant published field to
+  // reduce the JSON escape process during storage in the database, by
+  // customizing your TOrmModel instance:
+  // !  (aModel.Props[TOrmMyRecord]['VariantProp'] as TOrmPropInfoRttiVariant).
+  // !    DocVariantOptions := JSON_FAST_EXTENDED;
+  // or - in a cleaner way - by overriding TOrm.InternalDefineModel():
+  // ! class procedure TOrmMyRecord.InternalDefineModel(Props: TOrmProperties);
+  // ! begin
+  // !   (Props.Fields.ByName('VariantProp') as TOrmPropInfoRttiVariant).
+  // !     DocVariantOptions := JSON_FAST_EXTENDED;
+  // ! end;
+  // or to set all variant fields at once:
+  // ! class procedure TOrmMyRecord.InternalDefineModel(Props: TOrmProperties);
+  // ! begin
+  // !   Props.SetVariantFieldsDocVariantOptions(JSON_FAST_EXTENDED);
+  // ! end;
+  // - consider using JSON_NAMEVALUE[true] for case-sensitive
+  // TSynNameValue-like storage, or JSON_FAST_EXTENDEDINTERN if you
+  // expect RawUtf8 names and values interning
+  JSON_FAST_EXTENDED: TDocVariantOptions;
+
+  /// 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_FAST_EXTENDED if you don't expect
+  // RawUtf8 names and values interning, or need BSON variants parsing
+  JSON_FAST_EXTENDEDINTERN: TDocVariantOptions;
+
+  /// TDocVariant options to be used for case-sensitive TSynNameValue-like
+  // storage, with optional extended JSON syntax serialization
+  // - consider using JSON_FAST_EXTENDED for case-insensitive objects
+  JSON_NAMEVALUE: TDocVariantOptionsBool;
+
+  /// TDocVariant options to be used for case-sensitive TSynNameValue-like
+  // storage, RawUtf8 interning and optional extended JSON syntax serialization
+  // - consider using JSON_FAST_EXTENDED for case-insensitive objects,
+  // or JSON_NAMEVALUE[] if you don't expect names and values interning
+  JSON_NAMEVALUEINTERN: TDocVariantOptionsBool;
+
+  // - JSON_OPTIONS[false] is e.g. _Json() and _JsonFmt() functions default
+  // - JSON_OPTIONS[true] are used e.g. by _JsonFast() and _JsonFastFmt() functions
+  // - handle only currency for floating point values: use JSON_FAST_FLOAT/JSON_[mFastFloat]
+  // if you want to support double values, with potential precision loss
+  JSON_OPTIONS: TDocVariantOptionsBool;
+
+// some slightly more verbose backward compatible options
+{$ifndef PUREMORMOT2}
+  JSON_OPTIONS_FAST_STRICT: TDocVariantOptions
+    absolute JSON_FAST_STRICT;
+  JSON_OPTIONS_NAMEVALUE: TDocVariantOptionsBool
+    absolute JSON_NAMEVALUE;
+  JSON_OPTIONS_NAMEVALUEINTERN: TDocVariantOptionsBool
+    absolute JSON_NAMEVALUEINTERN;
+  JSON_OPTIONS_FAST_EXTENDED: TDocVariantOptions
+    absolute JSON_FAST_EXTENDED;
+  JSON_OPTIONS_FAST_EXTENDEDINTERN: TDocVariantOptions
+    absolute JSON_FAST_EXTENDEDINTERN;
+
+const
+  JSON_OPTIONS_FAST = JSON_FAST;
+  JSON_OPTIONS_FAST_FLOAT = JSON_FAST_FLOAT;
+{$endif PUREMORMOT2}
+
+
+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)
+  // - note: due to a local variable lifetime change in Delphi 11, don't use
+  // this function with a temporary variant (e.g. from TList.GetItem) -
+  // call _DV() and a local TDocVariantData instead of a PDocVariantData
+  PDocVariantData = ^TDocVariantData;
+
+  /// pointer to a dynamic array of TDocVariant storage
+  PDocVariantDataDynArray = array of PDocVariantData;
+
+  /// define the TDocVariant storage layout
+  // - if it has no name property, it is a dvArray
+  // - if it has one or more named properties, it is a dvObject
+  TDocVariantKind = (
+    dvUndefined,
+    dvArray,
+    dvObject);
+
+  /// exception class associated to TDocVariant JSON/BSON document
+  EDocVariant = class(ESynException)
+  protected
+    class procedure RaiseSafe(Kind: TDocVariantKind);
+  end;
+
+  /// a custom variant type used to store any JSON/BSON document-based content
+  // - i.e. name/value pairs for objects, or an array of values (including
+  // nested documents), stored in a TDocVariantData memory structure
+  // - you can use _Obj()/_ObjFast() _Arr()/_ArrFast() _Json()/_JsonFast() or
+  // _JsonFmt()/_JsonFastFmt() functions to create instances of such variants
+  // - property access may be done via late-binding - with some restrictions
+  // for older versions of FPC, e.g. allowing to write:
+  // ! TDocVariant.NewFast(aVariant);
+  // ! aVariant.Name := 'John';
+  // ! aVariant.Age := 35;
+  // ! writeln(aVariant.Name,' is ',aVariant.Age,' years old');
+  // - it also supports a small set of pseudo-properties or pseudo-methods:
+  // ! aVariant._Count = DocVariantData(aVariant).Count
+  // ! aVariant._Kind = ord(DocVariantData(aVariant).Kind)
+  // ! aVariant._JSON = DocVariantData(aVariant).JSON
+  // ! aVariant._(i) = DocVariantData(aVariant).Value[i]
+  // ! aVariant.Value(i) = DocVariantData(aVariant).Value[i]
+  // ! aVariant.Value(aName) = DocVariantData(aVariant).Value[aName]
+  // ! aVariant.Name(i) = DocVariantData(aVariant).Name[i]
+  // ! aVariant.Add(aItem) = DocVariantData(aVariant).AddItem(aItem)
+  // ! aVariant._ := aItem = DocVariantData(aVariant).AddItem(aItem)
+  // ! aVariant.Add(aName,aValue) = DocVariantData(aVariant).AddValue(aName,aValue)
+  // ! aVariant.Exists(aName) = DocVariantData(aVariant).GetValueIndex(aName)>=0
+  // ! aVariant.Delete(i) = DocVariantData(aVariant).Delete(i)
+  // ! aVariant.Delete(aName) = DocVariantData(aVariant).Delete(aName)
+  // ! aVariant.NameIndex(aName) = DocVariantData(aVariant).GetValueIndex(aName)
+  // - it features direct JSON serialization/unserialization, e.g.:
+  // ! assert(_Json('["one",2,3]')._JSON='["one",2,3]');
+  // - it features direct trans-typing into a string encoded as JSON, e.g.:
+  // ! assert(_Json('["one",2,3]')='["one",2,3]');
+  TDocVariant = class(TSynInvokeableVariantType)
+  protected
+    /// name and values interning are shared among all TDocVariantData instances
+    fInternNames, fInternValues: TRawUtf8Interning;
+    fInternSafe: TLightLock; // just protect TRawUtf8Interning initialization
+    function CreateInternNames: TRawUtf8Interning;
+    function CreateInternValues: TRawUtf8Interning;
+  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_FAST);
+    // - to be used e.g. as
+    // !var
+    // !  v: variant;
+    // !begin
+    // !  TDocVariant.NewFast(v);
+    // !  ...
+    class procedure NewFast(out aValue: variant;
+      aKind: TDocVariantKind = dvUndefined); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// ensure a variant is a TDocVariant instance
+    // - if aValue is not a TDocVariant, will create a new JSON_FAST
+    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;
+      aKind: TDocVariantKind = dvUndefined); 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, returns 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: TJsonWriter; Value: PVarData); override;
+    /// will check if the value is an array, and return the number of items
+    // - if the document is an array, will return the items count (0 meaning
+    // void array) - used e.g. by TSynMustacheContextVariant
+    // - this overridden method will implement it for dvArray instance kind
+    function IterateCount(const V: TVarData;
+      GetObjectAsValues: boolean): integer; override;
+    /// allow to loop over an array document
+    // - Index should be in 0..IterateCount-1 range
+    // - this default implementation will do handle dvArray instance kind
+    procedure Iterate(var Dest: TVarData; const V: TVarData;
+      Index: integer); override;
+    /// returns true if this document has Count = 0
+    function IsVoid(const V: TVarData): boolean; 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 access internal pseudo-methods
+    function DoProcedure(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;
+    /// overriden method for actual getter by name implementation
+    function IntGet(var Dest: TVarData; const Instance: TVarData;
+      Name: PAnsiChar; NameLen: PtrInt; NoException: boolean): boolean; override;
+    /// overriden method for actual setter by name implementation
+    function IntSet(const Instance, Value: TVarData;
+      Name: PAnsiChar; NameLen: PtrInt): boolean; override;
+    /// overriden method redirecting to TDocVariantData.Compare()
+    function IntCompare(const Instance, Another: TVarData;
+      CaseInsensitive: boolean): integer; override;
+  end;
+
+  /// 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;
+
+  {$ifdef HASITERATORS}
+  /// internal state engine used by TDocVariant enumerators records
+  TDocVariantEnumeratorState = record
+  private
+    Curr, After: PVariant;
+  public
+    procedure Init(Values: PVariantArray; Count: PtrUInt); inline;
+    procedure Void; inline;
+    function MoveNext: boolean; inline;
+  end;
+
+  /// local iterated name/value pair as returned by TDocVariantData.GetEnumerator
+  // and TDocVariantData.Fields
+  // - we use pointers for best performance - but warning: Name may be nil for
+  // TDocVariantData.GetEnumerator over an array
+  TDocVariantFields = record
+    /// points to current Name[] - nil if the TDocVariantData is an array
+    Name: PRawUtf8;
+    /// points to the current Value[] - never nil
+    Value: PVariant;
+  end;
+
+  /// low-level Enumerator as returned by TDocVariantData.GetEnumerator
+  // (default "for .. in dv do") and TDocVariantData.Fields
+  TDocVariantFieldsEnumerator = record
+  private
+    State: TDocVariantEnumeratorState;
+    Name: PRawUtf8;
+    function GetCurrent: TDocVariantFields; inline;
+  public
+    function MoveNext: boolean; inline;
+    function GetEnumerator: TDocVariantFieldsEnumerator; inline;
+    /// returns the current Name/Value or Value as pointers in TDocVariantFields
+    property Current: TDocVariantFields
+      read GetCurrent;
+  end;
+
+  /// low-level Enumerator as returned by TDocVariantData.FieldNames
+  TDocVariantFieldNamesEnumerator = record
+  private
+    Curr, After: PRawUtf8;
+  public
+    function MoveNext: boolean; inline;
+    function GetEnumerator: TDocVariantFieldNamesEnumerator; inline;
+    /// returns the current Name/Value or Value as pointers in TDocVariantFields
+    property Current: PRawUtf8
+      read Curr;
+  end;
+
+  /// low-level Enumerator as returned by TDocVariantData.Items and FieldValues
+  TDocVariantItemsEnumerator = record
+  private
+    State: TDocVariantEnumeratorState;
+  public
+    function MoveNext: boolean; inline;
+    function GetEnumerator: TDocVariantItemsEnumerator; inline;
+    /// returns the current Value as pointer
+    property Current: PVariant
+      read State.Curr;
+  end;
+
+  /// low-level Enumerator as returned by TDocVariantData.Objects
+  TDocVariantObjectsEnumerator = record
+  private
+    State: TDocVariantEnumeratorState;
+    Value: PDocVariantData;
+  public
+    function MoveNext: boolean; {$ifdef HASSAFEINLINE} inline; {$endif}
+    function GetEnumerator: TDocVariantObjectsEnumerator; inline;
+    /// returns the current Value as pointer to each TDocVariantData object
+    property Current: PDocVariantData
+      read Value;
+  end;
+  {$endif HASITERATORS}
+
+  /// how duplicated values could be searched
+  TSearchDuplicate = (
+    sdNone,
+    sdCaseSensitive,
+    sdCaseInsensitive);
+
+  {$A-} { packet object not allowed since Delphi 2009 :( }
+  /// memory structure used for TDocVariant storage of any JSON/BSON
+  // document-based content as variant
+  // - i.e. name/value pairs for objects, or an array of values (including
+  // nested documents)
+  // - you can use _Obj()/_ObjFast() _Arr()/_ArrFast() _Json()/_JsonFast() or
+  // _JsonFmt()/_JsonFastFmt() functions to create instances of such variants
+  // - you can transtype such an allocated variant into TDocVariantData
+  // to access directly its internals (like Count or Values[]/Names[]):
+  // ! aVariantObject := TDocVariant.NewObject(['name','John','year',1972]);
+  // ! aVariantObject := _ObjFast(['name','John','year',1972]);
+  // ! with _Safe(aVariantObject)^ do
+  // !   for i := 0 to Count-1 do
+  // !     writeln(Names[i],'=',Values[i]); // for an object
+  // ! aVariantArray := TDocVariant.NewArray(['one',2,3.0]);
+  // ! aVariantArray := _JsonFast('["one",2,3.0]');
+  // ! with _Safe(aVariantArray)^ do
+  // !   for i := 0 to Count-1 do
+  // !     writeln(Values[i]); // for an array
+  // - use "with _Safe(...)^ do"  and not "with TDocVariantData(...) do" as the
+  // former will handle internal variant redirection (varByRef), e.g. from late
+  // binding or assigned another TDocVariant
+  // - Delphi "object" is buggy on stack -> also defined as record with methods
+  {$ifdef USERECORDWITHMETHODS}
+  TDocVariantData = record
+  {$else}
+  TDocVariantData = object
+  {$endif USERECORDWITHMETHODS}
+  private
+    // note: this structure uses all TVarData available space: no filler needed!
+    VType: TVarType;              // 16-bit
+    VOptions: TDocVariantOptions; // 16-bit
+    VCount: integer;              // 32-bit
+    VName: TRawUtf8DynArray;      // pointer
+    VValue: TVariantDynArray;     // pointer
+    // retrieve the value as varByRef
+    function GetValueOrItem(const aNameOrIndex: variant): variant;
+    procedure SetValueOrItem(const aNameOrIndex, aValue: variant);
+    // kind is stored as dvoIsArray/dvoIsObject within VOptions
+    function GetKind: TDocVariantKind;
+      {$ifdef HASINLINE}inline;{$endif}
+    function Has(dvo: TDocVariantOption): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    procedure Include(dvo: TDocVariantOption);
+      {$ifdef HASINLINE}inline;{$endif}
+    procedure SetOptions(const opt: TDocVariantOptions); // keep dvoIsObject/Array
+      {$ifdef HASINLINE}inline;{$endif}
+    // capacity is Length(VValue) and Length(VName)
+    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;
+    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;
+    function GetVariantByPath(const aNameOrPath: RawUtf8): Variant;
+      {$ifdef HASINLINE}inline;{$endif}
+    function GetObjectProp(const aName: RawUtf8; out aFound: PVariant;
+      aPreviousIndex: PInteger): boolean;
+    function InternalAddBuf(aName: PUtf8Char; aNameLen: integer): integer;
+    procedure InternalSetValue(aIndex: PtrInt; const aValue: variant);
+      {$ifdef HASINLINE}inline;{$endif}
+    procedure InternalSetVarRec(aIndex: PtrInt; const aValue: TVarRec);
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    procedure InternalUniqueValueAt(aIndex: PtrInt);
+    function InternalNextPath(var aCsv: PUtf8Char; aName: PShortString;
+      aPathDelim: AnsiChar): PtrInt;
+      {$ifdef FPC}inline;{$endif}
+    procedure InternalNotFound(var Dest: variant; aName: PUtf8Char); overload;
+    procedure InternalNotFound(var Dest: variant; aIndex: integer); overload;
+    function InternalNotFound(aName: PUtf8Char): PVariant; overload;
+    function InternalNotFound(aIndex: integer): PDocVariantData; overload;
+    function RangeVoid(var Offset, Limit: integer): boolean;
+    procedure ClearFast;
+      {$ifdef HASINLINE}inline;{$endif}
+  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(const aOptions: TDocVariantOptions = []); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// initialize a TDocVariantData to store a content of some known type
+    // - if you call Init*() methods in a row, ensure you call Clear in-between
+    procedure Init(const aOptions: TDocVariantOptions;
+      aKind: TDocVariantKind); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// initialize a TDocVariantData to store some document-based content
+    // - use the options corresponding to the supplied TDocVariantModel
+    // - if you call Init*() methods in a row, ensure you call Clear in-between
+    procedure Init(aModel: TDocVariantModel;
+      aKind: TDocVariantKind = dvUndefined); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// initialize a TDocVariantData to store per-reference document-based content
+    // - same as Doc.Init(JSON_FAST);
+    // - 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(aKind: TDocVariantKind = dvUndefined); overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// 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 = []); overload;
+    /// initialize a TDocVariantData to store document-based object content
+    // - if you call Init*() methods in a row, ensure you call Clear in-between
+    procedure InitObject(const NameValuePairs: array of const;
+      Model: TDocVariantModel); overload;
+    /// 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 aItems: array of const;
+      aOptions: TDocVariantOptions = []); overload;
+    /// initialize a variant instance to store some document-based array content
+    // - if you call Init*() methods in a row, ensure you call Clear in-between
+    procedure InitArray(const aItems: array of const;
+      aModel: TDocVariantModel); overload;
+    /// 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 aItems: TVariantDynArray;
+      aOptions: TDocVariantOptions = [];
+      aItemsCopiedByReference: boolean = true; aCount: integer = -1);
+    /// initialize a variant array instance from an object Values[]
+    procedure InitArrayFromObjectValues(const aObject: variant;
+      aOptions: TDocVariantOptions = []; aItemsCopiedByReference: boolean = true);
+    /// initialize a variant array instance from an object Names[]
+    procedure InitArrayFromObjectNames(const aObject: variant;
+      aOptions: TDocVariantOptions = []; aItemsCopiedByReference: boolean = true);
+    /// initialize a variant instance from some 'a,b,c' CSV one-line content
+    // - is by default separator tolerant, i.e. will detect ',' ';' or #9 in text
+    procedure InitArrayFromCsv(const aCsv: RawUtf8;
+      aOptions: TDocVariantOptions; aSeparator: AnsiChar = #0;
+      aTrimItems: boolean = false; aAddVoidItems: boolean = false;
+      aQuote: AnsiChar = #0);
+    /// initialize a variant instance from a CSV file content with header
+    // - stored objects names will be retrieved from the first CSV line
+    // - is by default separator tolerant, i.e. will detect ',' ';' or #9 in text
+    procedure InitArrayFromCsvFile(const aCsv: RawUtf8;
+      aOptions: TDocVariantOptions; aSeparator: AnsiChar = #0;
+      aQuote: AnsiChar = #0);
+    /// create a TDocVariant array, from a sub-range of this document array
+    // - returned variant instance is a dvArray containing only the specified rows
+    // $ new.InitArrayFrom(src) returns a copy of src array
+    // $ new.InitArrayFrom(src, 10) returns items 10..Count-1 of src
+    // $ new.InitArrayFrom(src, 0, 10) returns first 0..9 items of src
+    // $ new.InitArrayFrom(src, 10, 20) returns items 10..29 - truncated if Count<30
+    // $ new.InitArrayFrom(src, -10) returns last Count-10..Count-1 items of src
+    procedure InitArrayFrom(const aSource: TDocVariantData;
+      aOptions: TDocVariantOptions; aOffset: integer = 0; aLimit: integer = 0); overload;
+    /// initialize a variant instance to store some RawUtf8 array content
+    procedure InitArrayFrom(const aItems: TRawUtf8DynArray;
+      aOptions: TDocVariantOptions; aCount: integer = -1); overload;
+    /// initialize a variant instance to store some 32-bit integer array content
+    procedure InitArrayFrom(const aItems: TIntegerDynArray;
+      aOptions: TDocVariantOptions; aCount: integer = -1); overload;
+    /// initialize a variant instance to store some 64-bit integer array content
+    procedure InitArrayFrom(const aItems: TInt64DynArray;
+      aOptions: TDocVariantOptions; aCount: integer = -1); overload;
+    /// initialize a variant instance to store some double array content
+    procedure InitArrayFrom(const aItems: TDoubleDynArray;
+      aOptions: TDocVariantOptions; aCount: integer = -1); overload;
+    /// initialize a variant instance to store some dynamic array content
+    procedure InitArrayFrom(var aItems; ArrayInfo: PRttiInfo;
+      aOptions: TDocVariantOptions; ItemsCount: PInteger = nil); overload;
+    /// initialize a variant instance to store some TDynArray content
+    procedure InitArrayFrom(const aItems: TDynArray;
+      aOptions: TDocVariantOptions = JSON_FAST_FLOAT); 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];
+      aCount: integer = -1);
+    /// fill a TDocVariant array from standard or non-expanded JSON ORM/DB result
+    // - accept the ORM/DB results dual formats as recognized by TOrmTableJson,
+    // i.e. both [{"f1":"1v1","f2":1v2},{"f2":"2v1","f2":2v2}...] and
+    // {"fieldCount":2,"values":["f1","f2","1v1",1v2,"2v1",2v2...],"rowCount":20}
+    // - about 2x (expanded) or 3x (non-expanded) faster than Doc.InitJsonInPlace()
+    // - will also use less memory, because all object field names will be shared
+    // - in expanded mode, the fields order won't be checked, as with TOrmTableJson
+    // - warning: the incoming JSON buffer will be modified in-place: so you should
+    // make a private copy before running this method, as overloaded procedures do
+    // - some numbers on a Core i5-13500, extracted from our regression tests:
+    // $ TDocVariant InitJsonInPlace in 72.91ms i.e. 2.1M rows/s, 268.8 MB/s
+    // $ TDocVariant InitJsonInPlace no guess in 69.49ms i.e. 2.2M rows/s, 282 MB/s
+    // $ TDocVariant InitJsonInPlace dvoIntern in 68.41ms i.e. 2.2M rows/s, 286.5 MB/s
+    // $ TDocVariant FromResults exp in 31.69ms i.e. 4.9M rows/s, 618.6 MB/s
+    // $ TDocVariant FromResults not exp in 24.48ms i.e. 6.4M rows/s, 352.1 MB/s
+    function InitArrayFromResults(Json: PUtf8Char; JsonLen: PtrInt;
+      aOptions: TDocVariantOptions = JSON_FAST_FLOAT): boolean; overload;
+    /// fill a TDocVariant array from standard or non-expanded JSON ORM/DB result
+    // - accept the ORM/DB results dual formats as recognized by TOrmTableJson
+    // - about 2x (expanded) or 3x (non-expanded) faster than Doc.InitJson()
+    // - will also use less memory, because all object field names will be shared
+    // - in expanded mode, the fields order won't be checked, as with TOrmTableJson
+    // - a private copy of the incoming JSON buffer will be used before parsing
+    function InitArrayFromResults(const Json: RawUtf8;
+      aOptions: TDocVariantOptions = JSON_FAST_FLOAT): boolean; overload;
+    /// fill a TDocVariant array from standard or non-expanded JSON ORM/DB result
+    // - accept the ORM/DB results dual formats as recognized by TOrmTableJson
+    // - about 2x (expanded) or 3x (non-expanded) faster than Doc.InitJson()
+    // - will also use less memory, because all object field names will be shared
+    // - in expanded mode, the fields order won't be checked, as with TOrmTableJson
+    // - a private copy of the incoming JSON buffer will be used before parsing
+    function InitArrayFromResults(const Json: RawUtf8;
+      aModel: TDocVariantModel): boolean; overload;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// 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 = []; aPathDelim: AnsiChar = '.');
+    /// 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, as InitJson() does
+    // - 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
+    // - consider the faster InitArrayFromResults() from ORM/SQL JSON results
+    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 or 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
+    // - handle only currency for floating point values: set JSON_FAST_FLOAT
+    // or dvoAllowDoubleValue option to support double, with potential precision loss
+    // - consider the faster InitArrayFromResults() from ORM/SQL JSON results
+    function InitJson(const Json: RawUtf8;
+      aOptions: TDocVariantOptions = []): boolean; overload;
+    /// initialize a variant instance to store some document-based object content
+    // from a supplied JSON array or JSON object content
+    // - use the options corresponding to the supplied TDocVariantModel
+    // - a private copy of the incoming JSON buffer will be made
+    // - if you call Init*() methods in a row, ensure you call Clear in-between
+    // - handle only currency for floating point values unless you set mFastFloat
+    // - consider the faster InitArrayFromResults() from ORM/SQL JSON results
+    function InitJson(const Json: RawUtf8; aModel: TDocVariantModel): boolean; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// initialize a variant instance to store some document-based object content
+    // from a file containing some JSON array or JSON object
+    // - file may have been serialized using the SaveToJsonFile() method
+    // - if you call Init*() methods in a row, ensure you call Clear in-between
+    // - handle only currency for floating point values: set JSON_FAST_FLOAT
+    // or dvoAllowDoubleValue option to support double, with potential precision loss
+    // - will assume text file with no BOM is already UTF-8 encoded
+    function InitJsonFromFile(const FileName: TFileName;
+      aOptions: TDocVariantOptions = []): 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_[mDefault])
+    // or per-value (if you set JSON_[mDefault]) 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);
+    /// clone a document-based variant with the very same options but no data
+    // - the same options will be used, without the dvArray/dvObject flags
+    // - if you call Init*() methods in a row, ensure you call Clear in-between
+    procedure InitClone(const CloneFrom: TDocVariantData);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// low-level copy a document-based variant with the very same options and count
+    // - if you call Init*() methods in a row, ensure you call Clear in-between
+    // - will copy Count and Names[] by reference, but Values[] only if CloneValues
+    // - returns the first item in Values[]
+    function InitFrom(const CloneFrom: TDocVariantData; CloneValues: boolean;
+      MakeUnique: boolean = false): PVariant;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// initialize a variant instance to store some document-based object content
+    // from a supplied name=value list of UTF-8 encoded text (e.g. .ini file)
+    // - 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 InitFromPairs(aPairs: 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 name=value list of UTF-8 encoded text (e.g. .ini file)
+    // - 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 InitFromPairs(const aPairs: 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;
+    // - will check the VType, and call ClearFast private method
+    procedure Clear;
+    /// delete all internal stored values
+    // - like Clear + Init() with the same options
+    // - will reset Kind to dvUndefined
+    procedure Reset;
+    /// keep the current Options and Kind, but reset all data and VCount to 0
+    procedure Void;
+    /// fill all Values[] with #0, then delete all values
+    // - could be used to specifically remove sensitive information from memory
+    procedure FillZero;
+    /// check if the Document is an object - i.e. Kind = dvObject
+    function IsObject: boolean;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// check if the Document is an array - i.e. Kind = dvArray
+    function IsArray: boolean;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// check if names lookups are case sensitive in this object Document
+    function IsCaseSensitive: boolean;
+      {$ifdef HASINLINE} inline; {$endif}
+    /// guess the TDocVariantModel corresponding to the current document Options
+    // - returns true if model has been found and set
+    // - returns false if no JSON_[] matches the current options
+    function GetModel(out model: TDocVariantModel): boolean;
+    /// 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 and to call Void if aCount=0
+    procedure SetCount(aCount: integer);
+      {$ifdef HASINLINE}inline;{$endif}
+    /// efficient comparison of two TDocVariantData content
+    // - will return the same result than JSON comparison, but more efficiently
+    function Compare(const Another: TDocVariantData;
+      CaseInsensitive: boolean = false): integer; overload;
+    /// efficient comparison of two TDocVariantData objects
+    // - will always ensure that both this instance and Another are Objects
+    // - will compare all supplied Fields values in their specified order
+    // - if ObjFields is void, will fallback to regular Compare()
+    function CompareObject(const ObjFields: array of RawUtf8;
+      const Another: TDocVariantData; CaseInsensitive: boolean = false): integer;
+    /// efficient equality comparison of two TDocVariantData content
+    // - just a wrapper around Compare(Another)=0
+    function Equals(const Another: TDocVariantData;
+      CaseInsensitive: boolean = false): boolean; overload;
+      {$ifdef HASSAFEINLINE}inline;{$endif}
+    /// compare a TTDocVariantData object property with a given value
+    // - returns -1 if this instance is not a dvObject or has no aName property
+    function Compare(const aName: RawUtf8; const aValue: variant;
+      aCaseInsensitive: boolean = false): integer; overload;
+      {$ifdef ISDELPHI}{$ifdef HASINLINE}inline;{$endif}{$endif}
+    /// efficient equality comparison a TTDocVariantData object property
+    function Equals(const aName: RawUtf8; const aValue: variant;
+      aCaseInsensitive: boolean = false): boolean; overload;
+      {$ifdef ISDELPHI}{$ifdef HASINLINE}inline;{$endif}{$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
+    // - you can specify an optional aIndex value to Insert instead of Add
+    // - warning: FPC optimizer is confused by Values[InternalAdd(name)] so
+    // you should call InternalAdd() in an explicit previous step
+    function InternalAdd(const aName: RawUtf8; aIndex: integer = -1): integer; 
+    {$ifdef HASITERATORS}
+    /// an enumerator able to compile "for .. in dv do" statements
+    // - returns pointers over all Names[] and Values[]
+    // - warning: if the document is an array, returned Name is nil:
+    // ! var e: TDocVariantFields;
+    // ! ...
+    // !    dv.InitArray([1, 3, 3, 4]);
+    // !    for e in dv do
+    // !      // here e.Name = nil
+    // !      writeln(e.Value^);
+    // ! // output  1  2  3  4
+    function GetEnumerator: TDocVariantFieldsEnumerator;
+    /// an enumerator able to compile "for .. in dv.Fields do" for objects
+    // - returns pointers over all Names[] and Values[]
+    // - don't iterate if the document is an array - so Name is never nil:
+    // ! var e: TDocVariantFields;
+    // ! ...
+    // !   dv.InitJson('{a:1,b:2,c:3}');
+    // !   for e in dv.Fields do
+    // !     writeln(e.Name^, ':', e.Value^);
+    // ! // output  a:1  b:2  c:3
+    function Fields: TDocVariantFieldsEnumerator;
+    /// an enumerator able to compile "for .. in dv.FieldNames do" for objects
+    // - returns pointers over all Names[]
+    // - don't iterate if the document is an array - so n is never nil:
+    // ! var n: PRawUtf8;
+    // ! ...
+    // !   dv.InitJson('{a:1,b:2,c:3}');
+    // !   for n in dv.FieldNames do
+    // !     writeln(n^);
+    // ! // output  a  b  c
+    function FieldNames: TDocVariantFieldNamesEnumerator;
+    /// an enumerator able to compile "for .. in dv.FieldValues do" for objects
+    // - returns pointers over all Values[]
+    // - don't iterate if the document is an array:
+    // ! var v: PVariant;
+    // ! ...
+    // !   dv.InitJson('{a:1,b:2,c:3}');
+    // !   for v in dv.FieldValues do
+    // !     writeln(v^);
+    // ! // output  1  2  3
+    function FieldValues: TDocVariantItemsEnumerator;
+    /// an enumerator able to compile "for .. in dv.Items do" for arrays
+    // - returns a PVariant over all Values[] of a document array
+    // - don't iterate if the document is an object
+    // - for instance:
+    // ! var v: PVariant;
+    // ! ...
+    // !    dv.InitArray([1, 3, 3, 4]);
+    // !    for v in dv.Items do
+    // !      writeln(v^);
+    // ! // output  1  2  3  4
+    function Items: TDocVariantItemsEnumerator;
+    /// an enumerator able to compile "for .. dv.Objects do" for array of objects
+    // - returns all Values[] of a document array which are a TDocVariantData
+    // - don't iterate if the document is an object, or if an item is not a
+    // TDocVariantData:
+    // ! var d: PDocVariantData;
+    // ! ...
+    // !    dv.InitJson('[{a:1,b:1},1,"no object",{a:2,b:2}]');
+    // !    for d in dv.Objects do
+    // !      writeln(d^.ToJson);
+    // ! // output {"a":1,"b":1} and {"a":2,"b":2} only
+    // ! // (ignoring 1 and "no object" items)
+    function Objects: TDocVariantObjectsEnumerator;
+    {$endif HASITERATORS}
+
+    /// 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 DocVariantType.ToJson()
+    function ToJson: RawUtf8; overload;
+    /// save a document as UTF-8 encoded JSON
+    function ToJson(const Prefix, Suffix: RawUtf8;
+      Format: TTextWriterJsonFormat): RawUtf8; overload;
+    /// save a document as UTF-8 encoded JSON file
+    // - you may then use InitJsonFromFile() to load and parse this file
+    procedure SaveToJsonFile(const FileName: TFileName);
+    /// save an array of objects as UTF-8 encoded non expanded layout JSON
+    // - returned content would be a JSON object in mORMot's TOrmTableJson non
+    // expanded format, with reduced JSON size, i.e.
+    // $ {"fieldCount":2,"values":["f1","f2","1v1",1v2,"2v1",2v2...],"rowCount":20}
+    // - 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
+    // - can be unserialized using the InitArrayFromResults() method
+    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
+    // - values will be passed by referenced as vtVariant to @VValue[ndx]
+    // - 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
+    // - values will be passed by referenced as vtVariant to @VValue[ndx]
+    // - 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;
+
+    /// returns true if this is not a true TDocVariant, or Count equals 0
+    function IsVoid: boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// search if a given Name do exists in this document
+    // - just a wrapper around GetValueIndex(aName) >= 0
+    function Exists(const aName: RawUtf8): boolean;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// find an item index in this document from its name
+    // - search will follow dvoNameCaseSensitive option of this document
+    // - lookup the value by name for an object document, or accept an integer
+    // text as index for an array document
+    // - returns -1 if not found
+    function GetValueIndex(const aName: RawUtf8): integer; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// find an item index in this document from its name
+    // - lookup the value by name for an object document, or accept an integer
+    // text as index for an array document
+    // - returns -1 if not found
+    function GetValueIndex(aName: PUtf8Char; aNameLen: PtrInt;
+      aCaseSensitive: boolean): integer; overload;
+    /// find an item in this document, and returns its value
+    // - raise an EDocVariant if not found and dvoReturnNullForUnknownProperty
+    // is not set in Options (in this case, it will return Null)
+    function GetValueOrRaiseException(const aName: RawUtf8): variant;
+    /// find an item in this document, and returns its value
+    // - return the supplied default if aName is not found, or if the instance
+    // is not a TDocVariant
+    function GetValueOrDefault(const aName: RawUtf8;
+      const aDefault: variant): variant;
+    /// find an item in this document, and returns its value
+    // - return null if aName is not found, or if the instance is not a TDocVariant
+    function GetValueOrNull(const aName: RawUtf8): variant;
+    /// find an item in this document, and returns its value
+    // - return a cleared variant if aName is not found, or if the instance is
+    // not a TDocVariant
+    function GetValueOrEmpty(const aName: RawUtf8): variant;
+    /// find an item in this document, and returns its value as enumerate
+    // - return false if aName is not found, if the instance is not a TDocVariant,
+    // or if the value is not a string corresponding to the supplied enumerate
+    // - return true if the name has been found, and aValue stores the value
+    // - will call Delete() on the found entry, if aDeleteFoundEntry is true
+    function GetValueEnumerate(const aName: RawUtf8; aTypeInfo: PRttiInfo;
+      out aValue; aDeleteFoundEntry: boolean = false): boolean;
+    /// returns a JSON object containing all properties matching the
+    // first characters of the supplied property name
+    // - returns null if the document is not a dvObject
+    // - will use IdemPChar(), so search would be case-insensitive
+    function GetJsonByStartName(const aStartName: RawUtf8): RawUtf8;
+    /// find an item in this document, and returns its value as TVarData
+    // - return false if aName is not found, or if the instance is not a TDocVariant
+    // - return true and set aValue if the name has been found
+    // - will use simple loop lookup to identify the name, unless aSortedCompare is
+    // set, and would let use a faster O(log(n)) binary search after a SortByName()
+    function GetVarData(const aName: RawUtf8; var aValue: TVarData;
+      aSortedCompare: TUtf8Compare = nil): boolean; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// find an item in this document, and returns its value as TVarData pointer
+    // - return nil if aName is not found, or if the instance is not a TDocVariant
+    // - return a pointer to the value if the name has been found, and optionally
+    // fill aFoundIndex^ with its index in Values[]
+    // - after a SortByName(aSortedCompare), could use faster binary search
+    function GetVarData(const aName: RawUtf8; aSortedCompare: TUtf8Compare = nil;
+      aFoundIndex: PInteger = nil): PVarData; overload;
+    /// find an item in this document, and returns its value as boolean
+    // - return false if aName is not found, or if the instance is not a TDocVariant
+    // - return true if the name has been found, and aValue stores the value
+    // - after a SortByName(aSortedCompare), could use faster binary search
+    // - consider using B[] property if you want simple read/write typed access
+    function GetAsBoolean(const aName: RawUtf8; out aValue: boolean;
+      aSortedCompare: TUtf8Compare = nil): boolean;
+    /// find an item in this document, and returns its value as integer
+    // - return false if aName is not found, or if the instance is not a TDocVariant
+    // - return true if the name has been found, and aValue stores the value
+    // - after a SortByName(aSortedCompare), could use faster binary search
+    // - consider using I[] property if you want simple read/write typed access
+    function GetAsInteger(const aName: RawUtf8; out aValue: integer;
+      aSortedCompare: TUtf8Compare = nil): boolean;
+    /// find an item in this document, and returns its value as integer
+    // - return false if aName is not found, or if the instance is not a TDocVariant
+    // - return true if the name has been found, and aValue stores the value
+    // - after a SortByName(aSortedCompare), could use faster binary search
+    // - consider using I[] property if you want simple read/write typed access
+    function GetAsInt64(const aName: RawUtf8; out aValue: Int64;
+      aSortedCompare: TUtf8Compare = nil): boolean;
+    /// find an item in this document, and returns its value as floating point
+    // - return false if aName is not found, or if the instance is not a TDocVariant
+    // - return true if the name has been found, and aValue stores the value
+    // - after a SortByName(aSortedCompare), could use faster binary search
+    // - consider using D[] property if you want simple read/write typed access
+    function GetAsDouble(const aName: RawUtf8; out aValue: double;
+      aSortedCompare: TUtf8Compare = nil): boolean;
+    /// find an item in this document, and returns its value as RawUtf8
+    // - return false if aName is not found, or if the instance is not a TDocVariant
+    // - return true if the name has been found, and aValue stores the value
+    // - after a SortByName(aSortedCompare), could use faster binary search
+    // - consider using U[] property if you want simple read/write typed access
+    function GetAsRawUtf8(const aName: RawUtf8; out aValue: RawUtf8;
+      aSortedCompare: TUtf8Compare = nil): boolean;
+    /// find an item in this document, and returns its value as a TDocVariantData
+    // - return false if aName is not found, or if the instance is not a TDocVariant
+    // - return true if the name has been found and points to a TDocVariant:
+    // then aValue stores a pointer to the value
+    // - after a SortByName(aSortedCompare), could use faster binary search
+    function GetAsDocVariant(const aName: RawUtf8; out aValue: PDocVariantData;
+      aSortedCompare: TUtf8Compare = nil): boolean;
+    /// find a non-void array item in this document, and returns its value
+    // - return false if aName is not found, or if not a TDocVariant array
+    // - return true if the name was found as non-void array and set to aArray
+    // - after a SortByName(aSortedCompare), could use faster binary search
+    function GetAsArray(const aName: RawUtf8; out aArray: PDocVariantData;
+      aSortedCompare: TUtf8Compare = nil): boolean;
+    /// find a non-void object item in this document, and returns its value
+    // - return false if aName is not found, or if not a TDocVariant object
+    // - return true if the name was found as non-void object and set to aObject
+    // - after a SortByName(aSortedCompare), could use faster binary search
+    function GetAsObject(const aName: RawUtf8; out aObject: PDocVariantData;
+      aSortedCompare: TUtf8Compare = nil): boolean;
+    /// find an item in this document, and returns its value as a TDocVariantData
+    // - returns a void TDocVariant if aName is not a document
+    // - after a SortByName(aSortedCompare), could use faster binary search
+    // - consider using O[] or A[] properties if you want simple read-only
+    // access, or O_[] or A_[] properties if you want the ability to add
+    // a missing object or array in the document
+    function GetAsDocVariantSafe(const aName: RawUtf8;
+      aSortedCompare: TUtf8Compare = nil): PDocVariantData;
+    /// find an item in this document, and returns pointer to its value
+    // - return false if aName is not found
+    // - return true if the name has been found: then aValue stores a pointer
+    // to the value
+    // - after a SortByName(aSortedCompare), could use faster binary search
+    function GetAsPVariant(const aName: RawUtf8; out aValue: PVariant;
+      aSortedCompare: TUtf8Compare = nil): boolean; overload;
+       {$ifdef HASINLINE}inline;{$endif}
+    /// find an item in this document, and returns pointer to its value
+    // - lookup the value by aName/aNameLen for an object document, or accept
+    // an integer text as index for an array document
+    // - return nil if aName is not found, or if the instance is not a TDocVariant
+    // - return a pointer to the stored variant, if the name has been found
+    function GetAsPVariant(aName: PUtf8Char; aNameLen: PtrInt): PVariant; overload;
+      {$ifdef HASINLINE}inline;{$endif}
+    /// retrieve a value, given its path
+    // - path is defined as a dotted name-space, e.g. 'doc.glossary.title'
+    // - return Unassigned (varEmpty) if there is no item at the supplied aPath
+    // - you can set e.g. aPathDelim = '/' to search e.g. for 'parent/child'
+    // - see also the P[] property if the default aPathDelim = '.' is enough
+    function GetValueByPath(
+      const aPath: RawUtf8; aPathDelim: AnsiChar = '.'): variant; overload;
+    /// retrieve a value, given its path
+    // - path is defined as a dotted name-space, e.g. 'doc.glossary.title'
+    // - returns FALSE if there is no item at the supplied aPath
+    // - returns TRUE and set the found value in aValue
+    // - you can set e.g. aPathDelim = '/' to search e.g. for 'parent/child'
+    // - see also the P[] property if the default aPathDelim = '.' is enough
+    function GetValueByPath(const aPath: RawUtf8; out aValue: variant;
+      aPathDelim: AnsiChar = '.'): boolean; overload;
+    /// retrieve a value, given its path
+    // - path is defined as a list of names, e.g. ['doc','glossary','title']
+    // - return Unassigned (varEmpty) if there is no item at the supplied aPath
+    // - 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
+    // - you can set e.g. aPathDelim = '/' to search e.g. for 'parent/child'
+    function GetPVariantByPath(const aPath: RawUtf8;
+      aPathDelim: AnsiChar = '.'): PVariant;
+    /// retrieve a reference to a value, given its path
+    // - if the supplied aPath does not match any object, it will follow
+    // dvoReturnNullForUnknownProperty option
+    function GetPVariantExistingByPath(const aPath: RawUtf8;
+      aPathDelim: AnsiChar = '.'): 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
+    // - you can set e.g. aPathDelim = '/' to search e.g. for 'parent/child'
+    function GetDocVariantByPath(const aPath: RawUtf8;
+      out aValue: PDocVariantData; aPathDelim: AnsiChar = '.'): boolean;
+    /// retrieve a dvObject in the dvArray, from a property value
+    // - {aPropName:aPropValue} will be searched within the stored array,
+    // and the corresponding item will be copied into Dest, on match
+    // - returns FALSE if no match is found, TRUE if found and copied
+    // - create a copy of the variant by default, unless DestByRef is TRUE
+    // - will call VariantEquals() for value comparison
+    function GetItemByProp(const aPropName, aPropValue: RawUtf8;
+      aPropValueCaseSensitive: boolean; var Dest: variant;
+      DestByRef: boolean = false): boolean;
+    /// retrieve a reference to a dvObject in the dvArray, from a property value
+    // - {aPropName:aPropValue} will be searched within the stored array,
+    // and the corresponding item will be copied into Dest, on match
+    // - returns FALSE if no match is found, TRUE if found and copied by reference
+    function GetDocVariantByProp(const aPropName, aPropValue: RawUtf8;
+      aPropValueCaseSensitive: boolean; out Dest: PDocVariantData): boolean;
+    /// find an item in this document, and returns its value
+    // - raise an EDocVariant if not found and dvoReturnNullForUnknownProperty
+    // is not set in Options (in this case, it will return Null)
+    // - create a copy of the variant by default, unless DestByRef is TRUE
+    function RetrieveValueOrRaiseException(aName: PUtf8Char; aNameLen: integer;
+      aCaseSensitive: boolean; var Dest: variant; DestByRef: boolean): boolean; overload;
+    /// retrieve an item in this document from its index, and returns its value
+    // - raise an EDocVariant if the supplied Index is not in the 0..Count-1
+    // range and dvoReturnNullForUnknownProperty is set in Options
+    // - create a copy of the variant by default, unless DestByRef is TRUE
+    procedure RetrieveValueOrRaiseException(Index: integer;
+     var Dest: variant; DestByRef: boolean); overload;
+    /// retrieve an item in this document from its index, and returns its Name
+    // - raise an EDocVariant if the supplied Index is not in the 0..Count-1
+    // range and dvoReturnNullForUnknownProperty is set in Options
+    procedure RetrieveNameOrRaiseException(Index: integer; var Dest: RawUtf8);
+    /// 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;
+    /// 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);
+    /// set a value, given its path
+    // - path is defined as a dotted name-space, e.g. 'doc.glossary.title'
+    // - aCreateIfNotExisting=true will force missing nested objects creation
+    // - returns FALSE if there is no item to be set at the supplied aPath
+    // - returns TRUE and set the found value in aValue
+    // - you can set e.g. aPathDelim = '/' to search e.g. for 'parent/child'
+    function SetValueByPath(const aPath: RawUtf8; const aValue: variant;
+      aCreateIfNotExisting: boolean = false; aPathDelim: AnsiChar = '.'): boolean;
+
+    /// add a value in this document
+    // - if aName is set, if dvoCheckForDuplicatedNames option is set, any
+    // existing duplicated aName will raise an EDocVariant; if instance's
+    // kind is dvArray and aName is defined, it will raise an EDocVariant
+    // - aName may be '' e.g. if you want to store an array: in this case,
+    // dvoCheckForDuplicatedNames option should not be set; if instance's Kind
+    // is dvObject, it will raise an EDocVariant exception
+    // - if aValueOwned is true, then the supplied aValue will be assigned to
+    // the internal values - by default, it will use SetVariantByValue()
+    // - you can therefore write e.g.:
+    // ! TDocVariant.New(aVariant);
+    // ! Assert(TDocVariantData(aVariant).Kind=dvUndefined);
+    // ! TDocVariantData(aVariant).AddValue('name','John');
+    // ! Assert(TDocVariantData(aVariant).Kind=dvObject);
+    // - you can specify an optional index in the array where to insert
+    // - returns the index of the corresponding newly added value
+    function AddValue(const aName: RawUtf8; const aValue: variant;
+      aValueOwned: boolean = false; aIndex: integer = -1): integer; overload;
+    /// add a value in this document
+    // - overloaded function accepting a UTF-8 encoded buffer for the name
+    function AddValue(aName: PUtf8Char; aNameLen: integer; const aValue: variant;
+      aValueOwned: boolean = false; aIndex: integer = -1): 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 dvoAllowDoubleValue option is set)
+    // - if Update=TRUE, will set the property, even if it is existing
+    function AddValueFromText(const aName, aValue: RawUtf8;
+      DoUpdate: 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 - use Update() if you want to
+    // replace any existing value
+    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 Update(const NameValuePairs: array of const);
+    {$ifndef PUREMORMOT2}
+    /// deprecated method which redirects to Update()
+    procedure AddOrUpdateNameValuesToObject(const NameValuePairs: array of const);
+    {$endif PUREMORMOT2}
+    /// 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);
+    // - you can specify an optional index in the array where to insert
+    // - returns the index of the corresponding newly added item
+    function AddItem(const aValue: variant; aIndex: integer = -1): integer; overload;
+    /// add a TDocVariant value to this document, handled as array
+    function AddItem(const aValue: TDocVariantData; aIndex: integer = -1): integer; overload;
+    /// 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
+    // and/or as varDouble is dvoAllowDoubleValue option is set)
+    // - if instance's Kind is dvObject, it will raise an EDocVariant exception
+    // - you can specify an optional index in the array where to insert
+    // - returns the index of the corresponding newly added item
+    function AddItemFromText(const aValue: RawUtf8;
+      aIndex: integer = -1): integer;
+    /// add a RawUtf8 value to this document, handled as array
+    // - if instance's Kind is dvObject, it will raise an EDocVariant exception
+    // - you can specify an optional index in the array where to insert
+    // - returns the index of the corresponding newly added item
+    function AddItemText(const aValue: RawUtf8; aIndex: integer = -1): 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 object document to this document
+    // - if the document is an array, keep aName=''
+    // - if the document is an object, set the new object property as aName
+    // - new object will keep the same options as this document
+    // - slightly faster than AddItem(_Obj(...)) or AddValue(aName, _Obj(...))
+    procedure AddObject(const aNameValuePairs: array of const;
+      const aName: RawUtf8 = '');
+    /// add one or several values from another document
+    // - supplied document should be of the same kind than the current one,
+    // otherwise nothing is added
+    // - for an object, dvoCheckForDuplicatedNames flag is used: use
+    // AddOrUpdateFrom() to force objects merging
+    procedure AddFrom(const aDocVariant: Variant);
+    /// merge (i.e. add or update) several values 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 open array, e.g. ['doc','glossary','title'], but
+    // could also contained nested paths, e.g. ['doc.glossary', title'] or
+    // ['doc', 'glossary/title'] of aPathDelim is '/'
+    // - 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; aPathDelim: AnsiChar = '.');
+    /// 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: PtrInt): 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; aValue: PVariant = nil): boolean; overload;
+    /// delete/filter some values/items in this document, from their name
+    // - return the number of deleted items
+    function Delete(const aNames: array of RawUtf8): integer; overload;
+    /// delete a value/item in this document, from its name
+    // - path is defined as a dotted name-space, e.g. 'doc.glossary.title'
+    // - return TRUE on success, FALSE if the supplied name does not exist
+    // - you can set e.g. aPathDelim = '/' to search e.g. for 'parent/child'
+    function DeleteByPath(const aPath: RawUtf8; aPathDelim: AnsiChar = '.';
+      aDeletedValue: PVariant = nil): boolean;
+    /// 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 occurrences 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;
+    /// retrieve a value at a given index, and delete it from the array
+    // - negative aIndex are from VCount, i.e. Extract(-1) pop the last item
+    function Extract(aIndex: integer; var aValue: variant;
+      aName: PRawUtf8 = nil): boolean;
+    /// 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: PtrInt = 0): PtrInt;
+    /// search and count occurences of one value in this document, handled as array
+    function CountItemByValue(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(SortCompare: TUtf8Compare = nil;
+      SortCompareReversed: boolean = false);
+    /// sort the document object values by value using a comparison function
+    // - work for both dvObject and dvArray documents
+    // - will sort by UTF-8 text (VariantCompare) if no custom aCompare is supplied
+    procedure SortByValue(SortCompare: TVariantCompare = nil;
+      SortCompareReversed: boolean = false);
+    /// sort the document object values by value using a comparison method
+    // - work for both dvObject and dvArray documents
+    // - you should supply a TVariantComparer callback method
+    procedure SortByRow(const SortComparer: TVariantComparer;
+      SortComparerReversed: boolean = false);
+    /// 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
+    // - aValueCompare will be called with the aItemPropName values, not row
+    // - will sort by UTF-8 text (VariantCompare) if no custom aValueCompare is supplied
+    // - this method is faster than SortByValue/SortByRow
+    procedure SortArrayByField(const aItemPropName: RawUtf8;
+      aValueCompare: TVariantCompare = nil;
+      aValueCompareReverse: boolean = false;
+      aNameSortedCompare: TUtf8Compare = nil);
+    /// sort the document array values by field(s) of some stored objet values
+    // - allow up to 4 fields (aItemPropNames[0]..aItemPropNames[3])
+    // - 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 aValueCompareField is supplied
+    procedure SortArrayByFields(const aItemPropNames: array of RawUtf8;
+      aValueCompare: TVariantCompare = nil;
+      const aValueCompareField: TVariantCompareField = nil;
+      aValueCompareReverse: boolean = false; aNameSortedCompare: TUtf8Compare = nil);
+    /// inverse the order of Names and Values of this document
+    // - could be applied after a content sort if needed
+    procedure Reverse;
+    /// create a TDocVariant object, from a selection of properties of the
+    // objects of this document array, 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;
+      var result: TDocVariantData; aDoNotAddVoidProp: boolean = false); overload;
+    /// create a TDocVariant object, from a selection of properties of the
+    // objects of this document array, 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, matching a filtering expression
+    // - expressions are e.g. 'name=Synopse' or 'price<100'
+    procedure ReduceFilter(const aExpression: RawUtf8; var result: TDocVariantData;
+      aLimit: integer = 0; aCompare: TVariantCompare = nil); overload;
+    /// create a TDocVariant array, matching a filtering expression
+    // - expressions are e.g. 'name=Synopse' or 'price<100'
+    function ReduceFilter(const aExpression: RawUtf8; aLimit: integer = 0): variant; overload;
+    /// create a TDocVariant array, matching a filtering expression
+    // - e.g. ReduceFilter('name=','Synopse') or ReduceFilter('price<',MaxPrice)
+    procedure ReduceFilter(const aExpression: RawUtf8; const aValue: variant;
+      var result: TDocVariantData; aCompare: TVariantCompare = nil;
+      aLimit: integer = 0); overload;
+    /// create a TDocVariant array, matching a filtering expression
+    // - e.g. ReduceFilter('name=','Synopse') or ReduceFilter('price<',MaxPrice)
+    function ReduceFilter(const aExpression: RawUtf8; const aValue: variant;
+      aLimit: integer = 0): variant; overload;
+    /// create a TDocVariant array, matching a filtering set of raw parameters
+    procedure ReduceFilter(const aKey: RawUtf8; const aValue: variant;
+      aMatch: TCompareOperator; aCompare: TVariantCompare; aLimit: integer;
+      var result: TDocVariantData); overload;
+    /// create a TDocVariant array, from the values of a single property of the
+    // objects of this document array, specified by name
+    // - you can optionally apply an additional filter to each reduced item
+    procedure ReduceAsArray(const aPropName: RawUtf8;
+      var result: TDocVariantData;
+      const OnReduce: TOnReducePerItem = nil); overload;
+    /// create a TDocVariant array, from the values of a single property of the
+    // objects of this document array, 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;
+      const OnReduce: TOnReducePerItem = nil): variant; overload;
+    /// create a TDocVariant array, from the values of a single property of the
+    // objects of this document array, specified by name
+    // - this overloaded method accepts an additional filter to each reduced item
+    procedure ReduceAsArray(const aPropName: RawUtf8;
+      var result: TDocVariantData;
+      const OnReduce: TOnReducePerValue); overload;
+    /// create a TDocVariant array, from the values of a single property of the
+    // objects of this document array, 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;
+      const OnReduce: TOnReducePerValue): variant; overload;
+    /// return the variant values of a single property of the objects of this
+    // document array, specified by name
+    // - returns nil if the document is not a dvArray
+    function ReduceAsVariantArray(const aPropName: RawUtf8;
+      aDuplicates: TSearchDuplicate = sdNone): TVariantDynArray;
+    /// rename some properties of a TDocVariant object
+    // - returns the number of property names modified
+    function Rename(const aFromPropName, aToPropName: TRawUtf8DynArray): integer;
+    /// return a dynamic array with all dvObject Names, and length() = Count
+    // - since length(Names) = Capacity, you can use this method to retrieve
+    // all the object keys
+    // - consider using FieldNames iterator or Names[0..Count-1] if you need
+    // to iterate on the key names
+    // - will internally force length(Names)=length(Values)=Capacity=Count and
+    // return the Names[] instance with no memory (re)allocation
+    // - if the document is not a dvObject, will return nil
+    function GetNames: TRawUtf8DynArray;
+    /// 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
+    // - is computed from the dvoArray or dvoObject flags 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
+    // - always 0 for Kind=dvUndefined
+    // - the number of name/value pairs for Kind=dvObject (may be 0 if void)
+    // - the number of items for Kind=dvArray (may be 0 if void)
+    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
+    // - note that length(Values)=Capacity and not Count, so copy(Values, 0, Count)
+    // or use FieldValues iterator if you want the exact count
+    // - transtyping a variant and direct access to TDocVariantData is the
+    // fastest way of accessing all properties of a given dvObject:
+    // ! with _Safe(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
+    // - note that length(Names)=Capacity and not Count, so copy(Names, 0, Count)
+    // or use FieldNames iterator or GetNames if you want the exact count
+    // - transtyping a variant and direct access to TDocVariantData is the
+    // fastest way of accessing all properties of a given dvObject:
+    // ! with _Safe(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'];
+    // or
+    // ! aValue := _Safe(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, or P[] to retrieve a variant from its path
+    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 (internally, 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
+    // - the new property object would inherit from the Options of this instance
+    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
+    // - the new property array would inherit from the Options of this instance
+    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;
+    /// direct access to a dvObject value stored property value from its path name
+    // - default Value[] will check only names in the current object properties,
+    // whereas this property will recognize e.g. 'parent.child' nested objects
+    // - follows dvoNameCaseSensitive and dvoReturnNullForUnknownProperty options
+    property P[const aNameOrPath: RawUtf8]: Variant
+      read GetVariantByPath;
+  end;
+  {$A+} { packet object not allowed since Delphi 2009 :( }
+
+var
+  /// the internal custom variant type used to register TDocVariant
+  DocVariantType: TDocVariant;
+
+  /// copy of DocVariantType.VarType
+  // - as used by inlined functions of TDocVariantData
+  DocVariantVType: cardinal;
+
+  // defined here for inlining - properly filled in initialization section below
+  DV_FAST: array[TDocVariantKind] of TVarData;
+
+
+/// 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');
+// - note: due to a local variable lifetime change in Delphi 11, don't use
+// this function with a temporary variant (e.g. from TList.GetItem) -
+// call _DV() and a local TDocVariantData instead of a PDocVariantData
+function DocVariantData(const DocVariant: variant): PDocVariantData;
+
+const
+  /// constant used e.g. by _Safe() and _DV() 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: varNull;
+    VOptions: [dvoReturnNullForUnknownProperty]{%H-});
+
+/// direct access to a TDocVariantData from a given variant instance
+// - return a pointer to the TDocVariantData corresponding to the variant
+// instance, which may be of kind varByRef (e.g. when retrieved by late binding)
+// - will return a read-only fake TDocVariantData with Kind=dvUndefined if the
+// supplied variant is not a TDocVariant instance, so could be safely used
+// in a with block (use "with" moderation, of course):
+// ! with _Safe(aDocVariant)^ do
+// !   for ndx := 0 to Count-1 do // here Count=0 for the "fake" result
+// !     writeln(Names[ndx]);
+// or excluding the "with" statement, as more readable code:
+// ! var dv: PDocVariantData;
+// !     ndx: PtrInt;
+// ! begin
+// !   dv := _Safe(aDocVariant);
+// !   for ndx := 0 to dv.Count-1 do // here Count=0 for the "fake" result
+// !     writeln(dv.Names[ndx]);
+// - note: due to a local variable lifetime change in Delphi 11, don't use
+// this function with a temporary variant (e.g. from TList.GetItem) -
+// call _DV() and a local TDocVariantData instead of a PDocVariantData
+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
+// - note: due to a local variable lifetime change in Delphi 11, don't use
+// this function with a temporary variant (e.g. from TList.GetItem) -
+// call _DV() and a local TDocVariantData instead of a PDocVariantData
+function _Safe(const DocVariant: variant;
+  ExpectedKind: TDocVariantKind): PDocVariantData; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// direct access to a TDocVariantData from a given variant instance
+// - return true and set DocVariant with a pointer to the TDocVariantData
+// corresponding to the variant instance, which may be of kind varByRef
+// (e.g. when retrieved by late binding)
+// - return false if the supplied Value is not a TDocVariant, but e.g. a string,
+// a number or another type of custom variant
+// - note: due to a local variable lifetime change in Delphi 11, don't use
+// this function with a temporary variant (e.g. from TList.GetItem) -
+// call _DV() and a local TDocVariantData instead of a PDocVariantData
+function _Safe(const DocVariant: variant; out DV: PDocVariantData): boolean; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// direct access to a TDocVariantData array from a given variant instance
+// - return true and set DV with a pointer to the TDocVariantData
+// corresponding to the variant instance, if it is a dvArray
+// - return false if the supplied Value is not an array TDocVariant
+// - note: due to a local variable lifetime change in Delphi 11, don't use
+// this function with a temporary variant (e.g. from TList.GetItem) -
+// call _DV() and a local TDocVariantData instead of a PDocVariantData
+function _SafeArray(const Value: variant; out DV: PDocVariantData): boolean; overload;
+
+/// direct access to a TDocVariantData array from a given variant instance
+// - overload to check for a given number of itemsin the array
+function _SafeArray(const Value: variant; ExpectedCount: integer;
+  out DV: PDocVariantData): boolean; overload;
+
+/// direct access to a TDocVariantData object from a given variant instance
+// - return true and set DV with a pointer to the TDocVariantData
+// corresponding to the variant instance, if it is a dvObject
+// - return false if the supplied Value is not an object TDocVariant
+// - note: due to a local variable lifetime change in Delphi 11, don't use
+// this function with a temporary variant (e.g. from TList.GetItem) -
+// call _DV() and a local TDocVariantData instead of a PDocVariantData
+function _SafeObject(const Value: variant; out DV: PDocVariantData): boolean;
+
+/// direct copy of a TDocVariantData from a given variant instance
+// - slower, but maybe used instead of _Safe() e.g. on Delphi 11
+function _DV(const DocVariant: variant): TDocVariantData; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// direct copy of a TDocVariantData from a given variant instance
+// - slower, but maybe used instead of _Safe() e.g. on Delphi 11
+function _DV(const DocVariant: variant;
+  ExpectedKind: TDocVariantKind): TDocVariantData; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// direct copy of a TDocVariantData from a given variant instance
+// - slower, but maybe used instead of _Safe() e.g. on Delphi 11
+function _DV(const DocVariant: variant;
+  var DV: TDocVariantData): boolean; overload;
+  {$ifdef FPC}inline;{$endif} // Delphi has troubles inlining goto/label
+
+/// 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 a property value to a document-based object content
+// - if Obj is a TDocVariant object, will add the Name/Value pair
+// - 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 _ObjAddProp(const Name: RawUtf8; const Value: variant;
+  var Obj: variant); overload;
+
+/// add a document property value to a document-based object content
+procedure _ObjAddProp(const Name: RawUtf8; const Value: TDocVariantData;
+  var Obj: variant); overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// add a RawUtf8 property value to a document-based object content
+procedure _ObjAddPropU(const Name: RawUtf8; const Value: RawUtf8;
+  var Obj: 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 return
+// an Unassigned (varEmpty) 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 mormot.db.nosql.bson 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()
+// - handle only currency for floating point values: call _JsonFastFloat or set
+// dvoAllowDoubleValue option to support double, with potential precision loss
+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 mormot.db.nosql.bson 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;
+
+/// initialize a variant instance to store some document-based object content
+// - this global function is an handy alias to:
+// ! Obj(NameValuePairs, JSON_FAST);
+// - 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 ObjectToVariant(aObject, result, aOptions)
+function _ObjFast(aObject: TObject;
+   aOptions: TTextWriterWriteObjectOptions = [woDontStoreDefault]): variant; overload;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// initialize a variant instance to store some document-based array content
+// - this global function is an handy alias to:
+// ! _Array(Items, JSON_FAST);
+// - 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_FAST);
+// so returns an Unassigned (varEmpty) 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()
+// - will handle only currency for floating point values to avoid precision
+// loss: use _JsonFastFloat() instead if you want to support double values
+function _JsonFast(const Json: RawUtf8): variant;
+
+/// initialize a variant instance to store some document-based content
+// from a supplied (extended) JSON content, with double conversion
+// - _JsonFast() will support only currency floats: use this method instead
+// if your JSON input is likely to require double values - with potential
+// precision loss
+function _JsonFastFloat(const Json: RawUtf8): variant;
+
+/// initialize a variant instance to store some extended document-based content
+// - this global function is an handy alias to:
+// ! _Json(JSON, JSON_FAST_EXTENDED);
+function _JsonFastExt(const Json: RawUtf8): variant;
+
+/// initialize a variant instance to store some document-based content
+// from a supplied (extended) JSON content, with parameters formating
+// - this global function is an handy alias e.g. to:
+// ! aVariant := _JsonFmt('{%:{$in:[?,?]}}',['type'],['food','snack'], JSON_FAST);
+// - 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_[mDefault])
+// - 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_FAST)
+// - 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_[mDefault])
+// - 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;
+
+/// return a full nested copy of a document-based variant instance
+// - is just a wrapper around:
+// ! TDocVariant.NewUnique(DocVariant, JSON_FAST)
+// - 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;
+
+/// 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
+// - fast processing function as used by _ObjFast(Value)
+// - 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 = [woDontStoreDefault]); overload;
+
+/// will convert any TObject into a TDocVariant document instance
+// - convenient overloaded function to include woEnumSetsAsText option
+function ObjectToVariant(Value: TObject; EnumSetsAsText: boolean): variant; overload;
+
+/// will serialize any TObject into a TDocVariant debugging document
+// - just a wrapper around _JsonFast(ObjectToJsonDebug()) with an optional
+// "Context":"..." text message
+// - if the supplied context format matches '{....}' then it will be added
+// as a corresponding TDocVariant JSON object
+function ObjectToVariantDebug(Value: TObject;
+  const ContextFormat: RawUtf8; const ContextArgs: array of const;
+  const ContextName: RawUtf8 = 'context'): variant; overload;
+
+/// get the enumeration names corresponding to a set value, as a JSON array
+function SetNameToVariant(Value: cardinal; Info: TRttiCustom;
+  FullSetsAsStar: boolean = false): variant; overload;
+
+/// get the enumeration names corresponding to a set value, as a JSON array
+function SetNameToVariant(Value: cardinal; Info: PRttiInfo;
+  FullSetsAsStar: boolean = false): variant; overload;
+
+/// fill a class instance from a TDocVariant object document properties
+// - returns FALSE if the variant is not a dvObject, TRUE otherwise
+function DocVariantToObject(var doc: TDocVariantData; obj: TObject;
+  objRtti: TRttiCustom = nil): boolean;
+
+/// fill a T*ObjArray variable from a TDocVariant array document values
+// - will always erase the T*ObjArray instance, and fill it from arr values
+procedure DocVariantToObjArray(var arr: TDocVariantData; var objArray;
+  objClass: TClass);
+
+/// will convert a blank TObject into a TDocVariant document instance
+function ObjectDefaultToVariant(aClass: TClass;
+  aOptions: TDocVariantOptions): variant; overload;
+
+
+
+{ ************** JSON Parsing into Variant }
+
+/// low-level function to set a variant from an unescaped JSON number or string
+// - expect the JSON input buffer to be already unescaped and #0 terminated,
+// e.g. by TGetJsonField, and having set properly the wasString flag
+// - set the varString or call GetVariantFromNotStringJson() if TryCustomVariants=nil
+// - or call JsonToAnyVariant() to support TryCustomVariants^ complex input
+procedure GetVariantFromJsonField(Json: PUtf8Char; wasString: boolean;
+  var Value: variant; TryCustomVariants: PDocVariantOptions = nil;
+  AllowDouble: boolean = false; JsonLen: integer = 0);
+
+/// low-level function to set a variant from an unescaped JSON non string
+// - expect the JSON input buffer to be already unescaped and #0 terminated,
+// e.g. by TGetJsonField, and having returned wasString=false
+// - is called e.g. by function GetVariantFromJsonField()
+// - 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;
+  {$ifdef HASINLINE}inline;{$endif}
+
+/// low-level function to parse a JSON buffer content into a variant
+// - warning: will decode in the Json buffer memory itself (no memory
+// allocation or copy), for faster process - so take care that it is not shared
+// - internal method used by VariantLoadJson(), GetVariantFromJsonField() and
+// TDocVariantData.InitJson()
+// - 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_[mFast] 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 JsonToAnyVariant(var Value: variant; var Info: TGetJsonField;
+  Options: PDocVariantOptions; AllowDouble: boolean = false);
+
+{$ifndef PUREMORMOT2}
+/// low-level function to parse a JSON content into a variant
+procedure GetJsonToAnyVariant(var Value: variant; var Json: PUtf8Char;
+  EndOfObject: PUtf8Char; Options: PDocVariantOptions; AllowDouble: boolean);
+    overload; {$ifdef HASINLINE}inline;{$endif}
+{$endif PUREMORMOT2}
+
+/// identify either varInt64, varDouble, varCurrency types following JSON format
+// - any non valid number is returned as varString
+// - warning: supplied JSON is expected to be not nil
+function TextToVariantNumberType(Json: PUtf8Char): cardinal;
+
+/// identify either varInt64 or varCurrency types following JSON format
+// - this version won't return varDouble, i.e. won't handle more than 4 exact
+// decimals (as varCurrency), nor scientific notation with exponent (1.314e10)
+// - this will ensure that any incoming JSON will converted back with its exact
+// textual representation, without digit truncation due to limited precision
+// - any non valid number is returned as varString
+// - warning: supplied JSON is expected to be not nil
+function TextToVariantNumberTypeNoDouble(Json: PUtf8Char): cardinal;
+
+/// low-level function to parse a variant from an unescaped JSON number
+// - returns the position after the number, and set Value to a variant of type
+// varInteger/varInt64/varCurrency (or varDouble if AllowVarDouble is true)
+// - returns nil if JSON can't be converted to a number - it is likely a string
+// - handle only up to 4 decimals (i.e. currency) if AllowVarDouble is false
+// - matches TextToVariantNumberType/TextToVariantNumberTypeNoDouble() logic
+// - see GetVariantFromNotStringJson() to check the whole Json input, and
+// parse null/false/true values
+function GetNumericVariantFromJson(Json: PUtf8Char;
+  var Value: TVarData; AllowVarDouble: boolean): PUtf8Char;
+
+/// convert some UTF-8 into a variant, detecting JSON numbers or constants
+// - first try GetVariantFromNotStringJson() then fallback to RawUtf8ToVariant()
+procedure TextToVariant(const aValue: RawUtf8; AllowVarDouble: boolean;
+  out aDest: variant);
+
+/// convert some UTF-8 buffer into a variant, detecting JSON numbers or constants
+// - first try GetVariantFromNotStringJson() then fallback to RawUtf8ToVariant()
+procedure TextBufferToVariant(aValue: PUtf8Char; AllowVarDouble: boolean;
+  out aDest: variant);
+
+/// convert some UTF-8 text buffer into a variant, with string interning
+// - similar to TextToVariant(), but with string interning (if Interning<>nil)
+// - first try GetVariantFromNotStringJson() then fallback to RawUtf8ToVariant()
+procedure UniqueVariant(Interning: TRawUtf8Interning;
+  var aResult: variant; aText: PUtf8Char; aTextLen: PtrInt;
+  aAllowVarDouble: boolean = false); overload;
+
+/// convert the next CSV item into a variant number or RawUtf8 varString
+// - just a wrapper around GetNextItem() + TextToVariant()
+function GetNextItemToVariant(var P: PUtf8Char;
+  out Value: Variant; Sep: AnsiChar = ','; AllowDouble: boolean = true): boolean;
+
+/// retrieve a variant value from a JSON number or string
+// - follows TJsonWriter.AddVariant() format (calls JsonToAnyVariant)
+// - make a temporary copy before parsing - use JsonToAnyVariant() on a buffer
+// - return true and set Value on success, or false and empty Value on error
+function VariantLoadJson(var Value: Variant; const Json: RawUtf8;
+  TryCustomVariants: PDocVariantOptions = nil;
+  AllowDouble: boolean = false): boolean; overload;
+
+/// retrieve a variant value from a JSON number or string
+// - just wrap VariantLoadJson(Value,Json...) procedure as a function
+function VariantLoadJson(const Json: RawUtf8;
+  TryCustomVariants: PDocVariantOptions = nil;
+  AllowDouble: boolean = false): variant; overload;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// just a wrapper around VariantLoadJson() with some TDocVariantOptions
+// - make a temporary copy of the input Json before parsing
+function JsonToVariant(const Json: RawUtf8;
+  Options: TDocVariantOptions = [dvoReturnNullForUnknownProperty];
+  AllowDouble: boolean = false): variant;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// just a wrapper around JsonToAnyVariant() with some TDocVariantOptions
+function JsonToVariantInPlace(var Value: Variant; Json: PUtf8Char;
+  Options: TDocVariantOptions = [dvoReturnNullForUnknownProperty];
+  AllowDouble: boolean = false): PUtf8Char;
+  {$ifdef HASINLINE} inline; {$endif}
+
+/// decode multipart/form-data POST request content into a TDocVariantData
+// - following RFC 1867
+// - decoded sections are encoded as Doc JSON object with its textual values,
+// or with nested objects, if the data was supplied as binary:
+// ! {"name1":{"data":..,"filename":...,"contenttype":...},"name2":...}
+procedure MultiPartToDocVariant(const MultiPart: TMultiPartDynArray;
+  var Doc: TDocVariantData; Options: PDocVariantOptions = nil);
+
+/// parse a "key dvUndefined=0 dvArray=1 dvObject=2
+  result := TDocVariantKind((TRttiVarData(self).VType shr 16) and _DVO);
+end;
+
+function TDocVariantData.Has(dvo: TDocVariantOption): boolean;
+begin
+  result := (TRttiVarData(self).VType and (1 shl (ord(dvo) + 16))) <> 0;
+end;
+
+function TDocVariantData.IsObject: boolean;
+begin
+  result := Has(dvoIsObject);
+end;
+
+function TDocVariantData.IsArray: boolean;
+begin
+  result := Has(dvoIsArray);
+end;
+
+function TDocVariantData.IsCaseSensitive: boolean;
+begin
+  result := Has(dvoNameCaseSensitive);
+end;
+
+procedure TDocVariantData.ClearFast;
+begin
+  TRttiVarData(self).VType := 0; // clear VType and VOptions
+  Void;
+end;
+
+procedure TDocVariantData.InternalSetValue(aIndex: PtrInt; const aValue: variant);
+begin
+  SetVariantByValue(aValue, VValue[aIndex]); // caller ensured that aIndex is OK
+  if Has(dvoInternValues) then
+    InternalUniqueValueAt(aIndex);
+end;
+
+
+{ ************** Low-Level Variant Wrappers }
+
+function VarIs(const V: Variant; const VTypes: TVarDataTypes): boolean;
+var
+  vd: PVarData;
+  vt: cardinal;
+begin
+  vd := @V;
+  repeat
+    vt := vd^.VType;
+    if vt <> varVariantByRef then
+      break;
+    vd := vd^.VPointer;
+    if vd = nil then
+    begin
+      result := false;
+      exit;
+    end;
+  until false;
+  result := vt in VTypes;
+end;
+
+function VarIsVoid(const V: Variant): boolean;
+var
+  vt: cardinal;
+  custom: TSynInvokeableVariantType;
+begin
+  vt := TVarData(V).VType;
+  with TVarData(V) do
+    case vt of
+      varEmpty,
+      varNull:
+        result := true;
+      varBoolean:
+        result := not VBoolean;
+      {$ifdef HASVARUSTRING}
+      varUString,
+      {$endif HASVARUSTRING}
+      varString,
+      varOleStr:
+        result := VAny = nil;
+      varDate:
+        result := VInt64 = 0;
+      // note: 0 as integer or float is considered as non-void
+    else
+      if vt = varVariantByRef then
+        result := VarIsVoid(PVariant(VPointer)^)
+      else if (vt = varStringByRef) or
+              (vt = varOleStrByRef)
+              {$ifdef HASVARUSTRING} or
+              (vt = varUStringByRef)
+              {$endif HASVARUSTRING} then
+        result := PPointer(VAny)^ = nil
+      else if vt = DocVariantVType then
+        result := TDocVariantData(V).Count = 0
+      else
+      begin
+        custom := FindSynVariantType(vt);
+        result := (custom <> nil) and
+                  custom.IsVoid(TVarData(V)); // e.g. TBsonVariant.IsVoid
+      end;
+    end;
+end;
+
+function VarStringOrNull(const v: RawUtf8): variant;
+begin
+  if v = '' then
+    SetVariantNull(result{%H-})
+  else
+    RawUtf8ToVariant(v, result);
+end;
+
+procedure SetVariantByRef(const Source: Variant; var Dest: Variant);
+var
+  vt: cardinal;
+begin
+  if PInteger(@Dest)^ <> 0 then // VarClear() is not always inlined :(
+    VarClear(Dest);
+  vt := TVarData(Source).VType;
+  if ((vt and varByRef) <> 0) or
+     (vt in VTYPE_SIMPLE) then
+    TVarData(Dest) := TVarData(Source)
+  else if not SetVariantUnRefSimpleValue(Source, TVarData(Dest)) then
+  begin
+    TRttiVarData(Dest).VType := varVariantByRef;
+    TVarData(Dest).VPointer := @Source;
+  end;
+end;
+
+procedure SetVariantByValue(const Source: Variant; var Dest: Variant);
+var
+  s: PVarData;
+  d: TVarData absolute Dest;
+  dt: cardinal absolute Dest;
+  vt: cardinal;
+  ct: TSynInvokeableVariantType;
+begin
+  s := @Source;
+  if PInteger(@Dest)^ <> 0 then // VarClear() is not always inlined :(
+    VarClear(Dest);
+  vt := s^.VType;
+  while vt = varVariantByRef do
+  begin
+    s := s^.VPointer;
+    vt := s^.VType;
+  end;
+  case vt of
+    varEmpty..varDate,
+    varBoolean,
+    varShortInt..varWord64:
+      begin
+        dt := vt;
+        d.VInt64 := s^.VInt64;
+      end;
+    varString:
+      begin
+        dt := varString;
+        d.VAny := nil;
+        RawByteString(d.VAny) := RawByteString(s^.VAny);
+      end;
+    varStringByRef:
+      begin
+        dt := varString;
+        d.VAny := nil;
+        RawByteString(d.VAny) := PRawByteString(s^.VAny)^;
+      end;
+    {$ifdef HASVARUSTRING}
+    varUString,
+    varUStringByRef,
+    {$endif HASVARUSTRING}
+    varOleStr,
+    varOleStrByRef:
+      begin
+        dt := varString;
+        d.VAny := nil;
+        VariantToUtf8(PVariant(s)^, RawUtf8(d.VAny)); // store as RawUtf8
+      end;
+  else // note: varVariant should not happen here
+    if DocVariantType.FindSynVariantType(vt, ct) then
+      ct.CopyByValue(d, s^) // needed e.g. for TBsonVariant
+    else
+      SetVariantUnRefSimpleValue(PVariant(s)^, d);
+  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}
+  PInt64Array(Value)^[2] := 0;
+  {$endif CPU64}
+end;
+
+procedure FillZero(var value: variant);
+begin
+  if TRttiVarData(value).VType and $ffff = varString then
+    FillZero(RawByteString(TVarData(value).VAny));
+  VarClear(value);
+end;
+
+procedure _VariantClearSeveral(V: PVarData; n: integer);
+var
+  vt, docv: cardinal;
+  handler: TCustomVariantType;
+  clearproc: procedure(V: PVarData);
+label
+  clr, hdr;
+begin
+  handler := nil;
+  docv := DocVariantVType;
+  clearproc := @VarClearProc;
+  repeat
+    vt := V^.VType;
+    if vt <= varWord64 then
+    begin
+      if (vt >= varOleStr) and
+         (vt <= varError) then
+        if vt = varOleStr then
+          WideString(V^.VAny) := ''
+        else
+          goto clr; // varError/varDispatch
+    end // note: varVariant/varUnknown are not handled because should not appear
+    else if vt = varString then
+      {$ifdef FPC}
+      FastAssignNew(V^.VAny)
+      {$else}
+      RawUtf8(V^.VAny) := ''
+      {$endif FPC}
+    else if vt < varByRef then // varByRef has no refcount -> nothing to clear
+      if vt = docv then
+        PDocVariantData(V)^.ClearFast // faster than Clear
+      {$ifdef HASVARUSTRING}
+      else if vt = varUString then
+        UnicodeString(V^.VAny) := ''
+      {$endif HASVARUSTRING}
+      else if vt >= varArray then // custom types are below varArray
+clr:    clearproc(V)
+      else if handler = nil then
+        if FindCustomVariantType(vt, handler) then
+hdr:      handler.Clear(V^)
+        else
+          goto clr
+      else if vt = handler.VarType then
+        goto hdr
+      else
+        goto clr;
+    PInteger(V)^ := varEmpty; // reset VType
+    inc(V);
+    dec(n);
+  until n = 0;
+end;
+
+procedure RawUtf8ToVariant(const Txt: RawUtf8; var Value: TVarData;
+  ExpectedValueType: cardinal);
+begin
+  if ExpectedValueType = varString then
+  begin
+    RawUtf8ToVariant(Txt, variant(Value));
+    exit;
+  end;
+  VarClearAndSetType(variant(Value), ExpectedValueType);
+  Value.VAny := nil; // avoid GPF below
+  if Txt <> '' then
+    case ExpectedValueType of
+      varOleStr:
+        Utf8ToWideString(Txt, WideString(Value.VAny));
+      {$ifdef HASVARUSTRING}
+      varUString:
+        Utf8DecodeToUnicodeString(
+          pointer(Txt), length(Txt), UnicodeString(Value.VAny));
+      {$endif HASVARUSTRING}
+    else
+      raise ESynVariant.CreateUtf8('RawUtf8ToVariant(%)?', [ExpectedValueType]);
+    end;
+end;
+
+function VariantToString(const V: Variant): string;
+begin
+  VariantToString(V, result);
+end;
+
+procedure VariantToString(const V: Variant; var result: string);
+var
+  wasString: boolean;
+  tmp: RawUtf8;
+  vt: cardinal;
+begin
+  vt := TVarData(V).VType;
+  case vt of
+    varEmpty,
+    varNull:
+      result := ''; // default VariantToUtf8(null)='null'
+    {$ifdef UNICODE} // not HASVARUSTRING: here we handle string=UnicodeString
+    varOleStr:
+      SetString(result, PWideChar(TVarData(V).VAny), length(WideString(TVarData(V).VAny)));
+    varUString:
+      result := UnicodeString(TVarData(V).VAny);
+    varUStringByRef:
+      result := PUnicodeString(TVarData(V).VAny)^;
+    varOleStrByRef:
+      SetString(result, PPWideChar(TVarData(V).VAny)^,
+        length(PWideString(TVarData(V).VAny)^));
+    {$endif UNICODE}
+  else
+    begin
+      VariantToUtf8(V, tmp, wasString);
+      if tmp = '' then
+        result := ''
+      else
+      {$ifndef UNICODE}
+      if not wasString or
+         (Unicode_CodePage = CP_UTF8) or
+         IsAnsiCompatible(tmp) then
+        result := tmp
+      else
+      {$endif UNICODE}
+        Utf8ToStringVar(tmp, result);
+    end;
+  end;
+end;
+
+procedure VariantToVarRec(const V: variant; var result: TVarRec);
+begin
+  result.VType := vtVariant;
+  if TVarData(V).VType = varVariantByRef then
+    result.VVariant := TVarData(V).VPointer
+  else
+    result.VVariant := @V;
+end;
+
+procedure VariantsToArrayOfConst(const V: array of variant; VCount: PtrInt;
+  out result: TTVarRecDynArray);
+var
+  i: PtrInt;
+begin
+  SetLength(result, VCount);
+  for i := 0 to VCount - 1 do
+    VariantToVarRec(V[i], result[i]);
+end;
+
+function VariantsToArrayOfConst(const V: array of variant): TTVarRecDynArray;
+begin
+  VariantsToArrayOfConst(V, length(V), result);
+end;
+
+function RawUtf8DynArrayToArrayOfConst(const V: array of RawUtf8): TTVarRecDynArray;
+var
+  i: PtrInt;
+begin
+  result := nil;
+  SetLength(result, Length(V));
+  for i := 0 to Length(V) - 1 do
+  begin
+    result[i].VType := vtAnsiString;
+    result[i].VAnsiString := pointer(V[i]);
+  end;
+end;
+
+function VarRecToVariant(const V: TVarRec): variant;
+begin
+  VarRecToVariant(V, result);
+end;
+
+procedure VarRecToVariant(const V: TVarRec; var result: variant);
+begin
+  VarClear(result{%H-});
+  with TRttiVarData(result) do
+    case V.VType of
+      vtPointer:
+        VType := varNull;
+      vtBoolean:
+        begin
+          VType := varBoolean;
+          Data.VBoolean := V.VBoolean;
+        end;
+      vtInteger:
+        begin
+          VType := varInteger;
+          Data.VInteger := V.VInteger;
+        end;
+      vtInt64:
+        begin
+          VType := varInt64;
+          Data.VInt64 := V.VInt64^;
+        end;
+      {$ifdef FPC}
+      vtQWord:
+        begin
+          VType := varWord64;
+          Data.VQWord := V.VQWord^;
+        end;
+      {$endif FPC}
+      vtCurrency:
+        begin
+          VType := varCurrency;
+          Data.VInt64 := PInt64(V.VCurrency)^;
+        end;
+      vtExtended:
+        begin
+          VType := varDouble;
+          Data.VDouble := V.VExtended^;
+        end;
+      vtVariant:
+        result := V.VVariant^;
+      // warning: use varStringByRef makes GPF -> safe and fast refcount
+      vtAnsiString:
+        begin
+          VType := varString;
+          Data.VAny := nil;
+          RawByteString(Data.VAny) := RawByteString(V.VAnsiString);
+        end;
+      {$ifdef HASVARUSTRING}
+      vtUnicodeString,
+      {$endif HASVARUSTRING}
+      vtWideString,
+      vtString,
+      vtPChar,
+      vtChar,
+      vtWideChar,
+      vtClass:
+        begin
+          VType := varString;
+          Data.VString := nil; // avoid GPF on next line
+          VarRecToUtf8(V, RawUtf8(Data.VString)); // decode as new RawUtf8
+        end;
+      vtObject:
+        // class instance will be serialized as a TDocVariant
+        ObjectToVariant(V.VObject, result, [woDontStoreDefault]);
+    else
+      raise ESynVariant.CreateUtf8('Unhandled TVarRec.VType=%', [V.VType]);
+    end;
+end;
+
+function VariantDynArrayToJson(const V: TVariantDynArray): RawUtf8;
+var
+  tmp: TDocVariantData;
+begin
+  tmp.InitArrayFromVariants(V);
+  result := tmp.ToJson;
+end;
+
+function VariantDynArrayToRawUtf8DynArray(const V: TVariantDynArray): TRawUtf8DynArray;
+var
+  i: PtrInt;
+  ws: boolean;
+begin
+  result := nil;
+  if V = nil then
+    exit;
+  SetLength(result, length(V));
+  for i := 0 to length(V) - 1 do
+    VariantToUtf8(V[i], result[i], ws);
+end;
+
+function JsonToVariantDynArray(const Json: RawUtf8): TVariantDynArray;
+var
+  tmp: TDocVariantData;
+begin
+  tmp.InitJson(Json, JSON_FAST);
+  result := tmp.VValue;
+  if result <> nil then
+    DynArrayFakeLength(result, tmp.Count);
+end;
+
+function ValuesToVariantDynArray(const items: array of const): TVariantDynArray;
+var
+  tmp: TDocVariantData;
+begin
+  tmp.InitArray(items, JSON_FAST);
+  result := tmp.VValue;
+  if result <> nil then
+    DynArrayFakeLength(result, tmp.Count);
+end;
+
+
+function SortDynArrayEmptyNull(const A, B): integer;
+begin
+  result := 0; // VType=varEmpty/varNull are always equal
+end;
+
+function SortDynArrayWordBoolean(const A, B): integer;
+begin
+  if WordBool(A) then // normalize
+    if WordBool(B) then
+      result := 0
+    else
+      result := 1
+  else if WordBool(B) then
+    result := -1
+  else
+    result := 0;
+end;
+
+const
+  _VARDATATEXT: array[0.. varWord64 + 5] of string[15] = (
+    'Empty', 'Null', 'SmallInt', 'Integer', 'Single', 'Double', 'Currency',
+    'Date', 'OleStr', 'Dispatch', 'Error', 'Boolean', 'Variant', 'Unknown',
+    'Decimal', '15', 'ShortInt', 'Byte', 'Word', 'LongWord', 'Int64', 'QWord',
+    'String', 'UString', 'Any', 'Array', 'DocVariant');
+var
+  _VariantTypeNameAsInt: shortstring; // seldom called
+
+function VariantTypeName(V: PVarData): PShortString;
+var
+  vt: PtrUInt;
+  ct: TSynInvokeableVariantType;
+  tmp: TVarData;
+begin
+  vt := V.VType;
+  if vt > varWord64 then
+  repeat
+    if SetVariantUnRefSimpleValue(PVariant(V)^, tmp{%H-}) then
+    begin
+      V := @tmp;
+      vt := tmp.VType;
+      if vt <= varWord64 then
+        break;
+    end;
+    case vt of
+      varStrArg,
+      varString,
+      varStringByRef:
+        vt := varWord64 + 1;
+      {$ifdef HASVARUSTRARG}
+      varUStrArg,
+      {$endif HASVARUSTRARG}
+      {$ifdef HASVARUSTRING}
+      varUString,
+      varUStringByRef:
+        vt := varWord64 + 2;
+      {$endif HASVARUSTRING}
+      varAny:
+        vt := varWord64 + 3;
+      varArray:
+        vt := varWord64 + 4;
+      varVariantByRef:
+        begin
+          result := VariantTypeName(V^.VPointer);
+          exit;
+        end;
+    else
+      if vt = DocVariantVType then
+        vt := varWord64 + 5
+      else
+      begin
+        ct := FindSynVariantType(vt);
+        if ct = nil then
+        begin
+          str(vt, _VariantTypeNameAsInt);
+          result := @_VariantTypeNameAsInt; // return VType as number
+        end
+        else
+          result := PPointer(PPtrInt(ct)^ + vmtClassName)^;
+        exit;
+      end
+    end;
+    break;
+  until false;
+  result := @_VARDATATEXT[vt];
+end;
+
+function VariantTypeName(const V: variant): PShortString;
+begin
+  result := VariantTypeName(@V);
+end;
+
+const
+  _CMP2SORT: array[0..18] of TDynArraySortCompare = (
+    nil,                         // 0
+    SortDynArrayEmptyNull,       // 1
+    SortDynArraySmallInt,        // 2
+    SortDynArrayInteger,         // 3
+    SortDynArraySingle,          // 4
+    SortDynArrayDouble,          // 5
+    SortDynArrayInt64,           // 6
+    SortDynArrayDouble,          // 7
+    SortDynArrayShortInt,        // 8
+    SortDynArrayByte,            // 9
+    SortDynArrayWord,            // 10
+    SortDynArrayCardinal,        // 11
+    SortDynArrayInt64,           // 12
+    SortDynArrayQWord,           // 13
+    SortDynArrayWordBoolean,     // 14
+    {$ifdef CPUINTEL}
+    SortDynArrayAnsiString,      // 15
+    {$else}
+    SortDynArrayRawByteString,
+    {$endif CPUINTEL}
+    SortDynArrayAnsiStringI,     // 16
+    SortDynArrayUnicodeString,   // 17
+    SortDynArrayUnicodeStringI); // 18
+var
+  // FastVarDataComp() efficient lookup for per-VType comparison function
+  _VARDATACMP: array[0 .. $102 {varUString}, boolean] of byte; // _CMP2SORT[]
+
+function FastVarDataComp(A, B: PVarData; caseInsensitive: boolean): integer;
+var
+  at, bt, cmp2sort: PtrUInt;
+  ah, bh: TSynInvokeableVariantType;
+begin
+  at := PtrUInt(A); // A=nil -> at=varEmpty
+  if at <> 0 then
+    repeat
+      at := PVarData(at)^.VType;
+      if at <> varVariantByRef then
+        break;
+      at := PtrUInt(A.VPointer);
+      A := pointer(at);
+    until at = 0;
+  bt := PtrUInt(B);
+  if bt <> 0 then
+    repeat
+      bt := PVarData(bt)^.VType;
+      if bt <> varVariantByRef then
+        break;
+      bt := PtrUInt(B.VPointer);
+      B := pointer(bt);
+    until bt = 0;
+  if at = bt then
+    // optimized comparison if A and B share the same type (most common case)
+    if at <= high(_VARDATACMP) then
+    begin
+      cmp2sort := _VARDATACMP[at, caseInsensitive];
+      if cmp2sort <> 0 then
+        result := _CMP2SORT[cmp2sort](A^.VAny, B^.VAny)
+      else
+        result := VariantCompSimple(PVariant(A)^, PVariant(B)^)
+    end
+    else if at = varStringByRef then
+      // e.g. from TRttiVarData / TRttiCustomProp.CompareValue
+      result := _CMP2SORT[_VARDATACMP[varString, caseInsensitive]](
+        PPointer(A^.VAny)^, PPointer(B^.VAny)^)
+    else if at = varSynUnicode or varByRef then
+      result := _CMP2SORT[_VARDATACMP[varSynUnicode, caseInsensitive]](
+         PPointer(A^.VAny)^, PPointer(B^.VAny)^)
+    else if at < varFirstCustom then
+      result := VariantCompSimple(PVariant(A)^, PVariant(B)^)
+    else if at = DocVariantVType then
+      // direct TDocVariantDat.VName/VValue comparison with no serialization
+      result := PDocVariantData(A)^.Compare(PDocVariantData(B)^, caseInsensitive)
+    else
+    begin
+      ah := FindSynVariantType(at);
+      if ah = nil then
+        // compare from custom types UTF-8 text representation/serialization
+        result := VariantCompAsText(A, B, caseInsensitive)
+      else
+        // use proper virtual comparison method
+        result := ah.IntCompare(A^, B^, caseInsensitive);
+    end
+  // A and B do not share the same type
+  else if (at <= varNull) or
+          (bt <= varNull) then
+    result := ord(at > varNull) - ord(bt > varNull)
+  else if (at < varString) and
+          (at <> varOleStr) and
+          (bt < varString) and
+          (bt <> varOleStr) then
+    result := VariantCompSimple(PVariant(A)^, PVariant(B)^)
+  else if (at < varFirstCustom) and
+          (bt < varFirstCustom) then
+    result := VariantCompAsText(A, B, caseInsensitive) // RawUtf8 convert
+  else
+  begin
+    ah := FindSynVariantType(at);
+    bh := FindSynVariantType(bt);
+    if ah <> nil then
+      result := ah.IntCompare(A^, B^, caseInsensitive)
+    else if bh <> nil then
+      result := - bh.IntCompare(B^, A^, caseInsensitive)
+    else
+      result := VariantCompAsText(A, B, caseInsensitive); // RawUtf8 convert
+  end;
+end;
+
+function VariantCompare(const V1, V2: variant): PtrInt;
+begin
+  result := FastVarDataComp(@V1, @V2, {caseins=}false);
+end;
+
+function VariantCompareI(const V1, V2: variant): PtrInt;
+begin
+  result := FastVarDataComp(@V1, @V2, {caseins=}true);
+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 := PropNameEquals(tmp, Str);
+  end;
+
+var
+  v1, v2: Int64;
+  vt: cardinal;
+begin
+  vt := TVarData(V).VType;
+  with TVarData(V) do
+    case vt of
+      varEmpty,
+      varNull:
+        result := Str = '';
+      varBoolean:
+        result := VBoolean = (Str <> '');
+      varString:
+        if CaseSensitive then
+          result := RawUtf8(VString) = Str
+        else
+          result := PropNameEquals(RawUtf8(VString), Str);
+    else
+      if VariantToInt64(V, v1) then
+      begin
+        SetInt64(pointer(Str), v2);
+        result := v1 = v2;
+      end
+      else
+        result := Complex;
+    end;
+end;
+
+
+{ ************** Custom Variant Types with JSON support }
+
+var
+  SynVariantTypesSafe: TLightLock; // protects only SynRegisterCustomVariantType
+
+  /// list of custom types (but not DocVariantVType) supporting TryJsonToVariant
+  SynVariantTryJsonTypes: array of TSynInvokeableVariantType;
+
+function FindSynVariantType(aVarType: cardinal): TSynInvokeableVariantType;
+var
+  n: integer;
+  t: ^TSynInvokeableVariantType;
+begin
+  if (aVarType >= varFirstCustom) and
+     (aVarType < varArray) then
+  begin
+    t := pointer(SynVariantTypes);
+    n := PDALen(PAnsiChar(t) - _DALEN)^ + _DAOFF;
+    repeat
+      result := t^;
+      if result.VarType = aVarType then
+        exit;
+      inc(t);
+      dec(n);
+    until n = 0;
+  end;
+  result := nil;
+end;
+
+function SynRegisterCustomVariantType(
+  aClass: TSynInvokeableVariantTypeClass): TSynInvokeableVariantType;
+var
+  i: PtrInt;
+begin
+  SynVariantTypesSafe.Lock;
+  try
+    for i := 0 to length(SynVariantTypes) - 1 do
+    begin
+      result := SynVariantTypes[i];
+      if PPointer(result)^ = pointer(aClass) then
+        // returns already registered instance
+        exit;
+    end;
+    result := aClass.Create; // register variant type
+    ObjArrayAdd(SynVariantTypes, result);
+    if sioHasTryJsonToVariant in result.Options then
+      ObjArrayAdd(SynVariantTryJsonTypes, result);
+  finally
+    SynVariantTypesSafe.UnLock;
+  end;
+end;
+
+function SortCompTo(cmp: integer): TVarCompareResult;
+begin
+  if cmp = 0 then
+    result := crEqual
+  else if cmp > 0 then
+    result:= crGreaterThan
+  else
+    result := crLessThan;
+end;
+
+
+{ TSynInvokeableVariantType }
+
+constructor TSynInvokeableVariantType.Create;
+begin
+  inherited Create; // call RegisterCustomVariantType(self)
+end;
+
+function TSynInvokeableVariantType.IterateCount(const V: TVarData;
+  GetObjectAsValues: boolean): 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;
+
+{$ifdef ISDELPHI}
+function TSynInvokeableVariantType.FixupIdent(const AText: string): string;
+begin
+  result := AText; // NO uppercased identifier for our custom types!
+end;
+{$endif ISDELPHI}
+
+function TSynInvokeableVariantType.{%H-}IntGet(var Dest: TVarData;
+  const Instance: TVarData; Name: PAnsiChar; NameLen: PtrInt;
+  NoException: boolean): boolean;
+begin
+  raise ESynVariant.CreateUtf8('Unexpected %.IntGet(%): this kind of ' +
+    'custom variant does not support fields', [self, Name]);
+end;
+
+function TSynInvokeableVariantType.{%H-}IntSet(const Instance, Value: TVarData;
+  Name: PAnsiChar; NameLen: PtrInt): boolean;
+begin
+  raise ESynVariant.CreateUtf8('Unexpected %.IntSet(%): this kind of ' +
+    'custom variant is read-only', [self, Name]);
+end;
+
+function TSynInvokeableVariantType.IntCompare(
+  const Instance, Another: TVarData; CaseInsensitive: boolean): integer;
+begin
+  result := VariantCompAsText(@Instance, @Another, CaseInsensitive);
+end;
+
+const
+  FROM_VAROP: array[opcmpeq .. opcmpge, TVarCompareResult] of boolean = (
+    (false,  true,   false), // opcmpeq
+    (true,   false,  true),  // opcmpne
+    (true,   false,  false), // opcmplt
+    (true,   true,   false), // opcmple
+    (false,  false,  true),  // opcmpgt
+    (false,  true,   true)); // opcmpge
+    // crLessThan crEqual crGreaterThan
+
+function TSynInvokeableVariantType.CompareOp(const Left, Right: TVarData;
+  const Operation: TVarOp): boolean;
+var
+  vcr: TVarCompareResult;
+begin
+  // redirect to Compare() as Delphi RTL does (but not the FPC RTL)
+  if not (Operation in [low(FROM_VAROP) .. high(FROM_VAROP)]) then
+    raise ESynVariant.CreateUtf8('Unexpected %.CompareOp(%)', [self, ord(Operation)]);
+  Compare(Left, Right, vcr);
+  result := FROM_VAROP[Operation, vcr];
+end;
+
+procedure TSynInvokeableVariantType.Compare(const Left, Right: TVarData;
+  var Relationship: TVarCompareResult);
+begin
+  Relationship := SortCompTo(IntCompare(Left, Right, {CaseInsen=}false));
+end;
+
+const
+  DISPATCH_METHOD      = 1;
+  DISPATCH_PROPERTYGET = 2; // in practice, never generated by the FPC compiler
+  DISPATCH_PROPERTYPUT = 4;
+  ARGTYPE_MASK         = $7f;
+  ARGREF_MASK          = $80;
+  VAR_PARAMNOTFOUND    = HRESULT($80020004);
+
+{$ifdef FPC}
+var
+  DispInvokeArgOrderInverted: boolean; // circumvent FPC 3.2+ breaking change
+{$endif FPC}
+
+{$ifdef FPC_VARIANTSETVAR}
+procedure TSynInvokeableVariantType.DispInvoke(
+  Dest: PVarData; var Source: TVarData; CallDesc: PCallDesc; Params: Pointer);
+{$else} // see http://mantis.freepascal.org/view.php?id=26773
+  {$ifdef ISDELPHIXE7}
+procedure TSynInvokeableVariantType.DispInvoke(
+  Dest: PVarData; [ref] const Source: TVarData; // why not just "var" ????
+  CallDesc: PCallDesc; Params: Pointer);
+  {$else}
+procedure TSynInvokeableVariantType.DispInvoke(
+  Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer);
+  {$endif ISDELPHIXE7}
+{$endif FPC_VARIANTSETVAR}
+var
+  name: string;
+  res: TVarData;
+  namelen, i, asize, n: PtrInt;
+  nameptr, a: PAnsiChar;
+  v: PVarData;
+  args: TVarDataArray; // DoProcedure/DoFunction require a dynamic array
+  t: cardinal;
+  {$ifdef FPC}
+  inverted: boolean;
+  {$endif FPC}
+
+  procedure RaiseInvalid;
+  begin
+    raise ESynVariant.CreateUtf8('%.DispInvoke: invalid %(%) call',
+      [self, name, CallDesc^.ArgCount]);
+  end;
+
+begin
+  // circumvent https://bugs.freepascal.org/view.php?id=38653 and
+  // inverted args order FPC bugs, avoid unneeded conversion to varOleString
+  // for Delphi, and implement direct IntGet/IntSet calls for all
+  n := CallDesc^.ArgCount;
+  nameptr := @CallDesc^.ArgTypes[n];
+  namelen := StrLen(nameptr);
+  // faster direct property getter
+  if (Dest <> nil) and
+     (n = 0) and
+     (CallDesc^.CallType in [DISPATCH_METHOD, DISPATCH_PROPERTYGET]) and
+     IntGet(Dest^, Source, nameptr, namelen, {noexception=}false) then
+    exit;
+  Ansi7ToString(pointer(nameptr), namelen, name);
+  if n > 0 then
+  begin
+    // convert varargs Params buffer into an array of TVarData
+    SetLength(args, n);
+    {$ifdef FPC} // circumvent FPC 3.2+ inverted order
+    inverted := (n > 1) and
+                DispInvokeArgOrderInverted;
+    if inverted then
+      v := @args[n - 1]
+    else
+    {$endif FPC}
+      v := pointer(args);
+    a := Params;
+    for i := 0 to n - 1 do
+    begin
+      asize := SizeOf(pointer);
+      t := cardinal(CallDesc^.ArgTypes[i]) and ARGTYPE_MASK;
+      case t of
+        {$ifdef HASVARUSTRARG}
+        varUStrArg:
+          t := varUString;
+        {$endif HASVARUSTRARG}
+        varStrArg:
+          t := varString;
+      end;
+      if CallDesc^.ArgTypes[i] and ARGREF_MASK <> 0 then
+      begin
+        TRttiVarData(v^).VType := t or varByRef;
+        v^.VPointer := PPointer(a)^;
+      end
+      else
+      begin
+        TRttiVarData(v^).VType := t;
+        case t of
+          varError:
+            begin
+              v^.VError := VAR_PARAMNOTFOUND;
+              asize := 0;
+            end;
+          varVariant:
+            {$ifdef CPU32DELPHI}
+            begin
+              v^ := PVarData(a)^;
+              asize := SizeOf(TVarData); // pushed by value
+            end;
+            {$else}
+            v^ := PPVarData(a)^^; // pushed by reference (as other parameters)
+            {$endif CPU32DELPHI}
+          varDouble,
+          varCurrency,
+          varDate,
+          varInt64,
+          varWord64:
+            begin
+              v^.VInt64 := PInt64(a)^;
+              asize := SizeOf(Int64);
+            end;
+          // small values are stored as pointers on stack but pushed as 32-bit
+          varSingle,
+          varSmallint,
+          varInteger,
+          varLongWord,
+          varBoolean,
+          varShortInt,
+          varByte,
+          varWord:
+            v^.VInteger := PInteger(a)^; // we assume little endian
+        else
+          v^.VAny := PPointer(a)^; // e.g. varString or varOleStr
+        end;
+      end;
+      inc(a, asize);
+      {$ifdef FPC}
+      if inverted then
+        dec(v)
+      else
+      {$endif FPC}
+        inc(v);
+    end;
+  end;
+  case CallDesc^.CallType of
+    // note: IntGet was already tried in function trailer
+    DISPATCH_METHOD:
+      if Dest <> nil then
+      begin
+        if not DoFunction(Dest^, Source, name, args) then
+          RaiseInvalid;
+      end
+      else if not DoProcedure(Source, name, args) then
+      begin
+        PCardinal(@res)^ := varEmpty;
+        try
+          if not DoFunction(Dest^, Source, name, args) then
+            RaiseInvalid;
+        finally
+          VarClearProc(res);
+        end;
+      end;
+    DISPATCH_PROPERTYGET:
+      if (Dest = nil) or
+         not DoFunction(Dest^, Source, name, args) then
+        RaiseInvalid;
+    DISPATCH_PROPERTYPUT:
+      if (Dest <> nil) or
+         (n <> 1) or
+         not IntSet(Source, args[0], nameptr, namelen) then
+        RaiseInvalid;
+  else
+    RaiseInvalid;
+  end;
+end;
+
+procedure TSynInvokeableVariantType.Clear(var V: TVarData);
+begin
+  ZeroFill(@V); // will set V.VType := varEmpty
+end;
+
+procedure TSynInvokeableVariantType.Copy(var Dest: TVarData;
+  const Source: TVarData; const Indirect: boolean);
+begin
+  if Indirect then
+    SetVariantByRef(variant(Source), variant(Dest))
+  else
+  begin
+    VarClear(variant(Dest)); // Dest may be a complex type
+    Dest := Source;
+  end;
+end;
+
+procedure TSynInvokeableVariantType.CopyByValue(
+  var Dest: TVarData; const Source: TVarData);
+begin
+  Copy(Dest, Source, {Indirect=} false);
+end;
+
+function TSynInvokeableVariantType.TryJsonToVariant(var Json: PUtf8Char;
+  var Value: variant; EndOfObject: PUtf8Char): boolean;
+begin
+  result := false;
+end;
+
+procedure TSynInvokeableVariantType.ToJson(W: TJsonWriter; Value: PVarData);
+begin
+  raise ESynVariant.CreateUtf8('%.ToJson is not implemented', [self]);
+end;
+
+procedure TSynInvokeableVariantType.ToJson(Value: PVarData;
+  var Json: RawUtf8; const Prefix, Suffix: RawUtf8; Format: TTextWriterJsonFormat);
+var
+  W: TJsonWriter;
+  temp: TTextWriterStackBuffer;
+begin
+  W := TJsonWriter.CreateOwnedStream(temp);
+  try
+    if Prefix <> '' then
+      W.AddString(Prefix);
+    ToJson(W, Value); // direct TSynInvokeableVariantType serialization
+    if Suffix <> '' then
+      W.AddString(Suffix);
+    W.SetText(Json, Format);
+  finally
+    W.Free;
+  end;
+end;
+
+function TSynInvokeableVariantType.IsOfType(const V: variant): boolean;
+var
+  vt: cardinal;
+  vd: PVarData;
+{%H-}begin
+  if self <> nil then
+  begin
+    vd := @V;
+    repeat
+      vt := vd^.VType;
+      if vt <> varVariantByRef then
+        break;
+      vd := vd^.VPointer;
+    until false;
+    result := vt = VarType;
+  end
+  else
+    result := false;
+end;
+
+function TSynInvokeableVariantType.IsVoid(const V: TVarData): boolean;
+begin
+  result := false; // not void by default
+end;
+
+function TSynInvokeableVariantType.FindSynVariantType(aVarType: cardinal;
+  out CustomType: TSynInvokeableVariantType): boolean;
+var
+  ct: TSynInvokeableVariantType;
+begin
+  if (self <> nil) and
+     (aVarType = VarType) then
+    ct := self
+  else
+    ct := mormot.core.variants.FindSynVariantType(aVarType);
+  CustomType := ct;
+  result := ct <> nil;
+end;
+
+function TSynInvokeableVariantType.FindSynVariantType(
+  aVarType: cardinal): TSynInvokeableVariantType;
+begin
+  if aVarType = VarType then
+    result := self
+  else
+    result := mormot.core.variants.FindSynVariantType(aVarType);
+end;
+
+procedure TSynInvokeableVariantType.Lookup(var Dest: TVarData;
+  const Instance: TVarData; FullName: PUtf8Char; PathDelim: AnsiChar);
+var
+  handler: TSynInvokeableVariantType;
+  v, tmp: TVarData; // PVarData wouldn't store e.g. RowID/count
+  vt: cardinal;
+  n: ShortString;
+begin
+  TRttiVarData(Dest).VType := varEmpty; // left to Unassigned if not found
+  v := Instance;
+  repeat
+    vt := v.VType;
+    if vt <> varVariantByRef then
+      break;
+    v := PVarData(v.VPointer)^;
+  until false;
+  repeat
+    if vt < varFirstCustom then
+      exit; // we need a complex type to lookup
+    GetNextItemShortString(FullName, @n, PathDelim); // n will end with #0
+    if n[0] = #0 then
+      exit;
+    handler := self;
+    if vt <> VarType then
+    begin
+      handler := mormot.core.variants.FindSynVariantType(vt);
+      if handler = nil then
+        exit;
+    end;
+    tmp := v; // v will be modified in-place
+    TRttiVarData(v).VType := varEmpty; // IntGet() would clear it otherwise!
+    if not handler.IntGet(v, tmp, @n[1], ord(n[0]), {noexc=}true) then
+      exit; // property not found (no exception should be raised in Lookup)
+    repeat
+      vt := v.VType;
+      if vt <> varVariantByRef then
+        break;
+      v := PVarData(v.VPointer)^;
+    until false;
+    if (vt = DocVariantVType) and
+       (TDocVariantData(v).VCount = 0) then
+      // recognize void TDocVariant as null
+      v.VType := varNull; // do not use PCardinal/TRttiVarData(v).VType here
+  until FullName = nil;
+  Dest := v;
+end;
+
+function CustomVariantToJson(W: TJsonWriter; Value: PVarData;
+  Escape: TTextWriterKind): boolean;
+var
+  v: TCustomVariantType;
+  tmp: variant;
+begin
+  result := true;
+  if FindCustomVariantType(Value.VType, v) then
+    if v.InheritsFrom(TSynInvokeableVariantType) then
+      TSynInvokeableVariantType(v).ToJson(W, Value)
+    else
+      try
+        v.CastTo(TVarData(tmp), Value^, varNativeString);
+        W.AddVariant(tmp, Escape);
+      except
+        result := false;
+      end
+  else
+    result := false;
+end;
+
+
+function ToText(kind: TDocVariantKind): PShortString;
+begin
+  result := GetEnumName(TypeInfo(TDocVariantKind), ord(kind));
+end;
+
+procedure __VariantSaveJsonEscape(const Value: variant; var Json: RawUtf8;
+  Escape: TTextWriterKind);
+var
+  temp: TTextWriterStackBuffer;
+begin
+  with TJsonWriter.CreateOwnedStream(temp) do
+    try
+      AddVariant(Value, Escape); // will use mormot.core.json serialization
+      SetText(Json, jsonCompact);
+    finally
+      Free;
+    end;
+end;
+
+procedure __VariantSaveJson(V: PVarData; Escape: TTextWriterKind;
+  var result: RawUtf8);
+var
+  cv: TSynInvokeableVariantType;
+  vt: cardinal;
+  dummy: boolean;
+begin
+  // is likely to be called from AddVariant() but can be used for simple values
+  if cardinal(V.VType) = varVariantByRef then
+    V := V^.VPointer;
+  cv := FindSynVariantType(V.VType);
+  if cv = nil then
+  begin
+    vt := V.VType;
+    if (vt >= varFirstCustom) or
+       ((Escape <> twNone) and
+        not (vt in [varEmpty..varDate, varBoolean, varShortInt..varWord64])) then
+      __VariantSaveJsonEscape(PVariant(V)^, result, Escape)
+    else
+      VariantToUtf8(PVariant(V)^, result, dummy); // no escape for simple values
+  end
+  else
+    cv.ToJson(V, result);
+end;
+
+
+{ EDocVariant }
+
+class procedure EDocVariant.RaiseSafe(Kind: TDocVariantKind);
+begin
+  raise CreateUtf8('_Safe(%)?', [ToText(Kind)^]);
+end;
+
+{ TDocVariant }
+
+destructor TDocVariant.Destroy;
+begin
+  inherited Destroy;
+  fInternNames.Free;
+  fInternValues.Free;
+end;
+
+const
+  _GETMETHOD: array[0..3] of PAnsiChar = (
+    'COUNT', // 0
+    'KIND',  // 1
+    'JSON',  // 2
+    nil);
+
+function IntGetPseudoProp(ndx: PtrInt; const source: TDocVariantData;
+  var Dest: variant): boolean;
+begin
+  // sub-function to avoid temporary RawUtf8 for source.ToJson
+  result := true;
+  case ndx of
+    0:
+      Dest := source.Count;
+    1:
+      Dest := ord(source.GetKind);
+    2:
+      RawUtf8ToVariant(source.ToJson, Dest);
+  else
+    result := false;
+  end;
+end;
+
+function TDocVariant.IntGet(var Dest: TVarData; const Instance: TVarData;
+  Name: PAnsiChar; NameLen: PtrInt; NoException: boolean): boolean;
+var
+  dv: TDocVariantData absolute Instance;
+  ndx: integer;
+begin
+  if Name = nil then
+    result := false
+  else if (NameLen > 4) and
+          (Name[0] = '_') and
+          IntGetPseudoProp(IdemPPChar(@Name[1], @_GETMETHOD), dv, variant(Dest)) then
+    result := true
+  else
+  begin
+    ndx := dv.GetValueIndex(pointer(Name), NameLen, dv.IsCaseSensitive);
+    if ndx < 0 then
+      if NoException or
+         dv.Has(dvoReturnNullForUnknownProperty) then
+      begin
+        SetVariantNull(PVariant(@Dest)^);
+        result := false;
+      end
+      else
+        raise EDocVariant.CreateUtf8('[%] property not found', [Name])
+    else
+    begin
+      SetVariantByRef(dv.VValue[ndx], PVariant(@Dest)^);
+      result := true;
+    end;
+  end;
+end;
+
+function TDocVariant.IntSet(const Instance, Value: TVarData;
+  Name: PAnsiChar; NameLen: PtrInt): boolean;
+var
+  ndx: PtrInt;
+  dv: TDocVariantData absolute Instance;
+begin
+  result := true;
+  if dv.IsArray and
+     (PWord(Name)^ = ord('_')) then
+  begin
+    dv.AddItem(variant(Value));
+    exit;
+  end;
+  ndx := dv.GetValueIndex(pointer(Name), NameLen, dv.IsCaseSensitive);
+  if ndx < 0 then
+    ndx := dv.InternalAddBuf(pointer(Name), NameLen);
+  dv.InternalSetValue(ndx, variant(Value));
+end;
+
+function TDocVariant.IntCompare(const Instance, Another: TVarData;
+  CaseInsensitive: boolean): integer;
+var
+  l, r: PDocVariantData;
+begin
+  if _Safe(variant(Instance), l) and // is likely to be a TDocVariant
+     _Safe(variant(Another), r) then
+    result := l^.Compare(r^, CaseInsensitive)
+  else // inlined inherited
+    result := VariantCompAsText(@Instance, @Another, CaseInsensitive);
+end;
+
+function TDocVariant.IterateCount(const V: TVarData;
+  GetObjectAsValues: boolean): integer;
+var
+  Data: TDocVariantData absolute V;
+begin
+  if Data.IsArray or
+     (GetObjectAsValues and
+      Data.IsObject) 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 // note: IterateCount() may accept IsObject values[]
+  if cardinal(Index) < cardinal(Data.VCount) then
+    Dest := TVarData(Data.VValue[Index])
+  else
+    TRttiVarData(Dest).VType := varEmpty;
+end;
+
+function TDocVariant.IsVoid(const V: TVarData): boolean;
+begin
+  result := TDocVariantData(V).Count > 0;
+end;
+
+function TDocVariant.DoProcedure(const V: TVarData; const Name: string;
+  const Arguments: TVarDataArray): boolean;
+var
+  Data: PDocVariantData;
+begin
+  result := false;
+  Data := @V; // allow to modify a const argument
+  case length(Arguments) of
+    0:
+      if SameText(Name, 'Clear') then
+      begin
+        Data^.Reset;
+        result := true;
+      end;
+    1:
+      if SameText(Name, 'Add') then
+      begin
+        Data^.AddItem(variant(Arguments[0]));
+        result := true;
+      end
+      else if SameText(Name, 'Delete') then
+      begin
+        Data^.Delete(Data^.GetValueIndex(ToUtf8(Arguments[0])));
+        result := true;
+      end;
+    2:
+      if SameText(Name, 'Add') then
+      begin
+        Data^.AddValue(ToUtf8(Arguments[0]), variant(Arguments[1]));
+        result := true;
+      end;
+  end;
+end;
+
+function TDocVariant.DoFunction(var Dest: TVarData; const V: TVarData;
+  const Name: string; const Arguments: TVarDataArray): boolean;
+var
+  ndx: integer;
+  Data: PDocVariantData;
+  temp: RawUtf8;
+begin
+  result := true;
+  Data := @V; // allow to modify a const argument
+  case length(Arguments) of
+    1:
+      if SameText(Name, 'Exists') then
+      begin
+        variant(Dest) := Data.GetValueIndex(ToUtf8(Arguments[0])) >= 0;
+        exit;
+      end
+      else if SameText(Name, 'NameIndex') then
+      begin
+        variant(Dest) := Data.GetValueIndex(ToUtf8(Arguments[0]));
+        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
+        temp := ToUtf8(Arguments[0]);
+        Data.RetrieveValueOrRaiseException(pointer(temp), length(temp),
+          Data.IsCaseSensitive, variant(Dest), true);
+        exit;
+      end;
+  end;
+  result := Data.Has(dvoReturnNullForUnknownProperty); // to avoid error
+end;
+
+procedure TDocVariant.ToJson(W: TJsonWriter; Value: PVarData);
+var
+  forced: TTextWriterOptions;
+  nam: PPUtf8Char;
+  val: PVariant;
+  vt: cardinal;
+  n: integer;
+  checkExtendedPropName: boolean;
+begin
+  repeat
+    vt := Value^.VType;
+    if vt <> varVariantByRef then
+      break;
+    Value := Value^.VPointer;
+  until false;
+  if vt <> DocVariantVType then
+  begin
+    W.AddNull;
+    exit;
+  end;
+  forced := [];
+  if [twoForceJsonExtended, twoForceJsonStandard] * W.CustomOptions = [] then
+  begin
+    if PDocVariantData(Value)^.Has(dvoSerializeAsExtendedJson) then
+      forced := [twoForceJsonExtended]
+    else
+      forced := [twoForceJsonStandard];
+    W.CustomOptions := W.CustomOptions + forced;
+  end;
+  n := PDocVariantData(Value)^.VCount;
+  val := pointer(PDocVariantData(Value)^.VValue);
+  if PDocVariantData(Value)^.IsObject then
+  begin
+    checkExtendedPropName := twoForceJsonExtended in W.CustomOptions;
+    W.Add('{');
+    nam := pointer(PDocVariantData(Value)^.VName);
+    if n <> 0 then
+      repeat
+        if checkExtendedPropName and
+           JsonPropNameValid(nam^) then
+          W.AddShort(nam^, PStrLen(nam^ - _STRLEN)^)
+        else
+        begin
+          W.AddDirect('"');
+          W.AddJsonEscape(nam^);
+          W.AddDirect('"');
+        end;
+        W.AddDirect(':');
+        W.AddVariant(val^, twJsonEscape);
+        dec(n);
+        if n = 0 then
+          break;
+        W.AddComma;
+        inc(nam);
+        inc(val);
+      until false;
+    W.AddDirect('}');
+  end
+  else if PDocVariantData(Value)^.IsArray then
+  begin
+    W.Add('[');
+    if n <> 0 then
+      repeat
+        W.AddVariant(val^, twJsonEscape);
+        dec(n);
+        if n = 0 then
+          break;
+        W.AddComma;
+        inc(val);
+      until false;
+    W.AddDirect(']');
+  end
+  else
+    W.AddNull;
+  if forced <> [] then
+    W.CustomOptions := W.CustomOptions - forced;
+end;
+
+procedure TDocVariant.Clear(var V: TVarData);
+begin
+  //Assert(V.VType=DocVariantVType);
+  TDocVariantData(V).ClearFast;
+end;
+
+procedure TDocVariant.Copy(var Dest: TVarData; const Source: TVarData;
+  const Indirect: boolean);
+begin
+  //Assert(Source.VType=DocVariantVType);
+  if Indirect then
+    SetVariantByRef(variant(Source), variant(Dest))
+  else
+    CopyByValue(Dest, Source);
+end;
+
+procedure TDocVariant.CopyByValue(var Dest: TVarData; const Source: TVarData);
+var
+  S: TDocVariantData absolute Source;
+  D: TDocVariantData absolute Dest;
+begin
+  //Assert(Source.VType=DocVariantVType);
+  VarClearAndSetType(variant(Dest), PCardinal(@S)^); // VType + VOptions
+  pointer(D.VName) := nil; // avoid GPF
+  pointer(D.VValue) := nil;
+  D.VCount := S.VCount;
+  if S.VCount = 0 then
+    exit; // no data to copy
+  D.VName := S.VName;
+  if S.Has(dvoValueCopiedByReference) then
+    D.VValue := S.VValue // byref copy of the whole array
+  else
+    D.VValue := system.copy(S.VValue); // new array, but byref values
+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
+  json: RawUtf8;
+  wasString: boolean;
+begin
+  if AVarType = VarType then
+  begin
+    VariantToUtf8(Variant(Source), json, wasString);
+    if wasString then
+    begin
+      VarClear(variant(Dest));
+      variant(Dest) := _JsonFast(json); // convert from JSON text
+      exit;
+    end;
+    RaiseCastError;
+  end
+  else
+  begin
+    if Source.VType <> VarType then
+      RaiseCastError;
+    DocVariantType.ToJson(@Source, json);
+    RawUtf8ToVariant(json, Dest, AVarType); // convert to JSON text
+  end;
+end;
+
+class procedure TDocVariant.New(out aValue: variant;
+  aOptions: TDocVariantOptions);
+begin
+  TDocVariantData(aValue).Init(aOptions);
+end;
+
+class procedure TDocVariant.NewFast(out aValue: variant;
+  aKind: TDocVariantKind);
+begin
+  TVarData(aValue) := DV_FAST[aKind];
+end;
+
+class procedure TDocVariant.IsOfTypeOrNewFast(var aValue: variant);
+begin
+  if DocVariantType.IsOfType(aValue) then
+    exit;
+  VarClear(aValue);
+  TVarData(aValue) := DV_FAST[dvUndefined];
+end;
+
+class procedure TDocVariant.NewFast(const aValues: array of PDocVariantData;
+  aKind: TDocVariantKind);
+var
+  i: PtrInt;
+  def: PDocVariantData;
+begin
+  def := @DV_FAST[aKind];
+  for i := 0 to high(aValues) do
+    aValues[i]^ := def^;
+end;
+
+class function TDocVariant.New(Options: TDocVariantOptions): Variant;
+begin
+  VarClear(result{%H-});
+  TDocVariantData(result).Init(Options);
+end;
+
+class function TDocVariant.NewObject(const NameValuePairs: array of const;
+  Options: TDocVariantOptions): variant;
+begin
+  VarClear(result{%H-});
+  TDocVariantData(result).InitObject(NameValuePairs, Options);
+end;
+
+class function TDocVariant.NewArray(const Items: array of const;
+  Options: TDocVariantOptions): variant;
+begin
+  VarClear(result{%H-});
+  TDocVariantData(result).InitArray(Items, Options);
+end;
+
+class function TDocVariant.NewArray(const Items: TVariantDynArray;
+  Options: TDocVariantOptions): variant;
+begin
+  VarClear(result{%H-});
+  TDocVariantData(result).InitArrayFromVariants(Items, Options);
+end;
+
+class function TDocVariant.NewJson(const Json: RawUtf8;
+  Options: TDocVariantOptions): variant;
+begin
+  _Json(Json, result, Options);
+end;
+
+class function TDocVariant.NewUnique(const SourceDocVariant: variant;
+  Options: TDocVariantOptions): variant;
+begin
+  VarClear(result{%H-});
+  TDocVariantData(result).InitCopy(SourceDocVariant, Options);
+end;
+
+class procedure TDocVariant.GetSingleOrDefault(
+  const docVariantArray, default: variant; var result: variant);
+var
+  vt: cardinal;
+begin
+  vt := TVarData(docVariantArray).VType;
+  if vt = varVariantByRef then
+    GetSingleOrDefault(
+      PVariant(TVarData(docVariantArray).VPointer)^, default, result)
+  else if (vt <> DocVariantVType) or
+          (TDocVariantData(docVariantArray).Count <> 1) or
+          not TDocVariantData(docVariantArray).IsArray then
+    result := default
+  else
+    result := TDocVariantData(docVariantArray).Values[0];
+end;
+
+function DocVariantData(const DocVariant: variant): PDocVariantData;
+var
+  docv, vt: cardinal;
+begin
+  result := @DocVariant;
+  docv := DocVariantVType;
+  vt := result^.VType;
+  if vt = docv then
+    exit
+  else if vt = varVariantByRef then
+  begin
+    result := PVarData(result)^.VPointer;
+    if cardinal(result^.VType) = docv then
+      exit;
+  end;
+  raise EDocVariant.CreateUtf8('Unexpected DocVariantData(var%)',
+    [VariantTypeName(PVarData(result))^]);
+end;
+
+{$ifdef FPC_OR_UNICODE} // Delphi has problems inlining this :(
+function _Safe(const DocVariant: variant): PDocVariantData;
+var
+  docv, vt: cardinal;
+begin
+  result := @DocVariant;
+  docv := DocVariantVType;
+  vt := result^.VType;
+  if vt = docv then
+    exit
+  else if vt = varVariantByRef then
+  begin
+    result := PVarData(result)^.VPointer;
+    if cardinal(result^.VType) = docv then
+      exit;
+  end;
+  result := @DocVariantDataFake;
+end;
+{$else} // fallback for Delphi 7/2007
+function _Safe(const DocVariant: variant): PDocVariantData;
+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, varVariantByRef
+        je      @ptr
+        lea     eax, [DocVariantDataFake]
+@ok:
+end;
+{$endif FPC_OR_UNICODE}
+
+function _Safe(const DocVariant: variant; out DV: PDocVariantData): boolean;
+var
+  docv, vt: cardinal;
+  v: PDocVariantData;
+{$ifdef FPC} // latest Delphi compilers have problems inlining labels
+label
+  no;
+{$endif FPC}
+begin
+  docv := DocVariantVType;
+  v := @DocVariant;
+  vt := v^.VType;
+  {$ifdef ISDELPHI}
+  result := false;
+  {$endif ISDELPHI}
+  if vt <> docv then
+    if vt <> varVariantByRef then
+    begin
+{$ifdef FPC}
+no:  result := false;
+{$endif FPC}
+     exit;
+    end
+    else
+    begin
+      v := PVarData(v)^.VPointer;
+      if cardinal(v^.VType) <> docv then
+      {$ifdef FPC}
+        goto no;
+      {$else}
+        exit;
+      {$endif FPC}
+    end;
+  DV := v;
+  result := true;
+end;
+
+function _SafeArray(const Value: variant; out DV: PDocVariantData): boolean;
+begin
+  result := _Safe(Value, DV) and
+            not {%H-}DV^.IsObject;
+end;
+
+function _SafeArray(const Value: variant; ExpectedCount: integer;
+  out DV: PDocVariantData): boolean;
+begin
+  result := _Safe(Value, DV) and
+            {%H-}DV^.IsArray and
+            (DV^.Count = ExpectedCount);
+end;
+
+function _SafeObject(const Value: variant; out DV: PDocVariantData): boolean;
+begin
+  result := _Safe(Value, DV) and
+            not {%H-}DV^.IsArray;
+end;
+
+function _Safe(const DocVariant: variant;
+  ExpectedKind: TDocVariantKind): PDocVariantData;
+begin
+  if ExpectedKind = dvArray then
+  begin
+    if _SafeArray(DocVariant, result) then
+      exit;
+  end
+  else if (ExpectedKind = dvObject) and
+          _SafeObject(DocVariant, result) then
+    exit;
+  EDocVariant.RaiseSafe(ExpectedKind);
+end;
+
+function _DV(const DocVariant: variant): TDocVariantData;
+begin
+  result := _Safe(DocVariant)^;
+end;
+
+function _DV(const DocVariant: variant;
+  ExpectedKind: TDocVariantKind): TDocVariantData;
+begin
+  result := _Safe(DocVariant, ExpectedKind)^;
+end;
+
+function _DV(const DocVariant: variant; var DV: TDocVariantData): boolean;
+var
+  docv, vt: cardinal;
+  v: PDocVariantData;
+label
+  no;
+begin
+  docv := DocVariantVType;
+  v := @DocVariant;
+  vt := v^.VType;
+  if vt <> docv then
+    if vt <> varVariantByRef then
+    begin
+no:   result := false;
+      exit;
+    end
+    else
+    begin
+      v := PVarData(v)^.VPointer;
+      if cardinal(v^.VType) <> docv then
+        goto no;
+    end;
+  DV := v^;
+  result := true;
+end;
+
+function _Csv(const DocVariantOrString: variant): RawUtf8;
+begin
+  with _Safe(DocVariantOrString)^ do
+    if IsArray then
+      result := ToCsv
+    else if IsObject or
+            not VariantToText(DocVariantOrString, result) then
+      result := '';
+end;
+
+function ObjectToVariant(Value: TObject; EnumSetsAsText: boolean): variant;
+const
+  OPTIONS: array[boolean] of TTextWriterWriteObjectOptions = (
+     [woDontStoreDefault], [woDontStoreDefault, woEnumSetsAsText]);
+begin
+  ObjectToVariant(Value, result, OPTIONS[EnumSetsAsText]);
+end;
+
+function ObjectToVariantDebug(Value: TObject;
+  const ContextFormat: RawUtf8; const ContextArgs: array of const;
+  const ContextName: RawUtf8): variant;
+begin
+  ObjectToVariant(Value, result, [woDontStoreDefault, woEnumSetsAsText]);
+  if ContextFormat <> '' then
+    if ContextFormat[1] = '{' then
+      _ObjAddProps([ContextName,
+        _JsonFastFmt(ContextFormat, [], ContextArgs)], result)
+    else
+      _ObjAddProps([ContextName,
+        FormatUtf8(ContextFormat, ContextArgs)], result);
+end;
+
+procedure ObjectToVariant(Value: TObject; var result: variant;
+  Options: TTextWriterWriteObjectOptions);
+var
+  json: RawUtf8;
+begin
+  VarClear(result{%H-});
+  json := ObjectToJson(Value, Options);
+  if PDocVariantData(@result)^.InitJsonInPlace(
+      pointer(json), JSON_FAST) = nil then
+    VarClear(result);
+end;
+
+function SetNameToVariant(Value: cardinal; Info: TRttiCustom;
+  FullSetsAsStar: boolean): variant;
+var
+  bit: PtrInt;
+  PS: PShortString;
+  arr: TDocVariantData;
+begin
+  TVarData(arr) := DV_FAST[dvArray];
+  if FullSetsAsStar and
+     GetAllBits(Value, Info.Cache.EnumMax + 1) then
+    arr.AddItem('*')
+  else
+    with Info.Cache do
+    begin
+      PS := EnumList;
+      for bit := EnumMin to EnumMax do
+      begin
+        if GetBitPtr(@Value, bit) then
+          arr.AddItem(PS^);
+        inc(PByte(PS), ord(PS^[0]) + 1); // next item
+      end;
+    end;
+  result := variant(arr);
+end;
+
+function SetNameToVariant(Value: cardinal; Info: PRttiInfo;
+  FullSetsAsStar: boolean): variant;
+begin
+  result := SetNameToVariant(Value, Rtti.RegisterType(Info), FullSetsAsStar);
+end;
+
+function DocVariantToObject(var doc: TDocVariantData; obj: TObject;
+  objRtti: TRttiCustom): boolean;
+var
+  p: PtrInt;
+  prop: PRttiCustomProp;
+begin
+  if doc.IsObject and
+     (doc.Count > 0) and
+     (obj <> nil) then
+  begin
+    if objRtti = nil then
+      objRtti := Rtti.RegisterClass(PClass(obj)^);
+    for p := 0 to doc.Count - 1 do
+    begin
+      prop := objRtti.Props.Find(doc.Names[p]);
+      if prop <> nil then
+        prop^.Prop.SetValue(obj, doc.Values[p]);
+    end;
+    result := true;
+  end
+  else
+    result := false;
+end;
+
+procedure DocVariantToObjArray(var arr: TDocVariantData; var objArray;
+  objClass: TClass);
+var
+  info: TRttiCustom;
+  i: PtrInt;
+  obj: TObjectDynArray absolute objArray;
+begin
+  if objClass = nil then
+    exit;
+  ObjArrayClear(obj);
+  if (not arr.IsArray) or
+     (arr.Count = 0) then
+    exit;
+  info := Rtti.RegisterClass(objClass);
+  SetLength(obj, arr.Count);
+  for i := 0 to arr.Count - 1 do
+  begin
+    obj[i] := info.ClassNewInstance;
+    DocVariantToObject(_Safe(arr.Values[i])^, obj[i], info);
+  end;
+end;
+
+function ObjectDefaultToVariant(aClass: TClass;
+  aOptions: TDocVariantOptions): variant;
+var
+  tempvoid: TObject;
+  json: RawUtf8;
+begin
+  VarClear(result);
+  tempvoid := Rtti.RegisterClass(aClass).ClassNewInstance;
+  try
+    json := ObjectToJson(tempvoid, [woDontStoreDefault]);
+    PDocVariantData(@result)^.InitJsonInPlace(pointer(json), aOptions);
+  finally
+    tempvoid.Free;
+  end;
+end;
+
+
+{$ifdef HASITERATORS}
+
+{ TDocVariantEnumeratorState }
+
+procedure TDocVariantEnumeratorState.Void;
+begin
+  After := nil;
+  Curr := nil;
+end;
+
+procedure TDocVariantEnumeratorState.Init(Values: PVariantArray; Count: PtrUInt);
+begin
+  if Count = 0 then
+    Void
+  else
+  begin
+    Curr := pointer(Values);
+    After := @Values[Count];
+    dec(Curr);
+  end;
+end;
+
+function TDocVariantEnumeratorState.MoveNext: boolean;
+begin
+   inc(Curr);
+   result := PtrUInt(Curr) < PtrUInt(After); // Void = nil+1= PtrUInt(State.After) then
+      break;
+    repeat
+      vt := vd^.VType;
+      if vt = DocVariantVType then
+      begin
+        Value := pointer(vd);
+        result := true;
+        exit;
+      end;
+      if vt <> varVariantByRef then
+        break;
+      vd := vd^.VPointer;
+    until false;
+  until false;
+  result := false;
+end;
+
+function TDocVariantObjectsEnumerator.GetEnumerator: TDocVariantObjectsEnumerator;
+begin
+  result := self;
+end;
+
+{$endif HASITERATORS}
+
+
+{ TDocVariantData }
+
+function TDocVariantData.GetValueIndex(const aName: RawUtf8): integer;
+begin
+  result := GetValueIndex(Pointer(aName), Length(aName), IsCaseSensitive);
+end;
+
+function TDocVariantData.GetCapacity: integer;
+begin
+  result := length(VValue);
+end;
+
+function TDocVariant.InternNames: TRawUtf8Interning;
+begin
+  result := fInternNames;
+  if result = nil then
+    result := CreateInternNames;
+end;
+
+function TDocVariant.CreateInternNames: TRawUtf8Interning;
+begin
+  fInternSafe.Lock;
+  try
+    if fInternNames = nil then
+      fInternNames := TRawUtf8Interning.Create;
+  finally
+    fInternSafe.UnLock;
+  end;
+  result := fInternNames;
+end;
+
+function TDocVariant.InternValues: TRawUtf8Interning;
+begin
+  result := fInternValues;
+  if fInternValues = nil then
+    result := CreateInternValues;
+end;
+
+function TDocVariant.CreateInternValues: TRawUtf8Interning;
+begin
+  fInternSafe.Lock;
+  try
+    if fInternValues = nil then
+      fInternValues := TRawUtf8Interning.Create;
+  finally
+    fInternSafe.UnLock;
+  end;
+  result := fInternValues;
+end;
+
+procedure TDocVariantData.InternalUniqueValueAt(aIndex: PtrInt);
+begin
+  DocVariantType.InternValues.UniqueVariant(VValue[aIndex]);
+end;
+
+procedure InternalUniqueValue(aValue: PVariant); // local to this unit
+begin
+  DocVariantType.InternValues.UniqueVariant(aValue^);
+end;
+
+procedure TDocVariantData.SetOptions(const opt: TDocVariantOptions);
+begin
+  VOptions := TDocVariantOptions(word(cardinal(word(opt) and not _DVO) +
+                                      cardinal(word(VOptions) and _DVO)));
+end;
+
+procedure TDocVariantData.InitClone(const CloneFrom: TDocVariantData);
+begin
+  TRttiVarData(self).VType := TRttiVarData(CloneFrom).VType and not (_DVO shl 16);
+  VCount := 0;
+  pointer(VName)  := nil; // to avoid GPF
+  pointer(VValue) := nil;
+end;
+
+function TDocVariantData.InitFrom(const CloneFrom: TDocVariantData;
+  CloneValues, MakeUnique: boolean): PVariant;
+begin
+  TRttiVarData(self).VType := TRttiVarData(CloneFrom).VType; // VType+VOptions
+  VCount := CloneFrom.VCount;
+  if MakeUnique then             // new array, but byref names
+    DynArrayCopy(@VName, @CloneFrom.VName, TypeInfo(TRawUtf8DynArray))
+  else
+    VName := CloneFrom.VName;    // byref copy of the whole array
+  if CloneValues then
+    if MakeUnique then           // new array, but byref values
+      DynArrayCopy(@VValue, @CloneFrom.VValue, TypeInfo(TVariantDynArray))
+    else
+      VValue := CloneFrom.VValue // byref copy of the whole array
+  else
+    SetLength(VValue, VCount);   // setup void values
+  result := pointer(VValue);
+end;
+
+procedure TDocVariantData.Init(const aOptions: TDocVariantOptions);
+begin
+  TRttiVarData(self).VType := DocVariantVType + // VType+VOptions
+    cardinal(word(aOptions) and not _DVO) shl 16;
+  VCount := 0;
+  pointer(VName)  := nil; // to avoid GPF when mapped within a TVarData/variant
+  pointer(VValue) := nil;
+end;
+
+procedure TDocVariantData.Init(const aOptions: TDocVariantOptions;
+  aKind: TDocVariantKind);
+begin // dvUndefined=0 dvArray=1 dvObject=2 -> [dvoIsArray]=1 [dvoIsObject]=2
+  TRttiVarData(self).VType := DocVariantVType + // VType+VOptions
+    cardinal((word(aOptions) and not _DVO) + ord(aKind)) shl 16;
+  VCount := 0;
+  pointer(VName)  := nil; // to avoid GPF
+  pointer(VValue) := nil;
+end;
+
+procedure TDocVariantData.Init(aModel: TDocVariantModel; aKind: TDocVariantKind);
+begin
+  Init(JSON_[aModel], aKind);
+end;
+
+procedure TDocVariantData.InitFast(aKind: TDocVariantKind);
+begin
+  TVarData(self) := DV_FAST[aKind];
+end;
+
+procedure TDocVariantData.InitFast(InitialCapacity: integer;
+  aKind: TDocVariantKind);
+begin
+  TVarData(self) := DV_FAST[aKind];
+  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.InitObject(const NameValuePairs: array of const;
+  Model: TDocVariantModel);
+begin
+  Init(Model, dvObject);
+  AddNameValuesToObject(NameValuePairs);
+end;
+
+procedure TDocVariantData.InternalSetVarRec(aIndex: PtrInt; const aValue: TVarRec);
+var
+  v: PVariant;
+begin
+  v := @VValue[aIndex];
+  if Has(dvoValueCopiedByReference) or
+     (aValue.VType <> vtVariant) then
+    VarRecToVariant(aValue, v^)
+  else
+    SetVariantByValue(aValue.VVariant^, v^);
+  if Has(dvoInternValues) then
+    InternalUniqueValueAt(aIndex);
+end;
+
+procedure TDocVariantData.Include(dvo: TDocVariantOption);
+begin
+  TRttiVarData(self).VType := TRttiVarData(self).VType or
+                              cardinal(1 shl (ord(dvo) + 16));
+end;
+
+procedure TDocVariantData.AddNameValuesToObject(
+  const NameValuePairs: array of const);
+var
+  n, arg, ndx: PtrInt;
+begin
+  n := length(NameValuePairs);
+  if (n = 0) or
+     (n and 1 = 1) or
+     IsArray then
+    exit; // nothing to add
+  Include(dvoIsObject);
+  n := n shr 1;
+  ndx := n + VCount;
+  if length(VValue) < ndx then
+  begin
+    SetLength(VValue, ndx);
+    SetLength(VName, ndx);
+  end;
+  ndx := VCount;
+  for arg := 0 to n - 1 do
+  begin
+    VarRecToUtf8(NameValuePairs[arg * 2], VName[ndx]);
+    if Has(dvoInternNames) then
+      DocVariantType.InternNames.UniqueText(VName[ndx]);
+    InternalSetVarRec(ndx, NameValuePairs[arg * 2 + 1]);
+    inc(ndx);
+  end;
+  inc(VCount, n);
+end;
+
+{$ifndef PUREMORMOT2}
+procedure TDocVariantData.AddOrUpdateNameValuesToObject(
+  const NameValuePairs: array of const);
+begin
+  Update(NameValuePairs);
+end;
+{$endif PUREMORMOT2}
+
+procedure TDocVariantData.Update(const NameValuePairs: array of const);
+var
+  n, arg: PtrInt;
+  nam: RawUtf8;
+  val: Variant;
+begin
+  n := length(NameValuePairs);
+  if (n = 0) or
+     (n and 1 = 1) or
+     IsArray then
+    exit; // nothing to add
+  for arg := 0 to (n shr 1) - 1 do
+  begin
+    VarRecToUtf8(NameValuePairs[arg * 2], nam);
+    VarRecToVariant(NameValuePairs[arg * 2 + 1], val);
+    AddOrUpdateValue(nam, val)
+  end;
+end;
+
+procedure TDocVariantData.AddOrUpdateObject(const NewValues: variant;
+  OnlyAddMissing: boolean; RecursiveUpdate: boolean);
+var
+  n, idx: PtrInt;
+  new: PDocVariantData;
+  wasAdded: boolean;
+begin
+  new := _Safe(NewValues);
+  if not IsArray and
+     not new^.IsArray then
+    for n := 0 to new^.Count - 1 do
+    begin
+      idx := AddOrUpdateValue(
+        new^.names[n], new^.Values[n], @wasAdded, OnlyAddMissing);
+      if RecursiveUpdate and
+         not wasAdded then
+        TDocVariantData(Values[idx]).AddOrUpdateObject(
+          new^.Values[n], OnlyAddMissing, true);
+    end;
+end;
+
+procedure TDocVariantData.InitArray(const aItems: array of const;
+  aOptions: TDocVariantOptions);
+var
+  arg: PtrInt;
+begin
+  Init(aOptions, dvArray);
+  if high(aItems) < 0 then
+    exit;
+  VCount := length(aItems);
+  SetLength(VValue, VCount);
+  for arg := 0 to high(aItems) do
+    InternalSetVarRec(arg, aItems[arg]);
+end;
+
+procedure TDocVariantData.InitArray(const aItems: array of const;
+  aModel: TDocVariantModel);
+begin
+  InitArray(aItems, JSON_[aModel]);
+end;
+
+procedure TDocVariantData.InitArrayFromVariants(const aItems: TVariantDynArray;
+  aOptions: TDocVariantOptions; aItemsCopiedByReference: boolean; aCount: integer);
+begin
+  if aItems = nil then
+    TRttiVarData(self).VType := varNull
+  else
+  begin
+    Init(aOptions, dvArray);
+    if aCount < 0 then
+      VCount := length(aItems)
+    else
+      VCount := aCount;
+    VValue := aItems; // fast by-reference copy of VValue[] array
+    if not aItemsCopiedByReference then
+      InitCopy(variant(self), aOptions);
+  end;
+end;
+
+procedure TDocVariantData.InitArrayFromObjectValues(const aObject: variant;
+  aOptions: TDocVariantOptions; aItemsCopiedByReference: boolean);
+var
+  dv: PDocVariantData;
+begin
+  if _SafeObject(aObject, dv) then
+    InitArrayFromVariants(dv^.Values, aOptions, aItemsCopiedByReference, dv^.Count)
+  else
+    TRttiVarData(self).VType := varNull;
+end;
+
+procedure TDocVariantData.InitArrayFromObjectNames(const aObject: variant;
+  aOptions: TDocVariantOptions; aItemsCopiedByReference: boolean);
+var
+  dv: PDocVariantData;
+begin
+  if _SafeObject(aObject, dv) then
+    InitArrayFrom(dv^.Names, aOptions, dv^.Count)
+  else
+    TRttiVarData(self).VType := varNull;
+end;
+
+procedure TDocVariantData.InitArrayFromCsv(const aCsv: RawUtf8;
+  aOptions: TDocVariantOptions; aSeparator: AnsiChar;
+  aTrimItems, aAddVoidItems: boolean; aQuote: AnsiChar);
+var
+  tmp: TRawUtf8DynArray;
+begin
+  if aSeparator = #0 then
+    aSeparator := CsvGuessSeparator(aCsv); // separator-tolerant
+  CsvToRawUtf8DynArray(
+    pointer(aCsv), tmp, aSeparator, aTrimItems, aAddVoidItems, aQuote);
+  InitArrayFrom(tmp, aOptions);
+end;
+
+procedure _FromText(opt: TDocVariantOptions; v: PVariant; const t: RawUtf8);
+begin
+  if not GetVariantFromNotStringJson(
+           pointer(t), PVarData(v)^, dvoAllowDoubleValue in opt) then
+    if dvoInternValues in opt then
+      DocVariantType.InternValues.UniqueVariant(v^, t)
+    else
+      RawUtf8ToVariant(t, v^);
+end;
+
+procedure TDocVariantData.InitArrayFromCsvFile(const aCsv: RawUtf8;
+  aOptions: TDocVariantOptions; aSeparator, aQuote: AnsiChar);
+var
+  c: PUtf8Char;
+  nam, tmp: TRawUtf8DynArray;
+  v: PDocVariantData;
+  line: RawUtf8;
+  n, j, t: PtrInt;
+begin
+  n := 0;
+  Init(aOptions, dvArray);
+  c := pointer(aCsv);
+  while c <> nil do
+  begin
+    line := GetNextLine(c, c);
+    if line = '' then
+      continue;
+    if (tmp = nil) and
+       (aSeparator = #0) then
+      aSeparator := CsvGuessSeparator(line); // separator-tolerant
+    tmp := nil;
+    CsvToRawUtf8DynArray(pointer(line), tmp, aSeparator, false, true, aQuote);
+    if tmp <> nil then
+      if nam = nil then
+      begin
+        nam := tmp; // first line are field/column names
+        n := length(nam);
+      end
+      else
+      begin
+        j := InternalAdd('', -1); // new row of data
+        v := @VValue[j];      // in two lines for FPC
+        v^.Init(aOptions, dvObject);
+        v^.VName := nam;
+        v^.VCount := n;
+        SetLength(v^.VValue, n);
+        t := length(tmp);
+        if t > n then
+          t := n; // allow too many or missing last columns
+        for j := 0 to t - 1 do
+          _FromText(aOptions, @v^.VValue[j], tmp[j]); // recognize numbers
+      end;
+  end;
+end;
+
+procedure TDocVariantData.InitArrayFrom(const aSource: TDocVariantData;
+  aOptions: TDocVariantOptions; aOffset, aLimit: integer);
+begin
+  Init(aOptions, dvArray);
+  VCount := aLimit;
+  if not aSource.RangeVoid(aOffset, VCount) then // not void
+    VValue := copy(aSource.VValue, aOffset, VCount); // new array, byref values
+end;
+
+function _InitArray(out aDest: TDocVariantData; aOptions: TDocVariantOptions;
+  aCount: integer; const aItems): PRttiVarData;
+begin
+  if aCount < 0 then
+    aCount := length(TByteDynArray(aItems));
+  if aCount = 0 then
+  begin
+    TRttiVarData(aDest).VType := varNull;
+    result := nil;
+    exit;
+  end;
+  {%H-}aDest.Init(aOptions, dvArray);
+  aDest.VCount := aCount;
+  SetLength(aDest.VValue, aCount);
+  result := pointer(aDest.VValue);
+end;
+
+procedure TDocVariantData.InitArrayFromObjArray(const ObjArray;
+  aOptions: TDocVariantOptions; aWriterOptions: TTextWriterWriteObjectOptions;
+  aCount: integer);
+var
+  ndx: PtrInt;
+  aItems: TObjectDynArray absolute ObjArray;
+begin
+  _InitArray(self, aOptions, aCount, aItems);
+  for ndx := 0 to VCount - 1 do
+    ObjectToVariant(aItems[ndx], VValue[ndx], aWriterOptions);
+end;
+
+procedure TDocVariantData.InitArrayFrom(const aItems: TRawUtf8DynArray;
+  aOptions: TDocVariantOptions; aCount: integer);
+var
+  ndx: PtrInt;
+  v: PRttiVarData;
+begin
+  v := _InitArray(self, aOptions, aCount, aItems);
+  for ndx := 0 to VCount - 1 do
+  begin
+    v^.VType := varString;
+    RawUtf8(v^.Data.VAny) := aItems[ndx];
+    inc(v);
+  end;
+end;
+
+procedure TDocVariantData.InitArrayFrom(const aItems: TIntegerDynArray;
+  aOptions: TDocVariantOptions; aCount: integer);
+var
+  ndx: PtrInt;
+  v: PRttiVarData;
+begin
+  v := _InitArray(self, aOptions, aCount, aItems);
+  for ndx := 0 to VCount - 1 do
+  begin
+    v^.VType := varInteger;
+    v^.Data.VInteger := aItems[ndx];
+    inc(v);
+  end;
+end;
+
+procedure TDocVariantData.InitArrayFrom(const aItems: TInt64DynArray;
+  aOptions: TDocVariantOptions; aCount: integer);
+var
+  ndx: PtrInt;
+  v: PRttiVarData;
+begin
+  v := _InitArray(self, aOptions, aCount, aItems);
+  for ndx := 0 to VCount - 1 do
+  begin
+    v^.VType := varInt64;
+    v^.Data.VInt64 := aItems[ndx];
+    inc(v);
+  end;
+end;
+
+procedure TDocVariantData.InitArrayFrom(const aItems: TDoubleDynArray;
+  aOptions: TDocVariantOptions; aCount: integer);
+var
+  ndx: PtrInt;
+  v: PRttiVarData;
+begin
+  v := _InitArray(self, aOptions, aCount, aItems);
+  for ndx := 0 to VCount - 1 do
+  begin
+    v^.VType := varDouble;
+    v^.Data.VDouble := aItems[ndx];
+    inc(v);
+  end;
+end;
+
+procedure TDocVariantData.InitArrayFrom(var aItems; ArrayInfo: PRttiInfo;
+  aOptions: TDocVariantOptions; ItemsCount: PInteger);
+var
+  da: TDynArray;
+begin
+  da.Init(ArrayInfo, aItems, ItemsCount);
+  InitArrayFrom(da, aOptions);
+end;
+
+procedure TDocVariantData.InitArrayFrom(const aItems: TDynArray;
+  aOptions: TDocVariantOptions);
+var
+  n: integer;
+  pb: PByte;
+  v: PVarData;
+  item: TRttiCustom;
+  json: RawUtf8;
+begin
+  Init(aOptions, dvArray);
+  n := aItems.Count;
+  item := aItems.Info.ArrayRtti;
+  if (n = 0) or
+     (item = nil) then
+    exit;
+  if item.Kind in (rkRecordOrDynArrayTypes + [rkClass]) then
+  begin
+    // use temporary non-expanded JSON conversion for complex nested content
+    aItems.SaveToJson(json, [twoNonExpandedArrays]);
+    if (json <> '') and
+       (json[1] = '{') then
+      // should be a non-expanded array, not JSON_BASE64_MAGIC_QUOTE_C
+      InitArrayFromResults(pointer(json), length(json), aOptions);
+  end
+  else
+  begin
+    // handle array of simple types
+    VCount := n;
+    SetLength(VValue, n);
+    pb := aItems.Value^;
+    v := pointer(VValue);
+    repeat
+      inc(pb, item.ValueToVariant(pb, v^));
+      inc(v);
+      dec(n);
+    until n = 0;
+  end;
+end;
+
+function TDocVariantData.InitArrayFromResults(Json: PUtf8Char; JsonLen: PtrInt;
+  aOptions: TDocVariantOptions): boolean;
+var
+  J: PUtf8Char;
+  fieldcount, rowcount, capa, r, f: PtrInt;
+  info: TGetJsonField;
+  dv: PDocVariantData;
+  val: PVariant;
+  proto: TDocVariantData;
+begin
+  result := false;
+  Init(aOptions, dvArray);
+  info.Json := GotoNextNotSpace(Json);
+  if IsNotExpandedBuffer(info.Json, Json + JsonLen, fieldcount, rowcount) then
+  begin
+    // A. Not Expanded (more optimized) format as array of values
+    // {"fieldCount":2,"values":["f1","f2","1v1",1v2,"2v1",2v2...],"rowCount":20}
+    // 1. check rowcount and fieldcount
+    if (rowcount < 0) or // IsNotExpandedBuffer() detected invalid input
+       (fieldcount = 0) then
+      exit;
+    // 2. initialize the object prototype with the trailing field names
+    proto.Init(aOptions, dvObject);
+    proto.Capacity := fieldcount;
+    for f := 1 to fieldcount do
+    begin
+      info.GetJsonField;
+      if not info.WasString then
+        exit; // should start with field names
+      proto.AddValue(info.Value, info.ValueLen, null); // set proper field name
+    end;
+    // 3. fill all nested objects from incoming values
+    SetLength(VValue, rowcount);
+    dv := pointer(VValue);
+    for r := 1 to rowcount do
+    begin
+      val := dv^.InitFrom(proto, {values=}false); // names byref + void values
+      for f := 1 to fieldcount do
+      begin
+        JsonToAnyVariant(val^, info, @aOptions);
+        inc(val);
+      end;
+      if info.Json = nil then
+        exit;
+      inc(dv); // next object
+    end;
+  end
+  else
+  begin
+    // B. Expanded format as array of objects (each with field names)
+    // [{"f1":"1v1","f2":1v2},{"f2":"2v1","f2":2v2}...]
+    // 1. get first object (will reuse its field names)
+    info.Json := GotoFieldCountExpanded(info.Json);
+    if (info.Json = nil) or
+       (info.Json^ = ']') then
+      exit; // [] -> valid, but void data
+    info.Json := proto.InitJsonInPlace(info.Json, aOptions, @info.EndOfObject);
+    if info.Json = nil then
+      exit;
+    if info.EndOfObject = ']' then
+    begin
+      AddItem(variant(proto)); // single item array
+      result := true;
+      exit;
+    end;
+    rowcount := 0;
+    capa := 16;
+    SetLength(VValue, capa);
+    dv := pointer(VValue);
+    dv^ := proto;
+    // 2. get values (assume fieldcount are always the same as in the first object)
+    repeat
+      J := info.Json;
+      while (J^ <> '{') and
+            (J^ <> ']') do // go to next object beginning
+        if J^ = #0 then
+          exit
+        else
+          inc(J);
+      inc(rowcount);
+      if J^ = ']' then
+        break;
+      info.Json := J + 1; // jmp '}'
+      if rowcount = capa then
+      begin
+        capa := NextGrow(capa);
+        SetLength(VValue, capa);
+        dv := @VValue[rowcount];
+      end
+      else
+        inc(dv);
+      val := dv^.InitFrom(proto, {values=}false);
+      for f := 1 to proto.Count do
+      begin
+        info.Json := GotoEndJsonItemString(info.Json); // ignore field names
+        if info.Json = nil then
+          exit;
+        inc(info.Json); // ignore jcEndOfJsonFieldOr0
+        JsonToAnyVariant(val^, info, @aOptions);
+        if info.Json = nil then
+          exit;
+        inc(val);
+      end;
+      if info.EndOfObject<> '}' then
+       exit;
+    until false;
+  end;
+  VCount := rowcount;
+  result := true;
+end;
+
+function TDocVariantData.InitArrayFromResults(const Json: RawUtf8;
+  aOptions: TDocVariantOptions): boolean;
+var
+  tmp: TSynTempBuffer;
+begin
+  tmp.Init(Json);
+  try
+    result := InitArrayFromResults(tmp.buf, tmp.len, aOptions);
+  finally
+    tmp.Done;
+  end;
+end;
+
+function TDocVariantData.InitArrayFromResults(const Json: RawUtf8;
+  aModel: TDocVariantModel): boolean;
+begin
+  result := InitArrayFromResults(Json, JSON_[aModel]);
+end;
+
+procedure TDocVariantData.InitObjectFromVariants(const aNames: TRawUtf8DynArray;
+  const aValues: TVariantDynArray; aOptions: TDocVariantOptions);
+begin
+  if (aNames = nil) or
+     (length(aValues) <> PDALen(PAnsiChar(aNames) - _DALEN)^ + _DAOFF) then
+    TRttiVarData(self).VType := varNull
+  else
+  begin
+    Init(aOptions, dvObject);
+    VCount := PDALen(PAnsiChar(aNames) - _DALEN)^ + _DAOFF;
+    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; aPathDelim: AnsiChar);
+var
+  right: RawUtf8;
+begin
+  if aPath <> '' then
+  begin
+    Init(aOptions, dvObject);
+    VCount := 1;
+    SetLength(VName, 1);
+    SetLength(VValue, 1);
+    Split(aPath, aPathDelim, VName[0], right);
+    if right = '' then
+      VValue[0] := aValue
+    else
+      PDocVariantData(@VValue[0])^.InitObjectFromPath(
+        right, aValue, aOptions, aPathDelim);
+    exit;
+  end;
+  TRttiVarData(self).VType := varNull;
+end;
+
+function TDocVariantData.InitJsonInPlace(Json: PUtf8Char;
+  aOptions: TDocVariantOptions; aEndOfObject: PUtf8Char): PUtf8Char;
+var
+  info: TGetJsonField;
+  Name: PUtf8Char;
+  NameLen: integer;
+  n, cap: PtrInt;
+  Val: PVariant;
+  intnames, intvalues: TRawUtf8Interning;
+begin
+  Init(aOptions);
+  result := nil;
+  if Json = nil then
+    exit;
+  if Has(dvoInternValues) then
+    intvalues := DocVariantType.InternValues
+  else
+    intvalues := nil;
+  while (Json^ <= ' ') and
+        (Json^ <> #0) do
+    inc(Json);
+  case Json^ of
+    '[':
+      begin
+        repeat
+          inc(Json);
+          if Json^ = #0 then
+            exit;
+        until Json^ > ' ';
+        Include(dvoIsArray);
+        if Json^ = ']' then
+          // void but valid input array
+          Json := GotoNextNotSpace(Json + 1)
+        else
+        begin
+          if Has(dvoJsonParseDoNotGuessCount) then
+            cap := 8 // with a lot of nested objects -> best to ignore
+          else
+          begin
+            // guess of the Json array items count - prefetch up to 64KB of input
+            cap := abs(JsonArrayCount(Json, Json + JSON_PREFETCH));
+            if cap = 0 then
+              exit; // invalid content
+          end;
+          SetLength(VValue, cap);
+          Val := pointer(VValue);
+          n := 0;
+          info.Json := Json;
+          repeat
+            if n = cap then
+            begin
+              // grow if our initial guess was aborted due to huge input
+              cap := NextGrow(cap);
+              SetLength(VValue, cap);
+              Val := @VValue[n];
+            end;
+            // unserialize the next item
+            JsonToAnyVariant(val^, info, @VOptions);
+            if info.Json = nil then
+              break; // invalid input
+            if intvalues <> nil then
+              intvalues.UniqueVariant(val^);
+            inc(Val);
+            inc(n);
+          until info.EndOfObject = ']';
+          Json := info.Json;
+          if Json = nil then
+          begin
+            // invalid input
+            VValue := nil;
+            exit;
+          end;
+          // ok - but no SetLength(..,VCount) if NextGrow() on huge input
+          VCount := n;
+        end;
+      end;
+    '{':
+      begin
+        repeat
+          inc(Json);
+          if Json^ = #0 then
+            exit;
+        until Json^ > ' ';
+        Include(dvoIsObject);
+        if Json^ = '}' then
+          // void but valid input object
+          Json := GotoNextNotSpace(Json + 1)
+        else
+        begin
+          if Has(dvoJsonParseDoNotGuessCount) then
+            cap := 4 // with a lot of nested documents -> best to ignore
+          else
+          begin
+            // guess of the Json object properties count - prefetch up to 64KB
+            cap := JsonObjectPropCount(Json, Json + JSON_PREFETCH);
+            if cap = 0 then
+              exit // invalid content (was <0 if early abort)
+            else if cap < 0 then
+            begin // nested or huge objects are evil -> no more guess
+              cap := -cap;
+              Include(dvoJsonParseDoNotGuessCount);
+            end;
+          end;
+          if Has(dvoInternNames) then
+            intnames := DocVariantType.InternNames
+          else
+            intnames := nil;
+          SetLength(VValue, cap);
+          Val := pointer(VValue);
+          SetLength(VName, cap);
+          n := 0;
+          info.Json := Json;
+          repeat
+            // see http://docs.mongodb.org/manual/reference/mongodb-extended-Json
+            Name := GetJsonPropName(info.Json, @NameLen);
+            if Name = nil then
+              break; // invalid input
+            if n = cap then
+            begin
+              // grow if our initial guess was aborted due to huge input
+              cap := NextGrow(cap);
+              SetLength(VName, cap);
+              SetLength(VValue, cap);
+              Val := @VValue[n];
+            end;
+            JsonToAnyVariant(Val^, info, @VOptions);
+            if info.Json = nil then
+              if info.EndOfObject = '}' then // valid object end
+                info.Json := @NULCHAR
+              else
+                break; // invalid input
+            if NameLen <> 0 then // we just ignore void "":xxx field names
+            begin
+              if intnames <> nil then
+                intnames.Unique(VName[n], Name, NameLen)
+              else
+                FastSetString(VName[n], Name, NameLen);
+              if intvalues <> nil then
+                intvalues.UniqueVariant(Val^);
+              inc(n);
+              inc(Val);
+            end;
+          until info.EndOfObject = '}';
+          Json := info.Json;
+          if (Name = nil) or
+             (Json = nil) then
+          begin
+            // invalid input
+            VName := nil;
+            VValue := nil;
+            exit;
+          end;
+          // ok - but no SetLength(..,VCount) if NextGrow() on huge input
+          VCount := n;
+        end;
+      end;
+    'n',
+    'N':
+      begin
+        if IdemPChar(Json + 1, 'ULL') then
+        begin
+          Include(dvoIsObject);
+          result := GotoNextNotSpace(Json + 4);
+        end;
+        exit;
+      end;
+  else
+    exit;
+  end;
+  while (Json^ <= ' ') and
+        (Json^ <> #0) do
+    inc(Json);
+  if aEndOfObject <> nil then
+    aEndOfObject^ := Json^;
+  if Json^ <> #0 then
+    repeat
+      inc(Json)
+    until (Json^ = #0) or
+          (Json^ > ' ');
+  result := Json; // indicates successfully parsed
+end;
+
+function TDocVariantData.InitJson(const Json: RawUtf8;
+  aOptions: TDocVariantOptions): boolean;
+var
+  tmp: TSynTempBuffer;
+begin
+  if Json = '' then
+    result := false
+  else
+  begin
+    tmp.Init(Json);
+    try
+      result := InitJsonInPlace(tmp.buf, aOptions) <> nil;
+    finally
+      tmp.Done;
+    end;
+  end;
+end;
+
+function TDocVariantData.InitJson(const Json: RawUtf8; aModel: TDocVariantModel): boolean;
+begin
+  result := InitJson(Json, JSON_[aModel]);
+end;
+
+function TDocVariantData.InitJsonFromFile(const FileName: TFileName;
+  aOptions: TDocVariantOptions): boolean;
+begin
+  result := InitJsonInPlace(pointer(RawUtf8FromFile(FileName)), aOptions) <> nil;
+end;
+
+procedure TDocVariantData.InitFromPairs(aPairs: PUtf8Char;
+  aOptions: TDocVariantOptions; NameValueSep, ItemSep: AnsiChar; DoTrim: boolean);
+var
+  n, v: RawUtf8;
+  val: variant;
+begin
+  Init(aOptions, dvObject);
+  while aPairs <> nil do
+  begin
+    GetNextItem(aPairs, NameValueSep, n);
+    if ItemSep = #10 then
+      GetNextItemTrimedCRLF(aPairs, v)
+    else
+      GetNextItem(aPairs, ItemSep, v);
+    if DoTrim then
+      TrimSelf(v);
+    if n = '' then
+      break;
+    RawUtf8ToVariant(v, val);
+    AddValue(n, val);
+  end;
+end;
+
+procedure TDocVariantData.InitFromPairs(const aPairs: RawUtf8;
+  aOptions: TDocVariantOptions; NameValueSep, ItemSep: AnsiChar; DoTrim: boolean);
+begin
+  InitFromPairs(pointer(aPairs), aOptions, NameValueSep, ItemSep, DoTrim);
+end;
+
+procedure TDocVariantData.InitCopy(const SourceDocVariant: variant;
+  aOptions: TDocVariantOptions);
+var
+  ndx: PtrInt;
+  vt: cardinal;
+  Source: PDocVariantData;
+  SourceVValue: TVariantDynArray;
+  Handler: TCustomVariantType;
+  v: PVarData;
+  vv: PVariant;
+begin
+  with TVarData(SourceDocVariant) do
+    if cardinal(VType) = varVariantByRef then
+      Source := VPointer
+    else
+      Source := @SourceDocVariant;
+  if cardinal(Source^.VType) <> DocVariantVType then
+    raise EDocVariant.CreateUtf8(
+      'Unexpected InitCopy(var%)', [VariantTypeName(PVarData(Source))^]);
+  SourceVValue := Source^.VValue; // local fast per-reference copy
+  if Source <> @self then
+  begin
+    VType := Source^.VType;
+    VCount := Source^.VCount;
+    pointer(VName) := nil;  // avoid GPF
+    pointer(VValue) := nil;
+    aOptions := aOptions - [dvoIsArray, dvoIsObject]; // may not match Source
+    if Source^.IsArray then
+      system.include(aOptions, dvoIsArray)
+    else if Source^.IsObject then
+    begin
+      system.include(aOptions, dvoIsObject);
+      SetLength(VName, VCount);
+      for ndx := 0 to VCount - 1 do
+        VName[ndx] := Source^.VName[ndx]; // manual copy is needed
+      if (dvoInternNames in aOptions) and
+         not Source^.Has(dvoInternNames) then
+        with DocVariantType.InternNames do
+          for ndx := 0 to VCount - 1 do
+            UniqueText(VName[ndx]);
+    end;
+    VOptions := aOptions;
+  end
+  else
+  begin
+    SetOptions(aOptions);
+    VariantDynArrayClear(VValue); // full copy of all values
+  end;
+  if VCount > 0 then
+  begin
+    SetLength(VValue, VCount);
+    v := pointer(SourceVValue);
+    vv := pointer(VValue);
+    ndx := VCount;
+    repeat
+      repeat
+        vt := v^.VType;
+        if vt <> varVariantByRef then
+          break;
+        v := v^.VPointer;
+      until false;
+      if vt < varFirstCustom then
+        // simple string/number types copy
+        vv^ := variant(v^)
+      else if vt = DocVariantVType then
+        // direct recursive copy for TDocVariant
+        PDocVariantData(vv)^.InitCopy(variant(v^), VOptions)
+      else if FindCustomVariantType(vt, Handler) then
+        if Handler.InheritsFrom(TSynInvokeableVariantType) then
+          TSynInvokeableVariantType(Handler).CopyByValue(PVarData(vv)^, v^)
+        else
+          Handler.Copy(PVarData(vv)^, v^, false)
+      else
+        vv^ := variant(v^); // default copy
+      inc(v);
+      inc(vv);
+      dec(ndx);
+    until ndx = 0;
+    if Has(dvoInternValues) then
+    begin
+      ndx := VCount;
+      vv := pointer(VValue);
+      with DocVariantType.InternValues do
+        repeat
+          UniqueVariant(vv^);
+          inc(vv);
+          dec(ndx);
+        until ndx = 0;
+    end;
+  end;
+  VariantDynArrayClear(SourceVValue);
+end;
+
+procedure TDocVariantData.Void;
+begin
+  VCount := 0;
+  if VName <> nil then
+    FastDynArrayClear(@VName, TypeInfo(RawUtf8));
+  if VValue <> nil then
+    FastDynArrayClear(@VValue, TypeInfo(variant));
+end;
+
+procedure TDocVariantData.Clear;
+begin
+  if cardinal(VType) = DocVariantVType then
+    ClearFast
+  else
+    VarClear(variant(self));
+end;
+
+procedure TDocVariantData.Reset;
+begin
+  VOptions := VOptions - [dvoIsArray, dvoIsObject];
+  Void;
+end;
+
+procedure TDocVariantData.FillZero;
+var
+  n: integer;
+  v: PVariant;
+begin
+  n := VCount;
+  v := pointer(VValue);
+  if n <> 0 then
+    repeat
+      mormot.core.variants.FillZero(v^);
+      inc(v);
+      dec(n);
+    until n = 0;
+  Reset;
+end;
+
+function TDocVariantData.GetModel(out model: TDocVariantModel): boolean;
+var
+  opt: TDocVariantOptions;
+  ndx: PtrInt;
+begin
+  opt := VOptions - [dvoIsArray, dvoIsObject, dvoJsonParseDoNotGuessCount];
+  ndx := WordScanIndex(@JSON_, ord(high(TDocVariantModel)) + 1, word(opt));
+  if ndx < 0 then
+    result := false
+  else
+  begin
+    model := TDocVariantModel(ndx);
+    result := true;
+  end;
+end;
+
+function TDocVariantData.RangeVoid(var Offset, Limit: integer): boolean;
+var
+  n, l: integer;
+begin
+  result := true; // void
+  n := Count;
+  if Offset < 0 then
+  begin
+    inc(Offset, n);
+    if Offset < 0 then
+      Offset := 0;
+  end;
+  if Limit = 0 then
+    Limit := n;
+  l := n - Offset;
+  if l <= 0 then
+    exit;
+  if Limit > l then
+    Limit := l;
+  result := false; // not void
+end;
+
+procedure TDocVariantData.SetCount(aCount: integer);
+begin
+  VCount := aCount;
+end;
+
+function TDocVariantData.Compare(const Another: TDocVariantData;
+  CaseInsensitive: boolean): integer;
+var
+  n: integer;
+  ndx: PtrInt;
+  v1, v2: PVarData;
+  nameCmp: TDynArraySortCompare;
+begin
+  // first validate the type: as { or [ in JSON
+  result := -1;
+  nameCmp := nil;
+  if IsArray then
+  begin
+    if not Another.IsArray then
+      exit;
+  end
+  else if IsObject then
+    if not Another.IsObject then
+      exit
+    else
+      nameCmp := SortDynArrayAnsiStringByCase[not IsCaseSensitive];
+  // compare as many in-order content as possible
+  n := Another.VCount;
+  if VCount < n then
+    n := VCount;
+  v1 := pointer(VValue);
+  v2 := pointer(Another.VValue);
+  for ndx := 0 to n - 1 do
+  begin
+    if Assigned(nameCmp) then
+    begin // each name should match
+      result := nameCmp(VName[ndx], Another.VName[ndx]);
+      if result <> 0 then
+        exit;
+    end;
+    result := FastVarDataComp(v1, v2, CaseInsensitive);
+    if result <> 0 then // each value should match
+      exit;
+    inc(v1);
+    inc(v2);
+  end;
+  // all content did match -> difference is now about the document count
+  result := VCount - Another.VCount;
+end;
+
+function TDocVariantData.CompareObject(const ObjFields: array of RawUtf8;
+  const Another: TDocVariantData; CaseInsensitive: boolean): integer;
+var
+  f: PtrInt;
+  prev: integer;
+  v1, v2: PVariant;
+begin
+  if IsObject then
+    if Another.IsObject then // compare Object, possibly by specified fields
+    begin
+      if high(ObjFields) < 0 then
+      begin
+        result := Compare(Another, CaseInsensitive);
+        exit;
+      end;
+      for f := 0 to high(ObjFields) do
+      begin
+        prev := -1; // optimistic: fields may be in the same position
+        GetObjectProp(ObjFields[f], v1, @prev);
+        Another.GetObjectProp(ObjFields[f], v2, @prev);
+        result := FastVarDataComp(pointer(v1), pointer(v2), CaseInsensitive);
+        if result <> 0 then // each value should match
+          exit;
+      end;
+      result := 0; // all supplied fields did match
+    end
+    else
+      result := 1   // Object, not Object
+  else if Another.IsObject then
+    result := -1  // not Object, Object
+  else
+    result := 0;  // not Object, not Object
+end;
+
+function TDocVariantData.Equals(const Another: TDocVariantData;
+  CaseInsensitive: boolean): boolean;
+begin
+  result := Compare(Another, CaseInsensitive) = 0;
+end;
+
+function TDocVariantData.Compare(const aName: RawUtf8; const aValue: variant;
+  aCaseInsensitive: boolean): integer;
+var
+  v: PVariant;
+begin
+  if (cardinal(VType) = DocVariantVType) and
+     GetObjectProp(aName, v{%H-}, nil) then
+    result := FastVarDataComp(pointer(v), @aValue, aCaseInsensitive)
+  else
+    result := -1;
+end;
+
+function TDocVariantData.Equals(const aName: RawUtf8; const aValue: variant;
+  aCaseInsensitive: boolean): boolean;
+var
+  v: PVariant;
+begin
+  result := (cardinal(VType) = DocVariantVType) and
+            GetObjectProp(aName, v{%H-}, nil) and
+            (FastVarDataComp(@aValue, pointer(v), aCaseInsensitive) = 0);
+end;
+
+function TDocVariantData.InternalAddBuf(aName: PUtf8Char; aNameLen: integer): integer;
+var
+  tmp: RawUtf8; // so that the caller won't need to reserve such a temp var
+begin
+  FastSetString(tmp, aName, aNameLen);
+  result := InternalAdd(tmp, -1);
+end;
+
+function TDocVariantData.InternalAdd(
+  const aName: RawUtf8; aIndex: integer): integer;
+var
+  len: integer;
+  v: PVariantArray;
+  k: PRawUtf8Array;
+begin
+  // validate consistent add/insert
+  if aName <> '' then
+  begin
+    if IsArray then
+      raise EDocVariant.CreateUtf8(
+        'Add: Unexpected [%] object property in an array', [aName]);
+    if not IsObject then
+    begin
+      VType := DocVariantVType; // may not be set yet
+      Include(dvoIsObject);
+    end;
+  end
+  else
+  begin
+    if IsObject then
+      raise EDocVariant.Create('Add: Unexpected array item in an object');
+    if not IsArray then
+    begin
+      VType := DocVariantVType; // may not be set yet
+      Include(dvoIsArray);
+    end;
+  end;
+  // grow up memory if needed
+  len := length(VValue);
+  if VCount >= len then
+  begin
+    len := NextGrow(VCount);
+    SetLength(VValue, len);
+  end;
+  result := VCount;
+  inc(VCount);
+  if cardinal(aIndex) < cardinal(result) then
+  begin
+    // reserve space for the inserted new item within existing data
+    dec(result, aIndex);
+    v := @VValue[aIndex];
+    MoveFast(v[0], v[1], result * SizeOf(variant));
+    PInteger(v)^ := varEmpty; // avoid GPF
+    if aName <> '' then
+    begin
+      if Length(VName) <> len then
+        SetLength(VName, len);
+      k := @VName[aIndex];
+      MoveFast(k[0], k[1], result * SizeOf(pointer));
+      PPointer(k)^ := nil; // avoid GPF
+    end;
+    result := aIndex;
+  end;
+  if aName = '' then
+    exit;
+  // store the object field name
+  if Length(VName) <> len then
+    SetLength(VName, len);
+  if Has(dvoInternNames) then
+    DocVariantType.InternNames.Unique(VName[result], aName)
+  else
+    VName[result] := aName;
+end;
+
+{$ifdef HASITERATORS}
+
+function TDocVariantData.GetEnumerator: TDocVariantFieldsEnumerator;
+begin
+  result.State.Init(pointer(Values), VCount);
+  if IsObject then
+  begin
+    result.Name := pointer(Names);
+    dec(result.Name);
+  end
+  else
+    result.Name := nil;
+end;
+
+function TDocVariantData.Items: TDocVariantItemsEnumerator;
+begin
+  if IsObject then
+    result{%H-}.State.Void
+  else
+    result.State.Init(pointer(Values), VCount);
+end;
+
+function TDocVariantData.Objects: TDocVariantObjectsEnumerator;
+begin
+  if IsObject then
+    result{%H-}.State.Void
+  else
+    result.State.Init(pointer(Values), VCount);
+end;
+
+function TDocVariantData.Fields: TDocVariantFieldsEnumerator;
+begin
+  if IsArray then
+    result{%H-}.State.Void
+  else
+    result := GetEnumerator;
+end;
+
+function TDocVariantData.FieldNames: TDocVariantFieldNamesEnumerator;
+begin
+  if IsArray or
+     (VCount = 0) then
+  begin
+    result.Curr := nil;
+    result.After := nil;
+  end
+  else
+  begin
+    result.Curr := pointer(Names);
+    result.After := @Names[VCount];
+    dec(result.Curr);
+  end;
+end;
+
+function TDocVariantData.FieldValues: TDocVariantItemsEnumerator;
+begin
+  if IsArray then
+    result{%H-}.State.Void
+  else
+    result.State.Init(pointer(Values), VCount);
+end;
+
+{$endif HASITERATORS}
+
+procedure TDocVariantData.SetCapacity(aValue: integer);
+begin
+  if IsObject then
+    SetLength(VName, aValue);
+  SetLength(VValue, aValue);
+end;
+
+function TDocVariantData.AddValue(const aName: RawUtf8; const aValue: variant;
+  aValueOwned: boolean; aIndex: integer): integer;
+var
+  v: PVariant;
+begin
+  if aName = '' then
+  begin
+    result := -1;
+    exit;
+  end;
+  if Has(dvoCheckForDuplicatedNames) then
+    if GetValueIndex(aName) >= 0 then
+      raise EDocVariant.CreateUtf8('AddValue: Duplicated [%] name', [aName]);
+  result := InternalAdd(aName, aIndex);
+  v := @VValue[result];
+  if aValueOwned then
+    v^ := aValue
+  else
+    SetVariantByValue(aValue, v^);
+  if Has(dvoInternValues) then
+    InternalUniqueValue(v);
+end;
+
+function TDocVariantData.AddValue(aName: PUtf8Char; aNameLen: integer;
+  const aValue: variant; aValueOwned: boolean; aIndex: integer): integer;
+var
+  tmp: RawUtf8;
+begin
+  FastSetString(tmp, aName, aNameLen);
+  result := AddValue(tmp, aValue, aValueOwned, aIndex);
+end;
+
+function TDocVariantData.AddValueFromText(const aName, aValue: RawUtf8;
+  DoUpdate: boolean): integer;
+var
+  v: PVariant;
+begin
+  if aName = '' then
+  begin
+    result := -1;
+    exit;
+  end;
+  result := GetValueIndex(aName);
+  if not DoUpdate and
+     (Has(dvoCheckForDuplicatedNames)) and
+     (result >= 0) then
+    raise EDocVariant.CreateUtf8(
+      'AddValueFromText: Duplicated [%] name', [aName]);
+  if result < 0 then
+    result := InternalAdd(aName);
+  v := @VValue[result];
+  VarClear(v^);
+  _FromText(VOptions, v, aValue); // recognize numbers
+end;
+
+procedure TDocVariantData.AddByPath(const aSource: TDocVariantData;
+  const aPaths: array of RawUtf8; aPathDelim: AnsiChar);
+var
+  ndx, added: PtrInt;
+  v: TVarData;
+begin
+  if (aSource.Count = 0) or
+     (not aSource.IsObject) or
+     IsArray then
+    exit;
+  for ndx := 0 to High(aPaths) do
+  begin
+    DocVariantType.Lookup(v, TVarData(aSource), pointer(aPaths[ndx]), aPathDelim);
+    if cardinal(v.VType) < varNull then
+      continue; // path not found
+    added := InternalAdd(aPaths[ndx]);
+    PVarData(@VValue[added])^ := v;
+    if Has(dvoInternValues) then
+      InternalUniqueValueAt(added);
+  end;
+end;
+
+procedure TDocVariantData.AddFrom(const aDocVariant: Variant);
+var
+  src: PDocVariantData;
+  n: integer;
+  v: PVariant;
+  k: PRawUtf8;
+begin
+  src := _Safe(aDocVariant);
+  n := src^.Count;
+  if n = 0 then
+    exit; // nothing to add
+  v := pointer(src^.VValue);
+  k := pointer(src^.VName);
+  if k = nil then // source aDocVariant is a dvArray
+    // add array items
+    if IsObject then
+      // types should match
+      exit
+    else
+      repeat
+        AddItem(v^);
+        inc(v);
+        dec(n)
+      until n = 0
+  else
+    // add object items
+    if IsArray then
+      // types should match
+      exit
+    else if Has(dvoCheckForDuplicatedNames) then
+      repeat
+        AddOrUpdateValue(k^, v^);
+        inc(k);
+        inc(v);
+        dec(n)
+      until n = 0
+    else
+      repeat
+        AddValue(k^, v^);
+        inc(k);
+        inc(v);
+        dec(n)
+      until n = 0;
+end;
+
+procedure TDocVariantData.AddOrUpdateFrom(const aDocVariant: Variant;
+  aOnlyAddMissing: boolean);
+var
+  src: PDocVariantData;
+  n: integer;
+  v: PVariant;
+  k: PRawUtf8;
+begin
+  src := _Safe(aDocVariant, dvObject);
+  n := src^.Count;
+  if n = 0 then
+    exit; // nothing to add
+  v := pointer(src^.VValue);
+  k := pointer(src^.VName);
+  repeat
+    AddOrUpdateValue(k^, v^, nil, aOnlyAddMissing);
+    inc(k);
+    inc(v);
+    dec(n)
+  until n = 0;
+end;
+
+function TDocVariantData.AddItem(const aValue: variant; aIndex: integer): integer;
+begin
+  result := InternalAdd('', aIndex);
+  InternalSetValue(result, aValue);
+end;
+
+function TDocVariantData.AddItem(const aValue: TDocVariantData; aIndex: integer): integer;
+begin
+  result := InternalAdd('', aIndex);
+  InternalSetValue(result, variant(aValue));
+end;
+
+function TDocVariantData.AddItemFromText(const aValue: RawUtf8; aIndex: integer): integer;
+begin
+  result := InternalAdd('', aIndex);
+  _FromText(VOptions, @VValue[result], aValue); // recognize numbers
+end;
+
+function TDocVariantData.AddItemText(
+  const aValue: RawUtf8; aIndex: integer): integer;
+begin
+  result := InternalAdd('', aIndex);
+  if Has(dvoInternValues) then
+    DocVariantType.InternValues.UniqueVariant(VValue[result], aValue)
+  else
+    RawUtf8ToVariant(aValue, VValue[result]);
+end;
+
+procedure TDocVariantData.AddItems(const aValue: array of const);
+var
+  ndx, added: PtrInt;
+begin
+  for ndx := 0 to high(aValue) do
+  begin
+    added := InternalAdd('');
+    VarRecToVariant(aValue[ndx], VValue[added]);
+    if Has(dvoInternValues) then
+      InternalUniqueValueAt(added);
+  end;
+end;
+
+procedure TDocVariantData.AddObject(const aNameValuePairs: array of const;
+  const aName: RawUtf8);
+var
+  added: PtrInt;
+  obj: PDocVariantData;
+begin
+  if (aName <> '') and
+     (Has(dvoCheckForDuplicatedNames)) then
+    if GetValueIndex(aName) >= 0 then
+      raise EDocVariant.CreateUtf8('AddObject: Duplicated [%] name', [aName]);
+  added := InternalAdd(aName);
+  obj := @VValue[added];
+  if PInteger(obj)^ = 0 then // most common case is adding a new value
+    obj^.InitClone(self)     // same options than owner document
+  else if (obj^.VType <> VType) or
+          not obj^.IsObject then
+    raise EDocVariant.CreateUtf8('AddObject: wrong existing [%]', [aName]);
+  obj^.AddNameValuesToObject(aNameValuePairs);
+  if Has(dvoInternValues) then
+    InternalUniqueValueAt(added);
+end;
+
+function TDocVariantData.GetObjectProp(const aName: RawUtf8;
+  out aFound: PVariant; aPreviousIndex: PInteger): boolean;
+var
+  ndx, n: PtrInt;
+begin
+  result := false;
+  aFound := nil;
+  n := VCount;
+  if (n = 0) or
+     (aName = '') or
+     not IsObject then
+    exit;
+  ndx := -1;
+  if aPreviousIndex <> nil then
+  begin // optimistic try if this field is in the same place
+    ndx := aPreviousIndex^;
+    if (PtrUInt(ndx) >= PtrUInt(n)) or
+       (SortDynArrayAnsiStringByCase[not IsCaseSensitive](
+         VName[ndx], aName) <> 0) then
+      ndx := -1;
+  end;
+  if ndx < 0 then
+    ndx := FindNonVoid[IsCaseSensitive](
+          pointer(VName), pointer(aName), length(aName), n);
+  if ndx < 0 then
+    exit;
+  if aPreviousIndex <> nil then
+    aPreviousIndex^ := ndx;
+  aFound := @VValue[ndx];
+  result  := true;
+end;
+
+function TDocVariantData.SearchItemByProp(const aPropName, aPropValue: RawUtf8;
+  aPropValueCaseSensitive: boolean): integer;
+var
+  v: PVariant;
+  prev: integer;
+begin
+  if IsObject then
+  begin
+    result := GetValueIndex(aPropName);
+    if (result >= 0) and
+       VariantEquals(VValue[result], aPropValue, aPropValueCaseSensitive) then
+      exit;
+  end
+  else if IsArray then
+  begin
+    prev := -1; // optimistic search aPropName at the previous field position
+    for result := 0 to VCount - 1 do
+      if _Safe(VValue[result])^.GetObjectProp(aPropName, v, @prev) and
+         VariantEquals({%H-}v^, 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: PtrInt): PtrInt;
+var
+  v: PVarData;
+  tmp: variant;
+begin
+  SetVariantByValue(aValue, tmp); // ensure text is RawUtf8
+  v := @VValue[StartIndex];
+  for result := StartIndex to VCount - 1 do
+    if FastVarDataComp(v, @tmp, CaseInsensitive) = 0 then
+      exit
+    else
+      inc(v);
+  result := -1;
+end;
+
+function TDocVariantData.CountItemByValue(const aValue: Variant;
+  CaseInsensitive: boolean; StartIndex: integer): integer;
+var
+  v: PVarData;
+  ndx: integer;
+  tmp: variant;
+begin
+  result := 0; // returns the number of occurences of this value
+  SetVariantByValue(aValue, tmp); // ensure text is RawUtf8
+  v := @VValue[StartIndex];
+  for ndx := StartIndex to VCount - 1 do
+  begin
+    if FastVarDataComp(v, @tmp, CaseInsensitive) = 0 then
+      inc(result);
+    inc(v);
+  end;
+end;
+
+type
+  {$ifdef USERECORDWITHMETHODS}
+  TQuickSortDocVariant = record
+  {$else}
+  TQuickSortDocVariant = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    names: PPointerArray;
+    values: PVariantArray;
+    nameCompare: TUtf8Compare;
+    valueCompare: TVariantCompare;
+    valueComparer: TVariantComparer;
+    reversed: PtrInt;
+    procedure SortByName(L, R: PtrInt);
+    procedure SortByValue(L, R: PtrInt);
+  end;
+
+procedure TQuickSortDocVariant.SortByName(L, R: PtrInt);
+var
+  I, J, P: PtrInt;
+  pivot: pointer;
+begin
+  if L < R then
+    repeat
+      I := L;
+      J := R;
+      P := (L + R) shr 1;
+      repeat
+        pivot := names[P];
+        while nameCompare(names[I], pivot) * reversed < 0 do
+          inc(I);
+        while nameCompare(names[J], pivot) * reversed > 0 do
+          dec(J);
+        if I <= J then
+        begin
+          if I <> J then
+          begin
+            ExchgPointer(@names[I], @names[J]);
+            ExchgVariant(@values[I], @values[J]);
+          end;
+          if P = I then
+            P := J
+          else if P = J then
+            P := I;
+          inc(I);
+          dec(J);
+        end;
+      until I > J;
+      if J - L < R - I then
+      begin
+        // use recursion only for smaller range
+        if L < J then
+          SortByName(L, J);
+        L := I;
+      end
+      else
+      begin
+        if I < R then
+          SortByName(I, R);
+        R := J;
+      end;
+    until L >= R;
+end;
+
+procedure TQuickSortDocVariant.SortByValue(L, R: PtrInt);
+var
+  I, J, P: PtrInt;
+  pivot: PVariant;
+begin
+  if L < R then
+    repeat
+      I := L;
+      J := R;
+      P := (L + R) shr 1;
+      repeat
+        pivot := @values[P];
+        if Assigned(valueCompare) then
+        begin // called from SortByValue
+          while valueCompare(values[I], pivot^) * reversed < 0 do
+            inc(I);
+          while valueCompare(values[J], pivot^) * reversed > 0 do
+            dec(J);
+        end
+        else
+        begin // called from SortByRow
+          while valueComparer(values[I], pivot^) * reversed < 0 do
+            inc(I);
+          while valueComparer(values[J], pivot^) * reversed > 0 do
+            dec(J);
+        end;
+        if I <= J then
+        begin
+          if I <> J then
+          begin
+            if names <> nil then
+              ExchgPointer(@names[I], @names[J]);
+            ExchgVariant(@values[I], @values[J]);
+          end;
+          if P = I then
+            P := J
+          else if P = J then
+            P := I;
+          inc(I);
+          dec(J);
+        end;
+      until I > J;
+      if J - L < R - I then
+      begin
+        // use recursion only for smaller range
+        if L < J then
+          SortByValue(L, J);
+        L := I;
+      end
+      else
+      begin
+        if I < R then
+          SortByValue(I, R);
+        R := J;
+      end;
+    until L >= R;
+end;
+
+procedure TDocVariantData.SortByName(
+  SortCompare: TUtf8Compare; SortCompareReversed: boolean);
+var
+  qs: TQuickSortDocVariant;
+begin
+  if (not IsObject) or
+     (VCount <= 1) then
+    exit;
+  if Assigned(SortCompare) then
+    qs.nameCompare := SortCompare
+  else
+    qs.nameCompare := @StrIComp;
+  qs.names := pointer(VName);
+  qs.values := pointer(VValue);
+  if SortCompareReversed then
+    qs.reversed := -1
+  else
+    qs.reversed := 1;
+  qs.SortByName(0, VCount - 1);
+end;
+
+procedure TDocVariantData.SortByValue(SortCompare: TVariantCompare;
+  SortCompareReversed: boolean);
+var
+  qs: TQuickSortDocVariant;
+begin
+  if VCount <= 1 then
+    exit;
+  if Assigned(SortCompare) then
+    qs.valueCompare := SortCompare
+  else
+    qs.valueCompare := @VariantCompare;
+  qs.valueComparer := nil;
+  qs.names := pointer(VName);
+  qs.values := pointer(VValue);
+  if SortCompareReversed then
+    qs.reversed := -1
+  else
+    qs.reversed := 1;
+  qs.SortByValue(0, VCount - 1);
+end;
+
+procedure TDocVariantData.SortByRow(const SortComparer: TVariantComparer;
+  SortComparerReversed: boolean);
+var
+  qs: TQuickSortDocVariant;
+begin
+  if (VCount <= 1) or
+     (not Assigned(SortComparer)) then
+    exit;
+  qs.valueCompare := nil;
+  qs.valueComparer := SortComparer;
+  qs.names := pointer(VName);
+  qs.values := pointer(VValue);
+  if SortComparerReversed then
+    qs.reversed := -1
+  else
+    qs.reversed := 1;
+  qs.SortByValue(0, VCount - 1);
+end;
+
+type
+  TQuickSortByFieldLookup = array[0..3] of PVariant;
+  PQuickSortByFieldLookup = ^TQuickSortByFieldLookup;
+
+  {$ifdef USERECORDWITHMETHODS}
+  TQuickSortDocVariantValuesByField = record
+  {$else}
+  TQuickSortDocVariantValuesByField = object
+  {$endif USERECORDWITHMETHODS}
+  public
+    Lookup: array of TQuickSortByFieldLookup; // per-name values
+    Compare: TVariantCompare;
+    CompareField: TVariantCompareField;
+    Fields: PRawUtf8Array;
+    P: PtrInt;
+    Pivot: PQuickSortByFieldLookup;
+    Doc: PDocVariantData;
+    TempExch: TQuickSortByFieldLookup;
+    Reverse: boolean;
+    Depth: integer; // = high(Lookup)
+    procedure Init(const aPropNames: array of RawUtf8;
+      aNameSortedCompare: TUtf8Compare);
+    function DoComp(Value: PQuickSortByFieldLookup): PtrInt;
+      {$ifndef CPUX86} inline; {$endif}
+    procedure Sort(L, R: PtrInt);
+  end;
+
+procedure TQuickSortDocVariantValuesByField.Init(
+  const aPropNames: array of RawUtf8; aNameSortedCompare: TUtf8Compare);
+var
+  namecomp: TUtf8Compare;
+  v: pointer;
+  row, f: PtrInt;
+  rowdata: PDocVariantData;
+  ndx: integer;
+begin
+  Depth := high(aPropNames);
+  if (Depth < 0) or
+     (Depth > high(TQuickSortByFieldLookup)) then
+    raise EDocVariant.CreateUtf8('TDocVariantData.SortByFields(%)', [Depth]);
+  // resolve GetPVariantByName(aPropNames) once into Lookup[]
+  SetLength(Lookup, Doc^.VCount);
+  if Assigned(aNameSortedCompare) then // just like GetVarData() searches names
+    namecomp := aNameSortedCompare
+  else
+    namecomp := StrCompByCase[not Doc^.IsCaseSensitive];
+  for f := 0 to Depth do
+  begin
+    if aPropNames[f] = '' then
+      raise EDocVariant.CreateUtf8('TDocVariantData.SortByFields(%=void)', [f]);
+    ndx := -1;
+    for row := 0 to Doc^.VCount - 1 do
+    begin
+      rowdata := _Safe(Doc^.VValue[row]);
+      if (cardinal(ndx) < cardinal(rowdata^.VCount)) and
+         (namecomp(pointer(rowdata^.VName[ndx]), pointer(aPropNames[f])) = 0) then
+        v := @rowdata^.VValue[ndx] // get the value at the (likely) same position
+      else
+      begin
+        v := rowdata^.GetVarData(aPropNames[f], aNameSortedCompare, @ndx);
+        if v = nil then
+          v := @NullVarData;
+      end;
+      Lookup[row, f] := v;
+    end;
+  end;
+end;
+
+function TQuickSortDocVariantValuesByField.DoComp(
+  Value: PQuickSortByFieldLookup): PtrInt;
+begin
+  if Assigned(Compare) then
+  begin
+    result := Compare(Value[0]^, Pivot[0]^);
+    if (result = 0) and
+       (depth > 0) then
+    begin
+      result := Compare(Value[1]^, Pivot[1]^);
+      if (result = 0) and
+         (depth > 1) then
+      begin
+        result := Compare(Value[2]^, Pivot[2]^);
+        if (result = 0) and
+           (depth > 2) then
+         result := Compare(Value[3]^, Pivot[3]^);
+      end;
+    end;
+  end
+  else
+  begin
+    result := CompareField(Fields[0], Value[0]^, Pivot[0]^);
+    if (result = 0) and
+       (depth > 0) then
+    begin
+      result := CompareField(Fields[1], Value[1]^, Pivot[1]^);
+      if (result = 0) and
+         (depth > 1) then
+      begin
+        result := CompareField(Fields[2], Value[2]^, Pivot[2]^);
+        if (result = 0) and
+           (depth > 2) then
+         result := CompareField(Fields[3], Value[3]^, Pivot[3]^);
+      end;
+    end;
+  end;
+  if Reverse then
+    result := -result;
+end;
+
+procedure TQuickSortDocVariantValuesByField.Sort(L, R: PtrInt);
+var
+  I, J: PtrInt;
+begin
+  if L < R then
+    repeat
+      I := L;
+      J := R;
+      P := (L + R) shr 1;
+      repeat
+        Pivot := @Lookup[P];
+        while DoComp(@Lookup[I]) < 0 do
+          inc(I);
+        while DoComp(@Lookup[J]) > 0 do
+          dec(J);
+        if I <= J then
+        begin
+          if I <> J then
+          begin
+            if Doc.VName <> nil then
+              ExchgPointer(@Doc.VName[I], @Doc.VName[J]);
+            ExchgVariant(@Doc.VValue[I], @Doc.VValue[J]);
+            ExchgPointers(@Lookup[I], @Lookup[J], Depth + 1);
+          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;
+begin
+  if (VCount <= 0) or
+     (aItemPropName = '') or
+     not IsArray then
+    exit;
+  if not Assigned(aValueCompare) then
+    aValueCompare := VariantCompare;
+  QS.Compare := aValueCompare;
+  QS.Doc := @self;
+  QS.Init([aItemPropName], aNameSortedCompare);
+  QS.Reverse := aValueCompareReverse;
+  QS.Sort(0, VCount - 1);
+end;
+
+procedure TDocVariantData.SortArrayByFields(
+  const aItemPropNames: array of RawUtf8; aValueCompare: TVariantCompare;
+  const aValueCompareField: TVariantCompareField;
+  aValueCompareReverse: boolean; aNameSortedCompare: TUtf8Compare);
+var
+  QS: TQuickSortDocVariantValuesByField;
+begin
+  if (VCount <= 0) or
+     not IsArray then
+    exit;
+  if Assigned(aValueCompareField) then
+  begin
+    QS.Compare := nil;
+    QS.Fields := @aItemPropNames[0];
+    QS.CompareField := aValueCompareField;
+  end
+  else if Assigned(aValueCompare) then
+      QS.Compare := aValueCompare
+    else
+      QS.Compare := VariantCompare;
+  QS.Doc := @self;
+  QS.Init(aItemPropNames, aNameSortedCompare);
+  QS.Reverse := aValueCompareReverse;
+  QS.Sort(0, VCount - 1);
+end;
+
+procedure TDocVariantData.Reverse;
+begin
+  if VCount <= 0 then
+    exit;
+  if VName <> nil then
+  begin
+    DynArrayFakeLength(VName, VCount);
+    DynArray(TypeInfo(TRawUtf8DynArray), VName).Reverse;
+  end;
+  DynArrayFakeLength(VValue, VCount);
+  DynArray(TypeInfo(TVariantDynArray), VValue).Reverse;
+end;
+
+function TDocVariantData.Reduce(const aPropNames: array of RawUtf8;
+  aCaseSensitive, aDoNotAddVoidProp: boolean): variant;
+begin
+  VarClear(result{%H-});
+  Reduce(aPropNames, aCaseSensitive, PDocVariantData(@result)^, aDoNotAddVoidProp);
+end;
+
+procedure TDocVariantData.Reduce(const aPropNames: array of RawUtf8;
+  aCaseSensitive: boolean; var result: TDocVariantData; aDoNotAddVoidProp: boolean);
+var
+  ndx, j: PtrInt;
+  reduced: TDocVariantData;
+begin
+  result.Init(VOptions); // same options than the main document
+  if (VCount = 0) or
+     (high(aPropNames) < 0) then
+    exit;
+  if IsObject then
+    for j := 0 to high(aPropNames) do
+    begin
+      if aPropNames[j] = '' then
+        continue; // avoid GPF in FindNonVoid()
+      ndx := FindNonVoid[aCaseSensitive](
+        pointer(VName), pointer(aPropNames[j]), length(aPropNames[j]), VCount);
+      if ndx >= 0 then
+        if not aDoNotAddVoidProp or
+           not VarIsVoid(VValue[ndx]) then
+          result.AddValue(VName[ndx], VValue[ndx]);
+    end
+  else if IsArray then
+    for ndx := 0 to VCount - 1 do
+    begin
+      _Safe(VValue[ndx])^.Reduce(
+        aPropNames, aCaseSensitive, reduced, aDoNotAddVoidProp);
+      if not reduced.IsObject then
+        continue;
+      result.AddItem(variant(reduced));
+      reduced.Clear;
+    end;
+end;
+
+procedure TDocVariantData.ReduceFilter(const aKey: RawUtf8;
+  const aValue: variant; aMatch: TCompareOperator; aCompare: TVariantCompare;
+  aLimit: integer; var result: TDocVariantData);
+var
+  n, prev: integer;
+  v, obj: PVariant;
+  haspath: boolean;
+  dv: PDocVariantData;
+begin
+  result.Init(VOptions, dvArray); // same options than the main document
+  n := VCount;
+  if (n = 0) or
+     (aKey = '') or
+     not IsArray then
+    exit;
+  if not Assigned(aCompare) then
+    aCompare := @VariantCompare;
+  prev := -1; // optimistic search aPropName at the previous field position
+  haspath := PosExChar('.', aKey) <> 0;
+  v := pointer(VValue);
+  repeat
+    dv := _Safe(v^);
+    if haspath then
+      obj := dv^.GetPVariantByPath(aKey, '.')
+    else
+      dv^.GetObjectProp(aKey, obj, @prev);
+    if (obj <> nil) and
+       SortMatch(aCompare({%H-}obj^, aValue), aMatch) then
+    begin
+      if result.VCount = 0 then
+        SetLength(result.VValue, n); // prepare for maximum capacity
+      result.AddItem(PVariant(dv)^);
+    end;
+    dec(aLimit);
+    if aLimit = 0 then
+      exit;
+    inc(v);
+    dec(n);
+  until n = 0;
+end;
+
+procedure TDocVariantData.ReduceFilter(const aExpression: RawUtf8;
+  var result: TDocVariantData; aLimit: integer; aCompare: TVariantCompare);
+var
+  k: RawUtf8;
+  v: variant;
+  m: TCompareOperator;
+begin
+  ParseSortMatch(pointer(aExpression), k, m, @v);
+  ReduceFilter(k, v, m, aCompare, aLimit, result);
+end;
+
+procedure ToSingle(result: PRttiVarData);
+var
+  tmp: TDocVariantData;
+begin
+  PRttiVarData(@tmp)^ := result^; // main dvArray to be finalized at exit
+  result^.VType := varEmpty;
+  if tmp.VCount <> 0 then
+    PVariant(result)^ := tmp.VValue[0]; // return the first (and unique) item
+end;
+
+function TDocVariantData.ReduceFilter(const aExpression: RawUtf8;
+  aLimit: integer): variant;
+begin
+  VarClear(result{%H-});
+  ReduceFilter(aExpression, PDocVariantData(@result)^, aLimit);
+  if aLimit = 1 then
+    ToSingle(@result);
+end;
+
+procedure TDocVariantData.ReduceFilter(const aExpression: RawUtf8;
+  const aValue: variant; var result: TDocVariantData;
+  aCompare: TVariantCompare; aLimit: integer);
+var
+  k: RawUtf8;
+  m: TCompareOperator;
+begin
+  ParseSortMatch(pointer(aExpression), k, m, nil);
+  ReduceFilter(k, aValue, m, aCompare, aLimit, result);
+end;
+
+function TDocVariantData.ReduceFilter(const aExpression: RawUtf8;
+  const aValue: variant; aLimit: integer): variant;
+begin
+  VarClear(result{%H-});
+  ReduceFilter(aExpression, aValue, PDocVariantData(@result)^);
+  if aLimit = 1 then
+    ToSingle(@result);
+end;
+
+function TDocVariantData.ReduceAsArray(const aPropName: RawUtf8;
+  const OnReduce: TOnReducePerItem): variant;
+begin
+  VarClear(result{%H-});
+  ReduceAsArray(aPropName, PDocVariantData(@result)^, OnReduce);
+end;
+
+procedure TDocVariantData.ReduceAsArray(const aPropName: RawUtf8;
+  var result: TDocVariantData; const OnReduce: TOnReducePerItem);
+var
+  ndx: PtrInt;
+  prev: integer;
+  item: PDocVariantData;
+  v: PVariant;
+begin
+  result.Init(VOptions, dvArray); // same options than the main document
+  if (VCount = 0) or
+     (aPropName = '') or
+     not IsArray then
+    exit;
+  prev := -1; // optimistic search aPropName at the previous field position
+  for ndx := 0 to VCount - 1 do
+    if _Safe(VValue[ndx], item) and
+       {%H-}item^.GetObjectProp(aPropName, v, @prev) then
+      if (not Assigned(OnReduce)) or
+         OnReduce(item) then
+        result.AddItem(v^);
+end;
+
+function TDocVariantData.ReduceAsArray(const aPropName: RawUtf8;
+  const OnReduce: TOnReducePerValue): variant;
+begin
+  VarClear(result{%H-});
+  ReduceAsArray(aPropName, PDocVariantData(@result)^, OnReduce);
+end;
+
+procedure TDocVariantData.ReduceAsArray(const aPropName: RawUtf8;
+  var result: TDocVariantData; const OnReduce: TOnReducePerValue);
+var
+  ndx: PtrInt;
+  prev: integer;
+  v: PVariant;
+begin
+  result.Init(VOptions, dvArray); // same options than the main document
+  if (VCount = 0) or
+     (aPropName = '') or
+     not IsArray then
+    exit;
+  prev := -1; // optimistic search aPropName at the previous field position
+  for ndx := 0 to VCount - 1 do
+    if _Safe(VValue[ndx])^.GetObjectProp(aPropName, v, @prev) then
+      if (not Assigned(OnReduce)) or
+         OnReduce(v^) then
+        result.AddItem(v^);
+end;
+
+function NotIn(a, v: PVarData; n: integer; caseins: boolean): boolean;
+begin
+  result := false;
+  if n <> 0 then
+    repeat
+      if FastVarDataComp(a, v, caseins) = 0 then
+        exit;
+      inc(a);
+      dec(n);
+    until n = 0;
+  result := true;
+end;
+
+function TDocVariantData.ReduceAsVariantArray(const aPropName: RawUtf8;
+  aDuplicates: TSearchDuplicate): TVariantDynArray;
+var
+  n, ndx: PtrInt;
+  prev: integer;
+  v: PVariant;
+begin
+  result := nil;
+  if (VCount = 0) or
+     (aPropName = '') or
+     not IsArray then
+    exit;
+  prev := -1; // optimistic search aPropName at the previous field position
+  n := 0;
+  for ndx := 0 to VCount - 1 do
+    if _Safe(VValue[ndx])^.GetObjectProp(aPropName, v, @prev) then
+      if (aDuplicates = sdNone) or
+         NotIn(pointer(result), pointer(v), n, aDuplicates = sdCaseInsensitive) then
+      begin
+        if length(result) = n then
+          SetLength(result, NextGrow(n));
+        SetVariantByValue(PVariant(v)^, result[n]);
+        inc(n);
+      end;
+  if n <> 0 then
+    DynArrayFakeLength(result, n);
+end;
+
+function TDocVariantData.Rename(
+  const aFromPropName, aToPropName: TRawUtf8DynArray): integer;
+var
+  n, prop, ndx: PtrInt;
+begin
+  result := 0;
+  n := length(aFromPropName);
+  if length(aToPropName) = n then
+    for prop := 0 to n - 1 do
+    begin
+      ndx := GetValueIndex(aFromPropName[prop]);
+      if ndx >= 0 then
+      begin
+        VName[ndx] := aToPropName[prop];
+        inc(result);
+      end;
+    end;
+end;
+
+function TDocVariantData.GetNames: TRawUtf8DynArray;
+begin
+  if IsObject and
+     (VCount > 0) then
+  begin
+    DynArrayFakeLength(VName, VCount);
+    DynArrayFakeLength(VValue, VCount);
+    result := VName; // truncate with no memory (re)allocation
+  end
+  else
+    result := nil;
+end;
+
+function TDocVariantData.FlattenAsNestedObject(
+  const aObjectPropName: RawUtf8): boolean;
+var
+  ndx, len: PtrInt;
+  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 IsObject) then
+    exit;
+  PWord(UpperCopy255(Up{%H-}, 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;
+  ClearFast;
+  InitObject([aObjectPropName, variant(nested)]);
+  result := true;
+end;
+
+function TDocVariantData.Delete(Index: PtrInt): boolean;
+var
+  n: PtrInt;
+  v: PVariantArray;
+  k: PRawUtf8Array;
+begin
+  result := cardinal(Index) < cardinal(VCount);
+  if not result then
+    exit;
+  dec(VCount);
+  if VCount = 0 then
+  begin
+    Void; // reset all in-memory storage and capacity
+    exit;
+  end;
+  k := pointer(VName);
+  if k <> nil then
+  begin
+    EnsureUnique(VName);
+    k := @VName[Index];
+    FastAssignNew(k[0]);
+  end;
+  EnsureUnique(VValue);
+  v := @VValue[Index];
+  VarClear(v[0]);
+  n := VCount - Index;
+  if n = 0 then
+    exit;
+  if k <> nil then
+  begin
+    MoveFast(k[1], k[0], n * SizeOf(pointer));
+    pointer(k[n]) := nil; // avoid GPF
+  end;
+  MoveFast(v[1], v[0], n * SizeOf(variant));
+  TRttiVarData(v[n]).VType := varEmpty; // avoid GPF
+end;
+
+function TDocVariantData.Extract(aIndex: integer; var aValue: variant;
+  aName: PRawUtf8): boolean;
+var
+  v: pointer;
+begin
+  result := false;
+  if aIndex < 0 then
+    inc(aIndex, VCount);
+  if cardinal(aIndex) >= cardinal(VCount) then
+    exit;
+  EnsureUnique(VValue);
+  VarClear(aValue);
+  v := @VValue[aIndex];
+  PRttiVarData(@aValue)^ := PRttiVarData(v)^; // no refcount
+  PRttiVarData(v)^.VType := varEmpty;         // no VarClear(v^)
+  if aName <> nil then
+    if VName = nil then
+      FastAssignNew(aName^)
+    else
+    begin
+      EnsureUnique(VName);
+      v := @VName[aIndex];
+      FastAssignNew(aName^, PPointer(v)^); // no refcount
+      PPointer(v)^ := nil;
+    end;
+  result := Delete(aIndex);
+end;
+
+function TDocVariantData.Delete(const aName: RawUtf8; aValue: PVariant): boolean;
+var
+  ndx: PtrInt;
+begin
+  result := false;
+  ndx := GetValueIndex(aName);
+  if ndx >= 0 then
+    if aValue <> nil then
+      result := Extract(ndx, aValue^)
+    else
+      result := Delete(ndx);
+end;
+
+function TDocVariantData.Delete(const aNames: array of RawUtf8): integer;
+var
+  n: PtrInt;
+begin
+  result := 0;
+  for n := 0 to high(aNames) do
+    inc(result, ord(Delete(aNames[n])));
+end;
+
+function TDocVariantData.InternalNextPath(
+  var aCsv: PUtf8Char; aName: PShortString; aPathDelim: AnsiChar): PtrInt;
+begin
+  GetNextItemShortString(aCsv, aName, aPathDelim);
+  if (VCount <> 0) and
+     (aName^[0] <> #0) then
+    if VName <> nil then
+    begin
+      result := FindNonVoid[IsCaseSensitive](
+        pointer(VName), @aName^[1], ord(aName^[0]), VCount);
+      exit;
+    end
+    else
+    begin
+      result := GetCardinalDef(@aName^[1], PtrUInt(-1));
+      if PtrUInt(result) < PtrUInt(VCount) then // array index integer as text
+        exit;
+    end;
+  result := -1;
+end;
+
+procedure TDocVariantData.InternalNotFound(var Dest: variant; aName: PUtf8Char);
+begin
+  if Has(dvoReturnNullForUnknownProperty) then
+    SetVariantNull(Dest)
+  else
+    raise EDocVariant.CreateUtf8('[%] property not found', [aName])
+end;
+
+procedure TDocVariantData.InternalNotFound(var Dest: variant; aIndex: integer);
+begin
+  if Has(dvoReturnNullForUnknownProperty) then
+    SetVariantNull(Dest)
+  else
+    raise EDocVariant.CreateUtf8('Out of range [%] (count=%)', [aIndex, VCount]);
+end;
+
+function TDocVariantData.InternalNotFound(aName: PUtf8Char): PVariant;
+begin
+  if Has(dvoReturnNullForUnknownProperty) then
+    result := @DocVariantDataFake
+  else
+    raise EDocVariant.CreateUtf8('[%] property not found', [aName])
+end;
+
+function TDocVariantData.InternalNotFound(aIndex: integer): PDocVariantData;
+begin
+  if Has(dvoReturnNullForUnknownProperty) then
+    result := @DocVariantDataFake
+  else
+    raise EDocVariant.CreateUtf8('Out of range [%] (count=%)', [aIndex, VCount]);
+end;
+
+function TDocVariantData.DeleteByPath(const aPath: RawUtf8;
+  aPathDelim: AnsiChar; aDeletedValue: PVariant): boolean;
+var
+  csv: PUtf8Char;
+  dv: PDocVariantData;
+  ndx: PtrInt;
+  n: ShortString;
+begin
+  result := false;
+  if IsArray then
+    exit;
+  csv := pointer(aPath);
+  dv := @self;
+  repeat
+    ndx := dv^.InternalNextPath(csv, @n, aPathDelim);
+    if csv = nil then
+    begin
+      // we reached the last item of the path, which is to be deleted
+      if aDeletedValue <> nil then
+        aDeletedValue^ := dv^.VValue[ndx];
+      result := dv^.Delete(ndx);
+      exit;
+    end;
+  until (ndx < 0) or
+       not _SafeObject(dv^.VValue[ndx], dv);
+end;
+
+function TDocVariantData.DeleteByProp(const aPropName, aPropValue: RawUtf8;
+  aPropValueCaseSensitive: boolean): boolean;
+begin
+  result := Delete(SearchItemByProp(aPropName, aPropValue, aPropValueCaseSensitive));
+end;
+
+function TDocVariantData.DeleteByValue(const aValue: Variant;
+  CaseInsensitive: boolean): integer;
+var
+  ndx: PtrInt;
+begin
+  result := 0;
+  if VarIsEmptyOrNull(aValue) then
+  begin
+    for ndx := VCount - 1 downto 0 do
+      if VarDataIsEmptyOrNull(@VValue[ndx]) then
+      begin
+        Delete(ndx);
+        inc(result);
+      end;
+  end
+  else
+    for ndx := VCount - 1 downto 0 do
+      if FastVarDataComp(@VValue[ndx], @aValue, CaseInsensitive) = 0 then
+      begin
+        Delete(ndx);
+        inc(result);
+      end;
+end;
+
+function TDocVariantData.DeleteByStartName(
+  aStartName: PUtf8Char; aStartNameLen: integer): integer;
+var
+  ndx: PtrInt;
+  upname: array[byte] of AnsiChar;
+begin
+  result := 0;
+  if aStartNameLen = 0 then
+    aStartNameLen := StrLen(aStartName);
+  if (VCount = 0) or
+     (not IsObject) or
+     (aStartNameLen = 0) then
+    exit;
+  UpperCopy255Buf(upname{%H-}, 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.IsVoid: boolean;
+begin
+  result := (cardinal(VType) <> DocVariantVType) or
+            (VCount = 0);
+end;
+
+function TDocVariantData.Exists(const aName: RawUtf8): boolean;
+begin
+  result := GetValueIndex(Pointer(aName), Length(aName), IsCaseSensitive) >= 0;
+end;
+
+function TDocVariantData.GetValueIndex(aName: PUtf8Char; aNameLen: PtrInt;
+  aCaseSensitive: boolean): integer;
+var
+  err: integer;
+begin
+  if (cardinal(VType) = DocVariantVType) and
+     (aNameLen > 0) and
+     (aName <> nil) and
+     (VCount > 0) then
+    if IsArray then
+    begin
+      // try index integer as text, for lookup in array document
+      result := GetInteger(aName, err);
+      if (err <> 0) or
+         (cardinal(result) >= cardinal(VCount)) then
+        result := -1;
+    end
+    else
+      // O(n) lookup for name -> efficient brute force sub-functions
+      result := FindNonVoid[IsCaseSensitive](
+        pointer(VName), aName, aNameLen, VCount)
+  else
+    result := -1;
+end;
+
+function TDocVariantData.GetValueOrRaiseException(
+  const aName: RawUtf8): variant;
+begin
+  RetrieveValueOrRaiseException(
+    pointer(aName), length(aName), IsCaseSensitive, result, false);
+end;
+
+function TDocVariantData.GetValueOrDefault(const aName: RawUtf8;
+  const aDefault: variant): variant;
+var
+  v: PVariant;
+begin
+  if (cardinal(VType) <> DocVariantVType) or
+     not GetObjectProp(aName, v{%H-}, nil) then
+    result := aDefault
+  else
+    SetVariantByValue(v^, result);
+end;
+
+function TDocVariantData.GetValueOrNull(const aName: RawUtf8): variant;
+var
+  v: PVariant;
+begin
+  if (cardinal(VType) <> DocVariantVType) or
+     not GetObjectProp(aName, v{%H-}, nil) then
+    SetVariantNull(result{%H-})
+  else
+    SetVariantByValue(v^, result);
+end;
+
+function TDocVariantData.GetValueOrEmpty(const aName: RawUtf8): variant;
+var
+  v: PVariant;
+begin
+  if (cardinal(VType) <> DocVariantVType) or
+     not GetObjectProp(aName, v{%H-}, nil) then
+   VarClear(result{%H-})
+  else
+    SetVariantByValue(v^, result);
+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 cardinal(found^.VType) > varNull then
+      // avoid default VariantToUtf8(null)='null'
+      VariantToUtf8(PVariant(found)^, aValue, wasString);
+    result := true;
+  end;
+end;
+
+function TDocVariantData.GetValueEnumerate(const aName: RawUtf8;
+  aTypeInfo: PRttiInfo; out aValue; aDeleteFoundEntry: boolean): boolean;
+var
+  text: RawUtf8;
+  ndx, ord: integer;
+begin
+  result := false;
+  ndx := GetValueIndex(aName);
+  if (ndx < 0) or
+     not VariantToText(Values[ndx], text) then
+    exit;
+  ord := GetEnumNameValue(aTypeInfo, text, true);
+  if ord < 0 then
+    exit;
+  byte(aValue) := ord;
+  if aDeleteFoundEntry then
+    Delete(ndx);
+  result := true;
+end;
+
+function TDocVariantData.GetAsDocVariant(const aName: RawUtf8;
+  out aValue: PDocVariantData; aSortedCompare: TUtf8Compare): boolean;
+var
+  found: PVarData;
+begin
+  found := GetVarData(aName, aSortedCompare);
+  result := (found <> nil) and
+            _Safe(PVariant(found)^, aValue);
+end;
+
+function TDocVariantData.GetAsArray(const aName: RawUtf8;
+  out aArray: PDocVariantData; aSortedCompare: TUtf8Compare): boolean;
+begin
+  result := GetAsDocVariant(aName, aArray, aSortedCompare) and
+            aArray^.IsArray and
+            (aArray^.Count > 0);
+end;
+
+function TDocVariantData.GetAsObject(const aName: RawUtf8;
+  out aObject: PDocVariantData; aSortedCompare: TUtf8Compare): boolean;
+begin
+  result := GetAsDocVariant(aName, aObject, aSortedCompare) and
+            aObject^.IsObject and
+            (aObject^.Count > 0);
+end;
+
+function TDocVariantData.GetAsDocVariantSafe(const aName: RawUtf8;
+  aSortedCompare: TUtf8Compare): PDocVariantData;
+var
+  found: PVarData;
+begin
+  found := GetVarData(aName, aSortedCompare);
+  if found = nil then
+    result := @DocVariantDataFake
+  else
+    result := _Safe(PVariant(found)^);
+end;
+
+function TDocVariantData.GetAsPVariant(const aName: RawUtf8;
+  out aValue: PVariant; aSortedCompare: TUtf8Compare): boolean;
+begin
+  aValue := pointer(GetVarData(aName, aSortedCompare));
+  result := aValue <> nil;
+end;
+
+function TDocVariantData.GetAsPVariant(
+  aName: PUtf8Char; aNameLen: PtrInt): PVariant;
+var
+  ndx: PtrInt;
+begin
+  ndx := GetValueIndex(aName, aNameLen, IsCaseSensitive);
+  if ndx >= 0 then
+    result := @VValue[ndx]
+  else
+    result := nil;
+end;
+
+function TDocVariantData.GetVarData(const aName: RawUtf8;
+  aSortedCompare: TUtf8Compare; aFoundIndex: PInteger): PVarData;
+var
+  ndx: PtrInt;
+begin
+  if (cardinal(VType) <> DocVariantVType) or
+     (not IsObject) or
+     (VCount = 0) or
+     (aName = '') then
+  begin
+    result := nil;
+    if aFoundIndex <> nil then
+      aFoundIndex^ := -1;
+  end
+  else
+  begin
+    if Assigned(aSortedCompare) then
+      if @aSortedCompare = @StrComp then
+        // use dedicated (branchless x86_64 asm) function for StrComp()
+        ndx := FastFindPUtf8CharSorted(pointer(VName), VCount - 1, pointer(aName))
+      else
+        ndx := FastFindPUtf8CharSorted(
+          pointer(VName), VCount - 1, pointer(aName), aSortedCompare)
+    else
+      ndx := FindNonVoid[IsCaseSensitive](
+        pointer(VName), pointer(aName), length(aName), VCount);
+    if aFoundIndex <> nil then
+      aFoundIndex^ := ndx;
+    if ndx >= 0 then
+      result := @VValue[ndx]
+    else
+      result := nil;
+  end;
+end;
+
+function TDocVariantData.GetVarData(const aName: RawUtf8; var aValue: TVarData;
+  aSortedCompare: TUtf8Compare): boolean;
+var
+  found: PVarData;
+begin
+  found := GetVarData(aName, aSortedCompare);
+  if found = nil then
+    result := false
+  else
+  begin
+    aValue := found^;
+    result := true;
+  end;
+end;
+
+function TDocVariantData.GetValueByPath(
+  const aPath: RawUtf8; aPathDelim: AnsiChar): variant;
+var
+  Dest: TVarData;
+begin
+  VarClear(result{%H-});
+  if (cardinal(VType) <> DocVariantVType) or
+     (VCount = 0) then
+    exit;
+  DocVariantType.Lookup(Dest, TVarData(self), pointer(aPath), aPathDelim);
+  if cardinal(Dest.VType) >= varNull then
+    result := variant(Dest); // copy
+end;
+
+function TDocVariantData.GetValueByPath(const aPath: RawUtf8;
+  out aValue: variant; aPathDelim: AnsiChar): boolean;
+var
+  Dest: TVarData;
+begin
+  result := false;
+  if (cardinal(VType) <> DocVariantVType) or
+     (VCount = 0) then
+    exit;
+  DocVariantType.Lookup(Dest, TVarData(self), pointer(aPath), aPathDelim);
+  if Dest.VType = varEmpty then
+    exit;
+  aValue := variant(Dest); // copy
+  result := true;
+end;
+
+function TDocVariantData.GetPVariantByPath(
+  const aPath: RawUtf8; aPathDelim: AnsiChar): PVariant;
+var
+  ndx: PtrInt;
+  vt: cardinal;
+  csv: PUtf8Char;
+  n: ShortString;
+begin
+  result := @self;
+  csv := pointer(aPath);
+  if aPath <> '' then
+    repeat
+      repeat
+        vt := PVarData(result)^.VType; // inlined dv := _Safe(result^)
+        if vt <> varVariantByRef then
+          break;
+        result := PVarData(result)^.VPointer;
+      until false;
+      if vt <> DocVariantVType then
+        break;
+      ndx := PDocVariantData(result)^.InternalNextPath(csv, @n, aPathDelim);
+      if ndx < 0 then
+        break;
+      result := @PDocVariantData(result)^.VValue[ndx];
+      if csv = nil then
+        exit; // exhausted all path, so result is the found item
+    until false;
+  result := nil;
+end;
+
+function TDocVariantData.GetPVariantExistingByPath(const aPath: RawUtf8;
+  aPathDelim: AnsiChar): PVariant;
+begin
+  result := GetPVariantByPath(aPath, aPathDelim);
+  if result = nil then
+    result := InternalNotFound(pointer(aPath));
+end;
+
+function TDocVariantData.GetVariantByPath(const aNameOrPath: RawUtf8): Variant;
+var
+  v: PVariant;
+begin
+  v := GetPVariantByPath(aNameOrPath, '.');
+  if v <> nil then
+    SetVariantByValue(v^, result)
+  else
+    InternalNotFound(result, pointer(aNameOrPath));
+end;
+
+function TDocVariantData.GetDocVariantByPath(const aPath: RawUtf8;
+  out aValue: PDocVariantData; aPathDelim: AnsiChar): boolean;
+var
+  v: PVariant;
+begin
+  v := GetPVariantByPath(aPath, aPathDelim);
+  result := (v <> nil) and
+            _Safe(v^, aValue);
+end;
+
+function TDocVariantData.GetValueByPath(
+  const aDocVariantPath: array of RawUtf8): variant;
+var
+  found, res: PVarData;
+  vt: cardinal;
+  ndx: integer;
+begin
+  VarClear(result{%H-});
+  if (cardinal(VType) <> DocVariantVType) or
+     (not IsObject) or
+     (high(aDocVariantPath) < 0) then
+    exit;
+  found := @self;
+  ndx := 0;
+  repeat
+    found := PDocVariantData(found).GetVarData(aDocVariantPath[ndx]);
+    if found = nil then
+      exit;
+    if ndx = high(aDocVariantPath) then
+      break; // we found the item!
+    inc(ndx);
+    // if we reached here, we should try for the next scope within Dest
+    repeat
+      vt := found^.VType;
+      if vt <> varVariantByRef then
+        break;
+      found := found^.VPointer;
+    until false;
+    if vt = VType then
+      continue;
+    exit;
+  until false;
+  res := found;
+  while cardinal(res^.VType) = varVariantByRef do
+    res := res^.VPointer;
+  if (cardinal(res^.VType) = VType) and
+     (PDocVariantData(res)^.VCount = 0) then
+    // return void TDocVariant as null
+    TRttiVarData(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 IsArray 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: PtrInt;
+begin
+  result := false;
+  if not IsArray then
+    exit;
+  ndx := SearchItemByProp(aPropName, aPropValue, aPropValueCaseSensitive);
+  if ndx >= 0 then
+    result := _Safe(VValue[ndx], Dest);
+end;
+
+function TDocVariantData.GetJsonByStartName(const aStartName: RawUtf8): RawUtf8;
+var
+  Up: array[byte] of AnsiChar;
+  temp: TTextWriterStackBuffer;
+  n: integer;
+  nam: PPUtf8Char;
+  val: PVariant;
+  W: TJsonWriter;
+begin
+  if (not IsObject) or
+     (VCount = 0) then
+  begin
+    result := NULL_STR_VAR;
+    exit;
+  end;
+  UpperCopy255(Up, aStartName)^ := #0;
+  W := TJsonWriter.CreateOwnedStream(temp);
+  try
+    W.Add('{');
+    n := VCount;
+    nam := pointer(VName);
+    val := pointer(VValue);
+    repeat
+      if IdemPChar(nam^, Up) then
+      begin
+        if Has(dvoSerializeAsExtendedJson) and
+           JsonPropNameValid(nam^) then
+          W.AddShort(nam^, PStrLen(nam^ - _STRLEN)^)
+        else
+        begin
+          W.AddDirect('"');
+          W.AddJsonEscape(nam^);
+          W.AddDirect('"');
+        end;
+        W.AddDirect(':');
+        W.AddVariant(val^, twJsonEscape);
+        W.AddComma;
+      end;
+      dec(n);
+      if n = 0 then
+        break;
+      inc(nam);
+      inc(val);
+    until false;
+    W.CancelLastComma('}');
+    W.SetText(result);
+  finally
+    W.Free;
+  end;
+end;
+
+function TDocVariantData.GetValuesByStartName(const aStartName: RawUtf8;
+  TrimLeftStartName: boolean): variant;
+var
+  Up: array[byte] of AnsiChar;
+  ndx: PtrInt;
+  name: RawUtf8;
+begin
+  if aStartName = '' then
+  begin
+    result := Variant(self);
+    exit;
+  end;
+  if (not IsObject) or
+     (VCount = 0) then
+  begin
+    SetVariantNull(result{%H-});
+    exit;
+  end;
+  TDocVariant.NewFast(result);
+  UpperCopy255(Up{%H-}, 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;
+
+function TDocVariantData.SetValueByPath(const aPath: RawUtf8;
+  const aValue: variant; aCreateIfNotExisting: boolean; aPathDelim: AnsiChar): boolean;
+var
+  csv: PUtf8Char;
+  v: PDocVariantData;
+  ndx: PtrInt;
+  n: ShortString;
+begin
+  result := false;
+  if IsArray then
+    exit;
+  csv := pointer(aPath);
+  v := @self;
+  repeat
+    ndx := v^.InternalNextPath(csv, @n, aPathDelim);
+    if csv = nil then
+      break; // we reached the last item of the path, which is the value to set
+    if ndx < 0 then
+      if aCreateIfNotExisting then
+      begin
+        ndx := v^.InternalAddBuf(@n[1], ord(n[0])); // in two steps for FPC
+        v := @v^.VValue[ndx];
+        v^.InitClone(self); // same Options than root but with no Kind
+      end
+      else
+        exit
+    else if not _SafeObject(v^.VValue[ndx], v) then
+      exit; // incorrect path
+  until false;
+  if ndx < 0 then
+    ndx := v^.InternalAddBuf(@n[1], ord(n[0]));
+  v^.InternalSetValue(ndx, aValue);
+  result := true;
+end;
+
+procedure TDocVariantData.RetrieveNameOrRaiseException(
+  Index: integer; var Dest: RawUtf8);
+begin
+  if (cardinal(Index) >= cardinal(VCount)) or
+     (VName = nil) then
+    if Has(dvoReturnNullForUnknownProperty) 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
+    InternalNotFound(Dest, Index)
+  else if DestByRef then
+    SetVariantByRef(VValue[Index], Dest)
+  else
+  begin
+    Source := @VValue[Index];
+    while PVarData(Source)^.VType = varVariantByRef do
+      Source := PVarData(Source)^.VPointer;
+    Dest := Source^;
+  end;
+end;
+
+function TDocVariantData.RetrieveValueOrRaiseException(
+  aName: PUtf8Char; aNameLen: integer; aCaseSensitive: boolean;
+  var Dest: variant; DestByRef: boolean): boolean;
+var
+  ndx: integer;
+begin
+  ndx := GetValueIndex(aName, aNameLen, aCaseSensitive);
+  if ndx < 0 then
+    InternalNotFound(Dest, aName)
+  else
+    RetrieveValueOrRaiseException(ndx, Dest, DestByRef);
+  result := ndx >= 0;
+end;
+
+function TDocVariantData.GetValueOrItem(const aNameOrIndex: variant): variant;
+var
+  wasString: boolean;
+  Name: RawUtf8;
+begin
+  if IsArray then
+    // fast index lookup e.g. for Value[1]
+    RetrieveValueOrRaiseException(
+      VariantToIntegerDef(aNameOrIndex, -1), result, true)
+  else
+  begin
+    // by name lookup e.g. for Value['abc']
+    VariantToUtf8(aNameOrIndex, Name, wasString);
+    if wasString then
+      RetrieveValueOrRaiseException(
+        pointer(Name), length(Name), IsCaseSensitive, 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 IsArray then
+    // fast index lookup e.g. for Value[1]
+    SetValueOrRaiseException(VariantToIntegerDef(aNameOrIndex, -1), aValue)
+  else
+  begin
+    // by name lookup e.g. for Value['abc']
+    VariantToUtf8(aNameOrIndex, Name, wasString);
+    if wasString then
+    begin
+      ndx := GetValueIndex(Name);
+      if ndx < 0 then
+        ndx := InternalAdd(Name);
+      InternalSetValue(ndx, aValue);
+    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 IsArray 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;
+  InternalSetValue(result, aValue);
+end;
+
+function TDocVariantData.ToJson: RawUtf8;
+begin // note: FPC has troubles inlining this, but it is a slow method anyway
+  DocVariantType.ToJson(@self, result, '', '', jsonCompact);
+end;
+
+function TDocVariantData.ToJson(const Prefix, Suffix: RawUtf8;
+  Format: TTextWriterJsonFormat): RawUtf8;
+begin
+  DocVariantType.ToJson(@self, result, Prefix, Suffix, Format);
+end;
+
+procedure TDocVariantData.SaveToJsonFile(const FileName: TFileName);
+var
+  F: TStream;
+  W: TJsonWriter;
+begin
+  if cardinal(VType) <> DocVariantVType then
+    exit;
+  F := TFileStreamEx.Create(FileName, fmCreate);
+  try
+    W := TJsonWriter.Create(F, 65536);
+    try
+      DocVariantType.ToJson(W, @self);
+      W.FlushFinal;
+    finally
+      W.Free;
+    end;
+  finally
+    F.Free;
+  end;
+end;
+
+function TDocVariantData.ToNonExpandedJson: RawUtf8;
+var
+  field: TRawUtf8DynArray;
+  fieldCount, r, f: PtrInt;
+  W: TJsonWriter;
+  row: PDocVariantData;
+  temp: TTextWriterStackBuffer;
+begin
+  if not IsArray then
+  begin
+    result := '';
+    exit;
+  end;
+  if VCount = 0 then
+  begin
+    result := '[]';
+    exit;
+  end;
+  fieldCount := 0;
+  with _Safe(VValue[0])^ do
+    if IsObject then
+    begin
+      field := VName;
+      fieldCount := VCount;
+    end;
+  if fieldCount = 0 then
+    raise EDocVariant.Create('ToNonExpandedJson: Value[0] is not an object');
+  W := TJsonWriter.CreateOwnedStream(temp);
+  try
+    W.Add('{"fieldCount":%,"rowCount":%,"values":[', [fieldCount, VCount]);
+    for f := 0 to fieldCount - 1 do
+    begin
+      W.Add('"');
+      W.AddJsonEscape(pointer(field[f]));
+      W.Add('"', ',');
+    end;
+    for r := 0 to VCount - 1 do
+    begin
+      row := _Safe(VValue[r]);
+      if (r > 0) and
+         ((not row^.IsObject) or
+          (row^.VCount <> fieldCount)) then
+        raise EDocVariant.CreateUtf8(
+          'ToNonExpandedJson: Value[%] not expected object', [r]);
+      for f := 0 to fieldCount - 1 do
+        if (r > 0) and
+           not PropNameEquals(row^.VName[f], field[f]) then
+          raise EDocVariant.CreateUtf8(
+            'ToNonExpandedJson: Value[%] field=% expected=%',
+            [r, row^.VName[f], field[f]])
+        else
+        begin
+          W.AddVariant(row^.VValue[f], twJsonEscape);
+          W.AddComma;
+        end;
+    end;
+    W.CancelLastComma;
+    W.AddDirect(']', '}');
+    W.SetText(result);
+  finally
+    W.Free;
+  end;
+end;
+
+procedure TDocVariantData.ToRawUtf8DynArray(out Result: TRawUtf8DynArray);
+var
+  ndx: PtrInt;
+  wasString: boolean;
+begin
+  if IsObject then
+    raise EDocVariant.Create('ToRawUtf8DynArray expects a dvArray');
+  if IsArray 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: PtrInt;
+  temp: TTextWriterStackBuffer;
+begin
+  if IsArray then
+    raise EDocVariant.Create('ToTextPairs expects a dvObject');
+  if (VCount > 0) and
+     IsObject then
+    with TJsonWriter.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);
+begin
+  if IsObject then
+    raise EDocVariant.Create('ToArrayOfConst expects a dvArray');
+  if IsArray then
+    VariantsToArrayOfConst(VValue, VCount, Result);
+end;
+
+function TDocVariantData.ToArrayOfConst: TTVarRecDynArray;
+begin
+  ToArrayOfConst(result);
+end;
+
+function TDocVariantData.ToUrlEncode(const UriRoot: RawUtf8): RawUtf8;
+var
+  json: RawUtf8; // temporary in-place modified buffer
+begin
+  DocVariantType.ToJson(@self, 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: PtrInt;
+begin
+  ndx := GetOrAddIndexByName(aName); // in two steps for FPC
+  result := @VValue[ndx];
+end;
+
+function TDocVariantData.GetPVariantByName(const aName: RawUtf8): PVariant;
+var
+  ndx: PtrInt;
+begin
+  ndx := GetValueIndex(aName);
+  if ndx < 0 then
+    result := InternalNotFound(pointer(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
+  StringToVariant(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^.GetKind = aNotMatchingKind then
+    result := @DocVariantDataFake;
+end;
+
+function TDocVariantData.GetDocVariantOrAddByName(const aName: RawUtf8;
+  aKind: TDocVariantKind): PDocVariantData;
+var
+  ndx: PtrInt;
+begin
+  ndx := GetOrAddIndexByName(aName);
+  result := _Safe(VValue[ndx]);
+  if result^.Kind <> aKind then
+  begin
+    result := @VValue[ndx];
+    VarClear(PVariant(result)^);
+    result^.Init(VOptions, 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) < cardinal(VCount) then
+    result := _Safe(VValue[aIndex])
+  else
+    result := InternalNotFound(aIndex);
+end;
+
+function _Obj(const NameValuePairs: array of const;
+  Options: TDocVariantOptions): variant;
+begin
+  VarClear(result{%H-});
+  TDocVariantData(result).InitObject(NameValuePairs, Options);
+end;
+
+function _Arr(const Items: array of const;
+  Options: TDocVariantOptions): variant;
+begin
+  VarClear(result{%H-});
+  TDocVariantData(result).InitArray(Items, Options);
+end;
+
+procedure _ObjAddProp(const Name: RawUtf8; const Value: variant;
+  var Obj: variant);
+var
+  o: PDocVariantData;
+begin
+  if _SafeObject(Obj, o) then
+  begin
+    // append new names/values to existing object
+    if o <> @Obj then
+      // ensure not stored by reference
+      TVarData(Obj) := PVarData(o)^;
+    o^.AddOrUpdateValue(Name, Value);
+  end
+  else
+  begin
+    // create new object
+    VarClear(Obj);
+    TDocVariantData(Obj).InitObject([Name, Value], JSON_FAST);
+  end
+end;
+
+procedure _ObjAddProp(const Name: RawUtf8; const Value: TDocVariantData;
+  var Obj: variant);
+begin
+  _ObjAddProp(Name, variant(Value), Obj);
+end;
+
+procedure _ObjAddPropU(const Name: RawUtf8; const Value: RawUtf8;
+  var Obj: variant);
+var
+  v: variant;
+begin
+  RawUtf8ToVariant(Value, v);
+  _ObjAddProp(Name, v, Obj);
+end;
+
+procedure _ObjAddProps(const NameValuePairs: array of const;
+  var Obj: variant);
+var
+  o: PDocVariantData;
+begin
+  if _SafeObject(Obj, o) then
+  begin
+    // append new names/values to existing object
+    if o <> @Obj then
+      // ensure not stored by reference
+      TVarData(Obj) := PVarData(o)^;
+    o^.AddNameValuesToObject(NameValuePairs);
+  end
+  else
+  begin
+    // create new object
+    VarClear(Obj);
+    TDocVariantData(Obj).InitObject(NameValuePairs, JSON_FAST);
+  end
+end;
+
+procedure _ObjAddProps(const Document: variant; var Obj: variant);
+var
+  ndx: PtrInt;
+  d, o: PDocVariantData;
+begin
+  o := _Safe(Obj);
+  if _SafeObject(Document, d) then
+    if not o.IsObject then
+      Obj := Document
+    else
+      for ndx := 0 to d^.VCount - 1 do
+        o^.AddOrUpdateValue(d^.VName[ndx], d^.VValue[ndx]);
+end;
+
+function _ObjFast(const NameValuePairs: array of const): variant;
+begin
+  VarClear(result{%H-});
+  TDocVariantData(result).InitObject(NameValuePairs, JSON_FAST);
+end;
+
+function _ObjFast(aObject: TObject;
+  aOptions: TTextWriterWriteObjectOptions): variant;
+begin
+  ObjectToVariant(aObject, result, aOptions);
+end;
+
+function _ArrFast(const Items: array of const): variant;
+begin
+  VarClear(result{%H-});
+  TDocVariantData(result).InitArray(Items, JSON_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_FAST);
+end;
+
+function _JsonFastFloat(const Json: RawUtf8): variant;
+begin
+  _Json(Json, result, JSON_FAST_FLOAT);
+end;
+
+function _JsonFastExt(const Json: RawUtf8): variant;
+begin
+  _Json(Json, result, JSON_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
+  FormatParams(Format, Args, Params, {json=}true, temp);
+  if TDocVariantData(Result).InitJsonInPlace(pointer(temp), Options) = nil then
+    TDocVariantData(Result).ClearFast;
+end;
+
+function _JsonFastFmt(const Format: RawUtf8;
+  const Args, Params: array of const): variant;
+begin
+  _JsonFmt(Format, Args, Params, JSON_FAST, result);
+end;
+
+function _Json(const Json: RawUtf8; var Value: variant;
+  Options: TDocVariantOptions): boolean;
+begin
+  VarClear(Value);
+  if not TDocVariantData(Value).InitJson(Json, Options) then
+  begin
+    TDocVariantData(Value).ClearFast;
+    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_[mDefault]);
+end;
+
+procedure _UniqueFast(var DocVariant: variant);
+begin
+  // TDocVariantData(DocVariant): InitCopy() will check the DocVariant type
+  TDocVariantData(DocVariant).InitCopy(DocVariant, JSON_[mFast]);
+end;
+
+function _Copy(const DocVariant: variant): variant;
+begin
+  result := TDocVariant.NewUnique(DocVariant, JSON_[mDefault]);
+end;
+
+function _CopyFast(const DocVariant: variant): variant;
+begin
+  result := TDocVariant.NewUnique(DocVariant, JSON_[mFast]);
+end;
+
+function _ByRef(const DocVariant: variant; Options: TDocVariantOptions): variant;
+begin
+  VarClear(result{%H-});
+  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;
+
+
+{ ************** JSON Parsing into Variant }
+
+function GetVariantFromNotStringJson(Json: PUtf8Char; var Value: TVarData;
+  AllowDouble: boolean): boolean;
+begin
+  if Json <> nil then
+    Json := GotoNextNotSpace(Json);
+  if (Json = nil) or
+     ((PInteger(Json)^ = NULL_LOW) and
+      (jcEndOfJsonValueField in JSON_CHARS[Json[4]])) then
+    TRttiVarData(Value).VType := varNull
+  else if (PInteger(Json)^ = FALSE_LOW) and
+          (Json[4] = 'e') and
+          (jcEndOfJsonValueField in JSON_CHARS[Json[5]]) then
+  begin
+    TRttiVarData(Value).VType := varBoolean;
+    Value.VInteger := ord(false);
+  end
+  else if (PInteger(Json)^ = TRUE_LOW) and
+          (jcEndOfJsonValueField in JSON_CHARS[Json[4]]) then
+  begin
+    TRttiVarData(Value).VType := varBoolean;
+    Value.VInteger := ord(true);
+  end
+  else
+  begin
+    Json := GetNumericVariantFromJson(Json, Value, AllowDouble);
+    if (Json = nil) or
+       (GotoNextNotSpace(Json)^ <> #0) then
+    begin
+      result := false;
+      exit;
+    end;
+  end;
+  result := true;
+end;
+
+function GotoEndOfJsonNumber(P: PUtf8Char; var PEndNum: PUtf8Char): PUtf8Char;
+  {$ifdef HASINLINE} inline; {$endif} // inlined for better code generation
+var
+  tab: PJsonCharSet;
+begin
+  result := P;
+  tab := @JSON_CHARS;
+  repeat
+    inc(result);
+  until not (jcDigitFloatChar in tab[result^]);
+  PEndNum := result;
+  while not (jcEndOfJsonFieldNotName in tab[result^]) do
+    inc(result); // #0, ',', ']', '}'
+end;
+
+{$ifndef PUREMORMOT2}
+procedure GetJsonToAnyVariant(var Value: variant; var Json: PUtf8Char;
+  EndOfObject: PUtf8Char; Options: PDocVariantOptions; AllowDouble: boolean);
+var
+  info: TGetJsonField;
+begin
+  info.Json := Json;
+  JsonToAnyVariant(Value, Info, Options, AllowDouble);
+  if EndOfObject <> nil then
+    EndOfObject^ := info.EndOfObject;
+  Json := info.Json;
+end;
+{$endif PUREMORMOT2}
+
+procedure JsonToAnyVariant(var Value: variant; var Info: TGetJsonField;
+  Options: PDocVariantOptions; AllowDouble: boolean);
+var
+  V: TVarData absolute Value;
+  n: integer;
+  t: ^TSynInvokeableVariantType;
+  J, J2: PUtf8Char;
+  EndOfObject2: AnsiChar;
+  wasParsedWithinString: boolean;
+label
+  parse, parsed, astext, endobj;
+begin
+  if PInteger(@V)^ <> 0 then
+    VarClearProc(V);
+  if Info.Json = nil then
+    exit;
+  Info.EndOfObject := ' ';
+  if (Options <> nil) and
+     (dvoAllowDoubleValue in Options^) then
+    AllowDouble := true;
+  wasParsedWithinString := false;
+  J := Info.Json;
+  while (J^ <= ' ') and
+        (J^ <> #0) do
+    inc(J);
+  case JSON_TOKENS[J^] of
+    jtFirstDigit:  // '-', '0'..'9': numbers are directly processed
+      begin
+        Info.Value := J;
+        J := GetNumericVariantFromJson(J, V, AllowDouble);
+        if J = nil then
+        begin
+          // not a supported number
+          if AllowDouble then
+          begin
+            Info.Json := nil; // we expected the precision to be enough
+            exit;
+          end;
+          // it may be a double value, but we didn't allow them -> store as text
+          J := Info.Value;
+          repeat
+            inc(J); // #0, ',', ']', '}'
+          until not (jcDigitFloatChar in JSON_CHARS[J^]);
+          Info.ValueLen := J - Info.Value;
+          J := GotoNextNotSpace(J);
+          Info.EndOfObject := J^;
+          if J^ <> #0 then
+            inc(J);
+          Info.Json := J;
+          goto astext;
+        end;
+        // we parsed a full number as variant
+endobj: Info.ValueLen := J - Info.Value;
+        while (J^ <= ' ') and
+              (J^ <> #0) do
+          inc(J);
+        Info.EndOfObject := J^;
+        if J^ <> #0 then
+          inc(J);
+        Info.Json := J;
+        exit;
+      end;
+    jtDoubleQuote:
+      begin
+        Info.Json := J;
+        if (Options <> nil) and
+           (dvoJsonObjectParseWithinString in Options^) then
+        begin
+          Info.GetJsonField;
+          J := Info.Value;
+          wasParsedWithinString := true;
+        end
+        else
+        begin
+          // parse string/numerical values (or true/false/null constants)
+parse:    Info.GetJsonField;
+parsed:   if Info.WasString or
+             not GetVariantFromNotStringJson(Info.Value, V, AllowDouble) then
+          begin
+astext:     TRttiVarData(V).VType := varString;
+            V.VAny := nil; // avoid GPF below
+            FastSetString(RawUtf8(V.VAny), Info.Value, Info.Valuelen);
+          end;
+          exit;
+        end;
+      end;
+    jtNullFirstChar:
+      if (PInteger(J)^ = NULL_LOW) and
+         (jcEndOfJsonValueField in JSON_CHARS[J[4]]) then
+      begin
+        Info.Value := J;
+        TRttiVarData(V).VType := varNull;
+        inc(J, 4);
+        goto endobj;
+      end;
+    jtFalseFirstChar:
+      if (PInteger(J + 1)^ = FALSE_LOW2) and
+         (jcEndOfJsonValueField in JSON_CHARS[J[5]]) then
+      begin
+        Info.Value := J;
+        TRttiVarData(V).VType := varBoolean;
+        V.VInteger := ord(false);
+        inc(J, 5);
+        goto endobj;
+      end;
+    jtTrueFirstChar:
+      if (PInteger(J)^ = TRUE_LOW) and
+         (jcEndOfJsonValueField in JSON_CHARS[J[4]]) then
+      begin
+        Info.Value := J;
+        TRttiVarData(V).VType := varBoolean;
+        V.VInteger := ord(true);
+        inc(J, 4);
+        goto endobj;
+      end;
+  end;
+  // if we reach here, input Json may be some complex value
+  if Options = nil then
+  begin
+    Info.Json := nil;
+    exit; // clearly invalid basic JSON
+  end;
+  if not (dvoJsonParseDoNotTryCustomVariants in Options^) then
+  begin
+    // first call TryJsonToVariant() overriden method for any complex content
+    t := pointer(SynVariantTryJsonTypes);
+    if t <> nil then
+    begin
+      n := PDALen(PAnsiChar(t) - _DALEN)^ + _DAOFF; // call all TryJsonToVariant()
+      repeat
+        J2 := J;
+        // currently, only implemented by mormot.db.nosql.bson BsonVariantType
+        if t^.TryJsonToVariant(J2, Value, @EndOfObject2) then
+        begin
+          if not wasParsedWithinString then
+          begin
+            Info.EndOfObject := EndOfObject2;
+            Info.Json := J2;
+          end;
+          exit;
+        end;
+        dec(n);
+        if n = 0 then
+          break;
+        inc(t);
+      until false;
+    end;
+  end;
+  if J^ in ['{', '['] then
+  begin
+    // default Json parsing and conversion to TDocVariant instance
+    J := TDocVariantData(Value).InitJsonInPlace(J, Options^, @EndOfObject2);
+    if J = nil then
+    begin
+      TDocVariantData(Value).ClearFast;
+      Info.Json := nil;
+      exit; // error parsing
+    end;
+    if not wasParsedWithinString then
+    begin
+      Info.EndOfObject := EndOfObject2;
+      Info.Json := J;
+    end;
+  end
+  else // back to simple variant types
+    if wasParsedWithinString then
+      goto parsed
+    else
+    begin
+      Info.Json := J;
+      goto parse;
+    end;
+end;
+
+function TextToVariantNumberTypeNoDouble(Json: PUtf8Char): cardinal;
+var
+  start: PUtf8Char;
+  c: AnsiChar;
+begin
+  result := varString;
+  c := Json[0];
+  if (jcDigitFirstChar in JSON_CHARS[c]) and // ['-', '0'..'9']
+     (((c >= '1') and
+       (c <= '9')) or      // is first char numeric?
+     ((c = '0') and
+      ((Json[1] = '.') or
+       (Json[1] = #0))) or // '012' is not Json, but '0.xx' and '0' are
+     ((c = '-') and
+      (Json[1] >= '0') and
+      (Json[1] <= '9'))) then  // negative number
+  begin
+    start := Json;
+    repeat
+      inc(Json)
+    until (Json^ < '0') or
+          (Json^ > '9'); // check digits
+    case Json^ of
+      #0:
+        if Json - start <= 19 then
+          // no decimal, and matcthing signed Int64 precision
+          result := varInt64;
+      '.':
+        if (Json[1] >= '0') and
+           (Json[1] <= '9') and
+           (Json[2] in [#0, '0'..'9']) then
+          if (Json[2] = #0) or
+             (Json[3] = #0) or
+             ((Json[3] >= '0') and
+              (Json[3] <= '9') and
+              (Json[4] = #0) or
+             ((Json[4] >= '0') and
+              (Json[4] <= '9') and
+              (Json[5] = #0))) then
+            result := varCurrency; // currency ###.1234 number
+    end;
+  end;
+end;
+
+function TextToVariantNumberType(Json: PUtf8Char): cardinal;
+var
+  start: PUtf8Char;
+  exp: PtrInt;
+  c: AnsiChar;
+label
+  exponent;
+begin
+  result := varString;
+  c := Json[0];
+  if (jcDigitFirstChar in JSON_CHARS[c]) and // ['-', '0'..'9']
+     (((c >= '1') and
+       (c <= '9')) or      // is first char numeric?
+     ((c = '0') and
+      ((Json[1] = '.') or
+       (Json[1] = #0))) or // '012' is not Json, but '0.xx' and '0' are
+     ((c = '-') and
+      (Json[1] >= '0') and
+      (Json[1] <= '9'))) then  // negative number
+  begin
+    start := Json;
+    repeat
+      inc(Json)
+    until (Json^ < '0') or
+          (Json^ > '9'); // check digits
+    case Json^ of
+      #0:
+        if Json - start <= 19 then // signed Int64 precision
+          result := varInt64
+        else
+          result := varDouble; // we may loose precision, but still a number
+      '.':
+        if (Json[1] >= '0') and
+           (Json[1] <= '9') and
+           (Json[2] in [#0, '0'..'9']) then
+          if (Json[2] = #0) or
+             (Json[3] = #0) or
+             ((Json[3] >= '0') and
+              (Json[3] <= '9') and
+              (Json[4] = #0) or
+             ((Json[4] >= '0') and
+              (Json[4] <= '9') and
+              (Json[5] = #0))) then
+            result := varCurrency // currency ###.1234 number
+          else
+          begin
+            repeat // more than 4 decimals
+              inc(Json)
+            until (Json^ < '0') or
+                  (Json^ > '9');
+            case Json^ of
+              #0:
+                result := varDouble;
+              'e',
+              'E':
+                begin
+exponent:         inc(Json); // inlined custom GetInteger()
+                  start := Json;
+                  c := Json^;
+                  if (c = '-') or
+                     (c = '+') then
+                  begin
+                    inc(Json);
+                    c := Json^;
+                  end;
+                  inc(Json);
+                  dec(c, 48);
+                  if c > #9 then
+                    exit;
+                  exp := ord(c);
+                  c := Json^;
+                  dec(c, 48);
+                  if c <= #9 then
+                  begin
+                    inc(Json);
+                    exp := exp * 10 + ord(c);
+                    c := Json^;
+                    dec(c, 48);
+                    if c <= #9 then
+                    begin
+                      inc(Json);
+                      exp := exp * 10 + ord(c);
+                    end;
+                  end;
+                  if Json^ <> #0 then
+                    exit;
+                  if start^ = '-' then
+                    exp := -exp;
+                  if (exp > -324) and
+                     (exp < 308) then
+                    result := varDouble; // 5.0 x 10^-324 .. 1.7 x 10^308
+                end;
+            end;
+          end;
+      'e',
+      'E':
+        goto exponent;
+    end;
+  end;
+end;
+
+const
+  CURRENCY_FACTOR: array[-4 .. -1] of integer = (1, 10, 100, 1000);
+
+function GetNumericVariantFromJson(Json: PUtf8Char; var Value: TVarData;
+  AllowVarDouble: boolean): PUtf8Char;
+var
+  // logic below is extracted from mormot.core.base.pas' GetExtended()
+  remdigit: integer;
+  frac, exp: PtrInt;
+  c: AnsiChar;
+  flags: set of (fNeg, fNegExp, fValid);
+  v64: Int64; // allows 64-bit resolution for the digits (match 80-bit extended)
+  d: double;
+begin
+  // 1. parse input text as number into v64, frac, digit, exp
+  result := nil; // return nil to indicate parsing error
+  byte(flags) := 0;
+  v64 := 0;
+  frac := 0;
+  if Json = nil then
+    exit;
+  c := Json^;
+  if c = '-' then // note: '+xxx' is not valid Json so is not handled here
+  begin
+    c := Json[1];
+    inc(Json);
+    include(flags, fNeg);
+  end;
+  if (c = '0') and
+     (Json[1] >= '0') and
+     (Json[1] <= '9') then // '012' is not Json, but '0.xx' and '0' are
+    exit;
+  remdigit := 19;    // max Int64 resolution
+  repeat
+    if (c >= '0') and
+       (c <= '9') then
+    begin
+      inc(Json);
+      dec(remdigit); // over-required digits are just ignored
+      if remdigit >= 0 then
+      begin
+        dec(c, ord('0'));
+        {$ifdef CPU64}
+        v64 := v64 * 10;
+        {$else}
+        v64 := v64 shl 3 + v64 + v64;
+        {$endif CPU64}
+        inc(v64, byte(c));
+        c := Json^;
+        include(flags, fValid);
+        if frac <> 0 then
+          dec(frac); // frac<0 for digits after '.'
+        continue;
+      end;
+      c := Json^;
+      if frac >= 0 then
+        inc(frac);   // frac>0 to handle #############00000
+      continue;
+    end;
+    if c <> '.' then
+      break;
+    c := Json[1];
+    if (frac > 0) or
+       (c = #0) then // avoid ##.
+      exit;
+    inc(json);
+    dec(frac);
+  until false;
+  if frac < 0 then
+    inc(frac);       // adjust digits after '.'
+  if (c = 'E') or
+     (c = 'e') then
+  begin
+    c := Json[1];
+    inc(Json);
+    exp := 0;
+    exclude(flags, fValid);
+    if c = '+' then
+      inc(Json)
+    else if c = '-' then
+    begin
+      inc(Json);
+      include(flags, fNegExp);
+    end;
+    repeat
+      c := Json^;
+      if (c < '0') or
+         (c > '9') then
+        break;
+      inc(Json);
+      dec(c, ord('0'));
+      exp := (exp * 10) + byte(c);
+      include(flags, fValid);
+    until false;
+    if fNegExp in flags then
+      dec(frac, exp)
+    else
+      inc(frac, exp);
+  end;
+  if not (fValid in flags) then
+    exit;
+  if fNeg in flags then
+    v64 := -v64;
+  // 2. now v64, frac, digit, exp contain number parsed from Json
+  if (frac = 0) and
+     (remdigit >= 0) then
+  begin
+    // return an integer or Int64 value
+    Value.VInt64 := v64;
+    if remdigit <= 9 then
+      TRttiVarData(Value).VType := varInt64
+    else
+      TRttiVarData(Value).VType := varInteger;
+  end
+  else if (frac < 0) and
+          (frac >= -4) then
+  begin
+    // currency as ###.0123
+    TRttiVarData(Value).VType := varCurrency;
+    Value.VInt64 := v64 * CURRENCY_FACTOR[frac]; // as round(CurrValue*10000)
+  end
+  else if AllowVarDouble and
+          (frac > -324) then // 5.0 x 10^-324 .. 1.7 x 10^308
+  begin
+    // converted into a double value
+    exp := PtrUInt(@POW10);
+    if frac >= -31 then
+      if frac <= 31 then
+        d := PPow10(exp)[frac]                 // -31 .. + 31
+      else if (18 - remdigit) + integer(frac) >= 308 then
+        exit                                   // +308 ..
+      else
+        d := HugePower10Pos(frac, PPow10(exp)) // +32 .. +307
+    else
+      d := HugePower10Neg(frac, PPow10(exp));  // .. -32
+    Value.VDouble := d * v64;
+    TRttiVarData(Value).VType := varDouble;
+  end
+  else
+    exit;
+  result := Json; // returns the first char after the parsed number
+end;
+
+procedure UniqueVariant(Interning: TRawUtf8Interning; var aResult: variant;
+  aText: PUtf8Char; aTextLen: PtrInt; aAllowVarDouble: boolean);
+var
+  tmp: RawUtf8;
+begin
+  if not GetVariantFromNotStringJson(
+           aText, TVarData(aResult), aAllowVarDouble) then
+  begin
+    FastSetString(tmp, aText, aTextLen);
+    if Interning = nil then
+      RawUtf8ToVariant(tmp, aResult)
+    else
+      Interning.UniqueVariant(aResult, tmp);
+  end;
+end;
+
+procedure TextToVariant(const aValue: RawUtf8; AllowVarDouble: boolean;
+  out aDest: variant);
+begin
+  try
+    if GetVariantFromNotStringJson(pointer(aValue), TVarData(aDest), AllowVarDouble) then
+      exit;
+  except // some obscure floating point exception may occur
+  end;
+  RawUtf8ToVariant(aValue, aDest);
+end;
+
+procedure TextBufferToVariant(aValue: PUtf8Char; AllowVarDouble: boolean;
+  out aDest: variant);
+begin
+  try
+    if GetVariantFromNotStringJson(aValue, TVarData(aDest), AllowVarDouble) then
+      exit;
+  except // some obscure floating point exception may occur
+  end;
+  RawUtf8ToVariant(aValue, StrLen(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);
+    TextToVariant(temp, AllowDouble, Value);
+    result := true;
+  end;
+end;
+
+procedure GetVariantFromJsonField(Json: PUtf8Char; wasString: boolean;
+  var Value: variant; TryCustomVariants: PDocVariantOptions;
+  AllowDouble: boolean; JsonLen: integer);
+var
+  V: TVarData absolute Value;
+  info: TGetJsonField;
+begin
+  // first handle any strict-Json syntax objects or arrays into custom variants
+  if (TryCustomVariants <> nil) and
+     (Json <> nil) then
+    if (GotoNextNotSpace(Json)^ in ['{', '[']) and
+       not wasString then
+    begin // also supports dvoJsonObjectParseWithinString
+      info.Json := Json;
+      JsonToAnyVariant(Value, info, TryCustomVariants, AllowDouble);
+      exit;
+    end
+    else if dvoAllowDoubleValue in TryCustomVariants^ then
+      AllowDouble := true;
+  // handle simple text or numerical values
+  VarClear(Value);
+  // try any numerical or true/false/null value
+  if wasString or
+     not GetVariantFromNotStringJson(Json, V, AllowDouble) then
+  begin
+    // found no numerical value -> return a string in the expected format
+    TRttiVarData(Value).VType := varString;
+    V.VString := nil; // avoid GPF below
+    if JsonLen = 0 then
+      JsonLen := StrLen(Json);
+    FastSetString(RawUtf8(V.VString), Json, JsonLen);
+  end;
+end;
+
+procedure _BinaryVariantLoadAsJson(var Value: variant; Json: PUtf8Char;
+  TryCustomVariant: pointer);
+var
+  info: TGetJsonField;
+begin
+  if TryCustomVariant = nil then
+    TryCustomVariant := @JSON_[mFast];
+  info.Json := Json;
+  JsonToAnyVariant(Value, info, TryCustomVariant, {double=}true);
+end;
+
+function VariantLoadJson(var Value: Variant; const Json: RawUtf8;
+  TryCustomVariants: PDocVariantOptions; AllowDouble: boolean): boolean;
+var
+  tmp: TSynTempBuffer;
+  info: TGetJsonField;
+begin
+  tmp.Init(Json); // temp copy before in-place decoding
+  try
+    info.Json := tmp.buf;
+    JsonToAnyVariant(Value, info, TryCustomVariants, AllowDouble);
+    result := info.Json <> nil;
+  finally
+    tmp.Done;
+  end;
+end;
+
+function VariantLoadJson(const Json: RawUtf8;
+  TryCustomVariants: PDocVariantOptions; AllowDouble: boolean): variant;
+begin
+  VariantLoadJson(result, Json, TryCustomVariants, AllowDouble);
+end;
+
+function JsonToVariantInPlace(var Value: Variant; Json: PUtf8Char;
+  Options: TDocVariantOptions; AllowDouble: boolean): PUtf8Char;
+var
+  info: TGetJsonField;
+begin
+  info.Json := Json;
+  JsonToAnyVariant(Value, info, @Options, AllowDouble);
+  result := info.Json;
+end;
+
+function JsonToVariant(const Json: RawUtf8; Options: TDocVariantOptions;
+  AllowDouble: boolean): variant;
+begin
+  VariantLoadJson(result, Json, @Options, AllowDouble);
+end;
+
+procedure MultiPartToDocVariant(const MultiPart: TMultiPartDynArray;
+  var Doc: TDocVariantData; Options: PDocVariantOptions);
+var
+  ndx: PtrInt;
+  v: variant;
+begin
+  if Options = nil then
+    Doc.InitFast(dvObject)
+  else
+    Doc.Init(Options^, dvObject);
+  for ndx := 0 to high(multipart) do
+    with MultiPart[ndx] do
+      if ContentType = TEXT_CONTENT_TYPE then
+      begin
+        // append as regular "Name":"TextValue" field
+        RawUtf8ToVariant(Content, v);
+        Doc.AddValue(name, v);
+      end
+      else
+        // append binary file as an object, with Base64-encoded data
+        Doc.AddValue(name, _ObjFast([
+          'data',        BinToBase64(Content),
+          'filename',    FileName,
+          'contenttype', ContentType]));
+end;
+
+function ParseSortMatch(Expression: PUtf8Char; out Key: RawUtf8;
+  out Match: TCompareOperator; Value: PVariant): boolean;
+var
+  KB, KE, B: PUtf8Char;
+begin
+  result := false;
+  if Expression = nil then
+    exit;
+  Expression := GotoNextNotSpace(Expression);
+  KB := Expression;
+  while jcJsonIdentifier in JSON_CHARS[Expression^] do
+    inc(Expression);
+  if Expression^ = #0 then
+    exit;
+  KE := Expression;
+  Expression := GotoNextNotSpace(Expression);
+  B := Expression;
+  while Expression^ in ['<', '>', '='] do
+    inc(Expression);
+  case Expression - B of
+    1:
+      case B^ of
+        '=':
+          Match := coEqualTo;
+        '<':
+          Match := coLessThan;
+        '>':
+          Match := coGreaterThan
+      else
+        exit;
+      end;
+    2:
+      case PWord(B)^ of
+        ord('=') + ord('=') shl 8: // c-style
+          Match := coEqualTo;
+        ord('!') + ord('=') shl 8, // c-style
+        ord('<') + ord('>') shl 8:
+          Match := coNotEqualTo;
+        ord('>') + ord('=') shl 8:
+          Match := coGreaterThanOrEqualTo;
+        ord('<') + ord('=') shl 8:
+          Match := coLessThanOrEqualTo;
+      else
+        exit;
+      end;
+  else
+    exit;
+  end;
+  FastSetString(Key, KB, KE - KB);
+  if Value <> nil then
+    TextBufferToVariant(GotoNextNotSpace(Expression), {allowdouble=}true, Value^);
+  result := true;
+end;
+
+{ ************** Variant Binary Serialization }
+
+{$ifndef PUREMORMOT2}
+
+function VariantSaveLength(const Value: variant): integer;
+begin
+  result := {%H-}BinarySaveLength(@Value, TypeInfo(Variant), nil, [rkVariant]);
+end;
+
+function VariantSave(const Value: variant; Dest: PAnsiChar): PAnsiChar;
+var
+  dummy: integer;
+begin
+  result := {%H-}BinarySave(@Value, Dest, TypeInfo(Variant), dummy, [rkVariant]);
+end;
+
+{$endif PUREMORMOT2}
+
+function VariantSave(const Value: variant): RawByteString;
+begin
+  result := BinarySave(@Value, TypeInfo(Variant), [rkVariant]);
+end;
+
+function VariantLoad(var Value: variant; Source: PAnsiChar;
+  CustomVariantOptions: PDocVariantOptions; SourceMax: PAnsiChar): PAnsiChar;
+begin
+  {$ifndef PUREMORMOT2}
+  if SourceMax = nil then
+    // mORMot 1 unsafe backward compatible: assume fake 100MB Source input
+    SourceMax := Source + 100 shl 20;
+  {$endif PUREMORMOT2}
+  result := BinaryLoad(@Value, Source, TypeInfo(Variant), nil, SourceMax,
+    [rkVariant], CustomVariantOptions);
+end;
+
+function VariantLoad(const Bin: RawByteString;
+  CustomVariantOptions: PDocVariantOptions): variant;
+begin
+  BinaryLoad(@result, Bin, TypeInfo(Variant),
+    [rkVariant], CustomVariantOptions);
+end;
+
+procedure FromVarVariant(var Source: PByte; var Value: variant;
+  CustomVariantOptions: PDocVariantOptions; SourceMax: PByte);
+begin
+  Source := PByte(VariantLoad(Value, pointer(Source),
+    CustomVariantOptions, pointer(SourceMax)));
+end;
+
+
+{ ************** IDocList/IDocDict advanced Wrappers of TDocVariant Documents }
+
+type
+  TDocAny = class(TInterfacedSerializable)
+  protected
+    fValue: PDocVariantData;
+    fValueOwned: TVarData;
+  public
+    constructor CreateOwned;
+    constructor CreateNew(const dv: TDocVariantData; m: TDocVariantModel); reintroduce;
+    constructor CreateCopy(const dv: TDocVariantData); reintroduce;
+    constructor CreateByRef(dv: PDocVariantData); reintroduce;
+    destructor Destroy; override;
+    procedure OwnedAs(opt: PDocVariantOptions; added: TDocVariantOption);
+      {$ifdef HASINLINE} inline; {$endif}
+    procedure Clear;
+    function Kind: TDocVariantKind;
+    function Model: TDocVariantModel;
+    function Len: integer;
+    procedure ToJson(W: TJsonWriter; Options: TTextWriterWriteObjectOptions); override;
+    function Value: PDocVariantData;
+    function AsList: IDocList;
+    function AsDict: IDocDict;
+    function AsVariant: variant;
+  end;
+
+  TDocList = class(TDocAny, IDocList)
+  public
+    // TInterfacedSerializable methods
+    constructor Create(options: PDocVariantOptions); override;
+    procedure FromJson(var context: TJsonParserContext); override;
+    // IDocList methods
+    function GetB(position: integer): boolean;
+    function GetC(position: integer): currency;
+    function GetD(position: integer): IDocDict;
+    function GetF(position: integer): double;
+    function GetI(position: integer): Int64;
+    function GetItem(position: integer): variant;
+    function GetL(position: integer): IDocList;
+    function GetS(position: integer): string;
+    function GetU(position: integer): RawUtf8;
+    procedure SetB(position: integer; value: boolean);
+    procedure SetC(position: integer; const value: currency);
+    procedure SetD(position: integer; const value: IDocDict);
+    procedure SetF(position: integer; const value: double);
+    procedure SetI(position: integer; value: Int64);
+    procedure SetItem(position: integer; const value: variant);
+    procedure SetL(position: integer; const value: IDocList);
+    procedure SetS(position: integer; const value: string);
+    procedure SetU(position: integer; const value: RawUtf8);
+    //procedure SetJson(const value: RawUtf8); override;
+    function Append(const value: variant): integer; overload;
+    function Append(const value: RawUtf8): integer; overload;
+    function AppendDoc(const value: IDocAny): integer;
+    function Copy(start, stop: integer): IDocList;
+    function Compare(const another: IDocList; caseinsensitive: boolean): integer;
+    function Count(const value: variant): integer; overload;
+    function Count(const value: RawUtf8): integer; overload;
+    procedure Extend(const value: IDocList); overload;
+    procedure Extend(const value: array of const); overload;
+    function Filter(const key: RawUtf8; const value: variant; limit: integer;
+      match: TCompareOperator; compare: TVariantCompare): IDocList; overload;
+    function Filter(const expression: RawUtf8): IDocList; overload;
+    function Filter(const expression: RawUtf8; const value: variant;
+      limit: integer): IDocList; overload;
+    function First(const expression: RawUtf8): variant; overload;
+    function First(const expression: RawUtf8; const value: variant): variant; overload;
+    function Index(const value: variant): integer; overload;
+    function Index(const value: RawUtf8; caseinsensitive: boolean): integer; overload;
+    function Exists(const value: variant): boolean; overload;
+    function Exists(const value: RawUtf8; caseinsensitive: boolean): boolean; overload;
+    function Insert(position: integer; const value: variant): integer; overload;
+    function Insert(position: integer; const value: RawUtf8): integer; overload;
+    function ObjectsDictDynArray: IDocDictDynArray;
+    function Pop(position: integer): variant;
+    function PopItem(out value: variant; position: integer): boolean; overload;
+    function PopItem(out value: IDocDict; position: integer): boolean; overload;
+    function Del(position: integer): boolean;
+    function Reduce(const keys: array of RawUtf8): IDocList;
+    function Remove(const value: variant): integer; overload;
+    function Remove(const value: RawUtf8; caseinsensitive: boolean): integer; overload;
+    procedure Reverse;
+    procedure Sort(reverse: boolean; compare: TVariantCompare);
+    procedure SortByKeyValue(const key: RawUtf8; reverse: boolean;
+      compare: TVariantCompare); overload;
+    procedure SortByKeyValue(const keys: array of RawUtf8; reverse: boolean;
+      compare: TVariantCompare); overload;
+    function ValueAt(position: integer): PVariant;
+    {$ifdef HASIMPLICITOPERATOR}
+    function GetV(position: integer): TDocValue;
+    function GetEnumerator: TDocValueEnumerator;
+    function Range(start, stop: integer): TDocValueEnumerator;
+    function Objects: TDocObjectEnumerator; overload;
+    function Objects(const key: RawUtf8; const value: variant;
+      match: TCompareOperator; compare: TVariantCompare): TDocObjectEnumerator; overload;
+    function Objects(const expression: RawUtf8): TDocObjectEnumerator; overload;
+    function Objects(const expression: RawUtf8;
+      const value: variant): TDocObjectEnumerator; overload;
+    {$endif HASIMPLICITOPERATOR}
+  end;
+
+  TDocDict = class(TDocAny, IDocDict)
+  protected
+    fPathDelim: AnsiChar; // some additional parameters to this IDocDict state
+    fSorted: TUtf8Compare;
+    function GetValueAt(const key: RawUtf8; out value: PVariant): boolean;
+    function SetValueAt(const key: RawUtf8; const value: variant): boolean;
+    function GetExistingValueAt(const key, method: RawUtf8): PVariant;
+    function PopAt(const key: RawUtf8; value: PVariant): boolean;
+  public
+    // TInterfacedSerializable methods
+    constructor Create(options: PDocVariantOptions); override;
+    procedure FromJson(var context: TJsonParserContext); override;
+    // IDocDict methods
+    function GetB(const key: RawUtf8): boolean;
+    function GetC(const key: RawUtf8): currency;
+    function GetD(const key: RawUtf8): IDocDict;
+    function GetF(const key: RawUtf8): double;
+    function GetI(const key: RawUtf8): Int64;
+    function GetItem(const key: RawUtf8): variant;
+    function GetL(const key: RawUtf8): IDocList;
+    function GetS(const key: RawUtf8): string;
+    function GetU(const key: RawUtf8): RawUtf8;
+    procedure SetB(const key: RawUtf8; const value: boolean);
+    procedure SetC(const key: RawUtf8; const value: currency);
+    procedure SetD(const key: RawUtf8; const value: IDocDict);
+    procedure SetF(const key: RawUtf8; const value: double);
+    procedure SetI(const key: RawUtf8; const value: Int64);
+    procedure SetItem(const key: RawUtf8; const value: variant);
+    procedure SetL(const key: RawUtf8; const value: IDocList);
+    procedure SetS(const key: RawUtf8; const value: string);
+    procedure SetU(const key: RawUtf8; const value: RawUtf8);
+    function Get(const key: RawUtf8): variant; overload;
+    function GetDef(const key: RawUtf8; const default: variant): variant; overload;
+    function GetDef(const key: RawUtf8; const default: RawUtf8): variant; overload;
+    function Get(const key: RawUtf8; var value: variant): boolean; overload;
+    function Get(const key: RawUtf8; var value: RawUtf8): boolean; overload;
+    function Get(const key: RawUtf8; var value: string): boolean; overload;
+    function Get(const key: RawUtf8; var value: boolean): boolean; overload;
+    function Get(const key: RawUtf8; var value: integer): boolean; overload;
+    function Get(const key: RawUtf8; var value: Int64): boolean; overload;
+    function Get(const key: RawUtf8; var value: double): boolean; overload;
+    function Get(const key: RawUtf8; var value: currency): boolean; overload;
+    function Get(const key: RawUtf8; var value: IDocList): boolean; overload;
+    function Get(const key: RawUtf8; var value: IDocDict): boolean; overload;
+    function Get(const key: RawUtf8; var value: PDocVariantData): boolean; overload;
+    function GetPathDelim: AnsiChar;
+    procedure SetPathDelim(value: AnsiChar);
+    function Compare(const another: IDocDict; caseinsensitive: boolean): integer; overload;
+    function Compare(const another: IDocDict; const keys: array of RawUtf8;
+      caseinsensitive: boolean = false): integer; overload;
+    function Copy: IDocDict;
+    function Del(const key: RawUtf8): boolean;
+    function Exists(const key: RawUtf8): boolean;
+    function Pop(const key: RawUtf8): variant; overload;
+    function Pop(const key: RawUtf8; const default: variant): variant; overload;
+    function PopItem(out key: RawUtf8; out value: variant; position: integer): boolean;
+    function Reduce(const keys: array of RawUtf8): IDocDict;
+    function SetDefault(const key: RawUtf8): variant; overload;
+    function SetDefault(const key: RawUtf8; const default: variant): variant; overload;
+    procedure Sort(reverse: boolean; keycompare: TUtf8Compare);
+    procedure Update(const key: RawUtf8; const value: variant); overload;
+    procedure Update(const keyvalues: array of const); overload;
+    procedure Update(const source: IDocDict; addonlymissing: boolean); overload;
+    function ValueAt(const key: RawUtf8): PVariant;
+    {$ifdef HASIMPLICITOPERATOR}
+    function GetV(const key: RawUtf8): TDocValue;
+    function GetEnumerator: TDocDictEnumerator;
+    function Keys: TDocKeyEnumerator;
+    function Values: TDocValueEnumerator;
+    {$endif HASIMPLICITOPERATOR}
+  end;
+
+{$ifdef HASIMPLICITOPERATOR}
+
+{ TDocValue }
+
+function TDocValue.IsString: boolean;
+begin
+  result := VarIsStr(V^);
+end;
+
+function TDocValue.Kind: TDocVariantKind;
+begin
+  result := _Safe(V^).GetKind;
+end;
+
+class operator TDocValue.Implicit(const A: TDocValue): boolean;
+begin
+  if not VariantToBoolean(A.V^, result) then
+    result := false;
+end;
+
+class operator TDocValue.Implicit(const A: TDocValue): integer;
+begin
+  if not VariantToInteger(A.V^, result) then
+    result := 0;
+end;
+
+class operator TDocValue.Implicit(const A: TDocValue): Int64;
+begin
+  if not VariantToInt64(A.V^, result) then
+    result := 0;
+end;
+
+class operator TDocValue.Implicit(const A: TDocValue): string;
+begin
+  VariantToString(A.V^, result);
+end;
+
+class operator TDocValue.Implicit(const A: TDocValue): RawUtf8;
+var
+  wasString: boolean;
+begin
+  VariantToUtf8(A.V^, RawUtf8(result), wasString);
+end;
+
+class operator TDocValue.Implicit(const A: TDocValue): IDocList;
+begin
+  result := DocListFrom(A.V^);
+end;
+
+class operator TDocValue.Implicit(const A: TDocValue): IDocDict;
+begin
+  result := DocDictFrom(A.V^);
+end;
+
+class operator TDocValue.Implicit(const A: TDocValue): variant;
+begin
+  result := A.V^;
+end;
+
+class operator TDocValue.Implicit(const A: TDocValue): PVarData;
+begin
+  result := pointer(A.V);
+end;
+
+class operator TDocValue.Implicit(const A: TDocValue): PDocVariantData;
+begin
+  result := _Safe(A.V^); // better not inlined at TDocValue level
+end;
+
+{ TDocValueEnumerator }
+
+function TDocValueEnumerator.MoveNext: boolean;
+var
+  c: PVariant;
+begin
+  c := Curr.V;
+  inc(c);
+  Curr.V := c;
+  result := PtrUInt(c) < PtrUInt(After.V);
+end;
+
+function TDocValueEnumerator.GetEnumerator: TDocValueEnumerator;
+begin
+  result := self; // just copy 2 pointers
+end;
+
+{ TDocObjectEnumerator }
+
+function TDocObjectEnumerator.MoveNext: boolean;
+var
+  c, o: PVariant;
+  v: TDocDict;
+  dv: PDocVariantData;
+begin
+  result := false;
+  repeat
+    c := Curr;
+    inc(c);
+    Curr := c;
+    if PtrUInt(c) >= PtrUInt(After) then
+      exit; // reached end of list
+    if not _Safe(c^, dv) then
+      continue
+    else if CompKey = '' then
+    begin
+      if not dv.IsObject then
+        continue; // ignore any list element which is not a IDocDict
+    end
+    else
+    begin
+      if CompKeyHasPath then
+      begin
+        o := dv^.GetPVariantByPath(CompKey, '.');
+        if o = nil then
+          continue;
+      end
+      else if not dv^.GetObjectProp(CompKey, o, @CompKeyPrev) then
+        continue;
+      if not SortMatch(CompFunc({%H-}o^, CompValue), CompMatch) then
+        continue;
+    end;
+    if CurrDict = nil then
+    begin
+      v := TDocDict.CreateByRef(nil);
+      CurrDictValue := @v.fValue;
+      CurrDict := v; // share a single TDocDict instance during loop
+    end;
+    CurrDictValue^ := dv; // directly change TDocDict.fValue
+    result := true;
+    exit;
+  until false;
+end;
+
+function TDocObjectEnumerator.GetEnumerator: TDocObjectEnumerator;
+begin
+  result := self;
+end;
+
+{ TDocKey }
+
+function TDocKey.Equals(const txt: RawUtf8): boolean;
+begin
+  result := txt = V^;
+end;
+
+function TDocKey.Utf8: RawUtf8;
+begin
+  result := V^;
+end;
+
+class operator TDocKey.Implicit(const A: TDocKey): string;
+begin
+  Utf8ToStringVar(A.V^, result);
+end;
+
+class operator TDocKey.Implicit(const A: TDocKey): RawUtf8;
+begin
+  result := A.V^;
+end;
+
+{ TDocDictFields }
+
+function TDocDictFields.KeyValue(const separator: RawUtf8): RawUtf8;
+begin
+  Make([Key.V^, separator, Value.V^], result);
+end;
+
+{ TDocKeyEnumerator }
+
+function TDocKeyEnumerator.MoveNext: boolean;
+var
+  c: PRawUtf8;
+begin
+  c := Curr.V;
+  inc(c);
+  Curr.V := c;
+  result := PtrUInt(c) < PtrUInt(After.V);
+end;
+
+function TDocKeyEnumerator.GetEnumerator: TDocKeyEnumerator;
+begin
+  result := self; // just copy 2 pointers
+end;
+
+{ TDocDictEnumerator }
+
+function TDocDictEnumerator.MoveNext: boolean;
+var
+  v: PVariant;
+begin
+  inc(Curr.Key.V);
+  v := Curr.Value.V;
+  inc(v);
+  Curr.Value.V := v;
+  result := PtrUInt(v) < PtrUInt(AfterValue.V);
+end;
+
+function TDocDictEnumerator.GetEnumerator: TDocDictEnumerator;
+begin
+  result := self; // just copy 3 pointers
+end;
+
+{$endif HASIMPLICITOPERATOR}
+
+
+{ IDocList factories functions }
+
+function DocList(model: TDocVariantModel): IDocList;
+var
+  v: TDocList;
+begin
+  v := TDocList.CreateOwned;
+  TDocVariantData(v.fValueOwned).Init(model, dvArray);
+  result := v;
+end;
+
+function DocList(const json: RawUtf8; model: TDocVariantModel): IDocList;
+begin
+  result := DocList(model);
+  result.SetJson(json);
+end;
+
+function DocListFromResults(const json: RawUtf8;
+  model: TDocVariantModel): IDocList;
+begin
+  result := TDocList.CreateOwned;
+  if not result.Value^.InitArrayFromResults(json, model) then
+    result := nil;
+end;
+
+function DocList(const dv: TDocVariantData): IDocList;
+var
+  v: TDocList;
+begin
+  v := nil;
+  if dv.IsArray then
+    v := TDocList.CreateByRef(@dv);
+  result := v;
+end;
+
+function DocListCopy(const dv: TDocVariantData): IDocList;
+var
+  v: TDocList;
+begin
+  v := nil;
+  if dv.IsArray then
+    v := TDocList.CreateCopy(dv);
+  result := v;
+end;
+
+function DocListCopy(const v: variant): IDocList;
+begin
+  result := DocListCopy(_Safe(v)^);
+end;
+
+function DocListCopy(const dv: TDocVariantData; model: TDocVariantModel): IDocList;
+var
+  v: TDocList;
+begin
+  v := nil;
+  if dv.IsArray then
+    v := TDocList.CreateNew(dv, model);
+  result := v;
+end;
+
+function DocList(const values: array of const; model: TDocVariantModel): IDocList;
+begin
+  result := TDocList.CreateOwned;
+  result.Value^.InitArray(values, model);
+end;
+
+function DocListFrom(const v: variant): IDocList;
+var
+  dv: PDocVariantData;
+  d: TDocList;
+begin
+  d := nil;
+  if _SafeArray(variant(v), dv) then
+    d := TDocList.CreateByRef(dv);
+  result := d;
+end;
+
+function DocListFrom(const dictarray: IDocDictDynArray): IDocList;
+var
+  i: PtrInt;
+begin
+  result := DocList(DocAnyDefaultModel);
+  for i := 0 to length(dictarray) - 1 do
+    result.AppendDoc(dictarray[i]);
+end;
+
+{ IDocDict factories functions }
+
+function DocDict(model: TDocVariantModel): IDocDict;
+var
+  v: TDocDict;
+begin
+  v := TDocDict.CreateOwned;
+  TDocVariantData(v.fValueOwned).Init(model, dvObject);
+  result := v;
+end;
+
+function DocDict(const json: RawUtf8; model: TDocVariantModel): IDocDict;
+begin
+  result := DocDict(model);
+  result.SetJson(json);
+end;
+
+function DocDictDynArray(const json: RawUtf8;
+  model: TDocVariantModel; jsonfromresults: boolean): IDocDictDynArray;
+var
+  main: TDocVariantData;
+  n, i: PtrInt;
+  p: PVariant;
+  dv: PDocVariantData;
+  v: TDocDict;
+begin
+  result := nil;
+  if jsonfromresults then
+  begin
+    if not main.InitArrayFromResults(json, model) then
+      exit;
+  end
+  else if not main.InitJson(json, model) or
+          not main.IsArray then
+    exit;
+  n := main.Count;
+  if n = 0 then
+    exit;
+  p := pointer(main.VValue);
+  i := 0;
+  repeat
+    if _SafeObject(p^, dv) then
+    begin
+      if result = nil then
+        SetLength(result, n); // allocate only when needed
+      v := TDocDict.CreateOwned;
+      v.fValueOwned := PVarData(dv)^; // raw copy with no refcount
+      PRttiVarData(dv)^.VType := varEmpty; // not in main any more
+      result[i] := v;
+      inc(i);
+    end;
+    inc(p);
+    dec(n);
+  until n = 0;
+  if i <> 0 then
+    DynArrayFakeLength(result, i); // no realloc
+end;
+
+function DocDictFrom(const v: variant): IDocDict;
+var
+  dv: PDocVariantData;
+  d: TDocDict;
+begin
+  d := nil;
+  if _SafeObject(variant(v), dv) then
+    d := TDocDict.CreateByRef(dv);
+  result := d;
+end;
+
+function DocDict(const dv: TDocVariantData): IDocDict;
+begin
+  if dv.IsObject then
+    result := TDocDict.CreateByRef(@dv)
+  else
+    result := nil;
+end;
+
+function DocDictCopy(const dv: TDocVariantData): IDocDict;
+var
+  d: TDocDict;
+begin
+  d := nil;
+  if dv.IsObject then
+    d := TDocDict.CreateCopy(dv);
+  result := d;
+end;
+
+function DocDictCopy(const v: variant): IDocDict;
+begin
+  result := DocDictCopy(_Safe(v)^);
+end;
+
+function DocDictCopy(const dv: TDocVariantData; model: TDocVariantModel): IDocDict;
+var
+  d: TDocDict;
+begin
+  d := nil;
+  if dv.IsObject then
+    d := TDocDict.CreateNew(dv, model);
+  result := d;
+end;
+
+function DocDict(const keyvalues: array of const; model: TDocVariantModel): IDocDict;
+begin
+  result := TDocDict.CreateOwned;
+  result.Value^.InitObject(keyvalues, model);
+end;
+
+function DocDictFromKeys(const keys: array of RawUtf8;
+  model: TDocVariantModel): IDocDict;
+begin
+  result := DocDictFromKeys(keys, Null, model);
+end;
+
+function DocDictFromKeys(const keys: array of RawUtf8; const value: variant;
+  model: TDocVariantModel): IDocDict;
+var
+  i: PtrInt;
+  dv: PDocVariantData;
+begin
+  result := TDocDict.CreateOwned;
+  dv := result.Value;
+  dv^.Init(model, dvObject);
+  dv^.SetCapacity(length(keys));
+  for i := 0 to high(keys) do
+    dv^.AddOrUpdateValue(keys[i], value);
+end;
+
+
+{ TDocAny }
+
+constructor TDocAny.CreateOwned;
+begin
+  fValue := @fValueOwned;
+end;
+
+procedure TDocAny.OwnedAs(opt: PDocVariantOptions; added: TDocVariantOption);
+begin
+  fValue := @fValueOwned;
+  if opt = nil then
+    opt := @JSON_[DocAnyDefaultModel];
+  TRttiVarData(fValueOwned).VType := DocVariantVType +
+    cardinal(PWord(opt)^ + 1 shl ord(added)) shl 16; // VType+VOptions
+end;
+
+constructor TDocAny.CreateNew(const dv: TDocVariantData; m: TDocVariantModel);
+begin
+  fValue := @fValueOwned;
+  TDocVariantData(fValueOwned).Init(m, dv.Kind); // new arrays, but byref values
+  if dv.Count = 0 then
+    exit;
+  DynArrayCopy(@fValue^.VName, @dv.VName, TypeInfo(TRawUtf8DynArray), @dv.Count);
+  DynArrayCopy(@fValue^.VValue, @dv.VValue, TypeInfo(TVariantDynArray), @dv.Count);
+  TDocVariantData(fValueOwned).VCount := dv.Count;
+end;
+
+constructor TDocAny.CreateCopy(const dv: TDocVariantData);
+begin
+  fValue := @fValueOwned;
+  TDocVariantData(fValueOwned).InitFrom(dv, true, true); // new arrays, but byref values
+end;
+
+constructor TDocAny.CreateByRef(dv: PDocVariantData);
+begin
+  fValue := dv;
+end;
+
+destructor TDocAny.Destroy;
+begin
+  inherited Destroy;
+  if fValue = @fValueOwned then
+    TDocVariantData(fValueOwned).Void;
+end;
+
+function TDocAny.Kind: TDocVariantKind;
+begin
+  result := fValue^.GetKind;
+end;
+
+function TDocAny.Model: TDocVariantModel;
+begin
+  if not fValue^.GetModel(result) then
+    result := DocAnyDefaultModel; // default value if not exactly found
+end;
+
+function TDocAny.Len: integer;
+begin
+  result := fValue^.VCount;
+end;
+
+procedure TDocAny.ToJson(W: TJsonWriter; Options: TTextWriterWriteObjectOptions);
+begin
+  DocVariantType.ToJson(W, PVarData(fValue));
+end;
+
+function TDocAny.Value: PDocVariantData;
+begin
+  result := fValue;
+end;
+
+procedure TDocAny.Clear;
+begin
+  fValue^.Void; // keep Options and Kind
+end;
+
+function TDocAny.AsList: IDocList;
+begin
+  if fValue^.IsArray then
+    result := self as TDocList
+  else
+    result := nil;
+end;
+
+function TDocAny.AsDict: IDocDict;
+begin
+  if fValue^.IsObject then
+    result := self as TDocDict
+  else
+    result := nil;
+end;
+
+function TDocAny.AsVariant: variant;
+begin
+  result := PVariant(fValue)^;
+end;
+
+procedure JL_IDocAny(var Context: TJsonParserContext;
+  Doc: PDocVariantData; Token: TJsonToken);
+var
+  ctx: TGetJsonField absolute Context; // circumvent USERECORDWITHMETHODS
+  opt: PDocVariantOptions;
+begin
+  Doc^.Void; // IDocList/IDocDict may be existing and with some previous data
+  if GetFirstJsonToken(ctx.Json) <> Token then
+  begin
+    Context.Valid := (ctx.Json <> nil) and Context.ParseNull;
+    exit;
+  end;
+  opt := Context.CustomVariant;
+  if opt = nil then
+    opt := @Doc^.VOptions;
+  ctx.Json := Doc^.InitJsonInPlace(ctx.Json, opt^, @ctx.EndOfObject);
+  Context.Valid := ctx.Json <> nil;
+end;
+
+
+{ EDocList }
+
+class procedure EDocList.GetRaise(method: AnsiChar; pos: integer; const v: variant);
+begin
+  raise CreateUtf8('%[%] on a var%', [method, pos, VariantTypeName(v)^]);
+end;
+
+{ TDocList }
+
+constructor TDocList.Create(options: PDocVariantOptions);
+begin
+  OwnedAs(options, dvoIsArray);
+end;
+
+procedure TDocList.FromJson(var context: TJsonParserContext);
+begin
+  JL_IDocAny(context, fValue, jtArrayStart);
+end;
+
+function TDocList.ValueAt(position: integer): PVariant;
+var
+  ndx, n: PtrUInt;
+begin
+  ndx := position;
+  n := fValue^.VCount;
+  if position < 0 then
+    inc(ndx, n);
+  if ndx >= n then
+    raise EDocList.CreateUtf8('Index % out of range (len=%)', [position, n]);
+  result := @fValue^.VValue[ndx];
+  // setters should not call EnsureUnique() because is done in constructor
+end;
+
+function TDocList.GetItem(position: integer): variant;
+begin
+  result := ValueAt(position)^;
+end;
+
+procedure TDocList.SetItem(position: integer; const value: variant);
+var
+  v: PVariant;
+begin
+  v := ValueAt(position);
+  SetVariantByValue(value, v^); // may convert to RawUtf8/varString
+  if (PVarData(v)^.VType = varString) and
+     fValue^.Has(dvoInternValues) then
+    InternalUniqueValue(v);
+end;
+
+function TDocList.GetU(position: integer): RawUtf8;
+begin
+  VariantToUtf8(ValueAt(position)^, result);
+end;
+
+procedure TDocList.SetU(position: integer; const value: RawUtf8);
+var
+  v: PVariant;
+begin
+  v := ValueAt(position);
+  RawUtf8ToVariant(value, v^);
+  if fValue^.Has(dvoInternValues) then
+    InternalUniqueValue(v);
+end;
+
+function TDocList.GetS(position: integer): string;
+begin
+  VariantToString(ValueAt(position)^, result);
+end;
+
+procedure TDocList.SetS(position: integer; const value: string);
+var
+  v: PVariant;
+begin
+  v := ValueAt(position);
+  StringToVariant(value, v^); // convert and store as RawUtf8/varString
+  if fValue^.Has(dvoInternValues) then
+    InternalUniqueValue(v);
+end;
+
+function TDocList.GetI(position: integer): Int64;
+var
+  v: PVariant;
+begin
+  v := ValueAt(position);
+  if not VariantToInt64(v^, result) then
+    EDocList.GetRaise('I', position, v^);
+end;
+
+function TDocList.GetF(position: integer): double;
+var
+  v: PVariant;
+begin
+  v := ValueAt(position);
+  if not VariantToDouble(v^, result) then
+    EDocList.GetRaise('F', position, v^);
+end;
+
+function TDocList.GetC(position: integer): currency;
+var
+  v: PVariant;
+begin
+  v := ValueAt(position);
+  if not VariantToCurrency(v^, result) then
+    EDocList.GetRaise('C', position, v^);
+end;
+
+procedure TDocList.SetI(position: integer; value: Int64);
+begin
+  ValueAt(position)^ := value;
+end;
+
+procedure TDocList.SetF(position: integer; const value: double);
+begin
+  ValueAt(position)^ := value;
+end;
+
+procedure TDocList.SetC(position: integer; const value: currency);
+begin
+  ValueAt(position)^ := value;
+end;
+
+function TDocList.GetB(position: integer): boolean;
+var
+  v: PVariant;
+begin
+  v := ValueAt(position);
+  if not VariantToBoolean(v^, result) then
+    EDocList.GetRaise('B', position, v^);
+end;
+
+function TDocList.GetL(position: integer): IDocList;
+begin
+  result := TDocList.CreateByRef(_Safe(ValueAt(position)^, dvArray));
+end;
+
+function TDocList.GetD(position: integer): IDocDict;
+begin
+  result := TDocDict.CreateByRef(_Safe(ValueAt(position)^, dvObject));
+end;
+
+procedure TDocList.SetB(position: integer; value: boolean);
+begin
+  ValueAt(position)^ := value;
+end;
+
+procedure TDocList.SetL(position: integer; const value: IDocList);
+var
+  v: PVariant;
+begin
+  v := ValueAt(position);
+  if value = nil then
+    VarClear(v^)
+  else
+    v^ := PVariant(value.Value)^;
+end;
+
+procedure TDocList.SetD(position: integer; const value: IDocDict);
+var
+  v: PVariant;
+begin
+  v := ValueAt(position);
+  if value = nil then
+    VarClear(v^)
+  else
+    v^ := PVariant(value.Value)^;
+end;
+
+function TDocList.Append(const value: variant): integer;
+begin
+  result := fValue^.AddItem(value);
+end;
+
+function TDocList.Append(const value: RawUtf8): integer;
+begin
+  result := fValue^.AddItemText(value);
+end;
+
+function TDocList.AppendDoc(const value: IDocAny): integer;
+begin
+  result := fValue^.AddItem(PVariant(value.Value)^);
+end;
+
+function DocListRangeVoid(var start, stop: integer; n: integer): boolean;
+begin
+  result := true;
+  if n = 0 then
+    exit;
+  if start < 0 then
+    inc(start, n);
+  if stop <> 0 then
+  begin
+    if stop < 0 then
+      inc(stop, n);
+    dec(stop, start); // from index to limit, excluding stop position
+    if stop <= 0 then
+      exit;
+  end;
+  result := false; // not void
+end;
+
+function TDocList.Copy(start, stop: integer): IDocList;
+begin
+  result := TDocList.CreateOwned;
+  if DocListRangeVoid(start, stop, fValue^.Count) then
+    result.Value^.Init(fValue^.VOptions, dvArray)
+  else
+    result.Value^.InitArrayFrom(fValue^, fValue^.VOptions, start, stop);
+end;
+
+function TDocList.Compare(const another: IDocList; caseinsensitive: boolean): integer;
+begin
+  if another = nil then
+    result := 1
+  else if another.Value = fValue then
+    result := 0 // same reference
+  else
+    result := fValue^.Compare(another.Value^, caseinsensitive);
+end;
+
+function TDocList.Count(const value: variant): integer;
+begin
+  result := fValue^.CountItemByValue(value);
+end;
+
+function TDocList.Count(const value: RawUtf8): integer;
+var
+  v: TRttiVarData;
+begin
+  v.VType := varString;
+  v.Data.VAny := pointer(value); // direct set to our RawUtf8 searched value
+  result := fValue^.CountItemByValue(variant(v));
+end;
+
+procedure TDocList.Extend(const value: IDocList);
+begin
+  if value <> nil then
+    fValue^.AddFrom(variant(value.Value^));
+end;
+
+procedure TDocList.Extend(const value: array of const);
+begin
+  fValue^.AddItems(value);
+end;
+
+function TDocList.Index(const value: variant): integer;
+begin
+  result := fValue^.SearchItemByValue(value);
+end;
+
+function TDocList.Index(const value: RawUtf8; caseinsensitive: boolean): integer;
+var
+  v: TRttiVarData;
+begin
+  v.VType := varString;
+  v.Data.VAny := pointer(value); // direct set to our RawUtf8 searched value
+  result := fValue^.SearchItemByValue(variant(v), caseinsensitive);
+end;
+
+function TDocList.Exists(const value: variant): boolean;
+begin
+  result := fValue^.SearchItemByValue(value) >= 0;
+end;
+
+function TDocList.Exists(const value: RawUtf8; caseinsensitive: boolean): boolean;
+begin
+  result := Index(value, caseinsensitive) >= 0;
+end;
+
+function TDocList.Insert(position: integer; const value: variant): integer;
+begin
+  result := fValue^.AddItem(value, position);
+end;
+
+function TDocList.Insert(position: integer; const value: RawUtf8): integer;
+begin
+  result := fValue^.AddItemText(value, position);
+end;
+
+function TDocList.ObjectsDictDynArray: IDocDictDynArray;
+var
+  n, i: PtrInt;
+  p: PVariant;
+  dv: PDocVariantData;
+begin
+  result := nil;
+  n := fValue^.Count;
+  if n = 0 then
+    exit;
+  p := pointer(fValue^.VValue);
+  i := 0;
+  repeat
+    if _SafeObject(p^, dv) then
+    begin
+      if result = nil then
+        SetLength(result, n); // allocate only when needed
+      result[i] := TDocDict.CreateByRef(dv);
+      inc(i);
+    end;
+    inc(p);
+    dec(n);
+  until n = 0;
+  if i <> 0 then
+    DynArrayFakeLength(result, i); // no realloc
+end;
+
+function TDocList.Pop(position: integer): variant;
+begin
+  if not fValue^.Extract(position, result) then
+    raise EDocList.CreateUtf8('Pop index % out of range', [position]);
+end;
+
+function TDocList.PopItem(out value: variant; position: integer): boolean;
+begin
+  result := fValue^.Extract(position, value);
+end;
+
+function TDocList.PopItem(out value: IDocDict; position: integer): boolean;
+begin
+  result := false;
+  if position < 0 then
+    inc(position, fValue^.Count);
+  if (cardinal(position) >= cardinal(fValue^.Count)) or
+     not _Safe(fValue^.VValue[position]).IsObject then
+    exit;
+  value := TDocDict.CreateOwned;
+  result := fValue^.Extract(position, PVariant(value.Value)^);
+end;
+
+function TDocList.Del(position: integer): boolean;
+begin
+  if position < 0 then
+    inc(position, fValue^.Count);
+  result := fValue^.Delete(position);
+end;
+
+function TDocList.Reduce(const keys: array of RawUtf8): IDocList;
+begin
+  result := DocList(Model);
+  fValue^.Reduce(keys, fValue^.IsCaseSensitive, result.Value^);
+end;
+
+function TDocList.Remove(const value: variant): integer;
+begin
+  result := fValue^.SearchItemByValue(value);
+  if result >= 0 then
+    fValue^.Delete(result);
+end;
+
+function TDocList.Remove(const value: RawUtf8; caseinsensitive: boolean): integer;
+begin
+  result := Index(value, caseinsensitive);
+  if result >= 0 then
+    fValue^.Delete(result);
+end;
+
+procedure TDocList.Reverse;
+begin
+  fValue^.Reverse;
+end;
+
+procedure TDocList.Sort(reverse: boolean; compare: TVariantCompare);
+begin
+  fValue^.SortByValue(compare, reverse);
+end;
+
+procedure TDocList.SortByKeyValue(const key: RawUtf8; reverse: boolean;
+  compare: TVariantCompare);
+begin
+  fValue^.SortArrayByField(key, compare, reverse);
+end;
+
+procedure TDocList.SortByKeyValue(const keys: array of RawUtf8;
+  reverse: boolean; compare: TVariantCompare);
+begin
+  fValue^.SortArrayByFields(keys, compare, nil, reverse);
+end;
+
+function TDocList.Filter(const key: RawUtf8; const value: variant;
+  limit: integer; match: TCompareOperator; compare: TVariantCompare): IDocList;
+begin
+  result := TDocList.CreateOwned;
+  fValue^.ReduceFilter(key, value, match, compare, limit, result.Value^);
+end;
+
+function TDocList.Filter(const expression: RawUtf8): IDocList;
+begin // no limit here to avoid confusion between overloads
+  result := TDocList.CreateOwned;
+  fValue^.ReduceFilter(expression, result.Value^);
+end;
+
+function TDocList.Filter(const expression: RawUtf8; const value: variant;
+  limit: integer): IDocList;
+begin
+  result := TDocList.CreateOwned;
+  fValue^.ReduceFilter(expression, value, result.Value^, nil, limit);
+end;
+
+function TDocList.First(const expression: RawUtf8): variant;
+begin
+  result := fValue^.ReduceFilter(expression, {limit=} 1);
+end;
+
+function TDocList.First(const expression: RawUtf8; const value: variant): variant;
+begin
+  result := fValue^.ReduceFilter(expression, value, {limit=} 1);
+end;
+
+{$ifdef HASIMPLICITOPERATOR}
+
+function TDocList.GetV(position: integer): TDocValue;
+begin
+  result.V := ValueAt(position);
+end;
+
+procedure SetValueEnumerator(dv: PDocVariantData; var res: TDocValueEnumerator);
+  {$ifdef HASINLINE} inline; {$endif}
+var
+  v: PVariant;
+begin
+  v := pointer(dv^.VValue);
+  res.Curr.V := v;
+  res.After.V := v;
+  if v = nil then
+    exit;
+  inc(res.After.V, dv^.VCount);
+  dec(res.Curr.V); // for the first MoveNext
+end;
+
+function TDocList.GetEnumerator: TDocValueEnumerator;
+begin
+  SetValueEnumerator(fValue, result{%H-}); // shared with IDocDict.Values
+end;
+
+function TDocList.Range(start, stop: integer): TDocValueEnumerator;
+var
+  v: PVariant;
+begin
+  result.Curr.V := nil;
+  result.After.V := nil; // ensure MoveNext=false on void range
+  if DocListRangeVoid(start, stop, fValue^.Count) or
+     fValue^.RangeVoid(start, stop) then
+    exit;
+  v := pointer(fValue^.VValue);
+  inc(v, start);
+  dec(v); // for the first MoveNext
+  result.Curr.V := v;
+  inc(v, stop + 1);
+  result.After.V := v;
+end;
+
+function TDocList.Objects: TDocObjectEnumerator;
+var
+  v: PVariant;
+begin
+  v := pointer(fValue^.VValue);
+  result.Curr := v;
+  result.After := v;
+  if v = nil then
+    exit;
+  inc(result.After, fValue^.VCount);
+  dec(result.Curr); // for the first MoveNext
+end;
+
+function TDocList.Objects(const key: RawUtf8; const value: variant;
+  match: TCompareOperator; compare: TVariantCompare): TDocObjectEnumerator;
+begin
+  if key = '' then
+    raise EDocList.Create('Invalid expression on Objects()');
+  result := Objects;
+  result.CompKey := key;
+  result.CompValue := value;
+  if not Assigned(compare) then
+    compare := @VariantCompare;
+  result.CompFunc := compare;
+  result.CompMatch := match;
+  result.CompKeyHasPath := PosExChar('.', key) <> 0;
+  result.CompKeyPrev := -1; // optimistic key search in previous position
+end;
+
+function TDocList.Objects(const expression: RawUtf8): TDocObjectEnumerator;
+var
+  k: RawUtf8;
+  v: variant;
+  m: TCompareOperator;
+begin
+  ParseSortMatch(pointer(expression), k, m, @v);
+  result := Objects(k, v, m, nil);
+end;
+
+function TDocList.Objects(const expression: RawUtf8;
+  const value: variant): TDocObjectEnumerator;
+var
+  k: RawUtf8;
+  m: TCompareOperator;
+begin
+  ParseSortMatch(pointer(expression), k, m, nil);
+  result := Objects(k, value, m, nil);
+end;
+
+{$endif HASIMPLICITOPERATOR}
+
+
+
+
+{ EDocDict }
+
+class procedure EDocDict.Error(method: AnsiChar; const key: RawUtf8; const v: variant);
+begin
+  raise CreateUtf8('%[%] on a var%', [method, key, VariantTypeName(v)^]);
+end;
+
+{ TDocDict }
+
+constructor TDocDict.Create(options: PDocVariantOptions);
+begin
+  OwnedAs(options, dvoIsObject);
+end;
+
+procedure TDocDict.FromJson(var context: TJsonParserContext);
+begin
+  JL_IDocAny(context, fValue, jtObjectStart);
+end;
+
+function TDocDict.GetPathDelim: AnsiChar;
+begin
+  result := fPathDelim;
+end;
+
+procedure TDocDict.SetPathDelim(value: AnsiChar);
+begin
+  fPathDelim := value;
+end;
+
+function TDocDict.Compare(const another: IDocDict; caseinsensitive: boolean): integer;
+begin
+  result := fValue^.Compare(another.Value^, caseinsensitive);
+end;
+
+function TDocDict.Compare(const another: IDocDict;
+  const keys: array of RawUtf8; caseinsensitive: boolean): integer;
+begin
+  result := fValue^.CompareObject(keys, another.Value^, caseinsensitive);
+end;
+
+function TDocDict.GetValueAt(const key: RawUtf8; out value: PVariant): boolean;
+begin
+  if fPathDelim = #0 then
+    value := pointer(fValue^.GetVarData(key, fSorted)) // faster
+  else
+    value := fValue^.GetPVariantByPath(key, fPathDelim);
+  result := value <> nil; // return false if not found
+end;
+
+function TDocDict.GetExistingValueAt(const key, method: RawUtf8): PVariant;
+begin
+  if not GetValueAt(key, result) then
+    if fValue^.Has(dvoReturnNullForUnknownProperty) then
+      result := @DocVariantDataFake
+    else
+      raise EDocDict.CreateUtf8('%[''%''] key not found', [method, key]);
+end;
+
+function TDocDict.ValueAt(const key: RawUtf8): PVariant;
+begin
+  result := GetExistingValueAt(key, 'ValueAt');
+end;
+
+function TDocDict.SetValueAt(const key: RawUtf8; const value: variant): boolean;
+begin
+  if fPathDelim = #0 then
+    result := fValue^.AddOrUpdateValue(key, value) >= 0
+  else
+    result := fValue^.SetValueByPath(key, value, {create=}true, fPathDelim);
+  if result then
+    fSorted := nil;
+end;
+
+function TDocDict.PopAt(const key: RawUtf8; value: PVariant): boolean;
+begin
+  if fPathDelim = #0 then
+    result := fValue.Delete(key, value)
+  else
+    result := fValue.DeleteByPath(key, fPathDelim, value);
+end;
+
+function TDocDict.GetB(const key: RawUtf8): boolean;
+var
+  v: PVariant;
+begin
+  v := GetExistingValueAt(key, 'B');
+  if not VariantToBoolean(v^, result) then
+    EDocDict.Error('B', key, v^);
+end;
+
+function TDocDict.GetC(const key: RawUtf8): currency;
+var
+  v: PVariant;
+begin
+  v := GetExistingValueAt(key, 'C');
+  if not VariantToCurrency(v^, result) then
+    EDocDict.Error('C', key, v^);
+end;
+
+function TDocDict.GetD(const key: RawUtf8): IDocDict;
+begin
+  result := TDocDict.CreateByRef(
+    _Safe(GetExistingValueAt(key, 'D')^, dvObject));
+end;
+
+function TDocDict.GetF(const key: RawUtf8): double;
+var
+  v: PVariant;
+begin
+  v := GetExistingValueAt(key, 'F');
+  if not VariantToDouble(v^, result) then
+    EDocDict.Error('F', key, v^);
+end;
+
+function TDocDict.GetI(const key: RawUtf8): Int64;
+var
+  v: PVariant;
+begin
+  v := GetExistingValueAt(key, 'I');
+  if not VariantToInt64(v^, result) then
+    EDocDict.Error('I', key, v^);
+end;
+
+function TDocDict.GetItem(const key: RawUtf8): variant;
+begin
+  result := GetExistingValueAt(key, 'Item')^;
+end;
+
+function TDocDict.GetL(const key: RawUtf8): IDocList;
+begin
+  result := TDocList.CreateByRef(
+    _Safe(GetExistingValueAt(key, 'B')^, dvArray));
+end;
+
+function TDocDict.GetS(const key: RawUtf8): string;
+begin
+  VariantToString(GetExistingValueAt(key, 'S')^, result);
+end;
+
+function TDocDict.GetU(const key: RawUtf8): RawUtf8;
+begin
+  VariantToUtf8(GetExistingValueAt(key, 'U')^, result);
+end;
+
+procedure TDocDict.SetB(const key: RawUtf8; const value: boolean);
+begin
+  SetValueAt(key, value);
+end;
+
+procedure TDocDict.SetC(const key: RawUtf8; const value: currency);
+begin
+  SetValueAt(key, value);
+end;
+
+procedure TDocDict.SetD(const key: RawUtf8; const value: IDocDict);
+begin
+  if value = nil then
+    EDocDict.Error('D', key, Null);
+  SetValueAt(key, PVariant(value.Value)^)
+end;
+
+procedure TDocDict.SetF(const key: RawUtf8; const value: double);
+begin
+  SetValueAt(key, value);
+end;
+
+procedure TDocDict.SetI(const key: RawUtf8; const value: Int64);
+begin
+  SetValueAt(key, value);
+end;
+
+procedure TDocDict.SetItem(const key: RawUtf8; const value: variant);
+begin
+  SetValueAt(key, value);
+end;
+
+procedure TDocDict.SetL(const key: RawUtf8; const value: IDocList);
+begin
+  if value = nil then
+    EDocDict.Error('D', key, Null);
+  SetValueAt(key, PVariant(value.Value)^)
+end;
+
+procedure TDocDict.SetS(const key: RawUtf8; const value: string);
+var
+  v: variant;
+begin
+  StringToVariant(value, v);
+  SetValueAt(key, v);
+end;
+
+procedure TDocDict.SetU(const key: RawUtf8; const value: RawUtf8);
+var
+  v: variant;
+begin
+  RawUtf8ToVariant(value, v);
+  SetValueAt(key, v);
+end;
+
+function TDocDict.Get(const key: RawUtf8): variant;
+var
+  v: PVariant;
+begin
+  if GetValueAt(key, v) then
+    result := v^
+  else
+    VarClear(result);
+end;
+
+function TDocDict.GetDef(const key: RawUtf8; const default: variant): variant;
+var
+  v: PVariant;
+begin
+  if GetValueAt(key, v) then
+    result := v^
+  else
+    result := default;
+end;
+
+function TDocDict.GetDef(const key: RawUtf8; const default: RawUtf8): variant;
+var
+  v: PVariant;
+begin
+  if GetValueAt(key, v) then
+    result := v^
+  else
+    RawUtf8ToVariant(default, result);
+end;
+
+function TDocDict.Get(const key: RawUtf8; var value: variant): boolean;
+var
+  v: PVariant;
+begin
+  result := GetValueAt(key, v);
+  if result then
+    value := v^;
+end;
+
+function TDocDict.Get(const key: RawUtf8; var value: RawUtf8): boolean;
+var
+  v: PVariant;
+begin
+  result := GetValueAt(key, v);
+  if result then
+    VariantToUtf8(v^, value, {wasstring=}result);
+end;
+
+function TDocDict.Get(const key: RawUtf8; var value: string): boolean;
+var
+  v: PVariant;
+begin
+  result := GetValueAt(key, v);
+  if result then
+    VariantToString(v^, value);
+end;
+
+function TDocDict.Get(const key: RawUtf8; var value: boolean): boolean;
+var
+  v: PVariant;
+begin
+  result := GetValueAt(key, v) and
+            VariantToBoolean(v^, value);
+end;
+
+function TDocDict.Get(const key: RawUtf8; var value: integer): boolean;
+var
+  v: PVariant;
+begin
+  result := GetValueAt(key, v) and
+            VariantToInteger(v^, value);
+end;
+
+function TDocDict.Get(const key: RawUtf8; var value: Int64): boolean;
+var
+  v: PVariant;
+begin
+  result := GetValueAt(key, v) and
+            VariantToInt64(v^, value);
+end;
+
+function TDocDict.Get(const key: RawUtf8; var value: double): boolean;
+var
+  v: PVariant;
+begin
+  result := GetValueAt(key, v) and
+            VariantToDouble(v^, value);
+end;
+
+function TDocDict.Get(const key: RawUtf8; var value: currency): boolean;
+var
+  v: PVariant;
+begin
+  result := GetValueAt(key, v) and
+            VariantToCurrency(v^, value);
+end;
+
+function TDocDict.Get(const key: RawUtf8; var value: IDocList): boolean;
+var
+  v: PVariant;
+  dv: PDocVariantData;
+begin
+  result := GetValueAt(key, v) and
+            _SafeArray(v^, dv);
+  if result then
+    value := TDocList.CreateByRef(dv);
+end;
+
+function TDocDict.Get(const key: RawUtf8; var value: IDocDict): boolean;
+var
+  v: PVariant;
+  dv: PDocVariantData;
+begin
+  result := GetValueAt(key, v) and
+            _SafeObject(v^, dv);
+  if result then
+    value := TDocDict.CreateByRef(dv);
+end;
+
+function TDocDict.Get(const key: RawUtf8; var value: PDocVariantData): boolean;
+var
+  v: PVariant;
+begin
+  result := GetValueAt(key, v) and
+            _Safe(v^, value);
+end;
+
+function TDocDict.Copy: IDocDict;
+var
+  v: TDocDict;
+begin
+  v := TDocDict.CreateCopy(fValue^);
+  v.fPathDelim := fPathDelim; // also include additional parameters
+  v.fSorted := fSorted;
+  result := v;
+end;
+
+function TDocDict.Del(const key: RawUtf8): boolean;
+begin
+  result := PopAt(key, nil);
+end;
+
+function TDocDict.Exists(const key: RawUtf8): boolean;
+begin
+  if fPathDelim = #0 then
+    result := fValue^.GetVarData(key, fSorted) <> nil // faster
+  else
+    result := fValue^.GetPVariantByPath(key, fPathDelim) <> nil;
+end;
+
+function TDocDict.Pop(const key: RawUtf8): variant;
+begin
+  if not PopAt(key, @result) then
+    raise EDocDict.CreateUtf8('Pop with unknown key [%]', [key]);
+end;
+
+function TDocDict.Pop(const key: RawUtf8; const default: variant): variant;
+begin
+  if not PopAt(key, @result) then
+    result := default;
+end;
+
+function TDocDict.PopItem(out key: RawUtf8; out value: variant;
+  position: integer): boolean;
+begin
+  result := fValue^.Extract(position, value, @key);
+end;
+
+function TDocDict.Reduce(const keys: array of RawUtf8): IDocDict;
+begin
+  result := TDocDict.CreateOwned;
+  fValue^.Reduce(keys, fValue^.IsCaseSensitive, result.Value^);
+end;
+
+function TDocDict.SetDefault(const key: RawUtf8): variant;
+begin
+  result := SetDefault(key, Null);
+end;
+
+function TDocDict.SetDefault(const key: RawUtf8; const default: variant): variant;
+begin
+  if Get(key, result) then
+    exit;
+  SetValueAt(key, default);
+  result := default;
+end;
+
+procedure TDocDict.Sort(reverse: boolean; keycompare: TUtf8Compare);
+begin
+  if not Assigned(keycompare) then
+    keycompare := StrCompByCase[fValue^.IsCaseSensitive];
+  fValue^.SortByName(keycompare, reverse);
+  if reverse then
+    fSorted := nil
+  else
+    fSorted := keycompare; // for O(log(n)) binary search on key lookup
+end;
+
+procedure TDocDict.Update(const key: RawUtf8; const value: variant);
+begin
+  SetValueAt(key, value);
+end;
+
+procedure TDocDict.Update(const keyvalues: array of const);
+begin
+  fValue^.Update(keyvalues);
+end;
+
+procedure TDocDict.Update(const source: IDocDict; addonlymissing: boolean);
+begin
+  if source <> nil then
+    fValue^.AddOrUpdateFrom(PVariant(source.Value)^, addonlymissing);
+end;
+
+{$ifdef HASIMPLICITOPERATOR}
+
+function TDocDict.GetV(const key: RawUtf8): TDocValue;
+begin
+  result.V := GetExistingValueAt(key, 'V');
+end;
+
+function TDocDict.GetEnumerator: TDocDictEnumerator;
+var
+  v: PVariant;
+begin
+  v := pointer(fValue^.VValue);
+  result.Curr.Value.V := v;
+  result.AfterValue.V := v;
+  if v = nil then
+    exit;
+  inc(result.AfterValue.V, fValue^.VCount);
+  result.Curr.Key.V := pointer(fValue^.VName);
+  dec(result.Curr.Value.V); // for the first MoveNext
+  dec(result.Curr.Key.V);
+end;
+
+function TDocDict.Keys: TDocKeyEnumerator;
+var
+  v: PRawUtf8;
+begin
+  v := pointer(fValue^.VName);
+  result.Curr.V := v;
+  result.After.V := v;
+  if v = nil then
+    exit;
+  inc(result.After.V, fValue^.VCount);
+  dec(result.Curr.V); // for the first MoveNext
+end;
+
+function TDocDict.Values: TDocValueEnumerator;
+begin
+  SetValueEnumerator(fValue, result{%H-}); // shared with IDocList
+end;
+
+{$endif HASIMPLICITOPERATOR}
+
+procedure InitializeVariantsJson;
+begin
+  // called from mormot.core.json once TRttiJson is set as global RTTI class
+  TDocList.RegisterToRtti(TypeInfo(IDocList));
+  TDocDict.RegisterToRtti(TypeInfo(IDocDict));
+end;
+
+
+var
+  // naive but efficient type cache - e.g. for TBsonVariant or TQuickJsVariant
+  LastDispInvoke: TSynInvokeableVariantType;
+
+// sysdispinvoke() replacement to meet TSynInvokeableVariantType expectations
+procedure NewDispInvoke(Dest: PVarData;
+{$ifdef FPC_VARIANTSETVAR}
+  var Source: TVarData;
+{$else} // see http://mantis.freepascal.org/view.php?id=26773
+  const Source: TVarData; // "[ref] const" on modern Delphi
+{$endif FPC_VARIANTSETVAR}
+  CallDesc: PCallDesc; Params: pointer); cdecl;
+// warning: Delphi OSX64 LINUX ANDROID64 expects Params := @VAList
+var
+  v: TVarData;
+  vp: PVariant;
+  t: cardinal;
+  ct: TSynInvokeableVariantType;
+label
+  direct;
+begin
+  t := Source.vType;
+  if t = varVariantByRef then
+    NewDispInvoke(Dest, PVarData(Source.VPointer)^, calldesc, params)
+  else
+  begin
+    TRttiVarData(v).VType := varEmpty;
+    vp := @v;
+    if Dest = nil then
+      vp := nil;
+    ct := nil;
+    try
+      case t of
+        varDispatch,
+        varAny,
+        varUnknown,
+        varDispatch or varByRef,
+        varAny or varByRef,
+        varUnknown or varByRef:
+          if Assigned(VarDispProc) and
+             Assigned(VarCopyProc) then
+            // standard Windows ComObj unit call
+            VarDispProc(vp, variant(Source), CallDesc, Params)
+          else
+            VarInvalidOp;
+        CFirstUserType .. varTypeMask:
+          begin
+            ct := DocVariantType; // recognize our TDocVariant
+            if t = ct.VarType then
+              goto direct;
+            ct := LastDispInvoke; // atomic pointer load
+            if (ct <> nil) and
+               (ct.VarType = t) then
+              // most calls are grouped within the same custom variant type
+              goto direct;
+            // FindCustomVariantType() is O(1) but has a global lock
+            if FindCustomVariantType(t, TCustomVariantType(ct)) then
+              if ct.InheritsFrom(TSynInvokeableVariantType) then
+              begin
+                // direct access of our custom variants without any temp copy
+                LastDispInvoke := ct;
+direct:         if Dest <> nil then
+                  VarClear(PVariant(Dest)^); // no temp copy, but Dest cleanup
+                ct.DispInvoke(Dest, Source, CallDesc, Params);
+                Dest := nil;
+              end
+              else if ct.InheritsFrom(TInvokeableVariantType) then
+                // use standard RTL behavior for non-mORMot custom variants
+                ct.DispInvoke(pointer(vp), Source, CallDesc, Params)
+              else
+                VarInvalidOp
+            else
+              VarInvalidOp;
+          end;
+      else
+        VarInvalidOp;
+      end;
+    finally
+      if Dest <> nil then
+      begin
+        if (ct <> nil) and
+           (v.VType = ct.VarType) then // don't search twice if we got it
+          ct.Copy(Dest^, v, {indirect=}false)
+        else
+          VarCopyProc(Dest^, v);
+        VarClear(vp^);
+      end;
+    end;
+  end;
+end;
+
+const
+  // _CMP2SORT[] comparison of simple types - as copied to _VARDATACMP[]
+  _VARDATACMPNUM1: array[varEmpty..varDate] of byte = (
+    1, 1, 2, 3, 4, 5, 6, 7);
+  _VARDATACMPNUM2: array[varShortInt..varWord64] of byte = (
+    8, 9, 10, 11, 12, 13);
+
+procedure InitializeUnit;
+var
+  vm: TVariantManager; // available since Delphi 7
+  vt: cardinal;
+  ins: boolean;
+  i: PtrUInt;
+  {$ifdef FPC}
+  test: variant;
+  {$endif FPC}
+begin
+  // register the TDocVariant custom type
+  DocVariantType := TDocVariant(SynRegisterCustomVariantType(TDocVariant));
+  vt := DocVariantType.VarType;
+  DocVariantVType := vt;
+  PCardinal(@DV_FAST[dvUndefined])^ := vt;
+  PCardinal(@DV_FAST[dvArray])^ := vt;
+  PCardinal(@DV_FAST[dvObject])^ := vt;
+  assert({%H-}SynVariantTypes[0].VarType = vt);
+  PDocVariantData(@DV_FAST[dvUndefined])^.VOptions := JSON_FAST;
+  PDocVariantData(@DV_FAST[dvArray])^.VOptions := JSON_FAST + [dvoIsArray];
+  PDocVariantData(@DV_FAST[dvObject])^.VOptions := JSON_FAST + [dvoIsObject];
+  // FPC allows to define variables with absolute JSON_[...] but Delphi doesn't
+  JSON_FAST_STRICT := JSON_[mFastStrict];
+  JSON_FAST_EXTENDED := JSON_[mFastExtended];
+  JSON_FAST_EXTENDEDINTERN := JSON_[mFastExtendedIntern];
+  JSON_NAMEVALUE := PDocVariantOptionsBool(@JSON_[mNameValue])^;
+  JSON_NAMEVALUEINTERN := PDocVariantOptionsBool(@JSON_[mNameValueIntern])^;
+  JSON_OPTIONS := PDocVariantOptionsBool(@JSON_[mDefault])^;
+  // redirect to the feature complete variant wrapper functions
+  BinaryVariantLoadAsJson := _BinaryVariantLoadAsJson;
+  VariantClearSeveral := _VariantClearSeveral;
+  _VariantSaveJson := @__VariantSaveJson;
+  SortDynArrayVariantComp := pointer(@FastVarDataComp);
+  // setup FastVarDataComp() efficient lookup comparison functions
+  for ins := false to true do
+  begin
+    for i := low(_VARDATACMPNUM1) to high(_VARDATACMPNUM1) do
+      _VARDATACMP[i, ins] := _VARDATACMPNUM1[i];
+    _VARDATACMP[varBoolean, ins] := 14;
+    for i := low(_VARDATACMPNUM2) to high(_VARDATACMPNUM2) do
+      _VARDATACMP[i, ins] := _VARDATACMPNUM2[i];
+  end;
+  _VARDATACMP[varString, false] := 15;
+  _VARDATACMP[varString, true]  := 16;
+  _VARDATACMP[varOleStr, false] := 17;
+  _VARDATACMP[varOleStr, true]  := 18;
+  {$ifdef HASVARUSTRING}
+  _VARDATACMP[varUString, false] := 17;
+  _VARDATACMP[varUString, true]  := 18;
+  {$endif HASVARUSTRING}
+  // patch DispInvoke for performance and to circumvent RTL inconsistencies
+  GetVariantManager(vm);
+  vm.DispInvoke := NewDispInvoke;
+  SetVariantManager(vm);
+  {$ifdef FPC}
+  // circumvent FPC 3.2+ inverted parameters order - may be fixed in later FPC
+  test := _ObjFast([]);
+  try
+    test.Add('nam', 'val'); // late binding DispInvoke() call
+    DispInvokeArgOrderInverted := (_Safe(test)^.Names[0] = 'val');
+  except // paranoid to avoid fatal exception during process initialization
+  end;
+  {$endif FPC}
+end;
+
+
+initialization
+  InitializeUnit;
+
+end.
+
diff --git a/lib/dmustache/mormot.defines.inc b/lib/dmustache/mormot.defines.inc
new file mode 100644
index 00000000..5a4378d0
--- /dev/null
+++ b/lib/dmustache/mormot.defines.inc
@@ -0,0 +1,790 @@
+{
+  This file is a part of the Open Source Synopse mORMot framework 2,
+  licensed under a MPL/GPL/LGPL three license - see LICENSE.md
+
+  Define a centralized set of conditional defines, included in all our
+  framework units, and could be used also for your own private units.
+}
+
+
+(********************** User-Trigerred Conditionals **********************)
+
+{  Those conditionals below can be enabled in your project Options,
+   to tune the compilation depending your setup or your project expectations. }
+
+{.$define USEPACKAGES}
+// define this if you compile the unit within a Delphi package
+// - it will avoid error like "[DCC Error] E2201 Need imported data reference
+// ($G) to access 'VarCopyProc'"
+// - shall be set at the package options level, and left untouched by default
+// - note: you should probably also set "Generate DCUs only" in Project Options
+// -> Delphi Compiler -> Output C/C++ -> C/C++ output file generation
+
+{.$define PUREMORMOT2}
+// if defined, no mORMot 1.18 compatilibity types nor functions would be enabled
+// - by default, existing projects should (almost) compile with mORMot 2
+// - you should eventually define this conditional to make a perfect code
+// conversion to the new types and methods definitions
+
+{.$define NEWRTTINOTUSED}
+// if defined, the new RTTI (available since Delphi 2010) won't be linked to
+// the executable: resulting file size will be much smaller, and mORMot won't
+// be affected (unless you use the enhanced RTTI for record/dynamic array JSON
+// serialization) - left undefined by default to ensure minimal impact
+
+{.$define FPCUSEVERSIONINFO}
+// link low-level fileinfo/machoreader/elfreader for TFileVersion/TExeVersion
+// from mormot.core.os.pas => disabled by default, to preserve code size
+
+{.$define NOSETTHREADNAME}
+// if defined, SetThreadName() would not raise the exception used to set the
+// thread name: to be defined if you have issues when debugging your application
+
+{.$define NODIRECTTHREADMANAGER}
+// on POSIX, omit direct GetThreadManager() API calls and just use RTL functions
+
+{.$define NOEXCEPTIONINTERCEPT}
+// if defined, exceptions shall not be intercepted nor logged
+
+{.$define NOPATCHVMT}
+// disable the vmtAutoTable slot runtime patch, replacing it with Rtti.FindType
+// - is likely to be defined with the NOPATCHRTL conditional
+// - could be used e.g. when in-memory executables can't be patched (e.g. on
+// security constrained systems, or on OS without any mmap support)
+
+{.$define NOPATCHRTL}
+// if defined, FPC RTL won't be patched on x86_64 with optimized asm
+// - is likely to be defined with the NOPATCHVMT conditional
+// - you can enable it if you find out some compatibility problem
+
+{$ifdef CPUX86}
+  {.$define HASNOSSE2} // force x87 code on very very old CPU
+{$endif CPUX86}
+
+{.$define NOSYNDBZEOS}
+// make mormot.db.sql.zeos.pas a "void" unit - defined for FPC/Lazarus packages only
+
+{.$define NOSYNDBIBX}
+// make mormot.db.sql.ibx.pas a "void" unit - defined for FPC/Lazarus packages only
+
+{.$define MONGO_OLDPROTOCOL}
+// may be used with old MongoDB instances < 3.6 with no OP_MSG in Wire protocol
+
+{.$define DISABLEAPPSQL}
+// mormot.db.sql external DB won't be linked to the executable by mormot.app
+
+{.$define DISABLEAPPNOSQL}
+// Mongo DB client won't be linked to the executable by mormot.app
+
+{.$define NOSSPIAUTH}
+// disable Windows mormot.lib.sspi support in mormot.rest.client/server units
+
+{.$define NOGSSAPIAUTH}
+// disable Posix mormot.lib.gsssapi support in mormot.rest.client/server units
+
+{.$define NOPOINTEROFFSET}
+// disable TOrmTable offsets on 64-bit if your memory is huge or fragmented
+// note: FPCMM_MEDIUM32BIT may need this for data >256KB
+
+{.$define NOTORMTABLELEN}
+// disable TOrmTable internal fLen[] pre-computed table - slower but less memory
+
+{.$define NOSQLITE3STATIC}
+// disable static SQlite3 linking - to force use external dll/so library
+
+{.$define NOSQLITE3FPUSAVE}
+// disable SetFpuFlags() calls during SQlite3 engine - may enhance performance
+
+{.$define DEBUGSTORAGELOCK}
+// could be defined to force verbose log of StorageLock/StorageUnLock
+
+{.$define DEBUGSQLVIRTUALTABLE}
+// could be defined to force verbose log of SQlite3 virtual table query planner costs
+
+{.$define ONLYUSEHTTPSOCKET}
+// is defined on POSIX but may be enabled on Windows if socket+SChannel is enough
+
+{.$define OLDLIBC}
+// use only oldest libc API, e.g. accept() instead of accept4()
+
+{.$define OLDLINUXKERNEL}
+// use only oldest Linux syscalls - as in FPC RTL
+
+{.$define USE_OPENSSL}
+// is defined on POSIX (with late binding) but may be enabled on Windows too
+
+{.$define USELIBCURL}
+// define cross-platform libcurl for https
+// (when our native socket+OpenSSL/SChannel doesn't seem to be good enough)
+
+{.$define LIBCURLMULTI}
+// enable the more advanced "multi session" API functions of mormot.lib.curl
+// see https://curl.haxx.se/libcurl/c/libcurl-multi.html interface
+
+
+{$ifdef FPC}
+
+(********************** FPC Conditionals **********************)
+
+  // -----------
+  // -- global code generation conditionals
+
+  // note: you may remove all unexpexted hints by setting in your project options
+  // -vm11047,6058,5092,5091,5060,5058,5057,5028,5024,5023,4081,4079,4055,3187,3124,3123
+
+  // disable some no-brainer warnings - let FPC align with Delphi in that matter
+  {$WARN 5089 off} // uninitialized managed variables 1
+  {$WARN 5091 off} // uninitialized managed variables 2
+  {$WARN 5093 off} // function result variable of a managed uninitialized 1
+  {$WARN 5094 off} // function result variable of a managed uninitialized 2
+  {$WARN 6058 off} // call to subroutine marked as inline is not inlined
+
+  {$ifndef FPC_DELPHI}
+    {$MODE DELPHI} // e.g. for asm syntax - disabled for FPC 2.6 compatibility
+  {$endif FPC_DELPHI}
+
+  {$INLINE ON}
+  {$MINENUMSIZE 1}
+  {$PACKRECORDS DEFAULT} // force normal alignment
+  {$PACKSET 1}
+  {$PACKENUM 1}
+  {$CODEPAGE UTF8} // otherwise unexpected behavior occurs in most cases
+  {$OBJECTCHECKS OFF} // as expected e.g. when hooking classes
+
+  {$define HASINLINE}
+  {$define HASINLINEWINAPI} // Delphi has troubles inlining Windows API calls
+  {$define HASSAFEINLINE}   // Delphi 2007-2009 have troubles inlining
+  {$define NODELPHIASM}     // avoid e.g. low-level System.@LStrFromPCharLen
+  {$define HASDYNARRAYTYPE} // eltype2 field, used e.g. for T*ObjArray
+  {$define HASITERATORS}
+  {$define HASIMPLICITOPERATOR}
+  {$define HASDBFTWIDE}
+  {$define HASTTHREADSTART}
+  {$define HASINTERFACEASTOBJECT}
+  {$define EXTENDEDTOSHORT_USESTR} // FloatToText uses str() in FPC
+  {$define DOUBLETOSHORT_USEGRISU} // fast DoubleToAscii()
+  {$define USERECORDWITHMETHODS}   // use "object" only for Delphi 7
+  {$define FPC_OR_UNICODE}
+  {$define FPC_OR_DELPHIXE}        // to circumvent Delphi internal errors
+  {$define FPC_OR_DELPHIXE4}
+
+
+  // -----------
+  // -- identify FPC versions
+
+  // $if FPC_FULLVERSION>20700 breaks Delphi 6-7 and SynProject :(
+  {$ifdef VER2_7}
+    {$define ISFPC27}
+  {$endif VER2_7}
+  {$ifdef VER3_0}
+    {$define ISFPC27}
+    {$define ISFPC30}
+    {$define HASDIRECTTYPEINFO}
+    // PTypeInfo would be stored with no pointer de-reference
+    // => Delphi and newer FPC uses a pointer reference to ease exe linking
+  {$endif VER3_0}
+  {$ifdef VER3_1} // trunk before 3.2
+    {$define ISFPC27}
+    {$define ISFPC30}
+    {.$define HASDIRECTTYPEINFO}
+    // define this for trunk revisions older than June 2016 - see
+    // http://wiki.freepascal.org/User_Changes_Trunk#RTTI_Binary_format_change
+  {$endif VER3_1}
+  {$ifdef VER3_1_1}
+    {$define ISFPC32}
+  {$endif VER3_1_1}
+  {$ifdef VER3_2}
+    {$define ISFPC27}
+    {$define ISFPC30}
+    {$define ISFPC32}
+    {$define HASGETTYPEKIND}
+    {$ifdef VER3_2_2}
+      {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet
+    {$endif VER3_2_2}
+    {$ifdef VER3_2_3}
+      {$define HASTTHREADTERMINATESET}
+    {$endif VER3_2_3}
+  {$endif VER3_2}
+  {$ifdef VER3_3} // trunk before 3.2
+    {$define ISFPC27}
+    {$define ISFPC30}
+    {$define ISFPC32}
+    {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet
+  {$endif VER3_3}
+  {$ifdef VER3_4}
+    {$define ISFPC27}
+    {$define ISFPC30}
+    {$define ISFPC32}
+    {$define ISFPC34}
+    {$define FPC_PROVIDE_ATTR_TABLE} // introducing TTypeData.AttributeTable
+    {$define STRCNT32}               // 32-bit TAnsiRec.Ref even on 64-bit CPU
+    // see https://gitlab.com/freepascal.org/fpc/source/-/issues/38018
+    {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet
+  {$endif VER3_4}
+  {$if not defined(VER3_0) and not defined(VER3_2) and not defined(VER2)}
+    {.$define FPC_PROVIDE_ATTR_TABLE} // to be defined since SVN 42356-42411
+    // on compilation error in mormot.core.Rtti, undefine the above conditional
+    // see https://lists.freepascal.org/pipermail/fpc-announce/2019-July/000612.html
+    {$define STRCNT32} // new trunk feature: 32-bit TAnsiRec.Ref even on 64-bit CPU
+  {$ifend}
+
+
+  // -----------
+  // -- identify Operating Systems
+
+  // mainly OSWINDOWS or OSPOSIX (OSLINUX, OSBSD, OSDARWIN, OSANDROID)
+
+  {$ifdef MSWINDOWS}
+    // conditionals for Windows
+    {$define OSWINDOWS}
+    {$define FPCWINDOWS}
+  {$else}
+    {$define OSPOSIX} // a POSIX/BSD system
+    {$define FPCPOSIX}
+    {$ifdef BSD}
+      // conditionals for Darwin and BSD family like OpenBSD/FreeBSD
+      {$define OSBSDDARWIN}     // OSBSDDARWIN = OSBSD + OSDARWIN
+      {$ifdef DARWIN}
+        {$define OSDARWIN}
+        {$define FPCDARWIN}
+        {$ifdef CPUINTEL}
+          {$define FPC_PIC}     // may have not be defined in compiler options
+        {$endif CPUINTEL}
+        {$define NOPATCHRTL}    // don't mess with asm stuff
+        {$define DISABLE_SSE42} // circumvent clang asm bugs
+      {$else}
+        {$define OSBSD}         // OSX has some non-standard API calls
+        {$define FPCBSD}
+        {$ifdef OPENBSD}
+          {$define OSOPENBSD}   // OSBDS = OSOPENBSD + OSFREEBSD
+          {$ifdef CPUX86}
+            {$define FPC_PIC}
+          {$endif CPUX86}
+        {$endif OPENBSD}
+        {$ifdef FREEBSD}
+          {$define OSFREEBSD}
+        {$endif FREEBSD}
+      {$endif DARWIN}
+    {$else}
+      {$ifdef LINUX}
+        // conditionals for Linux
+        {$define OSLINUX}       // e.g. to disable epoll API
+        {$define FPCLINUX}
+        {$define OSLINUXANDROID}
+        {$ifdef CPUX64}
+          {$define OSLINUXINTEL}
+          {$define OSLINUXX64}
+        {$endif CPUX64}
+        {$ifdef CPUX86}
+          {$define OSLINUXINTEL}
+          {$define OSLINUXX86}
+        {$endif CPUX86}
+      {$else}
+        {$ifdef ANDROID}
+          // conditionals for Android
+          {$define OSANDROID}
+          {$define FPCANDROID}
+          {$define OSLINUXANDROID}
+          {$define NOPATCHRTL}  // don't mess with asm stuff
+          {$ifdef CPUX86}
+            {$define FPC_PIC}
+          {$endif CPUX86}
+          {$ifdef CPUAARCH64}
+            {$define OSANDROIDARM64}
+          {$endif CPUAARCH64}
+        {$else}
+        'Unsupported Operating System - yet'
+        {$endif ANDROID}
+      {$endif LINUX}
+    {$endif BSD}
+  {$endif MSWINDOWS}
+
+
+  // -----------
+  // -- identify CPU Architectures
+
+  {$define FPC_SINGLEABI}      // only on i386 default ABI <> cdecl
+  {$ifdef CPU64}
+    // 64-bit Architecture
+    {$define FPC_64}
+    {$ifdef CPUX64}
+      {$ASMMODE INTEL}         // as Delphi expects
+      {$define CPUINTEL}
+      {$define FPC_CPUINTEL}
+      {$define FPC_CPUX64}
+      {$ifndef OSDARWIN}       // MachOS has troubles with our asm
+        {$define FPC_ASMX64}
+        {$define ASMX64}       // supports asm with globals
+        {$define ASMINTEL}     // either ASMX86 or ASMX64
+        {$define ASMX64AVX}    // supports AVX/AVX2/AVX512
+        {$define ASMX64AVXNOCONST} // supports AVX with no align32 constant load
+        {$define CPUX64ASM}    // FPC has no problem (not Delphi prior XE7)
+        {$define HASAESNI}     // mormot.crypt.core rejected by Darwin asm
+      {$endif OSDARWIN}
+    {$endif CPUX64}
+    {$ifdef CPUAARCH64}
+      {$define CPUARM3264}
+    {$endif CPUAARCH64}
+  {$else}
+    // 32-bit Architecture
+    {$define FPC_32}
+    {$ifdef CPUX86}
+      {$ASMMODE INTEL}         // as Delphi expects
+      {$define CPUINTEL}
+      {$define FPC_CPUINTEL}
+      {$define FPC_X86}
+      {$ifndef FPC_PIC}        // MachOS/OpenBSD/Android require PIC on i386
+        {$define ASMX86}       // supports asm with globals
+        {$define ASMINTEL}     // either ASMX86 or ASMX64
+        {$define CPUX86NOTPIC} // use "absolute" instead of local register
+        {$define HASAESNI}
+      {$endif FPC_PIC}
+      {$define TSYNEXTENDED80} // only 32-bit has a true x87 extended type
+      {$undef FPC_SINGLEABI}   // on i386, cdecl <> register convention
+    {$endif CPUX86}
+    {$ifdef CPUARM}
+      {$define CPUARM3264}
+    {$endif CPUARM}
+    {$define STRCNT32}         // 32-bit TAnsiRec.Ref
+    {$define DACNT32}          // 32-bit TDynArrayRec.refCnt
+  {$endif CPU64}
+  {$ifndef CPUX64}
+    {$undef FPC_X64MM}         // x86_64 only unit
+  {$endif CPUX64}
+
+
+  // -----------
+  // -- compiler-specific code generation conditionals
+
+  {$ifdef ISFPC32}
+    // FPC has its own RTTI layout only since late 3.x
+    {$define FPC_NEWRTTI}
+    // when http://bugs.freepascal.org/view.php?id=26774 has been fixed
+    {$define HASINTERFACERTTI}
+    // generics support seems good in FPC 3.2+ but triggers linking issues
+    {$define HASGENERICS}
+    {$define ORMGENERICS}
+    {$define FPCGENERICS}
+  {$endif}
+  // FPC generics (aka parameterized types) are available since 2.6
+  {$define HASGENERICSSYNTAX}
+
+  {$ifdef FPC_NEWRTTI}
+    {$define ISDELPHI2010_OR_FPC_NEWRTTI}
+  {$else}
+    {$define DELPHI_OR_FPC_OLDRTTI}
+    {$define FPC_OLDRTTI}
+  {$endif}
+
+  {$ifdef FPC_HAS_CPSTRING}
+    // see http://wiki.freepascal.org/FPC_Unicode_support
+    {$define HASCODEPAGE} // UNICODE means {$mode delphiunicode}
+  {$endif FPC_HAS_CPSTRING}
+
+  {$ifdef ISFPC27}
+    {$define ISFPC271}
+    {$define HASVARUSTRING}
+    {$define HASVARUSTRARG}
+    // defined if the http://mantis.freepascal.org/view.php?id=26773 bug is fixed
+    // you should use 2.7.1/trunk branch in revision 28995 from 2014-11-05T22:17:54
+    // => this will change the TInvokeableVariantType.SetProperty() signature
+    {$define FPC_VARIANTSETVAR}
+  {$endif ISFPC27}
+
+  {$if defined(FPC_USE_WIN32_SEH) or defined(FPC_USE_WIN64_SEH)}
+    {.$define HASFASTTRYFINALLY}
+    // FPC SEH is not fully efficient and generate some additional code/calls
+  {$ifend}
+
+{$else FPC}
+
+(********************** Delphi Conditionals **********************)
+
+  {$ifndef MSWINDOWS}
+  'Kylix or Delphi for MacOS/Linux/Mobile are unsupported'
+  '-> we recommend using FPC for POSIX platforms'
+  {$endif MSWINDOWS}
+
+  {$define OSWINDOWS}
+
+  {$ifndef CONDITIONALEXPRESSIONS}
+  'Delphi 2-5 are not supported'
+  {$endif CONDITIONALEXPRESSIONS}
+  {$ifdef VER140}
+  'Delphi 6 is not supported'
+  {$endif VER140}
+
+  {$A+} // force normal alignment, as expected by our units
+
+  {$ifdef UNICODE}
+    {$define HASVARUSTRING}
+    {$define HASCODEPAGE}
+    {$define FPC_OR_UNICODE}
+    {$define USERECORDWITHMETHODS}
+    {$define HASGENERICSSYNTAX}     // Delphi 2009+ compiler has TArray<>
+    { due to a bug in Delphi 2009+, we need to fake inheritance of record,
+      since TDynArrayHashed = object(TDynArray) fails to initialize
+      http://blog.synopse.info/post/2011/01/29/record-and-object-issue-in-Delphi-2010 }
+    {$define UNDIRECTDYNARRAY}
+  {$else}
+    {$define HASNOSTATICRTTI}        // Delphi 7/2007 has no TypeInfo(TGuid)
+  {$endif}
+
+  {$define ISDELPHI}
+  {$define CPUINTEL}          // Delphi only for Intel by now
+  {$define ASMINTEL}          // either ASMX86 or ASMX64
+  {$undef FPC_X64MM}          // FPC only unit
+  {$ifdef CPUX64}
+    {$undef CPU32}
+    {$define CPU64}           // Delphi compiler for 64 bit CPU
+    {$define CPU64DELPHI}
+    {$define ASMX64}          // supports asm with globals
+    {$define EXTENDEDTOSHORT_USESTR} // FloatToText() slower in Delphi Win64
+    {$define DOUBLETOSHORT_USEGRISU} // fast DoubleToAscii() - not Delphi Win32
+  {$else CPUX64}
+    {$define CPU32}           // Delphi compiler for 32 bit CPU
+    {$undef CPU64}
+    {$define CPU32DELPHI}
+    {$define CPUX86}          // for compatibility with older versions of Delphi
+    {$define ASMX86}          // supports asm with globals
+    {$define CPUX86NOTPIC}    // use "absolute" instead of local register
+    {$define TSYNEXTENDED80}  // only 32-bit has a true x87 extended type
+  {$endif CPUX64}
+
+  {$define DELPHI_OR_FPC_OLDRTTI}
+  {$define HASINTERFACERTTI}  // interface RTTI (not oldest FPC)
+  {$define HASFASTTRYFINALLY} // Delphi Win32/Win64 efficiently uses SEH
+  {$define STRCNT32}          // 32-bit TStrRec.refCnt even on 64-bit CPU
+  {$define DACNT32}           // 32-bit TDynArrayRec.refCnt even on 64-bit CPU
+  {$warn UNSAFE_CODE OFF}     // Delphi for .Net does not exist any more!
+  {$warn UNSAFE_TYPE OFF}
+  {$warn UNSAFE_CAST OFF}
+  {$warn DUPLICATE_CTOR_DTOR OFF} // avoid W1029 unneeded hints
+  {$warn SYMBOL_PLATFORM OFF}
+  {$warn SYMBOL_DEPRECATED OFF}   // for faVolumeID
+  {$warn UNIT_PLATFORM OFF}
+
+  {$if CompilerVersion >= 17}     // = Delphi 2005
+    {$define ISDELPHI2005ANDUP}
+    {$if CompilerVersion >= 18}
+      {$define ISDELPHI2006ANDUP} // = Delphi 2006
+      {$define HASNEWFILEAGE}
+      {$define HASINLINE}
+      {$define HASINLINEDELPHI}
+      {$define HASREGION}
+      {$define HASFASTMM4}
+      // you can define this so that GetMemoryInfo/TSynMonitorMemory returns
+      // low-level FastMM4 information
+      {.$define WITH_FASTMM4STATS}
+    {$ifend}
+    {$ifdef VER180}               // = Delphi 2006
+      {$define ISDELPHI20062007}  // to circumvent some specific bugs
+    {$endif}
+    {$ifdef VER185}               // = Delphi 2007
+      {$define ISDELPHI20062007}
+    {$endif}
+    {$if CompilerVersion > 18}
+      {$define ISDELPHI2007ANDUP} // = Delphi 2007 or newer
+      {$define HASITERATORS}
+      {$define HASDBFTWIDE}
+    {$ifend}
+    {$if CompilerVersion = 20}    // = Delphi 2009
+      {$define ISDELPHI2009}      // to circumvent some specific bugs
+      {$define ISDELPHI20092010}
+      {$define HASNOSTATICRTTI}   // has no TypeInfo(TGuid)
+    {$ifend}
+    {$if CompilerVersion = 21}    // = Delphi 2010
+      {$define ISDELPHI20092010}  // to circumvent some specific bugs
+    {$ifend}
+    {$if CompilerVersion >= 21.0}
+      {$define HASSAFEINLINE}     // Delphi 2007-2009 have troubles inlining :(
+      {$define ISDELPHI2010}
+      {$define HASDYNARRAYTYPE}   // eltype2 field, used e.g. for T*ObjArray
+      {$define HASEXTRECORDRTTI}
+      {$define HASIMPLICITOPERATOR}  // Delphi 2010+ "implicit operator" is ok
+      {$define ISDELPHI2010_OR_FPC_NEWRTTI}
+      {$define HASTTHREADSTART}
+      {$define HASINTERFACEASTOBJECT}
+      {$ifdef NEWRTTINOTUSED}     // to reduce EXE size by disabling some RTTI
+        {$WEAKLINKRTTI ON}
+        {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])}
+      {$endif NEWRTTINOTUSED}
+    {$ifend}
+    {$if CompilerVersion >= 22.0} // = Delphi XE
+      {$define FPC_OR_DELPHIXE}   // Delphi 2007/2009/2010 inlining bugs
+      {$define ISDELPHIXE}
+      {$define HASGENERICS}       // somewhat unusable generics (?)
+      {$define ORMGENERICS}
+    {$ifend}
+    {$if CompilerVersion >= 23.0} // = Delphi XE2
+      {$define ISDELPHIXE2}
+      // Delphi XE2 has some cross-platform features
+      // e.g. {$ifdef NEEDVCLPREFIX}VCL.Graphics{$else}Graphics{$endif}
+      {$define NEEDVCLPREFIX}
+      {$define HASVARUSTRARG}
+      {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet
+    {$ifend}
+    {$if CompilerVersion >= 24.0} // = Delphi XE3
+      {$define ISDELPHIXE3}
+    {$ifend}
+    {$if CompilerVersion >= 25.0} // = Delphi XE4
+      {$define ISDELPHIXE4}
+      {$define FPC_OR_DELPHIXE4}  // circumvent Internal Error: C2130 on XE3
+      {$define HASAESNI}
+      {$define HASALIGN}          // .align ### inline assembler directive
+    {$ifend}
+    {$if CompilerVersion >= 26.0} // = Delphi XE5
+      {$define ISDELPHIXE5}
+      {$define PUBLISHRECORD}
+      // if defined, will handle RTTI available only since Delphi XE5 for
+      // record published properties
+    {$ifend}
+    {$if CompilerVersion >= 27.0} // = Delphi XE6
+      {$define ISDELPHIXE6}
+    {$ifend}
+    {$if (CompilerVersion = 27.0) or
+         (CompilerVersion = 28.0)} // = Delphi XE6 or XE7
+      // avoid internal error G2515 or F2084 AV0044FF4E-R00000008-0
+      {$undef HASGENERICS}
+      {$undef ORMGENERICS}
+    {$ifend}
+    {$if CompilerVersion >= 28.0}
+      {$define ISDELPHIXE7}
+      {$ifdef CPU64}
+        {$define CPUX64ASM}       // e.g. XE4 SSE asm is buggy :(
+      {$endif CPU64}
+    {$ifend}
+    {$if CompilerVersion >= 29.0} // = Delphi XE8
+      {$define ISDELPHIXE8}
+      {$define HASGETTYPEKIND}    // generics intrinsics are buggy before XE8
+    {$ifend}
+    {$if CompilerVersion >= 30.0} // = Delphi 10
+      {$define ISDELPHI10}
+    {$ifend}
+    {$if CompilerVersion >= 31.0} // = Delphi 10.1
+      {$define ISDELPHI101}
+    {$ifend}
+    {$if CompilerVersion >= 32.0} // = Delphi 10.2
+      {$define ISDELPHI102}
+      {$ifdef CPUX64}
+      {$ifdef VER320withoutAprilUpdate}
+        // circumvent early Delphi 10.2 Tokyo Win64 compiler bug
+        {$undef HASINLINE}
+      {$endif}
+      {$endif}
+    {$ifend}
+    {$if CompilerVersion >= 33.0} // = Delphi 10.3
+      {$define ISDELPHI103}
+    {$ifend}
+    {$if CompilerVersion >= 34.0} // = Delphi 10.4
+      {$define ISDELPHI104}
+    {$ifend}
+    {$if CompilerVersion >= 35.0} // = Delphi 11.x Alexandria
+      {$define ISDELPHI11}
+      {$ifdef CPU64}
+        {.$define ASMX64AVX}      // initial AVX/AVX2/AVX512 support - but broken
+        {$define ASMX64AVXNOCONST} // supports AVX with no align32 constant load
+      {$endif CPU64}
+    {$ifend}
+    {$if CompilerVersion >= 36.0} // = Delphi 12 Athens
+      {$define ISDELPHI12}
+    {$ifend}
+    {$if CompilerVersion >= 37.0} // = Delphi 13 Next
+      {$define ISDELPHI13}
+    {$ifend}
+  {$else}
+     {$define ISDELPHI7}
+  {$ifend CompilerVersion >= 17}
+
+{$endif FPC}
+
+
+(********************** Shared Conditionals **********************)
+
+// -----------
+// -- about pascal code expectations
+
+  {$H+} // we use long strings
+  {$R-} // disable Range checking in our code
+  {$S-} // disable Stack checking in our code
+  {$X+} // expect extended syntax
+  {$W-} // disable stack frame generation
+  {$Q-} // disable overflow checking in our code
+  {$B-} // expect short circuit boolean
+  {$V-} // disable Var-String Checking
+  {$T-} // Typed @ operator
+  {$Z1} // enumerators stored as byte by default
+  {$P+} // Open string params
+
+  {$ifdef DEBUG}
+    {$assertions on} // assert() may be disabled, e.g. on FPC
+  {$endif DEBUG}
+
+
+// -----------
+// -- CPU specific conditionals
+
+{$ifdef CPUINTEL}
+  {$ifdef OSWINDOWS}
+    {$ifdef CPUX64}
+      {$define WIN64ABI}    // for asm on x86_64
+      {$define OSWINDOWS64} // Win64
+    {$else}
+      {$define OSWINDOWS32} // Win32
+    {$endif CPUX64}
+    {$define THREADID32}    // TThreadID = 32-bit DWORD on Win32 and Win64
+  {$endif OSWINDOWS}
+  {$ifdef OSPOSIX}
+    {$ifdef CPUX64}
+      {$define SYSVABI}     // for asm on x86_64
+    {$else}
+      {$define THREADID32}  // TThreadID = PtrUInt/pointer on pthread
+    {$endif CPUX64}
+  {$endif OSPOSIX}
+  {$define CPUINTELARM}
+{$else}
+  {$undef HASAESNI}         // AES-NI is an Intel-specific feature
+  {$ifdef CPUARM3264}
+    {$define CPUINTELARM}
+  {$endif CPUARM3264}
+  {$ifdef CPU32}
+    {$define THREADID32}    // TThreadID = PtrUInt/pointer on pthread
+  {$endif CPU32}
+{$endif CPUINTEL}
+
+{$ifdef CPU32}
+  {$define NOPOINTEROFFSET} // 32-bit CPU will always store pointers
+{$endif CPU32}
+
+
+  // -----------
+  // -- Libraries linking
+
+  // some static linked files are to be downloaded from
+  // https://github.com/synopse/mORMot2/releases
+
+{$ifdef FPC}
+  // Delphi doesn't accept GCC object files and libdeflate requires GCC
+  {$if defined(OSOPENBSD) and defined(FPC_CROSSCOMPILING)}
+    {$define NOSQLITE3STATIC} // OpenBSD problems with fpcupdeluxe libgcc.a
+  {$ifend}
+  {$define LIZARD_EXTERNALONLY}     // Lizard is disabled but on some targets
+  {$ifdef OSLINUX}
+    {$ifdef CPUINTEL}
+      {$define LIBDEFLATESTATIC}    // libdeflate static binding
+      {$define LIBQUICKJSSTATIC}    // quickjs static binding
+      {$undef LIZARD_EXTERNALONLY}  // static liblizard.a
+    {$endif CPUINTEL}
+    {$ifdef CPUARM}
+      {.$undef LIZARD_EXTERNALONLY} // static liblizard.a is not tested
+      {.$define LIBDEFLATESTATIC}   // compiles, but untested
+      {.$define LIBQUICKJSSTATIC}   // compiles, but untested
+    {$endif CPUARM}
+    {$ifdef CPUAARCH64}
+      {$define LIBDEFLATESTATIC}
+      {$undef LIZARD_EXTERNALONLY}  // static liblizard.a seems OK
+      {.$define LIBQUICKJSSTATIC}   // compiles, but access violations
+    {$endif CPUAARCH64}
+  {$endif OSLINUX}
+  {$ifdef OSWINDOWS}
+    {$undef LIZARD_EXTERNALONLY}    // static liblizard.a
+    {$ifdef CPUX86}
+      {$define LIBDEFLATESTATIC}
+      {$define LIBQUICKJSSTATIC}
+    {$endif CPUX86}
+    {$ifdef CPUX64}
+      {.$define LIBDEFLATESTATIC}   // Win64 + FPC 3.2 = internal error 200603061
+      {$define LIBQUICKJSSTATIC}
+    {$endif CPUX64}
+  {$endif OSWINDOWS}
+  {$ifdef CPUARM3264}
+    {$ifdef OSDARWIN}               // unsupported arch (e.g. Aarch64-Darwin)
+      {$define OSDARWINARM}
+      {$define LIZARD_EXTERNALONLY}
+      {$define NOLIBCSTATIC}
+    {$endif OSDWARWIN}
+  {$endif CPUARM3264}
+{$else}
+  {$define LIZARD_EXTERNALONLY}     // no static .obj for Delphi Win32/Win64 yet
+  {$ifdef CPUX86}
+    {$define LIBQUICKJSSTATIC}      // our quickjs.obj seems fine on Win32 :)
+  {$endif CPUX86}
+  // there is a linking bug with Delphi XE4 on Win64
+  {$ifdef CPUX64}
+    {$if (CompilerVersion = 25.0) or
+         (CompilerVersion = 28.0) or 
+         (CompilerVersion = 29.0)}  // exactly XE4, XE7 or XE8 are known to GPF
+      // other Win32/Win64 Delphi platforms "should work" (tm) as expected
+      {$define NOSQLITE3STATIC}
+    {$ifend}
+    {$define LIBQUICKJSSTATIC}      // seems fine BUT on Delphi 10.4+ Win64
+    {$if CompilerVersion >= 34.0}    // = Delphi 10.4 and later
+      {$undef LIBQUICKJSSTATIC}
+    {$ifend}
+  {$endif}
+{$endif FPC}
+
+{$ifdef OSWINDOWS}
+  // on Windows: enable Microsoft AES Cryptographic Provider (XP SP3 and up)
+  // - even if those AES engines are slower and closed source (so should better
+  // be avoided), we use it for TAesPrng.GetEntropy, as it can't hurt
+  {$define USE_PROV_RSA_AES}
+  // define at your own risk, if you have the good libraries ;)
+  {.$define USE_OPENSSL}
+{$else}
+  {$ifndef OSANDROID}
+    // try OpenSSL on POSIX systems where likely to be unique and maintained
+    {$define USE_OPENSSL}
+  {$endif OSANDROID}
+{$endif OSWINDOWS}
+{$ifdef FORCE_OPENSSL}
+  {$define USE_OPENSSL} // if you think you are a lucky enough guy
+{$endif FORCE_OPENSSL}
+
+
+// -----------
+// -- Per-platform Client-Server abilities
+
+{$ifdef OSWINDOWS}
+
+  {$ifndef ONLYUSEHTTPSOCKET}
+    {$define USEWININET}      // publish TWinINet/TWinHttp/TWinHttpAPI classes
+    {$define USEHTTPSYS}      // enable http.sys kernel-mode Web server
+  {$endif ONLYUSEHTTPSOCKET}
+
+  {$define USE_WINIOCP}     // I/O completion ports API is fine under Windows
+  // (as used by mormot.core.threads and mormot.net.async)
+  // (under Linux/POSIX, we fallback to a classical event-driven pool)
+
+  {$ifndef NOSSPIAUTH}        // from mormot.lib.sspi
+    {$define DOMAINRESTAUTH}  // enable SSPI in mormot.rest.client/server
+  {$endif NOSSPIAUTH}
+
+{$endif OSWINDOWS}
+
+{$ifdef OSPOSIX}
+
+  {$define ONLYUSEHTTPSOCKET} // efficient cross-platform Socket + OpenSSL API
+  {$undef USE_WINIOCP}        // disable any Windows-specific code
+
+  {$ifdef OSANDROID}
+
+    // for Android, consider using https://github.com/gcesarmza/curl-android-ios
+    // static libraries and force USELIBCURL in the project conditionals
+    {$define LIBCURLSTATIC}
+
+  {$else}
+
+    {$ifndef USE_OPENSSL}       // if OpenSSL is not available on this platform
+      {$define USELIBCURL}      // try cross-platform libcurl for https
+    {$endif USE_OPENSSL}
+
+    {$ifndef NOGSSAPIAUTH}      // mormot.lib.gssapi is not Android compatible
+      {$define DOMAINRESTAUTH}  // enable libgss in mormot.rest.client/server
+    {$endif NOGSSAPIAUTH}
+
+  {$endif OSANDROID}
+
+{$endif OSPOSIX}
+
+
diff --git a/samples/htmx/HTMX_Sample.dproj b/samples/htmx/HTMX_Sample.dproj
index 1a34d0ac..d7fdfcad 100644
--- a/samples/htmx/HTMX_Sample.dproj
+++ b/samples/htmx/HTMX_Sample.dproj
@@ -9,15 +9,11 @@
         2
         Console
         HTMX_Sample.dpr
+        HTMX_Sample
     
     
         true
     
-    
-        true
-        Base
-        true
-    
     
         true
         Base
@@ -68,9 +64,6 @@
         5129
         CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=
     
-    
-        DataSnapServer;fmx;emshosting;DbxCommonDriver;bindengine;FireDACCommonODBC;emsclient;FireDACCommonDriver;IndyProtocols;dbxcds;emsedge;inetdb;FireDACSqliteDriver;DbxClientDriver;FireDACASADriver;soapmidas;dbexpress;FireDACInfxDriver;inet;DataSnapCommon;dbrtl;FireDACOracleDriver;CustomIPTransport;FireDACMSSQLDriver;DataSnapIndy10ServerTransport;DataSnapConnectors;FireDACMongoDBDriver;IndySystem;FireDACTDataDriver;bindcomp;FireDACCommon;DataSnapServerMidas;FireDACODBCDriver;emsserverresource;IndyCore;RESTBackendComponents;rtl;FireDACMySQLDriver;FireDACADSDriver;RESTComponents;dsnapxml;DataSnapClient;DataSnapFireDAC;emsclientfiredac;FireDACPgDriver;FireDAC;xmlrtl;dsnap;CloudService;FireDACDb2Driver;DataSnapNativeClient;DatasnapConnectorsFreePascal;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage)
-    
     
         vclwinx;DataSnapServer;fmx;emshosting;vclie;DbxCommonDriver;bindengine;IndyIPCommon;VCLRESTComponents;DBXMSSQLDriver;FireDACCommonODBC;emsclient;FireDACCommonDriver;appanalytics;IndyProtocols;vclx;IndyIPClient;dbxcds;vcledge;bindcompvclwinx;emsedge;bindcompfmx;DBXFirebirdDriver;inetdb;ibmonitor;FireDACSqliteDriver;DbxClientDriver;FireDACASADriver;soapmidas;vclactnband;fmxFireDAC;dbexpress;FireDACInfxDriver;DBXMySQLDriver;VclSmp;inet;DataSnapCommon;EurekaLogCore;vcltouch;fmxase;DBXOdbcDriver;dbrtl;FireDACDBXDriver;FireDACOracleDriver;fmxdae;FireDACMSAccDriver;CustomIPTransport;FireDACMSSQLDriver;DataSnapIndy10ServerTransport;DataSnapConnectors;vcldsnap;DBXInterBaseDriver;OmniThreadLibraryRuntime;FireDACMongoDBDriver;IndySystem;BossExperts;FireDACTDataDriver;vcldb;ibxbindings;ADOCluster_RT;vclFireDAC;bindcomp;FireDACCommon;DataSnapServerMidas;FireDACODBCDriver;emsserverresource;IndyCore;RESTBackendComponents;dmvcframeworkDT;bindcompdbx;rtl;FireDACMySQLDriver;FireDACADSDriver;RESTComponents;DBXSqliteDriver;vcl;IndyIPServer;dsnapxml;dsnapcon;DataSnapClient;DataSnapProviderClient;adortl;DBXSybaseASEDriver;DBXDb2Driver;vclimg;DataSnapFireDAC;emsclientfiredac;FireDACPgDriver;FireDAC;FireDACDSDriver;inetdbxpress;xmlrtl;tethering;ibxpress;bindcompvcl;dsnap;CloudService;DBXSybaseASADriver;DBXOracleDriver;FireDACDb2Driver;DBXInformixDriver;vclib;fmxobj;bindcompvclsmp;DataSnapNativeClient;DatasnapConnectorsFreePascal;soaprtl;soapserver;FireDACIBDriver;$(DCC_UsePackage)
         Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)
@@ -104,8 +97,8 @@
         none
         true
         true
-        4
-        CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.4;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=
+        5
+        CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.5;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=
     
     
         false
@@ -778,6 +771,9 @@
                     
                         1
                     
+                    
+                        1
+                    
                 
                 
                     
@@ -1038,9 +1034,9 @@
                 
                 
                 
+                
             
             
-                False
                 False
                 True
             
diff --git a/samples/htmx_mustache/htmx_mustache.dpr b/samples/htmx_mustache/htmx_mustache.dpr
index 374ff270..2af16b9a 100644
--- a/samples/htmx_mustache/htmx_mustache.dpr
+++ b/samples/htmx_mustache/htmx_mustache.dpr
@@ -65,22 +65,6 @@ begin
   try
     if WebRequestHandler <> nil then
       WebRequestHandler.WebModuleClass := WebModuleClass;
-
-    dotEnvConfigure(
-      function: IMVCDotEnv
-      begin
-        Result := NewDotEnv
-                 .UseStrategy(TMVCDotEnvPriority.FileThenEnv)
-                                       //if available, by default, loads default environment (.env)
-                 .UseProfile('test') //if available loads the test environment (.env.test)
-                 .UseProfile('prod') //if available loads the prod environment (.env.prod)
-                 .UseLogger(procedure(LogItem: String)
-                            begin
-                              LogW('dotEnv: ' + LogItem);
-                            end)
-                 .Build();             //uses the executable folder to look for .env* files
-      end);
-
     WebRequestHandlerProc.MaxConnections := dotEnv.Env('dmvc.handler.max_connections', 1024);
     RunServer(dotEnv.Env('dmvc.server.port', 8080));
   except
diff --git a/samples/htmx_mustache/htmx_mustache.dproj b/samples/htmx_mustache/htmx_mustache.dproj
index 47fbca38..95762ff8 100644
--- a/samples/htmx_mustache/htmx_mustache.dproj
+++ b/samples/htmx_mustache/htmx_mustache.dproj
@@ -9,6 +9,7 @@
         Win32
         1
         Console
+        htmx_mustache
     
     
         true
@@ -73,8 +74,9 @@
     
     
         1033
-        None
         false
+        CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName)
+        none
     
     
         false
@@ -118,9 +120,10 @@
                     htmx_mustache.dpr
                 
                 
-                    Embarcadero C++Builder Office 2000 Servers Package
-                    Embarcadero C++Builder Office XP Servers Package
-                    Microsoft Office 2000 Sample Automation Server Wrapper Components
+                    Microsoft Office 2000 Sample Automation Server Wrapper Components
+                    Microsoft Office XP Sample Automation Server Wrapper Components
+                    Embarcadero C++Builder Office 2000 Servers Package
+                    Embarcadero C++Builder Office XP Servers Package
                 
             
             
@@ -724,6 +727,9 @@
                     
                         1
                     
+                    
+                        1
+                    
                 
                 
                     
@@ -985,6 +991,7 @@
                 
                 
                 
+                
             
             
                 True
diff --git a/samples/serversideviews_mustache/CustomMustacheHelpersU.pas b/samples/serversideviews_mustache/CustomMustacheHelpersU.pas
index 01abd584..ac14846b 100644
--- a/samples/serversideviews_mustache/CustomMustacheHelpersU.pas
+++ b/samples/serversideviews_mustache/CustomMustacheHelpersU.pas
@@ -27,7 +27,7 @@ unit CustomMustacheHelpersU;
 interface
 
 uses
-  SynMustache;
+  mormot.core.mustache;
 
 type
   TMyMustacheHelpers = class sealed
diff --git a/samples/serversideviews_mustache/ServerSideViewsMustache.dpr b/samples/serversideviews_mustache/ServerSideViewsMustache.dpr
index a2b43355..76f73251 100644
--- a/samples/serversideviews_mustache/ServerSideViewsMustache.dpr
+++ b/samples/serversideviews_mustache/ServerSideViewsMustache.dpr
@@ -19,8 +19,8 @@ uses
   DAL in 'DAL.pas',
   MyDataModuleU in '..\renders\MyDataModuleU.pas' {MyDataModule: TDataModule},
   CustomMustacheHelpersU in 'CustomMustacheHelpersU.pas',
-  SynMustache,
-  MVCFramework.Serializer.URLEncoded in '..\..\sources\MVCFramework.Serializer.URLEncoded.pas';
+  MVCFramework.Serializer.URLEncoded in '..\..\sources\MVCFramework.Serializer.URLEncoded.pas',
+  mormot.core.mustache;
 
 {$R *.res}
 
diff --git a/samples/serversideviews_mustache/ServerSideViewsMustache.dproj b/samples/serversideviews_mustache/ServerSideViewsMustache.dproj
index 5e973554..ce561b48 100644
--- a/samples/serversideviews_mustache/ServerSideViewsMustache.dproj
+++ b/samples/serversideviews_mustache/ServerSideViewsMustache.dproj
@@ -9,6 +9,7 @@
         Win32
         1
         Console
+        ServerSideViewsMustache
     
     
         true
@@ -725,6 +726,9 @@
                     
                         1
                     
+                    
+                        1
+                    
                 
                 
                     
@@ -986,6 +990,7 @@
                 
                 
                 
+                
             
             
                 True
diff --git a/samples/serversideviews_mustache/WebModuleU.pas b/samples/serversideviews_mustache/WebModuleU.pas
index d1fece5a..48c9d42a 100644
--- a/samples/serversideviews_mustache/WebModuleU.pas
+++ b/samples/serversideviews_mustache/WebModuleU.pas
@@ -28,7 +28,8 @@ uses
   WebSiteControllerU,
   System.IOUtils,
   MVCFramework.Commons,
-  MVCFramework.Middleware.StaticFiles, SynMustache, CustomMustacheHelpersU,
+  MVCFramework.Middleware.StaticFiles,
+  CustomMustacheHelpersU,
   MVCFramework.Serializer.URLEncoded;
 
 { %CLASSGROUP 'Vcl.Controls.TControl' }
diff --git a/sources/MVCFramework.ActiveRecord.pas b/sources/MVCFramework.ActiveRecord.pas
index 0c166d3b..97e898cd 100644
--- a/sources/MVCFramework.ActiveRecord.pas
+++ b/sources/MVCFramework.ActiveRecord.pas
@@ -1373,7 +1373,7 @@ begin
       for lPair in fTableMap.fMap do
       begin
         lPar := lQry.FindParam(SQLGenerator.GetParamNameForSQL(lPair.Value.FieldName));
-        if (lPar <> nil) and lpair.Value.Writeable then
+        if (lPar <> nil) and (lpair.Value.Insertable or lpair.Value.Updatable) then
         begin
           lValue := lPair.Key.GetValue(Self);
           lPar.DataTypeName := fTableMap.fMap.GetInfoByFieldName(lPair.Value.FieldName).DataTypeName;
diff --git a/sources/MVCFramework.Middleware.JWT.pas b/sources/MVCFramework.Middleware.JWT.pas
index 5f2b85a6..c75489fd 100644
--- a/sources/MVCFramework.Middleware.JWT.pas
+++ b/sources/MVCFramework.Middleware.JWT.pas
@@ -296,7 +296,7 @@ var
   AuthAccessToken: string;
   AuthToken: string;
   ErrorMsg: string;
-  cookieToken: string;
+  CookieToken: string;
 begin
   // check if the resource is protected
   if Assigned(FAuthenticationHandler) then
@@ -377,10 +377,10 @@ begin
       begin
         if FUseHttpOnly then
         begin
-          cookieToken := AContext.Request.Cookie('token');
-          if (not cookieToken.IsEmpty) then
+          CookieToken := AContext.Request.Cookie('token');
+          if (not CookieToken.IsEmpty) then
           begin
-            AuthToken := cookieToken.Trim;
+            AuthToken := CookieToken.Trim;
             AuthToken := Trim(TNetEncoding.URL.Decode(AuthToken));
           end;
         end;
diff --git a/sources/MVCFramework.View.Renderers.Mustache.pas b/sources/MVCFramework.View.Renderers.Mustache.pas
index 147e2aec..c2d54b8f 100644
--- a/sources/MVCFramework.View.Renderers.Mustache.pas
+++ b/sources/MVCFramework.View.Renderers.Mustache.pas
@@ -32,7 +32,8 @@ interface
 uses
   MVCFramework, System.SysUtils, System.Generics.Collections,
   MVCFramework.Commons, System.IOUtils, System.RTTI,
-  System.Classes, Data.DB, SynMustache, SynCommons, MVCFramework.IntfObjectPool;
+  System.Classes, Data.DB, MVCFramework.IntfObjectPool,
+  mormot.core.mustache, mormot.core.unicode;
 
 type
   { This class implements the mustache view engine for server side views }
@@ -48,8 +49,8 @@ type
     procedure LoadPartials;
     procedure LoadHelpers;
   protected
-    function RenderJSON(lViewEngine: TSynMustache; const JSON: RawUTF8; Partials: TSynMustachePartials;
-      Helpers: TSynMustacheHelpers; OnTranslate: TOnStringTranslate; EscapeInvert: boolean): RawUTF8; virtual;
+    function RenderJSON(lViewEngine: TSynMustache; const JSON: UTF8String; Partials: TSynMustachePartials;
+      Helpers: TSynMustacheHelpers; OnTranslate: TOnStringTranslate; EscapeInvert: boolean): UTF8String; virtual;
   public
     procedure Execute(const ViewName: string; const OutputStream: TStream); override;
     constructor Create(const AEngine: TMVCEngine; const AWebContext: TWebContext;
@@ -124,8 +125,8 @@ begin
   fPartials.Free;
 end;
 
-function TMVCMustacheViewEngine.RenderJSON(lViewEngine: TSynMustache; const JSON: RawUTF8; Partials: TSynMustachePartials;
-  Helpers: TSynMustacheHelpers; OnTranslate: TOnStringTranslate; EscapeInvert: boolean): RawUTF8;
+function TMVCMustacheViewEngine.RenderJSON(lViewEngine: TSynMustache; const JSON: UTF8String; Partials: TSynMustachePartials;
+  Helpers: TSynMustacheHelpers; OnTranslate: TOnStringTranslate; EscapeInvert: boolean): UTF8String;
 begin
   Result := lViewEngine.RenderJSON(JSON, Partials, Helpers, OnTranslate, EscapeInvert);
 end;
@@ -133,7 +134,7 @@ end;
 procedure TMVCMustacheViewEngine.Execute(const ViewName: string; const OutputStream: TStream);
 var
   lViewFileName: string;
-  lViewTemplate: RawUTF8;
+  lViewTemplate: UTF8String;
   lViewEngine: TSynMustache;
   lSW: TStreamWriter;
 begin